wip: split up layout and focus

reflex-vty.cabal

@@ -42,6 +42,7 @@ library
     text >= 1.2.3 && < 1.3,
     dependent-sum >= 0.7 && < 0.8,
     exception-transformers >= 0.4.0 && < 0.5,
+    ordered-containers >= 0.2.2 && < 0.3,
     primitive >= 0.6.3 && < 0.8,
     ref-tf >= 0.4.0 && < 0.5,
     reflex >= 0.8 && < 0.9,

src/Reflex/Vty/Widget.hs

@@ -29,6 +29,10 @@ module Reflex.Vty.Widget
   , HasFocus(..)
   , HasVtyInput(..)
   , DynRegion(..)
+  -- TODO get rid of DynRegion?
+  , joinDynRegion
+  , dynRegion
+  , dynamicRegion
   , currentRegion
   , Region(..)
   , regionSize
@@ -70,6 +74,7 @@ module Reflex.Vty.Widget
   ) where
 
 import Control.Applicative (liftA2)
+import Control.Monad (join)
 import Control.Monad.Fix (MonadFix)
 import Control.Monad.IO.Class (MonadIO)
 import Control.Monad.Reader (ReaderT, ask, asks, runReaderT)
@@ -263,6 +268,28 @@ regionBlankImage r@(Region _ _ width height) =
 currentRegion :: Reflex t => DynRegion t -> Behavior t Region
 currentRegion (DynRegion l t w h) = Region <$> current l <*> current t <*> current w <*> current h
 
+joinDynRegion :: Reflex t => Dynamic t (DynRegion t) -> DynRegion t
+joinDynRegion d = DynRegion
+  (_dynRegion_left =<< d)
+  (_dynRegion_top =<< d)
+  (_dynRegion_width =<< d)
+  (_dynRegion_height =<< d)
+
+dynRegion :: Reflex t => Dynamic t Region -> DynRegion t
+dynRegion r = DynRegion
+  { _dynRegion_left = _region_left <$> r
+  , _dynRegion_top = _region_top <$> r
+  , _dynRegion_width = _region_width <$> r
+  , _dynRegion_height = _region_height <$> r
+  }
+
+dynamicRegion :: Reflex t => DynRegion t -> Dynamic t Region
+dynamicRegion d = Region
+  <$> _dynRegion_left d
+  <*> _dynRegion_top d
+  <*> _dynRegion_width d
+  <*> _dynRegion_height d
+
 -- | Translates and crops an 'Image' so that it is contained by
 -- the given 'Region'.
 withinImage

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

@@ -103,18 +103,19 @@ multilineTextInput cfg = do
 -- | Wraps a 'textInput' or 'multilineTextInput' in a tile. Uses
 -- the computed line count to greedily size the tile when vertically
 -- oriented, and uses the fallback width when horizontally oriented.
-textInputTile
-  :: (Reflex t, MonadHold t m, MonadFix m, MonadNodeId m)
-  => VtyWidget t m (TextInput t)
-  -> Dynamic t Int
-  -> Layout t m (TextInput t)
-textInputTile txt width = do
-  o <- askOrientation
-  rec t <- fixed sz txt
-      let sz = join $ ffor o $ \case
-            Orientation_Column -> _textInput_lines t
-            Orientation_Row -> width
-  return t
+-- TODO
+-- textInputTile
+--   :: (Reflex t, MonadHold t m, MonadFix m, MonadNodeId m)
+--   => VtyWidget t m (TextInput t)
+--   -> Dynamic t Int
+--   -> Layout t m (TextInput t)
+-- textInputTile txt width = do
+--   o <- askOrientation
+--   rec t <- fixed sz txt
+--       let sz = join $ ffor o $ \case
+--             Orientation_Column -> _textInput_lines t
+--             Orientation_Row -> width
+--   return t
 
 -- | Default attributes for the text cursor
 cursorAttributes :: V.Attr

src/Reflex/Vty/Widget/Layout.hs

