jtdaugherty/brick
1
1
Fork 0
mirror of https://github.com/jtdaugherty/brick.git synced 2024-09-11 15:55:54 +03:00
Code Issues Projects Releases Wiki Activity

Monster patch: move most data types to Brick.Types, remove IsString

Browse Source 
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:
Jonathan Daugherty 2015-08-19 19:40:06 -07:00
parent 32b2740409
commit 35aa2ad8a4
24 changed files with 1031 additions and 1025 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
brick.cabal
View File

@ -73,6 +73,7 @@ library
Data.Text.Markup
other-modules:
Brick.Types.TH
Brick.Types.Internal
Brick.Widgets.Internal
build-depends: base <= 5,

39
programs/AttrDemo.hs
View File

@ -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

19
programs/BorderDemo.hs
View File

@ -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

6
programs/CustomEventDemo.hs
View File

@ -18,9 +18,11 @@ import Brick.Main
, continue
, halt
)
import Brick.Widgets.Core
import Brick.Types
( Widget
, (<=>)
)
import Brick.Widgets.Core
( (<=>)
, str
)

6
programs/DialogDemo.hs
View File

@ -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

16
programs/EditDemo.hs
View File

@ -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 =

6
programs/HelloWorldDemo.hs
View File

@ -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

6
programs/LayerDemo.hs
View File

@ -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
)

18
programs/ListDemo.hs
View File

@ -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])

6
programs/MarkupDemo.hs
View File

@ -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, (@?))

23
programs/PaddingDemo.hs
View File

@ -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

8
programs/SuspendAndResumeDemo.hs
View File

@ -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)

18
programs/ViewportScrollDemo.hs
View File

@ -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

6
programs/VisibilityDemo.hs
View File

@ -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

6
src/Brick/Main.hs
View File

@ -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.

1
src/Brick/Markup.hs
View File

@ -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.

156
src/Brick/Types.hs
View File

@ -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
View 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

2
src/Brick/Util.hs
View File

@ -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

1
src/Brick/Widgets/Border.hs
View File

@ -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(..))

694
src/Brick/Widgets/Core.hs
View File

@ -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]

2
src/Brick/Widgets/Dialog.hs
View File

@ -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

864
src/Brick/Widgets/Internal.hs
View File

@ -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]

1
src/Brick/Widgets/ProgressBar.hs
View File

@ -11,6 +11,7 @@ where
import Control.Lens ((^.))
import Data.Monoid
import Brick.Types
import Brick.AttrMap
import Brick.Widgets.Core