mirror of
https://github.com/jtdaugherty/brick.git
synced 2024-11-26 09:06:56 +03:00
Get rid of scrolling wrappers, replace with viewport abstraction and primitives
This commit is contained in:
Jonathan Daugherty
parent
1a6cf1a660
commit
5aac657d2f
@ -24,7 +24,6 @@ library
|
||||
Brick.List
|
||||
Brick.Main
|
||||
Brick.Render
|
||||
Brick.Scroll
|
||||
Brick.Util
|
||||
other-modules:
|
||||
Brick.Render.Internal
|
||||
|
||||
@ -45,11 +45,11 @@ drawUI st = [a]
|
||||
vCenter $
|
||||
(hCenter $ borderWithLabel bs bsName $
|
||||
(hLimit 25 (
|
||||
(vLimit 1 $ useAttr (cyan `on` blue) $ withLens stEditor drawEditor)
|
||||
(vLimit 1 $ useAttr (cyan `on` blue) $ drawEditor (st^.stEditor))
|
||||
<<=
|
||||
hBorder bs
|
||||
=>>
|
||||
(vLimit 10 $ withLens stList drawList)
|
||||
(vLimit 10 $ drawList (st^.stList))
|
||||
)))
|
||||
<<=
|
||||
(vLimit 1 $ vPad ' ')
|
||||
|
||||
@ -1,17 +1,22 @@
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
module Brick.Core
|
||||
( Location(..)
|
||||
( Location(Location)
|
||||
, loc
|
||||
, CursorName(..)
|
||||
, CursorLocation(..)
|
||||
, HandleEvent(..)
|
||||
, SetSize(..)
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Lens
|
||||
import Data.Monoid (Monoid(..))
|
||||
import Graphics.Vty (Event, DisplayRegion)
|
||||
|
||||
newtype Location = Location (Int, Int)
|
||||
deriving Show
|
||||
data Location = Location { _loc :: (Int, Int)
|
||||
}
|
||||
deriving Show
|
||||
|
||||
makeLenses ''Location
|
||||
|
||||
origin :: Location
|
||||
origin = Location (0, 0)
|
||||
@ -31,6 +36,3 @@ data CursorLocation =
|
||||
|
||||
class HandleEvent a where
|
||||
handleEvent :: Event -> a -> a
|
||||
|
||||
class SetSize a where
|
||||
setSize :: DisplayRegion -> a -> a
|
||||
|
||||
@ -5,20 +5,17 @@ module Brick.Edit
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Default
|
||||
import Data.Monoid ((<>))
|
||||
import Graphics.Vty (Event(..), Key(..), Modifier(..))
|
||||
|
||||
import Brick.Core (Location(..), CursorName(..), HandleEvent(..), SetSize(..))
|
||||
import Brick.Core (Location(..), CursorName(..), HandleEvent(..))
|
||||
import Brick.Render
|
||||
import Brick.Scroll (HScroll, hScroll, scrollToView)
|
||||
import Brick.Util (clamp)
|
||||
|
||||
data Editor =
|
||||
Editor { editStr :: !String
|
||||
, editCursorPos :: !Int
|
||||
, editorCursorName :: !CursorName
|
||||
, editorScroll :: !HScroll
|
||||
}
|
||||
|
||||
instance HandleEvent Editor where
|
||||
@ -37,8 +34,7 @@ instance HandleEvent Editor where
|
||||
editSetCursorPos :: Int -> Editor -> Editor
|
||||
editSetCursorPos pos e =
|
||||
let newCP = clamp 0 (length $ editStr e) pos
|
||||
in e { editorScroll = scrollToView (newCP, 1) (editorScroll e)
|
||||
, editCursorPos = newCP
|
||||
in e { editCursorPos = newCP
|
||||
}
|
||||
|
||||
moveLeft :: Editor -> Editor
|
||||
@ -70,7 +66,6 @@ insertChar :: Char -> Editor -> Editor
|
||||
insertChar c theEdit =
|
||||
theEdit { editStr = s
|
||||
, editCursorPos = newCursorPos
|
||||
, editorScroll = scrollToView (newCursorPos, 1) (editorScroll theEdit)
|
||||
}
|
||||
where
|
||||
s = take n oldStr ++ [c] ++ drop n oldStr
|
||||
@ -78,17 +73,22 @@ insertChar c theEdit =
|
||||
newCursorPos = n + 1
|
||||
oldStr = editStr theEdit
|
||||
|
||||
instance SetSize Editor where
|
||||
setSize sz e =
|
||||
let updatedScroll = setSize sz $ editorScroll e
|
||||
in e { editorScroll = scrollToView (editCursorPos e, 1) updatedScroll
|
||||
}
|
||||
|
||||
editor :: CursorName -> String -> Editor
|
||||
editor cName s = Editor s (length s) cName def
|
||||
editor cName s = Editor s (length s) cName
|
||||
|
||||
drawEditor :: Render Editor
|
||||
drawEditor =
|
||||
saveSize setSize $ hScroll editorScroll $ usingState $ \e ->
|
||||
let cursorLoc = Location (editCursorPos e, 0)
|
||||
in showCursor (editorCursorName e) cursorLoc $ txt (editStr e) <<+ hPad ' '
|
||||
drawEditor :: Editor -> Render Editor
|
||||
drawEditor e =
|
||||
let cursorLoc = Location (cp, 0)
|
||||
cp = editCursorPos e
|
||||
s = editStr e
|
||||
beforeCursor = take cp s
|
||||
onCursor' = take 1 $ drop cp s
|
||||
onCursor = if null onCursor' then " " else onCursor'
|
||||
afterCursor = drop (cp + 1) s
|
||||
in viewport "edit" Horizontal $
|
||||
showCursor (editorCursorName e) cursorLoc $
|
||||
hBox [ ( txt beforeCursor, High )
|
||||
, ( visible $ txt onCursor, High )
|
||||
, ( txt afterCursor, High )
|
||||
, ( hPad ' ', Low )
|
||||
]
|
||||
|
||||
@ -11,24 +11,19 @@ module Brick.List
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative ((<$>), (<|>))
|
||||
import Data.Default
|
||||
import Data.Maybe (fromMaybe, catMaybes)
|
||||
import Graphics.Vty (Event(..), Key(..), DisplayRegion)
|
||||
import qualified Data.Map as M
|
||||
import Control.Applicative ((<$>))
|
||||
import Data.Maybe (fromMaybe)
|
||||
import Graphics.Vty (Event(..), Key(..))
|
||||
|
||||
import Brick.Core (HandleEvent(..), SetSize(..))
|
||||
import Brick.Core (HandleEvent(..))
|
||||
import Brick.Merge (maintainSel)
|
||||
import Brick.Render
|
||||
import Brick.Scroll (VScroll, vScroll, scrollToView)
|
||||
import Brick.Util (clamp, for)
|
||||
|
||||
data List e =
|
||||
List { listElements :: ![e]
|
||||
, listElementDraw :: Bool -> e -> Render (List e)
|
||||
, listSelected :: !(Maybe Int)
|
||||
, listScroll :: !VScroll
|
||||
, listElementHeights :: M.Map Int Int
|
||||
}
|
||||
|
||||
instance HandleEvent (List e) where
|
||||
@ -39,37 +34,25 @@ instance HandleEvent (List e) where
|
||||
EvKey KDown [] -> moveDown
|
||||
_ -> id
|
||||
|
||||
instance SetSize (List e) where
|
||||
setSize sz l =
|
||||
let updatedScroll = setSize sz $ listScroll l
|
||||
in makeSelectedVisible $ l { listScroll = updatedScroll }
|
||||
|
||||
list :: (Bool -> e -> Render (List e)) -> [e] -> List e
|
||||
list draw es =
|
||||
let selIndex = if null es then Nothing else Just 0
|
||||
in List es draw selIndex def M.empty
|
||||
in List es draw selIndex
|
||||
|
||||
listSetElementSize :: Int -> DisplayRegion -> List e -> List e
|
||||
listSetElementSize i sz l =
|
||||
l { listElementHeights = M.insert i (snd sz) (listElementHeights l)
|
||||
}
|
||||
|
||||
drawList :: Render (List e)
|
||||
drawList = theList
|
||||
drawList :: List e -> Render (List e)
|
||||
drawList l = theList
|
||||
where
|
||||
theList = saveSize setSize $
|
||||
vScroll listScroll $
|
||||
ensure makeSelectedVisible body
|
||||
theList = viewport "list" Vertical $ body
|
||||
|
||||
body = usingState $ \l -> do
|
||||
let es = listElements l
|
||||
drawn = for (zip [0..] es) $ \(i, e) ->
|
||||
let isSelected = Just i == listSelected l
|
||||
elemRender = listElementDraw l isSelected e
|
||||
in ( saveSize (listSetElementSize i) elemRender
|
||||
, High
|
||||
)
|
||||
(vBox drawn <<= vPad ' ') <<+ hPad ' '
|
||||
body = (vBox drawn <<= vPad ' ') <<+ hPad ' '
|
||||
es = listElements l
|
||||
drawn = for (zip [0..] es) $ \(i, e) ->
|
||||
let isSelected = Just i == listSelected l
|
||||
elemRender = listElementDraw l isSelected e
|
||||
makeVisible = if isSelected then visible else id
|
||||
in ( makeVisible elemRender
|
||||
, High
|
||||
)
|
||||
|
||||
listInsert :: Int -> e -> List e -> List e
|
||||
listInsert pos e l =
|
||||
@ -81,9 +64,9 @@ listInsert pos e l =
|
||||
then s + 1
|
||||
else s
|
||||
(front, back) = splitAt safePos es
|
||||
in makeSelectedVisible $ l { listSelected = Just newSel
|
||||
, listElements = front ++ (e : back)
|
||||
}
|
||||
in l { listSelected = Just newSel
|
||||
, listElements = front ++ (e : back)
|
||||
}
|
||||
|
||||
listRemove :: Int -> List e -> List e
|
||||
listRemove pos l | null es = l
|
||||
@ -96,11 +79,11 @@ listRemove pos l | null es = l
|
||||
else s
|
||||
(front, back) = splitAt pos es
|
||||
es' = front ++ tail back
|
||||
in makeSelectedVisible $ l { listSelected = if null es'
|
||||
then Nothing
|
||||
else Just newSel
|
||||
, listElements = es'
|
||||
}
|
||||
in l { listSelected = if null es'
|
||||
then Nothing
|
||||
else Just newSel
|
||||
, listElements = es'
|
||||
}
|
||||
where
|
||||
es = listElements l
|
||||
|
||||
@ -114,9 +97,9 @@ listReplace es' l | es' == es = l
|
||||
(_, True) -> Nothing
|
||||
(True, False) -> Just 0
|
||||
(False, False) -> Just (maintainSel es es' sel)
|
||||
in makeSelectedVisible $ l { listSelected = newSel
|
||||
, listElements = es'
|
||||
}
|
||||
in l { listSelected = newSel
|
||||
, listElements = es'
|
||||
}
|
||||
where
|
||||
es = listElements l
|
||||
|
||||
@ -129,29 +112,18 @@ moveDown = moveBy 1
|
||||
moveBy :: Int -> List e -> List e
|
||||
moveBy amt l =
|
||||
let newSel = clamp 0 (length (listElements l) - 1) <$> (amt +) <$> listSelected l
|
||||
in makeSelectedVisible $ l { listSelected = newSel }
|
||||
in l { listSelected = newSel }
|
||||
|
||||
moveTo :: Int -> List e -> List e
|
||||
moveTo pos l =
|
||||
let len = length (listElements l)
|
||||
newSel = clamp 0 (len - 1) $ if pos < 0 then (len - pos) else pos
|
||||
in makeSelectedVisible $ l { listSelected = if len > 0
|
||||
then Just newSel
|
||||
else Nothing
|
||||
}
|
||||
in l { listSelected = if len > 0
|
||||
then Just newSel
|
||||
else Nothing
|
||||
}
|
||||
|
||||
listSelectedElement :: List e -> Maybe (Int, e)
|
||||
listSelectedElement l = do
|
||||
sel <- listSelected l
|
||||
return (sel, listElements l !! sel)
|
||||
|
||||
makeSelectedVisible :: List e -> List e
|
||||
makeSelectedVisible l =
|
||||
let Just scrollTo = (listSelected l) <|> (Just 0)
|
||||
heights = listElementHeights l
|
||||
scrollTop = sum $ catMaybes $ (\k -> M.lookup k heights) <$> [0..scrollTo-1]
|
||||
scrollBottom = case M.lookup scrollTo heights of
|
||||
Nothing -> 1
|
||||
Just k -> k
|
||||
in l { listScroll = scrollToView (scrollTop, scrollBottom) (listScroll l)
|
||||
}
|
||||
|
||||
@ -20,6 +20,7 @@ import Control.Monad (when, forever)
|
||||
import Control.Concurrent (forkIO, Chan, newChan, readChan, writeChan)
|
||||
import Data.Default
|
||||
import Data.Maybe (listToMaybe)
|
||||
import qualified Data.Map as M
|
||||
import Graphics.Vty
|
||||
( Vty
|
||||
, Picture(..)
|
||||
@ -35,7 +36,7 @@ import Graphics.Vty
|
||||
import System.Exit (exitSuccess)
|
||||
|
||||
import Brick.Render (Render)
|
||||
import Brick.Render.Internal (renderFinal)
|
||||
import Brick.Render.Internal (renderFinal, RenderState(..))
|
||||
import Brick.Core (Location(..), CursorLocation(..))
|
||||
|
||||
data App a e =
|
||||
@ -61,11 +62,12 @@ simpleMain ls =
|
||||
in defaultMain app ()
|
||||
|
||||
defaultMainWithVty :: IO Vty -> App a Event -> a -> IO ()
|
||||
defaultMainWithVty buildVty app initialState = do
|
||||
defaultMainWithVty buildVty app initialAppState = do
|
||||
let initialRS = RS M.empty
|
||||
chan <- newChan
|
||||
withVty buildVty $ \vty -> do
|
||||
forkIO $ supplyVtyEvents vty id chan
|
||||
runVty vty chan app initialState
|
||||
runVty vty chan app initialAppState initialRS
|
||||
|
||||
isResizeEvent :: Event -> Bool
|
||||
isResizeEvent (EvResize _ _) = True
|
||||
@ -80,28 +82,29 @@ supplyVtyEvents vty mkEvent chan =
|
||||
when (isResizeEvent e) $ writeChan chan $ mkEvent e
|
||||
writeChan chan $ mkEvent e
|
||||
|
||||
runVty :: Vty -> Chan e -> App a e -> a -> IO ()
|
||||
runVty vty chan app appState = do
|
||||
state' <- renderApp vty app appState
|
||||
runVty :: Vty -> Chan e -> App a e -> a -> RenderState -> IO ()
|
||||
runVty vty chan app appState rs = do
|
||||
newRS <- renderApp vty app appState rs
|
||||
e <- readChan chan
|
||||
appHandleEvent app e state' >>= runVty vty chan app
|
||||
newAppState <- appHandleEvent app e appState
|
||||
runVty vty chan app newAppState newRS
|
||||
|
||||
withVty :: IO Vty -> (Vty -> IO a) -> IO a
|
||||
withVty buildVty useVty = do
|
||||
vty <- buildVty
|
||||
useVty vty `finally` shutdown vty
|
||||
|
||||
renderApp :: Vty -> App a e -> a -> IO a
|
||||
renderApp vty app appState = do
|
||||
renderApp :: Vty -> App a e -> a -> RenderState -> IO RenderState
|
||||
renderApp vty app appState rs = do
|
||||
sz <- displayBounds $ outputIface vty
|
||||
let (newAppState, pic, theCursor) = renderFinal (appDraw app appState) sz (appChooseCursor app appState) appState
|
||||
let (newRS, pic, theCursor) = renderFinal (appDraw app appState) sz (appChooseCursor app appState) rs
|
||||
picWithCursor = case theCursor of
|
||||
Nothing -> pic { picCursor = NoCursor }
|
||||
Just (CursorLocation (Location (w, h)) _) -> pic { picCursor = Cursor w h }
|
||||
|
||||
update vty picWithCursor
|
||||
|
||||
return newAppState
|
||||
return newRS
|
||||
|
||||
neverShowCursor :: a -> [CursorLocation] -> Maybe CursorLocation
|
||||
neverShowCursor = const $ const Nothing
|
||||
|
||||
@ -3,6 +3,7 @@ module Brick.Render
|
||||
, Priority(..)
|
||||
, (=>>), (<<=), (<=>)
|
||||
, (+>>), (<<+), (<+>)
|
||||
, ViewportType(..)
|
||||
|
||||
, txt
|
||||
, hPad
|
||||
@ -21,12 +22,10 @@ module Brick.Render
|
||||
, cropTopBy
|
||||
, cropBottomBy
|
||||
, showCursor
|
||||
, saveSize
|
||||
, hRelease
|
||||
, vRelease
|
||||
, withLens
|
||||
, usingState
|
||||
, ensure
|
||||
, viewport
|
||||
, visible
|
||||
)
|
||||
where
|
||||
|
||||
|
||||
@ -8,10 +8,14 @@ module Brick.Render.Internal
|
||||
, image
|
||||
, cursors
|
||||
|
||||
, RenderState(..)
|
||||
|
||||
, Priority(..)
|
||||
, renderFinal
|
||||
, Render
|
||||
|
||||
, ViewportType(..)
|
||||
|
||||
, txt
|
||||
, hPad
|
||||
, vPad
|
||||
@ -29,33 +33,52 @@ module Brick.Render.Internal
|
||||
, cropTopBy
|
||||
, cropBottomBy
|
||||
, showCursor
|
||||
, saveSize
|
||||
, hRelease
|
||||
, vRelease
|
||||
, withLens
|
||||
, usingState
|
||||
, ensure
|
||||
, viewport
|
||||
, visible
|
||||
)
|
||||
where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Lens (makeLenses, (^.), (.=), (.~), (&), (%~), to, _2)
|
||||
import Control.Lens (makeLenses, (^.), (.~), (&), (%~), to, _1, _2)
|
||||
import Control.Monad (when)
|
||||
import Control.Monad.Trans.State.Lazy
|
||||
import Control.Monad.Trans.Reader
|
||||
import Control.Monad.Trans.Class (lift)
|
||||
import Data.Default
|
||||
import Data.Monoid ((<>), mempty)
|
||||
import qualified Data.Map as M
|
||||
import qualified Data.Function as DF
|
||||
import Data.List (sortBy)
|
||||
import Control.Lens (Lens')
|
||||
import Data.String (IsString(..))
|
||||
import qualified Graphics.Vty as V
|
||||
|
||||
import Brick.Core (Location(..), CursorLocation(..), CursorName(..))
|
||||
import Brick.Core (Location(..), loc, CursorLocation(..), CursorName(..))
|
||||
import Brick.Util (clOffset, for)
|
||||
|
||||
import qualified Debug.Trace as D
|
||||
|
||||
data VisibilityRequest =
|
||||
VR { _vrPosition :: Location
|
||||
, _vrSize :: V.DisplayRegion
|
||||
}
|
||||
deriving Show
|
||||
|
||||
data ViewportType = Vertical | Horizontal 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
|
||||
|
||||
@ -65,33 +88,45 @@ data Context =
|
||||
, _h :: Int
|
||||
}
|
||||
|
||||
makeLenses ''Result
|
||||
makeLenses ''Context
|
||||
|
||||
data Priority = High | Low
|
||||
deriving (Show, Eq)
|
||||
|
||||
type Render a = ReaderT Context (State a) Result
|
||||
type Render a = ReaderT Context (State RenderState) Result
|
||||
|
||||
data RenderState =
|
||||
RS { _viewportMap :: M.Map String Viewport
|
||||
}
|
||||
|
||||
makeLenses ''Result
|
||||
makeLenses ''Context
|
||||
makeLenses ''VisibilityRequest
|
||||
makeLenses ''Viewport
|
||||
makeLenses ''RenderState
|
||||
|
||||
instance IsString (Render a) where
|
||||
fromString = txt
|
||||
|
||||
instance Default Result where
|
||||
def = Result V.emptyImage []
|
||||
def = Result V.emptyImage [] []
|
||||
|
||||
renderFinal :: [Render a]
|
||||
-> V.DisplayRegion
|
||||
-> ([CursorLocation] -> Maybe CursorLocation)
|
||||
-> a
|
||||
-> (a, V.Picture, Maybe CursorLocation)
|
||||
renderFinal layerRenders sz chooseCursor st = (newState, pic, theCursor)
|
||||
-> RenderState
|
||||
-> (RenderState, V.Picture, Maybe CursorLocation)
|
||||
renderFinal layerRenders sz chooseCursor rs = (newRS, pic, theCursor)
|
||||
where
|
||||
(layerResults, newState) = flip runState st $ sequence $ (\p -> runReaderT p ctx) <$> layerRenders
|
||||
(layerResults, newRS) = flip runState rs $ sequence $ (\p -> runReaderT p ctx) <$> layerRenders
|
||||
ctx = Context V.defAttr (fst sz) (snd sz)
|
||||
pic = V.picForLayers $ uncurry V.resize sz <$> (^.image) <$> layerResults
|
||||
layerCursors = (^.cursors) <$> layerResults
|
||||
theCursor = chooseCursor $ concat layerCursors
|
||||
|
||||
addVisibilityOffset :: Location -> Result -> Result
|
||||
addVisibilityOffset off r =
|
||||
let addOffset vrs = (& vrPosition %~ (off <>)) <$> vrs
|
||||
in r & visibilityRequests %~ addOffset
|
||||
|
||||
addCursorOffset :: Location -> Result -> Result
|
||||
addCursorOffset off r =
|
||||
let onlyVisible = filter isVisible
|
||||
@ -155,12 +190,16 @@ hBox pairs = do
|
||||
allResults = snd <$> rendered
|
||||
allImages = (^.image) <$> allResults
|
||||
allWidths = V.imageWidth <$> allImages
|
||||
allTranslatedVRs = for (zip [0..] allResults) $ \(i, result) ->
|
||||
let off = Location (offWidth, 0)
|
||||
offWidth = sum $ take i allWidths
|
||||
in (addVisibilityOffset off result)^.visibilityRequests
|
||||
allTranslatedCursors = for (zip [0..] allResults) $ \(i, result) ->
|
||||
let off = Location (offWidth, 0)
|
||||
offWidth = sum $ take i allWidths
|
||||
in (addCursorOffset off result)^.cursors
|
||||
|
||||
return $ Result (V.horizCat allImages) (concat allTranslatedCursors)
|
||||
return $ Result (V.horizCat allImages) (concat allTranslatedCursors) (concat allTranslatedVRs)
|
||||
|
||||
vBox :: [(Render a, Priority)] -> Render a
|
||||
vBox pairs = do
|
||||
@ -189,18 +228,22 @@ vBox pairs = do
|
||||
allResults = snd <$> rendered
|
||||
allImages = (^.image) <$> allResults
|
||||
allHeights = V.imageHeight <$> allImages
|
||||
allTranslatedVRs = for (zip [0..] allResults) $ \(i, result) ->
|
||||
let off = Location (0, offHeight)
|
||||
offHeight = sum $ take i allHeights
|
||||
in (addVisibilityOffset off result)^.visibilityRequests
|
||||
allTranslatedCursors = for (zip [0..] allResults) $ \(i, result) ->
|
||||
let off = Location (0, offHeight)
|
||||
offHeight = sum $ take i allHeights
|
||||
in (addCursorOffset off result)^.cursors
|
||||
|
||||
return $ Result (V.vertCat allImages) (concat allTranslatedCursors)
|
||||
return $ Result (V.vertCat allImages) (concat allTranslatedCursors) (concat allTranslatedVRs)
|
||||
|
||||
-- xxx crop cursors
|
||||
-- xxx crop cursors and VRs
|
||||
hLimit :: Int -> Render a -> Render a
|
||||
hLimit w' = withReaderT (& w .~ w')
|
||||
|
||||
-- xxx crop cursors
|
||||
-- xxx crop cursors and VRs
|
||||
vLimit :: Int -> Render a -> Render a
|
||||
vLimit h' = withReaderT (& h .~ h')
|
||||
|
||||
@ -219,6 +262,7 @@ translate (Location (tw,th)) p = do
|
||||
result <- p
|
||||
c <- ask
|
||||
return $ addCursorOffset (Location (tw, th)) $
|
||||
addVisibilityOffset (Location (tw, th)) $
|
||||
result & image %~ (V.crop (c^.w) (c^.h) . V.translate tw th)
|
||||
|
||||
cropLeftBy :: Int -> Render a -> Render a
|
||||
@ -226,14 +270,16 @@ cropLeftBy cols p = do
|
||||
result <- p
|
||||
let amt = V.imageWidth (result^.image) - cols
|
||||
cropped img = if amt < 0 then V.emptyImage else V.cropLeft amt img
|
||||
return $ addCursorOffset (Location (-1 * cols, 0)) $ result & image %~ cropped
|
||||
return $ addCursorOffset (Location (-1 * cols, 0)) $
|
||||
addVisibilityOffset (Location (-1 * cols, 0)) $
|
||||
result & image %~ cropped
|
||||
|
||||
cropRightBy :: Int -> Render a -> Render a
|
||||
cropRightBy cols p = do
|
||||
result <- p
|
||||
let amt = V.imageWidth (result^.image) - cols
|
||||
cropped img = if amt < 0 then V.emptyImage else V.cropRight amt img
|
||||
-- xxx cursors
|
||||
-- xxx cursors / VRs
|
||||
return $ result & image %~ cropped
|
||||
|
||||
cropTopBy :: Int -> Render a -> Render a
|
||||
@ -241,28 +287,22 @@ cropTopBy rows p = do
|
||||
result <- p
|
||||
let amt = V.imageHeight (result^.image) - rows
|
||||
cropped img = if amt < 0 then V.emptyImage else V.cropTop amt img
|
||||
return $ addCursorOffset (Location (0, -1 * rows)) $ result & image %~ cropped
|
||||
return $ addCursorOffset (Location (0, -1 * rows)) $
|
||||
addVisibilityOffset (Location (0, -1 * rows)) $
|
||||
result & image %~ cropped
|
||||
|
||||
cropBottomBy :: Int -> Render a -> Render a
|
||||
cropBottomBy rows p = do
|
||||
result <- p
|
||||
let amt = V.imageHeight (result^.image) - rows
|
||||
cropped img = if amt < 0 then V.emptyImage else V.cropBottom amt img
|
||||
-- xxx crop cursors
|
||||
-- xxx crop cursors / VRs
|
||||
return $ result & image %~ cropped
|
||||
|
||||
showCursor :: CursorName -> Location -> Render a -> Render a
|
||||
showCursor n loc p = do
|
||||
showCursor n cloc p = do
|
||||
result <- p
|
||||
return $ result & cursors %~ (CursorLocation loc (Just n):)
|
||||
|
||||
saveSize :: (V.DisplayRegion -> a -> a) -> Render a -> Render a
|
||||
saveSize sizeSetter p = do
|
||||
result <- p
|
||||
let img = result^.image
|
||||
imgSz = (V.imageWidth img, V.imageHeight img)
|
||||
lift $ modify (sizeSetter imgSz)
|
||||
return result
|
||||
return $ result & cursors %~ (CursorLocation cloc (Just n):)
|
||||
|
||||
hRelease :: Render a -> Render a
|
||||
hRelease = withReaderT (& w .~ unrestricted) --- NB
|
||||
@ -270,20 +310,79 @@ hRelease = withReaderT (& w .~ unrestricted) --- NB
|
||||
vRelease :: Render a -> Render a
|
||||
vRelease = withReaderT (& h .~ unrestricted) --- NB
|
||||
|
||||
withLens :: (Lens' a b) -> Render b -> Render a
|
||||
withLens target p = do
|
||||
outerState <- lift get
|
||||
let oldInnerState = outerState^.target
|
||||
viewport :: String -> ViewportType -> Render a -> Render a
|
||||
viewport vpname typ p = do
|
||||
-- First, update the viewport size.
|
||||
c <- ask
|
||||
let (result, newInnerState) = runState (runReaderT p c) oldInnerState
|
||||
target .= newInnerState
|
||||
return result
|
||||
let newVp = VP 0 0 newSize
|
||||
newSize = (c^.w, c^.h)
|
||||
doInsert (Just vp) = Just $ vp & vpSize .~ newSize
|
||||
doInsert Nothing = Just newVp
|
||||
|
||||
usingState :: (a -> Render a) -> Render a
|
||||
usingState f = (lift get) >>= (\a -> f a)
|
||||
lift $ modify (& viewportMap %~ (M.alter doInsert vpname))
|
||||
|
||||
ensure :: (a -> a) -> Render a -> Render a
|
||||
ensure f p = do
|
||||
-- Then render the sub-rendering with the rendering layout
|
||||
-- constraint released
|
||||
let release = case typ of
|
||||
Vertical -> vRelease
|
||||
Horizontal -> hRelease
|
||||
|
||||
initialResult <- release p
|
||||
|
||||
-- If the sub-rendering requested visibility, update the scroll
|
||||
-- state accordingly
|
||||
when (not $ null $ initialResult^.visibilityRequests) $ do
|
||||
Just vp <- lift $ gets $ (^.viewportMap.to (M.lookup vpname))
|
||||
-- XXX for now, just permit one request but we could permit
|
||||
-- many by computing the bounding rectangle over the submitted
|
||||
-- requests.
|
||||
let [rq] = initialResult^.visibilityRequests
|
||||
updatedVp = scrollToView typ rq vp
|
||||
lift $ D.trace (show (vpname, rq, newVp)) $ modify (& viewportMap %~ (M.insert vpname updatedVp))
|
||||
|
||||
-- Get the viewport state now that it has been updated.
|
||||
Just vp <- lift $ gets (M.lookup vpname . (^.viewportMap))
|
||||
|
||||
-- Then perform a translation of the sub-rendering to fit into the
|
||||
-- viewport
|
||||
translated <- translate (Location (-1 * vp^.vpLeft, -1 * vp^.vpTop)) $ return initialResult
|
||||
|
||||
-- Return the translated result with the visibility requests
|
||||
-- discarded
|
||||
return $ translated & visibilityRequests .~ mempty
|
||||
|
||||
scrollToView :: ViewportType -> VisibilityRequest -> Viewport -> Viewport
|
||||
scrollToView typ rq vp = vp & theStart .~ newStart
|
||||
where
|
||||
theStart :: Lens' Viewport Int
|
||||
theStart = case typ of
|
||||
Horizontal -> vpLeft
|
||||
Vertical -> vpTop
|
||||
theSize = case typ of
|
||||
Horizontal -> vpSize._1
|
||||
Vertical -> vpSize._2
|
||||
reqStart = case typ of
|
||||
Horizontal -> rq^.vrPosition.loc._1
|
||||
Vertical -> rq^.vrPosition.loc._2
|
||||
reqSize = case typ of
|
||||
Horizontal -> rq^.vrSize._1
|
||||
Vertical -> rq^.vrSize._2
|
||||
|
||||
curStart = vp^.theStart
|
||||
curEnd = curStart + vp^.theSize
|
||||
|
||||
reqEnd = reqStart + reqSize
|
||||
newStart :: Int
|
||||
newStart = if reqStart < curStart
|
||||
then reqStart
|
||||
else if reqStart > curEnd || reqEnd > curEnd
|
||||
then reqEnd - vp^.theSize
|
||||
else curStart
|
||||
|
||||
visible :: Render a -> Render a
|
||||
visible p = do
|
||||
result <- p
|
||||
lift $ modify f
|
||||
return result
|
||||
let imageSize = ( result^.image.to V.imageWidth
|
||||
, result^.image.to V.imageHeight
|
||||
)
|
||||
return $ result & visibilityRequests %~ (VR (Location (0, 0)) imageSize :)
|
||||
|
||||
@ -1,81 +0,0 @@
|
||||
module Brick.Scroll
|
||||
( Scrollable(..)
|
||||
|
||||
, VScroll
|
||||
, vScroll
|
||||
|
||||
, HScroll
|
||||
, hScroll
|
||||
|
||||
, scrollToView
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Default
|
||||
|
||||
import Brick.Core (SetSize(..), Location(..))
|
||||
import Brick.Render
|
||||
|
||||
data HScroll =
|
||||
HScroll { scrollLeft :: !Int
|
||||
, scrollWidth :: !Int
|
||||
}
|
||||
|
||||
data VScroll =
|
||||
VScroll { scrollTop :: !Int
|
||||
, scrollHeight :: !Int
|
||||
}
|
||||
|
||||
instance SetSize VScroll where
|
||||
setSize (_, h) vs = vs { scrollHeight = h }
|
||||
|
||||
instance SetSize HScroll where
|
||||
setSize (w, _) hs = hs { scrollWidth = w }
|
||||
|
||||
instance Default HScroll where
|
||||
def = HScroll 0 0
|
||||
|
||||
instance Default VScroll where
|
||||
def = VScroll 0 0
|
||||
|
||||
class Scrollable a where
|
||||
setScrollStart :: Int -> a -> a
|
||||
scrollStart :: a -> Int
|
||||
scrollSize :: a -> Int
|
||||
|
||||
instance Scrollable HScroll where
|
||||
setScrollStart col hs = hs { scrollLeft = col }
|
||||
scrollStart = scrollLeft
|
||||
scrollSize = scrollWidth
|
||||
|
||||
instance Scrollable VScroll where
|
||||
setScrollStart row vs = vs { scrollTop = row }
|
||||
scrollStart = scrollTop
|
||||
scrollSize = scrollHeight
|
||||
|
||||
vScroll :: (a -> VScroll) -> Render a -> Render a
|
||||
vScroll f p = do
|
||||
result <- vRelease p
|
||||
usingState $ \s ->
|
||||
let vs = f s
|
||||
in translate (Location (0, -1 * scrollStart vs)) $ return result
|
||||
|
||||
hScroll :: (a -> HScroll) -> Render a -> Render a
|
||||
hScroll f p = do
|
||||
result <- hRelease p
|
||||
usingState $ \s ->
|
||||
let hs = f s
|
||||
in translate (Location (-1 * scrollStart hs, 0)) $ return result
|
||||
|
||||
scrollToView :: (Scrollable a) => (Int, Int) -> a -> a
|
||||
scrollToView (reqStart, reqSize) s =
|
||||
setScrollStart newStart s
|
||||
where
|
||||
curEnd = curStart + scrollSize s
|
||||
curStart = scrollStart s
|
||||
reqEnd = reqStart + reqSize
|
||||
newStart = if reqStart < curStart
|
||||
then reqStart
|
||||
else if reqStart > curEnd || reqEnd > curEnd
|
||||
then reqEnd - scrollSize s
|
||||
else curStart
|
||||
Loading…
Reference in New Issue
Block a user