@@ -7,45 +7,300 @@ Description: Monad transformer and tools for arranging widgets and building scre
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RecursiveDo #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TupleSections #-}
 {-# LANGUAGE UndecidableInstances #-}
 
-module Reflex.Vty.Widget.Layout
-  (  Orientation(..)
-  , Constraint(..)
-  , Layout
-  , runLayout
-  , TileConfig(..)
-  , tile
-  , fixed
-  , stretch
-  , col
-  , row
-  , tabNavigation
-  , askOrientation
-  ) where
+module Reflex.Vty.Widget.Layout where
+  -- (  Orientation(..)
+  -- , Constraint(..)
+  -- , Layout
+  -- , runLayout
+  -- , TileConfig(..)
+  -- , tile
+  -- , fixed
+  -- , stretch
+  -- , col
+  -- , row
+  -- , tabNavigation
+  -- , askOrientation
+  -- ) where
 
-import Control.Monad.NodeId (NodeId, MonadNodeId(..))
+import Control.Monad.NodeId (MonadNodeId(..), NodeId, NodeIdT)
 import Control.Monad.Reader
 import Data.Bimap (Bimap)
 import qualified Data.Bimap as Bimap
 import Data.Default (Default(..))
+import Data.List
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Maybe (fromMaybe)
 import Data.Monoid hiding (First(..))
 import Data.Ratio ((%))
 import Data.Semigroup (First(..))
+import Data.Sequence (Seq)
+import qualified Data.Sequence as Seq
 import qualified Graphics.Vty as V
+import Data.Map.Ordered (OMap, Bias(..), L)
+import qualified Data.Map.Ordered as OMap
+import qualified Graphics.Vty.Attributes as V
 
 import Reflex
 import Reflex.Host.Class (MonadReflexCreateTrigger)
 import Reflex.Vty.Widget
 
+-- * Focus
+
+newtype Focus t m a = Focus
+  { unFocus :: DynamicWriterT t (Seq FocusId) (ReaderT (Demux t (Maybe FocusId)) m) a
+  }
+  deriving
+    ( Functor
+    , Applicative
+    , Monad
+    , MonadHold t
+    , MonadSample t
+    , MonadFix
+    , TriggerEvent t
+    , PerformEvent t
+    , NotReady t
+    , MonadReflexCreateTrigger t
+    , HasDisplaySize t
+    , PostBuild t
+    , MonadNodeId
+    )
+
+instance MonadTrans (Focus t) where
+  lift = Focus . lift . lift
+
+newtype FocusId = FocusId NodeId
+  deriving (Eq, Ord)
+
+focusId :: (MonadNodeId m, Reflex t) => Focus t m FocusId
+focusId = do
+  fid <- FocusId <$> lift getNextNodeId
+  Focus $ tellDyn $ pure $ Seq.singleton fid
+  pure fid
+
+runFocus
+  :: (MonadFix m, MonadHold t m, Reflex t)
+  => Event t (Maybe FocusId)
+  -> Focus t m a
+  -> m (a, Dynamic t (Seq FocusId))
+runFocus e (Focus x) = do
+  rec (a, focusIds) <- flip runReaderT (demux sel) $ runDynamicWriterT x
+      sel <- holdDyn Nothing e
+  pure (a, focusIds)
+
+withFocus
+  :: (Reflex t, Monad m)
+  => FocusId
+  -> (Dynamic t Bool -> Focus t m a) -- TODO unnecessary: just return the dynamic bool
+  -> Focus t m a
+withFocus focusId builder = do
+  sel <- Focus ask
+  builder $ demuxed sel $ Just focusId
+
+-- focus builder = do
+--   fid <- focusId
+--   withFocus fid builder
+
+-- | Configuration options for and constraints on 'tile'
+data TileConfig t = TileConfig
+  { _tileConfig_constraint :: Dynamic t Constraint
+    -- ^ 'Constraint' on the tile's size
+  , _tileConfig_focusable :: Dynamic t Bool
+    -- ^ Whether the tile is focusable
+  }
+
+instance Reflex t => Default (TileConfig t) where
+  def = TileConfig (pure $ Constraint_Min 0) (pure True)
+
+tile
+  :: (MonadNodeId m, MonadFix m, Reflex t)
+  => VtyWidget t m a
+  -> Layout t (Focus t (VtyWidget t m)) a
+tile w = do
+  fid <- lift focusId
+  focused <- lift $ withFocus fid return
+  stretch $ \r -> lift $ pane r focused w
+
+-- * Layout
+
+data LTree a = LTree a (LForest a)
+
+newtype LForest a = LForest { unLForest :: OMap NodeId (LTree a) }
+
+instance Semigroup (LForest a) where
+  LForest a <> LForest b = LForest $ a OMap.|<> b
+
+instance Monoid (LForest a) where
+  mempty = LForest OMap.empty
+
+lookupLF :: NodeId -> LForest a -> Maybe (LTree a)
+lookupLF n (LForest a) = OMap.lookup n a
+
+singletonLF :: NodeId -> LTree a -> LForest a
+singletonLF n t = LForest $ OMap.singleton (n, t)
+
+fromListLF :: [(NodeId, LTree a)] -> LForest a
+fromListLF = LForest . OMap.fromList
+
+ltreeRoot :: LTree a -> a
+ltreeRoot (LTree a _) = a
+
+ltreeForest :: LTree a -> LForest a
+ltreeForest (LTree _ a) = a
+
+newtype Layout t m a = Layout
+  { unLayout :: DynamicWriterT t (LForest (Constraint, Orientation))
+      (ReaderT (Dynamic t (LTree (Region, Orientation))) m) a
+  }
+  deriving
+    ( Functor
+    , Applicative
+    , Monad
+    , MonadHold t
+    , MonadSample t
+    , MonadFix
+    , TriggerEvent t
+    , PerformEvent t
+    , NotReady t
+    , MonadReflexCreateTrigger t
+    , HasDisplaySize t
+    , PostBuild t
+    , MonadNodeId
+    )
+
+instance MonadTrans (Layout t) where
+  lift = Layout . lift . lift
+
+-- | Datatype representing constraints on a widget's size along the main axis (see 'Orientation')
+data Constraint = Constraint_Fixed Int
+                | Constraint_Min Int
+  deriving (Show, Read, Eq, Ord)
+
 -- | The main-axis orientation of a 'Layout' widget
 data Orientation = Orientation_Column
                  | Orientation_Row
   deriving (Show, Read, Eq, Ord)
 
+axis
+  :: (Monad m, MonadNodeId m, Reflex t, MonadFix m)
+  => Orientation
+  -> Constraint
+  -> Layout t m a
+  -> Layout t m a
+axis o c (Layout x) = Layout $ do
+  nodeId <- getNextNodeId
+  (result, forest) <- lift $ local (\t -> (\(Just x) -> x) . lookupLF nodeId . ltreeForest <$> t) $ runDynamicWriterT x -- TODO?
+  tellDyn $ fmap (singletonLF nodeId . LTree (c, o)) forest
+  pure result
+
+row, col
+  :: (Monad m, MonadNodeId m, Reflex t, MonadFix m)
+  => Constraint
+  -> Layout t m a
+  -> Layout t m a
+row = axis Orientation_Row
+col = axis Orientation_Column
+
+leaf
+  :: (Monad m, MonadNodeId m, Reflex t, MonadFix m)
+  => Dynamic t Constraint
+  -> (DynRegion t -> m a)
+  -> Layout t m a
+leaf c f = do
+  nodeId <- lift getNextNodeId
+  Layout $ tellDyn $ ffor c $ \c' -> singletonLF nodeId $ LTree (c', Orientation_Row) mempty
+  solutions <- Layout ask
+  let r = maybe (Region 0 0 0 0) (fst . ltreeRoot) . lookupLF nodeId . ltreeForest <$> solutions -- TODO revisit this fromMaybe
+  lift $ f $ dynRegion r
+
+fixed
+  :: (Monad m, MonadNodeId m, Reflex t, MonadFix m)
+  => Dynamic t Int
+  -> (DynRegion t -> m a)
+  -> Layout t m a
+fixed = leaf . fmap Constraint_Fixed
+
+stretch
+  :: (Monad m, MonadNodeId m, Reflex t, MonadFix m)
+  => (DynRegion t -> m a)
+  -> Layout t m a
+stretch = leaf (pure $ Constraint_Min 0)
+
+askOrientation :: (Monad m, Reflex t) => Layout t m (Dynamic t Orientation)
+askOrientation = Layout $ asks $ fmap (snd . ltreeRoot)
+
+ltreeConstraint :: LTree (Constraint, a) -> Constraint
+ltreeConstraint (LTree (c, _) _) = c
+
+solve
+  :: Orientation
+  -> Region
+  -> LForest (Constraint, Orientation)
+  -> LTree (Region, Orientation)
+solve o0 r0 (LForest cs) =
+  let a = map (\(x, t) -> ((x, t), ltreeConstraint t)) $ OMap.assocs cs
+      extent = case o0 of
+        Orientation_Row -> _region_width r0
+        Orientation_Column -> _region_height r0
+      sizes = computeEdges $ computeSizes extent a
+      chunks = [ (nodeId, solve o1 r1 f)
+               | ((nodeId, LTree (_, o1) f), sz) <- sizes
+               , let r1 = chunk o0 r0 sz
+               ]
+  in LTree (r0, o0) $ fromListLF chunks
+
+chunk :: Orientation -> Region -> (Int, Int) -> Region
+chunk o r (offset, sz) = case o of
+  Orientation_Column -> r
+    { _region_top = _region_top r + offset
+    , _region_height = sz
+    }
+  Orientation_Row -> r
+    { _region_left = _region_left r + offset
+    , _region_width = sz
+    }
+
+-- | Compute the size of each widget "@k@" based on the total set of 'Constraint's
+computeSizes
+  :: Int
+  -> [(a, Constraint)]
+  -> [(a, Int)]
+computeSizes available constraints =
+  let minTotal = sum $ ffor constraints $ \case
+        (_, Constraint_Fixed n) -> n
+        (_, Constraint_Min n) -> n
+      leftover = max 0 (available - minTotal)
+      numStretch = length $ filter (isMin . snd) constraints
+      szStretch = floor $ leftover % (max numStretch 1)
+      adjustment = max 0 $ available - minTotal - szStretch * numStretch
+  in snd $ mapAccumL (\adj (a, c) -> case c of
+      Constraint_Fixed n -> (adj, (a, n))
+      Constraint_Min n -> (0, (a, n + szStretch + adj))) adjustment constraints
+  where
+    isMin (Constraint_Min _) = True
+    isMin _ = False
+
+computeEdges :: [(a, Int)] -> [(a, (Int, Int))]
+computeEdges = ($ []) . fst . foldl (\(m, offset) (a, sz) ->
+  (((a, (offset, sz)) :) . m, sz + offset)) (id, 0)
+
+runLayout
+  :: (MonadFix m, Reflex t)
+  => Dynamic t Orientation
+  -> Dynamic t Region
+  -> Layout t m a
+  -> m a
+runLayout o r (Layout x) = do
+  rec (result, w) <- runReaderT (runDynamicWriterT x) solutions
+      let solutions = solve <$> o <*> r <*> w
+  return result
+
+{-
 data LayoutSegment = LayoutSegment
   { _layoutSegment_offset :: Int
   , _layoutSegment_size :: Int
@@ -119,23 +374,23 @@ runLayout ddir focus0 focusShift (Layout child) = do
             { _layoutSegment_offset = offset
             , _layoutSegment_size = sz
             }
-          focusable = fmap (Bimap.fromList . zip [0..]) $
-            ffor queries $ \qs -> fforMaybe qs $ \(nodeId, (f, _)) ->
-              if f then Just nodeId else Nothing
-          adjustFocus
-            :: (Bimap Int NodeId, (Int, Maybe NodeId))
-            -> Either Int NodeId
-            -> (Int, Maybe NodeId)
-          adjustFocus (fm, (cur, _)) (Left shift) =
-            let ix = (cur + shift) `mod` (max 1 $ Bimap.size fm)
-            in (ix, Bimap.lookup ix fm)
-          adjustFocus (fm, (cur, _)) (Right goto) =
-            let ix = fromMaybe cur $ Bimap.lookupR goto fm
-            in (ix, Just goto)
-          focusChange = attachWith
-            adjustFocus
-            (current $ (,) <$> focusable <*> focussed)
-            $ leftmost [Left <$> focusShift, Left 0 <$ pb, Right . getFirst <$> focusReq]
+          -- focusable = fmap (Bimap.fromList . zip [0..]) $
+          --   ffor queries $ \qs -> fforMaybe qs $ \(nodeId, (f, _)) ->
+          --     if f then Just nodeId else Nothing
+          -- adjustFocus
+          --   :: (Bimap Int NodeId, (Int, Maybe NodeId))
+          --   -> Either Int NodeId
+          --   -> (Int, Maybe NodeId)
+          -- adjustFocus (fm, (cur, _)) (Left shift) =
+          --   let ix = (cur + shift) `mod` (max 1 $ Bimap.size fm)
+          --   in (ix, Bimap.lookup ix fm)
+          -- adjustFocus (fm, (cur, _)) (Right goto) =
+          --   let ix = fromMaybe cur $ Bimap.lookupR goto fm
+          --   in (ix, Just goto)
+          -- focusChange = attachWith
+          --   adjustFocus
+          --   (current $ (,) <$> focusable <*> focussed)
+          --   $ leftmost [Left <$> focusShift, Left 0 <$ pb, Right . getFirst <$> focusReq]
       -- A pair (Int, Maybe NodeId) which represents the index
       -- that we're trying to focus, and the node that actually gets
       -- focused (at that index) if it exists
@@ -252,34 +507,41 @@ clickable child = do
 askOrientation :: Monad m => Layout t m (Dynamic t Orientation)
 askOrientation = Layout $ asks _layoutCtx_orientation
 
--- | Datatype representing constraints on a widget's size along the main axis (see 'Orientation')
-data Constraint = Constraint_Fixed Int
-                | Constraint_Min Int
-  deriving (Show, Read, Eq, Ord)
+-}
 
--- | Compute the size of each widget "@k@" based on the total set of 'Constraint's
-computeSizes
-  :: Ord k
-  => Int
-  -> Map k (a, Constraint)
-  -> Map k (a, Int)
-computeSizes available constraints =
-  let minTotal = sum $ ffor (Map.elems constraints) $ \case
-        (_, Constraint_Fixed n) -> n
-        (_, Constraint_Min n) -> n
-      leftover = max 0 (available - minTotal)
-      numStretch = Map.size $ Map.filter (isMin . snd) constraints
-      szStretch = floor $ leftover % (max numStretch 1)
-      adjustment = max 0 $ available - minTotal - szStretch * numStretch
-  in snd $ Map.mapAccum (\adj (a, c) -> case c of
-      Constraint_Fixed n -> (adj, (a, n))
-      Constraint_Min n -> (0, (a, n + szStretch + adj))) adjustment constraints
-  where
-    isMin (Constraint_Min _) = True
-    isMin _ = False
-
-computeEdges :: (Ord k) => Map k (a, Int) -> Map k (a, (Int, Int))
-computeEdges = fst . Map.foldlWithKey' (\(m, offset) k (a, sz) ->
-  (Map.insert k (a, (offset, sz)) m, sz + offset)) (Map.empty, 0)
+-- | Produces an 'Event' that navigates forward one tile when the Tab key is pressed
+-- and backward one tile when Shift+Tab is pressed.
+tabNavigation :: (Reflex t, Monad m) => VtyWidget t m (Event t Int)
+tabNavigation = do
+  fwd <- fmap (const 1) <$> key (V.KChar '\t')
+  back <- fmap (const (-1)) <$> key V.KBackTab
+  return $ leftmost [fwd, back]
 
