diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index e769a56e..1a839810 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -1,16 +1,17 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ViewPatterns #-} {-# OPTIONS_GHC -Wno-unused-record-wildcards #-} -{-# OPTIONS_GHC -Wno-unused-matches #-} -{-# LANGUAGE FlexibleInstances #-} +{-# OPTIONS_GHC -Wno-unused-matches #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE ViewPatterns #-} module BrickMain where @@ -33,8 +34,8 @@ import Brick AttrMap, EventM, Size(..), - Widget(..), - ViewportType (Vertical), + Widget(..), + ViewportType (Vertical), (<+>), (<=>)) import qualified Brick @@ -59,7 +60,7 @@ import Data.List import Data.Maybe import Data.IORef (IORef, readIORef, newIORef, writeIORef, modifyIORef) import Data.Vector ( Vector - + ) import Data.Versions hiding (Lens') import Haskus.Utils.Variant.Excepts @@ -87,14 +88,16 @@ import Optics.State (use) import Optics.State.Operators ( (.=), (%=), (<%=)) import Optics.Operators ((.~), (^.), (%~)) import Optics.Getter (view) -import Optics.Lens (Lens', lens, toLensVL) +import Optics (_1, _2, to, (%)) +import Optics.Lens (Lens', lens, toLensVL, lensVL) + {- 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). +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 @@ -115,8 +118,8 @@ makeLensesFor [("sectionListFocusRing", "sectionListFocusRingL"), ("sectionListE 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 +-- | 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 @@ -128,14 +131,14 @@ sectionList name elements height , 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 +-- 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. + 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 @@ -144,16 +147,16 @@ sectionL section_name = lens g s in gl & sectionListElementsL .~ new_elms moveDown :: (L.Splittable t, Ord n, Foldable t) => EventM n (GenericSectionList n t e) () -moveDown = do +moveDown = do ring <- use sectionListFocusRingL - case F.focusGetCurrent ring of + 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 + 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 @@ -169,10 +172,10 @@ moveUp = do current_list <- use (sectionL l) let current_idx = L.listSelected current_list if current_idx == Just 0 - then do + then do new_focus <- sectionListFocusRingL <%= F.focusPrev case F.focusGetCurrent new_focus of - Nothing -> pure () + 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 @@ -202,41 +205,57 @@ handleGenericListEvent (VtyEvent ev) = do handleGenericListEvent _ = pure () -- This re-uses Brick.Widget.List.renderList -renderSectionList :: (Traversable t, Ord n, Show n, Eq n, L.Splittable t) +renderSectionList :: forall n t e . (Traversable t, Ord n, Show n, Eq n, L.Splittable t, Semigroup (t e)) => (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 +renderSectionList renderElem sectionFocus ge@(GenericSectionList focus elms slName) = + Brick.Widget Brick.Greedy Brick.Greedy $ Brick.render $ Brick.viewport slName Brick.Vertical $ + V.ifoldl' (\(!accWidget) !i list -> + let hasFocusList = sectionIsFocused list + newWidget = if i == 0 + then makeVisible hasFocusList $ renderInnerList hasFocusList list + else hBorder <=> (makeVisible hasFocusList $ renderInnerList hasFocusList list) + in accWidget <=> newWidget + ) + Brick.emptyWidget + elms + where + -- A section is focused if the whole thing is focused, and the inner list has focus + sectionIsFocused :: L.GenericList n t e -> Bool + sectionIsFocused l = sectionFocus && (Just (L.listName l) == F.focusGetCurrent focus) + + renderInnerList :: Bool -> L.GenericList n t e -> Widget n + renderInnerList hasFocus l = Brick.vLimit (length l) $ L.renderList (\b -> renderElem (b && hasFocus)) hasFocus l + + makeVisible :: Bool -- ^ wether to actually make visible + -> Widget n -- ^ widged to make visible + -> Widget n + makeVisible b p + | b = Brick.Widget (hSize p) (vSize p) $ do + result <- render p + let imageSize = ( result ^. lensVL Brick.imageL % to Vty.imageWidth + , result ^. lensVL Brick.imageL % to Vty.imageHeight + ) + return $ if imageSize^._1 > 0 && imageSize^._2 > 0 + then result & lensVL Brick.visibilityRequestsL %~ (Brick.VR (Brick.Location (c, r)) (1, 1) :) + else result + | otherwise = p + where + -- compute the location to focus on + (c, r) :: (Int, Int) = case sectionListSelectedElement ge of + Nothing -> (0, 0) + Just (selElIx, _) -> (0, selElIx) + + -- | 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 + current_focus <- generic_section_list ^. sectionListFocusRingL & F.focusGetCurrent let current_section = generic_section_list ^. sectionL current_focus - L.listSelectedElement current_section + L.listSelectedElement current_section {- Brick app data structures. @@ -311,7 +330,7 @@ app attrs dimAttrs = {- Drawing. -The section for creating our widgets. +The section for creating our widgets. -} @@ -347,7 +366,7 @@ drawNavigation dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..} <+> minHSize 15 (Brick.str "Version") <+> Brick.padLeft (Pad 1) (minHSize 25 $ Brick.str "Tags") <+> Brick.padLeft (Pad 5) (Brick.str "Notes") - renderList' bis = + 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 @@ -418,7 +437,7 @@ drawNavigation dimAttrs BrickState{ _appSettings = as@BrickSettings{}, ..} minHSize s' = Brick.hLimit s' . Brick.vLimit 1 . (<+> Brick.fill ' ') drawTutorial :: Widget Name -drawTutorial = +drawTutorial = let mkTextBox = Brick.hLimitPercent 70 . Brick.vBox . fmap (Brick.padRight Brick.Max) txt_separator = hBorder <+> Brick.str " o " <+> hBorder @@ -427,7 +446,7 @@ drawTutorial = $ Brick.vLimitPercent 50 $ Brick.withBorderStyle unicode $ borderWithLabel (Brick.txt "Tutorial") - $ Brick.vBox + $ Brick.vBox (fmap center [ mkTextBox [Brick.txtWrap "GHCup is a distribution channel for Haskell's tools."] , txt_separator @@ -466,7 +485,7 @@ drawTutorial = ] , Brick.txtWrap "base-X.Y.Z.W tag is the minimun version of the base package admited in such ghc version" ] - , Brick.txt " " + , Brick.txt " " ]) <=> Brick.padRight Brick.Max (Brick.txt "Press q to exit the tutorial") @@ -518,7 +537,7 @@ drawKeyInfo KeyBindings {..} = <=> 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"] drawUI :: AttrMap -> BrickState -> [Widget Name] -drawUI dimAttrs st = +drawUI dimAttrs st = let navg = drawNavigation dimAttrs st in case st ^. mode of Navigation -> [navg] @@ -566,20 +585,20 @@ latestAttr, latestPrereleaseAttr, latestNightlyAttr, prereleaseAttr, nightlyAttr compiledAttr, strayAttr, dayAttr, helpAttr, hoorayAttr:: Brick.AttrName notInstalledAttr = Brick.attrName "not-installed" -setAttr = Brick.attrName "set" -installedAttr = Brick.attrName "installed" -recommendedAttr = Brick.attrName "recommended" +setAttr = Brick.attrName "set" +installedAttr = Brick.attrName "installed" +recommendedAttr = Brick.attrName "recommended" hlsPoweredAttr = Brick.attrName "hls-powered" -latestAttr = Brick.attrName "latest" +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" +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 = Brick.attrMap @@ -618,9 +637,9 @@ keyHandlers KeyBindings {..} = ] where --hideShowHandler' :: (BrickSettings -> Bool) -> (BrickSettings -> Bool) -> m () - hideShowHandler' f = do + hideShowHandler' f = do app_settings <- use appSettings - let + let vers = f app_settings newAppSettings = app_settings & showAllVersions .~ vers ad <- use appData @@ -630,7 +649,7 @@ keyHandlers KeyBindings {..} = tutorialHandler :: BrickEvent Name e -> EventM Name BrickState () -tutorialHandler ev = +tutorialHandler ev = case ev of VtyEvent (Vty.EvKey (Vty.KChar 'q') _ ) -> mode .= Navigation _ -> pure () @@ -661,7 +680,7 @@ eventHandler ev = do Navigation -> navigationHandler ev -{- Core Logic. +{- Core Logic. This section defines the IO actions we can execute within the Brick App: - Install @@ -719,7 +738,7 @@ constructList appD settings = 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) + tool_lens = sectionL (Singular tool) in internal_state & sectionListFocusRingL .~ new_focus & tool_lens %~ L.listMoveTo 0 -- We move to 0 first