Merge remote-tracking branch 'origin/pr/850'
This commit is contained in:
commit
e214695a3e
@ -7,6 +7,10 @@
|
|||||||
{-# LANGUAGE ViewPatterns #-}
|
{-# LANGUAGE ViewPatterns #-}
|
||||||
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
|
{-# OPTIONS_GHC -Wno-unused-record-wildcards #-}
|
||||||
{-# OPTIONS_GHC -Wno-unused-matches #-}
|
{-# OPTIONS_GHC -Wno-unused-matches #-}
|
||||||
|
{-# LANGUAGE FlexibleInstances #-}
|
||||||
|
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||||
|
{-# LANGUAGE TemplateHaskell #-}
|
||||||
|
{-# LANGUAGE BangPatterns #-}
|
||||||
|
|
||||||
module BrickMain where
|
module BrickMain where
|
||||||
|
|
||||||
@ -23,13 +27,23 @@ import GHCup.Prelude.Process
|
|||||||
import GHCup.Prompts
|
import GHCup.Prompts
|
||||||
|
|
||||||
import Brick
|
import Brick
|
||||||
import Brick.Widgets.Border
|
( BrickEvent(VtyEvent, MouseDown),
|
||||||
import Brick.Widgets.Border.Style
|
App(..),
|
||||||
import Brick.Widgets.Center
|
Padding(Max, Pad),
|
||||||
import Brick.Widgets.List ( listSelectedFocusedAttr
|
AttrMap,
|
||||||
, listSelectedAttr
|
EventM,
|
||||||
, listAttr
|
Size(..),
|
||||||
)
|
Widget(..),
|
||||||
|
ViewportType (Vertical),
|
||||||
|
(<+>),
|
||||||
|
(<=>))
|
||||||
|
import qualified Brick
|
||||||
|
import Brick.Widgets.Border ( hBorder, borderWithLabel)
|
||||||
|
import Brick.Widgets.Border.Style ( unicode )
|
||||||
|
import Brick.Widgets.Center ( center, centerLayer )
|
||||||
|
import qualified Brick.Widgets.List as L
|
||||||
|
import Brick.Focus (FocusRing)
|
||||||
|
import qualified Brick.Focus as F
|
||||||
import Codec.Archive
|
import Codec.Archive
|
||||||
import Control.Applicative
|
import Control.Applicative
|
||||||
import Control.Exception.Safe
|
import Control.Exception.Safe
|
||||||
@ -41,13 +55,14 @@ 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 ( (&), on)
|
||||||
import Data.List
|
import Data.List
|
||||||
import Data.Maybe
|
import Data.Maybe
|
||||||
import Data.IORef
|
import Data.IORef (IORef, readIORef, newIORef, writeIORef, modifyIORef)
|
||||||
import Data.Vector ( Vector
|
import Data.Vector ( Vector
|
||||||
, (!?)
|
|
||||||
)
|
)
|
||||||
import Data.Versions
|
import Data.Versions hiding (Lens')
|
||||||
import Haskus.Utils.Variant.Excepts
|
import Haskus.Utils.Variant.Excepts
|
||||||
import Prelude hiding ( appendFile )
|
import Prelude hiding ( appendFile )
|
||||||
import System.Exit
|
import System.Exit
|
||||||
@ -68,6 +83,175 @@ import System.FilePath
|
|||||||
import qualified System.Posix.Process as SPP
|
import qualified System.Posix.Process as SPP
|
||||||
#endif
|
#endif
|
||||||
|
|
||||||
|
import Optics.TH (makeLenses, makeLensesFor)
|
||||||
|
import Optics.State (use)
|
||||||
|
import Optics.State.Operators ( (.=), (%=), (<%=))
|
||||||
|
import Optics.Operators ((.~), (^.), (%~))
|
||||||
|
import Optics.Getter (view)
|
||||||
|
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)
|
||||||
|
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
|
||||||
|
|
||||||
|
|
||||||
|
-- | 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
|
||||||
|
|
||||||
|
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 ()
|
||||||
|
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 -> 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 ()
|
||||||
|
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 -> 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 -> Brick.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 -> 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_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)
|
||||||
|
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
|
||||||
|
|
||||||
|
{- 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.
|
||||||
|
|
||||||
|
-}
|
||||||
|
|
||||||
|
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 | KeyInfo | Tutorial deriving (Eq, Show, Ord)
|
||||||
|
|
||||||
installedSign :: String
|
installedSign :: String
|
||||||
#if IS_WINDOWS
|
#if IS_WINDOWS
|
||||||
@ -92,56 +276,45 @@ notInstalledSign = "✗ "
|
|||||||
|
|
||||||
|
|
||||||
data BrickData = BrickData
|
data BrickData = BrickData
|
||||||
{ lr :: [ListResult]
|
{ _lr :: [ListResult]
|
||||||
}
|
}
|
||||||
deriving Show
|
deriving Show
|
||||||
|
|
||||||
data BrickSettings = BrickSettings
|
makeLenses ''BrickData
|
||||||
{ showAllVersions :: Bool
|
|
||||||
}
|
|
||||||
deriving Show
|
|
||||||
|
|
||||||
data BrickInternalState = BrickInternalState
|
data BrickSettings = BrickSettings { _showAllVersions :: Bool}
|
||||||
{ clr :: Vector ListResult
|
--deriving Show
|
||||||
, ix :: Int
|
|
||||||
}
|
makeLenses ''BrickSettings
|
||||||
deriving Show
|
|
||||||
|
type BrickInternalState = SectionList Name ListResult
|
||||||
|
|
||||||
data BrickState = BrickState
|
data BrickState = BrickState
|
||||||
{ appData :: BrickData
|
{ _appData :: BrickData
|
||||||
, appSettings :: BrickSettings
|
, _appSettings :: BrickSettings
|
||||||
, appState :: BrickInternalState
|
, _appState :: BrickInternalState
|
||||||
, appKeys :: KeyBindings
|
, _appKeys :: KeyBindings
|
||||||
|
, _mode :: Mode
|
||||||
|
}
|
||||||
|
--deriving Show
|
||||||
|
|
||||||
|
makeLenses ''BrickState
|
||||||
|
|
||||||
|
app :: AttrMap -> AttrMap -> App BrickState () Name
|
||||||
|
app attrs dimAttrs =
|
||||||
|
App { appDraw = drawUI dimAttrs
|
||||||
|
, appHandleEvent = eventHandler
|
||||||
|
, appStartEvent = return ()
|
||||||
|
, appAttrMap = const attrs
|
||||||
|
, appChooseCursor = Brick.showFirstCursor
|
||||||
}
|
}
|
||||||
deriving Show
|
|
||||||
|
|
||||||
|
|
||||||
keyHandlers :: KeyBindings
|
{- Drawing.
|
||||||
-> [ ( KeyCombination
|
|
||||||
, BrickSettings -> String
|
|
||||||
, BrickState -> EventM String BrickState ()
|
|
||||||
)
|
|
||||||
]
|
|
||||||
keyHandlers KeyBindings {..} =
|
|
||||||
[ (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)
|
|
||||||
)
|
|
||||||
, (bUp, const "Up", \BrickState {..} -> put BrickState{ appState = moveCursor 1 appState Up, .. })
|
|
||||||
, (bDown, const "Down", \BrickState {..} -> put BrickState{ appState = moveCursor 1 appState Down, .. })
|
|
||||||
]
|
|
||||||
where
|
|
||||||
hideShowHandler f BrickState{..} =
|
|
||||||
let newAppSettings = appSettings { showAllVersions = f appSettings }
|
|
||||||
newInternalState = constructList appData newAppSettings (Just appState)
|
|
||||||
in put (BrickState appData newAppSettings newInternalState appKeys)
|
|
||||||
|
|
||||||
|
The section for creating our widgets.
|
||||||
|
|
||||||
|
-}
|
||||||
|
|
||||||
showKey :: Vty.Key -> String
|
showKey :: Vty.Key -> String
|
||||||
showKey (Vty.KChar c) = [c]
|
showKey (Vty.KChar c) = [c]
|
||||||
@ -153,38 +326,38 @@ showMod :: Vty.Modifier -> String
|
|||||||
showMod = tail . show
|
showMod = tail . show
|
||||||
|
|
||||||
|
|
||||||
ui :: AttrMap -> BrickState -> Widget String
|
drawNavigation :: AttrMap -> BrickState -> Widget Name
|
||||||
ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
|
drawNavigation 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 <=> hBorder <=> renderList' _appState))
|
||||||
)
|
)
|
||||||
<=> footer
|
<=> footer
|
||||||
|
|
||||||
where
|
where
|
||||||
footer =
|
footer =
|
||||||
withAttr (attrName "help")
|
Brick.withAttr helpAttr
|
||||||
. 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', ..} =
|
in Brick.withDefAttr L.listAttr $ renderSectionList (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 setAttr $ Brick.str setSign)
|
||||||
| lInstalled -> (withAttr (attrName "installed") $ str installedSign)
|
| lInstalled -> (Brick.withAttr installedAttr $ Brick.str installedSign)
|
||||||
| otherwise -> (withAttr (attrName "not-installed") $ str notInstalledSign)
|
| otherwise -> (Brick.withAttr notInstalledAttr $ Brick.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)
|
||||||
@ -192,127 +365,192 @@ 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 hoorayAttr
|
||||||
| 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 recommendedAttr $ Brick.str "recommended"
|
||||||
printTag Latest = Just $ withAttr (attrName "latest") $ str "latest"
|
printTag Latest = Just $ Brick.withAttr latestAttr $ Brick.str "latest"
|
||||||
printTag Prerelease = Just $ withAttr (attrName "prerelease") $ str "prerelease"
|
printTag Prerelease = Just $ Brick.withAttr prereleaseAttr $ Brick.str "prerelease"
|
||||||
printTag Nightly = Just $ withAttr (attrName "nightly") $ str "nightly"
|
printTag Nightly = Just $ Brick.withAttr nightlyAttr $ 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 latestPrereleaseAttr $ Brick.str "latest-prerelease"
|
||||||
printTag LatestNightly = Just $ withAttr (attrName "latest-nightly") $ str "latest-nightly"
|
printTag LatestNightly = Just $ Brick.withAttr latestNightlyAttr $ 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 hlsPoweredAttr $ Brick.str "hls-powered"] else mempty
|
||||||
)
|
)
|
||||||
++ (if lStray then [withAttr (attrName "stray") $ str "stray"] else mempty)
|
++ (if lStray then [Brick.withAttr strayAttr $ 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 dayAttr $ Brick.str (show d)])
|
||||||
|
|
||||||
-- | Draws the list elements.
|
minHSize s' = Brick.hLimit s' . Brick.vLimit 1 . (<+> Brick.fill ' ')
|
||||||
--
|
|
||||||
-- Evaluates the underlying container up to, and a bit beyond, the
|
drawTutorial :: Widget Name
|
||||||
-- selected element. The exact amount depends on available height
|
drawTutorial =
|
||||||
-- 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
|
let
|
||||||
es = clr
|
mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max)
|
||||||
listSelected = fmap fst $ listSelectedElement' is
|
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.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.txtWrap " means that the tool is installed but not in used"
|
||||||
|
]
|
||||||
|
, Brick.hBox [
|
||||||
|
Brick.txt "This symbol "
|
||||||
|
, Brick.withAttr setAttr (Brick.str setSign)
|
||||||
|
, Brick.txtWrap " 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.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"
|
||||||
|
, Brick.txtWrap " 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.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 q to exit the tutorial")
|
||||||
|
|
||||||
drawnElements = flip V.imap es $ \i' e ->
|
drawKeyInfo :: KeyBindings -> Widget Name
|
||||||
let addSeparator w = case es !? (i' - 1) of
|
drawKeyInfo KeyBindings {..} =
|
||||||
Just e' | lTool e' /= lTool e ->
|
let
|
||||||
hBorder <=> w
|
mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max)
|
||||||
_ -> w
|
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 q to return to Navigation" <+> Brick.padRight Brick.Max (Brick.txt " ") <+> Brick.txt "Press Enter to go to the Tutorial"]
|
||||||
|
|
||||||
isSelected = Just i' == listSelected
|
drawUI :: AttrMap -> BrickState -> [Widget Name]
|
||||||
elemWidget = drawElem i' isSelected e
|
drawUI dimAttrs st =
|
||||||
selItemAttr = if foc
|
let navg = drawNavigation dimAttrs st
|
||||||
then withDefAttr listSelectedFocusedAttr
|
in case st ^. mode of
|
||||||
else withDefAttr listSelectedAttr
|
Navigation -> [navg]
|
||||||
makeVisible' = if isSelected then visible . selItemAttr else id
|
Tutorial -> [drawTutorial, navg]
|
||||||
in addSeparator $ makeVisible' elemWidget
|
KeyInfo -> [drawKeyInfo (st ^. appKeys), navg]
|
||||||
|
|
||||||
in render
|
{- Attributes
|
||||||
$ viewport "GHCup" Vertical
|
|
||||||
$ vBox
|
|
||||||
$ V.toList drawnElements
|
|
||||||
|
|
||||||
|
-}
|
||||||
|
|
||||||
minHSize :: Int -> Widget n -> Widget n
|
|
||||||
minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ')
|
|
||||||
|
|
||||||
|
|
||||||
app :: AttrMap -> AttrMap -> App BrickState e String
|
|
||||||
app attrs dimAttrs =
|
|
||||||
App { appDraw = \st -> [ui dimAttrs st]
|
|
||||||
, appHandleEvent = \be -> get >>= \s -> eventHandler s be
|
|
||||||
, appStartEvent = return ()
|
|
||||||
, appAttrMap = const attrs
|
|
||||||
, appChooseCursor = 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 "not-installed" , Vty.defAttr `withForeColor` Vty.red)
|
, (L.listSelectedAttr , Vty.defAttr)
|
||||||
, (attrName "set" , Vty.defAttr `withForeColor` Vty.green)
|
, (notInstalledAttr , Vty.defAttr `withForeColor` Vty.red)
|
||||||
, (attrName "installed" , Vty.defAttr `withForeColor` Vty.green)
|
, (setAttr , Vty.defAttr `withForeColor` Vty.green)
|
||||||
, (attrName "recommended" , Vty.defAttr `withForeColor` Vty.green)
|
, (installedAttr , Vty.defAttr `withForeColor` Vty.green)
|
||||||
, (attrName "hls-powered" , Vty.defAttr `withForeColor` Vty.green)
|
, (recommendedAttr , Vty.defAttr `withForeColor` Vty.green)
|
||||||
, (attrName "latest" , Vty.defAttr `withForeColor` Vty.yellow)
|
, (hlsPoweredAttr , Vty.defAttr `withForeColor` Vty.green)
|
||||||
, (attrName "latest-prerelease" , Vty.defAttr `withForeColor` Vty.red)
|
, (latestAttr , Vty.defAttr `withForeColor` Vty.yellow)
|
||||||
, (attrName "latest-nightly" , Vty.defAttr `withForeColor` Vty.red)
|
, (latestPrereleaseAttr , Vty.defAttr `withForeColor` Vty.red)
|
||||||
, (attrName "prerelease" , Vty.defAttr `withForeColor` Vty.red)
|
, (latestNightlyAttr , Vty.defAttr `withForeColor` Vty.red)
|
||||||
, (attrName "nightly" , Vty.defAttr `withForeColor` Vty.red)
|
, (prereleaseAttr , Vty.defAttr `withForeColor` Vty.red)
|
||||||
, (attrName "compiled" , Vty.defAttr `withForeColor` Vty.blue)
|
, (nightlyAttr , Vty.defAttr `withForeColor` Vty.red)
|
||||||
, (attrName "stray" , Vty.defAttr `withForeColor` Vty.blue)
|
, (compiledAttr , Vty.defAttr `withForeColor` Vty.blue)
|
||||||
, (attrName "day" , Vty.defAttr `withForeColor` Vty.blue)
|
, (strayAttr , Vty.defAttr `withForeColor` Vty.blue)
|
||||||
, (attrName "help" , Vty.defAttr `withStyle` Vty.italic)
|
, (dayAttr , Vty.defAttr `withForeColor` Vty.blue)
|
||||||
, (attrName "hooray" , Vty.defAttr `withForeColor` Vty.brightWhite)
|
, (helpAttr , Vty.defAttr `withStyle` Vty.italic)
|
||||||
|
, (hoorayAttr , Vty.defAttr `withForeColor` Vty.brightWhite)
|
||||||
]
|
]
|
||||||
where
|
where
|
||||||
withForeColor | no_color = const
|
withForeColor | no_color = const
|
||||||
@ -323,58 +561,130 @@ defaultAttributes no_color = attrMap
|
|||||||
|
|
||||||
withStyle = Vty.withStyle
|
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 :: 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
|
||||||
| otherwise = Vty.withBackColor
|
| otherwise = Vty.withBackColor
|
||||||
|
|
||||||
eventHandler :: BrickState -> BrickEvent String e -> EventM String BrickState ()
|
{- Handlers
|
||||||
eventHandler st@BrickState{..} ev = do
|
|
||||||
|
-}
|
||||||
|
|
||||||
|
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)
|
||||||
|
)
|
||||||
|
, (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 = do
|
||||||
|
app_settings <- use appSettings
|
||||||
|
let
|
||||||
|
vers = f app_settings
|
||||||
|
newAppSettings = app_settings & showAllVersions .~ vers
|
||||||
|
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
|
||||||
|
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 ()
|
||||||
|
navigationHandler ev = do
|
||||||
AppState { keyBindings = kb } <- liftIO $ readIORef settings'
|
AppState { keyBindings = kb } <- liftIO $ readIORef settings'
|
||||||
case ev of
|
case ev of
|
||||||
(MouseDown _ Vty.BScrollUp _ _) ->
|
inner_event@(VtyEvent (Vty.EvKey key _)) ->
|
||||||
put (BrickState { appState = moveCursor 1 appState Up, .. })
|
case find (\(key', _, _) -> key' == KeyCombination key []) (keyHandlers kb) of
|
||||||
(MouseDown _ Vty.BScrollDown _ _) ->
|
Nothing -> void $ Brick.zoom (toLensVL appState) $ handleGenericListEvent inner_event
|
||||||
put (BrickState { appState = moveCursor 1 appState Down, .. })
|
Just (_, _, handler) -> handler
|
||||||
(VtyEvent (Vty.EvResize _ _)) -> put st
|
inner_event -> Brick.zoom (toLensVL appState) $ handleGenericListEvent inner_event
|
||||||
(VtyEvent (Vty.EvKey Vty.KUp [])) ->
|
|
||||||
put BrickState{ appState = moveCursor 1 appState Up, .. }
|
eventHandler :: BrickEvent Name e -> EventM Name BrickState ()
|
||||||
(VtyEvent (Vty.EvKey Vty.KDown [])) ->
|
eventHandler ev = do
|
||||||
put BrickState{ appState = moveCursor 1 appState Down, .. }
|
m <- use mode
|
||||||
(VtyEvent (Vty.EvKey key mods)) ->
|
case m of
|
||||||
case find (\(keyCombo, _, _) -> keyCombo == KeyCombination key mods) (keyHandlers kb) of
|
KeyInfo -> keyInfoHandler ev
|
||||||
Nothing -> put st
|
Tutorial -> tutorialHandler ev
|
||||||
Just (_, _, handler) -> handler st
|
Navigation -> navigationHandler ev
|
||||||
_ -> put st
|
|
||||||
|
|
||||||
|
|
||||||
moveCursor :: Int -> BrickInternalState -> Direction -> BrickInternalState
|
{- Core Logic.
|
||||||
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, .. }
|
|
||||||
Nothing -> ais
|
|
||||||
|
|
||||||
|
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
|
-- | 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)
|
||||||
=> (BrickState
|
=> ( (Int, ListResult) -> ReaderT AppState IO (Either String a))
|
||||||
-> (Int, ListResult)
|
|
||||||
-> ReaderT AppState IO (Either String a))
|
|
||||||
-> BrickState
|
|
||||||
-> EventM n BrickState ()
|
-> EventM n BrickState ()
|
||||||
withIOAction action as = case listSelectedElement' (appState as) of
|
withIOAction action = do
|
||||||
Nothing -> put as
|
as <- Brick.get
|
||||||
Just (ix, e) -> do
|
case sectionListSelectedElement (view appState as) of
|
||||||
suspendAndResume $ do
|
Nothing -> pure ()
|
||||||
|
Just (curr_ix, e) -> do
|
||||||
|
Brick.suspendAndResume $ do
|
||||||
settings <- readIORef settings'
|
settings <- readIORef settings'
|
||||||
flip runReaderT settings $ action as (ix, e) >>= \case
|
flip runReaderT settings $ action (curr_ix, e) >>= \case
|
||||||
Left err -> liftIO $ putStrLn ("Error: " <> err)
|
Left err -> liftIO $ putStrLn ("Error: " <> err)
|
||||||
Right _ -> liftIO $ putStrLn "Success"
|
Right _ -> liftIO $ putStrLn "Success"
|
||||||
getAppData Nothing >>= \case
|
getAppData Nothing >>= \case
|
||||||
@ -390,28 +700,35 @@ withIOAction action as = case listSelectedElement' (appState as) of
|
|||||||
-- and @BrickSettings@.
|
-- and @BrickSettings@.
|
||||||
updateList :: BrickData -> BrickState -> BrickState
|
updateList :: BrickData -> BrickState -> BrickState
|
||||||
updateList appD BrickState{..} =
|
updateList appD BrickState{..} =
|
||||||
let newInternalState = constructList appD appSettings (Just appState)
|
let newInternalState = constructList appD _appSettings (Just _appState)
|
||||||
in BrickState { appState = newInternalState
|
in BrickState { _appState = newInternalState
|
||||||
, appData = appD
|
, _appData = appD
|
||||||
, appSettings = appSettings
|
, _appSettings = _appSettings
|
||||||
, appKeys = appKeys
|
, _appKeys = _appKeys
|
||||||
|
, _mode = Navigation
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
||||||
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))
|
||||||
(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 (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
|
||||||
|
& 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
|
||||||
@ -421,14 +738,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 = [(Singular $ lTool (head g), V.fromList g) | g <- groupBy ((==) `on` lTool ) (filter filterF list_result)]
|
||||||
newSelected =
|
newSectionList = sectionList AllTools newVec 1
|
||||||
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
|
||||||
@ -446,10 +762,9 @@ filterVisible v e | lInstalled e = True
|
|||||||
|
|
||||||
|
|
||||||
install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)
|
install' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)
|
||||||
=> BrickState
|
=> (Int, ListResult)
|
||||||
-> (Int, ListResult)
|
|
||||||
-> m (Either String ())
|
-> m (Either String ())
|
||||||
install' _ (_, ListResult {..}) = do
|
install' (_, ListResult {..}) = do
|
||||||
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
|
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
|
||||||
|
|
||||||
let run =
|
let run =
|
||||||
@ -531,10 +846,9 @@ install' _ (_, ListResult {..}) = do
|
|||||||
|
|
||||||
|
|
||||||
set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)
|
set' :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadFail m, MonadMask m, MonadUnliftIO m, Alternative m)
|
||||||
=> BrickState
|
=> (Int, ListResult)
|
||||||
-> (Int, ListResult)
|
|
||||||
-> m (Either String ())
|
-> m (Either String ())
|
||||||
set' bs input@(_, ListResult {..}) = do
|
set' input@(_, ListResult {..}) = do
|
||||||
settings <- liftIO $ readIORef settings'
|
settings <- liftIO $ readIORef settings'
|
||||||
|
|
||||||
let run =
|
let run =
|
||||||
@ -589,12 +903,12 @@ set' bs input@(_, ListResult {..}) = do
|
|||||||
promptAnswer <- getUserPromptResponse userPrompt
|
promptAnswer <- getUserPromptResponse userPrompt
|
||||||
case promptAnswer of
|
case promptAnswer of
|
||||||
PromptYes -> do
|
PromptYes -> do
|
||||||
res <- install' bs input
|
res <- install' input
|
||||||
case res of
|
case res of
|
||||||
(Left err) -> pure $ Left err
|
(Left err) -> pure $ Left err
|
||||||
(Right _) -> do
|
(Right _) -> do
|
||||||
logInfo "Setting now..."
|
logInfo "Setting now..."
|
||||||
set' bs input
|
set' input
|
||||||
|
|
||||||
PromptNo -> pure $ Left (prettyHFError e)
|
PromptNo -> pure $ Left (prettyHFError e)
|
||||||
where
|
where
|
||||||
@ -609,10 +923,9 @@ set' bs input@(_, ListResult {..}) = do
|
|||||||
|
|
||||||
|
|
||||||
del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m)
|
del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m)
|
||||||
=> BrickState
|
=> (Int, ListResult)
|
||||||
-> (Int, ListResult)
|
|
||||||
-> m (Either String ())
|
-> m (Either String ())
|
||||||
del' _ (_, ListResult {..}) = do
|
del' (_, ListResult {..}) = do
|
||||||
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
|
AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
|
||||||
|
|
||||||
let run = runE @'[NotInstalled, UninstallFailed]
|
let run = runE @'[NotInstalled, UninstallFailed]
|
||||||
@ -636,10 +949,9 @@ del' _ (_, ListResult {..}) = do
|
|||||||
|
|
||||||
|
|
||||||
changelog' :: (MonadReader AppState m, MonadIO m)
|
changelog' :: (MonadReader AppState m, MonadIO m)
|
||||||
=> BrickState
|
=> (Int, ListResult)
|
||||||
-> (Int, ListResult)
|
|
||||||
-> m (Either String ())
|
-> m (Either String ())
|
||||||
changelog' _ (_, ListResult {..}) = do
|
changelog' (_, ListResult {..}) = do
|
||||||
AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
|
AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask
|
||||||
case getChangeLog dls lTool (ToolVersion lVer) of
|
case getChangeLog dls lTool (ToolVersion lVer) of
|
||||||
Nothing -> pure $ Left $
|
Nothing -> pure $ Left $
|
||||||
@ -678,7 +990,6 @@ settings' = unsafePerformIO $ do
|
|||||||
loggerConfig
|
loggerConfig
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
brickMain :: AppState
|
brickMain :: AppState
|
||||||
-> IO ()
|
-> IO ()
|
||||||
brickMain s = do
|
brickMain s = do
|
||||||
@ -687,12 +998,13 @@ 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
|
||||||
(constructList ad defaultAppSettings Nothing)
|
(constructList ad defaultAppSettings Nothing)
|
||||||
(keyBindings (s :: AppState))
|
(keyBindings (s :: AppState))
|
||||||
|
Navigation
|
||||||
|
|
||||||
)
|
)
|
||||||
$> ()
|
$> ()
|
||||||
@ -702,7 +1014,7 @@ brickMain s = do
|
|||||||
|
|
||||||
|
|
||||||
defaultAppSettings :: BrickSettings
|
defaultAppSettings :: BrickSettings
|
||||||
defaultAppSettings = BrickSettings { showAllVersions = False }
|
defaultAppSettings = BrickSettings { _showAllVersions = False}
|
||||||
|
|
||||||
|
|
||||||
getGHCupInfo :: IO (Either String GHCupInfo)
|
getGHCupInfo :: IO (Either String GHCupInfo)
|
||||||
|
|||||||
@ -327,6 +327,8 @@ executable ghcup
|
|||||||
, brick ^>=2.1
|
, brick ^>=2.1
|
||||||
, transformers ^>=0.5
|
, transformers ^>=0.5
|
||||||
, vty ^>=6.0
|
, vty ^>=6.0
|
||||||
|
, unix ^>=2.7
|
||||||
|
, optics ^>=0.4
|
||||||
|
|
||||||
if os(windows)
|
if os(windows)
|
||||||
cpp-options: -DIS_WINDOWS
|
cpp-options: -DIS_WINDOWS
|
||||||
|
|||||||
Loading…
Reference in New Issue
Block a user