use map-like data structure
This commit is contained in:
Luis Morillo
parent
aa9fbdbfc2
commit
1353a2fd20
@ -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)
|
||||
|
||||
|
||||
@ -354,7 +354,7 @@ test-suite ghcup-test
|
||||
default-language: Haskell2010
|
||||
default-extensions:
|
||||
LambdaCase
|
||||
MultiWayIf++-
|
||||
MultiWayIf
|
||||
PackageImports
|
||||
RecordWildCards
|
||||
ScopedTypeVariables
|
||||
|
||||
Loading…
Reference in New Issue
Block a user