diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index 83c98aa..d9c226f 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -7,6 +7,10 @@ {-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-unused-record-wildcards #-} {-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BangPatterns #-} module BrickMain where @@ -22,14 +26,24 @@ import GHCup.Prelude.Logger import GHCup.Prelude.Process import GHCup.Prompts -import Brick -import Brick.Widgets.Border -import Brick.Widgets.Border.Style -import Brick.Widgets.Center -import Brick.Widgets.List ( listSelectedFocusedAttr - , listSelectedAttr - , listAttr - ) +import Brick + ( BrickEvent(VtyEvent, MouseDown), + App(..), + Padding(Max, Pad), + AttrMap, + EventM, + 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 Control.Applicative import Control.Exception.Safe @@ -41,13 +55,14 @@ import Control.Monad.Trans.Except import Control.Monad.Trans.Resource import Data.Bool import Data.Functor +import Data.Function ( (&), on) import Data.List import Data.Maybe -import Data.IORef +import Data.IORef (IORef, readIORef, newIORef, writeIORef, modifyIORef) import Data.Vector ( Vector - , (!?) + ) -import Data.Versions +import Data.Versions hiding (Lens') import Haskus.Utils.Variant.Excepts import Prelude hiding ( appendFile ) import System.Exit @@ -68,6 +83,175 @@ import System.FilePath import qualified System.Posix.Process as SPP #endif +import Optics.TH (makeLenses, makeLensesFor) +import Optics.State (use) +import Optics.State.Operators ( (.=), (%=), (<%=)) +import Optics.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 #if IS_WINDOWS @@ -92,56 +276,45 @@ notInstalledSign = "✗ " data BrickData = BrickData - { lr :: [ListResult] + { _lr :: [ListResult] } deriving Show -data BrickSettings = BrickSettings - { showAllVersions :: Bool - } - deriving Show +makeLenses ''BrickData -data BrickInternalState = BrickInternalState - { clr :: Vector ListResult - , ix :: Int - } - deriving Show +data BrickSettings = BrickSettings { _showAllVersions :: Bool} + --deriving Show + +makeLenses ''BrickSettings + +type BrickInternalState = SectionList Name ListResult data BrickState = BrickState - { appData :: BrickData - , appSettings :: BrickSettings - , appState :: BrickInternalState - , appKeys :: KeyBindings + { _appData :: BrickData + , _appSettings :: BrickSettings + , _appState :: BrickInternalState + , _appKeys :: KeyBindings + , _mode :: Mode } - deriving Show + --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 + } -keyHandlers :: KeyBindings - -> [ ( 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) +{- Drawing. +The section for creating our widgets. + +-} showKey :: Vty.Key -> String showKey (Vty.KChar c) = [c] @@ -153,38 +326,38 @@ showMod :: Vty.Modifier -> String 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)) +drawNavigation :: AttrMap -> BrickState -> Widget Name +drawNavigation dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..} + = Brick.padBottom Max + ( Brick.withBorderStyle unicode + $ borderWithLabel (Brick.str "GHCup") + (center (header <=> hBorder <=> renderList' _appState)) ) <=> footer - where footer = - withAttr (attrName "help") - . txtWrap + Brick.withAttr helpAttr + . Brick.txtWrap . T.pack . foldr1 (\x y -> x <> " " <> y) . fmap (\(KeyCombination key mods, s, _) -> intercalate "+" (showKey key : (showMod <$> mods)) <> ":" <> s as) - $ keyHandlers appKeys + $ keyHandlers _appKeys header = - minHSize 2 emptyWidget - <+> padLeft (Pad 2) (minHSize 6 $ str "Tool") - <+> 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 + in Brick.withDefAttr L.listAttr $ renderSectionList (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 setAttr $ Brick.str setSign) + | lInstalled -> (Brick.withAttr installedAttr $ Brick.str installedSign) + | otherwise -> (Brick.withAttr notInstalledAttr $ Brick.str notInstalledSign) ver = case lCross of Nothing -> T.unpack . prettyVer $ lVer Just c -> T.unpack (c <> "-" <> prettyVer lVer) @@ -192,127 +365,192 @@ 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 hoorayAttr | 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 recommendedAttr $ Brick.str "recommended" + printTag Latest = Just $ Brick.withAttr latestAttr $ Brick.str "latest" + printTag Prerelease = Just $ Brick.withAttr prereleaseAttr $ Brick.str "prerelease" + printTag Nightly = Just $ Brick.withAttr nightlyAttr $ Brick.str "nightly" + printTag (Base pvp'') = Just $ Brick.str ("base-" ++ T.unpack (prettyPVP pvp'')) printTag Old = Nothing - printTag LatestPrerelease = Just $ 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 latestPrereleaseAttr $ Brick.str "latest-prerelease" + printTag LatestNightly = Just $ Brick.withAttr latestNightlyAttr $ 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 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 Nothing -> mempty - Just d -> [withAttr (attrName "day") $ str (show d)]) + Just d -> [Brick.withAttr dayAttr $ 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 + minHSize s' = Brick.hLimit s' . Brick.vLimit 1 . (<+> Brick.fill ' ') - drawnElements = flip V.imap es $ \i' e -> - let addSeparator w = case es !? (i' - 1) of - Just e' | lTool e' /= lTool e -> - hBorder <=> w - _ -> w +drawTutorial :: Widget Name +drawTutorial = + let + mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max) + txt_separator = hBorder <+> Brick.str " o " <+> hBorder + in centerLayer + $ Brick.hLimitPercent 75 + $ Brick.vLimitPercent 50 + $ Brick.withBorderStyle unicode + $ borderWithLabel (Brick.txt "Tutorial") + $ Brick.vBox + (fmap center + [ mkTextBox [Brick.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") - 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 +drawKeyInfo :: KeyBindings -> Widget Name +drawKeyInfo KeyBindings {..} = + let + mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max) + keyToWidget (KeyCombination key mods) = Brick.str $ intercalate "+" (showKey key : (showMod <$> mods)) + in centerLayer + $ Brick.hLimitPercent 75 + $ Brick.vLimitPercent 50 + $ Brick.withBorderStyle unicode + $ borderWithLabel (Brick.txt "Key Actions") + $ Brick.vBox [ + center $ + mkTextBox [ + Brick.hBox [ + Brick.txt "Press " + , keyToWidget bUp, Brick.txt " and ", keyToWidget bDown + , Brick.txtWrap " to navigate the list of tools" + ] + , Brick.hBox [ + Brick.txt "Press " + , keyToWidget bInstall + , Brick.txtWrap " to install the selected tool. Notice, you may need to set it as default afterwards" + ] + , Brick.hBox [ + Brick.txt "Press " + , keyToWidget bSet + , Brick.txtWrap " to set a tool as the one for use" + ] + , Brick.hBox [ + Brick.txt "Press " + , keyToWidget bUninstall + , Brick.txtWrap " to uninstall a tool" + ] + , Brick.hBox [ + Brick.txt "Press " + , keyToWidget bChangelog + , Brick.txtWrap " to open the tool's changelog. It will open a web browser" + ] + , Brick.hBox [ + Brick.txt "Press " + , keyToWidget bShowAllVersions + , Brick.txtWrap " to show older version of each tool" + ] + ] + ] + <=> Brick.hBox [Brick.txt "Press q to return to Navigation" <+> Brick.padRight Brick.Max (Brick.txt " ") <+> Brick.txt "Press Enter to go to the Tutorial"] - in render - $ viewport "GHCup" Vertical - $ vBox - $ V.toList drawnElements +drawUI :: AttrMap -> BrickState -> [Widget Name] +drawUI dimAttrs st = + let navg = drawNavigation dimAttrs st + in case st ^. mode of + Navigation -> [navg] + Tutorial -> [drawTutorial, navg] + KeyInfo -> [drawKeyInfo (st ^. appKeys), navg] +{- Attributes -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 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) + [ (L.listSelectedFocusedAttr , Vty.defAttr `withBackColor` Vty.blue) + , (L.listSelectedAttr , Vty.defAttr) + , (notInstalledAttr , Vty.defAttr `withForeColor` Vty.red) + , (setAttr , Vty.defAttr `withForeColor` Vty.green) + , (installedAttr , Vty.defAttr `withForeColor` Vty.green) + , (recommendedAttr , Vty.defAttr `withForeColor` Vty.green) + , (hlsPoweredAttr , Vty.defAttr `withForeColor` Vty.green) + , (latestAttr , Vty.defAttr `withForeColor` Vty.yellow) + , (latestPrereleaseAttr , Vty.defAttr `withForeColor` Vty.red) + , (latestNightlyAttr , Vty.defAttr `withForeColor` Vty.red) + , (prereleaseAttr , Vty.defAttr `withForeColor` Vty.red) + , (nightlyAttr , Vty.defAttr `withForeColor` Vty.red) + , (compiledAttr , Vty.defAttr `withForeColor` Vty.blue) + , (strayAttr , Vty.defAttr `withForeColor` Vty.blue) + , (dayAttr , Vty.defAttr `withForeColor` Vty.blue) + , (helpAttr , Vty.defAttr `withStyle` Vty.italic) + , (hoorayAttr , Vty.defAttr `withForeColor` Vty.brightWhite) ] where withForeColor | no_color = const @@ -323,66 +561,138 @@ defaultAttributes no_color = attrMap withStyle = Vty.withStyle + +notInstalledAttr, setAttr, installedAttr, recommendedAttr, hlsPoweredAttr:: Brick.AttrName +latestAttr, latestPrereleaseAttr, latestNightlyAttr, prereleaseAttr, nightlyAttr:: Brick.AttrName +compiledAttr, strayAttr, dayAttr, helpAttr, hoorayAttr:: Brick.AttrName + +notInstalledAttr = Brick.attrName "not-installed" +setAttr = Brick.attrName "set" +installedAttr = Brick.attrName "installed" +recommendedAttr = Brick.attrName "recommended" +hlsPoweredAttr = Brick.attrName "hls-powered" +latestAttr = Brick.attrName "latest" +latestPrereleaseAttr = Brick.attrName "latest-prerelease" +latestNightlyAttr = Brick.attrName "latest-nightly" +prereleaseAttr = Brick.attrName "prerelease" +nightlyAttr = Brick.attrName "nightly" +compiledAttr = Brick.attrName "compiled" +strayAttr = Brick.attrName "stray" +dayAttr = Brick.attrName "day" +helpAttr = Brick.attrName "help" +hoorayAttr = Brick.attrName "hooray" + dimAttributes :: Bool -> AttrMap -dimAttributes no_color = 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 | otherwise = Vty.withBackColor -eventHandler :: BrickState -> BrickEvent String e -> EventM String BrickState () -eventHandler st@BrickState{..} ev = do +{- Handlers + +-} + +keyHandlers :: KeyBindings + -> [ ( KeyCombination + , BrickSettings -> String + , EventM Name BrickState () + ) + ] +keyHandlers KeyBindings {..} = + [ (bQuit, const "Quit" , Brick.halt) + , (bInstall, const "Install" , withIOAction install') + , (bUninstall, const "Uninstall", withIOAction del') + , (bSet, const "Set" , withIOAction set') + , (bChangelog, const "ChangeLog", withIOAction changelog') + , ( bShowAllVersions + , \BrickSettings {..} -> + if _showAllVersions then "Don't show all versions" else "Show all versions" + , hideShowHandler' (not . _showAllVersions) + ) + , (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' case ev of - (MouseDown _ Vty.BScrollUp _ _) -> - put (BrickState { appState = moveCursor 1 appState Up, .. }) - (MouseDown _ Vty.BScrollDown _ _) -> - put (BrickState { appState = moveCursor 1 appState Down, .. }) - (VtyEvent (Vty.EvResize _ _)) -> put st - (VtyEvent (Vty.EvKey Vty.KUp [])) -> - put BrickState{ appState = moveCursor 1 appState Up, .. } - (VtyEvent (Vty.EvKey Vty.KDown [])) -> - put BrickState{ appState = moveCursor 1 appState Down, .. } - (VtyEvent (Vty.EvKey key mods)) -> - case find (\(keyCombo, _, _) -> keyCombo == KeyCombination key mods) (keyHandlers kb) of - Nothing -> put st - Just (_, _, handler) -> handler st - _ -> put st + inner_event@(VtyEvent (Vty.EvKey key _)) -> + case find (\(key', _, _) -> key' == KeyCombination key []) (keyHandlers kb) of + Nothing -> void $ Brick.zoom (toLensVL appState) $ handleGenericListEvent inner_event + Just (_, _, handler) -> handler + inner_event -> Brick.zoom (toLensVL appState) $ handleGenericListEvent inner_event + +eventHandler :: BrickEvent Name e -> EventM Name BrickState () +eventHandler ev = do + m <- use mode + case m of + KeyInfo -> keyInfoHandler ev + Tutorial -> tutorialHandler ev + Navigation -> navigationHandler ev -moveCursor :: Int -> BrickInternalState -> Direction -> BrickInternalState -moveCursor steps ais@BrickInternalState{..} direction = - let newIx = if direction == Down then ix + steps else ix - steps - in case clr !? newIx of - Just _ -> BrickInternalState { ix = newIx, .. } - Nothing -> ais +{- Core Logic. +This section defines the IO actions we can execute within the Brick App: + - Install + - Set + - UnInstall + - Launch the Changelog + +-} -- | Suspend the current UI and run an IO action in terminal. If the -- IO action returns a Left value, then it's thrown as userError. -withIOAction :: Ord n - => (BrickState - -> (Int, ListResult) - -> ReaderT AppState IO (Either String a)) - -> BrickState +withIOAction :: (Ord n, Eq n) + => ( (Int, ListResult) -> ReaderT AppState IO (Either String a)) -> EventM n BrickState () -withIOAction action as = case listSelectedElement' (appState as) of - Nothing -> put as - Just (ix, e) -> do - suspendAndResume $ do - settings <- readIORef settings' - flip runReaderT settings $ action as (ix, e) >>= \case - Left err -> liftIO $ putStrLn ("Error: " <> err) - Right _ -> liftIO $ putStrLn "Success" - getAppData Nothing >>= \case - Right data' -> do - putStrLn "Press enter to continue" - _ <- getLine - pure (updateList data' as) - Left err -> throwIO $ userError err +withIOAction action = do + as <- Brick.get + case sectionListSelectedElement (view appState as) of + Nothing -> pure () + Just (curr_ix, e) -> do + Brick.suspendAndResume $ do + settings <- readIORef settings' + flip runReaderT settings $ action (curr_ix, e) >>= \case + Left err -> liftIO $ putStrLn ("Error: " <> err) + Right _ -> liftIO $ putStrLn "Success" + getAppData Nothing >>= \case + Right data' -> do + putStrLn "Press enter to continue" + _ <- getLine + pure (updateList data' as) + Left err -> throwIO $ userError err -- | Update app data and list internal state based on new evidence. @@ -390,28 +700,35 @@ withIOAction action as = case listSelectedElement' (appState as) of -- and @BrickSettings@. updateList :: BrickData -> BrickState -> BrickState updateList appD BrickState{..} = - let newInternalState = constructList appD appSettings (Just appState) - in BrickState { appState = newInternalState - , appData = appD - , appSettings = appSettings - , appKeys = appKeys + let newInternalState = constructList appD _appSettings (Just _appState) + in BrickState { _appState = newInternalState + , _appData = appD + , _appSettings = _appSettings + , _appKeys = _appKeys + , _mode = Navigation } - constructList :: BrickData -> BrickSettings -> Maybe BrickInternalState -> BrickInternalState -constructList appD appSettings = - replaceLR (filterVisible (showAllVersions appSettings)) - (lr appD) +constructList appD settings = + replaceLR (filterVisible (_showAllVersions 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 (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. - -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 @@ -421,14 +738,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 = [(Singular $ lTool (head g), V.fromList g) | g <- groupBy ((==) `on` lTool ) (filter filterF list_result)] + newSectionList = sectionList AllTools newVec 1 + 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 @@ -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) - => BrickState - -> (Int, ListResult) + => (Int, ListResult) -> m (Either String ()) -install' _ (_, ListResult {..}) = do +install' (_, ListResult {..}) = do AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask 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) - => BrickState - -> (Int, ListResult) + => (Int, ListResult) -> m (Either String ()) -set' bs input@(_, ListResult {..}) = do +set' input@(_, ListResult {..}) = do settings <- liftIO $ readIORef settings' let run = @@ -589,12 +903,12 @@ set' bs input@(_, ListResult {..}) = do promptAnswer <- getUserPromptResponse userPrompt case promptAnswer of PromptYes -> do - res <- install' bs input + res <- install' input case res of (Left err) -> pure $ Left err (Right _) -> do logInfo "Setting now..." - set' bs input + set' input PromptNo -> pure $ Left (prettyHFError e) where @@ -609,10 +923,9 @@ set' bs input@(_, ListResult {..}) = do del' :: (MonadReader AppState m, MonadIO m, MonadFail m, MonadMask m, MonadUnliftIO m) - => BrickState - -> (Int, ListResult) + => (Int, ListResult) -> m (Either String ()) -del' _ (_, ListResult {..}) = do +del' (_, ListResult {..}) = do AppState { ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask let run = runE @'[NotInstalled, UninstallFailed] @@ -636,10 +949,9 @@ del' _ (_, ListResult {..}) = do changelog' :: (MonadReader AppState m, MonadIO m) - => BrickState - -> (Int, ListResult) + => (Int, ListResult) -> m (Either String ()) -changelog' _ (_, ListResult {..}) = do +changelog' (_, ListResult {..}) = do AppState { pfreq, ghcupInfo = GHCupInfo { _ghcupDownloads = dls }} <- ask case getChangeLog dls lTool (ToolVersion lVer) of Nothing -> pure $ Left $ @@ -678,7 +990,6 @@ settings' = unsafePerformIO $ do loggerConfig - brickMain :: AppState -> IO () brickMain s = do @@ -687,12 +998,13 @@ 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 (constructList ad defaultAppSettings Nothing) (keyBindings (s :: AppState)) + Navigation ) $> () @@ -702,7 +1014,7 @@ brickMain s = do defaultAppSettings :: BrickSettings -defaultAppSettings = BrickSettings { showAllVersions = False } +defaultAppSettings = BrickSettings { _showAllVersions = False} getGHCupInfo :: IO (Either String GHCupInfo) diff --git a/ghcup.cabal b/ghcup.cabal index 3824c08..476eb8e 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -327,6 +327,8 @@ executable ghcup , brick ^>=2.1 , transformers ^>=0.5 , vty ^>=6.0 + , unix ^>=2.7 + , optics ^>=0.4 if os(windows) cpp-options: -DIS_WINDOWS