{-# LANGUAGE RankNTypes #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-} -- | 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 ( -- * Basic rendering primitives TextWidth(..) , emptyWidget , raw , txt , txtWrap , txtWrapWith , str , strWrap , strWrapWith , fill , hyperlink -- * Padding , Padding(..) , padLeft , padRight , padTop , padBottom , padLeftRight , padTopBottom , padAll -- * Box layout , (<=>) , (<+>) , hBox , vBox -- * Limits , hLimit , hLimitPercent , vLimit , vLimitPercent , setAvailableSize -- * Attribute management , withDefAttr , modifyDefAttr , withAttr , forceAttr , overrideAttr , updateAttrMap -- * Border style management , withBorderStyle , joinBorders , separateBorders , freezeBorders -- * Cursor placement , showCursor , putCursor -- * Naming , Named(..) -- * Translation and positioning , translateBy , relativeTo -- * Cropping , cropLeftBy , cropRightBy , cropTopBy , cropBottomBy , cropLeftTo , cropRightTo , cropTopTo , cropBottomTo -- * Extent reporting , reportExtent , clickable -- * Scrollable viewports , viewport , visible , visibleRegion , unsafeLookupViewport , cached -- ** Viewport scroll bars , withVScrollBars , withHScrollBars , withClickableHScrollBars , withClickableVScrollBars , withVScrollBarHandles , withHScrollBarHandles , withVScrollBarRenderer , withHScrollBarRenderer , ScrollbarRenderer(..) , verticalScrollbarRenderer , horizontalScrollbarRenderer , scrollbarAttr , scrollbarTroughAttr , scrollbarHandleAttr , verticalScrollbar , horizontalScrollbar -- ** Adding offsets to cursor positions and visibility requests , addResultOffset -- ** Cropping results , cropToContext ) where #if !(MIN_VERSION_base(4,11,0)) import Data.Monoid ((<>)) #endif import Lens.Micro ((^.), (.~), (&), (%~), to, _1, _2, each, to, Lens') import Lens.Micro.Mtl (use, (%=)) import Control.Monad.State.Strict import Control.Monad.Reader import qualified Data.Foldable as F import qualified Data.Text as T import qualified Data.DList as DL import qualified Data.Map as M import qualified Data.Set as S import qualified Data.IMap as I import qualified Data.Function as DF import Data.List (sortBy, partition) import Data.Maybe (fromMaybe) import qualified Graphics.Vty as V import Control.DeepSeq import Text.Wrap (wrapTextToLines, WrapSettings, defaultWrapSettings) import Brick.Types import Brick.Types.Internal import Brick.Widgets.Border.Style import Brick.Util (clOffset, clamp) import Brick.AttrMap import Brick.Widgets.Internal import qualified Brick.BorderMap as BM -- | The class of text types that have widths measured in terminal -- columns. NEVER use 'length' etc. to measure the length of a string if -- you need to compute how much screen space it will occupy; always use -- 'textWidth'. class TextWidth a where textWidth :: a -> Int instance TextWidth T.Text where textWidth = V.wcswidth . T.unpack instance (F.Foldable f) => TextWidth (f Char) where textWidth = V.wcswidth . F.toList -- | The class of types that store interface element names. class Named a n where -- | Get the name of the specified value. getName :: a -> n -- | When rendering the specified widget, use the specified border style -- for any border rendering. withBorderStyle :: BorderStyle -> Widget n -> Widget n withBorderStyle bs p = Widget (hSize p) (vSize p) $ withReaderT (ctxBorderStyleL .~ bs) (render p) -- | When rendering the specified widget, create borders that respond -- dynamically to their neighbors to form seamless connections. joinBorders :: Widget n -> Widget n joinBorders p = Widget (hSize p) (vSize p) $ withReaderT (ctxDynBordersL .~ True) (render p) -- | When rendering the specified widget, use static borders. This -- may be marginally faster, but will introduce a small gap between -- neighboring orthogonal borders. -- -- This is the default for backwards compatibility. separateBorders :: Widget n -> Widget n separateBorders p = Widget (hSize p) (vSize p) $ withReaderT (ctxDynBordersL .~ False) (render p) -- | After the specified widget has been rendered, freeze its borders. A -- frozen border will not be affected by neighbors, nor will it affect -- neighbors. Compared to 'separateBorders', 'freezeBorders' will not -- affect whether borders connect internally to a widget (whereas -- 'separateBorders' prevents them from connecting). -- -- Frozen borders cannot be thawed. freezeBorders :: Widget n -> Widget n freezeBorders p = Widget (hSize p) (vSize p) $ (bordersL %~ BM.clear) <$> render p -- | The empty widget. emptyWidget :: Widget n emptyWidget = raw V.emptyImage -- | Add an offset to all cursor locations, visbility requests, and -- extents 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 n -> Result n addResultOffset off = addCursorOffset off . addVisibilityOffset off . addExtentOffset off . addDynBorderOffset off addVisibilityOffset :: Location -> Result n -> Result n addVisibilityOffset off r = r & visibilityRequestsL.each.vrPositionL %~ (off <>) addExtentOffset :: Location -> Result n -> Result n addExtentOffset off r = r & extentsL.each %~ (\(Extent n l sz) -> Extent n (off <> l) sz) addDynBorderOffset :: Location -> Result n -> Result n addDynBorderOffset off r = r & bordersL %~ BM.translate off -- | Render the specified widget and record its rendering extent using -- the specified name (see also 'lookupExtent'). -- -- This function is the counterpart to 'makeVisible'; any visibility -- requests made with 'makeVisible' must have a corresponding -- 'reportExtent' in order to work. The 'clickable' function will also -- work for this purpose to tell the renderer about the clickable -- region. reportExtent :: (Ord n) => n -> Widget n -> Widget n reportExtent n p = Widget (hSize p) (vSize p) $ do result <- render p let ext = Extent n (Location (0, 0)) sz sz = ( result^.imageL.to V.imageWidth , result^.imageL.to V.imageHeight ) -- If the reported extent also has a visibility request -- from EventM via makeVisible, add a visibility request to -- the render state so this gets scrolled into view by any -- containing viewport. vReqs <- use requestedVisibleNames_L let addVisReq = if sz^._1 > 0 && sz^._2 > 0 && n `S.member` vReqs then visibilityRequestsL %~ (VR (Location (0, 0)) sz :) else id return $ addVisReq $ result & extentsL %~ (ext:) -- | Request mouse click events on the specified widget. -- -- Regions used with 'clickable' can be scrolled into view with -- 'makeVisible'. clickable :: (Ord n) => n -> Widget n -> Widget n clickable n p = Widget (hSize p) (vSize p) $ do clickableNamesL %= (n:) render $ reportExtent n p addCursorOffset :: Location -> Result n -> Result n addCursorOffset off r = let onlyVisible = filter isVisible isVisible l = l^.locationColumnL >= 0 && l^.locationRowL >= 0 in r & cursorsL %~ (\cs -> onlyVisible $ (`clOffset` off) <$> cs) unrestricted :: Int unrestricted = 100000 -- | Take a substring capable of fitting into the number of specified -- columns. This function takes character column widths into -- consideration. takeColumns :: Int -> String -> String takeColumns _ "" = "" takeColumns numCols (c:cs) = let w = V.safeWcwidth c in if w > numCols then [] else c : takeColumns (numCols - w) cs -- | Make a widget from a string, but wrap the words in the input's -- lines at the available width using the default wrapping settings. The -- input string should not contain escape sequences or carriage returns. -- -- Unlike 'str', this is greedy horizontally. strWrap :: String -> Widget n strWrap = strWrapWith defaultWrapSettings -- | Make a widget from a string, but wrap the words in the input's -- lines at the available width using the specified wrapping settings. -- The input string should not contain escape sequences or carriage -- returns. -- -- Unlike 'str', this is greedy horizontally. strWrapWith :: WrapSettings -> String -> Widget n strWrapWith settings t = txtWrapWith settings $ T.pack t safeTextWidth :: T.Text -> Int safeTextWidth = V.safeWcswidth . T.unpack -- | Make a widget from text, but wrap the words in the input's lines at -- the available width using the default wrapping settings. The input -- text should not contain escape sequences or carriage returns. -- -- Unlike 'txt', this is greedy horizontally. txtWrap :: T.Text -> Widget n txtWrap = txtWrapWith defaultWrapSettings -- | Make a widget from text, but wrap the words in the input's lines at -- the available width using the specified wrapping settings. The input -- text should not contain escape sequences or carriage returns. -- -- Unlike 'txt', this is greedy horizontally. txtWrapWith :: WrapSettings -> T.Text -> Widget n txtWrapWith settings s = Widget Greedy Fixed $ do c <- getContext let theLines = fixEmpty <$> wrapTextToLines settings (c^.availWidthL) s fixEmpty l | T.null l = " " | otherwise = l case force theLines of [] -> return emptyResult multiple -> let maxLength = maximum $ safeTextWidth <$> multiple padding = V.charFill (c^.attrL) ' ' (c^.availWidthL - maxLength) (length lineImgs) lineImgs = lineImg <$> multiple lineImg lStr = V.text' (c^.attrL) (lStr <> T.replicate (maxLength - safeTextWidth lStr) " ") in return $ emptyResult & imageL .~ (V.horizCat [V.vertCat lineImgs, padding]) -- | Build a widget from a 'String'. Breaks newlines up and space-pads -- short lines out to the length of the longest line. -- -- The input string must not contain tab characters. If it does, -- interface corruption will result since the terminal will likely -- render it as taking up more than a single column. The caller should -- replace tabs with the appropriate number of spaces as desired. The -- input string should not contain escape sequences or carriage returns. str :: String -> Widget n str s = Widget Fixed Fixed $ do c <- getContext let theLines = fixEmpty <$> (dropUnused . lines) s fixEmpty :: String -> String fixEmpty [] = " " fixEmpty l = l dropUnused l = takeColumns (availWidth c) <$> take (availHeight c) l case force theLines of [] -> return emptyResult [one] -> return $ emptyResult & imageL .~ (V.string (c^.attrL) one) multiple -> let maxLength = maximum $ V.safeWcswidth <$> multiple lineImgs = lineImg <$> multiple lineImg lStr = V.string (c^.attrL) (lStr ++ replicate (maxLength - V.safeWcswidth lStr) ' ') in return $ emptyResult & imageL .~ (V.vertCat lineImgs) -- | Build a widget from a 'T.Text' value. Behaves the same as 'str' -- when the input contains multiple lines. -- -- The input string must not contain tab characters. If it does, -- interface corruption will result since the terminal will likely -- render it as taking up more than a single column. The caller should -- replace tabs with the appropriate number of spaces as desired. The -- input text should not contain escape sequences or carriage returns. txt :: T.Text -> Widget n txt = str . T.unpack -- | Hyperlink the given widget to the specified URL. Not all terminal -- emulators support this. In those that don't, this should have no -- discernible effect. hyperlink :: T.Text -> Widget n -> Widget n hyperlink url p = Widget (hSize p) (vSize p) $ do c <- getContext let attr = (c^.attrL) `V.withURL` url withReaderT (ctxAttrMapL %~ setDefaultAttr attr) (render p) -- | 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. If max padding is used, this -- grows greedily horizontally; otherwise it defers to the padded -- widget. padLeft :: Padding -> Widget n -> Widget n padLeft padding p = let (f, sz) = case padding of Max -> (id, Greedy) Pad i -> (hLimit i, hSize p) in Widget sz (vSize p) $ do c <- getContext let lim = case padding of Max -> c^.availWidthL Pad i -> c^.availWidthL - i result <- render $ hLimit lim p render $ (f $ vLimit (result^.imageL.to V.imageHeight) $ fill ' ') <+> (Widget Fixed Fixed $ return result) -- | Pad the specified widget on the right. If max padding is used, -- this grows greedily horizontally; otherwise it defers to the padded -- widget. padRight :: Padding -> Widget n -> Widget n padRight padding p = let (f, sz) = case padding of Max -> (id, Greedy) Pad i -> (hLimit i, hSize p) in Widget sz (vSize p) $ do c <- getContext let lim = case padding of Max -> c^.availWidthL Pad i -> c^.availWidthL - i result <- render $ hLimit lim p render $ (Widget Fixed Fixed $ return result) <+> (f $ vLimit (result^.imageL.to V.imageHeight) $ fill ' ') -- | Pad the specified widget on the top. If max padding is used, this -- grows greedily vertically; otherwise it defers to the padded widget. padTop :: Padding -> Widget n -> Widget n padTop padding p = let (f, sz) = case padding of Max -> (id, Greedy) Pad i -> (vLimit i, vSize p) in Widget (hSize p) sz $ do c <- getContext let lim = case padding of Max -> c^.availHeightL Pad i -> c^.availHeightL - i result <- render $ vLimit lim p render $ (f $ hLimit (result^.imageL.to V.imageWidth) $ fill ' ') <=> (Widget Fixed Fixed $ return result) -- | Pad the specified widget on the bottom. If max padding is used, -- this grows greedily vertically; otherwise it defers to the padded -- widget. padBottom :: Padding -> Widget n -> Widget n padBottom padding p = let (f, sz) = case padding of Max -> (id, Greedy) Pad i -> (vLimit i, vSize p) in Widget (hSize p) sz $ do c <- getContext let lim = case padding of Max -> c^.availHeightL Pad i -> c^.availHeightL - i result <- render $ vLimit lim p render $ (Widget Fixed Fixed $ return result) <=> (f $ hLimit (result^.imageL.to V.imageWidth) $ fill ' ') -- | Pad a widget on the left and right. Defers to the padded widget for -- growth policy. padLeftRight :: Int -> Widget n -> Widget n padLeftRight c w = padLeft (Pad c) $ padRight (Pad c) w -- | Pad a widget on the top and bottom. Defers to the padded widget for -- growth policy. padTopBottom :: Int -> Widget n -> Widget n padTopBottom r w = padTop (Pad r) $ padBottom (Pad r) w -- | Pad a widget on all sides. Defers to the padded widget for growth -- policy. padAll :: Int -> Widget n -> Widget n padAll v w = padLeftRight v $ padTopBottom v w -- | Fill all available space with the specified character. Grows both -- horizontally and vertically. fill :: Char -> Widget n fill ch = Widget Greedy Greedy $ do c <- getContext return $ emptyResult & imageL .~ (V.charFill (c^.attrL) ch (c^.availWidthL) (c^.availHeightL)) -- | Vertical box layout: put the specified widgets one above the other -- in the specified order (uppermost first). Defers growth policies to -- the growth policies of the contained widgets (if any are greedy, so -- is the box). {-# NOINLINE vBox #-} vBox :: [Widget n] -> Widget n vBox [] = emptyWidget vBox [a] = a vBox pairs = renderBox vBoxRenderer pairs -- | Horizontal box layout: put the specified widgets next to each other -- in the specified order (leftmost first). Defers growth policies to -- the growth policies of the contained widgets (if any are greedy, so -- is the box). {-# NOINLINE hBox #-} hBox :: [Widget n] -> Widget n hBox [] = emptyWidget hBox [a] = a 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 n = BoxRenderer { contextPrimary :: Lens' (Context n) Int , contextSecondary :: Lens' (Context n) Int , imagePrimary :: V.Image -> Int , imageSecondary :: V.Image -> Int , limitPrimary :: Int -> Widget n -> Widget n , limitSecondary :: Int -> Widget n -> Widget n , primaryWidgetSize :: Widget n -> Size , concatenatePrimary :: [V.Image] -> V.Image , concatenateSecondary :: [V.Image] -> V.Image , locationFromOffset :: Int -> Location , padImageSecondary :: Int -> V.Image -> V.Attr -> V.Image , loPrimary :: forall a. Lens' (Edges a) a -- lo: towards smaller coordinates in that dimension , hiPrimary :: forall a. Lens' (Edges a) a -- hi: towards larger coordinates in that dimension , loSecondary :: forall a. Lens' (Edges a) a , hiSecondary :: forall a. Lens' (Edges a) a , locationFromPrimarySecondary :: Int -> Int -> Location , splitLoPrimary :: Int -> V.Image -> V.Image , splitHiPrimary :: Int -> V.Image -> V.Image , splitLoSecondary :: Int -> V.Image -> V.Image , splitHiSecondary :: Int -> V.Image -> V.Image , lookupPrimary :: Int -> BM.BorderMap DynBorder -> I.IMap DynBorder , insertSecondary :: Location -> I.Run DynBorder -> BM.BorderMap DynBorder -> BM.BorderMap DynBorder } vBoxRenderer :: BoxRenderer n vBoxRenderer = BoxRenderer { contextPrimary = availHeightL , contextSecondary = availWidthL , imagePrimary = V.imageHeight , imageSecondary = V.imageWidth , limitPrimary = vLimit , limitSecondary = hLimit , primaryWidgetSize = vSize , concatenatePrimary = V.vertCat , concatenateSecondary = V.horizCat , locationFromOffset = Location . (0 ,) , padImageSecondary = \amt img a -> let p = V.charFill a ' ' amt (V.imageHeight img) in V.horizCat [img, p] , loPrimary = eTopL , hiPrimary = eBottomL , loSecondary = eLeftL , hiSecondary = eRightL , locationFromPrimarySecondary = \r c -> Location (c, r) , splitLoPrimary = V.cropBottom , splitHiPrimary = \n img -> V.cropTop (V.imageHeight img-n) img , splitLoSecondary = V.cropRight , splitHiSecondary = \n img -> V.cropLeft (V.imageWidth img-n) img , lookupPrimary = BM.lookupRow , insertSecondary = BM.insertH } hBoxRenderer :: BoxRenderer n hBoxRenderer = BoxRenderer { contextPrimary = availWidthL , contextSecondary = availHeightL , imagePrimary = V.imageWidth , imageSecondary = V.imageHeight , limitPrimary = hLimit , limitSecondary = vLimit , primaryWidgetSize = hSize , concatenatePrimary = V.horizCat , concatenateSecondary = V.vertCat , locationFromOffset = Location . (, 0) , padImageSecondary = \amt img a -> let p = V.charFill a ' ' (V.imageWidth img) amt in V.vertCat [img, p] , loPrimary = eLeftL , hiPrimary = eRightL , loSecondary = eTopL , hiSecondary = eBottomL , locationFromPrimarySecondary = \c r -> Location (c, r) , splitLoPrimary = V.cropRight , splitHiPrimary = \n img -> V.cropLeft (V.imageWidth img-n) img , splitLoSecondary = V.cropBottom , splitHiSecondary = \n img -> V.cropTop (V.imageHeight img-n) img , lookupPrimary = BM.lookupCol , insertSecondary = BM.insertV } -- | 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 n -> [Widget n] -> Widget n renderBox br ws = 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 let availPrimary = c^.(contextPrimary br) availSecondary = c^.(contextSecondary br) renderHis _ prev [] = return $ DL.toList prev renderHis remainingPrimary prev ((i, prim):rest) = do result <- render $ limitPrimary br remainingPrimary $ limitSecondary br availSecondary $ cropToContext prim renderHis (remainingPrimary - (result^.imageL.(to $ imagePrimary br))) (DL.snoc prev (i, result)) rest renderedHis <- renderHis availPrimary DL.empty 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 rest = remainingPrimary - (primaryPerLow * length ls) secondaryPerLow = c^.(contextSecondary br) primaries = replicate rest (primaryPerLow + 1) <> replicate (length ls - rest) primaryPerLow 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) (imageRewrites, newBorders) = catAllBorders br (borders <$> allTranslatedResults) rewrittenImages = zipWith (rewriteImage br) imageRewrites allImages paddedImages = padImage <$> rewrittenImages cropResultToContext $ Result (concatenatePrimary br paddedImages) (concat $ cursors <$> allTranslatedResults) (concat $ visibilityRequests <$> allTranslatedResults) (concat $ extents <$> allTranslatedResults) newBorders catDynBorder :: Lens' (Edges BorderSegment) BorderSegment -> Lens' (Edges BorderSegment) BorderSegment -> DynBorder -> DynBorder -> Maybe DynBorder catDynBorder towardsA towardsB a b -- Currently, we check if the 'BorderStyle's are exactly the same. In the -- future, it might be nice to relax this restriction. For example, if a -- horizontal border is being rewritten to accommodate a neighboring -- vertical border, all we care about is that the two 'bsVertical's line up -- sanely. After all, if the horizontal border's 'bsVertical' is the same -- as the vertical one's, and the horizontal border's 'BorderStyle' is -- self-consistent, then it will look "right" to rewrite according to the -- horizontal border's 'BorderStyle'. | dbStyle a == dbStyle b && dbAttr a == dbAttr b && a ^. dbSegmentsL.towardsB.bsAcceptL && b ^. dbSegmentsL.towardsA.bsOfferL && not (a ^. dbSegmentsL.towardsB.bsDrawL) -- don't bother doing an update if we don't need to = Just (a & dbSegmentsL.towardsB.bsDrawL .~ True) | otherwise = Nothing catDynBorders :: Lens' (Edges BorderSegment) BorderSegment -> Lens' (Edges BorderSegment) BorderSegment -> I.IMap DynBorder -> I.IMap DynBorder -> I.IMap DynBorder catDynBorders towardsA towardsB am bm = I.mapMaybe id $ I.intersectionWith (catDynBorder towardsA towardsB) am bm -- | Given borders that should be placed next to each other (the first argument -- on the right or bottom, and the second argument on the left or top), compute -- new borders and the rewrites that should be done along the edges of the two -- images to keep the image in sync with the border information. -- -- The input borders are assumed to be disjoint. This property is not checked. catBorders :: (border ~ BM.BorderMap DynBorder, rewrite ~ I.IMap V.Image) => BoxRenderer n -> border -> border -> ((rewrite, rewrite), border) catBorders br r l = if lCoord + 1 == rCoord then ((lRe, rRe), lr') else ((I.empty, I.empty), lr) where lr = BM.expand (BM.coordinates r) l `BM.unsafeUnion` BM.expand (BM.coordinates l) r lr' = id . mergeIMap lCoord lIMap' . mergeIMap rCoord rIMap' $ lr lCoord = BM.coordinates l ^. hiPrimary br rCoord = BM.coordinates r ^. loPrimary br lIMap = lookupPrimary br lCoord l rIMap = lookupPrimary br rCoord r lIMap' = catDynBorders (loPrimary br) (hiPrimary br) lIMap rIMap rIMap' = catDynBorders (hiPrimary br) (loPrimary br) rIMap lIMap lRe = renderDynBorder <$> lIMap' rRe = renderDynBorder <$> rIMap' mergeIMap p imap bm = F.foldl' (\bm' (s,v) -> insertSecondary br (locationFromPrimarySecondary br p s) v bm') bm (I.unsafeToAscList imap) -- | Given a direction to concatenate borders in, and the border information -- itself (which list is assumed to be already shifted so that borders do not -- overlap and are strictly increasing in the primary direction), produce: a -- list of rewrites for the lo and hi directions of each border, respectively, -- and the borders describing the fully concatenated object. catAllBorders :: BoxRenderer n -> [BM.BorderMap DynBorder] -> ([(I.IMap V.Image, I.IMap V.Image)], BM.BorderMap DynBorder) catAllBorders _ [] = ([], BM.empty) catAllBorders br (bm:bms) = (zip ([I.empty]++los) (his++[I.empty]), bm') where (rewrites, bm') = runState (traverse (state . catBorders br) bms) bm (his, los) = unzip rewrites rewriteEdge :: (Int -> V.Image -> V.Image) -> (Int -> V.Image -> V.Image) -> ([V.Image] -> V.Image) -> I.IMap V.Image -> V.Image -> V.Image rewriteEdge splitLo splitHi combine = (combine .) . go . offsets 0 . I.unsafeToAscList where -- convert absolute positions into relative ones offsets _ [] = [] offsets n ((n', r):nrs) = (n'-n, r) : offsets (n'+I.len r) nrs go [] old = [old] -- TODO: might be nice to construct this image with fill rather than -- replicate+char go ((lo, I.Run len new):nrs) old = [splitLo lo old] ++ replicate len new ++ go nrs (splitHi (lo+len) old) rewriteImage :: BoxRenderer n -> (I.IMap V.Image, I.IMap V.Image) -> V.Image -> V.Image rewriteImage br (loRewrite, hiRewrite) old = rewriteHi . rewriteLo $ old where size = imagePrimary br old go = rewriteEdge (splitLoSecondary br) (splitHiSecondary br) (concatenateSecondary br) rewriteLo img | I.null loRewrite || size == 0 = img | otherwise = concatenatePrimary br [ go loRewrite (splitLoPrimary br 1 img) , splitHiPrimary br 1 img ] rewriteHi img | I.null hiRewrite || size == 0 = img | otherwise = concatenatePrimary br [ splitLoPrimary br (size-1) img , go hiRewrite (splitHiPrimary br (size-1) img) ] -- | Limit the space available to the specified widget to the specified -- number of columns. This is important for constraining the horizontal -- growth of otherwise-greedy widgets. This is non-greedy horizontally -- and defers to the limited widget vertically. hLimit :: Int -> Widget n -> Widget n hLimit w p = Widget Fixed (vSize p) $ withReaderT (availWidthL %~ (min w)) $ render $ cropToContext p -- | Limit the space available to the specified widget to the specified -- percentage of available width, as a value between 0 and 100 -- inclusive. Values outside the valid range will be clamped to the -- range endpoints. This is important for constraining the horizontal -- growth of otherwise-greedy widgets. This is non-greedy horizontally -- and defers to the limited widget vertically. hLimitPercent :: Int -> Widget n -> Widget n hLimitPercent w' p = Widget Fixed (vSize p) $ do let w = clamp 0 100 w' ctx <- getContext let usableWidth = ctx^.availWidthL widgetWidth = round (toRational usableWidth * (toRational w / 100)) withReaderT (availWidthL %~ (min widgetWidth)) $ render $ cropToContext p -- | Limit the space available to the specified widget to the specified -- number of rows. This is important for constraining the vertical -- growth of otherwise-greedy widgets. This is non-greedy vertically and -- defers to the limited widget horizontally. vLimit :: Int -> Widget n -> Widget n vLimit h p = Widget (hSize p) Fixed $ withReaderT (availHeightL %~ (min h)) $ render $ cropToContext p -- | Limit the space available to the specified widget to the specified -- percentage of available height, as a value between 0 and 100 -- inclusive. Values outside the valid range will be clamped to the -- range endpoints. This is important for constraining the vertical -- growth of otherwise-greedy widgets. This is non-greedy vertically and -- defers to the limited widget horizontally. vLimitPercent :: Int -> Widget n -> Widget n vLimitPercent h' p = Widget (hSize p) Fixed $ do let h = clamp 0 100 h' ctx <- getContext let usableHeight = ctx^.availHeightL widgetHeight = round (toRational usableHeight * (toRational h / 100)) withReaderT (availHeightL %~ (min widgetHeight)) $ render $ cropToContext p -- | Set the rendering context height and width for this widget. This -- is useful for relaxing the rendering size constraints on e.g. layer -- widgets where cropping to the screen size is undesirable. setAvailableSize :: (Int, Int) -> Widget n -> Widget n setAvailableSize (w, h) p = Widget Fixed Fixed $ withReaderT (\c -> c & availHeightL .~ h & availWidthL .~ w) $ render $ cropToContext p -- | When drawing the specified widget, set the attribute used for -- drawing to the one with the specified name. Note that the widget may -- make further changes to the active drawing attribute, so this only -- takes effect if nothing in the specified widget invokes 'withAttr' -- or otherwise changes the rendering context's attribute setup. If you -- 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'. -- -- For example: -- -- @ -- appAttrMap = attrMap (white `on` blue) [ ("highlight", fg yellow) -- , ("warning", bg magenta) -- ] -- -- renderA :: (String, String) -> [Widget n] -- renderA (a,b) = hBox [ str a -- , str " is " -- , withAttr "highlight" (str b) -- ] -- -- render1 = renderA ("Brick", "fun") -- render2 = withAttr "warning" render1 -- @ -- -- In the example above, @render1@ will show @Brick is fun@ where the -- first two words are white on a blue background and the last word -- is yellow on a blue background. However, @render2@ will show the -- first two words in white on magenta although the last word is still -- rendered in yellow on blue. withAttr :: AttrName -> Widget n -> Widget n withAttr an p = Widget (hSize p) (vSize p) $ withReaderT (ctxAttrNameL .~ an) (render p) -- | Update the attribute map while rendering the specified widget: set -- the map's default attribute to the one that we get by applying the -- specified function to the current map's default attribute. This is a -- variant of 'withDefAttr'; see the latter for more information. modifyDefAttr :: (V.Attr -> V.Attr) -> Widget n -> Widget n modifyDefAttr f p = Widget (hSize p) (vSize p) $ do c <- getContext withReaderT (ctxAttrMapL %~ (setDefaultAttr (f $ getDefaultAttr (c^.ctxAttrMapL)))) (render p) -- | Update the attribute map used while rendering the specified -- widget (and any sub-widgets): set its new *default* attribute -- (i.e. the attribute components that will be applied if not -- overridden by any more specific attributes) to the one that we get -- by looking up the specified attribute name in the map. -- -- For example: -- -- @ -- ... -- appAttrMap = attrMap (white `on` blue) [ ("highlight", fg yellow) -- , ("warning", bg magenta) -- , ("good", white `on` green) ] -- ... -- -- renderA :: (String, String) -> [Widget n] -- renderA (a,b) = hBox [ withAttr "good" (str a) -- , str " is " -- , withAttr "highlight" (str b) ] -- -- render1 = renderA ("Brick", "fun") -- render2 = withDefAttr "warning" render1 -- @ -- -- In the above, render1 will show "Brick is fun" where the first word -- is white on a green background, the middle word is white on a blue -- background, and the last word is yellow on a blue background. -- However, render2 will show the first word in the same colors but -- the middle word will be shown in whatever the terminal's normal -- foreground is on a magenta background, and the third word will be -- yellow on a magenta background. withDefAttr :: AttrName -> Widget n -> Widget n withDefAttr an p = Widget (hSize p) (vSize p) $ do c <- getContext withReaderT (ctxAttrMapL %~ (setDefaultAttr (attrMapLookup an (c^.ctxAttrMapL)))) (render p) -- | While rendering the specified widget, use a transformed version -- of the current attribute map. This is a very general function with -- broad capabilities: you probably want a more specific function such -- as 'withDefAttr' or 'withAttr'. updateAttrMap :: (AttrMap -> AttrMap) -> Widget n -> Widget n updateAttrMap f p = Widget (hSize p) (vSize p) $ 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. This means that the attribute lookups will -- behave as if they all used the name specified here. That further -- means that the resolved attribute will still inherit from its parent -- entry in the attribute map as would normally be the case. If you -- want to have more control over the resulting attribute, consider -- 'modifyDefAttr'. -- -- For example: -- -- @ -- ... -- appAttrMap = attrMap (white `on` blue) [ ("highlight", fg yellow) -- , ("notice", fg red) ] -- ... -- -- renderA :: (String, String) -> [Widget n] -- renderA (a,b) = hBox [ withAttr "highlight" (str a) -- , str " is " -- , withAttr "highlight" (str b) -- ] -- -- render1 = renderA ("Brick", "fun") -- render2 = forceAttr "notice" render1 -- @ -- -- In the above, render1 will show "Brick is fun" where the first and -- last words are yellow on a blue background and the middle word is -- white on a blue background. However, render2 will show all words -- in red on a blue background. In both versions, the middle word -- will be in white on a blue background. forceAttr :: AttrName -> Widget n -> Widget n forceAttr an p = Widget (hSize p) (vSize p) $ do c <- getContext withReaderT (ctxAttrMapL .~ (forceAttrMap (attrMapLookup an (c^.ctxAttrMapL)))) (render p) -- | Override the lookup of the attribute name 'targetName' to return -- the attribute value associated with 'fromName' when rendering the -- specified widget. -- -- For example: -- -- @ -- appAttrMap = attrMap (white `on` blue) [ ("highlight", fg yellow) -- , ("notice", fg red) -- ] -- -- renderA :: (String, String) -> [Widget n] -- renderA (a, b) = str a <+> str " is " <+> withAttr "highlight" (str b) -- -- render1 = withAttr "notice" $ renderA ("Brick", "fun") -- render2 = overrideAttr "highlight" "notice" render1 -- @ -- -- In the example above, @render1@ will show @Brick is fun@ where the -- first two words are red on a blue background, but @fun@ is yellow on -- a blue background. However, @render2@ will show all three words in -- red on a blue background. overrideAttr :: AttrName -> AttrName -> Widget n -> Widget n overrideAttr targetName fromName = updateAttrMap (mapAttrName fromName targetName) -- | Build a widget directly from a raw Vty image. raw :: V.Image -> Widget n raw img = Widget Fixed Fixed $ return $ emptyResult & imageL .~ img -- | Translate the specified widget by the specified offset amount. -- Defers to the translated widget for growth policy. translateBy :: Location -> Widget n -> Widget n translateBy off p = Widget (hSize p) (vSize p) $ do result <- render p return $ addResultOffset off $ result & imageL %~ (V.translate (off^.locationColumnL) (off^.locationRowL)) -- | Given a widget, translate it to position it relative to the -- upper-left coordinates of a reported extent with the specified -- positioning offset. If the specified name has no reported extent, -- this just draws the specified widget with no special positioning. -- -- This is only useful for positioning something in a higher layer -- relative to a reported extent in a lower layer. Any other use is -- likely to result in the specified widget being rendered as-is with -- no translation. This is because this function relies on information -- about lower layer renderings in order to work; using it with a -- resource name that wasn't rendered in a lower layer will result in -- this being equivalent to @id@. -- -- For example, if you have two layers @topLayer@ and @bottomLayer@, -- then a widget drawn in @bottomLayer@ with @reportExtent Foo@ can be -- used to relatively position a widget in @topLayer@ with @topLayer = -- relativeTo Foo ...@. relativeTo :: (Ord n) => n -> Location -> Widget n -> Widget n relativeTo n off w = Widget (hSize w) (vSize w) $ do mExt <- lookupReportedExtent n case mExt of Nothing -> render w Just ext -> render $ translateBy (extentUpperLeft ext <> off) w -- | Crop the specified widget on the left by the specified number of -- columns. Defers to the cropped widget for growth policy. cropLeftBy :: Int -> Widget n -> Widget n 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 to the specified size from the left. -- Defers to the cropped widget for growth policy. cropLeftTo :: Int -> Widget n -> Widget n cropLeftTo cols p = Widget (hSize p) (vSize p) $ do result <- render p let w = V.imageWidth $ result^.imageL amt = w - cols if w <= cols then return result else render $ cropLeftBy amt $ Widget Fixed Fixed $ return result -- | Crop the specified widget on the right by the specified number of -- columns. Defers to the cropped widget for growth policy. cropRightBy :: Int -> Widget n -> Widget n 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 to the specified size from the right. -- Defers to the cropped widget for growth policy. cropRightTo :: Int -> Widget n -> Widget n cropRightTo cols p = Widget (hSize p) (vSize p) $ do result <- render p let w = V.imageWidth $ result^.imageL amt = w - cols if w <= cols then return result else render $ cropRightBy amt $ Widget Fixed Fixed $ return result -- | Crop the specified widget on the top by the specified number of -- rows. Defers to the cropped widget for growth policy. cropTopBy :: Int -> Widget n -> Widget n 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 to the specified size from the top. -- Defers to the cropped widget for growth policy. cropTopTo :: Int -> Widget n -> Widget n cropTopTo rows p = Widget (hSize p) (vSize p) $ do result <- render p let h = V.imageHeight $ result^.imageL amt = h - rows if h <= rows then return result else render $ cropTopBy amt $ Widget Fixed Fixed $ return result -- | Crop the specified widget on the bottom by the specified number of -- rows. Defers to the cropped widget for growth policy. cropBottomBy :: Int -> Widget n -> Widget n 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 -- | Crop the specified widget to the specified size from the bottom. -- Defers to the cropped widget for growth policy. cropBottomTo :: Int -> Widget n -> Widget n cropBottomTo rows p = Widget (hSize p) (vSize p) $ do result <- render p let h = V.imageHeight $ result^.imageL amt = h - rows if h <= rows then return result else render $ cropBottomBy amt $ Widget Fixed Fixed $ return result -- | When rendering the specified widget, also register a cursor -- positioning request using the specified name and location. showCursor :: n -> Location -> Widget n -> Widget n showCursor n cloc p = Widget (hSize p) (vSize p) $ (cursorsL %~ (CursorLocation cloc (Just n) True:)) <$> (render p) -- | When rendering the specified widget, also register a cursor -- positioning request using the specified name and location. -- The cursor will only be positioned but not made visible. putCursor :: n -> Location -> Widget n -> Widget n putCursor n cloc p = Widget (hSize p) (vSize p) $ (cursorsL %~ (CursorLocation cloc (Just n) False:)) <$> (render p) hRelease :: Widget n -> Maybe (Widget n) hRelease p = case hSize p of Fixed -> Just $ Widget Greedy (vSize p) $ withReaderT (availWidthL .~ unrestricted) (render p) Greedy -> Nothing vRelease :: Widget n -> Maybe (Widget n) vRelease p = case vSize p of Fixed -> Just $ Widget (hSize p) Greedy $ withReaderT (availHeightL .~ unrestricted) (render p) Greedy -> Nothing -- | If the specified resource name has an entry in the rendering cache, -- use the rendered version from the cache. If not, render the specified -- widget and update the cache with the result. -- -- To ensure that mouse events are emitted correctly for cached widgets, -- in addition to the rendered widget, we also cache (the names of) any -- clickable extents that were rendered and restore that when utilizing -- the cache. -- -- See also 'invalidateCacheEntry'. cached :: (Ord n) => n -> Widget n -> Widget n cached n w = Widget (hSize w) (vSize w) $ do result <- cacheLookup n case result of Just (clickables, prevResult) -> do clickableNamesL %= (clickables ++) return prevResult Nothing -> do wResult <- render w clickables <- renderedClickables wResult cacheUpdate n (clickables, wResult & visibilityRequestsL .~ mempty) return wResult where -- Given the rendered result of a Widget, collect the list of "clickable" names -- from the extents that were in the result. renderedClickables :: (Ord n) => Result n -> RenderM n [n] renderedClickables renderResult = do allClickables <- use clickableNamesL return [extentName e | e <- renderResult^.extentsL, extentName e `elem` allClickables] cacheLookup :: (Ord n) => n -> RenderM n (Maybe ([n], Result n)) cacheLookup n = do cache <- lift $ gets (^.renderCacheL) return $ M.lookup n cache cacheUpdate :: Ord n => n -> ([n], Result n) -> RenderM n () cacheUpdate n r = lift $ modify (renderCacheL %~ M.insert n r) -- | Enable vertical scroll bars on all viewports in the specified -- widget and draw them with the specified orientation. withVScrollBars :: VScrollBarOrientation -> Widget n -> Widget n withVScrollBars orientation w = Widget (hSize w) (vSize w) $ withReaderT (ctxVScrollBarOrientationL .~ Just orientation) (render w) -- | Enable scroll bar handles on all vertical scroll bars in the -- specified widget. Handles appear at the ends of the scroll bar, -- representing the "handles" that are typically clickable in -- graphical UIs to move the scroll bar incrementally. Vertical -- scroll bars are also clickable if mouse mode is enabled and if -- 'withClickableVScrollBars' is used. -- -- This will only have an effect if 'withVScrollBars' is also called. withVScrollBarHandles :: Widget n -> Widget n withVScrollBarHandles w = Widget (hSize w) (vSize w) $ withReaderT (ctxVScrollBarShowHandlesL .~ True) (render w) -- | Render vertical viewport scroll bars in the specified widget with -- the specified renderer. This is only needed if you want to override -- the use of the default renderer, 'verticalScrollbarRenderer'. withVScrollBarRenderer :: ScrollbarRenderer n -> Widget n -> Widget n withVScrollBarRenderer r w = Widget (hSize w) (vSize w) $ withReaderT (ctxVScrollBarRendererL .~ Just r) (render w) -- | The default renderer for vertical viewport scroll bars. Override -- with 'withVScrollBarRenderer'. verticalScrollbarRenderer :: ScrollbarRenderer n verticalScrollbarRenderer = ScrollbarRenderer { renderScrollbar = fill '█' , renderScrollbarTrough = fill ' ' , renderScrollbarHandleBefore = str "^" , renderScrollbarHandleAfter = str "v" } -- | Enable horizontal scroll bars on all viewports in the specified -- widget and draw them with the specified orientation. withHScrollBars :: HScrollBarOrientation -> Widget n -> Widget n withHScrollBars orientation w = Widget (hSize w) (vSize w) $ withReaderT (ctxHScrollBarOrientationL .~ Just orientation) (render w) -- | Enable mouse click reporting on horizontal scroll bars in the -- specified widget. This must be used with 'withHScrollBars'. The -- provided function is used to build a resource name containing the -- scroll bar element clicked and the viewport name associated with the -- scroll bar. It is usually a data constructor of the @n@ type. withClickableHScrollBars :: (ClickableScrollbarElement -> n -> n) -> Widget n -> Widget n withClickableHScrollBars f w = Widget (hSize w) (vSize w) $ withReaderT (ctxHScrollBarClickableConstrL .~ Just f) (render w) -- | Enable mouse click reporting on vertical scroll bars in the -- specified widget. This must be used with 'withVScrollBars'. The -- provided function is used to build a resource name containing the -- scroll bar element clicked and the viewport name associated with the -- scroll bar. It is usually a data constructor of the @n@ type. withClickableVScrollBars :: (ClickableScrollbarElement -> n -> n) -> Widget n -> Widget n withClickableVScrollBars f w = Widget (hSize w) (vSize w) $ withReaderT (ctxVScrollBarClickableConstrL .~ Just f) (render w) -- | Enable scroll bar handles on all horizontal scroll bars in -- the specified widget. Handles appear at the ends of the scroll -- bar, representing the "handles" that are typically clickable in -- graphical UIs to move the scroll bar incrementally. Horizontal -- scroll bars are also clickable if mouse mode is enabled and if -- 'withClickableHScrollBars' is used. -- -- This will only have an effect if 'withHScrollBars' is also called. withHScrollBarHandles :: Widget n -> Widget n withHScrollBarHandles w = Widget (hSize w) (vSize w) $ withReaderT (ctxHScrollBarShowHandlesL .~ True) (render w) -- | Render horizontal viewport scroll bars in the specified widget with -- the specified renderer. This is only needed if you want to override -- the use of the default renderer, 'horizontalScrollbarRenderer'. withHScrollBarRenderer :: ScrollbarRenderer n -> Widget n -> Widget n withHScrollBarRenderer r w = Widget (hSize w) (vSize w) $ withReaderT (ctxHScrollBarRendererL .~ Just r) (render w) -- | The default renderer for horizontal viewport scroll bars. Override -- with 'withHScrollBarRenderer'. horizontalScrollbarRenderer :: ScrollbarRenderer n horizontalScrollbarRenderer = ScrollbarRenderer { renderScrollbar = fill '█' , renderScrollbarTrough = fill ' ' , renderScrollbarHandleBefore = str "<" , renderScrollbarHandleAfter = str ">" } -- | 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. -- -- This function can automatically render vertical and horizontal scroll -- bars if desired. To enable scroll bars, wrap your call to 'viewport' -- with a call to 'withVScrollBars' and/or 'withHScrollBars'. If you -- don't like the appearance of the resulting scroll bars (defaults: -- 'verticalScrollbarRenderer' and 'horizontalScrollbarRenderer'), -- you can customize how they are drawn by making your own -- 'ScrollbarRenderer' and using 'withVScrollBarRenderer' and/or -- 'withHScrollBarRenderer'. Note that when you enable scrollbars, the -- content of your viewport will lose one column of available space if -- vertical scroll bars are enabled and one row of available space if -- horizontal scroll bars are enabled. -- -- If a viewport receives more than one visibility request, then the -- visibility requests are merged with the inner visibility request -- taking preference. If a viewport receives more than one scrolling -- request from 'Brick.Main.EventM', all are honored in the order in -- which they are received. -- -- Some caution should be advised when using this function. The viewport -- renders its contents anew each time the viewport is drawn; in many -- cases this is prohibitively expensive, and viewports should not be -- used to display large contents for scrolling. This function is best -- used when the contents are not too large OR when the contents are -- large and render-cacheable. -- -- Also, be aware that there is a rich API for accessing viewport -- information from within the 'EventM' monad; check the docs for -- @Brick.Main@ to learn more about ways to get information about -- viewports after they're drawn. viewport :: (Ord n, Show n) => n -- ^ The name of the viewport (must be unique and stable for -- reliable behavior) -> ViewportType -- ^ The type of viewport (indicates the permitted scrolling -- direction) -> Widget n -- ^ The widget to be rendered in the scrollable viewport -> Widget n viewport vpname typ p = clickable vpname $ Widget Greedy Greedy $ do -- Obtain the scroll bar configuration. c <- getContext let vsOrientation = ctxVScrollBarOrientation c hsOrientation = ctxHScrollBarOrientation c vsRenderer = fromMaybe verticalScrollbarRenderer (ctxVScrollBarRenderer c) hsRenderer = fromMaybe horizontalScrollbarRenderer (ctxHScrollBarRenderer c) showVHandles = ctxVScrollBarShowHandles c showHHandles = ctxHScrollBarShowHandles c vsbClickableConstr = ctxVScrollBarClickableConstr c hsbClickableConstr = ctxHScrollBarClickableConstr c -- Observe the viewport name so we can detect multiple uses of the -- name. let observeName :: (Ord n, Show n) => n -> RenderM n () observeName n = do observed <- use observedNamesL case S.member n observed of False -> observedNamesL %= S.insert n True -> error $ "Error: while rendering the interface, the name " <> show n <> " was seen more than once. You should ensure that all of the widgets " <> "in each interface have unique name values. This means either " <> "using a different name type or adding constructors to your " <> "existing one and using those to name your widgets. For more " <> "information, see the \"Resource Names\" section of the Brick User Guide." observeName vpname -- Update the viewport size. let newVp = VP 0 0 newSize (0, 0) newSize = (newWidth, newHeight) newWidth = c^.availWidthL - vSBWidth newHeight = c^.availHeightL - hSBHeight vSBWidth = maybe 0 (const 1) vsOrientation hSBHeight = maybe 0 (const 1) hsOrientation doInsert (Just vp) = Just $ vp & vpSize .~ newSize doInsert Nothing = Just newVp lift $ modify (viewportMapL %~ (M.alter doInsert vpname)) -- Then render the viewport content widget 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). Also note that for viewports that -- only scroll in one direction, we apply a constraint in the -- non-scrolling direction in case a scroll bar is present. let release = case typ of Vertical -> vRelease . hLimit newWidth Horizontal -> hRelease . vLimit newHeight Both -> vRelease >=> 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 vpname) Horizontal -> error $ "tried to embed an infinite-width " <> "widget in horizontal viewport " <> (show vpname) Both -> error $ "tried to embed an infinite-width or " <> "infinite-height widget in 'Both' type " <> "viewport " <> (show vpname) initialResult <- render released -- If the rendering state includes any scrolling requests for this -- viewport, apply those reqs <- lift $ gets $ (^.rsScrollRequestsL) let relevantRequests = snd <$> filter (\(n, _) -> n == vpname) reqs when (not $ null relevantRequests) $ do mVp <- lift $ gets $ (^.viewportMapL.to (M.lookup vpname)) case mVp of Nothing -> error $ "BUG: viewport: viewport name " <> show vpname <> " absent from viewport map" Just vp -> do 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)) -- If the sub-rendering requested visibility, update the scroll -- state accordingly when (not $ null $ initialResult^.visibilityRequestsL) $ do mVp <- lift $ gets $ (^.viewportMapL.to (M.lookup vpname)) case mVp of Nothing -> error $ "BUG: viewport: viewport name " <> show vpname <> " absent from viewport map" Just vp -> do let rqs = initialResult^.visibilityRequestsL updateVp vp' rq = 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 $ foldl updateVp vp rqs)) -- If the size of the rendering changes enough to make the -- viewport offsets invalid, reset them mVp <- lift $ gets $ (^.viewportMapL.to (M.lookup vpname)) vp <- case mVp of Nothing -> error $ "BUG: viewport: viewport name " <> show vpname <> " absent from viewport map" Just v -> return v let img = initialResult^.imageL fixTop v = if V.imageHeight img < v^.vpSize._2 then v & vpTop .~ 0 else v fixLeft v = if V.imageWidth img < v^.vpSize._1 then v & vpLeft .~ 0 else v updateContentSize v = v & vpContentSize .~ (V.imageWidth img, V.imageHeight img) updateVp = updateContentSize . case typ of Both -> fixLeft . fixTop Horizontal -> fixLeft Vertical -> fixTop lift $ modify (viewportMapL %~ (M.insert vpname (updateVp vp))) -- Get the viewport state now that it has been updated. mVpFinal <- lift $ gets (M.lookup vpname . (^.viewportMapL)) vpFinal <- case mVpFinal of Nothing -> error $ "BUG: viewport: viewport name " <> show vpname <> " absent from viewport map" Just v -> return v -- Then perform a translation of the sub-rendering to fit into the -- viewport translated <- render $ translateBy (Location (-1 * vpFinal^.vpLeft, -1 * vpFinal^.vpTop)) $ Widget Fixed Fixed $ return initialResult -- If the vertical scroll bar is enabled, render the scroll bar -- area. let addVScrollbar = case vsOrientation of Nothing -> id Just orientation -> let sb = verticalScrollbar vsRenderer vpname vsbClickableConstr showVHandles (vpFinal^.vpSize._2) (vpFinal^.vpTop) (vpFinal^.vpContentSize._2) combine = case orientation of OnLeft -> (<+>) OnRight -> flip (<+>) in combine sb addHScrollbar = case hsOrientation of Nothing -> id Just orientation -> let sb = horizontalScrollbar hsRenderer vpname hsbClickableConstr showHHandles (vpFinal^.vpSize._1) (vpFinal^.vpLeft) (vpFinal^.vpContentSize._1) combine = case orientation of OnTop -> (<=>) OnBottom -> flip (<=>) in combine sb -- 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) -> do let spaceFill = V.charFill (c^.attrL) ' ' (c^.availWidthL) (c^.availHeightL) return $ translated & imageL .~ spaceFill & visibilityRequestsL .~ mempty & extentsL .~ mempty _ -> render $ addVScrollbar $ addHScrollbar $ vLimit (vpFinal^.vpSize._2) $ hLimit (vpFinal^.vpSize._1) $ padBottom Max $ padRight Max $ Widget Fixed Fixed $ return $ translated & visibilityRequestsL .~ mempty -- | The base attribute for scroll bars. scrollbarAttr :: AttrName scrollbarAttr = attrName "scrollbar" -- | The attribute for scroll bar troughs. This attribute is a -- specialization of @scrollbarAttr@. scrollbarTroughAttr :: AttrName scrollbarTroughAttr = scrollbarAttr <> attrName "trough" -- | The attribute for scroll bar handles. This attribute is a -- specialization of @scrollbarAttr@. scrollbarHandleAttr :: AttrName scrollbarHandleAttr = scrollbarAttr <> attrName "handle" maybeClick :: (Ord n) => n -> Maybe (ClickableScrollbarElement -> n -> n) -> ClickableScrollbarElement -> Widget n -> Widget n maybeClick _ Nothing _ w = w maybeClick n (Just f) el w = clickable (f el n) w -- | Build a vertical scroll bar using the specified render and -- settings. -- -- You probably don't want to use this directly; instead, -- use @viewport@, @withVScrollBars@, and, if needed, -- @withVScrollBarRenderer@. This is exposed so that if you want to -- render a scroll bar of your own, you can do so outside the @viewport@ -- context. verticalScrollbar :: (Ord n) => ScrollbarRenderer n -- ^ The renderer to use. -> n -- ^ The viewport name associated with this scroll -- bar. -> Maybe (ClickableScrollbarElement -> n -> n) -- ^ Constructor for clickable scroll bar element names. -> Bool -- ^ Whether to display handles. -> Int -- ^ The total viewport height in effect. -> Int -- ^ The viewport vertical scrolling offset in effect. -> Int -- ^ The total viewport content height. -> Widget n verticalScrollbar vsRenderer n constr False vpHeight vOffset contentHeight = verticalScrollbar' vsRenderer n constr vpHeight vOffset contentHeight verticalScrollbar vsRenderer n constr True vpHeight vOffset contentHeight = vBox [ maybeClick n constr SBHandleBefore $ hLimit 1 $ withDefAttr scrollbarHandleAttr $ renderScrollbarHandleBefore vsRenderer , verticalScrollbar' vsRenderer n constr vpHeight vOffset contentHeight , maybeClick n constr SBHandleAfter $ hLimit 1 $ withDefAttr scrollbarHandleAttr $ renderScrollbarHandleAfter vsRenderer ] verticalScrollbar' :: (Ord n) => ScrollbarRenderer n -- ^ The renderer to use. -> n -- ^ The viewport name associated with this scroll -- bar. -> Maybe (ClickableScrollbarElement -> n -> n) -- ^ Constructor for clickable scroll bar element names. -> Int -- ^ The total viewport height in effect. -> Int -- ^ The viewport vertical scrolling offset in effect. -> Int -- ^ The total viewport content height. -> Widget n verticalScrollbar' vsRenderer _ _ vpHeight _ 0 = hLimit 1 $ vLimit vpHeight $ renderScrollbarTrough vsRenderer verticalScrollbar' vsRenderer n constr vpHeight vOffset contentHeight = Widget Fixed Greedy $ do c <- getContext -- Get the proportion of the total content that is visible let visibleContentPercent :: Double visibleContentPercent = fromIntegral vpHeight / fromIntegral contentHeight ctxHeight = c^.availHeightL -- Then get the proportion of the scroll bar that -- should be filled in sbSize = min ctxHeight $ max 1 $ round $ visibleContentPercent * (fromIntegral ctxHeight) -- Then get the vertical offset of the scroll bar -- itself sbOffset = if vOffset == 0 then 0 else if vOffset == contentHeight - vpHeight then ctxHeight - sbSize else min (ctxHeight - sbSize - 1) $ max 1 $ round $ fromIntegral ctxHeight * (fromIntegral vOffset / fromIntegral contentHeight::Double) sbAbove = maybeClick n constr SBTroughBefore $ withDefAttr scrollbarTroughAttr $ vLimit sbOffset $ renderScrollbarTrough vsRenderer sbBelow = maybeClick n constr SBTroughAfter $ withDefAttr scrollbarTroughAttr $ vLimit (ctxHeight - (sbOffset + sbSize)) $ renderScrollbarTrough vsRenderer sbMiddle = maybeClick n constr SBBar $ withDefAttr scrollbarAttr $ vLimit sbSize $ renderScrollbar vsRenderer sb = hLimit 1 $ if sbSize == ctxHeight then vLimit sbSize $ renderScrollbarTrough vsRenderer else vBox [sbAbove, sbMiddle, sbBelow] render sb -- | Build a horizontal scroll bar using the specified render and -- settings. -- -- You probably don't want to use this directly; instead, use -- @viewport@, @withHScrollBars@, and, if needed, -- @withHScrollBarRenderer@. This is exposed so that if you want to -- render a scroll bar of your own, you can do so outside the @viewport@ -- context. horizontalScrollbar :: (Ord n) => ScrollbarRenderer n -- ^ The renderer to use. -> n -- ^ The viewport name associated with this scroll -- bar. -> Maybe (ClickableScrollbarElement -> n -> n) -- ^ Constructor for clickable scroll bar element -- names. -> Bool -- ^ Whether to show handles. -> Int -- ^ The total viewport width in effect. -> Int -- ^ The viewport horizontal scrolling offset in effect. -> Int -- ^ The total viewport content width. -> Widget n horizontalScrollbar hsRenderer n constr False vpWidth hOffset contentWidth = horizontalScrollbar' hsRenderer n constr vpWidth hOffset contentWidth horizontalScrollbar hsRenderer n constr True vpWidth hOffset contentWidth = hBox [ maybeClick n constr SBHandleBefore $ vLimit 1 $ withDefAttr scrollbarHandleAttr $ renderScrollbarHandleBefore hsRenderer , horizontalScrollbar' hsRenderer n constr vpWidth hOffset contentWidth , maybeClick n constr SBHandleAfter $ vLimit 1 $ withDefAttr scrollbarHandleAttr $ renderScrollbarHandleAfter hsRenderer ] horizontalScrollbar' :: (Ord n) => ScrollbarRenderer n -- ^ The renderer to use. -> n -- ^ The viewport name associated with this scroll -- bar. -> Maybe (ClickableScrollbarElement -> n -> n) -- ^ Constructor for clickable scroll bar element -- names. -> Int -- ^ The total viewport width in effect. -> Int -- ^ The viewport horizontal scrolling offset in effect. -> Int -- ^ The total viewport content width. -> Widget n horizontalScrollbar' hsRenderer _ _ vpWidth _ 0 = vLimit 1 $ hLimit vpWidth $ renderScrollbarTrough hsRenderer horizontalScrollbar' hsRenderer n constr vpWidth hOffset contentWidth = Widget Greedy Fixed $ do c <- getContext -- Get the proportion of the total content that is visible let visibleContentPercent :: Double visibleContentPercent = fromIntegral vpWidth / fromIntegral contentWidth ctxWidth = c^.availWidthL -- Then get the proportion of the scroll bar that -- should be filled in sbSize = min ctxWidth $ max 1 $ round $ visibleContentPercent * (fromIntegral ctxWidth) -- Then get the horizontal offset of the scroll bar itself sbOffset = if hOffset == 0 then 0 else if hOffset == contentWidth - vpWidth then ctxWidth - sbSize else min (ctxWidth - sbSize - 1) $ max 1 $ round $ fromIntegral ctxWidth * (fromIntegral hOffset / fromIntegral contentWidth::Double) sbLeft = maybeClick n constr SBTroughBefore $ withDefAttr scrollbarTroughAttr $ hLimit sbOffset $ renderScrollbarTrough hsRenderer sbRight = maybeClick n constr SBTroughAfter $ withDefAttr scrollbarTroughAttr $ hLimit (ctxWidth - (sbOffset + sbSize)) $ renderScrollbarTrough hsRenderer sbMiddle = maybeClick n constr SBBar $ withDefAttr scrollbarAttr $ hLimit sbSize $ renderScrollbar hsRenderer sb = vLimit 1 $ if sbSize == ctxWidth then hLimit sbSize $ renderScrollbarTrough hsRenderer else hBox [sbLeft, sbMiddle, sbRight] render sb -- | Given a name, obtain the viewport for that name by consulting the -- viewport map in the rendering monad. NOTE! Some care must be taken -- when calling this function, since it only returns useful values -- after the viewport in question has been rendered. If you call this -- function during rendering before a viewport has been rendered, you -- may get nothing or you may get a stale version of the viewport. This -- is because viewports are updated during rendering and the one you are -- interested in may not have been rendered yet. So if you want to use -- this, be sure you know what you are doing. unsafeLookupViewport :: (Ord n) => n -> RenderM n (Maybe Viewport) unsafeLookupViewport name = lift $ gets (M.lookup name . (^.viewportMapL)) 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 SetTop i -> i _ -> 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 SetLeft i -> i _ -> 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.locationRowL reqEnd = rq^.vrPositionL.locationRowL + rq^.vrSizeL._2 newVStart :: Int newVStart = if reqStart < vStartEndVisible then reqStart else vStartEndVisible vStartEndVisible = if reqEnd < curEnd then curStart else curStart + (reqEnd - curEnd) scrollToView Horizontal rq vp = vp & vpLeft .~ newHStart where curStart = vp^.vpLeft curEnd = curStart + vp^.vpSize._1 reqStart = rq^.vrPositionL.locationColumnL reqEnd = rq^.vrPositionL.locationColumnL + rq^.vrSizeL._1 newHStart :: Int newHStart = if reqStart < hStartEndVisible then reqStart else hStartEndVisible hStartEndVisible = if reqEnd < curEnd then curStart else curStart + (reqEnd - curEnd) -- | 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 n -> Widget n 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 n -> Widget n 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'. {-# NOINLINE (<+>) #-} (<+>) :: Widget n -- ^ Left -> Widget n -- ^ Right -> Widget n (<+>) 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'. {-# NOINLINE (<=>) #-} (<=>) :: Widget n -- ^ Top -> Widget n -- ^ Bottom -> Widget n (<=>) a b = vBox [a, b] {-# RULES "baseHbox" forall a b . a <+> b = hBox [a, b] "hBox2" forall as bs . hBox [hBox as, hBox bs] = hBox (as ++ bs) "hboxL" forall as b . hBox [hBox as, b] = hBox (as ++ [b]) "hboxR" forall a bs . hBox [a, hBox bs] = hBox (a : bs) "baseVbox" forall a b . a <=> b = vBox [a, b] "vBox2" forall as bs . vBox [vBox as, vBox bs] = vBox (as ++ bs) "vboxL" forall as b . vBox [vBox as, b] = vBox (as ++ [b]) "vboxR" forall a bs . vBox [a, vBox bs] = vBox (a : bs) #-}