Skip to content

Commit

Permalink
Restore TUI scrolling to old behavior
Browse files Browse the repository at this point in the history
  • Loading branch information
@hasufell
hasufell committed Jan 22, 2024
1 parent 2c64cd0 commit 25683fa
Showing 1 changed file with 93 additions and 74 deletions.
167 changes: 93 additions & 74 deletions app/ghcup/BrickMain.hs
View file
Original file line number Diff line number Diff line change
@@ -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

Expand All @@ -33,8 +34,8 @@ import Brick
AttrMap,
EventM,
Size(..),
Widget(..),
ViewportType (Vertical),
Widget(..),
ViewportType (Vertical),
(<+>),
(<=>))
import qualified Brick
Expand All @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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
Expand All @@ -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

Expand Down Expand Up @@ -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.
Expand Down Expand Up @@ -311,7 +330,7 @@ app attrs dimAttrs =

{- Drawing.
The section for creating our widgets.
The section for creating our widgets.
-}

Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand Down Expand Up @@ -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")

Expand Down Expand Up @@ -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]
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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 ()
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down

0 comments on commit 25683fa

Please sign in to comment.