diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,68 @@ Brick changelog --------------- +0.2 +--- + +API changes: +* Added top-level `Brick` module that re-exports the most important + modules in the library. +* List: + * Now instead of passing the item-drawing function to the `list` state + constructor, it is passed to `renderList` + * `renderList` now takes the row height of the list's item widgets. + The list item-drawing function must respect this in order for + scrolling to work properly. This change made it possible to optimize + the list so that it only draws widgets visible in the viewport + rather than rendering all of the list's items (even the ones + off-screen). But to do this we must be able to tell in advance + how high each one is, so we require this parameter. In addition + this change means that lists no longer support items of different + heights. + * The list now uses Data.Vector instead of [a] to store items; this + permits efficient slicing so we can do the optimized rendering + described above. +* The `HandleEvent` type class `handleEvent` method now runs in + `EventM`. This permits event-handling code implemented in terms of + `HandleEvent` to do get access to viewport state and to run IO code, + making it just as powerful as code in the top-level `EventM` handler. +* Many types were moved from `Brick.Widgets.Core` and `Brick.Main` to + `Brick.Types`, making the former module merely a home for `Widget` + constructors and combinators. +* The `IsString` instance for `Widget` was removed; this might be + reinstated later, but this package provides enough `IsString` + instances that things can get confusing. +* `EventM` is now reader monad over the most recent rendering pass's + viewport state, in addition to being a state monad over viewport + requests for the renderer. Added the `lookupViewport` function to + provide access to the most recent viewport state. Exported the + `Viewport` type and lenses. +* Now that `handleEvent` is now an `EventM` action, composition with + `continue` et al got a little messier when using lenses to + update the application state. To help with this, there is now + `handleEventLensed`. + +Bugfixes: +* Lists now perform well with 10 items or a million (see above; fixes + #7, thanks Simon Michael) +* Added more haddock notes to `Brick.Widgets.Core` about growth + policies. +* Forced evaluation of render states to address a space leak in the + renderer (fixes #14, thanks Sebastian Reuße ) +* str: only reference string content that can be shown (eliminates a + space leak, fixes #14, thanks Sebastian Reuße ) + +Misc: +* Added a makefile for the user guide. +* List: added support for Home and End keys (thanks Simon Michael) +* Viewports: when rendering viewports, scroll requests from `EventM` are + processed before visibility requests from the rendering process; this + reverses this previous order of operations but permits user-supplied + event handlers to reset viewports when desired. + +Package changes: +* Added `deepseq` dependency + 0.1 --- Initial release diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -70,10 +70,10 @@ Your documentation options, in recommended order, are: -* [FAQ](FAQ.md) -* [The brick user guide](docs/guide.rst) +* [FAQ](https://github.com/jtdaugherty/brick/blob/master/FAQ.md) +* [The brick user guide](https://github.com/jtdaugherty/brick/blob/master/docs/guide.rst) * Haddock (all modules) -* [Demo programs](programs) +* [Demo programs](https://github.com/jtdaugherty/brick/blob/master/programs) Status ------ diff --git a/brick.cabal b/brick.cabal --- a/brick.cabal +++ b/brick.cabal @@ -1,5 +1,5 @@ name: brick -version: 0.1 +version: 0.2 synopsis: A declarative terminal user interface library description: Write terminal applications painlessly with 'brick'! You write an @@ -8,8 +8,7 @@ . > module Main where > - > import Brick.Main (simpleMain) - > import Brick.Widgets.Core (Widget, str) + > import Brick > > ui :: Widget > ui = str "Hello, world!" @@ -56,6 +55,7 @@ ghc-options: -Wall -fno-warn-unused-do-bind -O3 hs-source-dirs: src exposed-modules: + Brick Brick.AttrMap Brick.Focus Brick.Main @@ -73,6 +73,7 @@ Data.Text.Markup other-modules: Brick.Types.TH + Brick.Types.Internal Brick.Widgets.Internal build-depends: base <= 5, @@ -86,7 +87,8 @@ contravariant, text, text-zipper >= 0.2.1, - template-haskell + template-haskell, + deepseq >= 1.3 && < 1.5 executable brick-visibility-demo if !flag(demos) @@ -212,7 +214,8 @@ vty >= 5.3.1, data-default, text, - lens + lens, + vector executable brick-custom-event-demo if !flag(demos) diff --git a/docs/guide.rst b/docs/guide.rst --- a/docs/guide.rst +++ b/docs/guide.rst @@ -222,6 +222,59 @@ suspend your interface and execute some other program that needs to gain control of the terminal (such as an external editor). +The HandleEvent Type Class +************************** + +Event handlers are responsible for transforming the application state. +While you can use ordinary methods to do this such as pattern matching +and pure function calls, some widget state types such as the ones +provided by the ``Brick.Widgets.List`` and ``Brick.Widgets.Edit`` +modules support another interface: the ``Brick.Types.HandleEvent`` type +class. + +The ``HandleEvent`` type class has only one method: + +.. code:: haskell + + handleEvent :: Event -> a -> EventM a + +Instances of ``HandleEvent`` provide reasonable default behavior for +handling input events; for example, arrow keys change the ``List`` +selection and input keys modify the text in ``Editor`` states. + +Since ``handleEvent`` runs in ``EventM``, event handlers +written this way have access to rendering viewport states via +``Brick.Main.lookupViewport`` and the ``IO`` monad via ``liftIO``. + +To use ``handleEvent`` in your program, invoke it on the relevant piece +of state in your event handler, e.g., + +.. code:: haskell + + myEvent :: s -> e -> EventM (Next s) + myEvent s e = continue =<< handleEvent e s + +This pattern works fine when your application state instances +``HandleEvent``, but it can become unpleasant if the value on which +you want to invoke ``handleEvent`` is embedded deeply within your +application state. If you have chosen to generate lenses for your +application state fields, you can use the convenience function +``handleEventLensed`` by specifying your state, a lens, and the event: + +.. code:: haskell + + myEvent :: s -> e -> EventM (Next s) + myEvent s e = continue =<< handleEventLensed s someLens e + +Compare that with the more verbose explicit version: + +.. code:: haskell + + myEvent :: s -> e -> EventM (Next s) + myEvent s e = do + newVal <- handleEvent e (s^.someLens) + continue $ s & someLens .~ newVal + Using Your Own Event Type ************************* @@ -419,8 +472,8 @@ How widgets use space when rendered is described in two pieces of information in each ``Widget``: the widget's horizontal and vertical -growth policies. These fields have type ``Brick.Widgets.Core.Size`` and -can have the values ``Fixed`` and ``Greedy``. +growth policies. These fields have type ``Brick.Types.Size`` and can +have the values ``Fixed`` and ``Greedy``. A widget advertising a ``Fixed`` size in a given dimension is a widget that will always consume the same number of rows or columns no @@ -562,8 +615,8 @@ ========= A *viewport* is a scrollable window onto another widget. Viewports have -a *scrolling direction* of type ``Brick.Widgets.Core.ViewportType`` -which can be one of: +a *scrolling direction* of type ``Brick.Types.ViewportType`` which can +be one of: * ``Horizontal``: the viewport can only scroll horizontally. * ``Vertical``: the viewport can only scroll vertically. @@ -729,18 +782,18 @@ render :: RenderM Result -which is a function returning a ``Brick.Widgets.Core.Result``: +which is a function returning a ``Brick.Types.Result``: .. code:: haskell data Result = Result { image :: Graphics.Vty.Image , cursors :: [Brick.Types.CursorLocation] - , visibilityRequests :: [Brick.Widgets.Core.VisibilityRequest] + , visibilityRequests :: [Brick.Types.VisibilityRequest] } The ``RenderM`` monad gives us access to the rendering context (see `How -Widgets and Rendering Work`_) via the ``Brick.Widgets.Core.getContext`` +Widgets and Rendering Work`_) via the ``Brick.Types.getContext`` function. The context type is: .. code:: haskell @@ -774,7 +827,7 @@ determine how much space your widget has to render. To perform an attribute lookup in the attribute map for the context's -current attribute, use ``Brick.Widgets.Core.attrL``. +current attribute, use ``Brick.Types.attrL``. For example, to build a widget that always fills the available width and height with a fill character using the current attribute, we could diff --git a/programs/AttrDemo.hs b/programs/AttrDemo.hs --- a/programs/AttrDemo.hs +++ b/programs/AttrDemo.hs @@ -8,33 +8,36 @@ ) import Brick.Main -import Brick.Widgets.Core +import Brick.Types ( Widget - , (<=>) + ) +import Brick.Widgets.Core + ( (<=>) , withAttr , vBox + , str ) import Brick.Util (on, fg) import Brick.AttrMap (attrMap, AttrMap) ui :: Widget ui = - vBox [ "This text uses the global default attribute." - , withAttr "foundFull" - "Specifying an attribute name means we look it up in the attribute tree." - , withAttr "foundFgOnly" - ("When we find a value, we merge it with its parent in the attribute" - <=> "name tree all the way to the root (the global default).") - , withAttr "missing" - "A missing attribute name just resumes the search at its parent." - , withAttr ("general" <> "specific") - "In this way we build complete attribute values by using an inheritance scheme." - , withAttr "foundFull" - "You can override everything ..." - , withAttr "foundFgOnly" - "... or only you want to change and inherit the rest." - , "Attribute names are assembled with the Monoid append operation to indicate" - , "hierarchy levels, e.g. \"window\" <> \"title\"." + vBox [ str "This text uses the global default attribute." + , withAttr "foundFull" $ + str "Specifying an attribute name means we look it up in the attribute tree." + , (withAttr "foundFgOnly" $ + str ("When we find a value, we merge it with its parent in the attribute") + <=> str "name tree all the way to the root (the global default).") + , withAttr "missing" $ + str "A missing attribute name just resumes the search at its parent." + , withAttr ("general" <> "specific") $ + str "In this way we build complete attribute values by using an inheritance scheme." + , withAttr "foundFull" $ + str "You can override everything ..." + , withAttr "foundFgOnly" $ + str "... or only you want to change and inherit the rest." + , str "Attribute names are assembled with the Monoid append operation to indicate" + , str "hierarchy levels, e.g. \"window\" <> \"title\"." ] globalDefault :: Attr diff --git a/programs/BorderDemo.hs b/programs/BorderDemo.hs --- a/programs/BorderDemo.hs +++ b/programs/BorderDemo.hs @@ -9,9 +9,11 @@ import qualified Brick.Main as M import Brick.Util (fg, bg, on) import qualified Brick.AttrMap as A -import Brick.Widgets.Core +import Brick.Types ( Widget - , (<=>) + ) +import Brick.Widgets.Core + ( (<=>) , (<+>) , vLimit , hLimit @@ -19,6 +21,7 @@ , updateAttrMap , withBorderStyle , txt + , str ) import qualified Brick.Widgets.Center as C import qualified Brick.Widgets.Border as B @@ -55,7 +58,7 @@ mkBorderDemo :: (T.Text, BS.BorderStyle) -> Widget mkBorderDemo (styleName, sty) = withBorderStyle sty $ - B.borderWithLabel "label" $ + B.borderWithLabel (str "label") $ vLimit 5 $ C.vCenter $ txt $ " " <> styleName <> " style " @@ -75,21 +78,21 @@ colorDemo :: Widget colorDemo = updateAttrMap (A.applyAttrMappings borderMappings) $ - B.borderWithLabel "title" $ + B.borderWithLabel (str "title") $ hLimit 20 $ vLimit 5 $ C.center $ - "colors!" + str "colors!" ui :: Widget ui = hBox borderDemos <=> B.hBorder <=> colorDemo - <=> B.hBorderWithLabel "horizontal border label" - <=> (C.center "Left of vertical border" + <=> B.hBorderWithLabel (str "horizontal border label") + <=> (C.center (str "Left of vertical border") <+> B.vBorder - <+> C.center "Right of vertical border") + <+> C.center (str "Right of vertical border")) main :: IO () main = M.simpleMain ui diff --git a/programs/CustomEventDemo.hs b/programs/CustomEventDemo.hs --- a/programs/CustomEventDemo.hs +++ b/programs/CustomEventDemo.hs @@ -11,16 +11,18 @@ import Brick.Main ( App(..) - , Next - , EventM , showFirstCursor , customMain , continue , halt ) -import Brick.Widgets.Core +import Brick.Types ( Widget - , (<=>) + , Next + , EventM + ) +import Brick.Widgets.Core + ( (<=>) , str ) diff --git a/programs/DialogDemo.hs b/programs/DialogDemo.hs --- a/programs/DialogDemo.hs +++ b/programs/DialogDemo.hs @@ -5,9 +5,11 @@ import qualified Graphics.Vty as V import qualified Brick.Main as M -import Brick.Widgets.Core +import Brick.Types ( Widget - , padAll + ) +import Brick.Widgets.Core + ( padAll , str ) import qualified Brick.Widgets.Dialog as D @@ -24,12 +26,12 @@ where ui = D.renderDialog d $ C.hCenter $ padAll 1 $ str "This is the dialog body." -appEvent :: D.Dialog Choice -> V.Event -> M.EventM (M.Next (D.Dialog Choice)) +appEvent :: D.Dialog Choice -> V.Event -> T.EventM (T.Next (D.Dialog Choice)) appEvent d ev = case ev of V.EvKey V.KEsc [] -> M.halt d V.EvKey V.KEnter [] -> M.halt d - _ -> M.continue $ T.handleEvent ev d + _ -> M.continue =<< T.handleEvent ev d initialState :: D.Dialog Choice initialState = D.dialog "dialog" (Just "Title") (Just (0, choices)) 50 diff --git a/programs/EditDemo.hs b/programs/EditDemo.hs --- a/programs/EditDemo.hs +++ b/programs/EditDemo.hs @@ -9,8 +9,7 @@ import qualified Brick.Main as M import qualified Brick.Types as T import Brick.Widgets.Core - ( Widget - , (<+>) + ( (<+>) , (<=>) , hLimit , vLimit @@ -47,21 +46,21 @@ then edit1 else edit2 -drawUI :: St -> [Widget] +drawUI :: St -> [T.Widget] drawUI st = [ui] where - ui = C.center $ ("Input 1 (unlimited): " <+> (hLimit 30 $ vLimit 5 $ E.renderEditor $ st^.edit1)) <=> - " " <=> - ("Input 2 (limited to 2 lines): " <+> (hLimit 30 $ E.renderEditor $ st^.edit2)) <=> - " " <=> - "Press Tab to switch between editors, Esc to quit." + ui = C.center $ (str "Input 1 (unlimited): " <+> (hLimit 30 $ vLimit 5 $ E.renderEditor $ st^.edit1)) <=> + str " " <=> + (str "Input 2 (limited to 2 lines): " <+> (hLimit 30 $ E.renderEditor $ st^.edit2)) <=> + str " " <=> + str "Press Tab to switch between editors, Esc to quit." -appEvent :: St -> V.Event -> M.EventM (M.Next St) +appEvent :: St -> V.Event -> T.EventM (T.Next St) appEvent st ev = case ev of V.EvKey V.KEsc [] -> M.halt st V.EvKey (V.KChar '\t') [] -> M.continue $ switchEditors st - _ -> M.continue $ st & currentEditorL st %~ T.handleEvent ev + _ -> M.continue =<< T.handleEventLensed st (currentEditorL st) ev initialState :: St initialState = diff --git a/programs/HelloWorldDemo.hs b/programs/HelloWorldDemo.hs --- a/programs/HelloWorldDemo.hs +++ b/programs/HelloWorldDemo.hs @@ -1,11 +1,9 @@ -{-# LANGUAGE OverloadedStrings #-} module Main where -import Brick.Main (simpleMain) -import Brick.Widgets.Core (Widget) +import Brick ui :: Widget -ui = "Hello, world!" +ui = str "Hello, world!" main :: IO () main = simpleMain ui diff --git a/programs/LayerDemo.hs b/programs/LayerDemo.hs --- a/programs/LayerDemo.hs +++ b/programs/LayerDemo.hs @@ -11,10 +11,13 @@ import Brick.Types (rowL, columnL) import qualified Brick.Main as M import qualified Brick.Widgets.Border as B -import Brick.Widgets.Core +import Brick.Types ( Widget - , translateBy ) +import Brick.Widgets.Core + ( translateBy + , str + ) data St = St { _topLayerLocation :: T.Location @@ -32,14 +35,14 @@ topLayer :: St -> Widget topLayer st = translateBy (st^.topLayerLocation) $ - B.border "Top layer\n(Arrow keys move)" + B.border $ str "Top layer\n(Arrow keys move)" bottomLayer :: St -> Widget bottomLayer st = translateBy (st^.bottomLayerLocation) $ - B.border "Bottom layer\n(Ctrl-arrow keys move)" + B.border $ str "Bottom layer\n(Ctrl-arrow keys move)" -appEvent :: St -> V.Event -> M.EventM (M.Next St) +appEvent :: St -> V.Event -> T.EventM (T.Next St) appEvent st (V.EvKey V.KDown []) = M.continue $ st & topLayerLocation.rowL %~ (+ 1) appEvent st (V.EvKey V.KUp []) = M.continue $ st & topLayerLocation.rowL %~ (subtract 1) appEvent st (V.EvKey V.KRight []) = M.continue $ st & topLayerLocation.columnL %~ (+ 1) diff --git a/programs/ListDemo.hs b/programs/ListDemo.hs --- a/programs/ListDemo.hs +++ b/programs/ListDemo.hs @@ -12,9 +12,12 @@ import qualified Brick.Widgets.List as L import qualified Brick.Widgets.Center as C import qualified Brick.AttrMap as A -import Brick.Widgets.Core +import qualified Data.Vector as V +import Brick.Types ( Widget - , (<+>) + ) +import Brick.Widgets.Core + ( (<+>) , str , vLimit , hLimit @@ -26,26 +29,26 @@ drawUI :: L.List Int -> [Widget] drawUI l = [ui] where - label = "Item " <+> cur <+> " of " <+> total + label = str "Item " <+> cur <+> str " of " <+> total cur = case l^.(L.listSelectedL) of - Nothing -> "-" + Nothing -> str "-" Just i -> str (show (i + 1)) - total = str $ show $ length $ l^.(L.listElementsL) + total = str $ show $ V.length $ l^.(L.listElementsL) box = B.borderWithLabel label $ hLimit 25 $ vLimit 15 $ - L.renderList l + L.renderList l listDrawElement ui = C.vCenter $ vBox [ C.hCenter box - , " " - , C.hCenter "Press +/- to add/remove list elements." - , C.hCenter "Press Esc to exit." + , str " " + , C.hCenter $ str "Press +/- to add/remove list elements." + , C.hCenter $ str "Press Esc to exit." ] -appEvent :: L.List Int -> V.Event -> M.EventM (M.Next (L.List Int)) +appEvent :: L.List Int -> V.Event -> T.EventM (T.Next (L.List Int)) appEvent l e = case e of V.EvKey (V.KChar '+') [] -> - let el = length $ l^.(L.listElementsL) + let el = V.length $ l^.(L.listElementsL) in M.continue $ L.listInsert el el l V.EvKey (V.KChar '-') [] -> @@ -55,17 +58,17 @@ V.EvKey V.KEsc [] -> M.halt l - ev -> M.continue $ T.handleEvent ev l + ev -> M.continue =<< T.handleEvent ev l listDrawElement :: Bool -> Int -> Widget listDrawElement sel i = let selStr s = if sel then withAttr customAttr (str $ "<" <> s <> ">") else str s - in C.hCenter $ "Item " <+> (selStr $ show i) + in C.hCenter $ str "Item " <+> (selStr $ show i) initialState :: L.List Int -initialState = L.list (T.Name "list") listDrawElement [0, 1, 2] +initialState = L.list (T.Name "list") (V.fromList [0, 1, 2]) 1 customAttr :: A.AttrName customAttr = L.listSelectedAttr <> "custom" diff --git a/programs/MarkupDemo.hs b/programs/MarkupDemo.hs --- a/programs/MarkupDemo.hs +++ b/programs/MarkupDemo.hs @@ -5,9 +5,11 @@ import qualified Graphics.Vty as V import Brick.Main (App(..), defaultMain, resizeOrQuit, neverShowCursor) -import Brick.Widgets.Core +import Brick.Types ( Widget - , (<=>) + ) +import Brick.Widgets.Core + ( (<=>) ) import Brick.Util (on, fg) import Brick.Markup (markup, (@?)) diff --git a/programs/PaddingDemo.hs b/programs/PaddingDemo.hs --- a/programs/PaddingDemo.hs +++ b/programs/PaddingDemo.hs @@ -5,11 +5,14 @@ import qualified Graphics.Vty as V import Brick.Main (App(..), neverShowCursor, resizeOrQuit, defaultMain) -import Brick.Widgets.Core +import Brick.Types ( Widget - , vBox - , hBox , Padding(..) + ) +import Brick.Widgets.Core + ( vBox + , hBox + , str , padAll , padLeft , padRight @@ -23,24 +26,24 @@ ui :: Widget ui = - vBox [ hBox [ padLeft Max $ vCenter "Left-padded" + vBox [ hBox [ padLeft Max $ vCenter $ str "Left-padded" , B.vBorder - , padRight Max $ vCenter "Right-padded" + , padRight Max $ vCenter $ str "Right-padded" ] , B.hBorder - , hBox [ padTop Max $ hCenter "Top-padded" + , hBox [ padTop Max $ hCenter $ str "Top-padded" , B.vBorder - , padBottom Max $ hCenter "Bottom-padded" + , padBottom Max $ hCenter $ str "Bottom-padded" ] , B.hBorder - , hBox [ padLeftRight 2 "Padded by 2 on left/right" + , hBox [ padLeftRight 2 $ str "Padded by 2 on left/right" , B.vBorder - , vBox [ padTopBottom 1 "Padded by 1 on top/bottom" + , vBox [ padTopBottom 1 $ str "Padded by 1 on top/bottom" , B.hBorder ] ] , B.hBorder - , padAll 2 "Padded by 2 on all sides" + , padAll 2 $ str "Padded by 2 on all sides" ] app :: App () V.Event diff --git a/programs/SuspendAndResumeDemo.hs b/programs/SuspendAndResumeDemo.hs --- a/programs/SuspendAndResumeDemo.hs +++ b/programs/SuspendAndResumeDemo.hs @@ -11,11 +11,14 @@ import Brick.Main ( App(..), neverShowCursor, defaultMain , suspendAndResume, halt, continue - , EventM, Next ) -import Brick.Widgets.Core +import Brick.Types ( Widget - , vBox + , EventM + , Next + ) +import Brick.Widgets.Core + ( vBox , str ) @@ -29,7 +32,7 @@ drawUI st = [ui] where ui = vBox [ str $ "External input: \"" <> st^.stExternalInput <> "\"" - , "(Press Esc to quit or Space to ask for input)" + , str "(Press Esc to quit or Space to ask for input)" ] appEvent :: St -> V.Event -> EventM (Next St) diff --git a/programs/ViewportScrollDemo.hs b/programs/ViewportScrollDemo.hs --- a/programs/ViewportScrollDemo.hs +++ b/programs/ViewportScrollDemo.hs @@ -1,5 +1,5 @@ -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE OverloadedStrings #-} module Main where import Control.Applicative @@ -12,10 +12,12 @@ import qualified Brick.Main as M import qualified Brick.Widgets.Center as C import qualified Brick.Widgets.Border as B -import Brick.Widgets.Core +import Brick.Types ( Widget , ViewportType(Horizontal, Vertical, Both) - , hLimit + ) +import Brick.Widgets.Core + ( hLimit , vLimit , hBox , vBox @@ -38,15 +40,15 @@ ui = C.center $ B.border $ hLimit 60 $ vLimit 21 $ vBox [ pair, B.hBorder, singleton ] singleton = viewport vp3Name Both $ - vBox $ "Press ctrl-arrow keys to scroll this viewport horizontally and vertically." + vBox $ str "Press ctrl-arrow keys to scroll this viewport horizontally and vertically." : (str <$> [ "Line " <> show i | i <- [2..25::Int] ]) pair = hBox [ viewport vp1Name Vertical $ - vBox $ "Press up and down arrow keys" : - "to scroll this viewport." : + vBox $ str "Press up and down arrow keys" : + str "to scroll this viewport." : (str <$> [ "Line " <> (show i) | i <- [3..50::Int] ]) , B.vBorder - , viewport vp2Name Horizontal - "Press left and right arrow keys to scroll this viewport." + , viewport vp2Name Horizontal $ + str "Press left and right arrow keys to scroll this viewport." ] vp1Scroll :: M.ViewportScroll @@ -58,7 +60,7 @@ vp3Scroll :: M.ViewportScroll vp3Scroll = M.viewportScroll vp3Name -appEvent :: () -> V.Event -> M.EventM (M.Next ()) +appEvent :: () -> V.Event -> T.EventM (T.Next ()) appEvent _ (V.EvKey V.KDown [V.MCtrl]) = M.vScrollBy vp3Scroll 1 >> M.continue () appEvent _ (V.EvKey V.KUp [V.MCtrl]) = M.vScrollBy vp3Scroll (-1) >> M.continue () appEvent _ (V.EvKey V.KRight [V.MCtrl]) = M.hScrollBy vp3Scroll 1 >> M.continue () diff --git a/programs/VisibilityDemo.hs b/programs/VisibilityDemo.hs --- a/programs/VisibilityDemo.hs +++ b/programs/VisibilityDemo.hs @@ -13,10 +13,12 @@ import qualified Brick.Widgets.Border as B import Brick.AttrMap (AttrMap, AttrName, attrMap) import Brick.Util (on) -import Brick.Widgets.Core +import Brick.Types ( Widget , ViewportType(Horizontal, Vertical, Both) - , withAttr + ) +import Brick.Widgets.Core + ( withAttr , hLimit , vLimit , hBox @@ -100,7 +102,7 @@ vp3Scroll :: M.ViewportScroll vp3Scroll = M.viewportScroll vp3Name -appEvent :: St -> V.Event -> M.EventM (M.Next St) +appEvent :: St -> V.Event -> T.EventM (T.Next St) appEvent st (V.EvKey V.KDown [V.MCtrl]) = M.continue $ st & vp3Index._1 %~ min (vp3Size^._1) . (+ 1) appEvent st (V.EvKey V.KUp [V.MCtrl]) = M.continue $ st & vp3Index._1 %~ max 1 . subtract 1 appEvent st (V.EvKey V.KRight [V.MCtrl]) = M.continue $ st & vp3Index._2 %~ min (vp3Size^._1) . (+ 1) diff --git a/src/Brick.hs b/src/Brick.hs new file mode 100644 --- /dev/null +++ b/src/Brick.hs @@ -0,0 +1,16 @@ +-- | This module is provided as a convenience to import the most +-- important parts of the API all at once. +module Brick + ( module Brick.Main + , module Brick.Types + , module Brick.Widgets.Core + , module Brick.AttrMap + , module Brick.Util + ) +where + +import Brick.Main +import Brick.Types +import Brick.Widgets.Core +import Brick.AttrMap +import Brick.Util diff --git a/src/Brick/Main.hs b/src/Brick/Main.hs --- a/src/Brick/Main.hs +++ b/src/Brick/Main.hs @@ -6,11 +6,10 @@ , resizeOrQuit -- * Event handler functions - , EventM - , Next , continue , halt , suspendAndResume + , lookupViewport -- ** Viewport scrolling , viewportScroll @@ -34,7 +33,9 @@ import Control.Exception (finally) import Control.Lens ((^.)) import Control.Monad (forever) +import Control.Monad.Trans.Class (lift) import Control.Monad.Trans.State +import Control.Monad.Trans.Reader import Control.Concurrent (forkIO, Chan, newChan, readChan, writeChan, killThread) import Data.Default import Data.Maybe (listToMaybe) @@ -52,16 +53,11 @@ , mkVty ) -import Brick.Widgets.Core (Widget) -import Brick.Widgets.Internal (renderFinal, RenderState(..), ScrollRequest(..), Direction(..)) -import Brick.Types (rowL, columnL, CursorLocation(..), cursorLocationNameL, Name(..)) +import Brick.Types (Viewport, Direction, Widget, rowL, columnL, CursorLocation(..), cursorLocationNameL, Name(..), EventM) +import Brick.Types.Internal (ScrollRequest(..), RenderState(..), Next(..)) +import Brick.Widgets.Internal (renderFinal) import Brick.AttrMap --- | The type of actions to take in an event handler. -data Next a = Continue a - | SuspendAndResume (IO a) - | Halt a - -- | The library application abstraction. Your application's operations -- are represented here and passed to one of the various main functions -- in this module. An application is in terms of an application state @@ -98,11 +94,6 @@ -- 'Event', this is just 'id'. } --- | The monad in which event handlers run. -type EventM a = StateT EventState IO a - -type EventState = [(Name, ScrollRequest)] - -- | The default main entry point which takes an application and an -- initial state and returns the final state returned by a 'halt' -- operation. @@ -183,7 +174,7 @@ newAppState <- action run newRS newAppState - (st, initialScrollReqs) <- runStateT (appStartEvent app initialAppState) [] + (st, initialScrollReqs) <- runStateT (runReaderT (appStartEvent app initialAppState) M.empty) [] let initialRS = RS M.empty initialScrollReqs run initialRS st @@ -197,9 +188,17 @@ runVty vty chan app appState rs = do firstRS <- renderApp vty app appState rs e <- readChan chan - (next, scrollReqs) <- runStateT (appHandleEvent app appState e) [] + (next, scrollReqs) <- runStateT (runReaderT (appHandleEvent app appState e) (viewportMap rs)) [] return (next, firstRS { scrollRequests = scrollReqs }) +-- | Given a viewport name, get the viewport's size and offset +-- information from the most recent rendering. Returns 'Nothing' if +-- no such state could be found, either because the name was invalid +-- or because no rendering has occurred (e.g. in an 'appStartEvent' +-- handler). +lookupViewport :: Name -> EventM (Maybe Viewport) +lookupViewport = asks . M.lookup + withVty :: IO Vty -> (Vty -> IO a) -> IO a withVty buildVty useVty = do vty <- buildVty @@ -277,14 +276,14 @@ viewportScroll :: Name -> ViewportScroll viewportScroll n = ViewportScroll { viewportName = n - , hScrollPage = \dir -> modify ((n, HScrollPage dir) :) - , hScrollBy = \i -> modify ((n, HScrollBy i) :) - , hScrollToBeginning = modify ((n, HScrollToBeginning) :) - , hScrollToEnd = modify ((n, HScrollToEnd) :) - , vScrollPage = \dir -> modify ((n, HScrollPage dir) :) - , vScrollBy = \i -> modify ((n, VScrollBy i) :) - , vScrollToBeginning = modify ((n, VScrollToBeginning) :) - , vScrollToEnd = modify ((n, VScrollToEnd) :) + , hScrollPage = \dir -> lift $ modify ((n, HScrollPage dir) :) + , hScrollBy = \i -> lift $ modify ((n, HScrollBy i) :) + , hScrollToBeginning = lift $ modify ((n, HScrollToBeginning) :) + , hScrollToEnd = lift $ modify ((n, HScrollToEnd) :) + , vScrollPage = \dir -> lift $ modify ((n, HScrollPage dir) :) + , vScrollBy = \i -> lift $ modify ((n, VScrollBy i) :) + , vScrollToBeginning = lift $ modify ((n, VScrollToBeginning) :) + , vScrollToEnd = lift $ modify ((n, VScrollToEnd) :) } -- | Continue running the event loop with the specified application diff --git a/src/Brick/Markup.hs b/src/Brick/Markup.hs --- a/src/Brick/Markup.hs +++ b/src/Brick/Markup.hs @@ -19,8 +19,8 @@ import Graphics.Vty (Attr, horizCat, string) -import Brick.Widgets.Core import Brick.AttrMap +import Brick.Types -- | A type class for types that provide access to an attribute in the -- rendering monad. You probably won't need to instance this. diff --git a/src/Brick/Types.hs b/src/Brick/Types.hs --- a/src/Brick/Types.hs +++ b/src/Brick/Types.hs @@ -1,81 +1,172 @@ -- | Basic types used by this library. {-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Brick.Types - ( Location(..) + ( -- * The Widget type + Widget(..) + + -- * Location types and lenses + , Location(..) , locL , TerminalLocation(..) , CursorLocation(..) , cursorLocationL , cursorLocationNameL + + -- * Viewports + , Viewport(..) + , ViewportType(..) + , vpSize + , vpTop + , vpLeft + + -- * Event-handling types + , EventM + , Next , HandleEvent(..) - , Name(..) + , handleEventLensed + + -- * Rendering infrastructure + , RenderM + , getContext + + -- ** The rendering context + , Context(ctxAttrName, availWidth, availHeight, ctxBorderStyle, ctxAttrMap) + , attrL + , availWidthL + , availHeightL + , ctxAttrMapL + , ctxAttrNameL + , ctxBorderStyleL + + -- ** Rendering results + , Result(..) + , lookupAttrName + + -- ** Rendering result lenses + , imageL + , cursorsL + , visibilityRequestsL + + -- ** Visibility requests + , VisibilityRequest(..) + , vrPositionL + , vrSizeL + + -- * Making lenses , suffixLenses + + -- * Miscellaneous + , Size(..) + , Padding(..) + , Direction(..) + , Name(..) + ) where -import Control.Lens -import Data.String +import Control.Lens (_1, _2, to, (^.), (&), (.~), Lens') import Data.Monoid (Monoid(..)) -import Graphics.Vty (Event) +import Control.Monad.Trans.State.Lazy +import Control.Monad.Trans.Reader +import Graphics.Vty (Event, Image, emptyImage, Attr) +import Data.Default (Default(..)) +import Data.Functor.Contravariant +import qualified Data.Map as M import Brick.Types.TH +import Brick.Types.Internal +import Brick.AttrMap (AttrName, attrMapLookup) --- | A terminal screen location. -data Location = Location { loc :: (Int, Int) - -- ^ (Column, Row) - } - deriving Show +-- | The type of padding. +data Padding = Pad Int + -- ^ Pad by the specified number of rows or columns. + | Max + -- ^ Pad up to the number of available rows or columns. -suffixLenses ''Location +-- | The class of types that provide some basic event-handling. +class HandleEvent a where + -- | Handle a Vty event + handleEvent :: Event -> a -> EventM a -instance Field1 Location Location Int Int where - _1 = locL._1 +-- | A convenience function for handling events intended for values +-- that are targets of lenses in your application state. This function +-- obtains the target value of the specified lens, invokes 'handleEvent' +-- on it, and stores the resulting transformed value back in the state +-- using the lens. +handleEventLensed :: (HandleEvent b) + => a + -- ^ The state value. + -> Lens' a b + -- ^ The lens to use to extract and store the target + -- of the event. + -> Event + -- ^ The event to handle. + -> EventM a +handleEventLensed v target ev = do + newB <- handleEvent ev (v^.target) + return $ v & target .~ newB -instance Field2 Location Location Int Int where - _2 = locL._2 +-- | The monad in which event handlers run. Although it may be tempting +-- to dig into the reader value yourself, just use +-- 'Brick.Main.lookupViewport'. +type EventM a = ReaderT (M.Map Name Viewport) (StateT EventState IO) a --- | The class of types that behave like terminal locations. -class TerminalLocation a where - -- | Get the column out of the value - columnL :: Lens' a Int - column :: a -> Int - -- | Get the row out of the value - rowL :: Lens' a Int - row :: a -> Int +-- | Widget growth policies. These policies communicate to layout +-- algorithms how a widget uses space when being rendered. These +-- policies influence rendering order and space allocation in the box +-- layout algorithm. +data Size = Fixed + -- ^ Fixed widgets take up the same amount of space no matter + -- how much they are given (non-greedy). + | Greedy + -- ^ Greedy widgets take up all the space they are given. + deriving (Show, Eq, Ord) -instance TerminalLocation Location where - columnL = _1 - column (Location t) = fst t - rowL = _2 - row (Location t) = snd t +-- | The type of widgets. +data Widget = + Widget { hSize :: Size + -- ^ This widget's horizontal growth policy + , vSize :: Size + -- ^ This widget's vertical growth policy + , render :: RenderM Result + -- ^ This widget's rendering function + } --- | Names of things. Used to name cursor locations, widgets, and --- viewports. -newtype Name = Name String - deriving (Eq, Show, Ord) +-- | The type of the rendering monad. This monad is used by the +-- library's rendering routines to manage rendering state and +-- communicate rendering parameters to widgets' rendering functions. +type RenderM a = ReaderT Context (State RenderState) a -instance IsString Name where - fromString = Name +-- | The type of result returned by a widget's rendering function. The +-- result provides the image, cursor positions, and visibility requests +-- that resulted from the rendering process. +data Result = + Result { image :: Image + -- ^ The final rendered image for a widget + , cursors :: [CursorLocation] + -- ^ The list of reported cursor positions for the + -- application to choose from + , visibilityRequests :: [VisibilityRequest] + -- ^ The list of visibility requests made by widgets rendered + -- while rendering this one (used by viewports) + } + deriving Show --- | The origin (upper-left corner). -origin :: Location -origin = Location (0, 0) +instance Default Result where + def = Result emptyImage [] [] -instance Monoid Location where - mempty = origin - mappend (Location (w1, h1)) (Location (w2, h2)) = Location (w1+w2, h1+h2) +-- | Get the current rendering context. +getContext :: RenderM Context +getContext = ask --- | A cursor location. These are returned by the rendering process. -data CursorLocation = - CursorLocation { cursorLocation :: !Location - -- ^ The location - , cursorLocationName :: !(Maybe Name) - -- ^ The name of the widget associated with the location - } - deriving Show +suffixLenses ''Context +suffixLenses ''Result -suffixLenses ''CursorLocation +-- | The rendering context's current drawing attribute. +attrL :: (Contravariant f, Functor f) => (Attr -> f Attr) -> Context -> f Context +attrL = to (\c -> attrMapLookup (c^.ctxAttrNameL) (c^.ctxAttrMapL)) instance TerminalLocation CursorLocation where columnL = cursorLocationL._1 @@ -83,7 +174,9 @@ rowL = cursorLocationL._2 row = row . cursorLocation --- | The class of types that provide some basic event-handling. -class HandleEvent a where - -- | Handle a Vty event - handleEvent :: Event -> a -> a +-- | Given an attribute name, obtain the attribute for the attribute +-- name by consulting the context's attribute map. +lookupAttrName :: AttrName -> RenderM Attr +lookupAttrName n = do + c <- getContext + return $ attrMapLookup n (c^.ctxAttrMapL) diff --git a/src/Brick/Types/Internal.hs b/src/Brick/Types/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Brick/Types/Internal.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +module Brick.Types.Internal + ( ScrollRequest(..) + , VisibilityRequest(..) + , vrPositionL + , vrSizeL + , Name(..) + , Location(..) + , locL + , origin + , TerminalLocation(..) + , Viewport(..) + , ViewportType(..) + , RenderState(..) + , Direction(..) + , CursorLocation(..) + , cursorLocationL + , cursorLocationNameL + , Context(..) + , EventState + , Next(..) + + , scrollRequestsL + , viewportMapL + , vpSize + , vpLeft + , vpTop + ) +where + +import Control.Lens (Field1, Field2, _1, _2, Lens', makeLenses) +import Data.String +import Data.Monoid +import qualified Data.Map as M +import Graphics.Vty (DisplayRegion) + +import Brick.Types.TH +import Brick.AttrMap (AttrName, AttrMap) +import Brick.Widgets.Border.Style (BorderStyle) + +-- | Names of things. Used to name cursor locations, widgets, and +-- viewports. +newtype Name = Name String + deriving (Eq, Show, Ord) + +instance IsString Name where + fromString = Name + +data RenderState = + RS { viewportMap :: M.Map Name Viewport + , scrollRequests :: [(Name, ScrollRequest)] + } + +data ScrollRequest = HScrollBy Int + | HScrollPage Direction + | HScrollToBeginning + | HScrollToEnd + | VScrollBy Int + | VScrollPage Direction + | VScrollToBeginning + | VScrollToEnd + +data VisibilityRequest = + VR { vrPosition :: Location + , vrSize :: DisplayRegion + } + deriving Show + +-- | Describes the state of a viewport as it appears as its most recent +-- rendering. +data Viewport = + VP { _vpLeft :: Int + -- ^ The column offset of left side of the viewport. + , _vpTop :: Int + -- ^ The row offset of the top of the viewport. + , _vpSize :: DisplayRegion + -- ^ The size of the viewport. + } + deriving Show + +-- | The type of viewports that indicates the direction(s) in which a +-- viewport is scrollable. +data ViewportType = Vertical + -- ^ Viewports of this type are scrollable only vertically. + | Horizontal + -- ^ Viewports of this type are scrollable only horizontally. + | Both + -- ^ Viewports of this type are scrollable vertically and horizontally. + deriving Show + +type EventState = [(Name, ScrollRequest)] + +-- | The type of actions to take upon completion of an event handler. +data Next a = Continue a + | SuspendAndResume (IO a) + | Halt a + +-- | Scrolling direction. +data Direction = Up + -- ^ Up/left + | Down + -- ^ Down/right + +-- | A terminal screen location. +data Location = Location { loc :: (Int, Int) + -- ^ (Column, Row) + } + deriving Show + +suffixLenses ''Location + +instance Field1 Location Location Int Int where + _1 = locL._1 + +instance Field2 Location Location Int Int where + _2 = locL._2 + +-- | The class of types that behave like terminal locations. +class TerminalLocation a where + -- | Get the column out of the value + columnL :: Lens' a Int + column :: a -> Int + -- | Get the row out of the value + rowL :: Lens' a Int + row :: a -> Int + +instance TerminalLocation Location where + columnL = _1 + column (Location t) = fst t + rowL = _2 + row (Location t) = snd t + +-- | The origin (upper-left corner). +origin :: Location +origin = Location (0, 0) + +instance Monoid Location where + mempty = origin + mappend (Location (w1, h1)) (Location (w2, h2)) = Location (w1+w2, h1+h2) + +-- | A cursor location. These are returned by the rendering process. +data CursorLocation = + CursorLocation { cursorLocation :: !Location + -- ^ The location + , cursorLocationName :: !(Maybe Name) + -- ^ The name of the widget associated with the location + } + deriving Show + +-- | The rendering context. This tells widgets how to render: how much +-- space they have in which to render, which attribute they should use +-- to render, which bordring style should be used, and the attribute map +-- available for rendering. +data Context = + Context { ctxAttrName :: AttrName + , availWidth :: Int + , availHeight :: Int + , ctxBorderStyle :: BorderStyle + , ctxAttrMap :: AttrMap + } + +suffixLenses ''RenderState +suffixLenses ''VisibilityRequest +suffixLenses ''CursorLocation +makeLenses ''Viewport diff --git a/src/Brick/Util.hs b/src/Brick/Util.hs --- a/src/Brick/Util.hs +++ b/src/Brick/Util.hs @@ -12,7 +12,7 @@ import Data.Monoid ((<>)) import Graphics.Vty -import Brick.Types (Location(..), CursorLocation(..), cursorLocationL) +import Brick.Types.Internal (Location(..), CursorLocation(..), cursorLocationL) -- | Given a minimum value and a maximum value, clamp a value to that -- range (values less than the minimum map to the minimum and values diff --git a/src/Brick/Widgets/Border.hs b/src/Brick/Widgets/Border.hs --- a/src/Brick/Widgets/Border.hs +++ b/src/Brick/Widgets/Border.hs @@ -36,6 +36,7 @@ import Graphics.Vty (imageHeight, imageWidth) import Brick.AttrMap +import Brick.Types import Brick.Widgets.Core import Brick.Widgets.Center (hCenterWith) import Brick.Widgets.Border.Style (BorderStyle(..)) diff --git a/src/Brick/Widgets/Core.hs b/src/Brick/Widgets/Core.hs --- a/src/Brick/Widgets/Core.hs +++ b/src/Brick/Widgets/Core.hs @@ -1,19 +1,17 @@ +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TupleSections #-} -- | This module provides the core widget combinators and rendering -- routines. Everything this library does is in terms of these basic -- primitives. module Brick.Widgets.Core - ( Widget(..) - , Size(..) - - -- * Basic rendering primitives - , emptyWidget + ( -- * Basic rendering primitives + emptyWidget , raw , txt , str , fill -- * Padding - , Padding(..) , padLeft , padRight , padTop @@ -54,43 +52,674 @@ , cropBottomBy -- * Scrollable viewports - , ViewportType(..) , viewport , visible , visibleRegion - -- * Rendering infrastructure - , RenderM - , getContext - , lookupAttrName - - -- ** The rendering context - , Context(ctxAttrName, availWidth, availHeight, ctxBorderStyle, ctxAttrMap) - , attrL - , availWidthL - , availHeightL - , ctxAttrMapL - , ctxAttrNameL - , ctxBorderStyleL - - -- ** Rendering results - , Result(..) - -- ** Result lenses - , imageL - , cursorsL - , visibilityRequestsL - -- ** Visibility requests - , VisibilityRequest(..) - , vrPositionL - , vrSizeL -- ** Adding offsets to cursor positions and visibility requests , addResultOffset + -- ** Cropping results , cropToContext - - -- * Misc - , Direction(..) ) where +import Control.Applicative +import Control.Lens ((^.), (.~), (&), (%~), to, _1, _2, each, to, ix) +import Control.Monad (when) +import Control.Monad.Trans.State.Lazy +import Control.Monad.Trans.Reader +import Control.Monad.Trans.Class (lift) +import qualified Data.Text as T +import Data.Default +import Data.Monoid ((<>), mempty) +import qualified Data.Map as M +import qualified Data.Function as DF +import Data.List (sortBy, partition) +import Control.Lens (Lens') +import qualified Graphics.Vty as V +import Control.DeepSeq + +import Brick.Types +import Brick.Types.Internal +import Brick.Widgets.Border.Style +import Brick.Util (clOffset, clamp) +import Brick.AttrMap import Brick.Widgets.Internal + +-- | When rendering the specified widget, use the specified border style +-- for any border rendering. +withBorderStyle :: BorderStyle -> Widget -> Widget +withBorderStyle bs p = Widget (hSize p) (vSize p) $ withReaderT (& ctxBorderStyleL .~ bs) (render p) + +-- | The empty widget. +emptyWidget :: Widget +emptyWidget = raw V.emptyImage + +-- | Add an offset to all cursor locations and visbility requests +-- in the specified rendering result. This function is critical for +-- maintaining correctness in the rendering results as they are +-- processed successively by box layouts and other wrapping combinators, +-- since calls to this function result in converting from widget-local +-- coordinates to (ultimately) terminal-global ones so they can be used +-- by other combinators. You should call this any time you render +-- something and then translate it or otherwise offset it from its +-- original origin. +addResultOffset :: Location -> Result -> Result +addResultOffset off = addCursorOffset off . addVisibilityOffset off + +addVisibilityOffset :: Location -> Result -> Result +addVisibilityOffset off r = r & visibilityRequestsL.each.vrPositionL %~ (off <>) + +addCursorOffset :: Location -> Result -> Result +addCursorOffset off r = + let onlyVisible = filter isVisible + isVisible l = l^.columnL >= 0 && l^.rowL >= 0 + in r & cursorsL %~ (\cs -> onlyVisible $ (`clOffset` off) <$> cs) + +unrestricted :: Int +unrestricted = 100000 + +-- | Build a widget from a 'String'. Breaks newlines up and space-pads +-- short lines out to the length of the longest line. +str :: String -> Widget +str s = + Widget Fixed Fixed $ do + c <- getContext + let theLines = fixEmpty <$> (dropUnused . lines) s + fixEmpty [] = " " + fixEmpty l = l + dropUnused l = take (availWidth c) <$> take (availHeight c) l + case force theLines of + [] -> return def + [one] -> return $ def & imageL .~ (V.string (c^.attrL) one) + multiple -> + let maxLength = maximum $ length <$> multiple + lineImgs = lineImg <$> multiple + lineImg lStr = V.string (c^.attrL) (lStr ++ replicate (maxLength - length lStr) ' ') + in return $ def & imageL .~ (V.vertCat lineImgs) + +-- | Build a widget from a one-line 'T.Text' value. Behaves the same as +-- 'str'. +txt :: T.Text -> Widget +txt = str . T.unpack + +-- | Pad the specified widget on the left. If max padding is used, this +-- grows greedily horizontally; otherwise it defers to the padded +-- widget. +padLeft :: Padding -> Widget -> Widget +padLeft padding p = + let (f, sz) = case padding of + Max -> (id, Greedy) + Pad i -> (hLimit i, hSize p) + in Widget sz (vSize p) $ do + result <- render p + render $ (f $ vLimit (result^.imageL.to V.imageHeight) $ fill ' ') <+> + (Widget Fixed Fixed $ return result) + +-- | Pad the specified widget on the right. If max padding is used, +-- this grows greedily horizontally; otherwise it defers to the padded +-- widget. +padRight :: Padding -> Widget -> Widget +padRight padding p = + let (f, sz) = case padding of + Max -> (id, Greedy) + Pad i -> (hLimit i, hSize p) + in Widget sz (vSize p) $ do + result <- render p + render $ (Widget Fixed Fixed $ return result) <+> + (f $ vLimit (result^.imageL.to V.imageHeight) $ fill ' ') + +-- | Pad the specified widget on the top. If max padding is used, this +-- grows greedily vertically; otherwise it defers to the padded widget. +padTop :: Padding -> Widget -> Widget +padTop padding p = + let (f, sz) = case padding of + Max -> (id, Greedy) + Pad i -> (vLimit i, vSize p) + in Widget (hSize p) sz $ do + result <- render p + render $ (f $ hLimit (result^.imageL.to V.imageWidth) $ fill ' ') <=> + (Widget Fixed Fixed $ return result) + +-- | Pad the specified widget on the bottom. If max padding is used, +-- this grows greedily vertically; otherwise it defers to the padded +-- widget. +padBottom :: Padding -> Widget -> Widget +padBottom padding p = + let (f, sz) = case padding of + Max -> (id, Greedy) + Pad i -> (vLimit i, vSize p) + in Widget (hSize p) sz $ do + result <- render p + render $ (Widget Fixed Fixed $ return result) <=> + (f $ hLimit (result^.imageL.to V.imageWidth) $ fill ' ') + +-- | Pad a widget on the left and right. Defers to the padded widget for +-- growth policy. +padLeftRight :: Int -> Widget -> Widget +padLeftRight c w = padLeft (Pad c) $ padRight (Pad c) w + +-- | Pad a widget on the top and bottom. Defers to the padded widget for +-- growth policy. +padTopBottom :: Int -> Widget -> Widget +padTopBottom r w = padTop (Pad r) $ padBottom (Pad r) w + +-- | Pad a widget on all sides. Defers to the padded widget for growth +-- policy. +padAll :: Int -> Widget -> Widget +padAll v w = padLeftRight v $ padTopBottom v w + +-- | Fill all available space with the specified character. Grows both +-- horizontally and vertically. +fill :: Char -> Widget +fill ch = + Widget Greedy Greedy $ do + c <- getContext + return $ def & imageL .~ (V.charFill (c^.attrL) ch (c^.availWidthL) (c^.availHeightL)) + +-- | Vertical box layout: put the specified widgets one above the other +-- in the specified order (uppermost first). Defers growth policies to +-- the growth policies of the contained widgets (if any are greedy, so +-- is the box). +vBox :: [Widget] -> Widget +vBox [] = emptyWidget +vBox pairs = renderBox vBoxRenderer pairs + +-- | Horizontal box layout: put the specified widgets next to each other +-- in the specified order (leftmost first). Defers growth policies to +-- the growth policies of the contained widgets (if any are greedy, so +-- is the box). +hBox :: [Widget] -> Widget +hBox [] = emptyWidget +hBox pairs = renderBox hBoxRenderer pairs + +-- | The process of rendering widgets in a box layout is exactly the +-- same except for the dimension under consideration (width vs. height), +-- in which case all of the same operations that consider one dimension +-- in the layout algorithm need to be switched to consider the other. +-- Because of this we fill a BoxRenderer with all of the functions +-- needed to consider the "primary" dimension (e.g. vertical if the +-- box layout is vertical) as well as the "secondary" dimension (e.g. +-- horizontal if the box layout is vertical). Doing this permits us to +-- have one implementation for box layout and parameterizing on the +-- orientation of all of the operations. +data BoxRenderer = + BoxRenderer { contextPrimary :: Lens' Context Int + , contextSecondary :: Lens' Context Int + , imagePrimary :: V.Image -> Int + , imageSecondary :: V.Image -> Int + , limitPrimary :: Int -> Widget -> Widget + , limitSecondary :: Int -> Widget -> Widget + , primaryWidgetSize :: Widget -> Size + , concatenatePrimary :: [V.Image] -> V.Image + , locationFromOffset :: Int -> Location + , padImageSecondary :: Int -> V.Image -> V.Attr -> V.Image + } + +vBoxRenderer :: BoxRenderer +vBoxRenderer = + BoxRenderer { contextPrimary = availHeightL + , contextSecondary = availWidthL + , imagePrimary = V.imageHeight + , imageSecondary = V.imageWidth + , limitPrimary = vLimit + , limitSecondary = hLimit + , primaryWidgetSize = vSize + , concatenatePrimary = V.vertCat + , locationFromOffset = Location . (0 ,) + , padImageSecondary = \amt img a -> + let p = V.charFill a ' ' amt (V.imageHeight img) + in V.horizCat [img, p] + } + +hBoxRenderer :: BoxRenderer +hBoxRenderer = + BoxRenderer { contextPrimary = availWidthL + , contextSecondary = availHeightL + , imagePrimary = V.imageWidth + , imageSecondary = V.imageHeight + , limitPrimary = hLimit + , limitSecondary = vLimit + , primaryWidgetSize = hSize + , concatenatePrimary = V.horizCat + , locationFromOffset = Location . (, 0) + , padImageSecondary = \amt img a -> + let p = V.charFill a ' ' (V.imageWidth img) amt + in V.vertCat [img, p] + } + +-- | Render a series of widgets in a box layout in the order given. +-- +-- The growth policy of a box layout is the most unrestricted of the +-- growth policies of the widgets it contains, so to determine the hSize +-- and vSize of the box we just take the maximum (using the Ord instance +-- for Size) of all of the widgets to be rendered in the box. +-- +-- Then the box layout algorithm proceeds as follows. We'll use +-- the vertical case to concretely describe the algorithm, but the +-- horizontal case can be envisioned just by exchanging all +-- "vertical"/"horizontal" and "rows"/"columns", etc., in the +-- description. +-- +-- The growth policies of the child widgets determine the order in which +-- they are rendered, i.e., the order in which space in the box is +-- allocated to widgets as the algorithm proceeds. This is because order +-- matters: if we render greedy widgets first, there will be no space +-- left for non-greedy ones. +-- +-- So we render all widgets with size 'Fixed' in the vertical dimension +-- first. Each is rendered with as much room as the overall box has, but +-- we assume that they will not be greedy and use it all. If they do, +-- maybe it's because the terminal is small and there just isn't enough +-- room to render everything. +-- +-- Then the remaining height is distributed evenly amongst all remaining +-- (greedy) widgets and they are rendered in sub-boxes that are as high +-- as this even slice of rows and as wide as the box is permitted to be. +-- We only do this step at all if rendering the non-greedy widgets left +-- us any space, i.e., if there were any rows left. +-- +-- After rendering the non-greedy and then greedy widgets, their images +-- are sorted so that they are stored in the order the original widgets +-- were given. All cursor locations and visibility requests in each +-- sub-widget are translated according to the position of the sub-widget +-- in the box. +-- +-- All images are padded to be as wide as the widest sub-widget to +-- prevent attribute over-runs. Without this step the attribute used by +-- a sub-widget may continue on in an undesirable fashion until it hits +-- something with a different attribute. To prevent this and to behave +-- in the least surprising way, we pad the image on the right with +-- whitespace using the context's current attribute. +-- +-- Finally, the padded images are concatenated together vertically and +-- returned along with the translated cursor positions and visibility +-- requests. +renderBox :: BoxRenderer -> [Widget] -> Widget +renderBox br ws = do + Widget (maximum $ hSize <$> ws) (maximum $ vSize <$> ws) $ do + c <- getContext + + let pairsIndexed = zip [(0::Int)..] ws + (his, lows) = partition (\p -> (primaryWidgetSize br $ snd p) == Fixed) pairsIndexed + + renderedHis <- mapM (\(i, prim) -> (i,) <$> render prim) his + + renderedLows <- case lows of + [] -> return [] + ls -> do + let remainingPrimary = c^.(contextPrimary br) - (sum $ (^._2.imageL.(to $ imagePrimary br)) <$> renderedHis) + primaryPerLow = remainingPrimary `div` length ls + padFirst = remainingPrimary - (primaryPerLow * length ls) + secondaryPerLow = c^.(contextSecondary br) + primaries = replicate (length ls) primaryPerLow & ix 0 %~ (+ padFirst) + + let renderLow ((i, prim), pri) = + (i,) <$> (render $ limitPrimary br pri + $ limitSecondary br secondaryPerLow + $ cropToContext prim) + + if remainingPrimary > 0 then mapM renderLow (zip ls primaries) else return [] + + let rendered = sortBy (compare `DF.on` fst) $ renderedHis ++ renderedLows + allResults = snd <$> rendered + allImages = (^.imageL) <$> allResults + allPrimaries = imagePrimary br <$> allImages + allTranslatedResults = (flip map) (zip [0..] allResults) $ \(i, result) -> + let off = locationFromOffset br offPrimary + offPrimary = sum $ take i allPrimaries + in addResultOffset off result + -- Determine the secondary dimension value to pad to. In a + -- vertical box we want all images to be the same width to + -- avoid attribute over-runs or blank spaces with the wrong + -- attribute. In a horizontal box we want all images to have + -- the same height for the same reason. + maxSecondary = maximum $ imageSecondary br <$> allImages + padImage img = padImageSecondary br (maxSecondary - imageSecondary br img) img (c^.attrL) + paddedImages = padImage <$> allImages + + cropResultToContext $ Result (concatenatePrimary br paddedImages) + (concat $ cursors <$> allTranslatedResults) + (concat $ visibilityRequests <$> allTranslatedResults) + +-- | Limit the space available to the specified widget to the specified +-- number of columns. This is important for constraining the horizontal +-- growth of otherwise-greedy widgets. This is non-greedy horizontally +-- and defers to the limited widget vertically. +hLimit :: Int -> Widget -> Widget +hLimit w p = + Widget Fixed (vSize p) $ do + withReaderT (& availWidthL .~ w) $ render $ cropToContext p + +-- | Limit the space available to the specified widget to the specified +-- number of rows. This is important for constraining the vertical +-- growth of otherwise-greedy widgets. This is non-greedy vertically and +-- defers to the limited widget horizontally. +vLimit :: Int -> Widget -> Widget +vLimit h p = + Widget (hSize p) Fixed $ do + withReaderT (& availHeightL .~ h) $ render $ cropToContext p + +-- | When drawing the specified widget, set the current attribute used +-- for drawing to the one with the specified name. Note that the widget +-- may use further calls to 'withAttr' to override this; if you really +-- want to prevent that, use 'forceAttr'. Attributes used this way still +-- get merged hierarchically and still fall back to the attribute map's +-- default attribute. If you want to change the default attribute, use +-- 'withDefAttr'. +withAttr :: AttrName -> Widget -> Widget +withAttr an p = + Widget (hSize p) (vSize p) $ do + withReaderT (& ctxAttrNameL .~ an) (render p) + +-- | Update the attribute map while rendering the specified widget: set +-- its new default attribute to the one that we get by looking up the +-- specified attribute name in the map. +withDefAttr :: AttrName -> Widget -> Widget +withDefAttr an p = + Widget (hSize p) (vSize p) $ do + c <- getContext + withReaderT (& ctxAttrMapL %~ (setDefault (attrMapLookup an (c^.ctxAttrMapL)))) (render p) + +-- | When rendering the specified widget, update the attribute map with +-- the specified transformation. +updateAttrMap :: (AttrMap -> AttrMap) -> Widget -> Widget +updateAttrMap f p = + Widget (hSize p) (vSize p) $ do + withReaderT (& ctxAttrMapL %~ f) (render p) + +-- | When rendering the specified widget, force all attribute lookups +-- in the attribute map to use the value currently assigned to the +-- specified attribute name. +forceAttr :: AttrName -> Widget -> Widget +forceAttr an p = + Widget (hSize p) (vSize p) $ do + c <- getContext + withReaderT (& ctxAttrMapL .~ (forceAttrMap (attrMapLookup an (c^.ctxAttrMapL)))) (render p) + +-- | Build a widget directly from a raw Vty image. +raw :: V.Image -> Widget +raw img = Widget Fixed Fixed $ return $ def & imageL .~ img + +-- | Translate the specified widget by the specified offset amount. +-- Defers to the translated width for growth policy. +translateBy :: Location -> Widget -> Widget +translateBy off p = + Widget (hSize p) (vSize p) $ do + result <- render p + return $ addResultOffset off + $ result & imageL %~ (V.translate (off^.columnL) (off^.rowL)) + +-- | Crop the specified widget on the left by the specified number of +-- columns. Defers to the translated width for growth policy. +cropLeftBy :: Int -> Widget -> Widget +cropLeftBy cols p = + Widget (hSize p) (vSize p) $ do + result <- render p + let amt = V.imageWidth (result^.imageL) - cols + cropped img = if amt < 0 then V.emptyImage else V.cropLeft amt img + return $ addResultOffset (Location (-1 * cols, 0)) + $ result & imageL %~ cropped + +-- | Crop the specified widget on the right by the specified number of +-- columns. Defers to the translated width for growth policy. +cropRightBy :: Int -> Widget -> Widget +cropRightBy cols p = + Widget (hSize p) (vSize p) $ do + result <- render p + let amt = V.imageWidth (result^.imageL) - cols + cropped img = if amt < 0 then V.emptyImage else V.cropRight amt img + return $ result & imageL %~ cropped + +-- | Crop the specified widget on the top by the specified number of +-- rows. Defers to the translated width for growth policy. +cropTopBy :: Int -> Widget -> Widget +cropTopBy rows p = + Widget (hSize p) (vSize p) $ do + result <- render p + let amt = V.imageHeight (result^.imageL) - rows + cropped img = if amt < 0 then V.emptyImage else V.cropTop amt img + return $ addResultOffset (Location (0, -1 * rows)) + $ result & imageL %~ cropped + +-- | Crop the specified widget on the bottom by the specified number of +-- rows. Defers to the translated width for growth policy. +cropBottomBy :: Int -> Widget -> Widget +cropBottomBy rows p = + Widget (hSize p) (vSize p) $ do + result <- render p + let amt = V.imageHeight (result^.imageL) - rows + cropped img = if amt < 0 then V.emptyImage else V.cropBottom amt img + return $ result & imageL %~ cropped + +-- | When rendering the specified widget, also register a cursor +-- positioning request using the specified name and location. +showCursor :: Name -> Location -> Widget -> Widget +showCursor n cloc p = + Widget (hSize p) (vSize p) $ do + result <- render p + return $ result & cursorsL %~ (CursorLocation cloc (Just n):) + +hRelease :: Widget -> Maybe Widget +hRelease p = + case hSize p of + Fixed -> Just $ Widget Greedy (vSize p) $ withReaderT (& availWidthL .~ unrestricted) (render p) + Greedy -> Nothing + +vRelease :: Widget -> Maybe Widget +vRelease p = + case vSize p of + Fixed -> Just $ Widget (hSize p) Greedy $ withReaderT (& availHeightL .~ unrestricted) (render p) + Greedy -> Nothing + +-- | Render the specified widget in a named viewport with the +-- specified type. This permits widgets to be scrolled without being +-- scrolling-aware. To make the most use of viewports, the specified +-- widget should use the 'visible' combinator to make a "visibility +-- request". This viewport combinator will then translate the resulting +-- rendering to make the requested region visible. In addition, the +-- 'Brick.Main.EventM' monad provides primitives to scroll viewports +-- created by this function if 'visible' is not what you want. +-- +-- If a viewport receives more than one visibility request, only the +-- first is honored. If a viewport receives more than one scrolling +-- request from 'Brick.Main.EventM', all are honored in the order in +-- which they are received. +viewport :: Name + -- ^ The name of the viewport (must be unique and stable for + -- reliable behavior) + -> ViewportType + -- ^ The type of viewport (indicates the permitted scrolling + -- direction) + -> Widget + -- ^ The widget to be rendered in the scrollable viewport + -> Widget +viewport vpname typ p = + Widget Greedy Greedy $ do + -- First, update the viewport size. + c <- getContext + let newVp = VP 0 0 newSize + newSize = (c^.availWidthL, c^.availHeightL) + doInsert (Just vp) = Just $ vp & vpSize .~ newSize + doInsert Nothing = Just newVp + + lift $ modify (& viewportMapL %~ (M.alter doInsert vpname)) + + -- Then render the sub-rendering with the rendering layout + -- constraint released (but raise an exception if we are asked to + -- render an infinitely-sized widget in the viewport's scrolling + -- dimension) + let Name vpn = vpname + release = case typ of + Vertical -> vRelease + Horizontal -> hRelease + Both -> \w -> vRelease w >>= hRelease + released = case release p of + Just w -> w + Nothing -> case typ of + Vertical -> error $ "tried to embed an infinite-height widget in vertical viewport " <> (show vpn) + Horizontal -> error $ "tried to embed an infinite-width widget in horizontal viewport " <> (show vpn) + Both -> error $ "tried to embed an infinite-width or infinite-height widget in 'Both' type viewport " <> (show vpn) + + initialResult <- render released + + -- If the rendering state includes any scrolling requests for this + -- viewport, apply those + reqs <- lift $ gets $ (^.scrollRequestsL) + let relevantRequests = snd <$> filter (\(n, _) -> n == vpname) reqs + when (not $ null relevantRequests) $ do + Just vp <- lift $ gets $ (^.viewportMapL.to (M.lookup vpname)) + let updatedVp = applyRequests relevantRequests vp + applyRequests [] v = v + applyRequests (rq:rqs) v = + case typ of + Horizontal -> scrollTo typ rq (initialResult^.imageL) $ applyRequests rqs v + Vertical -> scrollTo typ rq (initialResult^.imageL) $ applyRequests rqs v + Both -> scrollTo Horizontal rq (initialResult^.imageL) $ + scrollTo Vertical rq (initialResult^.imageL) $ + applyRequests rqs v + lift $ modify (& viewportMapL %~ (M.insert vpname updatedVp)) + return () + + -- If the sub-rendering requested visibility, update the scroll + -- state accordingly + when (not $ null $ initialResult^.visibilityRequestsL) $ do + Just vp <- lift $ gets $ (^.viewportMapL.to (M.lookup vpname)) + let rq = head $ initialResult^.visibilityRequestsL + updatedVp = case typ of + Both -> scrollToView Horizontal rq $ scrollToView Vertical rq vp + Horizontal -> scrollToView typ rq vp + Vertical -> scrollToView typ rq vp + lift $ modify (& viewportMapL %~ (M.insert vpname updatedVp)) + + -- Get the viewport state now that it has been updated. + Just vp <- lift $ gets (M.lookup vpname . (^.viewportMapL)) + + -- Then perform a translation of the sub-rendering to fit into the + -- viewport + translated <- render $ translateBy (Location (-1 * vp^.vpLeft, -1 * vp^.vpTop)) + $ Widget Fixed Fixed $ return initialResult + + -- Return the translated result with the visibility requests + -- discarded + let translatedSize = ( translated^.imageL.to V.imageWidth + , translated^.imageL.to V.imageHeight + ) + case translatedSize of + (0, 0) -> return $ translated & imageL .~ (V.charFill (c^.attrL) ' ' (c^.availWidthL) (c^.availHeightL)) + & visibilityRequestsL .~ mempty + _ -> render $ cropToContext + $ padBottom Max + $ padRight Max + $ Widget Fixed Fixed $ return $ translated & visibilityRequestsL .~ mempty + +scrollTo :: ViewportType -> ScrollRequest -> V.Image -> Viewport -> Viewport +scrollTo Both _ _ _ = error "BUG: called scrollTo on viewport type 'Both'" +scrollTo Vertical req img vp = vp & vpTop .~ newVStart + where + newVStart = clamp 0 (V.imageHeight img - vp^.vpSize._2) adjustedAmt + adjustedAmt = case req of + VScrollBy amt -> vp^.vpTop + amt + VScrollPage Up -> vp^.vpTop - vp^.vpSize._2 + VScrollPage Down -> vp^.vpTop + vp^.vpSize._2 + VScrollToBeginning -> 0 + VScrollToEnd -> V.imageHeight img - vp^.vpSize._2 + _ -> vp^.vpTop +scrollTo Horizontal req img vp = vp & vpLeft .~ newHStart + where + newHStart = clamp 0 (V.imageWidth img - vp^.vpSize._1) adjustedAmt + adjustedAmt = case req of + HScrollBy amt -> vp^.vpLeft + amt + HScrollPage Up -> vp^.vpLeft - vp^.vpSize._1 + HScrollPage Down -> vp^.vpLeft + vp^.vpSize._1 + HScrollToBeginning -> 0 + HScrollToEnd -> V.imageWidth img - vp^.vpSize._1 + _ -> vp^.vpLeft + +scrollToView :: ViewportType -> VisibilityRequest -> Viewport -> Viewport +scrollToView Both _ _ = error "BUG: called scrollToView on 'Both' type viewport" +scrollToView Vertical rq vp = vp & vpTop .~ newVStart + where + curStart = vp^.vpTop + curEnd = curStart + vp^.vpSize._2 + reqStart = rq^.vrPositionL.rowL + + reqEnd = rq^.vrPositionL.rowL + rq^.vrSizeL._2 + newVStart :: Int + newVStart = if reqStart < curStart + then reqStart + else if reqStart > curEnd || reqEnd > curEnd + then reqEnd - vp^.vpSize._2 + else curStart +scrollToView Horizontal rq vp = vp & vpLeft .~ newHStart + where + curStart = vp^.vpLeft + curEnd = curStart + vp^.vpSize._1 + reqStart = rq^.vrPositionL.columnL + + reqEnd = rq^.vrPositionL.columnL + rq^.vrSizeL._1 + newHStart :: Int + newHStart = if reqStart < curStart + then reqStart + else if reqStart > curEnd || reqEnd > curEnd + then reqEnd - vp^.vpSize._1 + else curStart + +-- | Request that the specified widget be made visible when it is +-- rendered inside a viewport. This permits widgets (whose sizes and +-- positions cannot be known due to being embedded in arbitrary layouts) +-- to make a request for a parent viewport to locate them and scroll +-- enough to put them in view. This, together with 'viewport', is what +-- makes the text editor and list widgets possible without making them +-- deal with the details of scrolling state management. +-- +-- This does nothing if not rendered in a viewport. +visible :: Widget -> Widget +visible p = + Widget (hSize p) (vSize p) $ do + result <- render p + let imageSize = ( result^.imageL.to V.imageWidth + , result^.imageL.to V.imageHeight + ) + -- The size of the image to be made visible in a viewport must have + -- non-zero size in both dimensions. + return $ if imageSize^._1 > 0 && imageSize^._2 > 0 + then result & visibilityRequestsL %~ (VR (Location (0, 0)) imageSize :) + else result + +-- | Similar to 'visible', request that a region (with the specified +-- 'Location' as its origin and 'V.DisplayRegion' as its size) be made +-- visible when it is rendered inside a viewport. The 'Location' is +-- relative to the specified widget's upper-left corner of (0, 0). +-- +-- This does nothing if not rendered in a viewport. +visibleRegion :: Location -> V.DisplayRegion -> Widget -> Widget +visibleRegion vrloc sz p = + Widget (hSize p) (vSize p) $ do + result <- render p + -- The size of the image to be made visible in a viewport must have + -- non-zero size in both dimensions. + return $ if sz^._1 > 0 && sz^._2 > 0 + then result & visibilityRequestsL %~ (VR vrloc sz :) + else result + +-- | Horizontal box layout: put the specified widgets next to each other +-- in the specified order. Defers growth policies to the growth policies +-- of both widgets. This operator is a binary version of 'hBox'. +(<+>) :: Widget + -- ^ Left + -> Widget + -- ^ Right + -> Widget +(<+>) a b = hBox [a, b] + +-- | Vertical box layout: put the specified widgets one above the other +-- in the specified order. Defers growth policies to the growth policies +-- of both widgets. This operator is a binary version of 'vBox'. +(<=>) :: Widget + -- ^ Top + -> Widget + -- ^ Bottom + -> Widget +(<=>) a b = vBox [a, b] diff --git a/src/Brick/Widgets/Dialog.hs b/src/Brick/Widgets/Dialog.hs --- a/src/Brick/Widgets/Dialog.hs +++ b/src/Brick/Widgets/Dialog.hs @@ -68,9 +68,9 @@ instance HandleEvent (Dialog a) where handleEvent ev d = case ev of - EvKey (KChar '\t') [] -> nextButtonBy 1 d - EvKey KBackTab [] -> nextButtonBy (-1) d - _ -> d + EvKey (KChar '\t') [] -> return $ nextButtonBy 1 d + EvKey KBackTab [] -> return $ nextButtonBy (-1) d + _ -> return d -- | Create a dialog. dialog :: Name @@ -106,7 +106,7 @@ -- | Render a dialog with the specified body widget. renderDialog :: Dialog a -> Widget -> Widget renderDialog d body = - let buttonPadding = " " + let buttonPadding = str " " mkButton (i, (s, _)) = let att = if Just i == d^.dialogSelectedIndexL then buttonSelectedAttr else buttonAttr diff --git a/src/Brick/Widgets/Edit.hs b/src/Brick/Widgets/Edit.hs --- a/src/Brick/Widgets/Edit.hs +++ b/src/Brick/Widgets/Edit.hs @@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} --- | This module provides a basic single-line text editor widget. You'll --- need to embed an 'Editor' in your application state and transform it --- with 'handleEvent' when relevant events arrive. To get the contents +-- | This module provides a basic text editor widget. You'll need to +-- embed an 'Editor' in your application state and transform it with +-- 'handleEvent' when relevant events arrive. To get the contents -- of the editor, just use 'getEditContents'. To modify it, use the -- 'Z.TextZipper' interface with 'applyEdit'. -- @@ -72,7 +72,7 @@ EvKey KRight [] -> Z.moveRight EvKey KBS [] -> Z.deletePrevChar _ -> id - in applyEdit f ed + in return $ applyEdit f ed -- | Construct an editor. editor :: Name diff --git a/src/Brick/Widgets/Internal.hs b/src/Brick/Widgets/Internal.hs --- a/src/Brick/Widgets/Internal.hs +++ b/src/Brick/Widgets/Internal.hs @@ -1,226 +1,22 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE BangPatterns #-} module Brick.Widgets.Internal - ( Result(..) - , visibilityRequestsL - , imageL - , cursorsL - , addResultOffset - - , VisibilityRequest(..) - , vrPositionL - , vrSizeL - - , RenderState(..) - , ScrollRequest(..) - , Direction(..) - - , renderFinal - , Widget(..) - , Size(..) - , RenderM - - , Context(ctxAttrName, availWidth, availHeight, ctxBorderStyle, ctxAttrMap) - , lookupAttrName - , getContext - , attrL - , availWidthL - , availHeightL - , ctxAttrMapL - , ctxAttrNameL - , ctxBorderStyleL + ( renderFinal , cropToContext - - , withBorderStyle - - , ViewportType(..) - - , txt - , str - , fill - - , Padding(..) - , padLeft - , padRight - , padTop - , padBottom - , padLeftRight - , padTopBottom - , padAll - - , emptyWidget - , hBox - , vBox - , (<=>) - , (<+>) - - , hLimit - , vLimit - , withDefAttr - , withAttr - , forceAttr - , updateAttrMap - , raw - , translateBy - , cropLeftBy - , cropRightBy - , cropTopBy - , cropBottomBy - , showCursor - , viewport - , visible - , visibleRegion + , cropResultToContext ) where import Control.Applicative -import Control.Lens (makeLenses, (^.), (.~), (&), (%~), to, _1, _2, each, to, ix) -import Control.Monad (when) +import Control.Lens ((^.), (&), (%~)) import Control.Monad.Trans.State.Lazy import Control.Monad.Trans.Reader -import Control.Monad.Trans.Class (lift) -import qualified Data.Text as T import Data.Default -import Data.Functor.Contravariant -import Data.Monoid ((<>), mempty) -import qualified Data.Map as M -import qualified Data.Function as DF -import Data.List (sortBy, partition) -import Control.Lens (Lens') -import Data.String (IsString(..)) import qualified Graphics.Vty as V import Brick.Types -import Brick.Widgets.Border.Style -import Brick.Util (clOffset) +import Brick.Types.Internal import Brick.AttrMap -import Brick.Util (clamp) -data VisibilityRequest = - VR { vrPosition :: Location - , vrSize :: V.DisplayRegion - } - deriving Show - --- | The type of viewports that indicates the direction(s) in which a --- viewport is scrollable. -data ViewportType = Vertical - -- ^ Viewports of this type are scrollable only vertically. - | Horizontal - -- ^ Viewports of this type are scrollable only horizontally. - | Both - -- ^ Viewports of this type are scrollable vertically and horizontally. - deriving Show - -data Viewport = - VP { _vpLeft :: Int - , _vpTop :: Int - , _vpSize :: V.DisplayRegion - } - deriving Show - --- | The type of result returned by a widget's rendering function. The --- result provides the image, cursor positions, and visibility requests --- that resulted from the rendering process. -data Result = - Result { image :: V.Image - -- ^ The final rendered image for a widget - , cursors :: [CursorLocation] - -- ^ The list of reported cursor positions for the - -- application to choose from - , visibilityRequests :: [VisibilityRequest] - -- ^ The list of visibility requests made by widgets rendered - -- while rendering this one (used by viewports) - } - deriving Show - --- | The rendering context. This tells widgets how to render: how much --- space they have in which to render, which attribute they should use --- to render, which bordring style should be used, and the attribute map --- available for rendering. -data Context = - Context { ctxAttrName :: AttrName - , availWidth :: Int - , availHeight :: Int - , ctxBorderStyle :: BorderStyle - , ctxAttrMap :: AttrMap - } - --- | The type of the rendering monad. This monad is used by the --- library's rendering routines to manage rendering state and --- communicate rendering parameters to widgets' rendering functions. -type RenderM a = ReaderT Context (State RenderState) a - --- | Widget growth policies. These policies communicate to layout --- algorithms how a widget uses space when being rendered. These --- policies influence rendering order and space allocation in the box --- layout algorithm. -data Size = Fixed - -- ^ Fixed widgets take up the same amount of space no matter - -- how much they are given (non-greedy). - | Greedy - -- ^ Greedy widgets take up all the space they are given. - deriving (Show, Eq, Ord) - --- | The type of widgets. -data Widget = - Widget { hSize :: Size - -- ^ This widget's horizontal growth policy - , vSize :: Size - -- ^ This widget's vertical growth policy - , render :: RenderM Result - -- ^ This widget's rendering function - } - --- | Scrolling direction. -data Direction = Up - -- ^ Up/left - | Down - -- ^ Down/right - -data ScrollRequest = HScrollBy Int - | HScrollPage Direction - | HScrollToBeginning - | HScrollToEnd - | VScrollBy Int - | VScrollPage Direction - | VScrollToBeginning - | VScrollToEnd - -data RenderState = - RS { viewportMap :: M.Map Name Viewport - , scrollRequests :: [(Name, ScrollRequest)] - } - -suffixLenses ''Result -suffixLenses ''Context -suffixLenses ''VisibilityRequest -suffixLenses ''RenderState - -makeLenses ''Viewport - -instance IsString Widget where - fromString = str - -instance Default Result where - def = Result V.emptyImage [] [] - --- | Get the current rendering context. -getContext :: RenderM Context -getContext = ask - --- | When rendering the specified widget, use the specified border style --- for any border rendering. -withBorderStyle :: BorderStyle -> Widget -> Widget -withBorderStyle bs p = Widget (hSize p) (vSize p) $ withReaderT (& ctxBorderStyleL .~ bs) (render p) - --- | The empty widget. -emptyWidget :: Widget -emptyWidget = raw V.emptyImage - renderFinal :: AttrMap -> [Widget] -> V.DisplayRegion @@ -229,7 +25,7 @@ -> (RenderState, V.Picture, Maybe CursorLocation) renderFinal aMap layerRenders sz chooseCursor rs = (newRS, pic, theCursor) where - (layerResults, newRS) = flip runState rs $ sequence $ + (layerResults, !newRS) = flip runState rs $ sequence $ (\p -> runReaderT p ctx) <$> (render <$> cropToContext <$> layerRenders) ctx = Context def (fst sz) (snd sz) def aMap @@ -237,641 +33,13 @@ layerCursors = (^.cursorsL) <$> layerResults theCursor = chooseCursor $ concat layerCursors --- | Add an offset to all cursor locations and visbility requests --- in the specified rendering result. This function is critical for --- maintaining correctness in the rendering results as they are --- processed successively by box layouts and other wrapping combinators, --- since calls to this function result in converting from widget-local --- coordinates to (ultimately) terminal-global ones so they can be used --- by other combinators. You should call this any time you render --- something and then translate it or otherwise offset it from its --- original origin. -addResultOffset :: Location -> Result -> Result -addResultOffset off = addCursorOffset off . addVisibilityOffset off - -addVisibilityOffset :: Location -> Result -> Result -addVisibilityOffset off r = r & visibilityRequestsL.each.vrPositionL %~ (off <>) - -addCursorOffset :: Location -> Result -> Result -addCursorOffset off r = - let onlyVisible = filter isVisible - isVisible l = l^.columnL >= 0 && l^.rowL >= 0 - in r & cursorsL %~ (\cs -> onlyVisible $ (`clOffset` off) <$> cs) - -unrestricted :: Int -unrestricted = 100000 - --- | The rendering context's current drawing attribute. -attrL :: (Contravariant f, Functor f) => (V.Attr -> f V.Attr) -> Context -> f Context -attrL = to (\c -> attrMapLookup (c^.ctxAttrNameL) (c^.ctxAttrMapL)) - --- | Given an attribute name, obtain the attribute for the attribute --- name by consulting the context's attribute map. -lookupAttrName :: AttrName -> RenderM V.Attr -lookupAttrName n = do - c <- getContext - return $ attrMapLookup n (c^.ctxAttrMapL) - --- | Build a widget from a 'String'. Breaks newlines up and space-pads --- short lines out to the length of the longest line. -str :: String -> Widget -str s = - Widget Fixed Fixed $ do - c <- getContext - let theLines = lines s - fixEmpty [] = " " - fixEmpty l = l - case fixEmpty <$> theLines of - [] -> return def - [one] -> return $ def & imageL .~ (V.string (c^.attrL) one) - multiple -> - let maxLength = maximum $ length <$> multiple - lineImgs = lineImg <$> multiple - lineImg lStr = V.string (c^.attrL) (lStr ++ replicate (maxLength - length lStr) ' ') - in return $ def & imageL .~ (V.vertCat lineImgs) - --- | Build a widget from a 'T.Text' value. Behaves the same as 'str'. -txt :: T.Text -> Widget -txt = str . T.unpack - --- | The type of padding. -data Padding = Pad Int - -- ^ Pad by the specified number of rows or columns. - | Max - -- ^ Pad up to the number of available rows or columns. - --- | Pad the specified widget on the left. -padLeft :: Padding -> Widget -> Widget -padLeft padding p = - let (f, sz) = case padding of - Max -> (id, Greedy) - Pad i -> (hLimit i, hSize p) - in Widget sz (vSize p) $ do - result <- render p - render $ (f $ vLimit (result^.imageL.to V.imageHeight) $ fill ' ') <+> - (Widget Fixed Fixed $ return result) - --- | Pad the specified widget on the right. -padRight :: Padding -> Widget -> Widget -padRight padding p = - let (f, sz) = case padding of - Max -> (id, Greedy) - Pad i -> (hLimit i, hSize p) - in Widget sz (vSize p) $ do - result <- render p - render $ (Widget Fixed Fixed $ return result) <+> - (f $ vLimit (result^.imageL.to V.imageHeight) $ fill ' ') - --- | Pad the specified widget on the top. -padTop :: Padding -> Widget -> Widget -padTop padding p = - let (f, sz) = case padding of - Max -> (id, Greedy) - Pad i -> (vLimit i, vSize p) - in Widget (hSize p) sz $ do - result <- render p - render $ (f $ hLimit (result^.imageL.to V.imageWidth) $ fill ' ') <=> - (Widget Fixed Fixed $ return result) - --- | Pad the specified widget on the bottom. -padBottom :: Padding -> Widget -> Widget -padBottom padding p = - let (f, sz) = case padding of - Max -> (id, Greedy) - Pad i -> (vLimit i, vSize p) - in Widget (hSize p) sz $ do - result <- render p - render $ (Widget Fixed Fixed $ return result) <=> - (f $ hLimit (result^.imageL.to V.imageWidth) $ fill ' ') - --- | Pad a widget on the left and right. -padLeftRight :: Int -> Widget -> Widget -padLeftRight c w = padLeft (Pad c) $ padRight (Pad c) w - --- | Pad a widget on the top and bottom. -padTopBottom :: Int -> Widget -> Widget -padTopBottom r w = padTop (Pad r) $ padBottom (Pad r) w - --- | Pad a widget on all sides. -padAll :: Int -> Widget -> Widget -padAll v w = padLeftRight v $ padTopBottom v w - --- | Fill all available space with the specified character. Grows both --- horizontally and vertically. -fill :: Char -> Widget -fill ch = - Widget Greedy Greedy $ do - c <- getContext - return $ def & imageL .~ (V.charFill (c^.attrL) ch (c^.availWidthL) (c^.availHeightL)) - --- | Vertical box layout: put the specified widgets one above the other --- in the specified order (uppermost first). Defers growth policies to --- the growth policies of both widgets. -vBox :: [Widget] -> Widget -vBox [] = emptyWidget -vBox pairs = renderBox vBoxRenderer pairs - --- | Horizontal box layout: put the specified widgets next to each other --- in the specified order (leftmost first). Defers growth policies to --- the growth policies of both widgets. -hBox :: [Widget] -> Widget -hBox [] = emptyWidget -hBox pairs = renderBox hBoxRenderer pairs - --- | The process of rendering widgets in a box layout is exactly the --- same except for the dimension under consideration (width vs. height), --- in which case all of the same operations that consider one dimension --- in the layout algorithm need to be switched to consider the other. --- Because of this we fill a BoxRenderer with all of the functions --- needed to consider the "primary" dimension (e.g. vertical if the --- box layout is vertical) as well as the "secondary" dimension (e.g. --- horizontal if the box layout is vertical). Doing this permits us to --- have one implementation for box layout and parameterizing on the --- orientation of all of the operations. -data BoxRenderer = - BoxRenderer { contextPrimary :: Lens' Context Int - , contextSecondary :: Lens' Context Int - , imagePrimary :: V.Image -> Int - , imageSecondary :: V.Image -> Int - , limitPrimary :: Int -> Widget -> Widget - , limitSecondary :: Int -> Widget -> Widget - , primaryWidgetSize :: Widget -> Size - , concatenatePrimary :: [V.Image] -> V.Image - , locationFromOffset :: Int -> Location - , padImageSecondary :: Int -> V.Image -> V.Attr -> V.Image - } - -vBoxRenderer :: BoxRenderer -vBoxRenderer = - BoxRenderer { contextPrimary = availHeightL - , contextSecondary = availWidthL - , imagePrimary = V.imageHeight - , imageSecondary = V.imageWidth - , limitPrimary = vLimit - , limitSecondary = hLimit - , primaryWidgetSize = vSize - , concatenatePrimary = V.vertCat - , locationFromOffset = Location . (0 ,) - , padImageSecondary = \amt img a -> - let p = V.charFill a ' ' amt (V.imageHeight img) - in V.horizCat [img, p] - } - -hBoxRenderer :: BoxRenderer -hBoxRenderer = - BoxRenderer { contextPrimary = availWidthL - , contextSecondary = availHeightL - , imagePrimary = V.imageWidth - , imageSecondary = V.imageHeight - , limitPrimary = hLimit - , limitSecondary = vLimit - , primaryWidgetSize = hSize - , concatenatePrimary = V.horizCat - , locationFromOffset = Location . (, 0) - , padImageSecondary = \amt img a -> - let p = V.charFill a ' ' (V.imageWidth img) amt - in V.vertCat [img, p] - } - --- | Render a series of widgets in a box layout in the order given. --- --- The growth policy of a box layout is the most unrestricted of the --- growth policies of the widgets it contains, so to determine the hSize --- and vSize of the box we just take the maximum (using the Ord instance --- for Size) of all of the widgets to be rendered in the box. --- --- Then the box layout algorithm proceeds as follows. We'll use --- the vertical case to concretely describe the algorithm, but the --- horizontal case can be envisioned just by exchanging all --- "vertical"/"horizontal" and "rows"/"columns", etc., in the --- description. --- --- The growth policies of the child widgets determine the order in which --- they are rendered, i.e., the order in which space in the box is --- allocated to widgets as the algorithm proceeds. This is because order --- matters: if we render greedy widgets first, there will be no space --- left for non-greedy ones. --- --- So we render all widgets with size 'Fixed' in the vertical dimension --- first. Each is rendered with as much room as the overall box has, but --- we assume that they will not be greedy and use it all. If they do, --- maybe it's because the terminal is small and there just isn't enough --- room to render everything. --- --- Then the remaining height is distributed evenly amongst all remaining --- (greedy) widgets and they are rendered in sub-boxes that are as high --- as this even slice of rows and as wide as the box is permitted to be. --- We only do this step at all if rendering the non-greedy widgets left --- us any space, i.e., if there were any rows left. --- --- After rendering the non-greedy and then greedy widgets, their images --- are sorted so that they are stored in the order the original widgets --- were given. All cursor locations and visibility requests in each --- sub-widget are translated according to the position of the sub-widget --- in the box. --- --- All images are padded to be as wide as the widest sub-widget to --- prevent attribute over-runs. Without this step the attribute used by --- a sub-widget may continue on in an undesirable fashion until it hits --- something with a different attribute. To prevent this and to behave --- in the least surprising way, we pad the image on the right with --- whitespace using the context's current attribute. --- --- Finally, the padded images are concatenated together vertically and --- returned along with the translated cursor positions and visibility --- requests. -renderBox :: BoxRenderer -> [Widget] -> Widget -renderBox br ws = do - Widget (maximum $ hSize <$> ws) (maximum $ vSize <$> ws) $ do - c <- getContext - - let pairsIndexed = zip [(0::Int)..] ws - (his, lows) = partition (\p -> (primaryWidgetSize br $ snd p) == Fixed) pairsIndexed - - renderedHis <- mapM (\(i, prim) -> (i,) <$> render prim) his - - renderedLows <- case lows of - [] -> return [] - ls -> do - let remainingPrimary = c^.(contextPrimary br) - (sum $ (^._2.imageL.(to $ imagePrimary br)) <$> renderedHis) - primaryPerLow = remainingPrimary `div` length ls - padFirst = remainingPrimary - (primaryPerLow * length ls) - secondaryPerLow = c^.(contextSecondary br) - primaries = replicate (length ls) primaryPerLow & ix 0 %~ (+ padFirst) - - let renderLow ((i, prim), pri) = - (i,) <$> (render $ limitPrimary br pri - $ limitSecondary br secondaryPerLow - $ cropToContext prim) - - if remainingPrimary > 0 then mapM renderLow (zip ls primaries) else return [] - - let rendered = sortBy (compare `DF.on` fst) $ renderedHis ++ renderedLows - allResults = snd <$> rendered - allImages = (^.imageL) <$> allResults - allPrimaries = imagePrimary br <$> allImages - allTranslatedResults = (flip map) (zip [0..] allResults) $ \(i, result) -> - let off = locationFromOffset br offPrimary - offPrimary = sum $ take i allPrimaries - in addResultOffset off result - -- Determine the secondary dimension value to pad to. In a - -- vertical box we want all images to be the same width to - -- avoid attribute over-runs or blank spaces with the wrong - -- attribute. In a horizontal box we want all images to have - -- the same height for the same reason. - maxSecondary = maximum $ imageSecondary br <$> allImages - padImage img = padImageSecondary br (maxSecondary - imageSecondary br img) img (c^.attrL) - paddedImages = padImage <$> allImages - - cropResultToContext $ Result (concatenatePrimary br paddedImages) - (concat $ cursors <$> allTranslatedResults) - (concat $ visibilityRequests <$> allTranslatedResults) - --- | Limit the space available to the specified widget to the specified --- number of columns. This is important for constraining the horizontal --- growth of otherwise-greedy widgets. -hLimit :: Int -> Widget -> Widget -hLimit w p = - Widget Fixed (vSize p) $ do - withReaderT (& availWidthL .~ w) $ render $ cropToContext p - --- | Limit the space available to the specified widget to the specified --- number of rows. This is important for constraining the vertical --- growth of otherwise-greedy widgets. -vLimit :: Int -> Widget -> Widget -vLimit h p = - Widget (hSize p) Fixed $ do - withReaderT (& availHeightL .~ h) $ render $ cropToContext p - --- | When drawing the specified widget, set the current attribute used --- for drawing to the one with the specified name. Note that the widget --- may use further calls to 'withAttr' to override this; if you really --- want to prevent that, use 'forceAttr'. Attributes used this way still --- get merged hierarchically and still fall back to the attribute map's --- default attribute. If you want to change the default attribute, use --- 'withDefAttr'. -withAttr :: AttrName -> Widget -> Widget -withAttr an p = - Widget (hSize p) (vSize p) $ do - withReaderT (& ctxAttrNameL .~ an) (render p) - --- | Update the attribute map while rendering the specified widget: set --- its new default attribute to the one that we get by looking up the --- specified attribute name in the map. -withDefAttr :: AttrName -> Widget -> Widget -withDefAttr an p = - Widget (hSize p) (vSize p) $ do - c <- getContext - withReaderT (& ctxAttrMapL %~ (setDefault (attrMapLookup an (c^.ctxAttrMapL)))) (render p) - --- | When rendering the specified widget, update the attribute map with --- the specified transformation. -updateAttrMap :: (AttrMap -> AttrMap) -> Widget -> Widget -updateAttrMap f p = - Widget (hSize p) (vSize p) $ do - withReaderT (& ctxAttrMapL %~ f) (render p) - --- | When rendering the specified widget, force all attribute lookups --- in the attribute map to use the value currently assigned to the --- specified attribute name. -forceAttr :: AttrName -> Widget -> Widget -forceAttr an p = - Widget (hSize p) (vSize p) $ do - c <- getContext - withReaderT (& ctxAttrMapL .~ (forceAttrMap (attrMapLookup an (c^.ctxAttrMapL)))) (render p) - --- | Build a widget directly from a raw Vty image. -raw :: V.Image -> Widget -raw img = Widget Fixed Fixed $ return $ def & imageL .~ img - --- | Translate the specified widget by the specified offset amount. -translateBy :: Location -> Widget -> Widget -translateBy off p = - Widget (hSize p) (vSize p) $ do - result <- render p - return $ addResultOffset off - $ result & imageL %~ (V.translate (off^.columnL) (off^.rowL)) - -cropResultToContext :: Result -> RenderM Result -cropResultToContext result = do - c <- getContext - return $ result & imageL %~ (V.crop (c^.availWidthL) (c^.availHeightL)) - -- | After rendering the specified widget, crop its result image to the -- dimensions in the rendering context. cropToContext :: Widget -> Widget cropToContext p = Widget (hSize p) (vSize p) $ (render p >>= cropResultToContext) --- | Crop the specified widget on the left by the specified number of --- columns. -cropLeftBy :: Int -> Widget -> Widget -cropLeftBy cols p = - Widget (hSize p) (vSize p) $ do - result <- render p - let amt = V.imageWidth (result^.imageL) - cols - cropped img = if amt < 0 then V.emptyImage else V.cropLeft amt img - return $ addResultOffset (Location (-1 * cols, 0)) - $ result & imageL %~ cropped - --- | Crop the specified widget on the right by the specified number of --- columns. -cropRightBy :: Int -> Widget -> Widget -cropRightBy cols p = - Widget (hSize p) (vSize p) $ do - result <- render p - let amt = V.imageWidth (result^.imageL) - cols - cropped img = if amt < 0 then V.emptyImage else V.cropRight amt img - return $ result & imageL %~ cropped - --- | Crop the specified widget on the top by the specified number of --- rows. -cropTopBy :: Int -> Widget -> Widget -cropTopBy rows p = - Widget (hSize p) (vSize p) $ do - result <- render p - let amt = V.imageHeight (result^.imageL) - rows - cropped img = if amt < 0 then V.emptyImage else V.cropTop amt img - return $ addResultOffset (Location (0, -1 * rows)) - $ result & imageL %~ cropped - --- | Crop the specified widget on the bottom by the specified number of --- rows. -cropBottomBy :: Int -> Widget -> Widget -cropBottomBy rows p = - Widget (hSize p) (vSize p) $ do - result <- render p - let amt = V.imageHeight (result^.imageL) - rows - cropped img = if amt < 0 then V.emptyImage else V.cropBottom amt img - return $ result & imageL %~ cropped - --- | When rendering the specified widget, also register a cursor --- positioning request using the specified name and location. -showCursor :: Name -> Location -> Widget -> Widget -showCursor n cloc p = - Widget (hSize p) (vSize p) $ do - result <- render p - return $ result & cursorsL %~ (CursorLocation cloc (Just n):) - -hRelease :: Widget -> Maybe Widget -hRelease p = - case hSize p of - Fixed -> Just $ Widget Greedy (vSize p) $ withReaderT (& availWidthL .~ unrestricted) (render p) - Greedy -> Nothing - -vRelease :: Widget -> Maybe Widget -vRelease p = - case vSize p of - Fixed -> Just $ Widget (hSize p) Greedy $ withReaderT (& availHeightL .~ unrestricted) (render p) - Greedy -> Nothing - --- | Render the specified widget in a named viewport with the --- specified type. This permits widgets to be scrolled without being --- scrolling-aware. To make the most use of viewports, the specified --- widget should use the 'visible' combinator to make a "visibility --- request". This viewport combinator will then translate the resulting --- rendering to make the requested region visible. In addition, the --- 'Brick.Main.EventM' monad provides primitives to scroll viewports --- created by this function if 'visible' is not what you want. --- --- If a viewport receives more than one visibility request, only the --- first is honored. If a viewport receives more than one scrolling --- request from 'Brick.Main.EventM', all are honored in the order in --- which they are received. -viewport :: Name - -- ^ The name of the viewport (must be unique and stable for - -- reliable behavior) - -> ViewportType - -- ^ The type of viewport (indicates the permitted scrolling - -- direction) - -> Widget - -- ^ The widget to be rendered in the scrollable viewport - -> Widget -viewport vpname typ p = - Widget Greedy Greedy $ do - -- First, update the viewport size. - c <- getContext - let newVp = VP 0 0 newSize - newSize = (c^.availWidthL, c^.availHeightL) - doInsert (Just vp) = Just $ vp & vpSize .~ newSize - doInsert Nothing = Just newVp - - lift $ modify (& viewportMapL %~ (M.alter doInsert vpname)) - - -- Then render the sub-rendering with the rendering layout - -- constraint released (but raise an exception if we are asked to - -- render an infinitely-sized widget in the viewport's scrolling - -- dimension) - let Name vpn = vpname - release = case typ of - Vertical -> vRelease - Horizontal -> hRelease - Both -> \w -> vRelease w >>= hRelease - released = case release p of - Just w -> w - Nothing -> case typ of - Vertical -> error $ "tried to embed an infinite-height widget in vertical viewport " <> (show vpn) - Horizontal -> error $ "tried to embed an infinite-width widget in horizontal viewport " <> (show vpn) - Both -> error $ "tried to embed an infinite-width or infinite-height widget in 'Both' type viewport " <> (show vpn) - - initialResult <- render released - - -- If the sub-rendering requested visibility, update the scroll - -- state accordingly - when (not $ null $ initialResult^.visibilityRequestsL) $ do - Just vp <- lift $ gets $ (^.viewportMapL.to (M.lookup vpname)) - let rq = head $ initialResult^.visibilityRequestsL - updatedVp = case typ of - Both -> scrollToView Horizontal rq $ scrollToView Vertical rq vp - Horizontal -> scrollToView typ rq vp - Vertical -> scrollToView typ rq vp - lift $ modify (& viewportMapL %~ (M.insert vpname updatedVp)) - - -- If the rendering state includes any scrolling requests for this - -- viewport, apply those - reqs <- lift $ gets $ (^.scrollRequestsL) - let relevantRequests = snd <$> filter (\(n, _) -> n == vpname) reqs - when (not $ null relevantRequests) $ do - Just vp <- lift $ gets $ (^.viewportMapL.to (M.lookup vpname)) - let updatedVp = applyRequests relevantRequests vp - applyRequests [] v = v - applyRequests (rq:rqs) v = - case typ of - Horizontal -> scrollTo typ rq (initialResult^.imageL) $ applyRequests rqs v - Vertical -> scrollTo typ rq (initialResult^.imageL) $ applyRequests rqs v - Both -> scrollTo Horizontal rq (initialResult^.imageL) $ - scrollTo Vertical rq (initialResult^.imageL) $ - applyRequests rqs v - lift $ modify (& viewportMapL %~ (M.insert vpname updatedVp)) - return () - - -- Get the viewport state now that it has been updated. - Just vp <- lift $ gets (M.lookup vpname . (^.viewportMapL)) - - -- Then perform a translation of the sub-rendering to fit into the - -- viewport - translated <- render $ translateBy (Location (-1 * vp^.vpLeft, -1 * vp^.vpTop)) - $ Widget Fixed Fixed $ return initialResult - - -- Return the translated result with the visibility requests - -- discarded - let translatedSize = ( translated^.imageL.to V.imageWidth - , translated^.imageL.to V.imageHeight - ) - case translatedSize of - (0, 0) -> return $ translated & imageL .~ (V.charFill (c^.attrL) ' ' (c^.availWidthL) (c^.availHeightL)) - & visibilityRequestsL .~ mempty - _ -> render $ cropToContext - $ padBottom Max - $ padRight Max - $ Widget Fixed Fixed $ return $ translated & visibilityRequestsL .~ mempty - -scrollTo :: ViewportType -> ScrollRequest -> V.Image -> Viewport -> Viewport -scrollTo Both _ _ _ = error "BUG: called scrollTo on viewport type 'Both'" -scrollTo Vertical req img vp = vp & vpTop .~ newVStart - where - newVStart = clamp 0 (V.imageHeight img - vp^.vpSize._2) adjustedAmt - adjustedAmt = case req of - VScrollBy amt -> vp^.vpTop + amt - VScrollPage Up -> vp^.vpTop - vp^.vpSize._2 - VScrollPage Down -> vp^.vpTop + vp^.vpSize._2 - VScrollToBeginning -> 0 - VScrollToEnd -> V.imageHeight img - vp^.vpSize._2 - _ -> vp^.vpTop -scrollTo Horizontal req img vp = vp & vpLeft .~ newHStart - where - newHStart = clamp 0 (V.imageWidth img - vp^.vpSize._1) adjustedAmt - adjustedAmt = case req of - HScrollBy amt -> vp^.vpLeft + amt - HScrollPage Up -> vp^.vpLeft - vp^.vpSize._1 - HScrollPage Down -> vp^.vpLeft + vp^.vpSize._1 - HScrollToBeginning -> 0 - HScrollToEnd -> V.imageWidth img - vp^.vpSize._1 - _ -> vp^.vpLeft - -scrollToView :: ViewportType -> VisibilityRequest -> Viewport -> Viewport -scrollToView Both _ _ = error "BUG: called scrollToView on 'Both' type viewport" -scrollToView Vertical rq vp = vp & vpTop .~ newVStart - where - curStart = vp^.vpTop - curEnd = curStart + vp^.vpSize._2 - reqStart = rq^.vrPositionL.rowL - - reqEnd = rq^.vrPositionL.rowL + rq^.vrSizeL._2 - newVStart :: Int - newVStart = if reqStart < curStart - then reqStart - else if reqStart > curEnd || reqEnd > curEnd - then reqEnd - vp^.vpSize._2 - else curStart -scrollToView Horizontal rq vp = vp & vpLeft .~ newHStart - where - curStart = vp^.vpLeft - curEnd = curStart + vp^.vpSize._1 - reqStart = rq^.vrPositionL.columnL - - reqEnd = rq^.vrPositionL.columnL + rq^.vrSizeL._1 - newHStart :: Int - newHStart = if reqStart < curStart - then reqStart - else if reqStart > curEnd || reqEnd > curEnd - then reqEnd - vp^.vpSize._1 - else curStart - --- | Request that the specified widget be made visible when it is --- rendered inside a viewport. This permits widgets (whose sizes and --- positions cannot be known due to being embedded in arbitrary layouts) --- to make a request for a parent viewport to locate them and scroll --- enough to put them in view. This, together with 'viewport', is what --- makes the text editor and list widgets possible without making them --- deal with the details of scrolling state management. --- --- This does nothing if not rendered in a viewport. -visible :: Widget -> Widget -visible p = - Widget (hSize p) (vSize p) $ do - result <- render p - let imageSize = ( result^.imageL.to V.imageWidth - , result^.imageL.to V.imageHeight - ) - -- The size of the image to be made visible in a viewport must have - -- non-zero size in both dimensions. - return $ if imageSize^._1 > 0 && imageSize^._2 > 0 - then result & visibilityRequestsL %~ (VR (Location (0, 0)) imageSize :) - else result - --- | Similar to 'visible', request that a region (with the specified --- 'Location' as its origin and 'V.DisplayRegion' as its size) be made --- visible when it is rendered inside a viewport. The 'Location' is --- relative to the specified widget's upper-left corner of (0, 0). --- --- This does nothing if not rendered in a viewport. -visibleRegion :: Location -> V.DisplayRegion -> Widget -> Widget -visibleRegion vrloc sz p = - Widget (hSize p) (vSize p) $ do - result <- render p - -- The size of the image to be made visible in a viewport must have - -- non-zero size in both dimensions. - return $ if sz^._1 > 0 && sz^._2 > 0 - then result & visibilityRequestsL %~ (VR vrloc sz :) - else result - --- | Horizontal box layout: put the specified widgets next to each other --- in the specified order. Defers growth policies to the growth policies --- of both widgets. This operator is a binary version of 'hBox'. -(<+>) :: Widget - -- ^ Left - -> Widget - -- ^ Right - -> Widget -(<+>) a b = hBox [a, b] - --- | Vertical box layout: put the specified widgets one above the other --- in the specified order. Defers growth policies to the growth policies --- of both widgets. This operator is a binary version of 'vBox'. -(<=>) :: Widget - -- ^ Top - -> Widget - -- ^ Bottom - -> Widget -(<=>) a b = vBox [a, b] +cropResultToContext :: Result -> RenderM Result +cropResultToContext result = do + c <- getContext + return $ result & imageL %~ (V.crop (c^.availWidthL) (c^.availHeightL)) diff --git a/src/Brick/Widgets/List.hs b/src/Brick/Widgets/List.hs --- a/src/Brick/Widgets/List.hs +++ b/src/Brick/Widgets/List.hs @@ -4,7 +4,7 @@ -- | This module provides a scrollable list type and functions for -- manipulating and rendering it. module Brick.Widgets.List - ( List(listElements, listSelected, listName, listElementDraw) + ( List(listElements, listSelected, listName, listItemHeight) -- * Consructing a list , list @@ -16,6 +16,7 @@ , listElementsL , listSelectedL , listNameL + , listItemHeightL -- * Manipulating a list , listMoveBy @@ -34,13 +35,15 @@ where import Control.Applicative ((<$>)) -import Control.Lens ((^.), (&), (.~)) +import Control.Lens ((^.), (&), (.~), _2) import Data.Monoid ((<>)) import Data.Maybe (fromMaybe) import qualified Data.Algorithm.Diff as D import Graphics.Vty (Event(..), Key(..)) +import qualified Data.Vector as V import Brick.Types +import Brick.Main (lookupViewport) import Brick.Widgets.Core import Brick.Util (clamp) import Brick.AttrMap @@ -49,22 +52,38 @@ -- by the list. Lists handle the following events by default: -- -- * Up/down arrow keys: move cursor of selected item +-- * Page up / page down keys: move cursor of selected item by one page +-- at a time (based on the number of items shown) +-- * Home/end keys: move cursor of selected item to beginning or end of +-- list data List e = - List { listElements :: ![e] - , listElementDraw :: Bool -> e -> Widget + List { listElements :: !(V.Vector e) , listSelected :: !(Maybe Int) , listName :: Name + , listItemHeight :: Int } suffixLenses ''List instance HandleEvent (List e) where - handleEvent e theList = f theList + handleEvent e theList = f where f = case e of - EvKey KUp [] -> listMoveUp - EvKey KDown [] -> listMoveDown - _ -> id + EvKey KUp [] -> return $ listMoveUp theList + EvKey KDown [] -> return $ listMoveDown theList + EvKey KHome [] -> return $ listMoveTo 0 theList + EvKey KEnd [] -> return $ listMoveTo (V.length $ listElements theList) theList + EvKey KPageDown [] -> do + v <- lookupViewport (theList^.listNameL) + case v of + Nothing -> return theList + Just vp -> return $ listMoveBy (vp^.vpSize._2 `div` theList^.listItemHeightL) theList + EvKey KPageUp [] -> do + v <- lookupViewport (theList^.listNameL) + case v of + Nothing -> return theList + Just vp -> return $ listMoveBy (negate $ vp^.vpSize._2 `div` theList^.listItemHeightL) theList + _ -> return theList -- | The top-level attribute used for the entire list. listAttr :: AttrName @@ -78,35 +97,51 @@ -- | Construct a list in terms of an element type 'e'. list :: Name -- ^ The list name (must be unique) - -> (Bool -> e -> Widget) - -- ^ The item rendering function (takes the item and whether it is - -- currently selected) - -> [e] + -> V.Vector e -- ^ The initial list contents + -> Int + -- ^ The list item height in rows (all list item widgets must be + -- this high) -> List e -list name draw es = - let selIndex = if null es then Nothing else Just 0 - in List es draw selIndex name +list name es h = + let selIndex = if V.null es then Nothing else Just 0 + in List es selIndex name h --- | Turn a list state value into a widget. -renderList :: List e -> Widget -renderList l = withDefAttr listAttr $ - viewport (l^.listNameL) Vertical $ - vBox $ - drawListElements l +-- | Turn a list state value into a widget given an item drawing +-- function. +renderList :: List e -> (Bool -> e -> Widget) -> Widget +renderList l drawElem = + withDefAttr listAttr $ + drawListElements l drawElem -drawListElements :: List e -> [Widget] -drawListElements l = drawnElements - where - es = l^.listElementsL - drawnElements = (flip map) (zip [0..] es) $ \(i, e) -> - let isSelected = Just i == l^.listSelectedL - elemWidget = (l^.listElementDrawL) isSelected e - makeVisible = if isSelected - then (visible . withDefAttr listSelectedAttr) - else id - in makeVisible elemWidget +drawListElements :: List e -> (Bool -> e -> Widget) -> Widget +drawListElements l drawElem = + Widget Fixed Fixed $ do + c <- getContext + let es = V.slice start num (l^.listElementsL) + idx = case l^.listSelectedL of + Nothing -> 0 + Just i -> i + + start = max 0 $ idx - numPerHeight + 1 + num = min (numPerHeight * 2) (V.length (l^.listElementsL) - start) + numPerHeight = (c^.availHeightL) `div` (l^.listItemHeightL) + + off = start * (l^.listItemHeightL) + + drawnElements = (flip V.imap) es $ \i e -> + let isSelected = Just (i + start) == l^.listSelectedL + elemWidget = drawElem isSelected e + makeVisible = if isSelected + then (visible . withDefAttr listSelectedAttr) + else id + in makeVisible elemWidget + + render $ viewport (l^.listNameL) Vertical $ + translateBy (Location (0, off)) $ + vBox $ V.toList drawnElements + -- | Insert an item into a list at the specified position. listInsert :: Int -- ^ The position at which to insert (0 <= i <= size) @@ -115,24 +150,24 @@ -> List e -> List e listInsert pos e l = - let safePos = clamp 0 (length es) pos + let safePos = clamp 0 (V.length es) pos es = l^.listElementsL newSel = case l^.listSelectedL of Nothing -> 0 Just s -> if safePos < s then s + 1 else s - (front, back) = splitAt safePos es + (front, back) = V.splitAt safePos es in l & listSelectedL .~ Just newSel - & listElementsL .~ (front ++ (e : back)) + & listElementsL .~ (front V.++ (e `V.cons` back)) -- | Remove an element from a list at the specified position. listRemove :: Int -- ^ The position at which to remove an element (0 <= i < size) -> List e -> List e -listRemove pos l | null (l^.listElementsL) = l - | pos /= clamp 0 (length (l^.listElementsL) - 1) pos = l +listRemove pos l | V.null (l^.listElementsL) = l + | pos /= clamp 0 (V.length (l^.listElementsL) - 1) pos = l | otherwise = let newSel = case l^.listSelectedL of Nothing -> 0 @@ -143,22 +178,22 @@ else if pos < s then s - 1 else s - (front, back) = splitAt pos es - es' = front ++ tail back + (front, back) = V.splitAt pos es + es' = front V.++ V.tail back es = l^.listElementsL - in l & listSelectedL .~ (if null es' then Nothing else Just newSel) + in l & listSelectedL .~ (if V.null es' then Nothing else Just newSel) & listElementsL .~ es' -- | Replace the contents of a list with a new set of elements but -- preserve the currently selected index. -listReplace :: Eq e => [e] -> List e -> List e +listReplace :: Eq e => V.Vector e -> List e -> List e listReplace es' l | es' == l^.listElementsL = l | otherwise = let sel = fromMaybe 0 (l^.listSelectedL) - getNewSel es = case (null es, null es') of + getNewSel es = case (V.null es, V.null es') of (_, True) -> Nothing (True, False) -> Just 0 - (False, False) -> Just (maintainSel es es' sel) + (False, False) -> Just (maintainSel (V.toList es) (V.toList es') sel) newSel = getNewSel (l^.listElementsL) in l & listSelectedL .~ newSel @@ -178,14 +213,14 @@ -- validation. listMoveBy :: Int -> List e -> List e listMoveBy amt l = - let newSel = clamp 0 (length (l^.listElementsL) - 1) <$> (amt +) <$> (l^.listSelectedL) + let newSel = clamp 0 (V.length (l^.listElementsL) - 1) <$> (amt +) <$> (l^.listSelectedL) in l & listSelectedL .~ newSel -- | Set the selected index for a list to the specified index, subject -- to validation. listMoveTo :: Int -> List e -> List e listMoveTo pos l = - let len = length (l^.listElementsL) + let len = V.length (l^.listElementsL) newSel = clamp 0 (len - 1) $ if pos < 0 then (len - pos) else pos in l & listSelectedL .~ if len > 0 then Just newSel @@ -195,7 +230,7 @@ listSelectedElement :: List e -> Maybe (Int, e) listSelectedElement l = do sel <- l^.listSelectedL - return (sel, (l^.listElementsL) !! sel) + return (sel, (l^.listElementsL) V.! sel) -- Assuming `xs` is an existing list that we want to update to match the -- state of `ys`. Given a selected index in `xs`, the goal is to compute diff --git a/src/Brick/Widgets/ProgressBar.hs b/src/Brick/Widgets/ProgressBar.hs --- a/src/Brick/Widgets/ProgressBar.hs +++ b/src/Brick/Widgets/ProgressBar.hs @@ -11,6 +11,7 @@ import Control.Lens ((^.)) import Data.Monoid +import Brick.Types import Brick.AttrMap import Brick.Widgets.Core