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

use map-like data structure

Browse Source
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
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

397
app/ghcup/BrickMain.hs
View File

@ -26,53 +26,21 @@ import GHCup.Prelude.Process
import GHCup.Prompts import GHCup.Prompts
import Brick import Brick
( defaultMain, ( BrickEvent(VtyEvent, MouseDown),
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(..), App(..),
ViewportType(Vertical),
Size(Greedy),
Location(Location),
Padding(Max, Pad), Padding(Max, Pad),
Widget(Widget, render),
AttrMap, AttrMap,
Direction(..),
get,
zoom,
EventM, EventM,
suffixLenses, Size(..),
Named(..), modify ) Named(..),
import Brick.Widgets.Border ( hBorder, borderWithLabel ) Widget(..),
ViewportType (Vertical),
(<+>),
(<=>))
import qualified Brick
import Brick.Widgets.Border ( hBorder, borderWithLabel)
import Brick.Widgets.Border.Style ( unicode ) import Brick.Widgets.Border.Style ( unicode )
import Brick.Widgets.Center ( center ) 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 qualified Brick.Widgets.List as L
import Brick.Focus (FocusRing) import Brick.Focus (FocusRing)
import qualified Brick.Focus as F import qualified Brick.Focus as F
@ -87,12 +55,12 @@ import Control.Monad.Trans.Except
import Control.Monad.Trans.Resource import Control.Monad.Trans.Resource
import Data.Bool import Data.Bool
import Data.Functor import Data.Functor
import Data.Function ( (&)) import Data.Function ( (&), on)
import Data.List import Data.List
import Data.Maybe import Data.Maybe
import Data.IORef (IORef, readIORef, newIORef, writeIORef, modifyIORef) import Data.IORef (IORef, readIORef, newIORef, writeIORef, modifyIORef)
import Data.Vector ( Vector import Data.Vector ( Vector
, (!?)
) )
import Data.Versions import Data.Versions
import Haskus.Utils.Variant.Excepts import Haskus.Utils.Variant.Excepts
@ -117,10 +85,9 @@ import qualified System.Posix.Process as SPP
import Optics.TH (makeLenses, makeLensesFor) import Optics.TH (makeLenses, makeLensesFor)
import Optics.State (use) import Optics.State (use)
import Optics.State.Operators ( (.=), (%=), (<%=)) import Optics.State.Operators ( (.=), (%=), (<%=))
import Optics.Optic ((%)) import Optics.Operators ((.~), (^.), (%~))
import Optics.Operators ((.~), (^.))
import Optics.Getter (view) import Optics.Getter (view)
import Optics.Lens (Lens', lens, toLensVL, lensVL) import Optics.Lens (Lens', lens, toLensVL)
{- Brick's widget: {- 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) 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)]) Just i -> let new_elms = V.update elms (V.fromList [(i, list)])
in gl & sectionListElementsL .~ new_elms in gl & sectionListElementsL .~ new_elms
-- | Handle events for list cursor movement. Events handled are: moveDown :: (L.Splittable t, Ord n, Foldable t) => EventM n (GenericSectionList n t e) ()
-- moveDown = do
-- * 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 ring <- use sectionListFocusRingL
case F.focusGetCurrent ring of case F.focusGetCurrent ring of
Nothing -> pure () Nothing -> pure ()
@ -205,9 +160,11 @@ handleGenericListEvent (VtyEvent ev@(Vty.EvKey Vty.KDown [])) = do
new_focus <- sectionListFocusRingL <%= F.focusNext new_focus <- sectionListFocusRingL <%= F.focusNext
case F.focusGetCurrent new_focus of 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 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) Just new_l -> Brick.zoom (toLensVL $ sectionL new_l) (Brick.modify L.listMoveToBeginning)
else zoom (toLensVL $ sectionL l) $ L.handleListEvent ev else Brick.zoom (toLensVL $ sectionL l) $ Brick.modify L.listMoveDown
handleGenericListEvent (VtyEvent ev@(Vty.EvKey Vty.KUp [])) = do
moveUp :: (L.Splittable t, Ord n, Foldable t) => EventM n (GenericSectionList n t e) ()
moveUp = do
ring <- use sectionListFocusRingL ring <- use sectionListFocusRingL
case F.focusGetCurrent ring of case F.focusGetCurrent ring of
Nothing -> pure () Nothing -> pure ()
@ -219,13 +176,32 @@ handleGenericListEvent (VtyEvent ev@(Vty.EvKey Vty.KUp [])) = do
new_focus <- sectionListFocusRingL <%= F.focusPrev new_focus <- sectionListFocusRingL <%= F.focusPrev
case F.focusGetCurrent new_focus of case F.focusGetCurrent new_focus of
Nothing -> pure () Nothing -> pure ()
Just new_l -> zoom (toLensVL $ sectionL new_l) (modify L.listMoveToEnd) Just new_l -> Brick.zoom (toLensVL $ sectionL new_l) (Brick.modify L.listMoveToEnd)
else zoom (toLensVL $ sectionL l) $ L.handleListEvent ev 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 handleGenericListEvent (VtyEvent ev) = do
ring <- use sectionListFocusRingL ring <- use sectionListFocusRingL
case F.focusGetCurrent ring of case F.focusGetCurrent ring of
Nothing -> pure () Nothing -> pure ()
Just l -> zoom (toLensVL $ sectionL l) $ L.handleListEvent ev Just l -> Brick.zoom (toLensVL $ sectionL l) $ L.handleListEvent ev
handleGenericListEvent _ = pure () handleGenericListEvent _ = pure ()
-- This re-uses Brick.Widget.List.renderList -- 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 -> Bool -- ^ Whether the section list has focus
-> GenericSectionList n t e -- ^ The section list to render -> GenericSectionList n t e -- ^ The section list to render
-> Widget n -> 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) =
V.foldl' (\wacc list -> Widget Greedy Greedy $ render $
let has_focus = is_focused_section list Brick.viewport sl_name Vertical $
list_name = L.listName list V.foldl' (\wacc list ->
in wacc let has_focus_list = is_focused_section list
<=> render_separator has_focus list_name list_name = L.listName list
<=> inner_widget has_focus list_name list in wacc
) <=> render_separator has_focus_list list_name
emptyWidget elms <=> inner_widget has_focus_list list_name list
)
Brick.emptyWidget elms
where where
is_focused_section l = section_focus && Just (L.listName l) == F.focusGetCurrent focus 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 -- | Equivalent to listSelectedElement
@ -261,6 +241,7 @@ sectionListSelectedElement generic_section_list = do
-} -}
type Name = String
installedSign :: String installedSign :: String
#if IS_WINDOWS #if IS_WINDOWS
@ -299,13 +280,7 @@ data BrickSettings = BrickSettings
makeLenses ''BrickSettings makeLenses ''BrickSettings
data BrickInternalState = BrickInternalState type BrickInternalState = SectionList Name ListResult
{ _clr :: Vector ListResult
, _ix :: Int
}
--deriving Show
makeLenses ''BrickInternalState
data BrickState = BrickState data BrickState = BrickState
{ _appData :: BrickData { _appData :: BrickData
@ -324,7 +299,7 @@ keyHandlers :: KeyBindings
) )
] ]
keyHandlers KeyBindings {..} = keyHandlers KeyBindings {..} =
[ (bQuit, const "Quit" , halt) [ (bQuit, const "Quit" , Brick.halt)
, (bInstall, const "Install" , withIOAction install') , (bInstall, const "Install" , withIOAction install')
, (bUninstall, const "Uninstall", withIOAction del') , (bUninstall, const "Uninstall", withIOAction del')
, (bSet, const "Set" , withIOAction set') , (bSet, const "Set" , withIOAction set')
@ -348,7 +323,7 @@ keyHandlers KeyBindings {..} =
ad <- use appData ad <- use appData
current_app_state <- use appState current_app_state <- use appState
appSettings .= newAppSettings 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 :: AttrMap -> BrickState -> Widget String
ui dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..} ui dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..}
= padBottom Max = Brick.padBottom Max
( withBorderStyle unicode ( Brick.withBorderStyle unicode
$ borderWithLabel (str "GHCup") $ borderWithLabel (Brick.str "GHCup")
(center (header <=> hBorder <=> renderList' _appState)) (center (header <=> renderList' _appState))
) )
<=> footer <=> footer
where where
footer = footer =
withAttr (attrName "help") Brick.withAttr (Brick.attrName "help")
. txtWrap . Brick.txtWrap
. T.pack . T.pack
. foldr1 (\x y -> x <> " " <> y) . foldr1 (\x y -> x <> " " <> y)
. fmap (\(KeyCombination key mods, s, _) -> intercalate "+" (showKey key : (showMod <$> mods)) <> ":" <> s as) . fmap (\(KeyCombination key mods, s, _) -> intercalate "+" (showKey key : (showMod <$> mods)) <> ":" <> s as)
$ keyHandlers _appKeys $ keyHandlers _appKeys
header = header =
minHSize 2 emptyWidget minHSize 2 Brick.emptyWidget
<+> padLeft (Pad 2) (minHSize 6 $ str "Tool") <+> Brick.padLeft (Pad 2) (minHSize 6 $ Brick.str "Tool")
<+> minHSize 15 (str "Version") <+> minHSize 15 (Brick.str "Version")
<+> padLeft (Pad 1) (minHSize 25 $ str "Tags") <+> Brick.padLeft (Pad 1) (minHSize 25 $ Brick.str "Tags")
<+> padLeft (Pad 5) (str "Notes") <+> Brick.padLeft (Pad 5) (Brick.str "Notes")
renderList' bis@BrickInternalState{..} = renderList' bis =
let minTagSize = V.maximum $ V.map (length . intercalate "," . fmap tagToString . lTag) _clr let allElements = V.concatMap L.listElements $ sectionListElements bis
minVerSize = V.maximum $ V.map (\ListResult{..} -> T.length $ tVerToText (GHCTargetVersion lCross lVer)) _clr minTagSize = V.maximum $ V.map (length . intercalate "," . fmap tagToString . lTag) allElements
in withDefAttr listAttr . drawListElements (renderItem minTagSize minVerSize) True $ bis minVerSize = V.maximum $ V.map (\ListResult{..} -> T.length $ tVerToText (GHCTargetVersion lCross lVer)) allElements
renderItem minTagSize minVerSize _ b listResult@ListResult{lTag = lTag', ..} = 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 let marks = if
| lSet -> (withAttr (attrName "set") $ str setSign) | lSet -> (Brick.withAttr (Brick.attrName "set") $ str setSign)
| lInstalled -> (withAttr (attrName "installed") $ str installedSign) | lInstalled -> (Brick.withAttr (Brick.attrName "installed") $ str installedSign)
| otherwise -> (withAttr (attrName "not-installed") $ str notInstalledSign) | otherwise -> (Brick.withAttr (Brick.attrName "not-installed") $ str notInstalledSign)
ver = case lCross of ver = case lCross of
Nothing -> T.unpack . prettyVer $ lVer Nothing -> T.unpack . prettyVer $ lVer
Just c -> T.unpack (c <> "-" <> prettyVer lVer) Just c -> T.unpack (c <> "-" <> prettyVer lVer)
@ -401,97 +378,59 @@ ui dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..}
| lNoBindist && not lInstalled | lNoBindist && not lInstalled
&& not b -- TODO: overloading dim and active ignores active && not b -- TODO: overloading dim and active ignores active
-- so we hack around it here -- 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 | otherwise = id
hooray hooray
| elem Latest lTag' && not lInstalled = | elem Latest lTag' && not lInstalled =
withAttr (attrName "hooray") Brick.withAttr (Brick.attrName "hooray")
| otherwise = id | otherwise = id
active = if b then putCursor "GHCup" (Location (0,0)) . forceAttr (attrName "active") else id in hooray $ dim
in hooray $ active $ dim
( marks ( marks
<+> padLeft (Pad 2) <+> Brick.padLeft (Pad 2)
( minHSize 6 ( minHSize 6
(printTool lTool) (printTool lTool)
) )
<+> minHSize minVerSize (str ver) <+> minHSize minVerSize (Brick.str ver)
<+> (let l = catMaybes . fmap printTag $ sort lTag' <+> (let l = catMaybes . fmap printTag $ sort lTag'
in padLeft (Pad 1) $ minHSize minTagSize $ if null l in Brick.padLeft (Pad 1) $ minHSize minTagSize $ if null l
then emptyWidget then Brick.emptyWidget
else foldr1 (\x y -> x <+> str "," <+> y) l else foldr1 (\x y -> x <+> Brick.str "," <+> y) l
) )
<+> padLeft (Pad 5) <+> Brick.padLeft (Pad 5)
( let notes = printNotes listResult ( let notes = printNotes listResult
in if null notes in if null notes
then emptyWidget then Brick.emptyWidget
else foldr1 (\x y -> x <+> str "," <+> y) notes 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 Recommended = Just $ Brick.withAttr (Brick.attrName "recommended") $ Brick.str "recommended"
printTag Latest = Just $ withAttr (attrName "latest") $ str "latest" printTag Latest = Just $ Brick.withAttr (Brick.attrName "latest") $ Brick.str "latest"
printTag Prerelease = Just $ withAttr (attrName "prerelease") $ str "prerelease" printTag Prerelease = Just $ Brick.withAttr (Brick.attrName "prerelease") $ Brick.str "prerelease"
printTag Nightly = Just $ withAttr (attrName "nightly") $ str "nightly" printTag Nightly = Just $ Brick.withAttr (Brick.attrName "nightly") $ Brick.str "nightly"
printTag (Base pvp'') = Just $ str ("base-" ++ T.unpack (prettyPVP pvp'')) printTag (Base pvp'') = Just $ Brick.str ("base-" ++ T.unpack (prettyPVP pvp''))
printTag Old = Nothing printTag Old = Nothing
printTag LatestPrerelease = Just $ withAttr (attrName "latest-prerelease") $ str "latest-prerelease" printTag LatestPrerelease = Just $ Brick.withAttr (Brick.attrName "latest-prerelease") $ Brick.str "latest-prerelease"
printTag LatestNightly = Just $ withAttr (attrName "latest-nightly") $ str "latest-nightly" printTag LatestNightly = Just $ Brick.withAttr (Brick.attrName "latest-nightly") $ Brick.str "latest-nightly"
printTag (UnknownTag t) = Just $ str t printTag (UnknownTag t) = Just $ Brick.str t
printTool Cabal = str "cabal" printTool Cabal = Brick.str "cabal"
printTool GHC = str "GHC" printTool GHC = Brick.str "GHC"
printTool GHCup = str "GHCup" printTool GHCup = Brick.str "GHCup"
printTool HLS = str "HLS" printTool HLS = Brick.str "HLS"
printTool Stack = str "Stack" printTool Stack = Brick.str "Stack"
printNotes ListResult {..} = 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 ++ (case lReleaseDay of
Nothing -> mempty Nothing -> mempty
Just d -> [withAttr (attrName "day") $ str (show d)]) Just d -> [Brick.withAttr (Brick.attrName "day") $ Brick.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
minHSize :: Int -> Widget n -> Widget n 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 :: AttrMap -> AttrMap -> App BrickState () String
app attrs dimAttrs = app attrs dimAttrs =
@ -499,29 +438,29 @@ app attrs dimAttrs =
, appHandleEvent = eventHandler , appHandleEvent = eventHandler
, appStartEvent = return () , appStartEvent = return ()
, appAttrMap = const attrs , appAttrMap = const attrs
, appChooseCursor = showFirstCursor , appChooseCursor = Brick.showFirstCursor
} }
defaultAttributes :: Bool -> AttrMap defaultAttributes :: Bool -> AttrMap
defaultAttributes no_color = attrMap defaultAttributes no_color = Brick.attrMap
Vty.defAttr Vty.defAttr
[ (attrName "active" , Vty.defAttr `withBackColor` Vty.blue) [ (L.listSelectedFocusedAttr , Vty.defAttr `withBackColor` Vty.blue) --, (attrName "active" , Vty.defAttr `withBackColor` Vty.blue)
, (attrName "not-installed" , Vty.defAttr `withForeColor` Vty.red) , (L.listSelectedAttr , Vty.defAttr) -- we use list attributes for active.
, (attrName "set" , Vty.defAttr `withForeColor` Vty.green) , (Brick.attrName "not-installed" , Vty.defAttr `withForeColor` Vty.red)
, (attrName "installed" , Vty.defAttr `withForeColor` Vty.green) , (Brick.attrName "set" , Vty.defAttr `withForeColor` Vty.green)
, (attrName "recommended" , Vty.defAttr `withForeColor` Vty.green) , (Brick.attrName "installed" , Vty.defAttr `withForeColor` Vty.green)
, (attrName "hls-powered" , Vty.defAttr `withForeColor` Vty.green) , (Brick.attrName "recommended" , Vty.defAttr `withForeColor` Vty.green)
, (attrName "latest" , Vty.defAttr `withForeColor` Vty.yellow) , (Brick.attrName "hls-powered" , Vty.defAttr `withForeColor` Vty.green)
, (attrName "latest-prerelease" , Vty.defAttr `withForeColor` Vty.red) , (Brick.attrName "latest" , Vty.defAttr `withForeColor` Vty.yellow)
, (attrName "latest-nightly" , Vty.defAttr `withForeColor` Vty.red) , (Brick.attrName "latest-prerelease" , Vty.defAttr `withForeColor` Vty.red)
, (attrName "prerelease" , Vty.defAttr `withForeColor` Vty.red) , (Brick.attrName "latest-nightly" , Vty.defAttr `withForeColor` Vty.red)
, (attrName "nightly" , Vty.defAttr `withForeColor` Vty.red) , (Brick.attrName "prerelease" , Vty.defAttr `withForeColor` Vty.red)
, (attrName "compiled" , Vty.defAttr `withForeColor` Vty.blue) , (Brick.attrName "nightly" , Vty.defAttr `withForeColor` Vty.red)
, (attrName "stray" , Vty.defAttr `withForeColor` Vty.blue) , (Brick.attrName "compiled" , Vty.defAttr `withForeColor` Vty.blue)
, (attrName "day" , Vty.defAttr `withForeColor` Vty.blue) , (Brick.attrName "stray" , Vty.defAttr `withForeColor` Vty.blue)
, (attrName "help" , Vty.defAttr `withStyle` Vty.italic) , (Brick.attrName "day" , Vty.defAttr `withForeColor` Vty.blue)
, (attrName "hooray" , Vty.defAttr `withForeColor` Vty.brightWhite) , (Brick.attrName "help" , Vty.defAttr `withStyle` Vty.italic)
, (buttonSelectedAttr , Vty.defAttr `withBackColor` Vty.brightWhite) , (Brick.attrName "hooray" , Vty.defAttr `withForeColor` Vty.brightWhite)
] ]
where where
withForeColor | no_color = const withForeColor | no_color = const
@ -533,10 +472,10 @@ defaultAttributes no_color = attrMap
withStyle = Vty.withStyle withStyle = Vty.withStyle
dimAttributes :: Bool -> AttrMap dimAttributes :: Bool -> AttrMap
dimAttributes no_color = attrMap dimAttributes no_color = Brick.attrMap
(Vty.defAttr `Vty.withStyle` Vty.dim) (Vty.defAttr `Vty.withStyle` Vty.dim)
[ (attrName "active" , Vty.defAttr `withBackColor` Vty.blue) -- has no effect ?? [ (Brick.attrName "active" , Vty.defAttr `withBackColor` Vty.blue) -- has no effect ??
, (attrName "no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim) , (Brick.attrName "no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim)
] ]
where where
withBackColor | no_color = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo withBackColor | no_color = \attr _ -> attr `Vty.withStyle` Vty.reverseVideo
@ -546,37 +485,23 @@ eventHandler :: BrickEvent String e -> EventM String BrickState ()
eventHandler ev = do eventHandler ev = do
AppState { keyBindings = kb } <- liftIO $ readIORef settings' AppState { keyBindings = kb } <- liftIO $ readIORef settings'
case ev of case ev of
(MouseDown _ Vty.BScrollUp _ _) -> appState %= moveCursor 1 Up inner_event@(VtyEvent (Vty.EvKey key _)) ->
(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 case find (\(key', _, _) -> key' == key) (keyHandlers kb) of
Nothing -> pure () Nothing -> void $ Brick.zoom (toLensVL appState) $ handleGenericListEvent inner_event
Just (_, _, handler) -> handler Just (_, _, handler) -> handler
_ -> pure () inner_event -> Brick.zoom (toLensVL appState) $ handleGenericListEvent inner_event
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 -- | Suspend the current UI and run an IO action in terminal. If the
-- IO action returns a Left value, then it's thrown as userError. -- IO action returns a Left value, then it's thrown as userError.
withIOAction :: Ord n withIOAction :: (Ord n, Eq n)
=> ( (Int, ListResult) -> ReaderT AppState IO (Either String a)) => ( (Int, ListResult) -> ReaderT AppState IO (Either String a))
-> EventM n BrickState () -> EventM n BrickState ()
withIOAction action = do withIOAction action = do
as <- get as <- Brick.get
case listSelectedElement' (view appState as) of case sectionListSelectedElement (view appState as) of
Nothing -> pure () Nothing -> pure ()
Just (curr_ix, e) -> do Just (curr_ix, e) -> do
suspendAndResume $ do Brick.suspendAndResume $ do
settings <- readIORef settings' settings <- readIORef settings'
flip runReaderT settings $ action (curr_ix, e) >>= \case flip runReaderT settings $ action (curr_ix, e) >>= \case
Left err -> liftIO $ putStrLn ("Error: " <> err) Left err -> liftIO $ putStrLn ("Error: " <> err)
@ -601,22 +526,28 @@ updateList appD BrickState{..} =
, _appKeys = _appKeys , _appKeys = _appKeys
} }
constructList :: BrickData constructList :: BrickData
-> BrickSettings -> BrickSettings
-> Maybe BrickInternalState -> Maybe BrickInternalState
-> BrickInternalState -> BrickInternalState
constructList appD appSettings = constructList appD settings =
replaceLR (filterVisible (_showAllVersions appSettings) replaceLR (filterVisible (_showAllVersions settings)
(_showAllTools appSettings)) (_showAllTools settings))
(_lr appD) (_lr appD)
listSelectedElement' :: BrickInternalState -> Maybe (Int, ListResult) -- | Focus on the tool section and the predicate which matches. If no result matches, focus on index 0
listSelectedElement' BrickInternalState{..} = fmap (_ix, ) $ _clr !? _ix 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.
-- | Select the latests GHC tool
selectLatest :: Vector ListResult -> Int selectLatest :: BrickInternalState -> BrickInternalState
selectLatest = fromMaybe 0 . V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag) selectLatest = selectBy GHC (elem Latest . lTag)
-- | Replace the @appState@ or construct it based on a filter function -- | Replace the @appState@ or construct it based on a filter function
@ -626,14 +557,13 @@ replaceLR :: (ListResult -> Bool)
-> [ListResult] -> [ListResult]
-> Maybe BrickInternalState -> Maybe BrickInternalState
-> BrickInternalState -> BrickInternalState
replaceLR filterF lr s = replaceLR filterF list_result s =
let oldElem = s >>= listSelectedElement' let oldElem = s >>= sectionListSelectedElement -- Maybe (Int, e)
newVec = V.fromList . filter filterF $ lr newVec = [(show $ lTool (head g), V.fromList g) | g <- groupBy ((==) `on` lTool ) (filter filterF list_result)]
newSelected = newSectionList = sectionList "GHCupList" newVec 0
case oldElem >>= \(_, oldE) -> V.findIndex (toolEqual oldE) newVec of in case oldElem of
Just ix -> ix Just (_, el) -> selectBy (lTool el) (toolEqual el) newSectionList
Nothing -> selectLatest newVec Nothing -> selectLatest newSectionList
in BrickInternalState newVec newSelected
where where
toolEqual e1 e2 = toolEqual e1 e2 =
lTool e1 == lTool e2 && lVer e1 == lVer e2 && lCross e1 == lCross e2 lTool e1 == lTool e2 && lVer e1 == lVer e2 && lCross e1 == lCross e2
@ -881,7 +811,7 @@ brickMain s = do
eAppData <- getAppData (Just $ ghcupInfo s) eAppData <- getAppData (Just $ ghcupInfo s)
case eAppData of case eAppData of
Right ad -> Right ad ->
defaultMain Brick.defaultMain
(app (defaultAttributes (noColor $ settings s)) (dimAttributes (noColor $ settings s))) (app (defaultAttributes (noColor $ settings s)) (dimAttributes (noColor $ settings s)))
(BrickState ad (BrickState ad
defaultAppSettings defaultAppSettings
@ -925,4 +855,3 @@ getAppData mgi = runExceptT $ do
flip runReaderT settings $ do flip runReaderT settings $ do
lV <- listVersions Nothing [] False True (Nothing, Nothing) lV <- listVersions Nothing [] False True (Nothing, Nothing)
pure $ BrickData (reverse lV) pure $ BrickData (reverse lV)

2
ghcup.cabal
View File

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