Update splitVDrag and examples to use DynRegion

reflex-vty.cabal

@@ -23,6 +23,7 @@ library
                  , Reflex.Vty.Widget.Input.Text
                  , Data.Text.Zipper
                  , Control.Monad.Writer.Adjustable
+                 , Reflex.Class.Orphans
                  , Reflex.Class.Switchable
                  , Reflex.NotReady.Class.Orphans
                  , Reflex.Spider.Orphans

src-bin/example.hs

@@ -21,27 +21,39 @@ import qualified Data.Text as T
 import qualified Data.Text.Zipper as TZ
 import qualified Graphics.Vty as V
 import Reflex
+import Reflex.Class.Orphans
 import Reflex.Network
 import Reflex.Class.Switchable
 import Reflex.NotReady.Class
 import Reflex.Vty
 
+import Data.Tree
+
+-- Unlimited Stack
+  -- Parent provides orientation and maximum cross-dimension size
+  -- Each child takes as much main-dimension space as it wants and reports what it took
+  -- Parent offsets each child so that it does not overlap with other children
+  -- If parent runs of out space, parent provides a scroll bar
+
 data Example = Example_TextEditor
              | Example_Todo
   deriving (Show, Read, Eq, Ord, Enum, Bounded)
 
+div' :: (Integral a, Applicative f) => f a ->f a -> f a
+div' = liftA2 div
+
 main :: IO ()
 main = mainWidget $ do
   inp <- input
-  taskList
 
-{-
+  w <- displayWidth
+  h <- displayHeight
   let buttons = do
         text $ pure "Select an example. Esc will bring you back here. Ctrl+c to quit."
-        let region1 = ffor size $ \(w,h) ->
-              Region (w `div` 6) (h `div` 6) (w `div` 6) (h `div` 6)
-            region2 = ffor size $ \(w,h) ->
-              Region (2 * w `div` 6) (h `div` 6) (w `div` 6) (h `div` 6)
+        let w' = fmap (`div`6) w
+            h' = fmap (`div`6) h
+            region1 = DynRegion w' h' w' h'
+            region2 = DynRegion (2 * w') h' w' h'
         todo' <- pane region1 (pure True) $ textButtonStatic def "Todo List"
         editor <- pane region2 (pure True) $ textButtonStatic def "Text Editor"
         return $ leftmost
@@ -59,7 +71,6 @@ main = mainWidget $ do
         Left Example_Todo -> escapable taskList
         Right () -> buttons
 
--}
   return $ fforMaybe inp $ \case
     V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
     _ -> Nothing
@@ -80,18 +91,16 @@ taskList = do
         splitV (pure (subtract 3)) (pure (True, True)) btn (display $ current m)
   return ()
 
-{-
 testBoxes :: (Reflex t, MonadHold t m, MonadFix m) => VtyWidget t m ()
 testBoxes = do
   dw <- displayWidth
   dh <- displayHeight
-  let region1 = liftA2 (\w h -> Region (w `div` 6) (h `div` 6) (w `div` 2) (h `div` 2)) dw dh
-      region2 = liftA2 (\w h -> Region (w `div` 4) (h `div` 4) (2 * (w `div` 3)) (2*(h `div` 3))) dw dh
+  let region1 = DynRegion (div' dw 6) (div' dh 6) (div' dw 2) (div' dh 2)
+      region2 = DynRegion (div' dw 4) (div' dh 4) (2 * div' dw 3) (2 * div' dh 3)
   pane region1 (constDyn False) . boxStatic singleBoxStyle $ debugInput
   _ <- pane region2 (constDyn True) . boxStatic singleBoxStyle $
     splitVDrag (hRule doubleBoxStyle) (boxStatic roundedBoxStyle $ multilineTextInput def) (boxStatic roundedBoxStyle dragTest)
   return ()
--}
 
 debugFocus :: (Reflex t, Monad m) => VtyWidget t m ()
 debugFocus = do
@@ -137,14 +146,14 @@ todo
 todo t0 = do
   w <- displayWidth
   rec let checkboxWidth = 3
-          checkboxRegion = pure $ Region 0 0 checkboxWidth 1
+          checkboxRegion = DynRegion 0 0 checkboxWidth 1
           labelHeight = _textInput_lines ti
-          labelWidth = ffor w $ \w' -> w' - 1 - checkboxWidth
-          labelLeft = constDyn $ checkboxWidth + 1 
+          labelWidth = w - 1 - checkboxWidth
+          labelLeft = checkboxWidth + 1 
           labelTop = constDyn 0
-          -- labelRegion = liftA2 (\w' h -> Region (checkboxWidth + 1) 0 (w' - 1 - checkboxWidth) h) w (_textInput_lines ti)
+          labelRegion = DynRegion labelLeft labelTop labelWidth labelHeight
       value <- pane checkboxRegion (pure True) $ checkbox def $ _todo_done t0
