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
, cropToContext
, withBorderStyle
, ViewportType(..)
, txt
, str
, fill
, Padding(..)
, padLeft
, padRight
, padTop
, padBottom
, padLeftRight
, padTopBottom
, padAll
, emptyWidget
, hBox
, vBox
, (<=>)
, (<+>)
, hLimit
, vLimit
, withDefAttr
, withAttr
, forceAttr
, updateAttrMap
, raw
, translateBy
, cropLeftBy
, cropRightBy
, cropTopBy
, cropBottomBy
, showCursor
, viewport
, visible
, visibleRegion
)
where
import Control.Applicative
import Control.Lens (makeLenses, (^.), (.~), (&), (%~), 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.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.AttrMap
import Brick.Util (clamp)
data VisibilityRequest =
VR { vrPosition :: Location
, vrSize :: V.DisplayRegion
}
deriving Show
data ViewportType = Vertical
| Horizontal
| Both
deriving Show
data Viewport =
VP { _vpLeft :: Int
, _vpTop :: Int
, _vpSize :: V.DisplayRegion
}
deriving Show
data Result =
Result { image :: V.Image
, cursors :: [CursorLocation]
, visibilityRequests :: [VisibilityRequest]
}
deriving Show
data Context =
Context { ctxAttrName :: AttrName
, availWidth :: Int
, availHeight :: Int
, ctxBorderStyle :: BorderStyle
, ctxAttrMap :: AttrMap
}
type RenderM a = ReaderT Context (State RenderState) a
data Size = Fixed
| Greedy
deriving (Show, Eq, Ord)
data Widget =
Widget { hSize :: Size
, vSize :: Size
, render :: RenderM Result
}
data Direction = Up
| Down
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 [] []
getContext :: RenderM Context
getContext = ask
withBorderStyle :: BorderStyle -> Widget -> Widget
withBorderStyle bs p = Widget (hSize p) (vSize p) $ withReaderT (& ctxBorderStyleL .~ bs) (render p)
emptyWidget :: Widget
emptyWidget = raw V.emptyImage
renderFinal :: AttrMap
-> [Widget]
-> V.DisplayRegion
-> ([CursorLocation] -> Maybe CursorLocation)
-> RenderState
-> (RenderState, V.Picture, Maybe CursorLocation)
renderFinal aMap layerRenders sz chooseCursor rs = (newRS, pic, theCursor)
where
(layerResults, newRS) = flip runState rs $ sequence $
(\p -> runReaderT p ctx) <$>
(render <$> cropToContext <$> layerRenders)
ctx = Context def (fst sz) (snd sz) def aMap
pic = V.picForLayers $ uncurry V.resize sz <$> (^.imageL) <$> layerResults
layerCursors = (^.cursorsL) <$> layerResults
theCursor = chooseCursor $ concat layerCursors
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
attrL :: (Contravariant f, Functor f) => (V.Attr -> f V.Attr) -> Context -> f Context
attrL = to (\c -> attrMapLookup (c^.ctxAttrNameL) (c^.ctxAttrMapL))
lookupAttrName :: AttrName -> RenderM V.Attr
lookupAttrName n = do
c <- getContext
return $ attrMapLookup n (c^.ctxAttrMapL)
str :: String -> Widget
str s =
Widget Fixed Fixed $ do
c <- getContext
let theLines = lines s
fixEmpty [] = " "
fixEmpty l = l
case fixEmpty <$> theLines of
[] -> return def
[one] -> return $ def & imageL .~ (V.string (c^.attrL) one)
multiple ->
let maxLength = maximum $ length <$> multiple
lineImgs = lineImg <$> multiple
lineImg lStr = V.string (c^.attrL) (lStr ++ replicate (maxLength length lStr) ' ')
in return $ def & imageL .~ (V.vertCat lineImgs)
txt :: T.Text -> Widget
txt = str . T.unpack
data Padding = Pad Int
| Max
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)
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 ' ')
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)
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 ' ')
padLeftRight :: Int -> Widget -> Widget
padLeftRight c w = padLeft (Pad c) $ padRight (Pad c) w
padTopBottom :: Int -> Widget -> Widget
padTopBottom r w = padTop (Pad r) $ padBottom (Pad r) w
padAll :: Int -> Widget -> Widget
padAll v w = padLeftRight v $ padTopBottom v w
fill :: Char -> Widget
fill ch =
Widget Greedy Greedy $ do
c <- getContext
return $ def & imageL .~ (V.charFill (c^.attrL) ch (c^.availWidthL) (c^.availHeightL))
vBox :: [Widget] -> Widget
vBox [] = emptyWidget
vBox pairs = renderBox vBoxRenderer pairs
hBox :: [Widget] -> Widget
hBox [] = emptyWidget
hBox pairs = renderBox hBoxRenderer pairs
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]
}
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
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)
hLimit :: Int -> Widget -> Widget
hLimit w p =
Widget Fixed (vSize p) $ do
withReaderT (& availWidthL .~ w) $ render $ cropToContext p
vLimit :: Int -> Widget -> Widget
vLimit h p =
Widget (hSize p) Fixed $ do
withReaderT (& availHeightL .~ h) $ render $ cropToContext p
withAttr :: AttrName -> Widget -> Widget
withAttr an p =
Widget (hSize p) (vSize p) $ do
withReaderT (& ctxAttrNameL .~ an) (render p)
withDefAttr :: AttrName -> Widget -> Widget
withDefAttr an p =
Widget (hSize p) (vSize p) $ do
c <- getContext
withReaderT (& ctxAttrMapL %~ (setDefault (attrMapLookup an (c^.ctxAttrMapL)))) (render p)
updateAttrMap :: (AttrMap -> AttrMap) -> Widget -> Widget
updateAttrMap f p =
Widget (hSize p) (vSize p) $ do
withReaderT (& ctxAttrMapL %~ f) (render p)
forceAttr :: AttrName -> Widget -> Widget
forceAttr an p =
Widget (hSize p) (vSize p) $ do
c <- getContext
withReaderT (& ctxAttrMapL .~ (forceAttrMap (attrMapLookup an (c^.ctxAttrMapL)))) (render p)
raw :: V.Image -> Widget
raw img = Widget Fixed Fixed $ return $ def & imageL .~ img
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))
cropToContext :: Widget -> Widget
cropToContext p =
Widget (hSize p) (vSize p) $ (render p >>= cropResultToContext)
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
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
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
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
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
viewport :: Name
-> ViewportType
-> Widget
-> Widget
viewport vpname typ p =
Widget Greedy Greedy $ do
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))
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
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))
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 ()
Just vp <- lift $ gets (M.lookup vpname . (^.viewportMapL))
translated <- render $ translateBy (Location (1 * vp^.vpLeft, 1 * vp^.vpTop))
$ Widget Fixed Fixed $ return initialResult
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
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
)
return $ if imageSize^._1 > 0 && imageSize^._2 > 0
then result & visibilityRequestsL %~ (VR (Location (0, 0)) imageSize :)
else result
visibleRegion :: Location -> V.DisplayRegion -> Widget -> Widget
visibleRegion vrloc sz p =
Widget (hSize p) (vSize p) $ do
result <- render p
return $ if sz^._1 > 0 && sz^._2 > 0
then result & visibilityRequestsL %~ (VR vrloc sz :)
else result
(<+>) :: Widget
-> Widget
-> Widget
(<+>) a b = hBox [a, b]
(<=>) :: Widget
-> Widget
-> Widget
(<=>) a b = vBox [a, b]