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

Browse Source
This commit is contained in:
Luis Morillo 2023-07-19 08:24:35 +02:00
parent d64bb1db1e
commit e2341bf50d
2 changed files with 108 additions and 137 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

241
app/ghcup/BrickMain.hs
View File

@ -5,6 +5,7 @@
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE TemplateHaskell #-}
module BrickMain where module BrickMain where
@ -25,7 +26,7 @@ import Brick
import Brick.Widgets.Border import Brick.Widgets.Border
import Brick.Widgets.Border.Style import Brick.Widgets.Border.Style
import Brick.Widgets.Center import Brick.Widgets.Center
import Brick.Widgets.Dialog (Dialog, dialog, renderDialog, handleDialogEvent, buttonSelectedAttr, dialogSelection) import Brick.Widgets.Dialog (buttonSelectedAttr)
import Brick.Widgets.List ( listSelectedFocusedAttr import Brick.Widgets.List ( listSelectedFocusedAttr
, listSelectedAttr , listSelectedAttr
, listAttr , listAttr
@ -42,7 +43,7 @@ import Data.Bool
import Data.Functor import Data.Functor
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
, (!?) , (!?)
) )
@ -62,90 +63,84 @@ import qualified Graphics.Vty as Vty
import qualified Data.Vector as V import qualified Data.Vector as V
import System.Environment (getExecutablePath) import System.Environment (getExecutablePath)
import qualified System.Posix.Process as SPP import qualified System.Posix.Process as SPP
import qualified Lens.Micro as Micro import Lens.Micro.TH (makeLenses)
import Lens.Micro.Mtl ( (.=), use, (%=), view )
import Lens.Micro ((.~), (&))
hiddenTools :: [Tool] hiddenTools :: [Tool]
hiddenTools = [] hiddenTools = []
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 , _showAllTools :: Bool
} }
--deriving Show --deriving Show
data PopUp = PopUp {isVisible :: Bool, popUpDialog :: Dialog Bool String, selectedValue :: Maybe Bool} makeLenses ''BrickSettings
data BrickInternalState = BrickInternalState data BrickInternalState = BrickInternalState
{ clr :: Vector ListResult { _clr :: Vector ListResult
, ix :: Int , _ix :: Int
, popUp :: PopUp
} }
--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
popUpL :: Micro.Lens' BrickState (Dialog Bool String) makeLenses ''BrickState
popUpL = Micro.lens
(popUpDialog . popUp . appState)
(\(BrickState {appState = BrickInternalState {popUp = PopUp {..}, ..}, ..}) dg -> BrickState{appState = BrickInternalState{popUp = PopUp {popUpDialog=dg, ..}, ..}, ..} )
isPopUpVisible :: BrickState -> Bool
isPopUpVisible (BrickState _ _ (BrickInternalState _ _ popup) _) = isVisible popup
updateWithSelection :: BrickState -> BrickState
updateWithSelection BrickState{appState=BrickInternalState{popUp = PopUp _ d _, ..},..}
= BrickState{appState=BrickInternalState{popUp = PopUp False d (snd <$> dialogSelection d),..},..}
makePopUpVisible :: BrickState -> BrickState
makePopUpVisible BrickState{appState=BrickInternalState{popUp = PopUp _ b c, ..},..}
= BrickState{appState=BrickInternalState{popUp = PopUp True b c,..},..}
viewSelection :: BrickState -> Bool
viewSelection = fromMaybe False . selectedValue . popUp . appState
keyHandlers :: KeyBindings keyHandlers :: KeyBindings
-> [ ( Vty.Key -> [ ( Vty.Key
, 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" , \_ -> modify makePopUpVisible) , (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) showAllTools , hideShowHandler' (not . _showAllVersions) _showAllTools
) )
, ( bShowAllTools , ( bShowAllTools
, \BrickSettings {..} -> , \BrickSettings {..} ->
if showAllTools then "Don't show all tools" else "Show all tools" if _showAllTools then "Don't show all tools" else "Show all tools"
, hideShowHandler showAllVersions (not . showAllTools) , hideShowHandler' _showAllVersions (not . _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 p BrickState{..} = --hideShowHandler' :: (BrickSettings -> Bool) -> (BrickSettings -> Bool) -> m ()
let newAppSettings = appSettings { showAllVersions = f appSettings , showAllTools = p 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
@ -154,22 +149,12 @@ showKey Vty.KUp = "↑"
showKey Vty.KDown = "↓" showKey Vty.KDown = "↓"
showKey key = tail (show key) showKey key = tail (show key)
-- | This is the Dialog. It includes only the buttons, their labels, and bounded values
afterInstallPopUp :: PopUp
afterInstallPopUp = PopUp False yes_no_dialog Nothing
where yes_no_dialog = dialog Nothing (Just ("YesButton", [("Yes", "YesButton", True), ("No", "NoButton", False)])) 40
-- | This is used to render the dialog, if it exists, else, just draw nothing
renderPopUp :: PopUp -> Widget String
renderPopUp (PopUp False _ _) = emptyWidget
renderPopUp (PopUp True d _) = renderDialog d (txtWrap "Do you want to set the installed tool as the default?")
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
@ -180,7 +165,7 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
. T.pack . T.pack
. foldr1 (\x y -> x <> " " <> y) . foldr1 (\x y -> x <> " " <> y)
. fmap (\(key, s, _) -> showKey key <> ":" <> s as) . fmap (\(key, s, _) -> showKey key <> ":" <> 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")
@ -188,8 +173,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
@ -266,7 +251,7 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
-> Bool -> Bool
-> BrickInternalState -> BrickInternalState
-> Widget String -> Widget String
drawListElements drawElem foc is@(BrickInternalState clr _ _) = drawListElements drawElem foc is@(BrickInternalState clr _) =
Widget Greedy Greedy $ Widget Greedy Greedy $
let let
es = clr es = clr
@ -295,10 +280,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 e String app :: AttrMap -> AttrMap -> App BrickState () String
app attrs dimAttrs = app attrs dimAttrs =
App { appDraw = \st -> [renderPopUp (popUp . appState $ 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
@ -344,58 +329,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.EvKey Vty.KEnter [])) | isPopUpVisible st -> modify updateWithSelection >> (gets viewSelection >>= \isSet -> installAndSet isSet st) (VtyEvent (Vty.EvKey Vty.KDown _)) -> appState %= moveCursor 1 Down
(VtyEvent e) | isPopUpVisible st -> zoom popUpL (handleDialogEvent e)
(VtyEvent (Vty.EvResize _ _)) -> put st
(VtyEvent (Vty.EvKey Vty.KUp _)) ->
put BrickState{ appState = moveCursor 1 appState Up, .. }
(VtyEvent (Vty.EvKey Vty.KDown _)) ->
put BrickState{ appState = moveCursor 1 appState Down, .. }
(VtyEvent (Vty.EvKey key _)) -> (VtyEvent (Vty.EvKey key _)) ->
case find (\(key', _, _) -> key' == key) (keyHandlers kb) of case find (\(key', _, _) -> key' == key) (keyHandlers kb) of
Nothing -> put st Nothing -> pure ()
Just (_, _, handler) -> handler st Just (_, _, handler) -> handler
_ -> put st _ -> pure ()
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.
@ -403,11 +381,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
} }
@ -416,12 +394,12 @@ constructList :: BrickData
-> Maybe BrickInternalState -> Maybe BrickInternalState
-> BrickInternalState -> BrickInternalState
constructList appD appSettings = constructList appD appSettings =
replaceLR (filterVisible (showAllVersions appSettings) replaceLR (filterVisible (_showAllVersions appSettings)
(showAllTools appSettings)) (_showAllTools appSettings))
(lr appD) (_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
@ -442,7 +420,7 @@ replaceLR filterF lr s =
case oldElem >>= \(_, oldE) -> V.findIndex (toolEqual oldE) newVec of case oldElem >>= \(_, oldE) -> V.findIndex (toolEqual oldE) newVec of
Just ix -> ix Just ix -> ix
Nothing -> selectLatest newVec Nothing -> selectLatest newVec
in BrickInternalState newVec newSelected afterInstallPopUp in BrickInternalState newVec newSelected
where where
toolEqual e1 e2 = toolEqual e1 e2 =
lTool e1 == lTool e2 && lVer e1 == lVer e2 && lCross e1 == lCross e2 lTool e1 == lTool e2 && lVer e1 == lVer e2 && lCross e1 == lCross e2
@ -466,17 +444,10 @@ filterVisible v t e | lInstalled e = True
(lTool e `notElem` hiddenTools) (lTool e `notElem` hiddenTools)
installAndSet :: Bool -> BrickState -> EventM String BrickState ()
installAndSet b brickstate = do
withIOAction install' brickstate
when b (get >>= withIOAction set')
install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO 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 =
@ -550,10 +521,9 @@ install' _ (_, ListResult {..}) = do
set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m) set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO 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 =
@ -575,12 +545,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
@ -595,10 +565,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]
@ -622,10 +591,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 $
@ -681,7 +649,7 @@ brickMain s = do
defaultAppSettings :: BrickSettings defaultAppSettings :: BrickSettings
defaultAppSettings = BrickSettings { showAllVersions = False, showAllTools = False } defaultAppSettings = BrickSettings { _showAllVersions = False, _showAllTools = False }
getGHCupInfo :: IO (Either String GHCupInfo) getGHCupInfo :: IO (Either String GHCupInfo)
@ -708,3 +676,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)

2
ghcup.cabal
View File

@ -353,6 +353,8 @@ executable ghcup
, unix ^>=2.7 , unix ^>=2.7
, vty ^>=5.37 , vty ^>=5.37
, microlens ^>=0.4.13 , microlens ^>=0.4.13
, microlens-th ^>=0.4.3
, microlens-mtl ^>=0.2.0
if os(windows) if os(windows)
cpp-options: -DIS_WINDOWS cpp-options: -DIS_WINDOWS