-      (ti, d) <- pane' labelLeft labelTop labelWidth labelHeight (pure True) $ do
+      (ti, d) <- pane labelRegion (pure True) $ do
         i <- input
         v <- textInput $ def { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }
         let deleteSelf = attachWithMaybe backspaceOnEmpty (current $ _textInput_value v) i
@@ -171,11 +180,7 @@ todos todos0 newTodo = do
         let reg = zipDynWith (\w' ts ->
               let l = Map.size $ Map.takeWhileAntitone (<row) ts
               in Region 0 l w' 1) w todosMap
-        pane'
-          (pure 0)
-          (fromMaybe 0 . Map.lookup row <$> offsets)
-          w
-          (fromMaybe 1 . Map.lookup row <$> heights)
+        pane (DynRegion 0 (fromMaybe 0 . Map.lookup row <$> offsets) w (fromMaybe 1 . Map.lookup row <$> heights))
           (fmap (==row) selected) $ do
             e <- mouseUp
             r <- todo t

src/Reflex/Class/Orphans.hs

@@ -0,0 +1,19 @@
+{-
+Module: Reflex.Class.Orphans
+Description: Orphan instances for Dynamic. These should be upstreamed.
+-}
+module Reflex.Class.Orphans where
+
+import Control.Applicative
+import Reflex.Class
+
+instance (Num a, Reflex t) => Num (Dynamic t a) where
+  (+) = liftA2 (+)
+  (*) = liftA2 (*)
+  abs = fmap abs
+  signum = fmap signum
+  fromInteger = pure . fromInteger
+  negate = fmap negate
+  (-) = liftA2 (-)
+
+

src/Reflex/Vty/Widget.hs

@@ -25,6 +25,8 @@ module Reflex.Vty.Widget
   , HasDisplaySize(..)
   , HasFocus(..)
   , HasVtyInput(..)
+  , DynRegion(..)
+  , currentRegion
   , Region(..)
   , regionSize
   , regionBlankImage
@@ -35,10 +37,9 @@ module Reflex.Vty.Widget
   , mouseDown
   , mouseUp
   , pane
-  , pane'
   , tellImages
   , splitV
-  -- , splitVDrag TODO
+  , splitVDrag
   , box
   , boxStatic
   , RichTextConfig(..)
@@ -66,10 +67,9 @@ import qualified Data.Text.Zipper as TZ
 import Graphics.Vty (Image)
 import qualified Graphics.Vty as V
 import Reflex
+import Reflex.Class.Orphans
 import Reflex.NotReady.Class
 import Reflex.NotReady.Class.Orphans ()
-import Reflex.BehaviorWriter.Class (tellBehavior)
-import Reflex.BehaviorWriter.Base (BehaviorWriterT, runBehaviorWriterT)
 
 import Reflex.Vty.Host
 
@@ -194,6 +194,14 @@ data Region = Region
   }
   deriving (Show, Read, Eq, Ord)
 
+-- | A dynamic chunk of the display area
+data DynRegion t = DynRegion
+  { _dynRegion_left :: Dynamic t Int
+  , _dynRegion_top :: Dynamic t Int
+  , _dynRegion_width :: Dynamic t Int
+  , _dynRegion_height :: Dynamic t Int
+  }
+
 -- | The width and height of a 'Region'
 regionSize :: Region -> (Int, Int)
 regionSize (Region _ _ w h) = (w, h)
@@ -203,6 +211,10 @@ regionBlankImage :: Region -> Image
 regionBlankImage r@(Region _ _ width height) =
   withinImage r $ V.charFill V.defAttr ' ' width height
 
