From aa9fbdbfc2c2ca91c211e5a533296a7b01576e08 Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Tue, 11 Jul 2023 18:55:10 +0200 Subject: [PATCH 1/8] Use MonadState Instance to simplify install', del', set' and changelog'. Lensify the app --- app/ghcup/BrickMain.hs | 400 +++++++++++++++++++++++++++++++---------- ghcup.cabal | 4 +- 2 files changed, 304 insertions(+), 100 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 5f3cc06..46eabc2 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -7,6 +7,9 @@ {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-unused-record-wildcards #-} {-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} module BrickMain where @@ -22,14 +25,57 @@ import GHCup.Prelude.Logger import GHCup.Prelude.Process import GHCup.Prompts -import Brick -import Brick.Widgets.Border -import Brick.Widgets.Border.Style -import Brick.Widgets.Center +import Brick + ( defaultMain, + suspendAndResume, + 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 , listSelectedAttr , listAttr ) +import qualified Brick.Widgets.List as L +import Brick.Focus (FocusRing) +import qualified Brick.Focus as F import Codec.Archive import Control.Applicative import Control.Exception.Safe @@ -41,9 +87,10 @@ import Control.Monad.Trans.Except import Control.Monad.Trans.Resource import Data.Bool import Data.Functor +import Data.Function ( (&)) import Data.List import Data.Maybe -import Data.IORef +import Data.IORef (IORef, readIORef, newIORef, writeIORef, modifyIORef) import Data.Vector ( Vector , (!?) ) @@ -67,6 +114,153 @@ import System.FilePath import qualified System.Posix.Process as SPP #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 #if IS_WINDOWS @@ -91,55 +285,71 @@ notInstalledSign = "✗ " data BrickData = BrickData - { lr :: [ListResult] + { _lr :: [ListResult] } deriving Show +makeLenses ''BrickData + data BrickSettings = BrickSettings - { showAllVersions :: Bool + { _showAllVersions :: Bool + , _showAllTools :: Bool } - deriving Show + --deriving Show + +makeLenses ''BrickSettings data BrickInternalState = BrickInternalState - { clr :: Vector ListResult - , ix :: Int + { _clr :: Vector ListResult + , _ix :: Int } - deriving Show + --deriving Show + +makeLenses ''BrickInternalState data BrickState = BrickState - { appData :: BrickData - , appSettings :: BrickSettings - , appState :: BrickInternalState - , appKeys :: KeyBindings + { _appData :: BrickData + , _appSettings :: BrickSettings + , _appState :: BrickInternalState + , _appKeys :: KeyBindings } - deriving Show + --deriving Show +makeLenses ''BrickState keyHandlers :: KeyBindings -> [ ( KeyCombination , BrickSettings -> String - , BrickState -> EventM String BrickState () + , EventM String BrickState () ) ] keyHandlers KeyBindings {..} = - [ (bQuit, const "Quit" , \_ -> halt) + [ (bQuit, const "Quit" , 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) + if _showAllVersions then "Don't show all versions" else "Show all versions" + , hideShowHandler' (not . _showAllVersions) _showAllTools ) - , (bUp, const "Up", \BrickState {..} -> put BrickState{ appState = moveCursor 1 appState Up, .. }) - , (bDown, const "Down", \BrickState {..} -> put BrickState{ appState = moveCursor 1 appState Down, .. }) + , (bUp, const "Up", appState %= moveCursor 1 Up) + , (bDown, const "Down", appState %= moveCursor 1 Down) ] where - hideShowHandler f BrickState{..} = - let newAppSettings = appSettings { showAllVersions = f appSettings } - newInternalState = constructList appData newAppSettings (Just appState) - in put (BrickState appData newAppSettings newInternalState appKeys) + --hideShowHandler' :: (BrickSettings -> Bool) -> (BrickSettings -> Bool) -> m () + hideShowHandler' f p = do + app_settings <- use appSettings + 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 @@ -153,11 +363,11 @@ showMod = tail . show ui :: AttrMap -> BrickState -> Widget String -ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..} +ui dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..} = padBottom Max ( withBorderStyle unicode $ borderWithLabel (str "GHCup") - (center (header <=> hBorder <=> renderList' appState)) + (center (header <=> hBorder <=> renderList' _appState)) ) <=> footer @@ -168,7 +378,7 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..} . T.pack . foldr1 (\x y -> x <> " " <> y) . fmap (\(KeyCombination key mods, s, _) -> intercalate "+" (showKey key : (showMod <$> mods)) <> ":" <> s as) - $ keyHandlers appKeys + $ keyHandlers _appKeys header = minHSize 2 emptyWidget <+> 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 5) (str "Notes") renderList' bis@BrickInternalState{..} = - 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 + 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 in withDefAttr listAttr . drawListElements (renderItem minTagSize minVerSize) True $ bis renderItem minTagSize minVerSize _ b listResult@ListResult{lTag = lTag', ..} = let marks = if @@ -283,11 +493,10 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..} minHSize :: Int -> Widget n -> Widget n minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ') - -app :: AttrMap -> AttrMap -> App BrickState e String +app :: AttrMap -> AttrMap -> App BrickState () String app attrs dimAttrs = - App { appDraw = \st -> [ui dimAttrs st] - , appHandleEvent = \be -> get >>= \s -> eventHandler s be + App { appDraw = \st -> [ui dimAttrs st] + , appHandleEvent = eventHandler , appStartEvent = return () , appAttrMap = const attrs , appChooseCursor = showFirstCursor @@ -312,6 +521,7 @@ defaultAttributes no_color = attrMap , (attrName "day" , Vty.defAttr `withForeColor` Vty.blue) , (attrName "help" , Vty.defAttr `withStyle` Vty.italic) , (attrName "hooray" , Vty.defAttr `withForeColor` Vty.brightWhite) + , (buttonSelectedAttr , Vty.defAttr `withBackColor` Vty.brightWhite) ] where withForeColor | no_color = const @@ -332,56 +542,51 @@ dimAttributes no_color = attrMap withBackColor | no_color = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo | otherwise = Vty.withBackColor -eventHandler :: BrickState -> BrickEvent String e -> EventM String BrickState () -eventHandler st@BrickState{..} ev = do +eventHandler :: BrickEvent String e -> EventM String BrickState () +eventHandler ev = do AppState { keyBindings = kb } <- liftIO $ readIORef settings' case ev of - (MouseDown _ Vty.BScrollUp _ _) -> - put (BrickState { appState = moveCursor 1 appState Up, .. }) - (MouseDown _ Vty.BScrollDown _ _) -> - put (BrickState { appState = moveCursor 1 appState Down, .. }) - (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 mods)) -> - case find (\(keyCombo, _, _) -> keyCombo == KeyCombination key mods) (keyHandlers kb) of - Nothing -> put st - Just (_, _, handler) -> handler st - _ -> put st + (MouseDown _ Vty.BScrollUp _ _) -> appState %= moveCursor 1 Up + (MouseDown _ Vty.BScrollDown _ _) -> appState %= moveCursor 1 Down + (VtyEvent (Vty.EvResize _ _)) -> pure () + (VtyEvent (Vty.EvKey Vty.KUp _)) -> appState %= moveCursor 1 Up + (VtyEvent (Vty.EvKey Vty.KDown _)) -> appState %= moveCursor 1 Down + (VtyEvent (Vty.EvKey key _)) -> + case find (\(key', _, _) -> key' == key) (keyHandlers kb) of + Nothing -> pure () + Just (_, _, handler) -> handler + _ -> pure () -moveCursor :: Int -> BrickInternalState -> Direction -> BrickInternalState -moveCursor steps ais@BrickInternalState{..} direction = - let newIx = if direction == Down then ix + steps else ix - steps - in case clr !? newIx of - Just _ -> BrickInternalState { ix = newIx, .. } +moveCursor :: Int -> Direction -> BrickInternalState -> BrickInternalState +moveCursor steps direction ais@BrickInternalState{..} = + let newIx = if direction == Down then _ix + steps else _ix - steps + in case _clr !? newIx of + Just _ -> ais & ix .~ newIx Nothing -> ais -- | 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. withIOAction :: Ord n - => (BrickState - -> (Int, ListResult) - -> ReaderT AppState IO (Either String a)) - -> BrickState + => ( (Int, ListResult) -> ReaderT AppState IO (Either String a)) -> EventM n BrickState () -withIOAction action as = case listSelectedElement' (appState as) of - Nothing -> put as - Just (ix, e) -> do - suspendAndResume $ do - settings <- readIORef settings' - flip runReaderT settings $ action as (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 +withIOAction action = do + as <- get + case listSelectedElement' (view appState as) of + Nothing -> pure () + Just (curr_ix, e) -> do + 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 -- | 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@. updateList :: BrickData -> BrickState -> BrickState updateList appD BrickState{..} = - let newInternalState = constructList appD appSettings (Just appState) - in BrickState { appState = newInternalState - , appData = appD - , appSettings = appSettings - , appKeys = appKeys + let newInternalState = constructList appD _appSettings (Just _appState) + in BrickState { _appState = newInternalState + , _appData = appD + , _appSettings = _appSettings + , _appKeys = _appKeys } @@ -402,11 +607,12 @@ constructList :: BrickData -> Maybe BrickInternalState -> BrickInternalState constructList appD appSettings = - replaceLR (filterVisible (showAllVersions appSettings)) - (lr appD) + replaceLR (filterVisible (_showAllVersions appSettings) + (_showAllTools appSettings)) + (_lr appD) listSelectedElement' :: BrickInternalState -> Maybe (Int, ListResult) -listSelectedElement' BrickInternalState{..} = fmap (ix, ) $ clr !? ix +listSelectedElement' BrickInternalState{..} = fmap (_ix, ) $ _clr !? _ix selectLatest :: Vector ListResult -> Int @@ -444,11 +650,10 @@ filterVisible v e | lInstalled e = True (Nightly `notElem` lTag e) -install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m) - => BrickState - -> (Int, ListResult) +install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m) + => (Int, ListResult) -> m (Either String ()) -install' _ (_, ListResult {..}) = do +install' (_, ListResult {..}) = do AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask 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) - => BrickState - -> (Int, ListResult) + => (Int, ListResult) -> m (Either String ()) -set' bs input@(_, ListResult {..}) = do +set' input@(_, ListResult {..}) = do settings <- liftIO $ readIORef settings' let run = @@ -588,12 +792,12 @@ set' bs input@(_, ListResult {..}) = do promptAnswer <- getUserPromptResponse userPrompt case promptAnswer of PromptYes -> do - res <- install' bs input + res <- install' input case res of (Left err) -> pure $ Left err (Right _) -> do logInfo "Setting now..." - set' bs input + set' input PromptNo -> pure $ Left (prettyHFError e) where @@ -608,10 +812,9 @@ set' bs input@(_, ListResult {..}) = do del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m) - => BrickState - -> (Int, ListResult) + => (Int, ListResult) -> m (Either String ()) -del' _ (_, ListResult {..}) = do +del' (_, ListResult {..}) = do AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask let run = runE @'[NotInstalled, UninstallFailed] @@ -635,10 +838,9 @@ del' _ (_, ListResult {..}) = do changelog' :: (MonadReader AppState m, MonadIO m) - => BrickState - -> (Int, ListResult) + => (Int, ListResult) -> m (Either String ()) -changelog' _ (_, ListResult {..}) = do +changelog' (_, ListResult {..}) = do AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask case getChangeLog dls lTool (ToolVersion lVer) of Nothing -> pure $ Left $ @@ -671,7 +873,6 @@ settings' = unsafePerformIO $ do loggerConfig - brickMain :: AppState -> IO () brickMain s = do @@ -695,7 +896,7 @@ brickMain s = do defaultAppSettings :: BrickSettings -defaultAppSettings = BrickSettings { showAllVersions = False } +defaultAppSettings = BrickSettings { _showAllVersions = False, _showAllTools = False } getGHCupInfo :: IO (Either String GHCupInfo) @@ -724,3 +925,4 @@ getAppData mgi = runExceptT $ do flip runReaderT settings $ do lV <- listVersions Nothing [] False True (Nothing, Nothing) pure $ BrickData (reverse lV) + diff --git a/ghcup.cabal b/ghcup.cabal index 3824c08..6ec8a4f 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -327,6 +327,8 @@ executable ghcup , brick ^>=2.1 , transformers ^>=0.5 , vty ^>=6.0 + , unix ^>=2.7 + , optics ^>=0.4 if os(windows) cpp-options: -DIS_WINDOWS @@ -352,7 +354,7 @@ test-suite ghcup-test default-language: Haskell2010 default-extensions: LambdaCase - MultiWayIf + MultiWayIf++- PackageImports RecordWildCards ScopedTypeVariables From 1353a2fd2077b3d328b445b188adaed1d7957aa7 Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Sun, 8 Oct 2023 17:11:32 +0200 Subject: [PATCH 2/8] use map-like data structure --- app/ghcup/BrickMain.hs | 397 +++++++++++++++++------------------------ ghcup.cabal | 2 +- 2 files changed, 164 insertions(+), 235 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 46eabc2..456c8b4 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -26,53 +26,21 @@ import GHCup.Prelude.Process import GHCup.Prompts import Brick - ( defaultMain, - suspendAndResume, - attrMap, - showFirstCursor, - hLimit, - vBox, - viewport, - visible, - fill, - vLimit, - forceAttr, - putCursor, - updateAttrMap, - withDefAttr, - padLeft, - (<+>), - emptyWidget, - txtWrap, - attrName, - withAttr, - (<=>), - str, - withBorderStyle, - padBottom, - halt, - BrickEvent(VtyEvent, MouseDown), + ( 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 ) + Size(..), + Named(..), + Widget(..), + ViewportType (Vertical), + (<+>), + (<=>)) +import qualified Brick +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 - , listSelectedAttr - , listAttr - ) import qualified Brick.Widgets.List as L import Brick.Focus (FocusRing) import qualified Brick.Focus as F @@ -87,12 +55,12 @@ import Control.Monad.Trans.Except import Control.Monad.Trans.Resource import Data.Bool import Data.Functor -import Data.Function ( (&)) +import Data.Function ( (&), on) import Data.List import Data.Maybe import Data.IORef (IORef, readIORef, newIORef, writeIORef, modifyIORef) import Data.Vector ( Vector - , (!?) + ) import Data.Versions import Haskus.Utils.Variant.Excepts @@ -117,10 +85,9 @@ import qualified System.Posix.Process as SPP import Optics.TH (makeLenses, makeLensesFor) import Optics.State (use) import Optics.State.Operators ( (.=), (%=), (<%=)) -import Optics.Optic ((%)) -import Optics.Operators ((.~), (^.)) +import Optics.Operators ((.~), (^.), (%~)) import Optics.Getter (view) -import Optics.Lens (Lens', lens, toLensVL, lensVL) +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) @@ -179,20 +146,8 @@ sectionL section_name = lens g s 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 +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 () @@ -205,9 +160,11 @@ handleGenericListEvent (VtyEvent ev@(Vty.EvKey Vty.KDown [])) = 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 + 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 () @@ -219,13 +176,32 @@ handleGenericListEvent (VtyEvent ev@(Vty.EvKey Vty.KUp [])) = 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 + 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 () - Just l -> zoom (toLensVL $ sectionL l) $ L.handleListEvent ev + Just l -> Brick.zoom (toLensVL $ sectionL l) $ L.handleListEvent ev handleGenericListEvent _ = pure () -- This re-uses Brick.Widget.List.renderList @@ -236,18 +212,22 @@ renderSectionList :: (Traversable t, Ord n, Show n, Eq n, L.Splittable t) -> 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 +renderSectionList render_separator render_border render_elem section_focus (GenericSectionList focus elms sl_name) = + Widget Greedy Greedy $ render $ + Brick.viewport sl_name Vertical $ + V.foldl' (\wacc list -> + let has_focus_list = is_focused_section list + list_name = L.listName list + in wacc + <=> render_separator has_focus_list list_name + <=> inner_widget has_focus_list list_name list + ) + Brick.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) + inner_widget has_focus k l = + let w = render_border has_focus k (Brick.vLimit (length l) $ L.renderList render_elem has_focus l) + in if has_focus then Brick.visible w else w -- | Equivalent to listSelectedElement @@ -261,6 +241,7 @@ sectionListSelectedElement generic_section_list = do -} +type Name = String installedSign :: String #if IS_WINDOWS @@ -299,13 +280,7 @@ data BrickSettings = BrickSettings makeLenses ''BrickSettings -data BrickInternalState = BrickInternalState - { _clr :: Vector ListResult - , _ix :: Int - } - --deriving Show - -makeLenses ''BrickInternalState +type BrickInternalState = SectionList Name ListResult data BrickState = BrickState { _appData :: BrickData @@ -324,7 +299,7 @@ keyHandlers :: KeyBindings ) ] keyHandlers KeyBindings {..} = - [ (bQuit, const "Quit" , halt) + [ (bQuit, const "Quit" , Brick.halt) , (bInstall, const "Install" , withIOAction install') , (bUninstall, const "Uninstall", withIOAction del') , (bSet, const "Set" , withIOAction set') @@ -348,7 +323,7 @@ keyHandlers KeyBindings {..} = ad <- use appData current_app_state <- use appState appSettings .= newAppSettings - appState .= constructList ad app_settings (Just current_app_state) + appState .= constructList ad newAppSettings (Just current_app_state) @@ -364,36 +339,38 @@ showMod = tail . show ui :: AttrMap -> BrickState -> Widget String ui dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..} - = padBottom Max - ( withBorderStyle unicode - $ borderWithLabel (str "GHCup") - (center (header <=> hBorder <=> renderList' _appState)) + = Brick.padBottom Max + ( Brick.withBorderStyle unicode + $ borderWithLabel (Brick.str "GHCup") + (center (header <=> renderList' _appState)) ) <=> footer - where footer = - withAttr (attrName "help") - . txtWrap + Brick.withAttr (Brick.attrName "help") + . Brick.txtWrap . T.pack . foldr1 (\x y -> x <> " " <> y) . fmap (\(KeyCombination key mods, s, _) -> intercalate "+" (showKey key : (showMod <$> mods)) <> ":" <> s as) $ keyHandlers _appKeys header = - minHSize 2 emptyWidget - <+> padLeft (Pad 2) (minHSize 6 $ str "Tool") - <+> minHSize 15 (str "Version") - <+> padLeft (Pad 1) (minHSize 25 $ str "Tags") - <+> padLeft (Pad 5) (str "Notes") - renderList' bis@BrickInternalState{..} = - 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 - in withDefAttr listAttr . drawListElements (renderItem minTagSize minVerSize) True $ bis - renderItem minTagSize minVerSize _ b listResult@ListResult{lTag = lTag', ..} = + 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 + render_separator _ _ = hBorder + render_border _ _ = id + in Brick.withDefAttr L.listAttr $ renderSectionList render_separator render_border (renderItem minTagSize minVerSize) True bis + renderItem minTagSize minVerSize b listResult@ListResult{lTag = lTag', ..} = let marks = if - | lSet -> (withAttr (attrName "set") $ str setSign) - | lInstalled -> (withAttr (attrName "installed") $ str installedSign) - | otherwise -> (withAttr (attrName "not-installed") $ str notInstalledSign) + | lSet -> (Brick.withAttr (Brick.attrName "set") $ str setSign) + | lInstalled -> (Brick.withAttr (Brick.attrName "installed") $ str installedSign) + | otherwise -> (Brick.withAttr (Brick.attrName "not-installed") $ str notInstalledSign) ver = case lCross of Nothing -> T.unpack . prettyVer $ lVer Just c -> T.unpack (c <> "-" <> prettyVer lVer) @@ -401,97 +378,59 @@ ui dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..} | lNoBindist && not lInstalled && not b -- TODO: overloading dim and active ignores active -- so we hack around it here - = updateAttrMap (const dimAttrs) . withAttr (attrName "no-bindist") + = Brick.updateAttrMap (const dimAttrs) . Brick.withAttr (Brick.attrName "no-bindist") | otherwise = id hooray | elem Latest lTag' && not lInstalled = - withAttr (attrName "hooray") + Brick.withAttr (Brick.attrName "hooray") | otherwise = id - active = if b then putCursor "GHCup" (Location (0,0)) . forceAttr (attrName "active") else id - in hooray $ active $ dim + in hooray $ dim ( marks - <+> padLeft (Pad 2) + <+> Brick.padLeft (Pad 2) ( minHSize 6 (printTool lTool) ) - <+> minHSize minVerSize (str ver) + <+> minHSize minVerSize (Brick.str ver) <+> (let l = catMaybes . fmap printTag $ sort lTag' - in padLeft (Pad 1) $ minHSize minTagSize $ if null l - then emptyWidget - else foldr1 (\x y -> x <+> str "," <+> y) l + in Brick.padLeft (Pad 1) $ minHSize minTagSize $ if null l + then Brick.emptyWidget + else foldr1 (\x y -> x <+> Brick.str "," <+> y) l ) - <+> padLeft (Pad 5) + <+> Brick.padLeft (Pad 5) ( let notes = printNotes listResult in if null notes - then emptyWidget - else foldr1 (\x y -> x <+> str "," <+> y) notes + then Brick.emptyWidget + else foldr1 (\x y -> x <+> Brick.str "," <+> y) notes ) - <+> vLimit 1 (fill ' ') + <+> Brick.vLimit 1 (Brick.fill ' ') ) - printTag Recommended = Just $ withAttr (attrName "recommended") $ str "recommended" - printTag Latest = Just $ withAttr (attrName "latest") $ str "latest" - printTag Prerelease = Just $ withAttr (attrName "prerelease") $ str "prerelease" - printTag Nightly = Just $ withAttr (attrName "nightly") $ str "nightly" - printTag (Base pvp'') = Just $ str ("base-" ++ T.unpack (prettyPVP pvp'')) + printTag Recommended = Just $ Brick.withAttr (Brick.attrName "recommended") $ Brick.str "recommended" + printTag Latest = Just $ Brick.withAttr (Brick.attrName "latest") $ Brick.str "latest" + printTag Prerelease = Just $ Brick.withAttr (Brick.attrName "prerelease") $ Brick.str "prerelease" + printTag Nightly = Just $ Brick.withAttr (Brick.attrName "nightly") $ Brick.str "nightly" + printTag (Base pvp'') = Just $ Brick.str ("base-" ++ T.unpack (prettyPVP pvp'')) printTag Old = Nothing - printTag LatestPrerelease = Just $ withAttr (attrName "latest-prerelease") $ str "latest-prerelease" - printTag LatestNightly = Just $ withAttr (attrName "latest-nightly") $ str "latest-nightly" - printTag (UnknownTag t) = Just $ str t + printTag LatestPrerelease = Just $ Brick.withAttr (Brick.attrName "latest-prerelease") $ Brick.str "latest-prerelease" + printTag LatestNightly = Just $ Brick.withAttr (Brick.attrName "latest-nightly") $ Brick.str "latest-nightly" + printTag (UnknownTag t) = Just $ Brick.str t - printTool Cabal = str "cabal" - printTool GHC = str "GHC" - printTool GHCup = str "GHCup" - printTool HLS = str "HLS" - printTool Stack = str "Stack" + 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" printNotes ListResult {..} = - (if hlsPowered then [withAttr (attrName "hls-powered") $ str "hls-powered"] else mempty + (if hlsPowered then [Brick.withAttr (Brick.attrName "hls-powered") $ Brick.str "hls-powered"] else mempty ) - ++ (if lStray then [withAttr (attrName "stray") $ str "stray"] else mempty) + ++ (if lStray then [Brick.withAttr (Brick.attrName "stray") $ Brick.str "stray"] else mempty) ++ (case lReleaseDay of Nothing -> mempty - Just d -> [withAttr (attrName "day") $ str (show d)]) - - -- | Draws the list elements. - -- - -- Evaluates the underlying container up to, and a bit beyond, the - -- selected element. The exact amount depends on available height - -- for drawing and 'listItemHeight'. At most, it will evaluate up to - -- element @(i + h + 1)@ where @i@ is the selected index and @h@ is the - -- available height. - drawListElements :: (Int -> Bool -> ListResult -> Widget String) - -> Bool - -> BrickInternalState - -> Widget String - drawListElements drawElem foc is@(BrickInternalState clr _) = - Widget Greedy Greedy $ - let - es = clr - listSelected = fmap fst $ listSelectedElement' is - - drawnElements = flip V.imap es $ \i' e -> - let addSeparator w = case es !? (i' - 1) of - Just e' | lTool e' /= lTool e -> - hBorder <=> w - _ -> w - - isSelected = Just i' == listSelected - elemWidget = drawElem i' isSelected e - selItemAttr = if foc - then withDefAttr listSelectedFocusedAttr - else withDefAttr listSelectedAttr - makeVisible' = if isSelected then visible . selItemAttr else id - in addSeparator $ makeVisible' elemWidget - - in render - $ viewport "GHCup" Vertical - $ vBox - $ V.toList drawnElements - + Just d -> [Brick.withAttr (Brick.attrName "day") $ Brick.str (show d)]) minHSize :: Int -> Widget n -> Widget n -minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ') +minHSize s' = Brick.hLimit s' . Brick.vLimit 1 . (<+> Brick.fill ' ') app :: AttrMap -> AttrMap -> App BrickState () String app attrs dimAttrs = @@ -499,29 +438,29 @@ app attrs dimAttrs = , appHandleEvent = eventHandler , appStartEvent = return () , appAttrMap = const attrs - , appChooseCursor = showFirstCursor + , appChooseCursor = Brick.showFirstCursor } defaultAttributes :: Bool -> AttrMap -defaultAttributes no_color = attrMap +defaultAttributes no_color = Brick.attrMap Vty.defAttr - [ (attrName "active" , Vty.defAttr `withBackColor` Vty.blue) - , (attrName "not-installed" , Vty.defAttr `withForeColor` Vty.red) - , (attrName "set" , Vty.defAttr `withForeColor` Vty.green) - , (attrName "installed" , Vty.defAttr `withForeColor` Vty.green) - , (attrName "recommended" , Vty.defAttr `withForeColor` Vty.green) - , (attrName "hls-powered" , Vty.defAttr `withForeColor` Vty.green) - , (attrName "latest" , Vty.defAttr `withForeColor` Vty.yellow) - , (attrName "latest-prerelease" , Vty.defAttr `withForeColor` Vty.red) - , (attrName "latest-nightly" , Vty.defAttr `withForeColor` Vty.red) - , (attrName "prerelease" , Vty.defAttr `withForeColor` Vty.red) - , (attrName "nightly" , Vty.defAttr `withForeColor` Vty.red) - , (attrName "compiled" , Vty.defAttr `withForeColor` Vty.blue) - , (attrName "stray" , Vty.defAttr `withForeColor` Vty.blue) - , (attrName "day" , Vty.defAttr `withForeColor` Vty.blue) - , (attrName "help" , Vty.defAttr `withStyle` Vty.italic) - , (attrName "hooray" , Vty.defAttr `withForeColor` Vty.brightWhite) - , (buttonSelectedAttr , Vty.defAttr `withBackColor` Vty.brightWhite) + [ (L.listSelectedFocusedAttr , Vty.defAttr `withBackColor` Vty.blue) --, (attrName "active" , Vty.defAttr `withBackColor` Vty.blue) + , (L.listSelectedAttr , Vty.defAttr) -- we use list attributes for active. + , (Brick.attrName "not-installed" , Vty.defAttr `withForeColor` Vty.red) + , (Brick.attrName "set" , Vty.defAttr `withForeColor` Vty.green) + , (Brick.attrName "installed" , Vty.defAttr `withForeColor` Vty.green) + , (Brick.attrName "recommended" , Vty.defAttr `withForeColor` Vty.green) + , (Brick.attrName "hls-powered" , Vty.defAttr `withForeColor` Vty.green) + , (Brick.attrName "latest" , Vty.defAttr `withForeColor` Vty.yellow) + , (Brick.attrName "latest-prerelease" , Vty.defAttr `withForeColor` Vty.red) + , (Brick.attrName "latest-nightly" , Vty.defAttr `withForeColor` Vty.red) + , (Brick.attrName "prerelease" , Vty.defAttr `withForeColor` Vty.red) + , (Brick.attrName "nightly" , Vty.defAttr `withForeColor` Vty.red) + , (Brick.attrName "compiled" , Vty.defAttr `withForeColor` Vty.blue) + , (Brick.attrName "stray" , Vty.defAttr `withForeColor` Vty.blue) + , (Brick.attrName "day" , Vty.defAttr `withForeColor` Vty.blue) + , (Brick.attrName "help" , Vty.defAttr `withStyle` Vty.italic) + , (Brick.attrName "hooray" , Vty.defAttr `withForeColor` Vty.brightWhite) ] where withForeColor | no_color = const @@ -533,10 +472,10 @@ defaultAttributes no_color = attrMap withStyle = Vty.withStyle dimAttributes :: Bool -> AttrMap -dimAttributes no_color = attrMap +dimAttributes no_color = Brick.attrMap (Vty.defAttr `Vty.withStyle` Vty.dim) - [ (attrName "active" , Vty.defAttr `withBackColor` Vty.blue) -- has no effect ?? - , (attrName "no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim) + [ (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 @@ -546,37 +485,23 @@ eventHandler :: BrickEvent String e -> EventM String BrickState () eventHandler ev = do AppState { keyBindings = kb } <- liftIO $ readIORef settings' case ev of - (MouseDown _ Vty.BScrollUp _ _) -> appState %= moveCursor 1 Up - (MouseDown _ Vty.BScrollDown _ _) -> appState %= moveCursor 1 Down - (VtyEvent (Vty.EvResize _ _)) -> pure () - (VtyEvent (Vty.EvKey Vty.KUp _)) -> appState %= moveCursor 1 Up - (VtyEvent (Vty.EvKey Vty.KDown _)) -> appState %= moveCursor 1 Down - (VtyEvent (Vty.EvKey key _)) -> + inner_event@(VtyEvent (Vty.EvKey key _)) -> case find (\(key', _, _) -> key' == key) (keyHandlers kb) of - Nothing -> pure () + Nothing -> void $ Brick.zoom (toLensVL appState) $ handleGenericListEvent inner_event Just (_, _, handler) -> handler - _ -> pure () - - -moveCursor :: Int -> Direction -> BrickInternalState -> BrickInternalState -moveCursor steps direction ais@BrickInternalState{..} = - let newIx = if direction == Down then _ix + steps else _ix - steps - in case _clr !? newIx of - Just _ -> ais & ix .~ newIx - Nothing -> ais - + inner_event -> Brick.zoom (toLensVL appState) $ handleGenericListEvent inner_event -- | 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. -withIOAction :: Ord n +withIOAction :: (Ord n, Eq n) => ( (Int, ListResult) -> ReaderT AppState IO (Either String a)) -> EventM n BrickState () withIOAction action = do - as <- get - case listSelectedElement' (view appState as) of + as <- Brick.get + case sectionListSelectedElement (view appState as) of Nothing -> pure () Just (curr_ix, e) -> do - suspendAndResume $ do + Brick.suspendAndResume $ do settings <- readIORef settings' flip runReaderT settings $ action (curr_ix, e) >>= \case Left err -> liftIO $ putStrLn ("Error: " <> err) @@ -601,22 +526,28 @@ updateList appD BrickState{..} = , _appKeys = _appKeys } - constructList :: BrickData -> BrickSettings -> Maybe BrickInternalState -> BrickInternalState -constructList appD appSettings = - replaceLR (filterVisible (_showAllVersions appSettings) - (_showAllTools appSettings)) +constructList appD settings = + replaceLR (filterVisible (_showAllVersions settings) + (_showAllTools settings)) (_lr appD) -listSelectedElement' :: BrickInternalState -> Maybe (Int, ListResult) -listSelectedElement' BrickInternalState{..} = fmap (_ix, ) $ _clr !? _ix +-- | 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 (show tool) (view sectionListFocusRingL internal_state) + tool_lens = sectionL (show tool) + 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. - -selectLatest :: Vector ListResult -> Int -selectLatest = fromMaybe 0 . V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag) +-- | Select the latests GHC tool +selectLatest :: BrickInternalState -> BrickInternalState +selectLatest = selectBy GHC (elem Latest . lTag) -- | Replace the @appState@ or construct it based on a filter function @@ -626,14 +557,13 @@ replaceLR :: (ListResult -> Bool) -> [ListResult] -> Maybe BrickInternalState -> BrickInternalState -replaceLR filterF lr s = - let oldElem = s >>= listSelectedElement' - newVec = V.fromList . filter filterF $ lr - newSelected = - case oldElem >>= \(_, oldE) -> V.findIndex (toolEqual oldE) newVec of - Just ix -> ix - Nothing -> selectLatest newVec - in BrickInternalState newVec newSelected +replaceLR filterF list_result s = + let oldElem = s >>= sectionListSelectedElement -- Maybe (Int, e) + newVec = [(show $ lTool (head g), V.fromList g) | g <- groupBy ((==) `on` lTool ) (filter filterF list_result)] + newSectionList = sectionList "GHCupList" newVec 0 + in case oldElem of + Just (_, el) -> selectBy (lTool el) (toolEqual el) newSectionList + Nothing -> selectLatest newSectionList where toolEqual e1 e2 = lTool e1 == lTool e2 && lVer e1 == lVer e2 && lCross e1 == lCross e2 @@ -881,7 +811,7 @@ brickMain s = do eAppData <- getAppData (Just $ ghcupInfo s) case eAppData of Right ad -> - defaultMain + Brick.defaultMain (app (defaultAttributes (noColor $ settings s)) (dimAttributes (noColor $ settings s))) (BrickState ad defaultAppSettings @@ -925,4 +855,3 @@ getAppData mgi = runExceptT $ do flip runReaderT settings $ do lV <- listVersions Nothing [] False True (Nothing, Nothing) pure $ BrickData (reverse lV) - diff --git a/ghcup.cabal b/ghcup.cabal index 6ec8a4f..476eb8e 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -354,7 +354,7 @@ test-suite ghcup-test default-language: Haskell2010 default-extensions: LambdaCase - MultiWayIf++- + MultiWayIf PackageImports RecordWildCards ScopedTypeVariables From 8f4246e716301c2661d66d59452dfdf14dd316aa Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Tue, 10 Oct 2023 16:32:33 +0200 Subject: [PATCH 3/8] Use proper Name type and Modal type. Create tutorial Widget --- app/ghcup/BrickMain.hs | 86 +++++++++++++++++++++++++++++++++--------- 1 file changed, 69 insertions(+), 17 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 456c8b4..b9854e6 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -40,7 +40,7 @@ import Brick import qualified Brick import Brick.Widgets.Border ( hBorder, borderWithLabel) import Brick.Widgets.Border.Style ( unicode ) -import Brick.Widgets.Center ( center ) +import Brick.Widgets.Center ( center, centerLayer ) import qualified Brick.Widgets.List as L import Brick.Focus (FocusRing) import qualified Brick.Focus as F @@ -241,7 +241,13 @@ sectionListSelectedElement generic_section_list = do -} -type Name = String +data Name = AllTools -- The main list widget + | Singular Tool -- The particular list for each tool + | IODialog -- The pop up when installing a tool + | TutorialBox -- The tutorial widget + deriving (Eq, Ord, Show) + +data Mode = Navigation | Tutorial deriving (Eq, Show, Ord) installedSign :: String #if IS_WINDOWS @@ -287,6 +293,7 @@ data BrickState = BrickState , _appSettings :: BrickSettings , _appState :: BrickInternalState , _appKeys :: KeyBindings + , _mode :: Mode } --deriving Show @@ -295,7 +302,7 @@ makeLenses ''BrickState keyHandlers :: KeyBindings -> [ ( KeyCombination , BrickSettings -> String - , EventM String BrickState () + , EventM Name BrickState () ) ] keyHandlers KeyBindings {..} = @@ -311,6 +318,7 @@ keyHandlers KeyBindings {..} = ) , (bUp, const "Up", appState %= moveCursor 1 Up) , (bDown, const "Down", appState %= moveCursor 1 Down) + , (Vty.KChar 'x', const "Tutorial", mode .= Tutorial) ] where --hideShowHandler' :: (BrickSettings -> Bool) -> (BrickSettings -> Bool) -> m () @@ -337,7 +345,7 @@ showMod :: Vty.Modifier -> String showMod = tail . show -ui :: AttrMap -> BrickState -> Widget String +ui :: AttrMap -> BrickState -> Widget Name ui dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..} = Brick.padBottom Max ( Brick.withBorderStyle unicode @@ -432,14 +440,43 @@ ui dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..} minHSize :: Int -> Widget n -> Widget n minHSize s' = Brick.hLimit s' . Brick.vLimit 1 . (<+> Brick.fill ' ') -app :: AttrMap -> AttrMap -> App BrickState () String +app :: AttrMap -> AttrMap -> App BrickState () Name app attrs dimAttrs = - App { appDraw = \st -> [ui dimAttrs st] - , appHandleEvent = eventHandler - , appStartEvent = return () - , appAttrMap = const attrs - , appChooseCursor = Brick.showFirstCursor - } + App { appDraw = drawUI dimAttrs + , appHandleEvent = eventHandler + , appStartEvent = return () + , appAttrMap = const attrs + , appChooseCursor = Brick.showFirstCursor + } + + +drawUI :: AttrMap -> BrickState -> [Widget Name] +drawUI dimAttrs st = + case st ^. mode of + Navigation -> [ui dimAttrs st] + Tutorial -> + let tutorial = centerLayer + $ Brick.hLimitPercent 75 + $ Brick.vLimitPercent 50 + $ Brick.withBorderStyle unicode + $ borderWithLabel (Brick.txt "Tutorial") + $ Brick.vBox + [ Brick.txt "GHCup is a tool for managing your Haskell tooling." + , center (Brick.txt "--- o ---") + , Brick.txt "This symbol " + <+> Brick.withAttr (Brick.attrName "installed") (Brick.str "✓ ") + <+> Brick.txt " means that the tool is installed but not in used" + , Brick.txt "This symbol " + <+> Brick.withAttr (Brick.attrName "set") (Brick.str "✔✔") + <+> Brick.txt " means that the tool is installed and in used" + , Brick.txt "This symbol " + <+> Brick.withAttr (Brick.attrName "not-installed") (Brick.str "✗ ") + <+> Brick.txt " means that the tool isn't installed" + , center (Brick.txt "--- o ---") + , Brick.txt "Press Enter to exit the tutorial" + ] + in [tutorial, ui dimAttrs st] + defaultAttributes :: Bool -> AttrMap defaultAttributes no_color = Brick.attrMap @@ -481,8 +518,14 @@ dimAttributes no_color = Brick.attrMap withBackColor | no_color = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo | otherwise = Vty.withBackColor -eventHandler :: BrickEvent String e -> EventM String BrickState () -eventHandler ev = do +tutorialHandler :: BrickEvent Name e -> EventM Name BrickState () +tutorialHandler ev = + case ev of + VtyEvent (Vty.EvKey Vty.KEnter _) -> mode .= Navigation + _ -> pure () + +navigationHandler :: BrickEvent Name e -> EventM Name BrickState () +navigationHandler ev = do AppState { keyBindings = kb } <- liftIO $ readIORef settings' case ev of inner_event@(VtyEvent (Vty.EvKey key _)) -> @@ -491,6 +534,13 @@ eventHandler ev = do Just (_, _, handler) -> handler 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 + Navigation -> navigationHandler ev + Tutorial -> tutorialHandler ev + -- | 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. withIOAction :: (Ord n, Eq n) @@ -524,6 +574,7 @@ updateList appD BrickState{..} = , _appData = appD , _appSettings = _appSettings , _appKeys = _appKeys + , _mode = Navigation } constructList :: BrickData @@ -538,8 +589,8 @@ constructList appD settings = -- | 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 (show tool) (view sectionListFocusRingL internal_state) - tool_lens = sectionL (show tool) + let new_focus = F.focusSetCurrent (Singular tool) (view sectionListFocusRingL internal_state) + tool_lens = sectionL (Singular tool) in internal_state & sectionListFocusRingL .~ new_focus & tool_lens %~ L.listMoveTo 0 -- We move to 0 first @@ -559,8 +610,8 @@ replaceLR :: (ListResult -> Bool) -> BrickInternalState replaceLR filterF list_result s = let oldElem = s >>= sectionListSelectedElement -- Maybe (Int, e) - newVec = [(show $ lTool (head g), V.fromList g) | g <- groupBy ((==) `on` lTool ) (filter filterF list_result)] - newSectionList = sectionList "GHCupList" newVec 0 + newVec = [(Singular $ lTool (head g), V.fromList g) | g <- groupBy ((==) `on` lTool ) (filter filterF list_result)] + newSectionList = sectionList AllTools newVec 0 in case oldElem of Just (_, el) -> selectBy (lTool el) (toolEqual el) newSectionList Nothing -> selectLatest newSectionList @@ -817,6 +868,7 @@ brickMain s = do defaultAppSettings (constructList ad defaultAppSettings Nothing) (keyBindings (s :: AppState)) + Navigation ) $> () From 835352428a9501933dbb29c740c39439856be58f Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Sun, 5 Nov 2023 19:24:57 +0100 Subject: [PATCH 4/8] simplify rendering for better ux --- app/ghcup/BrickMain.hs | 72 ++++++++++++++++++++---------------------- 1 file changed, 35 insertions(+), 37 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index b9854e6..5377eb1 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -10,6 +10,7 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BangPatterns #-} module BrickMain where @@ -32,7 +33,6 @@ import Brick AttrMap, EventM, Size(..), - Named(..), Widget(..), ViewportType (Vertical), (<+>), @@ -62,7 +62,7 @@ import Data.IORef (IORef, readIORef, newIORef, writeIORef, modifyIORef import Data.Vector ( Vector ) -import Data.Versions +import Data.Versions hiding (Lens') import Haskus.Utils.Variant.Excepts import Prelude hiding ( appendFile ) import System.Exit @@ -114,9 +114,6 @@ makeLensesFor [("sectionListFocusRing", "sectionListFocusRingL"), ("sectionListE 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 @@ -206,29 +203,33 @@ 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 -> 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 sl_name) = - Widget Greedy Greedy $ render $ - Brick.viewport sl_name Vertical $ - V.foldl' (\wacc list -> - let has_focus_list = is_focused_section list - list_name = L.listName list - in wacc - <=> render_separator has_focus_list list_name - <=> inner_widget has_focus_list list_name list - ) - Brick.emptyWidget elms - where - is_focused_section l = section_focus && Just (L.listName l) == F.focusGetCurrent focus - inner_widget has_focus k l = - let w = render_border has_focus k (Brick.vLimit (length l) $ L.renderList render_elem has_focus l) - in if has_focus then Brick.visible w else w - +renderSectionList render_elem section_focus (GenericSectionList focus elms sl_name) = + Brick.Widget Brick.Greedy Brick.Greedy $ do + c <- Brick.getContext + let -- A section is focused if the whole thing is focused, and the inner list has focus + section_is_focused l = section_focus && (Just (L.listName l) == F.focusGetCurrent focus) + -- We need to limit the widget size when the length of the list is higher than the size of the terminal + limit = min (Brick.windowHeight c) (Brick.availHeight c) + s_idx = fromMaybe 0 $ V.findIndex section_is_focused elms + render_inner_list has_focus l = Brick.vLimit (length l) $ L.renderList (\b -> render_elem (b && has_focus)) has_focus l + (widget, off) = + V.ifoldl' (\wacc i list -> + let has_focus_list = section_is_focused list + (!acc_widget, !acc_off) = wacc + new_widget = if i == 0 then render_inner_list has_focus_list list else hBorder <=> render_inner_list has_focus_list list + new_off + | i < s_idx = 1 + L.listItemHeight list * length list + | i == s_idx = 1 + L.listItemHeight list * fromMaybe 0 (L.listSelected list) + | otherwise = 0 + in (acc_widget <=> new_widget, acc_off + new_off) + ) + (Brick.emptyWidget, 0) + elms + Brick.render $ Brick.viewport sl_name Brick.Vertical $ Brick.translateBy (Brick.Location (0, min 0 (limit-off))) widget -- | Equivalent to listSelectedElement sectionListSelectedElement :: (Eq n, L.Splittable t, Traversable t, Semigroup (t e)) => GenericSectionList n t e -> Maybe (Int, e) @@ -243,7 +244,6 @@ sectionListSelectedElement generic_section_list = do data Name = AllTools -- The main list widget | Singular Tool -- The particular list for each tool - | IODialog -- The pop up when installing a tool | TutorialBox -- The tutorial widget deriving (Eq, Ord, Show) @@ -318,7 +318,7 @@ keyHandlers KeyBindings {..} = ) , (bUp, const "Up", appState %= moveCursor 1 Up) , (bDown, const "Down", appState %= moveCursor 1 Down) - , (Vty.KChar 'x', const "Tutorial", mode .= Tutorial) + , (KeyCombination (Vty.KChar 'x') [], const "Tutorial", mode .= Tutorial) ] where --hideShowHandler' :: (BrickSettings -> Bool) -> (BrickSettings -> Bool) -> m () @@ -350,7 +350,7 @@ ui dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..} = Brick.padBottom Max ( Brick.withBorderStyle unicode $ borderWithLabel (Brick.str "GHCup") - (center (header <=> renderList' _appState)) + (center (header <=> hBorder <=> renderList' _appState)) ) <=> footer where @@ -371,14 +371,12 @@ ui dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..} 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 - render_separator _ _ = hBorder - render_border _ _ = id - in Brick.withDefAttr L.listAttr $ renderSectionList render_separator render_border (renderItem minTagSize minVerSize) True bis + in Brick.withDefAttr L.listAttr $ renderSectionList (renderItem minTagSize minVerSize) True bis renderItem minTagSize minVerSize b listResult@ListResult{lTag = lTag', ..} = let marks = if - | lSet -> (Brick.withAttr (Brick.attrName "set") $ str setSign) - | lInstalled -> (Brick.withAttr (Brick.attrName "installed") $ str installedSign) - | otherwise -> (Brick.withAttr (Brick.attrName "not-installed") $ str notInstalledSign) + | lSet -> (Brick.withAttr (Brick.attrName "set") $ Brick.str setSign) + | lInstalled -> (Brick.withAttr (Brick.attrName "installed") $ Brick.str installedSign) + | otherwise -> (Brick.withAttr (Brick.attrName "not-installed") $ Brick.str notInstalledSign) ver = case lCross of Nothing -> T.unpack . prettyVer $ lVer Just c -> T.unpack (c <> "-" <> prettyVer lVer) @@ -529,7 +527,7 @@ navigationHandler ev = do AppState { keyBindings = kb } <- liftIO $ readIORef settings' case ev of inner_event@(VtyEvent (Vty.EvKey key _)) -> - case find (\(key', _, _) -> key' == key) (keyHandlers kb) of + case find (\(key', _, _) -> key' == KeyCombination key []) (keyHandlers kb) of Nothing -> void $ Brick.zoom (toLensVL appState) $ handleGenericListEvent inner_event Just (_, _, handler) -> handler inner_event -> Brick.zoom (toLensVL appState) $ handleGenericListEvent inner_event @@ -611,7 +609,7 @@ replaceLR :: (ListResult -> Bool) 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)] - newSectionList = sectionList AllTools newVec 0 + newSectionList = sectionList AllTools newVec 1 in case oldElem of Just (_, el) -> selectBy (lTool el) (toolEqual el) newSectionList Nothing -> selectLatest newSectionList @@ -631,7 +629,7 @@ filterVisible v e | lInstalled e = True (Nightly `notElem` lTag e) -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, Alternative m) => (Int, ListResult) -> m (Either String ()) install' (_, ListResult {..}) = do From 987cdaf313897ec004732fb1684dbc29c532c067 Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Wed, 15 Nov 2023 21:35:56 +0100 Subject: [PATCH 5/8] factor out attr names. Add windows symbols to tutotial widget. Improve tutorial aesthetics and text --- app/ghcup/BrickMain.hs | 152 +++++++++++++++++++++++++++-------------- 1 file changed, 101 insertions(+), 51 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 5377eb1..a9a42e3 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -355,7 +355,7 @@ ui dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..} <=> footer where footer = - Brick.withAttr (Brick.attrName "help") + Brick.withAttr helpAttr . Brick.txtWrap . T.pack . foldr1 (\x y -> x <> " " <> y) @@ -374,9 +374,9 @@ ui dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..} in Brick.withDefAttr L.listAttr $ renderSectionList (renderItem minTagSize minVerSize) True bis renderItem minTagSize minVerSize b listResult@ListResult{lTag = lTag', ..} = let marks = if - | lSet -> (Brick.withAttr (Brick.attrName "set") $ Brick.str setSign) - | lInstalled -> (Brick.withAttr (Brick.attrName "installed") $ Brick.str installedSign) - | otherwise -> (Brick.withAttr (Brick.attrName "not-installed") $ Brick.str notInstalledSign) + | lSet -> (Brick.withAttr setAttr $ Brick.str setSign) + | lInstalled -> (Brick.withAttr installedAttr $ Brick.str installedSign) + | otherwise -> (Brick.withAttr notInstalledAttr $ Brick.str notInstalledSign) ver = case lCross of Nothing -> T.unpack . prettyVer $ lVer Just c -> T.unpack (c <> "-" <> prettyVer lVer) @@ -388,7 +388,7 @@ ui dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..} | otherwise = id hooray | elem Latest lTag' && not lInstalled = - Brick.withAttr (Brick.attrName "hooray") + Brick.withAttr hoorayAttr | otherwise = id in hooray $ dim ( marks @@ -411,14 +411,14 @@ ui dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..} <+> Brick.vLimit 1 (Brick.fill ' ') ) - printTag Recommended = Just $ Brick.withAttr (Brick.attrName "recommended") $ Brick.str "recommended" - printTag Latest = Just $ Brick.withAttr (Brick.attrName "latest") $ Brick.str "latest" - printTag Prerelease = Just $ Brick.withAttr (Brick.attrName "prerelease") $ Brick.str "prerelease" - printTag Nightly = Just $ Brick.withAttr (Brick.attrName "nightly") $ Brick.str "nightly" + 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" printTag (Base pvp'') = Just $ Brick.str ("base-" ++ T.unpack (prettyPVP pvp'')) printTag Old = Nothing - printTag LatestPrerelease = Just $ Brick.withAttr (Brick.attrName "latest-prerelease") $ Brick.str "latest-prerelease" - printTag LatestNightly = Just $ Brick.withAttr (Brick.attrName "latest-nightly") $ Brick.str "latest-nightly" + printTag LatestPrerelease = Just $ Brick.withAttr latestPrereleaseAttr $ Brick.str "latest-prerelease" + printTag LatestNightly = Just $ Brick.withAttr latestNightlyAttr $ Brick.str "latest-nightly" printTag (UnknownTag t) = Just $ Brick.str t printTool Cabal = Brick.str "cabal" @@ -428,12 +428,12 @@ ui dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..} printTool Stack = Brick.str "Stack" printNotes ListResult {..} = - (if hlsPowered then [Brick.withAttr (Brick.attrName "hls-powered") $ Brick.str "hls-powered"] else mempty + (if hlsPowered then [Brick.withAttr hlsPoweredAttr $ Brick.str "hls-powered"] else mempty ) - ++ (if lStray then [Brick.withAttr (Brick.attrName "stray") $ Brick.str "stray"] else mempty) + ++ (if lStray then [Brick.withAttr strayAttr $ Brick.str "stray"] else mempty) ++ (case lReleaseDay of Nothing -> mempty - Just d -> [Brick.withAttr (Brick.attrName "day") $ Brick.str (show d)]) + Just d -> [Brick.withAttr dayAttr $ Brick.str (show d)]) minHSize :: Int -> Widget n -> Widget n minHSize s' = Brick.hLimit s' . Brick.vLimit 1 . (<+> Brick.fill ' ') @@ -453,49 +453,78 @@ drawUI dimAttrs st = case st ^. mode of Navigation -> [ui dimAttrs st] Tutorial -> - let tutorial = centerLayer - $ Brick.hLimitPercent 75 - $ Brick.vLimitPercent 50 - $ Brick.withBorderStyle unicode - $ borderWithLabel (Brick.txt "Tutorial") - $ Brick.vBox - [ Brick.txt "GHCup is a tool for managing your Haskell tooling." - , center (Brick.txt "--- o ---") - , Brick.txt "This symbol " - <+> Brick.withAttr (Brick.attrName "installed") (Brick.str "✓ ") - <+> Brick.txt " means that the tool is installed but not in used" - , Brick.txt "This symbol " - <+> Brick.withAttr (Brick.attrName "set") (Brick.str "✔✔") - <+> Brick.txt " means that the tool is installed and in used" - , Brick.txt "This symbol " - <+> Brick.withAttr (Brick.attrName "not-installed") (Brick.str "✗ ") - <+> Brick.txt " means that the tool isn't installed" - , center (Brick.txt "--- o ---") - , Brick.txt "Press Enter to exit the tutorial" - ] + let mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max) + txt_separator = hBorder <+> Brick.str " o " <+> hBorder + tutorial = centerLayer + $ Brick.hLimitPercent 75 + $ Brick.vLimitPercent 50 + $ Brick.withBorderStyle unicode + $ borderWithLabel (Brick.txt "Tutorial") + $ Brick.vBox + (fmap center + [ mkTextBox [Brick.txt "GHCup is a distribution channel for Haskell's tools."] + , txt_separator + , mkTextBox [ + Brick.hBox [ + Brick.txt "This symbol " + , Brick.withAttr installedAttr (Brick.str installedSign) + , Brick.txt " means that the tool is installed but not in used" + ] + , Brick.hBox [ + Brick.txt "This symbol " + , Brick.withAttr setAttr (Brick.str setSign) + , Brick.txt " means that the tool is installed and in used" + ] + , 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.txt " tag is based on ..." + ] + , Brick.hBox [ + Brick.withAttr latestAttr $ Brick.str "latest" + , Brick.txt " tag is for the latest distributed version of the tool" + ] + , 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.txt "base-X.Y.Z.W tag is the minimun version of the base package admited in such ghc version" + ] + , Brick.txt " " + ]) + <=> Brick.padRight Brick.Max (Brick.txt "Press Enter to exit the tutorial") in [tutorial, ui dimAttrs st] defaultAttributes :: Bool -> AttrMap defaultAttributes no_color = Brick.attrMap Vty.defAttr - [ (L.listSelectedFocusedAttr , Vty.defAttr `withBackColor` Vty.blue) --, (attrName "active" , Vty.defAttr `withBackColor` Vty.blue) - , (L.listSelectedAttr , Vty.defAttr) -- we use list attributes for active. - , (Brick.attrName "not-installed" , Vty.defAttr `withForeColor` Vty.red) - , (Brick.attrName "set" , Vty.defAttr `withForeColor` Vty.green) - , (Brick.attrName "installed" , Vty.defAttr `withForeColor` Vty.green) - , (Brick.attrName "recommended" , Vty.defAttr `withForeColor` Vty.green) - , (Brick.attrName "hls-powered" , Vty.defAttr `withForeColor` Vty.green) - , (Brick.attrName "latest" , Vty.defAttr `withForeColor` Vty.yellow) - , (Brick.attrName "latest-prerelease" , Vty.defAttr `withForeColor` Vty.red) - , (Brick.attrName "latest-nightly" , Vty.defAttr `withForeColor` Vty.red) - , (Brick.attrName "prerelease" , Vty.defAttr `withForeColor` Vty.red) - , (Brick.attrName "nightly" , Vty.defAttr `withForeColor` Vty.red) - , (Brick.attrName "compiled" , Vty.defAttr `withForeColor` Vty.blue) - , (Brick.attrName "stray" , Vty.defAttr `withForeColor` Vty.blue) - , (Brick.attrName "day" , Vty.defAttr `withForeColor` Vty.blue) - , (Brick.attrName "help" , Vty.defAttr `withStyle` Vty.italic) - , (Brick.attrName "hooray" , Vty.defAttr `withForeColor` Vty.brightWhite) + [ (L.listSelectedFocusedAttr , Vty.defAttr `withBackColor` Vty.blue) --, (attrName "active" , Vty.defAttr `withBackColor` Vty.blue) + , (L.listSelectedAttr , Vty.defAttr) -- we use list attributes for active. + , (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 @@ -506,6 +535,27 @@ defaultAttributes no_color = Brick.attrMap 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 dimAttributes no_color = Brick.attrMap (Vty.defAttr `Vty.withStyle` Vty.dim) From 5c3dad1bb9199abaf815bfcae563eeb8274a4fcb Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Sat, 18 Nov 2023 10:55:16 +0100 Subject: [PATCH 6/8] reorganize code by sections --- app/ghcup/BrickMain.hs | 228 +++++++++++++++++++++++------------------ 1 file changed, 128 insertions(+), 100 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index a9a42e3..30fe099 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -238,7 +238,9 @@ sectionListSelectedElement generic_section_list = do let current_section = generic_section_list ^. sectionL current_focus L.listSelectedElement current_section -{- GHCUp State +{- 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. -} @@ -299,41 +301,21 @@ data BrickState = BrickState makeLenses ''BrickState -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) _showAllTools - ) - , (bUp, const "Up", appState %= moveCursor 1 Up) - , (bDown, const "Down", appState %= moveCursor 1 Down) - , (KeyCombination (Vty.KChar 'x') [], const "Tutorial", mode .= Tutorial) - ] - where - --hideShowHandler' :: (BrickSettings -> Bool) -> (BrickSettings -> Bool) -> m () - hideShowHandler' f p = do - app_settings <- use appSettings - 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 newAppSettings (Just current_app_state) +app :: AttrMap -> AttrMap -> App BrickState () Name +app attrs dimAttrs = + App { appDraw = drawUI dimAttrs + , appHandleEvent = eventHandler + , appStartEvent = return () + , appAttrMap = const attrs + , appChooseCursor = Brick.showFirstCursor + } +{- Drawing. + +The section for creating our widgets. + +-} showKey :: Vty.Key -> String showKey (Vty.KChar c) = [c] @@ -345,8 +327,8 @@ showMod :: Vty.Modifier -> String showMod = tail . show -ui :: AttrMap -> BrickState -> Widget Name -ui dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..} +drawNavigation :: AttrMap -> BrickState -> Widget Name +drawNavigation dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..} = Brick.padBottom Max ( Brick.withBorderStyle unicode $ borderWithLabel (Brick.str "GHCup") @@ -435,81 +417,79 @@ ui dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..} Nothing -> mempty Just d -> [Brick.withAttr dayAttr $ Brick.str (show d)]) -minHSize :: Int -> Widget n -> Widget n -minHSize s' = Brick.hLimit s' . Brick.vLimit 1 . (<+> Brick.fill ' ') + minHSize s' = Brick.hLimit s' . Brick.vLimit 1 . (<+> Brick.fill ' ') + +drawTutorial :: AttrMap -> BrickState -> Widget Name +drawTutorial dimAttrs st = + 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.txt "GHCup is a distribution channel for Haskell's tools."] + , txt_separator + , mkTextBox [ + Brick.hBox [ + Brick.txt "This symbol " + , Brick.withAttr installedAttr (Brick.str installedSign) + , Brick.txt " means that the tool is installed but not in used" + ] + , Brick.hBox [ + Brick.txt "This symbol " + , Brick.withAttr setAttr (Brick.str setSign) + , Brick.txt " means that the tool is installed and in used" + ] + , 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.txt " tag is based on ..." + ] + , Brick.hBox [ + Brick.withAttr latestAttr $ Brick.str "latest" + , Brick.txt " tag is for the latest distributed version of the tool" + ] + , 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.txt "base-X.Y.Z.W tag is the minimun version of the base package admited in such ghc version" + ] + , Brick.txt " " + ]) + <=> Brick.padRight Brick.Max (Brick.txt "Press Enter to exit the tutorial") -app :: AttrMap -> AttrMap -> App BrickState () Name -app attrs dimAttrs = - App { appDraw = drawUI dimAttrs - , appHandleEvent = eventHandler - , appStartEvent = return () - , appAttrMap = const attrs - , appChooseCursor = Brick.showFirstCursor - } drawUI :: AttrMap -> BrickState -> [Widget Name] drawUI dimAttrs st = case st ^. mode of - Navigation -> [ui dimAttrs st] - Tutorial -> - let mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max) - txt_separator = hBorder <+> Brick.str " o " <+> hBorder - tutorial = centerLayer - $ Brick.hLimitPercent 75 - $ Brick.vLimitPercent 50 - $ Brick.withBorderStyle unicode - $ borderWithLabel (Brick.txt "Tutorial") - $ Brick.vBox - (fmap center - [ mkTextBox [Brick.txt "GHCup is a distribution channel for Haskell's tools."] - , txt_separator - , mkTextBox [ - Brick.hBox [ - Brick.txt "This symbol " - , Brick.withAttr installedAttr (Brick.str installedSign) - , Brick.txt " means that the tool is installed but not in used" - ] - , Brick.hBox [ - Brick.txt "This symbol " - , Brick.withAttr setAttr (Brick.str setSign) - , Brick.txt " means that the tool is installed and in used" - ] - , 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.txt " tag is based on ..." - ] - , Brick.hBox [ - Brick.withAttr latestAttr $ Brick.str "latest" - , Brick.txt " tag is for the latest distributed version of the tool" - ] - , 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.txt "base-X.Y.Z.W tag is the minimun version of the base package admited in such ghc version" - ] - , Brick.txt " " - ]) - <=> Brick.padRight Brick.Max (Brick.txt "Press Enter to exit the tutorial") - in [tutorial, ui dimAttrs st] + Navigation -> [drawNavigation dimAttrs st] + Tutorial -> [drawTutorial dimAttrs st, drawNavigation dimAttrs st] + +{- Attributes + +-} defaultAttributes :: Bool -> AttrMap defaultAttributes no_color = Brick.attrMap Vty.defAttr - [ (L.listSelectedFocusedAttr , Vty.defAttr `withBackColor` Vty.blue) --, (attrName "active" , Vty.defAttr `withBackColor` Vty.blue) - , (L.listSelectedAttr , Vty.defAttr) -- we use list attributes for active. + [ (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) @@ -566,6 +546,43 @@ dimAttributes no_color = Brick.attrMap withBackColor | no_color = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo | otherwise = Vty.withBackColor +{- 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) _showAllTools + ) + , (KeyCombination (Vty.KChar 'x') [], const "Tutorial", mode .= Tutorial) + ] + where + --hideShowHandler' :: (BrickSettings -> Bool) -> (BrickSettings -> Bool) -> m () + hideShowHandler' f p = do + app_settings <- use appSettings + 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 newAppSettings (Just current_app_state) + + tutorialHandler :: BrickEvent Name e -> EventM Name BrickState () tutorialHandler ev = case ev of @@ -589,6 +606,17 @@ eventHandler ev = do Navigation -> navigationHandler ev Tutorial -> tutorialHandler ev + +{- Core Logic. + +This section defines the IO actions we can execute within the Brick App: + - Install + - Set + - UnInstall + - Launch the Changelog + +-} + -- | 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. withIOAction :: (Ord n, Eq n) From d3474d0cd99d18d4d7a8f9edcb46035ff068ce84 Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Sat, 18 Nov 2023 11:56:12 +0100 Subject: [PATCH 7/8] add KeyInfo handler and widget. Improve tutorial --- app/ghcup/BrickMain.hs | 95 ++++++++++++++++++++++++++++++++++-------- 1 file changed, 78 insertions(+), 17 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 30fe099..ec9232c 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -246,10 +246,11 @@ In this section we define the state, the widgets and the core data structures wh 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 | Tutorial deriving (Eq, Show, Ord) +data Mode = Navigation | KeyInfo | Tutorial deriving (Eq, Show, Ord) installedSign :: String #if IS_WINDOWS @@ -419,8 +420,8 @@ drawNavigation dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..} minHSize s' = Brick.hLimit s' . Brick.vLimit 1 . (<+> Brick.fill ' ') -drawTutorial :: AttrMap -> BrickState -> Widget Name -drawTutorial dimAttrs st = +drawTutorial :: Widget Name +drawTutorial = let mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max) txt_separator = hBorder <+> Brick.str " o " <+> hBorder @@ -431,18 +432,18 @@ drawTutorial dimAttrs st = $ borderWithLabel (Brick.txt "Tutorial") $ Brick.vBox (fmap center - [ mkTextBox [Brick.txt "GHCup is a distribution channel for Haskell's tools."] + [ mkTextBox [Brick.txtWrap "GHCup is a distribution channel for Haskell's tools."] , txt_separator , mkTextBox [ Brick.hBox [ Brick.txt "This symbol " , Brick.withAttr installedAttr (Brick.str installedSign) - , Brick.txt " means that the tool is installed but not in used" + , Brick.txtWrap " means that the tool is installed but not in used" ] , Brick.hBox [ Brick.txt "This symbol " , Brick.withAttr setAttr (Brick.str setSign) - , Brick.txt " means that the tool is installed and in used" + , Brick.txtWrap " means that the tool is installed and in used" ] , Brick.hBox [ Brick.txt "This symbol " @@ -454,11 +455,11 @@ drawTutorial dimAttrs st = , mkTextBox [ Brick.hBox [ Brick.withAttr recommendedAttr $ Brick.str "recommended" - , Brick.txt " tag is based on ..." + , Brick.txtWrap " tag is based on ..." ] , Brick.hBox [ Brick.withAttr latestAttr $ Brick.str "latest" - , Brick.txt " tag is for the latest distributed version of the tool" + , Brick.txtWrap " tag is for the latest distributed version of the tool" ] , Brick.hBox [ Brick.withAttr latestAttr $ Brick.str "hls-powered" @@ -466,19 +467,71 @@ drawTutorial dimAttrs st = , Brick.withAttr setAttr (Brick.str setSign) , Brick.txt ") hls" ] - , Brick.txt "base-X.Y.Z.W tag is the minimun version of the base package admited in such ghc version" + , Brick.txtWrap "base-X.Y.Z.W tag is the minimun version of the base package admited in such ghc version" ] , Brick.txt " " ]) - <=> Brick.padRight Brick.Max (Brick.txt "Press Enter to exit the tutorial") - + <=> 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 " + , keyToWidget bShowAllTools + , Brick.txtWrap " to ??? " + ] + ] + ] + <=> 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 = - case st ^. mode of - Navigation -> [drawNavigation dimAttrs st] - Tutorial -> [drawTutorial dimAttrs st, drawNavigation dimAttrs st] + let navg = drawNavigation dimAttrs st + in case st ^. mode of + Navigation -> [navg] + Tutorial -> [drawTutorial, navg] + KeyInfo -> [drawKeyInfo (st ^. appKeys), navg] {- Attributes @@ -567,7 +620,7 @@ keyHandlers KeyBindings {..} = if _showAllVersions then "Don't show all versions" else "Show all versions" , hideShowHandler' (not . _showAllVersions) _showAllTools ) - , (KeyCombination (Vty.KChar 'x') [], const "Tutorial", mode .= Tutorial) + , (KeyCombination (Vty.KChar 'h') [], const "help", mode .= KeyInfo) ] where --hideShowHandler' :: (BrickSettings -> Bool) -> (BrickSettings -> Bool) -> m () @@ -586,7 +639,14 @@ keyHandlers KeyBindings {..} = tutorialHandler :: BrickEvent Name e -> EventM Name BrickState () tutorialHandler ev = case ev of - VtyEvent (Vty.EvKey Vty.KEnter _) -> mode .= Navigation + 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 () @@ -603,8 +663,9 @@ eventHandler :: BrickEvent Name e -> EventM Name BrickState () eventHandler ev = do m <- use mode case m of - Navigation -> navigationHandler ev + KeyInfo -> keyInfoHandler ev Tutorial -> tutorialHandler ev + Navigation -> navigationHandler ev {- Core Logic. From 0e46b9509ac7ee36e366b2c2390c4990b4a581f9 Mon Sep 17 00:00:00 2001 From: Luis Morillo Date: Thu, 23 Nov 2023 16:05:12 +0100 Subject: [PATCH 8/8] complete tutorial. remove show all tools from widgets. resolve some conflicts. --- app/ghcup/BrickMain.hs | 30 +++++++++++------------------- 1 file changed, 11 insertions(+), 19 deletions(-) diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index ec9232c..785865f 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -192,8 +192,8 @@ handleGenericListEvent (VtyEvent (Vty.EvKey (Vty.KChar '\t') [])) = sectionListF 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 (Vty.EvKey Vty.KDown [])) = moveDown +handleGenericListEvent (VtyEvent (Vty.EvKey Vty.KUp [])) = moveUp handleGenericListEvent (VtyEvent ev) = do ring <- use sectionListFocusRingL case F.focusGetCurrent ring of @@ -281,10 +281,7 @@ data BrickData = BrickData makeLenses ''BrickData -data BrickSettings = BrickSettings - { _showAllVersions :: Bool - , _showAllTools :: Bool - } +data BrickSettings = BrickSettings { _showAllVersions :: Bool} --deriving Show makeLenses ''BrickSettings @@ -455,7 +452,7 @@ drawTutorial = , mkTextBox [ Brick.hBox [ Brick.withAttr recommendedAttr $ Brick.str "recommended" - , Brick.txtWrap " tag is based on ..." + , Brick.txtWrap " tag is based on community adoption, known bugs, etc... So It makes this version the least experimental" ] , Brick.hBox [ Brick.withAttr latestAttr $ Brick.str "latest" @@ -516,11 +513,6 @@ drawKeyInfo KeyBindings {..} = , keyToWidget bShowAllVersions , Brick.txtWrap " to show older version of each tool" ] - , Brick.hBox [ - Brick.txt "Press " - , keyToWidget bShowAllTools - , Brick.txtWrap " to ??? " - ] ] ] <=> 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"] @@ -618,18 +610,19 @@ keyHandlers KeyBindings {..} = , ( bShowAllVersions , \BrickSettings {..} -> if _showAllVersions then "Don't show all versions" else "Show all versions" - , hideShowHandler' (not . _showAllVersions) _showAllTools + , hideShowHandler' (not . _showAllVersions) ) + , (bUp, const "Up", Brick.zoom (toLensVL appState) moveUp) + , (bDown, const "Down", Brick.zoom (toLensVL appState) moveDown) , (KeyCombination (Vty.KChar 'h') [], const "help", mode .= KeyInfo) ] where --hideShowHandler' :: (BrickSettings -> Bool) -> (BrickSettings -> Bool) -> m () - hideShowHandler' f p = do + hideShowHandler' f = do app_settings <- use appSettings let vers = f app_settings - tools = p app_settings - newAppSettings = app_settings & showAllVersions .~ vers & showAllTools .~ tools + newAppSettings = app_settings & showAllVersions .~ vers ad <- use appData current_app_state <- use appState appSettings .= newAppSettings @@ -719,8 +712,7 @@ constructList :: BrickData -> Maybe BrickInternalState -> BrickInternalState constructList appD settings = - replaceLR (filterVisible (_showAllVersions settings) - (_showAllTools settings)) + replaceLR (filterVisible (_showAllVersions settings)) (_lr appD) -- | Focus on the tool section and the predicate which matches. If no result matches, focus on index 0 @@ -1015,7 +1007,7 @@ brickMain s = do defaultAppSettings :: BrickSettings -defaultAppSettings = BrickSettings { _showAllVersions = False, _showAllTools = False } +defaultAppSettings = BrickSettings { _showAllVersions = False} getGHCupInfo :: IO (Either String GHCupInfo)