ghcup-hs/app/ghcup/BrickMain.hs

1047 lines
41 KiB
Haskell
Raw Normal View History

{-# LANGUAGE CPP #-}
2020-07-06 20:39:16 +00:00
{-# LANGUAGE DataKinds #-}
2020-10-11 19:07:13 +00:00
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
2021-05-14 21:09:45 +00:00
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-}
2023-11-05 14:28:23 +00:00
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
{-# OPTIONS_GHC -Wno-unused-matches #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
2023-11-05 18:24:57 +00:00
{-# LANGUAGE BangPatterns #-}
2024-01-22 14:27:13 +00:00
{-# LANGUAGE ViewPatterns #-}
2020-07-06 20:39:16 +00:00
module BrickMain where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Types.Optics ( getDirs, getPlatformReq )
2021-07-18 21:29:09 +00:00
import GHCup.Types hiding ( LeanAppState(..) )
2020-07-06 20:39:16 +00:00
import GHCup.Utils
2022-12-20 13:28:49 +00:00
import GHCup.OptParse.Common (logGHCPostRm)
2022-05-21 20:54:18 +00:00
import GHCup.Prelude ( decUTF8Safe )
import GHCup.Prelude.Logger
import GHCup.Prelude.Process
import GHCup.Prompts
2020-07-06 20:39:16 +00:00
import Brick
2023-10-08 15:11:32 +00:00
( BrickEvent(VtyEvent, MouseDown),
App(..),
Padding(Max, Pad),
AttrMap,
EventM,
2023-10-08 15:11:32 +00:00
Size(..),
Widget(..),
ViewportType (Vertical),
(<+>),
(<=>))
import qualified Brick
import Brick.Widgets.Border ( hBorder, borderWithLabel)
import Brick.Widgets.Border.Style ( unicode )
import Brick.Widgets.Center ( center, centerLayer )
import qualified Brick.Widgets.List as L
import Brick.Focus (FocusRing)
import qualified Brick.Focus as F
import Control.Applicative
2020-07-06 20:39:16 +00:00
import Control.Exception.Safe
2021-11-02 18:53:22 +00:00
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
2020-07-06 20:39:16 +00:00
import Control.Monad.Reader
2021-05-14 21:09:45 +00:00
import Control.Monad.Trans.Except
2020-07-06 20:39:16 +00:00
import Control.Monad.Trans.Resource
import Data.Bool
import Data.Functor
2023-10-08 15:11:32 +00:00
import Data.Function ( (&), on)
2020-07-06 20:39:16 +00:00
import Data.List
import Data.Maybe
import Data.IORef (IORef, readIORef, newIORef, writeIORef, modifyIORef)
2020-10-11 19:07:13 +00:00
import Data.Vector ( Vector
2023-10-08 15:11:32 +00:00
2020-10-11 19:07:13 +00:00
)
2023-11-05 18:24:57 +00:00
import Data.Versions hiding (Lens')
2020-07-06 20:39:16 +00:00
import Haskus.Utils.Variant.Excepts
import Prelude hiding ( appendFile )
import System.Exit
import System.IO.Unsafe
2023-11-20 14:36:17 +00:00
import System.Process ( system )
import Text.PrettyPrint.HughesPJClass ( prettyShow )
2020-07-06 20:39:16 +00:00
import URI.ByteString
import qualified Data.Text as T
import qualified Data.Text.Lazy.Builder as B
import qualified Data.Text.Lazy as L
2020-07-06 20:39:16 +00:00
import qualified Graphics.Vty as Vty
import qualified Data.Vector as V
import System.Environment (getExecutablePath)
2023-11-05 10:00:23 +00:00
#if !IS_WINDOWS
2023-11-05 14:28:23 +00:00
import GHCup.Prelude.File
import System.FilePath
import qualified System.Posix.Process as SPP
2023-11-05 10:00:23 +00:00
#endif
2020-07-06 20:39:16 +00:00
import Optics.TH (makeLenses, makeLensesFor)
import Optics.State (use)
import Optics.State.Operators ( (.=), (%=), (<%=))
2023-10-08 15:11:32 +00:00
import Optics.Operators ((.~), (^.), (%~))
import Optics.Getter (view)
2023-10-08 15:11:32 +00:00
import Optics.Lens (Lens', lens, toLensVL)
{- Brick's widget:
It is a FocusRing over many list's. Each list contains the information for each tool. Each list has an internal name (for Brick's runtime)
and a label which we can use in rendering. This data-structure helps to reuse Brick.Widget.List and to navegate easily across
Consider this code as private. GenericSectionList should not be used directly as the FocusRing should be align with the Vector containing
the elements, otherwise you'd be focusing on a non-existent widget with unknown result (In theory the code is safe unless you have an empty section list).
- To build a SectionList use the safe constructor sectionList
- To access sections use the lens provider sectionL and the name of the section you'd like to access
- You can modify Brick.Widget.List.GenericList within GenericSectionList via sectionL but do not
modify the vector length
-}
data GenericSectionList n t e
= GenericSectionList
{ sectionListFocusRing :: FocusRing n -- ^ The FocusRing for all sections
, sectionListElements :: !(Vector (L.GenericList n t e)) -- ^ A key-value vector
, sectionListName :: n -- ^ The section list name
}
makeLensesFor [("sectionListFocusRing", "sectionListFocusRingL"), ("sectionListElements", "sectionListElementsL"), ("sectionListName", "sectionListNameL")] ''GenericSectionList
type SectionList n e = GenericSectionList n V.Vector e
-- | Build a SectionList from nonempty list. If empty we could not defined sectionL lenses.
sectionList :: Foldable t
=> n -- The name of the section list
-> [(n, t e)] -- a list of tuples (section name, collection of elements)
-> Int
-> GenericSectionList n t e
sectionList name elements height
= GenericSectionList
{ sectionListFocusRing = F.focusRing [section_name | (section_name, _) <- elements]
, sectionListElements = V.fromList [L.list section_name els height | (section_name, els) <- elements]
, sectionListName = name
}
-- | This lens constructor, takes a name and looks if a section has such a name.
-- Used to dispatch events to sections. It is a partial function only meant to
-- be used with the FocusRing inside GenericSectionList
sectionL :: Eq n => n -> Lens' (GenericSectionList n t e) (L.GenericList n t e)
sectionL section_name = lens g s
where is_section_name = (== section_name) . L.listName
g section_list =
let elms = section_list ^. sectionListElementsL
zeroth = elms V.! 0 -- TODO: This crashes for empty vectors.
in fromMaybe zeroth (V.find is_section_name elms)
s gl@(GenericSectionList _ elms _) list =
case V.findIndex is_section_name elms of
Nothing -> gl
Just i -> let new_elms = V.update elms (V.fromList [(i, list)])
in gl & sectionListElementsL .~ new_elms
2023-10-08 15:11:32 +00:00
moveDown :: (L.Splittable t, Ord n, Foldable t) => EventM n (GenericSectionList n t e) ()
moveDown = do
ring <- use sectionListFocusRingL
case F.focusGetCurrent ring of
Nothing -> pure ()
Just l -> do -- If it is the last element, move to the first element of the next focus; else, just handle regular list event.
current_list <- use (sectionL l)
let current_idx = L.listSelected current_list
list_length = current_list & length
if current_idx == Just (list_length - 1)
then do
new_focus <- sectionListFocusRingL <%= F.focusNext
case F.focusGetCurrent new_focus of
Nothing -> pure () -- |- Optic.Zoom.zoom doesn't typecheck but Lens.Micro.Mtl.zoom does. It is re-exported by Brick
2023-10-08 15:11:32 +00:00
Just new_l -> Brick.zoom (toLensVL $ sectionL new_l) (Brick.modify L.listMoveToBeginning)
else Brick.zoom (toLensVL $ sectionL l) $ Brick.modify L.listMoveDown
moveUp :: (L.Splittable t, Ord n, Foldable t) => EventM n (GenericSectionList n t e) ()
moveUp = do
ring <- use sectionListFocusRingL
case F.focusGetCurrent ring of
Nothing -> pure ()
Just l -> do -- If it is the first element, move to the last element of the prev focus; else, just handle regular list event.
current_list <- use (sectionL l)
let current_idx = L.listSelected current_list
if current_idx == Just 0
then do
new_focus <- sectionListFocusRingL <%= F.focusPrev
case F.focusGetCurrent new_focus of
Nothing -> pure ()
2023-10-08 15:11:32 +00:00
Just new_l -> Brick.zoom (toLensVL $ sectionL new_l) (Brick.modify L.listMoveToEnd)
else Brick.zoom (toLensVL $ sectionL l) $ Brick.modify L.listMoveUp
-- | Handle events for list cursor movement. Events handled are:
--
-- * Up (up arrow key). If first element of section, then jump prev section
-- * Down (down arrow key). If last element of section, then jump next section
-- * Page Up (PgUp)
-- * Page Down (PgDown)
-- * Go to next section (Tab)
-- * Go to prev section (BackTab)
handleGenericListEvent :: (Foldable t, L.Splittable t, Ord n)
=> BrickEvent n a
-> EventM n (GenericSectionList n t e) ()
handleGenericListEvent (VtyEvent (Vty.EvResize _ _)) = pure ()
handleGenericListEvent (VtyEvent (Vty.EvKey (Vty.KChar '\t') [])) = sectionListFocusRingL %= F.focusNext
handleGenericListEvent (VtyEvent (Vty.EvKey Vty.KBackTab [])) = sectionListFocusRingL %= F.focusPrev
handleGenericListEvent (MouseDown _ Vty.BScrollDown _ _) = moveDown
handleGenericListEvent (MouseDown _ Vty.BScrollUp _ _) = moveUp
handleGenericListEvent (VtyEvent (Vty.EvKey Vty.KDown [])) = moveDown
handleGenericListEvent (VtyEvent (Vty.EvKey Vty.KUp [])) = moveUp
handleGenericListEvent (VtyEvent ev) = do
ring <- use sectionListFocusRingL
case F.focusGetCurrent ring of
Nothing -> pure ()
2023-10-08 15:11:32 +00:00
Just l -> Brick.zoom (toLensVL $ sectionL l) $ L.handleListEvent ev
handleGenericListEvent _ = pure ()
-- This re-uses Brick.Widget.List.renderList
2024-01-22 14:27:13 +00:00
renderSectionList :: forall n t e . (Traversable t, Ord n, Show n, Eq n, L.Splittable t, Semigroup (t e))
2023-11-05 18:24:57 +00:00
=> (Bool -> e -> Widget n) -- ^ Rendering function of the list element, True for the selected element
-> Bool -- ^ Whether the section list has focus
-> GenericSectionList n t e -- ^ The section list to render
-> Widget n
2024-01-22 14:27:13 +00:00
renderSectionList renderElem sectionFocus ge@(GenericSectionList focus elms slName) =
Brick.Widget Brick.Greedy Brick.Greedy $ Brick.render $ Brick.viewport slName Brick.Vertical $
V.ifoldl' (\(!accWidget) !i list ->
let hasFocusList = sectionIsFocused list
makeVisible = if hasFocusList then Brick.visibleRegion (Brick.Location (c, r)) (1, 1) else id
appendBorder = if i == 0 then id else (hBorder <=>)
newWidget = appendBorder (makeVisible $ renderInnerList hasFocusList list)
in accWidget <=> newWidget
)
Brick.emptyWidget
elms
where
-- A section is focused if the whole thing is focused, and the inner list has focus
sectionIsFocused :: L.GenericList n t e -> Bool
sectionIsFocused l = sectionFocus && (Just (L.listName l) == F.focusGetCurrent focus)
renderInnerList :: Bool -> L.GenericList n t e -> Widget n
renderInnerList hasFocus l = Brick.vLimit (length l) $ L.renderList (\b -> renderElem (b && hasFocus)) hasFocus l
-- compute the location to focus on within the active section
(c, r) :: (Int, Int) = case sectionListSelectedElement ge of
Nothing -> (0, 0)
Just (selElIx, _) -> (0, selElIx)
-- | Equivalent to listSelectedElement
sectionListSelectedElement :: (Eq n, L.Splittable t, Traversable t, Semigroup (t e)) => GenericSectionList n t e -> Maybe (Int, e)
sectionListSelectedElement generic_section_list = do
current_focus <- generic_section_list ^. sectionListFocusRingL & F.focusGetCurrent
let current_section = generic_section_list ^. sectionL current_focus
L.listSelectedElement current_section
2023-11-18 09:55:16 +00:00
{- Brick app data structures.
In this section we define the state, the widgets and the core data structures which we will be using for the brick app.
-}
data Name = AllTools -- The main list widget
| Singular Tool -- The particular list for each tool
| KeyInfoBox -- The text box widget with action informacion
| TutorialBox -- The tutorial widget
deriving (Eq, Ord, Show)
data Mode = Navigation | KeyInfo | Tutorial deriving (Eq, Show, Ord)
2020-10-11 19:07:13 +00:00
2023-11-05 14:28:23 +00:00
installedSign :: String
#if IS_WINDOWS
installedSign = "I "
#else
installedSign = ""
#endif
setSign :: String
#if IS_WINDOWS
setSign = "IS"
#else
setSign = "✔✔"
#endif
notInstalledSign :: String
#if IS_WINDOWS
notInstalledSign = "X "
#else
notInstalledSign = ""
#endif
2020-10-11 19:07:13 +00:00
2020-10-23 23:06:53 +00:00
data BrickData = BrickData
{ _lr :: [ListResult]
2020-10-11 19:07:13 +00:00
}
deriving Show
makeLenses ''BrickData
data BrickSettings = BrickSettings { _showAllVersions :: Bool}
--deriving Show
makeLenses ''BrickSettings
2023-10-08 15:11:32 +00:00
type BrickInternalState = SectionList Name ListResult
2020-07-06 20:39:16 +00:00
2020-10-23 23:06:53 +00:00
data BrickState = BrickState
{ _appData :: BrickData
, _appSettings :: BrickSettings
, _appState :: BrickInternalState
, _appKeys :: KeyBindings
, _mode :: Mode
2020-10-11 19:07:13 +00:00
}
--deriving Show
2020-07-06 20:39:16 +00:00
makeLenses ''BrickState
2020-07-06 20:39:16 +00:00
2023-11-18 09:55:16 +00:00
app :: AttrMap -> AttrMap -> App BrickState () Name
app attrs dimAttrs =
App { appDraw = drawUI dimAttrs
, appHandleEvent = eventHandler
, appStartEvent = return ()
, appAttrMap = const attrs
, appChooseCursor = Brick.showFirstCursor
}
{- Drawing.
2023-11-18 09:55:16 +00:00
The section for creating our widgets.
2023-11-18 09:55:16 +00:00
-}
showKey :: Vty.Key -> String
showKey (Vty.KChar c) = [c]
2021-03-11 16:03:51 +00:00
showKey Vty.KUp = ""
showKey Vty.KDown = ""
showKey key = tail (show key)
2020-07-06 20:39:16 +00:00
showMod :: Vty.Modifier -> String
showMod = tail . show
2020-07-06 20:39:16 +00:00
2023-11-18 09:55:16 +00:00
drawNavigation :: AttrMap -> BrickState -> Widget Name
drawNavigation dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..}
2023-10-08 15:11:32 +00:00
= Brick.padBottom Max
( Brick.withBorderStyle unicode
$ borderWithLabel (Brick.str "GHCup")
2023-11-05 18:24:57 +00:00
(center (header <=> hBorder <=> renderList' _appState))
2020-07-06 20:39:16 +00:00
)
2020-09-20 21:06:35 +00:00
<=> footer
2020-07-06 20:39:16 +00:00
where
2020-09-20 21:06:35 +00:00
footer =
Brick.withAttr helpAttr
2023-10-08 15:11:32 +00:00
. Brick.txtWrap
2020-09-20 21:06:35 +00:00
. T.pack
. foldr1 (\x y -> x <> " " <> y)
. fmap (\(KeyCombination key mods, s, _) -> intercalate "+" (showKey key : (showMod <$> mods)) <> ":" <> s as)
$ keyHandlers _appKeys
2020-09-20 21:06:35 +00:00
header =
2023-10-08 15:11:32 +00:00
minHSize 2 Brick.emptyWidget
<+> Brick.padLeft (Pad 2) (minHSize 6 $ Brick.str "Tool")
<+> minHSize 15 (Brick.str "Version")
<+> Brick.padLeft (Pad 1) (minHSize 25 $ Brick.str "Tags")
<+> Brick.padLeft (Pad 5) (Brick.str "Notes")
renderList' bis =
let allElements = V.concatMap L.listElements $ sectionListElements bis
minTagSize = V.maximum $ V.map (length . intercalate "," . fmap tagToString . lTag) allElements
minVerSize = V.maximum $ V.map (\ListResult{..} -> T.length $ tVerToText (GHCTargetVersion lCross lVer)) allElements
2023-11-05 18:24:57 +00:00
in Brick.withDefAttr L.listAttr $ renderSectionList (renderItem minTagSize minVerSize) True bis
2023-10-08 15:11:32 +00:00
renderItem minTagSize minVerSize b listResult@ListResult{lTag = lTag', ..} =
2020-07-06 20:39:16 +00:00
let marks = if
| lSet -> (Brick.withAttr setAttr $ Brick.str setSign)
| lInstalled -> (Brick.withAttr installedAttr $ Brick.str installedSign)
| otherwise -> (Brick.withAttr notInstalledAttr $ Brick.str notInstalledSign)
2020-07-06 20:39:16 +00:00
ver = case lCross of
Nothing -> T.unpack . prettyVer $ lVer
Just c -> T.unpack (c <> "-" <> prettyVer lVer)
dim
2021-03-11 16:03:51 +00:00
| lNoBindist && not lInstalled
&& not b -- TODO: overloading dim and active ignores active
-- so we hack around it here
2023-10-08 15:11:32 +00:00
= Brick.updateAttrMap (const dimAttrs) . Brick.withAttr (Brick.attrName "no-bindist")
| otherwise = id
2020-10-11 19:44:11 +00:00
hooray
| elem Latest lTag' && not lInstalled =
Brick.withAttr hoorayAttr
2020-10-11 19:44:11 +00:00
| otherwise = id
2023-10-08 15:11:32 +00:00
in hooray $ dim
( marks
2023-10-08 15:11:32 +00:00
<+> Brick.padLeft (Pad 2)
2021-03-11 16:03:51 +00:00
( minHSize 6
(printTool lTool)
2020-09-20 21:06:35 +00:00
)
2023-10-08 15:11:32 +00:00
<+> minHSize minVerSize (Brick.str ver)
<+> (let l = catMaybes . fmap printTag $ sort lTag'
2023-10-08 15:11:32 +00:00
in Brick.padLeft (Pad 1) $ minHSize minTagSize $ if null l
then Brick.emptyWidget
else foldr1 (\x y -> x <+> Brick.str "," <+> y) l
)
2023-10-08 15:11:32 +00:00
<+> Brick.padLeft (Pad 5)
2021-03-11 16:03:51 +00:00
( let notes = printNotes listResult
in if null notes
2023-10-08 15:11:32 +00:00
then Brick.emptyWidget
else foldr1 (\x y -> x <+> Brick.str "," <+> y) notes
)
2023-10-08 15:11:32 +00:00
<+> Brick.vLimit 1 (Brick.fill ' ')
)
2020-07-06 20:39:16 +00:00
printTag Recommended = Just $ Brick.withAttr recommendedAttr $ Brick.str "recommended"
printTag Latest = Just $ Brick.withAttr latestAttr $ Brick.str "latest"
printTag Prerelease = Just $ Brick.withAttr prereleaseAttr $ Brick.str "prerelease"
printTag Nightly = Just $ Brick.withAttr nightlyAttr $ Brick.str "nightly"
2023-10-08 15:11:32 +00:00
printTag (Base pvp'') = Just $ Brick.str ("base-" ++ T.unpack (prettyPVP pvp''))
2020-10-11 19:07:13 +00:00
printTag Old = Nothing
printTag LatestPrerelease = Just $ Brick.withAttr latestPrereleaseAttr $ Brick.str "latest-prerelease"
printTag LatestNightly = Just $ Brick.withAttr latestNightlyAttr $ Brick.str "latest-nightly"
2023-10-08 15:11:32 +00:00
printTag (UnknownTag t) = Just $ Brick.str t
2020-10-11 19:07:13 +00:00
2023-10-08 15:11:32 +00:00
printTool Cabal = Brick.str "cabal"
printTool GHC = Brick.str "GHC"
printTool GHCup = Brick.str "GHCup"
printTool HLS = Brick.str "HLS"
printTool Stack = Brick.str "Stack"
2020-07-06 20:39:16 +00:00
2020-09-20 21:06:35 +00:00
printNotes ListResult {..} =
(if hlsPowered then [Brick.withAttr hlsPoweredAttr $ Brick.str "hls-powered"] else mempty
2020-09-20 21:06:35 +00:00
)
++ (if lStray then [Brick.withAttr strayAttr $ Brick.str "stray"] else mempty)
++ (case lReleaseDay of
Nothing -> mempty
Just d -> [Brick.withAttr dayAttr $ Brick.str (show d)])
2020-07-06 20:39:16 +00:00
2023-11-18 09:55:16 +00:00
minHSize s' = Brick.hLimit s' . Brick.vLimit 1 . (<+> Brick.fill ' ')
drawTutorial :: Widget Name
drawTutorial =
2023-11-18 09:55:16 +00:00
let
mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max)
txt_separator = hBorder <+> Brick.str " o " <+> hBorder
in centerLayer
$ Brick.hLimitPercent 75
$ Brick.vLimitPercent 50
$ Brick.withBorderStyle unicode
$ borderWithLabel (Brick.txt "Tutorial")
$ Brick.vBox
(fmap center
[ mkTextBox [Brick.txtWrap "GHCup is a distribution channel for Haskell's tools."]
2023-11-18 09:55:16 +00:00
, txt_separator
, mkTextBox [
Brick.hBox [
Brick.txt "This symbol "
, Brick.withAttr installedAttr (Brick.str installedSign)
, Brick.txtWrap " means that the tool is installed but not in used"
2023-11-18 09:55:16 +00:00
]
, Brick.hBox [
Brick.txt "This symbol "
, Brick.withAttr setAttr (Brick.str setSign)
, Brick.txtWrap " means that the tool is installed and in used"
2023-11-18 09:55:16 +00:00
]
, Brick.hBox [
Brick.txt "This symbol "
, Brick.withAttr notInstalledAttr (Brick.str notInstalledSign)
, Brick.txt " means that the tool isn't installed"
]
]
, txt_separator
, mkTextBox [
Brick.hBox [
Brick.withAttr recommendedAttr $ Brick.str "recommended"
, Brick.txtWrap " tag is based on community adoption, known bugs, etc... So It makes this version the least experimental"
2023-11-18 09:55:16 +00:00
]
, Brick.hBox [
Brick.withAttr latestAttr $ Brick.str "latest"
, Brick.txtWrap " tag is for the latest distributed version of the tool"
2023-11-18 09:55:16 +00:00
]
, Brick.hBox [
Brick.withAttr latestAttr $ Brick.str "hls-powered"
, Brick.txt " denotes the compiler version supported by the currently set ("
, Brick.withAttr setAttr (Brick.str setSign)
, Brick.txt ") hls"
]
, Brick.txtWrap "base-X.Y.Z.W tag is the minimun version of the base package admited in such ghc version"
2023-11-18 09:55:16 +00:00
]
, Brick.txt " "
])
<=> Brick.padRight Brick.Max (Brick.txt "Press q to exit the tutorial")
drawKeyInfo :: KeyBindings -> Widget Name
drawKeyInfo KeyBindings {..} =
let
mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max)
keyToWidget (KeyCombination key mods) = Brick.str $ intercalate "+" (showKey key : (showMod <$> mods))
in centerLayer
$ Brick.hLimitPercent 75
$ Brick.vLimitPercent 50
$ Brick.withBorderStyle unicode
$ borderWithLabel (Brick.txt "Key Actions")
$ Brick.vBox [
center $
mkTextBox [
Brick.hBox [
Brick.txt "Press "
, keyToWidget bUp, Brick.txt " and ", keyToWidget bDown
, Brick.txtWrap " to navigate the list of tools"
]
, Brick.hBox [
Brick.txt "Press "
, keyToWidget bInstall
, Brick.txtWrap " to install the selected tool. Notice, you may need to set it as default afterwards"
]
, Brick.hBox [
Brick.txt "Press "
, keyToWidget bSet
, Brick.txtWrap " to set a tool as the one for use"
]
, Brick.hBox [
Brick.txt "Press "
, keyToWidget bUninstall
, Brick.txtWrap " to uninstall a tool"
]
, Brick.hBox [
Brick.txt "Press "
, keyToWidget bChangelog
, Brick.txtWrap " to open the tool's changelog. It will open a web browser"
]
, Brick.hBox [
Brick.txt "Press "
, keyToWidget bShowAllVersions
, Brick.txtWrap " to show older version of each tool"
]
]
]
<=> Brick.hBox [Brick.txt "Press q to return to Navigation" <+> Brick.padRight Brick.Max (Brick.txt " ") <+> Brick.txt "Press Enter to go to the Tutorial"]
drawUI :: AttrMap -> BrickState -> [Widget Name]
drawUI dimAttrs st =
let navg = drawNavigation dimAttrs st
in case st ^. mode of
Navigation -> [navg]
Tutorial -> [drawTutorial, navg]
KeyInfo -> [drawKeyInfo (st ^. appKeys), navg]
2023-11-18 09:55:16 +00:00
{- Attributes
-}
defaultAttributes :: Bool -> AttrMap
2023-10-08 15:11:32 +00:00
defaultAttributes no_color = Brick.attrMap
Vty.defAttr
2023-11-18 09:55:16 +00:00
[ (L.listSelectedFocusedAttr , Vty.defAttr `withBackColor` Vty.blue)
, (L.listSelectedAttr , Vty.defAttr)
, (notInstalledAttr , Vty.defAttr `withForeColor` Vty.red)
, (setAttr , Vty.defAttr `withForeColor` Vty.green)
, (installedAttr , Vty.defAttr `withForeColor` Vty.green)
, (recommendedAttr , Vty.defAttr `withForeColor` Vty.green)
, (hlsPoweredAttr , Vty.defAttr `withForeColor` Vty.green)
, (latestAttr , Vty.defAttr `withForeColor` Vty.yellow)
, (latestPrereleaseAttr , Vty.defAttr `withForeColor` Vty.red)
, (latestNightlyAttr , Vty.defAttr `withForeColor` Vty.red)
, (prereleaseAttr , Vty.defAttr `withForeColor` Vty.red)
, (nightlyAttr , Vty.defAttr `withForeColor` Vty.red)
, (compiledAttr , Vty.defAttr `withForeColor` Vty.blue)
, (strayAttr , Vty.defAttr `withForeColor` Vty.blue)
, (dayAttr , Vty.defAttr `withForeColor` Vty.blue)
, (helpAttr , Vty.defAttr `withStyle` Vty.italic)
, (hoorayAttr , Vty.defAttr `withForeColor` Vty.brightWhite)
]
where
withForeColor | no_color = const
| otherwise = Vty.withForeColor
withBackColor | no_color = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo
| otherwise = Vty.withBackColor
withStyle = Vty.withStyle
notInstalledAttr, setAttr, installedAttr, recommendedAttr, hlsPoweredAttr:: Brick.AttrName
latestAttr, latestPrereleaseAttr, latestNightlyAttr, prereleaseAttr, nightlyAttr:: Brick.AttrName
compiledAttr, strayAttr, dayAttr, helpAttr, hoorayAttr:: Brick.AttrName
notInstalledAttr = Brick.attrName "not-installed"
setAttr = Brick.attrName "set"
installedAttr = Brick.attrName "installed"
recommendedAttr = Brick.attrName "recommended"
hlsPoweredAttr = Brick.attrName "hls-powered"
latestAttr = Brick.attrName "latest"
latestPrereleaseAttr = Brick.attrName "latest-prerelease"
latestNightlyAttr = Brick.attrName "latest-nightly"
prereleaseAttr = Brick.attrName "prerelease"
nightlyAttr = Brick.attrName "nightly"
compiledAttr = Brick.attrName "compiled"
strayAttr = Brick.attrName "stray"
dayAttr = Brick.attrName "day"
helpAttr = Brick.attrName "help"
hoorayAttr = Brick.attrName "hooray"
dimAttributes :: Bool -> AttrMap
2023-10-08 15:11:32 +00:00
dimAttributes no_color = Brick.attrMap
(Vty.defAttr `Vty.withStyle` Vty.dim)
2023-10-08 15:11:32 +00:00
[ (Brick.attrName "active" , Vty.defAttr `withBackColor` Vty.blue) -- has no effect ??
, (Brick.attrName "no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim)
]
where
withBackColor | no_color = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo
| otherwise = Vty.withBackColor
2023-11-18 09:55:16 +00:00
{- Handlers
-}
keyHandlers :: KeyBindings
-> [ ( KeyCombination
, BrickSettings -> String
, EventM Name BrickState ()
)
]
keyHandlers KeyBindings {..} =
[ (bQuit, const "Quit" , Brick.halt)
, (bInstall, const "Install" , withIOAction install')
, (bUninstall, const "Uninstall", withIOAction del')
, (bSet, const "Set" , withIOAction set')
, (bChangelog, const "ChangeLog", withIOAction changelog')
, ( bShowAllVersions
, \BrickSettings {..} ->
if _showAllVersions then "Don't show all versions" else "Show all versions"
, hideShowHandler' (not . _showAllVersions)
2023-11-18 09:55:16 +00:00
)
, (bUp, const "Up", Brick.zoom (toLensVL appState) moveUp)
, (bDown, const "Down", Brick.zoom (toLensVL appState) moveDown)
, (KeyCombination (Vty.KChar 'h') [], const "help", mode .= KeyInfo)
2023-11-18 09:55:16 +00:00
]
where
--hideShowHandler' :: (BrickSettings -> Bool) -> (BrickSettings -> Bool) -> m ()
hideShowHandler' f = do
2023-11-18 09:55:16 +00:00
app_settings <- use appSettings
let
vers = f app_settings
newAppSettings = app_settings & showAllVersions .~ vers
2023-11-18 09:55:16 +00:00
ad <- use appData
current_app_state <- use appState
appSettings .= newAppSettings
appState .= constructList ad newAppSettings (Just current_app_state)
tutorialHandler :: BrickEvent Name e -> EventM Name BrickState ()
tutorialHandler ev =
case ev of
VtyEvent (Vty.EvKey (Vty.KChar 'q') _ ) -> mode .= Navigation
_ -> pure ()
keyInfoHandler :: BrickEvent Name e -> EventM Name BrickState ()
keyInfoHandler ev = do
case ev of
VtyEvent (Vty.EvKey (Vty.KChar 'q') _ ) -> mode .= Navigation
VtyEvent (Vty.EvKey Vty.KEnter _ ) -> mode .= Tutorial
_ -> pure ()
navigationHandler :: BrickEvent Name e -> EventM Name BrickState ()
navigationHandler ev = do
AppState { keyBindings = kb } <- liftIO $ readIORef settings'
case ev of
2023-10-08 15:11:32 +00:00
inner_event@(VtyEvent (Vty.EvKey key _)) ->
2023-11-05 18:24:57 +00:00
case find (\(key', _, _) -> key' == KeyCombination key []) (keyHandlers kb) of
2023-10-08 15:11:32 +00:00
Nothing -> void $ Brick.zoom (toLensVL appState) $ handleGenericListEvent inner_event
Just (_, _, handler) -> handler
2023-10-08 15:11:32 +00:00
inner_event -> Brick.zoom (toLensVL appState) $ handleGenericListEvent inner_event
eventHandler :: BrickEvent Name e -> EventM Name BrickState ()
eventHandler ev = do
m <- use mode
case m of
KeyInfo -> keyInfoHandler ev
Tutorial -> tutorialHandler ev
Navigation -> navigationHandler ev
2023-11-18 09:55:16 +00:00
{- Core Logic.
2023-11-18 09:55:16 +00:00
This section defines the IO actions we can execute within the Brick App:
- Install
- Set
- UnInstall
- Launch the Changelog
-}
2020-07-06 20:39:16 +00:00
-- | Suspend the current UI and run an IO action in terminal. If the
-- IO action returns a Left value, then it's thrown as userError.
2023-10-08 15:11:32 +00:00
withIOAction :: (Ord n, Eq n)
=> ( (Int, ListResult) -> ReaderT AppState IO (Either String a))
-> EventM n BrickState ()
withIOAction action = do
2023-10-08 15:11:32 +00:00
as <- Brick.get
case sectionListSelectedElement (view appState as) of
Nothing -> pure ()
Just (curr_ix, e) -> do
2023-10-08 15:11:32 +00:00
Brick.suspendAndResume $ do
settings <- readIORef settings'
flip runReaderT settings $ action (curr_ix, e) >>= \case
Left err -> liftIO $ putStrLn ("Error: " <> err)
Right _ -> liftIO $ putStrLn "Success"
getAppData Nothing >>= \case
Right data' -> do
putStrLn "Press enter to continue"
_ <- getLine
pure (updateList data' as)
Left err -> throwIO $ userError err
2020-07-06 20:39:16 +00:00
2020-10-11 19:07:13 +00:00
-- | Update app data and list internal state based on new evidence.
2020-10-23 23:06:53 +00:00
-- This synchronises @BrickInternalState@ with @BrickData@
-- and @BrickSettings@.
updateList :: BrickData -> BrickState -> BrickState
2021-03-11 16:03:51 +00:00
updateList appD BrickState{..} =
let newInternalState = constructList appD _appSettings (Just _appState)
in BrickState { _appState = newInternalState
, _appData = appD
, _appSettings = _appSettings
, _appKeys = _appKeys
, _mode = Navigation
}
2020-10-11 19:07:13 +00:00
2020-10-23 23:06:53 +00:00
constructList :: BrickData
-> BrickSettings
-> Maybe BrickInternalState
-> BrickInternalState
2023-10-08 15:11:32 +00:00
constructList appD settings =
replaceLR (filterVisible (_showAllVersions settings))
(_lr appD)
2020-10-11 19:07:13 +00:00
2023-10-08 15:11:32 +00:00
-- | Focus on the tool section and the predicate which matches. If no result matches, focus on index 0
selectBy :: Tool -> (ListResult -> Bool) -> BrickInternalState -> BrickInternalState
selectBy tool predicate internal_state =
let new_focus = F.focusSetCurrent (Singular tool) (view sectionListFocusRingL internal_state)
tool_lens = sectionL (Singular tool)
2023-10-08 15:11:32 +00:00
in internal_state
& sectionListFocusRingL .~ new_focus
& tool_lens %~ L.listMoveTo 0 -- We move to 0 first
& tool_lens %~ L.listFindBy predicate -- The lookup by the predicate.
2020-10-11 19:07:13 +00:00
2023-10-08 15:11:32 +00:00
-- | Select the latests GHC tool
selectLatest :: BrickInternalState -> BrickInternalState
selectLatest = selectBy GHC (elem Latest . lTag)
2020-10-11 19:07:13 +00:00
-- | Replace the @appState@ or construct it based on a filter function
-- and a new @[ListResult]@ evidence.
-- When passed an existing @appState@, tries to keep the selected element.
replaceLR :: (ListResult -> Bool)
-> [ListResult]
2020-10-23 23:06:53 +00:00
-> Maybe BrickInternalState
-> BrickInternalState
2023-10-08 15:11:32 +00:00
replaceLR filterF list_result s =
let oldElem = s >>= sectionListSelectedElement -- Maybe (Int, e)
newVec = [(Singular $ lTool (head g), V.fromList g) | g <- groupBy ((==) `on` lTool ) (filter filterF list_result)]
2023-11-05 18:24:57 +00:00
newSectionList = sectionList AllTools newVec 1
2023-10-08 15:11:32 +00:00
in case oldElem of
Just (_, el) -> selectBy (lTool el) (toolEqual el) newSectionList
Nothing -> selectLatest newSectionList
2020-10-11 19:07:13 +00:00
where
toolEqual e1 e2 =
lTool e1 == lTool e2 && lVer e1 == lVer e2 && lCross e1 == lCross e2
filterVisible :: Bool -> ListResult -> Bool
filterVisible v e | lInstalled e = True
| v
, Nightly `notElem` lTag e = True
| not v
, Old `notElem` lTag e
, Nightly `notElem` lTag e = True
| otherwise = (Old `notElem` lTag e) &&
(Nightly `notElem` lTag e)
2021-05-14 21:09:45 +00:00
install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)
=> (Int, ListResult)
2021-05-14 21:09:45 +00:00
-> m (Either String ())
install' (_, ListResult {..}) = do
2021-05-14 21:09:45 +00:00
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
2020-10-11 19:07:13 +00:00
let run =
2021-08-30 20:41:58 +00:00
runResourceT
2020-10-11 19:07:13 +00:00
. runE
@'[ AlreadyInstalled
, ArchiveResult
, UnknownArchive
, FileDoesNotExistError
, CopyError
, NoDownload
, NotInstalled
, BuildFailed
, TagNotFound
, DigestError
, ContentLengthError
2021-09-18 17:45:32 +00:00
, GPGError
2020-10-11 19:07:13 +00:00
, DownloadFailed
2021-08-11 10:24:51 +00:00
, DirNotEmpty
2020-10-11 19:07:13 +00:00
, NoUpdate
, TarDirDoesNotExist
, FileAlreadyExistsError
2021-10-10 18:02:15 +00:00
, ProcessError
2022-05-23 14:48:29 +00:00
, ToolShadowed
, UninstallFailed
, MergeFileTreeError
, NoCompatiblePlatform
, GHCup.Errors.ParseError
, UnsupportedSetupCombo
, DistroNotFound
, NoCompatibleArch
2020-10-11 19:07:13 +00:00
]
2020-07-06 20:39:16 +00:00
2021-03-11 16:03:51 +00:00
run (do
ce <- liftIO $ fmap (either (const Nothing) Just) $
try @_ @SomeException $ getExecutablePath >>= canonicalizePath
dirs <- lift getDirs
2020-07-06 20:39:16 +00:00
case lTool of
GHC -> do
2023-07-07 08:41:58 +00:00
let vi = getVersionInfo (GHCTargetVersion lCross lVer) GHC dls
liftE $ installGHCBin (GHCTargetVersion lCross lVer) GHCupInternal False [] $> (vi, dirs, ce)
Cabal -> do
2023-07-07 08:41:58 +00:00
let vi = getVersionInfo (GHCTargetVersion lCross lVer) Cabal dls
liftE $ installCabalBin lVer GHCupInternal False $> (vi, dirs, ce)
GHCup -> do
let vi = snd <$> getLatest dls GHCup
liftE $ upgradeGHCup Nothing False False $> (vi, dirs, ce)
HLS -> do
2023-07-07 08:41:58 +00:00
let vi = getVersionInfo (GHCTargetVersion lCross lVer) HLS dls
liftE $ installHLSBin lVer GHCupInternal False $> (vi, dirs, ce)
2021-05-14 22:31:36 +00:00
Stack -> do
2023-07-07 08:41:58 +00:00
let vi = getVersionInfo (GHCTargetVersion lCross lVer) Stack dls
liftE $ installStackBin lVer GHCupInternal False $> (vi, dirs, ce)
2020-07-06 20:39:16 +00:00
)
>>= \case
VRight (vi, Dirs{..}, Just ce) -> do
forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg
case lTool of
GHCup -> do
2023-11-05 10:00:23 +00:00
#if !IS_WINDOWS
up <- liftIO $ fmap (either (const Nothing) Just)
$ try @_ @SomeException $ canonicalizePath (binDir </> "ghcup" <.> exeExt)
when ((normalise <$> up) == Just (normalise ce)) $
-- TODO: track cli arguments of previous invocation
liftIO $ SPP.executeFile ce False ["tui"] Nothing
2023-11-05 10:00:23 +00:00
#else
logInfo "Please restart 'ghcup' for the changes to take effect"
2023-11-05 10:00:23 +00:00
#endif
_ -> pure ()
pure $ Right ()
VRight (vi, _, _) -> do
forM_ (_viPostInstall =<< vi) $ \msg -> logInfo msg
logInfo "Please restart 'ghcup' for the changes to take effect"
pure $ Right ()
2020-07-06 20:39:16 +00:00
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
VLeft (V NoUpdate) -> pure $ Right ()
VLeft e -> pure $ Left $ prettyHFError e <> "\n"
2021-08-25 16:54:58 +00:00
<> "Also check the logs in ~/.ghcup/logs"
2020-07-06 20:39:16 +00:00
set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)
=> (Int, ListResult)
-> m (Either String ())
set' input@(_, ListResult {..}) = do
settings <- liftIO $ readIORef settings'
2020-07-06 20:39:16 +00:00
let run =
2021-08-30 20:41:58 +00:00
flip runReaderT settings
. runResourceT
. runE
@'[ AlreadyInstalled
, ArchiveResult
, UnknownArchive
, FileDoesNotExistError
, CopyError
, NoDownload
, NotInstalled
, BuildFailed
, TagNotFound
, DigestError
, ContentLengthError
, GPGError
, DownloadFailed
, DirNotEmpty
, NoUpdate
, TarDirDoesNotExist
, FileAlreadyExistsError
, ProcessError
, ToolShadowed
, UninstallFailed
, MergeFileTreeError
, NoCompatiblePlatform
, GHCup.Errors.ParseError
, UnsupportedSetupCombo
, DistroNotFound
, NoCompatibleArch
]
2020-07-06 20:39:16 +00:00
2021-03-11 16:03:51 +00:00
run (do
2020-07-06 20:39:16 +00:00
case lTool of
2022-02-09 17:57:59 +00:00
GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly Nothing $> ()
2020-07-06 20:39:16 +00:00
Cabal -> liftE $ setCabal lVer $> ()
2022-02-09 17:57:59 +00:00
HLS -> liftE $ setHLS lVer SetHLSOnly Nothing $> ()
2021-05-14 22:31:36 +00:00
Stack -> liftE $ setStack lVer $> ()
GHCup -> do
promptAnswer <- getUserPromptResponse "Switching GHCup versions is not supported.\nDo you want to install the latest version? [Y/N]: "
case promptAnswer of
PromptYes -> do
void $ liftE $ upgradeGHCup Nothing False False
PromptNo -> pure ()
2020-07-06 20:39:16 +00:00
)
>>= \case
VRight _ -> pure $ Right ()
VLeft e -> case e of
(V (NotInstalled tool _)) -> do
promptAnswer <- getUserPromptResponse userPrompt
case promptAnswer of
PromptYes -> do
res <- install' input
case res of
(Left err) -> pure $ Left err
(Right _) -> do
logInfo "Setting now..."
set' input
PromptNo -> pure $ Left (prettyHFError e)
where
userPrompt = L.toStrict . B.toLazyText . B.fromString $
"This Version of "
<> show tool
<> " you are trying to set is not installed.\n"
<> "Would you like to install it first? [Y/N]: "
_ -> pure $ Left (prettyHFError e)
2020-07-06 20:39:16 +00:00
2021-05-14 21:09:45 +00:00
del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m)
=> (Int, ListResult)
2021-05-14 21:09:45 +00:00
-> m (Either String ())
del' (_, ListResult {..}) = do
2021-05-14 21:09:45 +00:00
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
2020-07-06 20:39:16 +00:00
let run = runE @'[NotInstalled, UninstallFailed]
2020-07-06 20:39:16 +00:00
2021-03-11 16:03:51 +00:00
run (do
2023-07-07 08:41:58 +00:00
let vi = getVersionInfo (GHCTargetVersion lCross lVer) lTool dls
2020-07-06 20:39:16 +00:00
case lTool of
GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi
Cabal -> liftE $ rmCabalVer lVer $> vi
HLS -> liftE $ rmHLSVer lVer $> vi
2021-05-14 22:31:36 +00:00
Stack -> liftE $ rmStackVer lVer $> vi
GHCup -> pure Nothing
2020-07-06 20:39:16 +00:00
)
>>= \case
VRight vi -> do
when (lTool == GHC) $ logGHCPostRm (mkTVer lVer)
2021-10-15 20:24:23 +00:00
forM_ (_viPostRemove =<< vi) $ \msg ->
2021-08-30 20:41:58 +00:00
logInfo msg
pure $ Right ()
VLeft e -> pure $ Left (prettyHFError e)
2020-07-06 20:39:16 +00:00
2021-05-14 21:09:45 +00:00
changelog' :: (MonadReader AppState m, MonadIO m)
=> (Int, ListResult)
2021-05-14 21:09:45 +00:00
-> m (Either String ())
changelog' (_, ListResult {..}) = do
2021-05-14 21:09:45 +00:00
AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
case getChangeLog dls lTool (ToolVersion lVer) of
2021-08-25 16:54:58 +00:00
Nothing -> pure $ Left $
"Could not find ChangeLog for " <> prettyShow lTool <> ", version " <> T.unpack (prettyVer lVer)
2020-07-06 20:39:16 +00:00
Just uri -> do
2023-11-20 14:36:17 +00:00
case _rPlatform pfreq of
Darwin -> exec "open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing
Linux _ -> exec "xdg-open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing
FreeBSD -> exec "xdg-open" [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing
Windows -> do
let args = "start \"\" " ++ (T.unpack $ decUTF8Safe $ serializeURIRef' uri)
c <- liftIO $ system $ args
case c of
(ExitFailure xi) -> pure $ Left $ NonZeroExit xi "cmd.exe" [args]
ExitSuccess -> pure $ Right ()
>>= \case
2020-07-06 20:39:16 +00:00
Right _ -> pure $ Right ()
Left e -> pure $ Left $ prettyHFError e
2020-07-06 20:39:16 +00:00
2020-10-23 23:06:53 +00:00
settings' :: IORef AppState
2020-07-06 20:39:16 +00:00
{-# NOINLINE settings' #-}
settings' = unsafePerformIO $ do
2021-07-18 21:29:09 +00:00
dirs <- getAllDirs
let loggerConfig = LoggerConfig { lcPrintDebug = False
, consoleOutter = \_ -> pure ()
, fileOutter = \_ -> pure ()
, fancyColors = True
2021-08-30 20:41:58 +00:00
}
newIORef $ AppState defaultSettings
2020-10-23 23:06:53 +00:00
dirs
defaultKeyBindings
(GHCupInfo mempty mempty Nothing)
2021-05-14 21:09:45 +00:00
(PlatformRequest A_64 Darwin Nothing)
2021-08-30 20:41:58 +00:00
loggerConfig
2020-10-23 23:06:53 +00:00
2020-07-06 20:39:16 +00:00
2020-10-23 23:06:53 +00:00
brickMain :: AppState
2020-10-11 19:07:13 +00:00
-> IO ()
2021-08-30 20:41:58 +00:00
brickMain s = do
2020-07-06 20:39:16 +00:00
writeIORef settings' s
2021-07-18 21:29:09 +00:00
eAppData <- getAppData (Just $ ghcupInfo s)
case eAppData of
2020-10-11 19:07:13 +00:00
Right ad ->
2023-10-08 15:11:32 +00:00
Brick.defaultMain
(app (defaultAttributes (noColor $ settings s)) (dimAttributes (noColor $ settings s)))
2020-10-23 23:06:53 +00:00
(BrickState ad
2020-10-11 19:07:13 +00:00
defaultAppSettings
(constructList ad defaultAppSettings Nothing)
2021-07-18 21:29:09 +00:00
(keyBindings (s :: AppState))
Navigation
2020-10-11 19:07:13 +00:00
)
$> ()
Left e -> do
2021-08-30 20:41:58 +00:00
flip runReaderT s $ logError $ "Error building app state: " <> T.pack (show e)
2020-07-06 20:39:16 +00:00
exitWith $ ExitFailure 2
2020-10-23 23:06:53 +00:00
defaultAppSettings :: BrickSettings
defaultAppSettings = BrickSettings { _showAllVersions = False}
2021-05-14 21:09:45 +00:00
getGHCupInfo :: IO (Either String GHCupInfo)
getGHCupInfo = do
2020-07-06 20:39:16 +00:00
settings <- readIORef settings'
r <-
2021-08-30 20:41:58 +00:00
flip runReaderT settings
. runE @'[DigestError, ContentLengthError, GPGError, JSONError , DownloadFailed , FileDoesNotExistError, StackPlatformDetectError]
$ do
pfreq <- lift getPlatformReq
liftE $ getDownloadsF pfreq
2020-07-06 20:39:16 +00:00
case r of
VRight a -> pure $ Right a
VLeft e -> pure $ Left (prettyHFError e)
2021-05-14 21:09:45 +00:00
getAppData :: Maybe GHCupInfo
2020-10-23 23:06:53 +00:00
-> IO (Either String BrickData)
2021-05-14 21:09:45 +00:00
getAppData mgi = runExceptT $ do
r <- ExceptT $ maybe getGHCupInfo (pure . Right) mgi
liftIO $ modifyIORef settings' (\s -> s { ghcupInfo = r })
settings <- liftIO $ readIORef settings'
2021-08-30 20:41:58 +00:00
flip runReaderT settings $ do
lV <- listVersions Nothing [] False True (Nothing, Nothing)
2021-05-14 21:09:45 +00:00
pure $ BrickData (reverse lV)