From 5aac657d2f1e542b1473cb6193212ee5451453f6 Mon Sep 17 00:00:00 2001 From: Jonathan Daugherty Date: Sun, 7 Jun 2015 17:33:34 -0700 Subject: [PATCH] Get rid of scrolling wrappers, replace with viewport abstraction and primitives --- brick.cabal | 1 - programs/Main.hs | 4 +- src/Brick/Core.hs | 16 +-- src/Brick/Edit.hs | 38 +++---- src/Brick/List.hs | 94 ++++++----------- src/Brick/Main.hs | 25 +++-- src/Brick/Render.hs | 7 +- src/Brick/Render/Internal.hs | 191 ++++++++++++++++++++++++++--------- src/Brick/Scroll.hs | 81 --------------- 9 files changed, 225 insertions(+), 232 deletions(-) delete mode 100644 src/Brick/Scroll.hs diff --git a/brick.cabal b/brick.cabal index eacc52e..b5f30b9 100644 --- a/brick.cabal +++ b/brick.cabal @@ -24,7 +24,6 @@ library Brick.List Brick.Main Brick.Render - Brick.Scroll Brick.Util other-modules: Brick.Render.Internal diff --git a/programs/Main.hs b/programs/Main.hs index 2064092..d1a4412 100644 --- a/programs/Main.hs +++ b/programs/Main.hs @@ -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 ' ') diff --git a/src/Brick/Core.hs b/src/Brick/Core.hs index ad2cab9..cddbd78 100644 --- a/src/Brick/Core.hs +++ b/src/Brick/Core.hs @@ -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 diff --git a/src/Brick/Edit.hs b/src/Brick/Edit.hs index 903a00f..a8da649 100644 --- a/src/Brick/Edit.hs +++ b/src/Brick/Edit.hs @@ -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 ) + ] diff --git a/src/Brick/List.hs b/src/Brick/List.hs index a9c12cc..1826a1f 100644 --- a/src/Brick/List.hs +++ b/src/Brick/List.hs @@ -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) - } diff --git a/src/Brick/Main.hs b/src/Brick/Main.hs index 1572949..a3929dc 100644 --- a/src/Brick/Main.hs +++ b/src/Brick/Main.hs @@ -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 diff --git a/src/Brick/Render.hs b/src/Brick/Render.hs index bfb10e3..4f28240 100644 --- a/src/Brick/Render.hs +++ b/src/Brick/Render.hs @@ -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 diff --git a/src/Brick/Render/Internal.hs b/src/Brick/Render/Internal.hs index b7933f6..9526d73 100644 --- a/src/Brick/Render/Internal.hs +++ b/src/Brick/Render/Internal.hs @@ -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 :) diff --git a/src/Brick/Scroll.hs b/src/Brick/Scroll.hs deleted file mode 100644 index 1c20b84..0000000 --- a/src/Brick/Scroll.hs +++ /dev/null @@ -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