use map-like data structure

This commit is contained in:
Luis Morillo 2023-10-08 17:11:32 +02:00
parent aa9fbdbfc2
commit 1353a2fd20
2 changed files with 164 additions and 235 deletions

View File

@ -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 )
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 _) =
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 = is_focused_section list
let has_focus_list = is_focused_section list
list_name = L.listName list
in wacc
<=> render_separator has_focus list_name
<=> inner_widget has_focus list_name list
<=> render_separator has_focus_list list_name
<=> inner_widget has_focus_list list_name list
)
emptyWidget elms
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)

View File

@ -354,7 +354,7 @@ test-suite ghcup-test
default-language: Haskell2010
default-extensions:
LambdaCase
MultiWayIf++-
MultiWayIf
PackageImports
RecordWildCards
ScopedTypeVariables