+-- | A behavior of the current display area represented by a 'DynRegion'
+currentRegion :: Reflex t => DynRegion t -> Behavior t Region
+currentRegion (DynRegion l t w h) = Region <$> current l <*> current t <*> current w <*> current h
+
 -- | Translates and crops an 'Image' so that it is contained by
 -- the given 'Region'.
 withinImage
@@ -222,53 +234,11 @@ withinImage (Region left top width height)
 --   that (0,0) is the top-left corner of the region
 pane
   :: (Reflex t, Monad m)
-  => Dynamic t Region -- ^ Region into which we should draw the widget (in coordinates relative to our own)
+  => DynRegion t
   -> Dynamic t Bool -- ^ Whether the widget should be focused when the parent is.
   -> VtyWidget t m a
   -> VtyWidget t m a
-pane reg foc child = VtyWidget $ do
-  ctx <- lift ask
-  let ctx' = VtyWidgetCtx
-        { _vtyWidgetCtx_input = leftmost -- TODO: think about this leftmost more.
-            [ fmapMaybe id $
-                attachWith (\(r,f) e -> filterInput r f e)
-                  (liftA2 (,) (current reg) (current foc))
-                  (_vtyWidgetCtx_input ctx)
-            ]
-        , _vtyWidgetCtx_focus = liftA2 (&&) (_vtyWidgetCtx_focus ctx) foc
-        , _vtyWidgetCtx_width = fmap (fst . regionSize) reg
-        , _vtyWidgetCtx_height = fmap (snd . regionSize) reg
-        }
-  (result, images) <- lift . lift $ runVtyWidget ctx' child
-  let images' = liftA2 (\r is -> map (withinImage r) is) (current reg) images
-  tellImages images'
-  return result
-  where
-    filterInput :: Region -> Bool -> VtyEvent -> Maybe VtyEvent
-    filterInput (Region l t w h) focused e = case e of
-      V.EvKey _ _ | not focused -> Nothing
-      V.EvMouseDown x y btn m -> mouse (\u v -> V.EvMouseDown u v btn m) x y
-      V.EvMouseUp x y btn -> mouse (\u v -> V.EvMouseUp u v btn) x y
-      _ -> Just e
-      where
-        mouse con x y
-          | or [ x < l
-               , y < t
-               , x >= l + w
-               , y >= t + h ] = Nothing
-          | otherwise =
-            Just (con (x - l) (y - t))
-
-pane'
-  :: (Reflex t, Monad m)
-  => Dynamic t Int
-  -> Dynamic t Int
-  -> Dynamic t Int
-  -> Dynamic t Int
-  -> Dynamic t Bool -- ^ Whether the widget should be focused when the parent is.
-  -> VtyWidget t m a
-  -> VtyWidget t m a
-pane' l t w h foc child = VtyWidget $ do
+pane (DynRegion l t w h) foc child = VtyWidget $ do
   ctx <- lift ask
   let reg = Region <$> l <*> t <*> w <*> h
   let ctx' = VtyWidgetCtx
@@ -398,13 +368,22 @@ splitV :: (Reflex t, Monad m)
 splitV sizeFunD focD wA wB = do
   dw <- displayWidth
   dh <- displayHeight
-  let regA = (\f w h -> Region 0 0 w (f h)) <$> sizeFunD <*> dw <*> dh
-      regB = (\w h (Region _ _ _ hA) -> Region 0 hA w (h - hA)) <$> dw <*> dh <*> regA
+  let regA = DynRegion
+        { _dynRegion_left = pure 0
+        , _dynRegion_top = pure 0
+        , _dynRegion_width = dw
+        , _dynRegion_height = sizeFunD <*> dh
+        }
+      regB = DynRegion
+        { _dynRegion_left = pure 0
+        , _dynRegion_top = _dynRegion_height regA
+        , _dynRegion_width = dw
+        , _dynRegion_height = liftA2 (-) dh (_dynRegion_height regA)
+        }
   ra <- pane regA (fst <$> focD) wA
   rb <- pane regB (snd <$> focD) wB
   return (ra,rb)
 
