mirror of
https://github.com/jtdaugherty/brick.git
synced 2024-09-11 15:55:54 +03:00
Monster patch: move most data types to Brick.Types, remove IsString
instance for Widget - This makes the module layout more predictable since Brick.Widgets.Core now (mostly) only contains widgets and widget transformations - Utility functions closely related to types are now in Brick.Types - Brick.Types.Internal contains types used internal by the renderer, some are re-exported by Brick.Types
This commit is contained in:
parent
32b2740409
commit
35aa2ad8a4
@ -73,6 +73,7 @@ library
|
||||
Data.Text.Markup
|
||||
other-modules:
|
||||
Brick.Types.TH
|
||||
Brick.Types.Internal
|
||||
Brick.Widgets.Internal
|
||||
|
||||
build-depends: base <= 5,
|
||||
|
@ -8,33 +8,36 @@ import Graphics.Vty
|
||||
)
|
||||
|
||||
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
|
||||
|
@ -9,9 +9,11 @@ import qualified Graphics.Vty as V
|
||||
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 @@ import Brick.Widgets.Core
|
||||
, updateAttrMap
|
||||
, withBorderStyle
|
||||
, txt
|
||||
, str
|
||||
)
|
||||
import qualified Brick.Widgets.Center as C
|
||||
import qualified Brick.Widgets.Border as B
|
||||
@ -55,7 +58,7 @@ borderDemos = mkBorderDemo <$> styles
|
||||
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 @@ borderMappings =
|
||||
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
|
||||
|
@ -18,9 +18,11 @@ import Brick.Main
|
||||
, continue
|
||||
, halt
|
||||
)
|
||||
import Brick.Widgets.Core
|
||||
import Brick.Types
|
||||
( Widget
|
||||
, (<=>)
|
||||
)
|
||||
import Brick.Widgets.Core
|
||||
( (<=>)
|
||||
, str
|
||||
)
|
||||
|
||||
|
@ -5,9 +5,11 @@ import Data.Monoid
|
||||
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
|
||||
|
@ -9,11 +9,11 @@ import qualified Graphics.Vty as V
|
||||
import qualified Brick.Main as M
|
||||
import qualified Brick.Types as T
|
||||
import Brick.Widgets.Core
|
||||
( Widget
|
||||
, (<+>)
|
||||
( (<+>)
|
||||
, (<=>)
|
||||
, hLimit
|
||||
, vLimit
|
||||
, str
|
||||
, multilineStr
|
||||
)
|
||||
import qualified Brick.Widgets.Center as C
|
||||
@ -47,14 +47,14 @@ currentEditorL st =
|
||||
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 ev =
|
||||
|
@ -1,11 +1,11 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Main where
|
||||
|
||||
import Brick.Main (simpleMain)
|
||||
import Brick.Widgets.Core (Widget)
|
||||
import Brick.Types (Widget)
|
||||
import Brick.Widgets.Core (str)
|
||||
|
||||
ui :: Widget
|
||||
ui = "Hello, world!"
|
||||
ui = str "Hello, world!"
|
||||
|
||||
main :: IO ()
|
||||
main = simpleMain ui
|
||||
|
@ -11,9 +11,11 @@ import qualified Brick.Types as T
|
||||
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
|
||||
, multilineStr
|
||||
)
|
||||
|
||||
|
@ -13,9 +13,11 @@ import qualified Brick.Widgets.List as L
|
||||
import qualified Brick.Widgets.Center as C
|
||||
import qualified Brick.AttrMap as A
|
||||
import qualified Data.Vector as V
|
||||
import Brick.Widgets.Core
|
||||
import Brick.Types
|
||||
( Widget
|
||||
, (<+>)
|
||||
)
|
||||
import Brick.Widgets.Core
|
||||
( (<+>)
|
||||
, str
|
||||
, vLimit
|
||||
, hLimit
|
||||
@ -27,9 +29,9 @@ import Brick.Util (fg, on)
|
||||
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 $ V.length $ l^.(L.listElementsL)
|
||||
box = B.borderWithLabel label $
|
||||
@ -37,9 +39,9 @@ drawUI l = [ui]
|
||||
vLimit 15 $
|
||||
L.renderList l listDrawElement 1
|
||||
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))
|
||||
@ -63,7 +65,7 @@ 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") (V.fromList [0, 1, 2])
|
||||
|
@ -5,9 +5,11 @@ import Data.Monoid ((<>))
|
||||
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, (@?))
|
||||
|
@ -5,11 +5,14 @@ import Data.Default
|
||||
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 @@ import Brick.Widgets.Center as C
|
||||
|
||||
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
|
||||
|
@ -13,9 +13,11 @@ import Brick.Main
|
||||
, suspendAndResume, halt, continue
|
||||
, EventM, Next
|
||||
)
|
||||
import Brick.Widgets.Core
|
||||
import Brick.Types
|
||||
( Widget
|
||||
, vBox
|
||||
)
|
||||
import Brick.Widgets.Core
|
||||
( vBox
|
||||
, str
|
||||
)
|
||||
|
||||
@ -29,7 +31,7 @@ drawUI :: St -> [Widget]
|
||||
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)
|
||||
|
@ -1,5 +1,5 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
module Main where
|
||||
|
||||
import Control.Applicative
|
||||
@ -12,10 +12,12 @@ import qualified Brick.Types as T
|
||||
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 @@ drawUi = const [ui]
|
||||
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
|
||||
|
@ -13,10 +13,12 @@ import qualified Brick.Widgets.Center as C
|
||||
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
|
||||
|
@ -52,9 +52,9 @@ import Graphics.Vty
|
||||
, 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.Internal (ScrollRequest(..), RenderState(..))
|
||||
import Brick.Widgets.Internal (renderFinal)
|
||||
import Brick.Types (Direction, Widget, rowL, columnL, CursorLocation(..), cursorLocationNameL, Name(..))
|
||||
import Brick.AttrMap
|
||||
|
||||
-- | The type of actions to take in an event handler.
|
||||
|
@ -21,6 +21,7 @@ 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.
|
||||
|
@ -1,6 +1,6 @@
|
||||
-- | Basic types used by this library.
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
module Brick.Types
|
||||
( Location(..)
|
||||
, locL
|
||||
@ -11,71 +11,117 @@ module Brick.Types
|
||||
, HandleEvent(..)
|
||||
, Name(..)
|
||||
, suffixLenses
|
||||
, Widget(..)
|
||||
, Size(..)
|
||||
, Direction(..)
|
||||
, ViewportType(..)
|
||||
, Padding(..)
|
||||
|
||||
-- * Rendering infrastructure
|
||||
, RenderM
|
||||
, getContext
|
||||
|
||||
-- ** The rendering context
|
||||
, Context(ctxAttrName, availWidth, availHeight, ctxBorderStyle, ctxAttrMap)
|
||||
, attrL
|
||||
, availWidthL
|
||||
, availHeightL
|
||||
, ctxAttrMapL
|
||||
, ctxAttrNameL
|
||||
, ctxBorderStyleL
|
||||
|
||||
-- ** Rendering results
|
||||
, Result(..)
|
||||
, lookupAttrName
|
||||
-- ** Result lenses
|
||||
, imageL
|
||||
, cursorsL
|
||||
, visibilityRequestsL
|
||||
|
||||
-- ** Visibility requests
|
||||
, VisibilityRequest(..)
|
||||
, vrPositionL
|
||||
, vrSizeL
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens
|
||||
import Data.String
|
||||
import Control.Lens (_1, _2, to, (^.))
|
||||
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 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 -> a
|
||||
|
||||
instance Field1 Location Location Int Int where
|
||||
_1 = locL._1
|
||||
-- | 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 Field2 Location Location Int Int where
|
||||
_2 = locL._2
|
||||
-- | 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
|
||||
}
|
||||
|
||||
-- | 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
|
||||
-- | 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 TerminalLocation Location where
|
||||
columnL = _1
|
||||
column (Location t) = fst t
|
||||
rowL = _2
|
||||
row (Location t) = snd t
|
||||
-- | 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
|
||||
|
||||
-- | Names of things. Used to name cursor locations, widgets, and
|
||||
-- viewports.
|
||||
newtype Name = Name String
|
||||
deriving (Eq, Show, Ord)
|
||||
instance Default Result where
|
||||
def = Result emptyImage [] []
|
||||
|
||||
instance IsString Name where
|
||||
fromString = Name
|
||||
-- | Get the current rendering context.
|
||||
getContext :: RenderM Context
|
||||
getContext = ask
|
||||
|
||||
-- | The origin (upper-left corner).
|
||||
origin :: Location
|
||||
origin = Location (0, 0)
|
||||
suffixLenses ''Context
|
||||
suffixLenses ''Result
|
||||
|
||||
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
|
||||
|
||||
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 +129,9 @@ instance TerminalLocation CursorLocation where
|
||||
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)
|
||||
|
151
src/Brick/Types/Internal.hs
Normal file
151
src/Brick/Types/Internal.hs
Normal file
@ -0,0 +1,151 @@
|
||||
{-# 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(..)
|
||||
|
||||
, scrollRequestsL
|
||||
, viewportMapL
|
||||
, vpSize
|
||||
, vpLeft
|
||||
, vpTop
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens (Field1, Field2, _1, _2, Lens', makeLenses)
|
||||
import Data.String
|
||||
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
|
||||
|
||||
data Viewport =
|
||||
VP { _vpLeft :: Int
|
||||
, _vpTop :: Int
|
||||
, _vpSize :: 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
|
||||
|
||||
-- | 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
|
@ -12,7 +12,7 @@ import Control.Lens ((&), (%~))
|
||||
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
|
||||
|
@ -36,6 +36,7 @@ import Data.Monoid ((<>))
|
||||
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(..))
|
||||
|
@ -1,12 +1,11 @@
|
||||
{-# 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
|
||||
, multilineTxt
|
||||
@ -15,7 +14,6 @@ module Brick.Widgets.Core
|
||||
, fill
|
||||
|
||||
-- * Padding
|
||||
, Padding(..)
|
||||
, padLeft
|
||||
, padRight
|
||||
, padTop
|
||||
@ -56,43 +54,671 @@ module Brick.Widgets.Core
|
||||
, 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 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 one-line 'String'.
|
||||
str :: String -> Widget
|
||||
str s =
|
||||
Widget Fixed Fixed $ do
|
||||
c <- getContext
|
||||
return $ def & imageL .~ (V.string (c^.attrL) s)
|
||||
|
||||
-- | Build a widget from a multi-line 'String'. Breaks newlines up and
|
||||
-- space-pads short lines out to the length of the longest line. If you
|
||||
-- know that your string is only one line, use 'str' instead since it is
|
||||
-- faster.
|
||||
multilineStr :: String -> Widget
|
||||
multilineStr 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 one-line 'T.Text' value. Behaves the same as
|
||||
-- 'str'.
|
||||
txt :: T.Text -> Widget
|
||||
txt = str . T.unpack
|
||||
|
||||
-- | Build a widget from a multi-line 'T.Text' value. Behaves the same as
|
||||
-- 'multilineStr'.
|
||||
multilineTxt :: T.Text -> Widget
|
||||
multilineTxt = multilineStr . T.unpack
|
||||
|
||||
-- | 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))
|
||||
|
||||
-- | 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]
|
||||
|
@ -106,7 +106,7 @@ buttonSelectedAttr = buttonAttr <> "selected"
|
||||
-- | 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
|
||||
|
@ -1,227 +1,21 @@
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeSynonymInstances #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
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
|
||||
, multilineTxt
|
||||
, str
|
||||
, multilineStr
|
||||
, 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]
|
||||
@ -239,656 +33,14 @@ renderFinal aMap layerRenders sz chooseCursor rs = (newRS, pic, theCursor)
|
||||
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 one-line 'String'.
|
||||
str :: String -> Widget
|
||||
str s =
|
||||
Widget Fixed Fixed $ do
|
||||
c <- getContext
|
||||
return $ def & imageL .~ (V.string (c^.attrL) s)
|
||||
|
||||
-- | Build a widget from a multi-line 'String'. Breaks newlines up and
|
||||
-- space-pads short lines out to the length of the longest line. If you
|
||||
-- know that your string is only one line, use 'str' instead since it is
|
||||
-- faster.
|
||||
multilineStr :: String -> Widget
|
||||
multilineStr 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 one-line 'T.Text' value. Behaves the same as
|
||||
-- 'str'.
|
||||
txt :: T.Text -> Widget
|
||||
txt = str . T.unpack
|
||||
|
||||
-- | Build a widget from a multi-line 'T.Text' value. Behaves the same as
|
||||
-- 'multilineStr'.
|
||||
multilineTxt :: T.Text -> Widget
|
||||
multilineTxt = multilineStr . 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
|
||||
cropResultToContext :: Result -> RenderM Result
|
||||
cropResultToContext result = do
|
||||
c <- getContext
|
||||
return $ result & imageL %~ (V.crop (c^.availWidthL) (c^.availHeightL))
|
||||
|
||||
-- | 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]
|
||||
|
@ -11,6 +11,7 @@ where
|
||||
import Control.Lens ((^.))
|
||||
import Data.Monoid
|
||||
|
||||
import Brick.Types
|
||||
import Brick.AttrMap
|
||||
import Brick.Widgets.Core
|
||||
|
||||
|
Loading…
Reference in New Issue
Block a user