hasufell
/
ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Use MonadState Instance to simplify install', del', set' and changelog'. Lensify the app

This commit is contained in:
Luis Morillo 2023-07-11 18:55:10 +02:00
parent 2caf491e9d
commit aa9fbdbfc2
2 changed files with 304 additions and 100 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

400
app/ghcup/BrickMain.hs
View File

@ -7,6 +7,9 @@
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-} {-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
{-# OPTIONS_GHC -Wno-unused-matches #-} {-# OPTIONS_GHC -Wno-unused-matches #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
module BrickMain where module BrickMain where
@ -22,14 +25,57 @@ import GHCup.Prelude.Logger
import GHCup.Prelude.Process import GHCup.Prelude.Process
import GHCup.Prompts import GHCup.Prompts
import Brick import Brick
import Brick.Widgets.Border ( defaultMain,
import Brick.Widgets.Border.Style suspendAndResume,
import Brick.Widgets.Center attrMap,
showFirstCursor,
hLimit,
vBox,
viewport,
visible,
fill,
vLimit,
forceAttr,
putCursor,
updateAttrMap,
withDefAttr,
padLeft,
(<+>),
emptyWidget,
txtWrap,
attrName,
withAttr,
(<=>),
str,
withBorderStyle,
padBottom,
halt,
BrickEvent(VtyEvent, MouseDown),
App(..),
ViewportType(Vertical),
Size(Greedy),
Location(Location),
Padding(Max, Pad),
Widget(Widget, render),
AttrMap,
Direction(..),
get,
zoom,
EventM,
suffixLenses,
Named(..), modify )
import Brick.Widgets.Border ( hBorder, borderWithLabel )
import Brick.Widgets.Border.Style ( unicode )
import Brick.Widgets.Center ( center )
import Brick.Widgets.Dialog (buttonSelectedAttr)
import Brick.Widgets.List ( listSelectedFocusedAttr import Brick.Widgets.List ( listSelectedFocusedAttr
, listSelectedAttr , listSelectedAttr
, listAttr , listAttr
) )
import qualified Brick.Widgets.List as L
import Brick.Focus (FocusRing)
import qualified Brick.Focus as F
import Codec.Archive import Codec.Archive
import Control.Applicative import Control.Applicative
import Control.Exception.Safe import Control.Exception.Safe
@ -41,9 +87,10 @@ import Control.Monad.Trans.Except
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
import Data.Bool import Data.Bool
import Data.Functor import Data.Functor
import Data.Function ( (&))
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Data.IORef import Data.IORef (IORef, readIORef, newIORef, writeIORef, modifyIORef)
import Data.Vector ( Vector import Data.Vector ( Vector
, (!?) , (!?)
) )
@ -67,6 +114,153 @@ import System.FilePath
import qualified System.Posix.Process as SPP import qualified System.Posix.Process as SPP
#endif #endif
import Optics.TH (makeLenses, makeLensesFor)
import Optics.State (use)
import Optics.State.Operators ( (.=), (%=), (<%=))
import Optics.Optic ((%))
import Optics.Operators ((.~), (^.))
import Optics.Getter (view)
import Optics.Lens (Lens', lens, toLensVL, lensVL)
{- 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
instance Named (GenericSectionList n t e) n where
getName = sectionListName
-- | 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
-- | 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 ()
-> EventM n (GenericSectionList n t e) ()
handleGenericListEvent (VtyEvent (Vty.EvKey (Vty.KChar '\t') [])) = sectionListFocusRingL %= F.focusNext
handleGenericListEvent (VtyEvent (Vty.EvKey Vty.KBackTab [])) = sectionListFocusRingL %= F.focusPrev
handleGenericListEvent (VtyEvent ev@(Vty.EvKey Vty.KDown [])) = 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
Just new_l -> zoom (toLensVL $ sectionL new_l) (modify L.listMoveToBeginning)
else zoom (toLensVL $ sectionL l) $ L.handleListEvent ev
handleGenericListEvent (VtyEvent ev@(Vty.EvKey Vty.KUp [])) = 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 ()
Just new_l -> zoom (toLensVL $ sectionL new_l) (modify L.listMoveToEnd)
else zoom (toLensVL $ sectionL l) $ L.handleListEvent ev
handleGenericListEvent (VtyEvent ev) = do
ring <- use sectionListFocusRingL
case F.focusGetCurrent ring of
Nothing -> pure ()
Just l -> zoom (toLensVL $ sectionL l) $ L.handleListEvent ev
handleGenericListEvent _ = pure ()
-- This re-uses Brick.Widget.List.renderList
renderSectionList :: (Traversable t, Ord n, Show n, Eq n, L.Splittable t)
=> (Bool -> n -> Widget n) -- ^ Rendering function for separator between sections. True for selected before section
-> (Bool -> n -> Widget n -> Widget n) -- ^ Rendering function for the borders. True for selected section
-> (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
renderSectionList render_separator render_border render_elem section_focus (GenericSectionList focus elms _) =
V.foldl' (\wacc list ->
let has_focus = is_focused_section list
list_name = L.listName list
in wacc
<=> render_separator has_focus list_name
<=> inner_widget has_focus list_name list
)
emptyWidget elms
where
is_focused_section l = section_focus && Just (L.listName l) == F.focusGetCurrent focus
inner_widget has_focus k l = render_border has_focus k (L.renderList render_elem has_focus l)
-- | 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
{- GHCUp State
-}
installedSign :: String installedSign :: String
#if IS_WINDOWS #if IS_WINDOWS
@ -91,55 +285,71 @@ notInstalledSign = "✗ "
data BrickData = BrickData data BrickData = BrickData
{ lr :: [ListResult] { _lr :: [ListResult]
} }
deriving Show deriving Show
makeLenses ''BrickData
data BrickSettings = BrickSettings data BrickSettings = BrickSettings
{ showAllVersions :: Bool { _showAllVersions :: Bool
, _showAllTools :: Bool
} }
deriving Show --deriving Show
makeLenses ''BrickSettings
data BrickInternalState = BrickInternalState data BrickInternalState = BrickInternalState
{ clr :: Vector ListResult { _clr :: Vector ListResult
, ix :: Int , _ix :: Int
} }
deriving Show --deriving Show
makeLenses ''BrickInternalState
data BrickState = BrickState data BrickState = BrickState
{ appData :: BrickData { _appData :: BrickData
, appSettings :: BrickSettings , _appSettings :: BrickSettings
, appState :: BrickInternalState , _appState :: BrickInternalState
, appKeys :: KeyBindings , _appKeys :: KeyBindings
} }
deriving Show --deriving Show
makeLenses ''BrickState
keyHandlers :: KeyBindings keyHandlers :: KeyBindings
-> [ ( KeyCombination -> [ ( KeyCombination
, BrickSettings -> String , BrickSettings -> String
, BrickState -> EventM String BrickState () , EventM String BrickState ()
) )
] ]
keyHandlers KeyBindings {..} = keyHandlers KeyBindings {..} =
[ (bQuit, const "Quit" , \_ -> halt) [ (bQuit, const "Quit" , halt)
, (bInstall, const "Install" , withIOAction install') , (bInstall, const "Install" , withIOAction install')
, (bUninstall, const "Uninstall", withIOAction del') , (bUninstall, const "Uninstall", withIOAction del')
, (bSet, const "Set" , withIOAction set') , (bSet, const "Set" , withIOAction set')
, (bChangelog, const "ChangeLog", withIOAction changelog') , (bChangelog, const "ChangeLog", withIOAction changelog')
, ( bShowAllVersions , ( bShowAllVersions
, \BrickSettings {..} -> , \BrickSettings {..} ->
if showAllVersions then "Don't show all versions" else "Show all versions" if _showAllVersions then "Don't show all versions" else "Show all versions"
, hideShowHandler (not . showAllVersions) , hideShowHandler' (not . _showAllVersions) _showAllTools
) )
, (bUp, const "Up", \BrickState {..} -> put BrickState{ appState = moveCursor 1 appState Up, .. }) , (bUp, const "Up", appState %= moveCursor 1 Up)
, (bDown, const "Down", \BrickState {..} -> put BrickState{ appState = moveCursor 1 appState Down, .. }) , (bDown, const "Down", appState %= moveCursor 1 Down)
] ]
where where
hideShowHandler f BrickState{..} = --hideShowHandler' :: (BrickSettings -> Bool) -> (BrickSettings -> Bool) -> m ()
let newAppSettings = appSettings { showAllVersions = f appSettings } hideShowHandler' f p = do
newInternalState = constructList appData newAppSettings (Just appState) app_settings <- use appSettings
in put (BrickState appData newAppSettings newInternalState appKeys) let
vers = f app_settings
tools = p app_settings
newAppSettings = app_settings & showAllVersions .~ vers & showAllTools .~ tools
ad <- use appData
current_app_state <- use appState
appSettings .= newAppSettings
appState .= constructList ad app_settings (Just current_app_state)
showKey :: Vty.Key -> String showKey :: Vty.Key -> String
@ -153,11 +363,11 @@ showMod = tail . show
ui :: AttrMap -> BrickState -> Widget String ui :: AttrMap -> BrickState -> Widget String
ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..} ui dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..}
= padBottom Max = padBottom Max
( withBorderStyle unicode ( withBorderStyle unicode
$ borderWithLabel (str "GHCup") $ borderWithLabel (str "GHCup")
(center (header <=> hBorder <=> renderList' appState)) (center (header <=> hBorder <=> renderList' _appState))
) )
<=> footer <=> footer
@ -168,7 +378,7 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
. T.pack . T.pack
. foldr1 (\x y -> x <> " " <> y) . foldr1 (\x y -> x <> " " <> y)
. fmap (\(KeyCombination key mods, s, _) -> intercalate "+" (showKey key : (showMod <$> mods)) <> ":" <> s as) . fmap (\(KeyCombination key mods, s, _) -> intercalate "+" (showKey key : (showMod <$> mods)) <> ":" <> s as)
$ keyHandlers appKeys $ keyHandlers _appKeys
header = header =
minHSize 2 emptyWidget minHSize 2 emptyWidget
<+> padLeft (Pad 2) (minHSize 6 $ str "Tool") <+> padLeft (Pad 2) (minHSize 6 $ str "Tool")
@ -176,8 +386,8 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
<+> padLeft (Pad 1) (minHSize 25 $ str "Tags") <+> padLeft (Pad 1) (minHSize 25 $ str "Tags")
<+> padLeft (Pad 5) (str "Notes") <+> padLeft (Pad 5) (str "Notes")
renderList' bis@BrickInternalState{..} = renderList' bis@BrickInternalState{..} =
let minTagSize = V.maximum $ V.map (length . intercalate "," . fmap tagToString . lTag) clr let minTagSize = V.maximum $ V.map (length . intercalate "," . fmap tagToString . lTag) _clr
minVerSize = V.maximum $ V.map (\ListResult{..} -> T.length $ tVerToText (GHCTargetVersion lCross lVer)) clr minVerSize = V.maximum $ V.map (\ListResult{..} -> T.length $ tVerToText (GHCTargetVersion lCross lVer)) _clr
in withDefAttr listAttr . drawListElements (renderItem minTagSize minVerSize) True $ bis in withDefAttr listAttr . drawListElements (renderItem minTagSize minVerSize) True $ bis
renderItem minTagSize minVerSize _ b listResult@ListResult{lTag = lTag', ..} = renderItem minTagSize minVerSize _ b listResult@ListResult{lTag = lTag', ..} =
let marks = if let marks = if
@ -283,11 +493,10 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
minHSize :: Int -> Widget n -> Widget n minHSize :: Int -> Widget n -> Widget n
minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ') minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ')
app :: AttrMap -> AttrMap -> App BrickState () String
app :: AttrMap -> AttrMap -> App BrickState e String
app attrs dimAttrs = app attrs dimAttrs =
App { appDraw = \st -> [ui dimAttrs st] App { appDraw = \st -> [ui dimAttrs st]
, appHandleEvent = \be -> get >>= \s -> eventHandler s be , appHandleEvent = eventHandler
, appStartEvent = return () , appStartEvent = return ()
, appAttrMap = const attrs , appAttrMap = const attrs
, appChooseCursor = showFirstCursor , appChooseCursor = showFirstCursor
@ -312,6 +521,7 @@ defaultAttributes no_color = attrMap
, (attrName "day" , Vty.defAttr `withForeColor` Vty.blue) , (attrName "day" , Vty.defAttr `withForeColor` Vty.blue)
, (attrName "help" , Vty.defAttr `withStyle` Vty.italic) , (attrName "help" , Vty.defAttr `withStyle` Vty.italic)
, (attrName "hooray" , Vty.defAttr `withForeColor` Vty.brightWhite) , (attrName "hooray" , Vty.defAttr `withForeColor` Vty.brightWhite)
, (buttonSelectedAttr , Vty.defAttr `withBackColor` Vty.brightWhite)
] ]
where where
withForeColor | no_color = const withForeColor | no_color = const
@ -332,56 +542,51 @@ dimAttributes no_color = attrMap
withBackColor | no_color = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo withBackColor | no_color = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo
| otherwise = Vty.withBackColor | otherwise = Vty.withBackColor
eventHandler :: BrickState -> BrickEvent String e -> EventM String BrickState () eventHandler :: BrickEvent String e -> EventM String BrickState ()
eventHandler st@BrickState{..} ev = do eventHandler ev = do
AppState { keyBindings = kb } <- liftIO $ readIORef settings' AppState { keyBindings = kb } <- liftIO $ readIORef settings'
case ev of case ev of
(MouseDown _ Vty.BScrollUp _ _) -> (MouseDown _ Vty.BScrollUp _ _) -> appState %= moveCursor 1 Up
put (BrickState { appState = moveCursor 1 appState Up, .. }) (MouseDown _ Vty.BScrollDown _ _) -> appState %= moveCursor 1 Down
(MouseDown _ Vty.BScrollDown _ _) -> (VtyEvent (Vty.EvResize _ _)) -> pure ()
put (BrickState { appState = moveCursor 1 appState Down, .. }) (VtyEvent (Vty.EvKey Vty.KUp _)) -> appState %= moveCursor 1 Up
(VtyEvent (Vty.EvResize _ _)) -> put st (VtyEvent (Vty.EvKey Vty.KDown _)) -> appState %= moveCursor 1 Down
(VtyEvent (Vty.EvKey Vty.KUp [])) -> (VtyEvent (Vty.EvKey key _)) ->
put BrickState{ appState = moveCursor 1 appState Up, .. } case find (\(key', _, _) -> key' == key) (keyHandlers kb) of
(VtyEvent (Vty.EvKey Vty.KDown [])) -> Nothing -> pure ()
put BrickState{ appState = moveCursor 1 appState Down, .. } Just (_, _, handler) -> handler
(VtyEvent (Vty.EvKey key mods)) -> _ -> pure ()
case find (\(keyCombo, _, _) -> keyCombo == KeyCombination key mods) (keyHandlers kb) of
Nothing -> put st
Just (_, _, handler) -> handler st
_ -> put st
moveCursor :: Int -> BrickInternalState -> Direction -> BrickInternalState moveCursor :: Int -> Direction -> BrickInternalState -> BrickInternalState
moveCursor steps ais@BrickInternalState{..} direction = moveCursor steps direction ais@BrickInternalState{..} =
let newIx = if direction == Down then ix + steps else ix - steps let newIx = if direction == Down then _ix + steps else _ix - steps
in case clr !? newIx of in case _clr !? newIx of
Just _ -> BrickInternalState { ix = newIx, .. } Just _ -> ais & ix .~ newIx
Nothing -> ais Nothing -> ais
-- | Suspend the current UI and run an IO action in terminal. If the -- | 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. -- IO action returns a Left value, then it's thrown as userError.
withIOAction :: Ord n withIOAction :: Ord n
=> (BrickState => ( (Int, ListResult) -> ReaderT AppState IO (Either String a))
-> (Int, ListResult)
-> ReaderT AppState IO (Either String a))
-> BrickState
-> EventM n BrickState () -> EventM n BrickState ()
withIOAction action as = case listSelectedElement' (appState as) of withIOAction action = do
Nothing -> put as as <- get
Just (ix, e) -> do case listSelectedElement' (view appState as) of
suspendAndResume $ do Nothing -> pure ()
settings <- readIORef settings' Just (curr_ix, e) -> do
flip runReaderT settings $ action as (ix, e) >>= \case suspendAndResume $ do
Left err -> liftIO $ putStrLn ("Error: " <> err) settings <- readIORef settings'
Right _ -> liftIO $ putStrLn "Success" flip runReaderT settings $ action (curr_ix, e) >>= \case
getAppData Nothing >>= \case Left err -> liftIO $ putStrLn ("Error: " <> err)
Right data' -> do Right _ -> liftIO $ putStrLn "Success"
putStrLn "Press enter to continue" getAppData Nothing >>= \case
_ <- getLine Right data' -> do
pure (updateList data' as) putStrLn "Press enter to continue"
Left err -> throwIO $ userError err _ <- getLine
pure (updateList data' as)
Left err -> throwIO $ userError err
-- | Update app data and list internal state based on new evidence. -- | Update app data and list internal state based on new evidence.
@ -389,11 +594,11 @@ withIOAction action as = case listSelectedElement' (appState as) of
-- and @BrickSettings@. -- and @BrickSettings@.
updateList :: BrickData -> BrickState -> BrickState updateList :: BrickData -> BrickState -> BrickState
updateList appD BrickState{..} = updateList appD BrickState{..} =
let newInternalState = constructList appD appSettings (Just appState) let newInternalState = constructList appD _appSettings (Just _appState)
in BrickState { appState = newInternalState in BrickState { _appState = newInternalState
, appData = appD , _appData = appD
, appSettings = appSettings , _appSettings = _appSettings
, appKeys = appKeys , _appKeys = _appKeys
} }
@ -402,11 +607,12 @@ constructList :: BrickData
-> Maybe BrickInternalState -> Maybe BrickInternalState
-> BrickInternalState -> BrickInternalState
constructList appD appSettings = constructList appD appSettings =
replaceLR (filterVisible (showAllVersions appSettings)) replaceLR (filterVisible (_showAllVersions appSettings)
(lr appD) (_showAllTools appSettings))
(_lr appD)
listSelectedElement' :: BrickInternalState -> Maybe (Int, ListResult) listSelectedElement' :: BrickInternalState -> Maybe (Int, ListResult)
listSelectedElement' BrickInternalState{..} = fmap (ix, ) $ clr !? ix listSelectedElement' BrickInternalState{..} = fmap (_ix, ) $ _clr !? _ix
selectLatest :: Vector ListResult -> Int selectLatest :: Vector ListResult -> Int
@ -444,11 +650,10 @@ filterVisible v e | lInstalled e = True
(Nightly `notElem` lTag e) (Nightly `notElem` lTag e)
install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m)
=> BrickState => (Int, ListResult)
-> (Int, ListResult)
-> m (Either String ()) -> m (Either String ())
install' _ (_, ListResult {..}) = do install' (_, ListResult {..}) = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
let run = let run =
@ -530,10 +735,9 @@ install' _ (_, ListResult {..}) = do
set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)
=> BrickState => (Int, ListResult)
-> (Int, ListResult)
-> m (Either String ()) -> m (Either String ())
set' bs input@(_, ListResult {..}) = do set' input@(_, ListResult {..}) = do
settings <- liftIO $ readIORef settings' settings <- liftIO $ readIORef settings'
let run = let run =
@ -588,12 +792,12 @@ set' bs input@(_, ListResult {..}) = do
promptAnswer <- getUserPromptResponse userPrompt promptAnswer <- getUserPromptResponse userPrompt
case promptAnswer of case promptAnswer of
PromptYes -> do PromptYes -> do
res <- install' bs input res <- install' input
case res of case res of
(Left err) -> pure $ Left err (Left err) -> pure $ Left err
(Right _) -> do (Right _) -> do
logInfo "Setting now..." logInfo "Setting now..."
set' bs input set' input
PromptNo -> pure $ Left (prettyHFError e) PromptNo -> pure $ Left (prettyHFError e)
where where
@ -608,10 +812,9 @@ set' bs input@(_, ListResult {..}) = do
del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m) del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m)
=> BrickState => (Int, ListResult)
-> (Int, ListResult)
-> m (Either String ()) -> m (Either String ())
del' _ (_, ListResult {..}) = do del' (_, ListResult {..}) = do
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
let run = runE @'[NotInstalled, UninstallFailed] let run = runE @'[NotInstalled, UninstallFailed]
@ -635,10 +838,9 @@ del' _ (_, ListResult {..}) = do
changelog' :: (MonadReader AppState m, MonadIO m) changelog' :: (MonadReader AppState m, MonadIO m)
=> BrickState => (Int, ListResult)
-> (Int, ListResult)
-> m (Either String ()) -> m (Either String ())
changelog' _ (_, ListResult {..}) = do changelog' (_, ListResult {..}) = do
AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
case getChangeLog dls lTool (ToolVersion lVer) of case getChangeLog dls lTool (ToolVersion lVer) of
Nothing -> pure $ Left $ Nothing -> pure $ Left $
@ -671,7 +873,6 @@ settings' = unsafePerformIO $ do
loggerConfig loggerConfig
brickMain :: AppState brickMain :: AppState
-> IO () -> IO ()
brickMain s = do brickMain s = do
@ -695,7 +896,7 @@ brickMain s = do
defaultAppSettings :: BrickSettings defaultAppSettings :: BrickSettings
defaultAppSettings = BrickSettings { showAllVersions = False } defaultAppSettings = BrickSettings { _showAllVersions = False, _showAllTools = False }
getGHCupInfo :: IO (Either String GHCupInfo) getGHCupInfo :: IO (Either String GHCupInfo)
@ -724,3 +925,4 @@ getAppData mgi = runExceptT $ do
flip runReaderT settings $ do flip runReaderT settings $ do
lV <- listVersions Nothing [] False True (Nothing, Nothing) lV <- listVersions Nothing [] False True (Nothing, Nothing)
pure $ BrickData (reverse lV) pure $ BrickData (reverse lV)

4
ghcup.cabal
View File

@ -327,6 +327,8 @@ executable ghcup
, brick ^>=2.1 , brick ^>=2.1
, transformers ^>=0.5 , transformers ^>=0.5
, vty ^>=6.0 , vty ^>=6.0
, unix ^>=2.7
, optics ^>=0.4
if os(windows) if os(windows)
cpp-options: -DIS_WINDOWS cpp-options: -DIS_WINDOWS
@ -352,7 +354,7 @@ test-suite ghcup-test
default-language: Haskell2010 default-language: Haskell2010
default-extensions: default-extensions:
LambdaCase LambdaCase
MultiWayIf MultiWayIf++-
PackageImports PackageImports
RecordWildCards RecordWildCards
ScopedTypeVariables ScopedTypeVariables