Add support for viewports that scroll both vertically and horizontally, add visibility demo

TODO.txt

@@ -6,7 +6,6 @@ consistent with other lenses
 Features:
 - Text wrapping (with markup)
 - Deal with multi-column characters everywhere
-- Viewports that support both horizontal and vertical scrolling
 
 Open issues:
 - Centering and other operations pad widgets with fills with interacts

brick.cabal

@@ -82,6 +82,20 @@ executable brick
                        lens,
                        text
 
+executable brick-visibility-demo
+  if !flag(demos)
+    Buildable: False
+  hs-source-dirs:      programs
+  ghc-options:         -threaded -Wall -fno-warn-unused-do-bind -O3
+  default-language:    Haskell2010
+  main-is:             VisibilityDemo.hs
+  build-depends:       base,
+                       brick,
+                       vty >= 5.2.9,
+                       data-default,
+                       text,
+                       lens
+
 executable brick-viewport-scroll-demo
   if !flag(demos)
     Buildable: False

programs/ViewportScrollDemo.hs

@@ -14,7 +14,7 @@ import qualified Brick.Widgets.Center as C
 import qualified Brick.Widgets.Border as B
 import Brick.Widgets.Core
   ( Widget
-  , ViewportType(Horizontal, Vertical)
+  , ViewportType(Horizontal, Vertical, Both)
   , hLimit
   , vLimit
   , hBox
@@ -29,21 +29,25 @@ vp1Name = "demo1"
 vp2Name :: T.Name
 vp2Name = "demo2"
 
+vp3Name :: T.Name
+vp3Name = "demo3"
+
 drawUi :: () -> [Widget]
 drawUi = const [ui]
     where
-        ui = C.center $
-             hLimit 60 $
-             vLimit 20 $
-             B.border $
-             hBox [ viewport vp1Name Vertical $
-                    vBox $ "Press up and down arrow keys" :
-                           "to scroll this viewport." :
-                           (str <$> [ "Line " <> (show i) | i <- [3..50::Int] ])
-                  , B.vBorder
-                  , viewport vp2Name Horizontal
-                    "Press left and right arrow keys to scroll this viewport."
-                  ]
+        ui = C.center $ B.border $ hLimit 60 $ vLimit 21 $
+             vBox [ pair, B.hBorder, singleton ]
+        singleton = viewport vp3Name Both $
+                    vBox $ "Press ctrl-arrow keys to scroll this viewport horizontally and vertically."
+                         : (str <$> [ "Line " <> show i | i <- [2..25::Int] ])
+        pair = hBox [ viewport vp1Name Vertical $
+                      vBox $ "Press up and down arrow keys" :
+                             "to scroll this viewport." :
+                             (str <$> [ "Line " <> (show i) | i <- [3..50::Int] ])
+                    , B.vBorder
+                    , viewport vp2Name Horizontal
+                      "Press left and right arrow keys to scroll this viewport."
+                    ]
 
 vp1Scroll :: M.ViewportScroll
 vp1Scroll = M.viewportScroll vp1Name
@@ -51,11 +55,18 @@ vp1Scroll = M.viewportScroll vp1Name
 vp2Scroll :: M.ViewportScroll
 vp2Scroll = M.viewportScroll vp2Name
 
+vp3Scroll :: M.ViewportScroll
+vp3Scroll = M.viewportScroll vp3Name
+
 appEvent :: () -> V.Event -> M.EventM (M.Next ())
-appEvent _ (V.EvKey V.KDown [])  = M.scrollBy vp1Scroll 1 >> M.continue ()
-appEvent _ (V.EvKey V.KUp [])    = M.scrollBy vp1Scroll (-1) >> M.continue ()
-appEvent _ (V.EvKey V.KRight []) = M.scrollBy vp2Scroll 1 >> M.continue ()
-appEvent _ (V.EvKey V.KLeft [])  = M.scrollBy vp2Scroll (-1) >> M.continue ()
+appEvent _ (V.EvKey V.KDown  [V.MCtrl]) = M.vScrollBy vp3Scroll 1 >> M.continue ()
+appEvent _ (V.EvKey V.KUp    [V.MCtrl]) = M.vScrollBy vp3Scroll (-1) >> M.continue ()
+appEvent _ (V.EvKey V.KRight [V.MCtrl]) = M.hScrollBy vp3Scroll 1 >> M.continue ()
+appEvent _ (V.EvKey V.KLeft  [V.MCtrl]) = M.hScrollBy vp3Scroll (-1) >> M.continue ()
+appEvent _ (V.EvKey V.KDown [])  = M.vScrollBy vp1Scroll 1 >> M.continue ()
+appEvent _ (V.EvKey V.KUp [])    = M.vScrollBy vp1Scroll (-1) >> M.continue ()
+appEvent _ (V.EvKey V.KRight []) = M.hScrollBy vp2Scroll 1 >> M.continue ()
+appEvent _ (V.EvKey V.KLeft [])  = M.hScrollBy vp2Scroll (-1) >> M.continue ()
 appEvent _ (V.EvKey V.KEsc []) = M.halt ()
 appEvent _ _ = M.continue ()
 

programs/VisibilityDemo.hs

@@ -0,0 +1,134 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+module Main where
+
+import Control.Monad (void)
+import Control.Lens
+import Data.Monoid
+import qualified Graphics.Vty as V
+
+import qualified Brick.Types as T
+import qualified Brick.Main as M
+import qualified Brick.Widgets.Center as C
+import qualified Brick.Widgets.Border as B
+import Brick.AttrMap (AttrMap, AttrName, attrMap)
+import Brick.Util (on)
+import Brick.Widgets.Core
+  ( Widget
+  , ViewportType(Horizontal, Vertical, Both)
+  , withAttr
+  , hLimit
+  , vLimit
+  , hBox
+  , vBox
+  , viewport
+  , str
+  , visible
+  )
+
+data St =
+    St { _vp1Index :: Int
+       , _vp2Index :: Int
+       , _vp3Index :: (Int, Int)
+       }
+
+makeLenses ''St
+
+vp1Name :: T.Name
+vp1Name = "demo1"
+
+vp1Size :: Int
+vp1Size = 15
+
+vp2Name :: T.Name
+vp2Name = "demo2"
+
+vp2Size :: Int
+vp2Size = 15
+
+vp3Name :: T.Name
+vp3Name = "demo3"
+
+vp3Size :: (Int, Int)
+vp3Size = (25, 25)
+
+selectedAttr :: AttrName
+selectedAttr = "selected"
+
+drawUi :: St -> [Widget]
+drawUi st = [ui]
+    where
+        ui = C.center $ hLimit 60 $ vLimit 30 $
+             vBox [ B.border $ vBox [ pair, B.hBorder, singleton ]
+                  , str $ "- Up/down arrow keys scroll the top-left viewport\n" <>
+                          "- Left/right arrow keys scroll the top-right viewport\n" <>
+                          "- Ctrl-arrow keys move the bottom viewport"
+                  ]
+        singleton = viewport vp3Name Both $
+                    vBox $ do
+                         i <- [1..vp3Size^._1]
+                         let row = do
+                               j <- [1..vp3Size^._2]
+                               let mkItem = if (i, j) == st^.vp3Index
+                                            then withAttr selectedAttr . visible
+                                            else id
+                               return $ mkItem $ str $ "Item " <> show (i, j) <> " "
+                         return $ hBox row
+
+        pair = hBox [ vp1, B.vBorder, vp2 ]
+        vp1 = viewport vp1Name Vertical $
+                  vBox $ do
+                      i <- [1..vp1Size]
+                      let mkItem = if i == st^.vp1Index
+                                   then withAttr selectedAttr . visible
+                                   else id
+                      return $ mkItem $ str $ "Item " <> show i
+        vp2 = viewport vp2Name Horizontal $
+                  hBox $ do
+                      i <- [1..vp2Size]
+                      let mkItem = if i == st^.vp2Index
+                                   then withAttr selectedAttr . visible
+                                   else id
+                      return $ mkItem $ str $ "Item " <> show i <> " "
+
+vp1Scroll :: M.ViewportScroll
+vp1Scroll = M.viewportScroll vp1Name
+
+vp2Scroll :: M.ViewportScroll
+vp2Scroll = M.viewportScroll vp2Name
+
+vp3Scroll :: M.ViewportScroll
+vp3Scroll = M.viewportScroll vp3Name
+
+appEvent :: St -> V.Event -> M.EventM (M.Next St)
+appEvent st (V.EvKey V.KDown  [V.MCtrl]) = M.continue $ st & vp3Index._1 %~ min (vp3Size^._1) . (+ 1)
+appEvent st (V.EvKey V.KUp    [V.MCtrl]) = M.continue $ st & vp3Index._1 %~ max 1 . subtract 1
+appEvent st (V.EvKey V.KRight [V.MCtrl]) = M.continue $ st & vp3Index._2 %~ min (vp3Size^._1) . (+ 1)
+appEvent st (V.EvKey V.KLeft  [V.MCtrl]) = M.continue $ st & vp3Index._2 %~ max 1 .  subtract 1
+appEvent st (V.EvKey V.KDown [])         = M.continue $ st & vp1Index %~ min vp1Size . (+ 1)
+appEvent st (V.EvKey V.KUp [])           = M.continue $ st & vp1Index %~ max 1 . subtract 1
+appEvent st (V.EvKey V.KRight [])        = M.continue $ st & vp2Index %~ min vp2Size . (+ 1)
+appEvent st (V.EvKey V.KLeft [])         = M.continue $ st & vp2Index %~ max 1 . subtract 1
+appEvent st (V.EvKey V.KEsc []) = M.halt st
+appEvent st _ = M.continue st
+
+theMap :: AttrMap
+theMap = attrMap V.defAttr
+    [ (selectedAttr, V.black `on` V.yellow)
+    ]
+
+app :: M.App St V.Event
+app =
+    M.App { M.appDraw = drawUi
+          , M.appStartEvent = return
+          , M.appHandleEvent = appEvent
+          , M.appAttrMap = const theMap
+          , M.appLiftVtyEvent = id
+          , M.appChooseCursor = M.neverShowCursor
+          }
+
+initialState :: St
+initialState = St 1 1 (1, 1)
+
+main :: IO ()
+main = void $ M.defaultMain app initialState

src/Brick/Main.hs

@@ -15,10 +15,14 @@ module Brick.Main
   -- ** Viewport scrolling
   , viewportScroll
   , ViewportScroll
-  , scrollBy
-  , scrollPage
-  , scrollToBeginning
-  , scrollToEnd
+  , vScrollBy
+  , vScrollPage
+  , vScrollToBeginning
+  , vScrollToEnd
+  , hScrollBy
+  , hScrollPage
+  , hScrollToBeginning
+  , hScrollToEnd
 
   -- * Cursor management functions
   , neverShowCursor
@@ -236,27 +240,43 @@ data ViewportScroll =
     ViewportScroll { viewportName :: Name
                    -- ^ The name of the viewport to be controlled by
                    -- this scrolling handle.
-                   , scrollPage :: Direction -> EventM ()
-                   -- ^ Scroll the viewport by one page in the specified
-                   -- direction.
-                   , scrollBy :: Int -> EventM ()
-                   -- ^ Scroll the viewport by the specified number of
-                   -- rows or columns depending on the orientation of
-                   -- the viewport.
-                   , scrollToBeginning :: EventM ()
-                   -- ^ Scroll to the beginning of the viewport.
-                   , scrollToEnd :: EventM ()
-                   -- ^ Scroll to the end of the viewport.
+                   , hScrollPage :: Direction -> EventM ()
+                   -- ^ Scroll the viewport horizontally by one page in
+                   -- the specified direction.
+                   , hScrollBy :: Int -> EventM ()
+                   -- ^ Scroll the viewport horizontally by the
+                   -- specified number of rows or columns depending on
+                   -- the orientation of the viewport.
+                   , hScrollToBeginning :: EventM ()
+                   -- ^ Scroll horizontally to the beginning of the
+                   -- viewport.
+                   , hScrollToEnd :: EventM ()
+                   -- ^ Scroll horizontally to the end of the viewport.
+                   , vScrollPage :: Direction -> EventM ()
+                   -- ^ Scroll the viewport vertically by one page in
+                   -- the specified direction.
+                   , vScrollBy :: Int -> EventM ()
+                   -- ^ Scroll the viewport vertically by the specified
+                   -- number of rows or columns depending on the
+                   -- orientation of the viewport.
+                   , vScrollToBeginning :: EventM ()
+                   -- ^ Scroll vertically to the beginning of the viewport.
+                   , vScrollToEnd :: EventM ()
+                   -- ^ Scroll vertically to the end of the viewport.
                    }
 
 -- | Build a viewport scroller for the viewport with the specified name.
 viewportScroll :: Name -> ViewportScroll
 viewportScroll n =
     ViewportScroll { viewportName = n
-                   , scrollPage = \dir -> modify ((n, ScrollPage dir) :)
-                   , scrollBy = \i -> modify ((n, ScrollBy i) :)
-                   , scrollToBeginning = modify ((n, ScrollToBeginning) :)
-                   , scrollToEnd = modify ((n, ScrollToEnd) :)
+                   , hScrollPage = \dir -> modify ((n, HScrollPage dir) :)
+                   , hScrollBy = \i -> modify ((n, HScrollBy i) :)
+                   , hScrollToBeginning = modify ((n, HScrollToBeginning) :)
+                   , hScrollToEnd = modify ((n, HScrollToEnd) :)
+                   , vScrollPage = \dir -> modify ((n, HScrollPage dir) :)
+                   , vScrollBy = \i -> modify ((n, VScrollBy i) :)
+                   , vScrollToBeginning = modify ((n, VScrollToBeginning) :)
+                   , vScrollToEnd = modify ((n, VScrollToEnd) :)
                    }
 
 -- | Continue running the event loop with the specified application

src/Brick/Widgets/Internal.hs

@@ -98,7 +98,15 @@ data VisibilityRequest =
        }
        deriving Show
 