-{-
 -- | A split of the available space into two parts with a draggable separator.
 -- Starts with half the space allocated to each, and the first pane has focus.
 -- Clicking in a pane switches focus.
@@ -414,22 +393,23 @@ splitVDrag :: (Reflex t, MonadFix m, MonadHold t m)
   -> VtyWidget t m b
   -> VtyWidget t m (a,b)
 splitVDrag wS wA wB = do
-  sz <- displaySize
-  (_, h0) <- sample $ current sz
+  dh <- displayHeight
+  dw <- displayWidth
+  h0 <- sample $ current dh -- TODO
   dragE <- drag V.BLeft
   let splitter0 = h0 `div` 2
   rec splitterCheckpoint <- holdDyn splitter0 $ leftmost [fst <$> ffilter snd dragSplitter, resizeSplitter]
       splitterPos <- holdDyn splitter0 $ leftmost [fst <$> dragSplitter, resizeSplitter]
-      splitterFrac <- holdDyn ((1::Double) / 2) $ ffor (attach (current sz) (fst <$> dragSplitter)) $ \((_,h),x) ->
+      splitterFrac <- holdDyn ((1::Double) / 2) $ ffor (attach (current dh) (fst <$> dragSplitter)) $ \(h, x) ->
         fromIntegral x / fromIntegral h
       let dragSplitter = fforMaybe (attach (current splitterCheckpoint) dragE) $
             \(splitterY, Drag (_, fromY) (_, toY) _ _ end) ->
               if splitterY == fromY then Just (toY, end) else Nothing
-          regA = (\(w,_) sp -> Region 0 0 w sp) <$> sz <*> splitterPos
-          regS = (\(w,_) sp -> Region 0 sp w 1) <$> sz <*> splitterPos
-          regB = (\(w,h) sp -> Region 0 (sp + 1) w (h - sp - 1)) <$> sz <*> splitterPos
-          resizeSplitter = ffor (attach (current splitterFrac) (updated sz)) $
-            \(frac, (_,h)) -> round (frac * fromIntegral h)
+          regA = DynRegion 0 0 dw splitterPos
+          regS = DynRegion 0 splitterPos dw 1
+          regB = DynRegion 0 (splitterPos + 1) dw (dh - splitterPos - 1)
+          resizeSplitter = ffor (attach (current splitterFrac) (updated dh)) $
+            \(frac, h) -> round (frac * fromIntegral h)
       focA <- holdDyn True $ leftmost
         [ True <$ mA
         , False <$ mB
@@ -443,7 +423,7 @@ splitVDrag wS wA wB = do
       m <- mouseDown V.BLeft
       x' <- x
       return (m, x')
--}
+
 -- | Fill the background with a particular character.
 fill :: (Reflex t, Monad m) => Char -> VtyWidget t m ()
 fill c = do
@@ -501,10 +481,10 @@ box :: (Monad m, Reflex t)
 box boxStyle child = do
   dh <- displayHeight
   dw <- displayWidth
-  let boxReg = liftA2 (\w h -> Region 0 0 w h) dw dh
-      innerReg = liftA2 (\w h -> Region 1 1 (w - 2) (h - 2)) dw dh
-  tellImages (boxImages <$> boxStyle <*> current boxReg)
-  tellImages (fmap (\r -> [regionBlankImage r]) (current innerReg))
+  let boxReg = DynRegion (pure 0) (pure 0) dw dh
+      innerReg = DynRegion (pure 1) (pure 1) (subtract 2 <$> dw) (subtract 2 <$> dh)
+  tellImages (boxImages <$> boxStyle <*> currentRegion boxReg)
+  tellImages (fmap (\r -> [regionBlankImage r]) (currentRegion innerReg))
   pane innerReg (pure True) child
   where
     boxImages :: BoxStyle -> Region -> [Image]

src/Reflex/Vty/Widget/Input/Text.hs

@@ -32,6 +32,9 @@ data TextInputConfig t = TextInputConfig
 instance Reflex t => Default (TextInputConfig t) where
   def = TextInputConfig empty never 4
 
+-- | The output produced by text input widgets, including the text
+-- value and the number of display lines (post-wrapping). Note that some
+-- display lines may not be visible due to scrolling.
 data TextInput t = TextInput
   { _textInput_value :: Dynamic t Text
   , _textInput_lines :: Dynamic t Int