@@ -1,15 +1,15 @@
1−{-|
2−Module: Reflex.Vty.Widget.Layout
3−Description: Monad transformer and tools for arranging widgets and building screen layouts
4−-}
5−{-# LANGUAGE FlexibleInstances #-}
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2+{-# LANGUAGE FlexibleContexts #-}
3+{-# LANGUAGE FlexibleInstances #-}
64{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7−{-# LANGUAGE LambdaCase #-}
8−{-# LANGUAGE MultiParamTypeClasses #-}
9−{-# LANGUAGE RecursiveDo #-}
10−{-# LANGUAGE UndecidableInstances #-}
5+{-# LANGUAGE LambdaCase #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE RecordWildCards #-}
8+{-# LANGUAGE RecursiveDo #-}
9+{-# LANGUAGE UndecidableInstances #-}
1110
12−module Reflex.Vty.Widget.Layout
11+
12+module Potato.Reflex.Vty.Widget.Layout2
1313 ( Orientation(..)
1414 , Constraint(..)
1515 , Layout
@@ -17,29 +17,48 @@ module Reflex.Vty.Widget.Layout
1717 , TileConfig(..)
1818 , tile
1919 , fixed
20+ , fixedD
2021 , stretch
22+ , stretchD
2123 , col
2224 , row
25+ , dummy
26+ , beginLayout
27+ , beginLayoutD
2328 , tabNavigation
2429 , askOrientation
2530 ) where
2631
27−import Control.Monad.NodeId (NodeId, MonadNodeId(..))
28−import Control.Monad.Reader
29−import Data.Bimap (Bimap)
30−import qualified Data.Bimap as Bimap
31−import Data.Default (Default(..))
32−import Data.Map (Map)
33−import qualified Data.Map as Map
34−import Data.Maybe (fromMaybe)
35−import Data.Monoid hiding (First(..))
36−import Data.Ratio ((%))
37−import Data.Semigroup (First(..))
38−import qualified Graphics.Vty as V
39−
40−import Reflex
41−import Reflex.Host.Class (MonadReflexCreateTrigger)
42−import Reflex.Vty.Widget
32+import Prelude
33+
34+import qualified Relude as R
35+
36+import Control.Monad.Identity (Identity (..))
37+import Control.Monad.NodeId (MonadNodeId (..), NodeId (..))
38+import Control.Monad.Reader
39+import Data.Bimap (Bimap)
40+import qualified Data.Bimap as Bimap
41+import Data.Default (Default (..))
42+import Data.Dependent.Map (DMap, DSum ((:=>)))
43+import qualified Data.Dependent.Map as DMap
44+import Data.Functor.Misc
45+import Data.Map (Map)
46+import qualified Data.Map as Map
47+import qualified Data.Map.Internal as Map (Map (Bin, Tip))
48+import Data.Maybe (fromMaybe, isJust)
49+import Data.Monoid hiding (First (..))
50+import Data.Ratio ((%))
51+import Data.Semigroup (First (..))
52+import Data.Traversable (mapAccumL)
53+import Data.Tuple.Extra
54+import qualified Graphics.Vty as V
55+import Unsafe.Coerce
56+
57+import Reflex
58+import Reflex.Host.Class (MonadReflexCreateTrigger)
59+import Reflex.Vty.Widget
60+
61+import Control.Exception (assert)
4362
4463-- | The main-axis orientation of a 'Layout' widget
4564data Orientation = Orientation_Column
@@ -48,21 +67,23 @@ data Orientation = Orientation_Column
4867
4968data LayoutSegment = LayoutSegment
5069 { _layoutSegment_offset :: Int
51− , _layoutSegment_size :: Int
70+ , _layoutSegment_size :: Int
5271 }
5372
5473data LayoutCtx t = LayoutCtx
55− { _layoutCtx_regions :: Dynamic t (Map NodeId LayoutSegment)
56− , _layoutCtx_focusDemux :: Demux t (Maybe NodeId)
57− , _layoutCtx_orientation :: Dynamic t Orientation
74+ { _layoutCtx_regions :: Dynamic t (Map NodeId LayoutSegment)
75+ , _layoutCtx_focusSelfDemux :: Demux t (Maybe NodeId)
76+ , _layoutCtx_orientation :: Dynamic t Orientation
77+ , _layoutCtx_focusChildSelector :: EventSelector t (Const2 NodeId (Maybe Int))
5878 }
5979
80+
6081-- | The Layout monad transformer keeps track of the configuration (e.g., 'Orientation') and
6182-- 'Constraint's of its child widgets, apportions vty real estate to each, and acts as a
6283-- switchboard for focus requests. See 'tile' and 'runLayout'.
6384newtype Layout t m a = Layout
64− { unLayout :: EventWriterT t (First NodeId)
65− (DynamicWriterT t (Endo [(NodeId, (Bool, Constraint))])
85+ { unLayout :: EventWriterT t (First (NodeId, Int))
86+ (DynamicWriterT t (Endo [(NodeId, (Bool, Constraint), LayoutDebugTree t, Int)])
6687 (ReaderT (LayoutCtx t)
6788 (VtyWidget t m))) a
6889 } deriving
@@ -90,70 +111,147 @@ instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (Layout t m
90111 traverseDMapWithKeyWithAdjust f m e = Layout $ traverseDMapWithKeyWithAdjust (\k v -> unLayout $ f k v) m e
91112 traverseDMapWithKeyWithAdjustWithMove f m e = Layout $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unLayout $ f k v) m e
92113
114+
115+findNearestFloor_ :: (Ord k) => k -> (k, a) -> (k, a) -> Map k a -> Maybe (k, a)
116+findNearestFloor_ target leftmost parent Map.Tip = if target < fst leftmost
117+ then Nothing -- error $ "Map.findNearestFloorSure: map has no element <= " <> show target
118+ else if target < fst parent
119+ then Just leftmost
120+ else Just parent
121+findNearestFloor_ target leftmost _ (Map.Bin _ k a l r) = if target == k
122+ then Just (k, a)
123+ else if target < k
124+ then findNearestFloor_ target leftmost (k, a) l
125+ else findNearestFloor_ target (k, a) (k, a) r
126+
127+findNearestFloor :: (Ord k) => k -> Map k a -> Maybe (k,a)
128+findNearestFloor _ Map.Tip = Nothing
129+-- TODO I don't think we need to do findMin here, just pass in (k,x) as a placeholder value
130+findNearestFloor target m@(Map.Bin _ k x _ _) = findNearestFloor_ target (Map.findMin m) (k, x) m
131+
132+
133+
134+fanFocusEv :: (Reflex t) => Behavior t (Maybe (NodeId, Int)) -> Event t (Maybe (NodeId, Int)) -> EventSelector t (Const2 NodeId (Maybe Int))
135+fanFocusEv focussed focusReqIx = fan $ attachWith attachfn focussed focusReqIx where
136+ attachfn mkv0 mkv1 = case mkv1 of
137+ Nothing -> case mkv0 of
138+ Nothing -> DMap.empty
139+ Just (k0,v0) -> DMap.fromList [Const2 k0 :=> Identity Nothing]
140+ Just (k1,v1) -> case mkv0 of
141+ Nothing -> DMap.fromList [Const2 k1 :=> Identity (Just v1)]
142+ Just (k0,v0) | k0 == k1 && v0 == v1 -> DMap.empty
143+ Just (k0,v0) | k0 == k1 -> DMap.fromList [Const2 k1 :=> Identity (Just v1)]
144+ Just (k0,v0) -> DMap.fromList [Const2 k0 :=> Identity Nothing,
145+ Const2 k1 :=> Identity (Just v1)]
146+
93147-- | Run a 'Layout' action
94−runLayout
95− :: (MonadFix m, MonadHold t m, PostBuild t m, Monad m, MonadNodeId m)
148+runLayoutD
149+ :: forall t m a. (Reflex t, MonadFix m, MonadHold t m, Monad m, MonadNodeId m)
96150 => Dynamic t Orientation -- ^ The main-axis 'Orientation' of this 'Layout'
97− -> Int -- ^ The positional index of the initially focused tile
98− -> Event t Int -- ^ An event that shifts focus by a given number of tiles
151+ -> Maybe Int -- ^ The positional index of the initially focused tile
99152 -> Layout t m a -- ^ The 'Layout' widget
100− -> VtyWidget t m a
101−runLayout ddir focus0 focusShift (Layout child) = do
153+ -> LayoutVtyWidget t m (LayoutDebugTree t, Dynamic t (Maybe Int), Int, a)
154+runLayoutD ddir mfocus0 (Layout child) = LayoutVtyWidget . ReaderT $ \focusReqIx -> mdo
102155 dw <- displayWidth
103156 dh <- displayHeight
104157 let main = ffor3 ddir dw dh $ \d w h -> case d of
105158 Orientation_Column -> h
106− Orientation_Row -> w
107− pb <- getPostBuild
108− rec ((a, focusReq), queriesEndo) <- runReaderT (runDynamicWriterT $ runEventWriterT child) $ LayoutCtx solutionMap focusDemux ddir
109− let queries = flip appEndo [] <$> queriesEndo
110− solution = ffor2 main queries $ \sz qs -> Map.fromList
111− . Map.elems
112− . computeEdges
113− . computeSizes sz
114− . fmap (fmap snd)
115− . Map.fromList
116− . zip [0::Integer ..]
117− $ qs
118− solutionMap = ffor solution $ \ss -> ffor ss $ \(offset, sz) -> LayoutSegment
119− { _layoutSegment_offset = offset
120− , _layoutSegment_size = sz
121− }
122− focusable = fmap (Bimap.fromList . zip [0..]) $
123− ffor queries $ \qs -> fforMaybe qs $ \(nodeId, (f, _)) ->
124− if f then Just nodeId else Nothing
125− adjustFocus
126− :: (Bimap Int NodeId, (Int, Maybe NodeId))
127− -> Either Int NodeId
128− -> (Int, Maybe NodeId)
129− adjustFocus (fm, (cur, _)) (Left shift) =
130− let ix = (cur + shift) `mod` (max 1 $ Bimap.size fm)
131− in (ix, Bimap.lookup ix fm)
132− adjustFocus (fm, (cur, _)) (Right goto) =
133− let ix = fromMaybe cur $ Bimap.lookupR goto fm
134− in (ix, Just goto)
135− focusChange = attachWith
136− adjustFocus
137− (current $ (,) <$> focusable <*> focussed)
138− $ leftmost [Left <$> focusShift, Left 0 <$ pb, Right . getFirst <$> focusReq]
139− -- A pair (Int, Maybe NodeId) which represents the index
140− -- that we're trying to focus, and the node that actually gets
141− -- focused (at that index) if it exists
142− focussed <- holdDyn (focus0, Nothing) focusChange
143− let focusDemux = demux $ snd <$> focussed
144− return a
159+ Orientation_Row -> w
160+ ((a, focusReq), queriesEndo) <- runReaderT (runDynamicWriterT $ runEventWriterT child) $ LayoutCtx solutionMap focusDemux ddir focusChildSelector
161+ let queries = flip appEndo [] <$> queriesEndo
162+ solution = ffor2 main queries $ \sz qs -> Map.fromList
163+ . Map.elems
164+ . computeEdges
165+ . computeSizes sz
166+ . fmap (\(nodeid,(_,constraint),_,_) -> (nodeid,constraint))
167+ . Map.fromList
168+ . zip [0::Integer ..]
169+ $ qs
170+ solutionMap = ffor solution $ \ss -> ffor ss $ \(offset, sz) -> LayoutSegment
171+ { _layoutSegment_offset = offset
172+ , _layoutSegment_size = sz
173+ }
174+
175+
176+ focusableMapAccumFn acc (nodeId, (_, _), _, nKiddos) = (nextAcc, value) where
177+ nextAcc = acc + nKiddos
178+ value = (acc, nodeId)
179+ focusable' = fmap (Bimap.fromList . snd . mapAccumL focusableMapAccumFn 0) $
180+ ffor queries $ \qs -> fforMaybe qs $ \n@(_, (f, _), _, nc) ->
181+ if f && nc > 0 then Just n else Nothing
182+ focusable = focusable'
183+
184+ -- ix is focus in self index space
185+ -- fst of return value is child node id to focus
186+ -- snd of return value is focus in child's index space
187+ findChildFocus :: Bimap Int NodeId -> Int -> Maybe (NodeId, Int)
188+ findChildFocus fm ix = findNearestFloor ix (Bimap.toMap fm) >>= \(ixl, t) -> Just (t, ix-ixl)
189+
190+ adjustFocus
191+ :: (Bimap Int NodeId)
192+ -> Either Int (NodeId, Int) -- left is self index, right is (child id, child index)
193+ -> Maybe (Int, (NodeId, Int)) -- fst is self index, snd is (child id, child index)
194+ adjustFocus fm (Left ix) = do
195+ x <- findChildFocus fm ix
196+ return (ix, x)
197+ adjustFocus fm (Right (goto, ixrel)) = do
198+ ix <- Bimap.lookupR goto fm
199+ return (ix+ixrel, (goto, ixrel))
200+
201+ focusChange = attachWith adjustFocus (current focusable)
202+ -- TODO handle Nothing case in both places (so that event produces Nothing in this case)
203+ $ leftmost [ fmap Right . fmap getFirst $ focusReq, Left <$> (fmapMaybe id focusReqIx)]
204+
205+
206+ fm0 <- sample . current $ focusable
207+ totalKiddos <- sample . current $ fmap (sum . fmap (\(_,_,_,k) -> k)) queries
208+
209+ -- brief explanation of overly complicated focus tracking
210+ -- focus is propogated in 2 ways
211+ -- focusReq (focus from bottom up)
212+ -- focusReqIx (focus from top down)
213+ -- focussed tracks the focus state
214+ -- focusDemux is used to pass the 'pane's of immediate children
215+
216+ -- fst is index we want to focus in self index space, snd is node id we want to focus
217+ focussed :: Dynamic t (Maybe (Int, (NodeId, Int))) <- holdDyn initialFocus (focusChange)
218+ let
219+ initialFocus :: Maybe (Int, (NodeId, Int)) = do
220+ f0 <- mfocus0
221+ cf0 <- findChildFocus fm0 f0
222+ return (f0, cf0)
223+
224+ focussedForDemux = fmap (fmap (fst . snd)) focussed
225+ focusDemux :: Demux t (Maybe NodeId) = demux focussedForDemux
226+
227+ focusReqWithNodeId :: Event t (Maybe (NodeId, Int))
228+ focusReqWithNodeId = attachWith (\fm mix -> mix >>= \ix -> findChildFocus fm ix) (current focusable) (focusReqIx)
229+ focusChildSelector = fanFocusEv (current $ fmap (fmap snd) focussed) (focusReqWithNodeId)
230+
231+ return (emptyLayoutDebugTree, (fmap (fmap fst)) focussed, totalKiddos, a)
232+
233+-- | Run a 'Layout' action
234+runLayout
235+ :: (MonadFix m, MonadHold t m, PostBuild t m, Monad m, MonadNodeId m)
236+ => Dynamic t Orientation -- ^ The main-axis 'Orientation' of this 'Layout'
237+ -> Maybe Int -- ^ The positional index of the initially focused tile
238+ -> Layout t m a -- ^ The 'Layout' widget
239+ -> LayoutVtyWidget t m a
240+runLayout ddir mfocus0 layout = fmap (\(_,_,_,a)->a) $ runLayoutD ddir mfocus0 layout
145241
146242-- | Tiles are the basic building blocks of 'Layout' widgets. Each tile has a constraint
147243-- on its size and ability to grow and on whether it can be focused. It also allows its child
148244-- widget to request focus.
149245tile
150− :: (Reflex t, Monad m, MonadNodeId m)
246+ :: forall t b widget x m a. (Reflex t, IsLayoutReturn t b a, IsLayoutVtyWidget widget t m, Monad m, MonadFix m, MonadNodeId m)
151247 => TileConfig t -- ^ The tile's configuration
152− -> VtyWidget t m (Event t x, a) -- ^ A child widget. The 'Event' that it returns is used to request that it be focused.
248+ -> widget t m (Event t x, b) -- ^ A child widget. The 'Event' that it returns is used to request that it be focused.
153249 -> Layout t m a
154−tile (TileConfig con focusable) child = do
250+tile (TileConfig con focusable) child = mdo
155251 nodeId <- getNextNodeId
156− Layout $ tellDyn $ ffor2 con focusable $ \c f -> Endo ((nodeId, (f, c)):)
252+ -- by calling getLayoutTree/getLayoutNumChildren here, we store the children's layout info inside the DynamicWriter
253+ -- runLayoutD will extract this info later
254+ Layout $ tellDyn $ ffor2 con focusable $ \c f -> Endo ((nodeId, (f, c), getLayoutTree @t @b @a b, nKiddos):)
157255 seg <- Layout $ asks $
158256 fmap (Map.findWithDefault (LayoutSegment 0 0) nodeId) . _layoutCtx_regions
159257 dw <- displayWidth
@@ -176,58 +274,92 @@ tile (TileConfig con focusable) child = do
176274 Orientation_Column -> _layoutSegment_size s
177275 Orientation_Row -> c
178276 }
179− focussed <- Layout $ asks _layoutCtx_focusDemux
180− (focusReq, a) <- Layout $ lift $ lift $ lift $
181− pane reg (demuxed focussed $ Just nodeId) $ child
182− Layout $ tellEvent $ First nodeId <$ focusReq
183− return a
277+ let nKiddos = getLayoutNumChildren @t @b @a b
278+
279+ focusChildSelector <- Layout $ asks _layoutCtx_focusChildSelector
280+ let focusChildEv = select focusChildSelector (Const2 nodeId)
281+ focussed <- Layout $ asks _layoutCtx_focusSelfDemux
282+ (focusReq, b) <- Layout $ lift $ lift $ lift $
283+ pane reg (demuxed focussed $ Just nodeId) $ runIsLayoutVtyWidget child (focusChildEv)
284+ Layout $ tellEvent $ if nKiddos > 0
285+ then fmap (First . swap) $ attachPromptlyDyn (fmap (fromMaybe 0) $ getLayoutFocussedDyn @t @b @a b) (nodeId <$ focusReq)
286+ else never
287+ return $ getLayoutResult @t b
288+
184289
185290-- | Configuration options for and constraints on 'tile'
186291data TileConfig t = TileConfig
187292 { _tileConfig_constraint :: Dynamic t Constraint
188293 -- ^ 'Constraint' on the tile's size
189− , _tileConfig_focusable :: Dynamic t Bool
294+ , _tileConfig_focusable :: Dynamic t Bool
190295 -- ^ Whether the tile is focusable
191296 }
192297
298+
193299instance Reflex t => Default (TileConfig t) where
194300 def = TileConfig (pure $ Constraint_Min 0) (pure True)
195301
196302-- | A 'tile' of a fixed size that is focusable and gains focus on click
303+fixed'
304+ :: (Reflex t, IsLayoutReturn t b a, IsLayoutVtyWidget widget t m, Monad m, MonadFix m, MonadNodeId m)
305+ => Dynamic t Int
306+ -> widget t m b
307+ -> Layout t m a
308+fixed' sz = tile (def { _tileConfig_constraint = Constraint_Fixed <$> sz }) . clickable
309+
310+fixedD
311+ :: (Reflex t, Monad m, MonadFix m, MonadNodeId m)
312+ => Dynamic t Int
313+ -> LayoutVtyWidget t m (LayoutDebugTree t, Dynamic t (Maybe Int), Int, a)
314+ -> Layout t m a
315+fixedD = fixed'
316+
197317fixed
198− :: (Reflex t, Monad m, MonadNodeId m)
318+ :: (Reflex t, IsLayoutVtyWidget widget t m, Monad m, MonadFix m, MonadNodeId m)
199319 => Dynamic t Int
200− -> VtyWidget t m a
320+ -> widget t m a
201321 -> Layout t m a
202−fixed sz = tile (def { _tileConfig_constraint = Constraint_Fixed <$> sz }) . clickable
322+fixed = fixed'
203323
204324-- | A 'tile' that can stretch (i.e., has no fixed size) and has a minimum size of 0.
205325-- This tile is focusable and gains focus on click.
326+stretch'
327+ :: (Reflex t, IsLayoutReturn t b a, IsLayoutVtyWidget widget t m, Monad m, MonadFix m, MonadNodeId m)
328+ => widget t m b
329+ -> Layout t m a
330+stretch' = tile def . clickable
331+
332+stretchD
333+ :: (Reflex t, Monad m, MonadFix m, MonadNodeId m)
334+ => LayoutVtyWidget t m (LayoutDebugTree t, Dynamic t (Maybe Int), Int, a)
335+ -> Layout t m a
336+stretchD = stretch'
337+
206338stretch
207− :: (Reflex t, Monad m, MonadNodeId m)
208− => VtyWidget t m a
339+ :: (Reflex t, IsLayoutVtyWidget widget t m, Monad m, MonadFix m, MonadNodeId m)
340+ => widget t m a
209341 -> Layout t m a
210−stretch = tile def . clickable
342+stretch = stretch'
211343
212344-- | A version of 'runLayout' that arranges tiles in a column and uses 'tabNavigation' to
213345-- change tile focus.
214346col
215347 :: (MonadFix m, MonadHold t m, PostBuild t m, MonadNodeId m)
216348 => Layout t m a
217− -> VtyWidget t m a
218−col child = do
219− nav <- tabNavigation
220− runLayout (pure Orientation_Column) 0 nav child
349+ -> LayoutVtyWidget t m (LayoutDebugTree t, Dynamic t (Maybe Int), Int, a)
350+col child = runLayoutD (pure Orientation_Column) (Just 0) child
221351
222352-- | A version of 'runLayout' that arranges tiles in a row and uses 'tabNavigation' to
223353-- change tile focus.
224354row
225355 :: (MonadFix m, MonadHold t m, PostBuild t m, MonadNodeId m)
226356 => Layout t m a
227− -> VtyWidget t m a
228−row child = do
229− nav <- tabNavigation
230− runLayout (pure Orientation_Row) 0 nav child
357+ -> LayoutVtyWidget t m (LayoutDebugTree t, Dynamic t (Maybe Int), Int, a)
358+row child = runLayoutD (pure Orientation_Row) (Just 0) child
359+
360+-- | Testing placeholder DELETE
361+dummy :: (Reflex t, Monad m) => LayoutVtyWidget t m (LayoutDebugTree t, Dynamic t (Maybe Int), Int, ())
362+dummy = return (emptyLayoutDebugTree, constDyn Nothing, 0, ())
231363
232364-- | Produces an 'Event' that navigates forward one tile when the Tab key is pressed
233365-- and backward one tile when Shift+Tab is pressed.
@@ -240,14 +372,33 @@ tabNavigation = do
240372-- | Captures the click event in a 'VtyWidget' context and returns it. Useful for
241373-- requesting focus when using 'tile'.
242374clickable
243− :: (Reflex t, Monad m)
244− => VtyWidget t m a
245− -> VtyWidget t m (Event t (), a)
246−clickable child = do
375+ :: (Reflex t, IsLayoutVtyWidget widget t m, Monad m)
376+ => widget t m a
377+ -> LayoutVtyWidget t m (Event t (), a)
378+clickable child = LayoutVtyWidget . ReaderT $ \focusEv -> do
247379 click <- mouseDown V.BLeft
248− a <- child
380+ a <- runIsLayoutVtyWidget child focusEv
249381 return (() <$ click, a)
250382
383+beginLayoutD ::
384+ forall m t a. (MonadHold t m, PostBuild t m, MonadFix m, MonadNodeId m)
385+ => LayoutVtyWidget t m (LayoutDebugTree t, Dynamic t (Maybe Int), Int, a)
386+ -> VtyWidget t m (LayoutDebugTree t, a)
387+beginLayoutD child = mdo
388+ -- TODO consider unfocusing if this loses focus
389+ --focussed <- focus
390+ tabEv <- tabNavigation
391+ let focusChildEv = fmap (\(mcur, shift) -> maybe (Just 0) (\cur -> Just $ (shift + cur) `mod` totalKiddos) mcur) (attach (current indexDyn) tabEv)
392+ (ldt, indexDyn, totalKiddos, a) <- runIsLayoutVtyWidget child focusChildEv
393+ return (ldt, a)
394+
395+-- |
396+beginLayout ::
397+ forall m t b a. (MonadHold t m, PostBuild t m, MonadFix m, MonadNodeId m)
398+ => LayoutVtyWidget t m (LayoutDebugTree t, Dynamic t (Maybe Int), Int, a)
399+ -> VtyWidget t m a
400+beginLayout = fmap snd . beginLayoutD
401+
251402-- | Retrieve the current orientation of a 'Layout'
252403askOrientation :: Monad m => Layout t m (Dynamic t Orientation)
253404askOrientation = Layout $ asks _layoutCtx_orientation
@@ -273,13 +424,74 @@ computeSizes available constraints =
273424 adjustment = max 0 $ available - minTotal - szStretch * numStretch
274425 in snd $ Map.mapAccum (\adj (a, c) -> case c of
275426 Constraint_Fixed n -> (adj, (a, n))
276− Constraint_Min n -> (0, (a, n + szStretch + adj))) adjustment constraints
427+ Constraint_Min n -> (0, (a, n + szStretch + adj))) adjustment constraints
277428 where
278429 isMin (Constraint_Min _) = True
279− isMin _ = False
430+ isMin _ = False
280431
281432computeEdges :: (Ord k) => Map k (a, Int) -> Map k (a, (Int, Int))
282433computeEdges = fst . Map.foldlWithKey' (\(m, offset) k (a, sz) ->
283434 (Map.insert k (a, (offset, sz)) m, sz + offset)) (Map.empty, 0)
284435
285436
437+
438+
439+
440+
441+
442+
443+-- TODO should prob be (Branch [LayoutDebugTree] | Leaf PosDim
444+-- but it's weird cuz a leaf node won't know it's PosDim until combined with a Region...
445+data LayoutDebugTree t = LayoutDebugTree_Branch [LayoutDebugTree t] | LayoutDebugTree_Leaf
446+
447+emptyLayoutDebugTree :: LayoutDebugTree t
448+emptyLayoutDebugTree = LayoutDebugTree_Leaf
449+
450+class IsLayoutReturn t b a where
451+ getLayoutResult :: b -> a
452+ getLayoutNumChildren :: b -> Int
453+ getLayoutFocussedDyn :: b -> Dynamic t (Maybe Int)
454+ getLayoutTree :: b -> LayoutDebugTree t
455+
456+
457+instance IsLayoutReturn t (LayoutDebugTree t, Dynamic t (Maybe Int), Int, a) a where
458+ getLayoutResult (_,_,_,a) = a
459+ getLayoutNumChildren (_,_,d,_) = d
460+ getLayoutFocussedDyn (_,d,_,_) = d
461+ getLayoutTree (tree,_,_,_) = tree
462+
463+instance Reflex t => IsLayoutReturn t a a where
464+ getLayoutResult = id
465+ getLayoutNumChildren _ = 1
466+ getLayoutFocussedDyn _ = constDyn Nothing
467+ getLayoutTree _ = emptyLayoutDebugTree
468+
469+class IsLayoutVtyWidget l t (m :: * -> *) where
470+ runIsLayoutVtyWidget :: l t m a -> Event t (Maybe Int) -> VtyWidget t m a
471+
472+newtype LayoutVtyWidget t m a = LayoutVtyWidget {
473+ unLayoutVtyWidget :: ReaderT (Event t (Maybe Int)) (VtyWidget t m) a
474+ } deriving
475+ ( Functor
476+ , Applicative
477+ , Monad
478+ , MonadHold t
479+ , MonadSample t
480+ , MonadFix
481+ , TriggerEvent t
482+ , PerformEvent t
483+ , NotReady t
484+ , MonadReflexCreateTrigger t
485+ , HasDisplaySize t
486+ , MonadNodeId
487+ , PostBuild t
488+ )
489+
490+instance MonadTrans (LayoutVtyWidget t) where
491+ lift x = LayoutVtyWidget $ lift $ lift x
492+
493+instance IsLayoutVtyWidget VtyWidget t m where
494+ runIsLayoutVtyWidget w _ = w
495+
496+instance IsLayoutVtyWidget LayoutVtyWidget t m where
497+ runIsLayoutVtyWidget = runReaderT . unLayoutVtyWidget