+test :: IO ()
+test = mainWidget $ do
+  inp <- input
+  dw <- displayWidth
+  dh <- displayHeight
+  let r = Region <$> 0 <*> 0 <*> dw <*> dh
+      text' t = do
+        f <- focus
+        richText (RichTextConfig $ current $ (\x -> if x then V.withStyle V.defAttr V.bold else V.defAttr) <$> f) t
+  tab <- tabNavigation
+  rec (_, focusSeq) <- runFocus (updated sel) $ runLayout (pure Orientation_Column) r $ do -- TODO start focused
+        col (Constraint_Min 0) $ do
+          tile $ text' "asdf"
+          tile $ text' "asdf"
+          row (Constraint_Min 0) $ do
+            tile $ text' "xyz"
+            tile $ text' "xyz"
+            tile $ text' "xyz"
+            tile $ text' "xyz"
+          tile $ text' "asdf"
+          tile $ text' "asdf"
+      ix <- foldDyn (+) 0 tab
+      let sel = Seq.lookup <$> (mod <$> ix <*> (Seq.length <$> focusSeq)) <*> focusSeq -- TODO this sucks: when elements are added your focus will shift (OSet)
+  return $ fforMaybe inp $ \case
+    V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
+    _ -> Nothing
 
+  -- TODO These functions shouldn't be so higher order