-data ViewportType = Vertical | Horizontal deriving Show
+-- | The type of viewports that indicates the direction(s) in which a
+-- viewport is scrollable.
+data ViewportType = Vertical
+                  -- ^ Viewports of this type are scrollable only vertically.
+                  | Horizontal
+                  -- ^ Viewports of this type are scrollable only horizontally.
+                  | Both
+                  -- ^ Viewports of this type are scrollable vertically and horizontally.
+                  deriving Show
 
 data Viewport =
     VP { _vpLeft :: Int
@@ -159,10 +167,15 @@ data Widget =
 
 data Direction = Up | Down
 
-data ScrollRequest = ScrollBy Int
-                   | ScrollPage Direction
-                   | ScrollToBeginning
-                   | ScrollToEnd
+data ScrollRequest = HScrollBy Int
+                   | HScrollPage Direction
+                   | HScrollToBeginning
+                   | HScrollToEnd
+                   | VScrollBy Int
+                   | VScrollPage Direction
+                   | VScrollToBeginning
+                   | VScrollToEnd
+
 
 data RenderState =
     RS { _viewportMap :: M.Map Name Viewport
@@ -588,11 +601,13 @@ viewport vpname typ p =
           release = case typ of
             Vertical -> vRelease
             Horizontal -> hRelease
+            Both -> \w -> vRelease w >>= hRelease
           released = case release p of
             Just w -> w
             Nothing -> case typ of
                 Vertical -> error $ "tried to embed an infinite-height widget in vertical viewport " <> (show vpn)
                 Horizontal -> error $ "tried to embed an infinite-width widget in horizontal viewport " <> (show vpn)
+                Both -> error $ "tried to embed an infinite-width or infinite-height widget in 'Both' type viewport " <> (show vpn)
 
       initialResult <- render released
 
@@ -601,7 +616,10 @@ viewport vpname typ p =
       when (not $ null $ initialResult^.visibilityRequests) $ do
           Just vp <- lift $ gets $ (^.viewportMap.to (M.lookup vpname))
           let rq = head $ initialResult^.visibilityRequests
-              updatedVp = scrollToView typ rq vp
+              updatedVp = case typ of
+                  Both -> scrollToView Horizontal rq $ scrollToView Vertical rq vp
+                  Horizontal -> scrollToView typ rq vp
+                  Vertical -> scrollToView typ rq vp
           lift $ modify (& viewportMap %~ (M.insert vpname updatedVp))
 
       -- If the rendering state includes any scrolling requests for this
@@ -612,7 +630,13 @@ viewport vpname typ p =
           Just vp <- lift $ gets $ (^.viewportMap.to (M.lookup vpname))
           let updatedVp = applyRequests relevantRequests vp
               applyRequests [] v = v
-              applyRequests (rq:rqs) v = scrollTo typ rq (initialResult^.image) $ applyRequests rqs v
+              applyRequests (rq:rqs) v =
+                  case typ of
+                      Horizontal -> scrollTo typ rq (initialResult^.image) $ applyRequests rqs v
+                      Vertical -> scrollTo typ rq (initialResult^.image) $ applyRequests rqs v
+                      Both -> scrollTo Horizontal rq (initialResult^.image) $
+                              scrollTo Vertical rq (initialResult^.image) $
+                              applyRequests rqs v
           lift $ modify (& viewportMap %~ (M.insert vpname updatedVp))
           return ()
 
@@ -638,53 +662,55 @@ viewport vpname typ p =
                       $ Widget Fixed Fixed $ return $ translated & visibilityRequests .~ mempty
 
 scrollTo :: ViewportType -> ScrollRequest -> V.Image -> Viewport -> Viewport
-scrollTo typ req img vp = vp & theStart .~ newStart
+scrollTo Both _ _ _ = error "BUG: called scrollTo on viewport type 'Both'"
+scrollTo Vertical req img vp = vp & vpTop .~ newVStart
     where
-        theStart :: Lens' Viewport Int
-        theStart = case typ of
-            Horizontal -> vpLeft
-            Vertical -> vpTop
-        theSize = case typ of
-            Horizontal -> vpSize._1
-            Vertical -> vpSize._2
-        imgSize = case typ of
-            Horizontal -> V.imageWidth img
-            Vertical -> V.imageHeight img
-
-        newStart = clamp 0 (imgSize - vp^.theSize) adjustedAmt
+        newVStart = clamp 0 (V.imageHeight img - vp^.vpSize._2) adjustedAmt
         adjustedAmt = case req of
-            ScrollBy amt -> (vp^.theStart) + amt
-            ScrollPage Up -> (vp^.theStart) - (vp^.theSize)
-            ScrollPage Down -> (vp^.theStart) + (vp^.theSize)
-            ScrollToBeginning -> 0
-            ScrollToEnd -> imgSize - (vp^.theSize)
+            VScrollBy amt -> vp^.vpTop + amt
+            VScrollPage Up -> vp^.vpTop - vp^.vpSize._2
+            VScrollPage Down -> vp^.vpTop + vp^.vpSize._2
+            VScrollToBeginning -> 0
+            VScrollToEnd -> V.imageHeight img - vp^.vpSize._2
+            _ -> vp^.vpTop
+scrollTo Horizontal req img vp = vp & vpLeft .~ newHStart
+    where
+        newHStart = clamp 0 (V.imageWidth img - vp^.vpSize._1) adjustedAmt
+        adjustedAmt = case req of
+            HScrollBy amt -> vp^.vpLeft + amt
+            HScrollPage Up -> vp^.vpLeft - vp^.vpSize._1
+            HScrollPage Down -> vp^.vpLeft + vp^.vpSize._1
+            HScrollToBeginning -> 0
+            HScrollToEnd -> V.imageWidth img - vp^.vpSize._1
+            _ -> vp^.vpLeft
 
 scrollToView :: ViewportType -> VisibilityRequest -> Viewport -> Viewport
-scrollToView typ rq vp = vp & theStart .~ newStart
+scrollToView Both _ _ = error "BUG: called scrollToView on 'Both' type viewport"
+scrollToView Vertical rq vp = vp & vpTop .~ newVStart
     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.column
-            Vertical -> rq^.vrPosition.row
-        reqSize = case typ of
-            Horizontal -> rq^.vrSize._1
-            Vertical -> rq^.vrSize._2
+        curStart = vp^.vpTop
+        curEnd = curStart + vp^.vpSize._2
+        reqStart = rq^.vrPosition.row
 
-        curStart = vp^.theStart
-        curEnd = curStart + vp^.theSize
-
-        reqEnd = reqStart + reqSize
-        newStart :: Int
-        newStart = if reqStart < curStart
+        reqEnd = rq^.vrPosition.row + rq^.vrSize._2
+        newVStart :: Int
+        newVStart = if reqStart < curStart
                    then reqStart
                    else if reqStart > curEnd || reqEnd > curEnd
-                        then reqEnd - vp^.theSize
+                        then reqEnd - vp^.vpSize._2
+                        else curStart
+scrollToView Horizontal rq vp = vp & vpLeft .~ newHStart
+    where
+        curStart = vp^.vpLeft
+        curEnd = curStart + vp^.vpSize._1
+        reqStart = rq^.vrPosition.column
+
+        reqEnd = rq^.vrPosition.column + rq^.vrSize._1
+        newHStart :: Int
+        newHStart = if reqStart < curStart
+                   then reqStart
+                   else if reqStart > curEnd || reqEnd > curEnd
+                        then reqEnd - vp^.vpSize._1
                         else curStart
 
 -- | Request that the specified widget be made visible when it is