module Brick.Widgets.Core
(
emptyWidget
, raw
, txt
, str
, fill
, padLeft
, padRight
, padTop
, padBottom
, padLeftRight
, padTopBottom
, padAll
, (<=>)
, (<+>)
, hBox
, vBox
, hLimit
, vLimit
, withDefAttr
, withAttr
, forceAttr
, updateAttrMap
, withBorderStyle
, showCursor
, translateBy
, cropLeftBy
, cropRightBy
, cropTopBy
, cropBottomBy
, viewport
, visible
, visibleRegion
, addResultOffset
, cropToContext
)
where
import Control.Applicative
import Control.Lens ((^.), (.~), (&), (%~), to, _1, _2, each, to, ix)
import Control.Monad (when)
import Control.Monad.Trans.State.Lazy
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Class (lift)
import qualified Data.Text as T
import Data.Default
import Data.Monoid ((<>), mempty)
import qualified Data.Map as M
import qualified Data.Function as DF
import Data.List (sortBy, partition)
import Control.Lens (Lens')
import qualified Graphics.Vty as V
import Control.DeepSeq
import Brick.Types
import Brick.Types.Internal
import Brick.Widgets.Border.Style
import Brick.Util (clOffset, clamp)
import Brick.AttrMap
import Brick.Widgets.Internal
withBorderStyle :: BorderStyle -> Widget -> Widget
withBorderStyle bs p = Widget (hSize p) (vSize p) $ withReaderT (& ctxBorderStyleL .~ bs) (render p)
emptyWidget :: Widget
emptyWidget = raw V.emptyImage
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
str :: String -> Widget
str s =
Widget Fixed Fixed $ do
c <- getContext
let theLines = fixEmpty <$> (dropUnused . lines) s
fixEmpty [] = " "
fixEmpty l = l
dropUnused l = take (availWidth c) <$> take (availHeight c) l
case force theLines of
[] -> return def
[one] -> return $ def & imageL .~ (V.string (c^.attrL) one)
multiple ->
let maxLength = maximum $ length <$> multiple
lineImgs = lineImg <$> multiple
lineImg lStr = V.string (c^.attrL) (lStr ++ replicate (maxLength length lStr) ' ')
in return $ def & imageL .~ (V.vertCat lineImgs)
txt :: T.Text -> Widget
txt = str . T.unpack
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))
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
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 ()
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))
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]