@@ -1,15 +1,15 @@
1−{-|
1+{-# LANGUAGE AllowAmbiguousTypes #-}
2−Module: Reflex.Vty.Widget.Layout
2+{-# LANGUAGE FlexibleContexts #-}
3−Description: Monad transformer and tools for arranging widgets and building screen layouts
5−{-# LANGUAGE FlexibleInstances #-}
3+{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE GeneralizedNewtypeDeriving #-}
4{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7−{-# LANGUAGE LambdaCase #-}
5+{-# LANGUAGE LambdaCase #-}
8−{-# LANGUAGE MultiParamTypeClasses #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE RecordWildCards #-}
9−{-# LANGUAGE RecursiveDo #-}
8+{-# LANGUAGE RecursiveDo #-}
10−{-# LANGUAGE UndecidableInstances #-}
9+{-# LANGUAGE UndecidableInstances #-}
12−module Reflex.Vty.Widget.Layout
12+module Potato.Reflex.Vty.Widget.Layout2
13 ( Orientation(..)
13 ( Orientation(..)
14 , Constraint(..)
14 , Constraint(..)
@@ -17,29 +17,48 @@ module Reflex.Vty.Widget.Layout
17 , TileConfig(..)
17 , TileConfig(..)
23 , tabNavigation
28 , tabNavigation
24 , askOrientation
29 , askOrientation
34+import qualified Relude as R
36+import Control.Monad.Identity (Identity (..))
27−import Control.Monad.NodeId (NodeId, MonadNodeId(..))
37+import Control.Monad.NodeId (MonadNodeId (..), NodeId (..))
28−import Control.Monad.Reader
38+import Control.Monad.Reader
29−import Data.Bimap (Bimap)
39+import Data.Bimap (Bimap)
30−import qualified Data.Bimap as Bimap
40+import qualified Data.Bimap as Bimap
31−import Data.Default (Default(..))
41+import Data.Default (Default (..))
32−import Data.Map (Map)
42+import Data.Dependent.Map (DMap, DSum ((:=>)))
43+import qualified Data.Dependent.Map as DMap
44+import Data.Functor.Misc
33−import qualified Data.Map as Map
46+import qualified Data.Map as Map
47+import qualified Data.Map.Internal as Map (Map (Bin, Tip))
34−import Data.Maybe (fromMaybe)
48+import Data.Maybe (fromMaybe, isJust)
35−import Data.Monoid hiding (First(..))
49+import Data.Monoid hiding (First (..))
36−import Data.Ratio ((%))
50+import Data.Ratio ((%))
37−import Data.Semigroup (First(..))
51+import Data.Semigroup (First (..))
52+import Data.Traversable (mapAccumL)
53+import Data.Tuple.Extra
38−import qualified Graphics.Vty as V
54+import qualified Graphics.Vty as V
39−
55+import Unsafe.Coerce
40−import Reflex
57+import Reflex
41−import Reflex.Host.Class (MonadReflexCreateTrigger)
58+import Reflex.Host.Class (MonadReflexCreateTrigger)
42−import Reflex.Vty.Widget
59+import Reflex.Vty.Widget
61+import Control.Exception (assert)
44-- | The main-axis orientation of a 'Layout' widget
63-- | The main-axis orientation of a 'Layout' widget
45data Orientation = Orientation_Column
64data Orientation = Orientation_Column
@@ -48,21 +67,23 @@ data Orientation = Orientation_Column
49data LayoutSegment = LayoutSegment
68data LayoutSegment = LayoutSegment
50 { _layoutSegment_offset :: Int
69 { _layoutSegment_offset :: Int
51− , _layoutSegment_size :: Int
70+ , _layoutSegment_size :: Int
54data LayoutCtx t = LayoutCtx
73data LayoutCtx t = LayoutCtx
55− { _layoutCtx_regions :: Dynamic t (Map NodeId LayoutSegment)
74+ { _layoutCtx_regions :: Dynamic t (Map NodeId LayoutSegment)
56− , _layoutCtx_focusDemux :: Demux t (Maybe NodeId)
75+ , _layoutCtx_focusSelfDemux :: Demux t (Maybe NodeId)
57− , _layoutCtx_orientation :: Dynamic t Orientation
76+ , _layoutCtx_orientation :: Dynamic t Orientation
77+ , _layoutCtx_focusChildSelector :: EventSelector t (Const2 NodeId (Maybe Int))
60-- | The Layout monad transformer keeps track of the configuration (e.g., 'Orientation') and
81-- | The Layout monad transformer keeps track of the configuration (e.g., 'Orientation') and
61-- 'Constraint's of its child widgets, apportions vty real estate to each, and acts as a
82-- 'Constraint's of its child widgets, apportions vty real estate to each, and acts as a
62-- switchboard for focus requests. See 'tile' and 'runLayout'.
83-- switchboard for focus requests. See 'tile' and 'runLayout'.
63newtype Layout t m a = Layout
84newtype Layout t m a = Layout
64− { unLayout :: EventWriterT t (First NodeId)
85+ { unLayout :: EventWriterT t (First (NodeId, Int))
65− (DynamicWriterT t (Endo [(NodeId, (Bool, Constraint))])
86+ (DynamicWriterT t (Endo [(NodeId, (Bool, Constraint), LayoutDebugTree t, Int)])
66 (ReaderT (LayoutCtx t)
87 (ReaderT (LayoutCtx t)
67 (VtyWidget t m))) a
88 (VtyWidget t m))) a
68 } deriving
89 } deriving
@@ -90,70 +111,147 @@ instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (Layout t m
90 traverseDMapWithKeyWithAdjust f m e = Layout $ traverseDMapWithKeyWithAdjust (\k v -> unLayout $ f k v) m e
111 traverseDMapWithKeyWithAdjust f m e = Layout $ traverseDMapWithKeyWithAdjust (\k v -> unLayout $ f k v) m e
91 traverseDMapWithKeyWithAdjustWithMove f m e = Layout $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unLayout $ f k v) m e
112 traverseDMapWithKeyWithAdjustWithMove f m e = Layout $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unLayout $ f k v) m e
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
121+findNearestFloor_ target leftmost _ (Map.Bin _ k a l r) = if target == k
124+ then findNearestFloor_ target leftmost (k, a) l
125+ else findNearestFloor_ target (k, a) (k, a) r
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
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)]
93-- | Run a 'Layout' action
147-- | Run a 'Layout' action
94−runLayout
148+runLayoutD
95− :: (MonadFix m, MonadHold t m, PostBuild t m, Monad m, MonadNodeId m)
149+ :: forall t m a. (Reflex t, MonadFix m, MonadHold t m, Monad m, MonadNodeId m)
96 => Dynamic t Orientation -- ^ The main-axis 'Orientation' of this 'Layout'
150 => Dynamic t Orientation -- ^ The main-axis 'Orientation' of this 'Layout'
97− -> Int -- ^ The positional index of the initially focused tile
151+ -> Maybe Int -- ^ The positional index of the initially focused tile
98− -> Event t Int -- ^ An event that shifts focus by a given number of tiles
99 -> Layout t m a -- ^ The 'Layout' widget
152 -> Layout t m a -- ^ The 'Layout' widget
100− -> VtyWidget t m a
153+ -> LayoutVtyWidget t m (LayoutDebugTree t, Dynamic t (Maybe Int), Int, a)
101−runLayout ddir focus0 focusShift (Layout child) = do
154+runLayoutD ddir mfocus0 (Layout child) = LayoutVtyWidget . ReaderT $ \focusReqIx -> mdo
102 dw <- displayWidth
155 dw <- displayWidth
103 dh <- displayHeight
156 dh <- displayHeight
104 let main = ffor3 ddir dw dh $ \d w h -> case d of
157 let main = ffor3 ddir dw dh $ \d w h -> case d of
105 Orientation_Column -> h
158 Orientation_Column -> h
106− Orientation_Row -> w
159+ Orientation_Row -> w
108− rec ((a, focusReq), queriesEndo) <- runReaderT (runDynamicWriterT $ runEventWriterT child) $ LayoutCtx solutionMap focusDemux ddir
160+ ((a, focusReq), queriesEndo) <- runReaderT (runDynamicWriterT $ runEventWriterT child) $ LayoutCtx solutionMap focusDemux ddir focusChildSelector
109− let queries = flip appEndo [] <$> queriesEndo
161+ let queries = flip appEndo [] <$> queriesEndo
110− solution = ffor2 main queries $ \sz qs -> Map.fromList
162+ solution = ffor2 main queries $ \sz qs -> Map.fromList
111− . Map.elems
163+ . Map.elems
112− . computeEdges
164+ . computeEdges
113− . computeSizes sz
165+ . computeSizes sz
114− . fmap (fmap snd)
166+ . fmap (\(nodeid,(_,constraint),_,_) -> (nodeid,constraint))
115− . Map.fromList
167+ . Map.fromList
116− . zip [0::Integer ..]
168+ . zip [0::Integer ..]
118− solutionMap = ffor solution $ \ss -> ffor ss $ \(offset, sz) -> LayoutSegment
170+ solutionMap = ffor solution $ \ss -> ffor ss $ \(offset, sz) -> LayoutSegment
119− { _layoutSegment_offset = offset
171+ { _layoutSegment_offset = offset
120− , _layoutSegment_size = sz
172+ , _layoutSegment_size = sz
176+ focusableMapAccumFn acc (nodeId, (_, _), _, nKiddos) = (nextAcc, value) where
177+ nextAcc = acc + nKiddos
178+ value = (acc, nodeId)
122− focusable = fmap (Bimap.fromList . zip [0..]) $
179+ focusable' = fmap (Bimap.fromList . snd . mapAccumL focusableMapAccumFn 0) $
123− ffor queries $ \qs -> fforMaybe qs $ \(nodeId, (f, _)) ->
180+ ffor queries $ \qs -> fforMaybe qs $ \n@(_, (f, _), _, nc) ->
124− if f then Just nodeId else Nothing
181+ if f && nc > 0 then Just n else Nothing
125− adjustFocus
182+ focusable = focusable'
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
126− :: (Bimap Int NodeId, (Int, Maybe NodeId))
187+ findChildFocus :: Bimap Int NodeId -> Int -> Maybe (NodeId, Int)
188+ findChildFocus fm ix = findNearestFloor ix (Bimap.toMap fm) >>= \(ixl, t) -> Just (t, ix-ixl)
191+ :: (Bimap Int NodeId)
127− -> Either Int NodeId
192+ -> Either Int (NodeId, Int) -- left is self index, right is (child id, child index)
128− -> (Int, Maybe NodeId)
193+ -> Maybe (Int, (NodeId, Int)) -- fst is self index, snd is (child id, child index)
129− adjustFocus (fm, (cur, _)) (Left shift) =
194+ adjustFocus fm (Left ix) = do
130− let ix = (cur + shift) `mod` (max 1 $ Bimap.size fm)
195+ x <- findChildFocus fm ix
131− in (ix, Bimap.lookup ix fm)
196+ return (ix, x)
132− adjustFocus (fm, (cur, _)) (Right goto) =
197+ adjustFocus fm (Right (goto, ixrel)) = do
133− let ix = fromMaybe cur $ Bimap.lookupR goto fm
198+ ix <- Bimap.lookupR goto fm
134− in (ix, Just goto)
199+ return (ix+ixrel, (goto, ixrel))
135− focusChange = attachWith
201+ focusChange = attachWith adjustFocus (current focusable)
136− adjustFocus
202+ -- TODO handle Nothing case in both places (so that event produces Nothing in this case)
137− (current $ (,) <$> focusable <*> focussed)
203+ $ leftmost [ fmap Right . fmap getFirst $ focusReq, Left <$> (fmapMaybe id focusReqIx)]
138− $ leftmost [Left <$> focusShift, Left 0 <$ pb, Right . getFirst <$> focusReq]
204+
139− -- A pair (Int, Maybe NodeId) which represents the index
205+
140− -- that we're trying to focus, and the node that actually gets
206+ fm0 <- sample . current $ focusable
141− -- focused (at that index) if it exists
207+ totalKiddos <- sample . current $ fmap (sum . fmap (\(_,_,_,k) -> k)) queries
142− focussed <- holdDyn (focus0, Nothing) focusChange
208+
143− let focusDemux = demux $ snd <$> focussed
209+ -- brief explanation of overly complicated focus tracking
144− return a
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
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)
219+ initialFocus :: Maybe (Int, (NodeId, Int)) = do
221+ cf0 <- findChildFocus fm0 f0
224+ focussedForDemux = fmap (fmap (fst . snd)) focussed
225+ focusDemux :: Demux t (Maybe NodeId) = demux focussedForDemux
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)
231+ return (emptyLayoutDebugTree, (fmap (fmap fst)) focussed, totalKiddos, a)
233+-- | Run a 'Layout' action
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
146-- | Tiles are the basic building blocks of 'Layout' widgets. Each tile has a constraint
242-- | Tiles are the basic building blocks of 'Layout' widgets. Each tile has a constraint
147-- on its size and ability to grow and on whether it can be focused. It also allows its child
243-- on its size and ability to grow and on whether it can be focused. It also allows its child
148-- widget to request focus.
244-- widget to request focus.
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)
151 => TileConfig t -- ^ The tile's configuration
247 => 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.
153 -> Layout t m a
249 -> Layout t m a
154−tile (TileConfig con focusable) child = do
250+tile (TileConfig con focusable) child = mdo
155 nodeId <- getNextNodeId
251 nodeId <- getNextNodeId
252+ -- by calling getLayoutTree/getLayoutNumChildren here, we store the children's layout info inside the DynamicWriter
253+ -- runLayoutD will extract this info later
156− Layout $ tellDyn $ ffor2 con focusable $ \c f -> Endo ((nodeId, (f, c)):)
254+ Layout $ tellDyn $ ffor2 con focusable $ \c f -> Endo ((nodeId, (f, c), getLayoutTree @t @b @a b, nKiddos):)
157 seg <- Layout $ asks $
255 seg <- Layout $ asks $
158 fmap (Map.findWithDefault (LayoutSegment 0 0) nodeId) . _layoutCtx_regions
256 fmap (Map.findWithDefault (LayoutSegment 0 0) nodeId) . _layoutCtx_regions
159 dw <- displayWidth
257 dw <- displayWidth
@@ -176,58 +274,92 @@ tile (TileConfig con focusable) child = do
176 Orientation_Column -> _layoutSegment_size s
274 Orientation_Column -> _layoutSegment_size s
177 Orientation_Row -> c
275 Orientation_Row -> c
277+ let nKiddos = getLayoutNumChildren @t @b @a b
279+ focusChildSelector <- Layout $ asks _layoutCtx_focusChildSelector
280+ let focusChildEv = select focusChildSelector (Const2 nodeId)
179− focussed <- Layout $ asks _layoutCtx_focusDemux
281+ focussed <- Layout $ asks _layoutCtx_focusSelfDemux
180− (focusReq, a) <- Layout $ lift $ lift $ lift $
282+ (focusReq, b) <- Layout $ lift $ lift $ lift $
181− pane reg (demuxed focussed $ Just nodeId) $ child
283+ pane reg (demuxed focussed $ Just nodeId) $ runIsLayoutVtyWidget child (focusChildEv)
182− Layout $ tellEvent $ First nodeId <$ focusReq
284+ Layout $ tellEvent $ if nKiddos > 0
285+ then fmap (First . swap) $ attachPromptlyDyn (fmap (fromMaybe 0) $ getLayoutFocussedDyn @t @b @a b) (nodeId <$ focusReq)
183− return a
287+ return $ getLayoutResult @t b
185-- | Configuration options for and constraints on 'tile'
290-- | Configuration options for and constraints on 'tile'
186data TileConfig t = TileConfig
291data TileConfig t = TileConfig
187 { _tileConfig_constraint :: Dynamic t Constraint
292 { _tileConfig_constraint :: Dynamic t Constraint
188 -- ^ 'Constraint' on the tile's size
293 -- ^ 'Constraint' on the tile's size
189− , _tileConfig_focusable :: Dynamic t Bool
294+ , _tileConfig_focusable :: Dynamic t Bool
190 -- ^ Whether the tile is focusable
295 -- ^ Whether the tile is focusable
193instance Reflex t => Default (TileConfig t) where
299instance Reflex t => Default (TileConfig t) where
194 def = TileConfig (pure $ Constraint_Min 0) (pure True)
300 def = TileConfig (pure $ Constraint_Min 0) (pure True)
196-- | A 'tile' of a fixed size that is focusable and gains focus on click
302-- | A 'tile' of a fixed size that is focusable and gains focus on click
304+ :: (Reflex t, IsLayoutReturn t b a, IsLayoutVtyWidget widget t m, Monad m, MonadFix m, MonadNodeId m)
308+fixed' sz = tile (def { _tileConfig_constraint = Constraint_Fixed <$> sz }) . clickable
311+ :: (Reflex t, Monad m, MonadFix m, MonadNodeId m)
313+ -> LayoutVtyWidget t m (LayoutDebugTree t, Dynamic t (Maybe Int), Int, a)
198− :: (Reflex t, Monad m, MonadNodeId m)
318+ :: (Reflex t, IsLayoutVtyWidget widget t m, Monad m, MonadFix m, MonadNodeId m)
199 => Dynamic t Int
319 => Dynamic t Int
200− -> VtyWidget t m a
320+ -> widget t m a
201 -> Layout t m a
321 -> Layout t m a
202−fixed sz = tile (def { _tileConfig_constraint = Constraint_Fixed <$> sz }) . clickable
322+fixed = fixed'
204-- | A 'tile' that can stretch (i.e., has no fixed size) and has a minimum size of 0.
324-- | A 'tile' that can stretch (i.e., has no fixed size) and has a minimum size of 0.
205-- This tile is focusable and gains focus on click.
325-- This tile is focusable and gains focus on click.
327+ :: (Reflex t, IsLayoutReturn t b a, IsLayoutVtyWidget widget t m, Monad m, MonadFix m, MonadNodeId m)
330+stretch' = tile def . clickable
333+ :: (Reflex t, Monad m, MonadFix m, MonadNodeId m)
334+ => LayoutVtyWidget t m (LayoutDebugTree t, Dynamic t (Maybe Int), Int, a)
207− :: (Reflex t, Monad m, MonadNodeId m)
339+ :: (Reflex t, IsLayoutVtyWidget widget t m, Monad m, MonadFix m, MonadNodeId m)
208− => VtyWidget t m a
340+ => widget t m a
209 -> Layout t m a
341 -> Layout t m a
210−stretch = tile def . clickable
342+stretch = stretch'
212-- | A version of 'runLayout' that arranges tiles in a column and uses 'tabNavigation' to
344-- | A version of 'runLayout' that arranges tiles in a column and uses 'tabNavigation' to
213-- change tile focus.
345-- change tile focus.
215 :: (MonadFix m, MonadHold t m, PostBuild t m, MonadNodeId m)
347 :: (MonadFix m, MonadHold t m, PostBuild t m, MonadNodeId m)
216 => Layout t m a
348 => Layout t m a
217− -> VtyWidget t m a
349+ -> LayoutVtyWidget t m (LayoutDebugTree t, Dynamic t (Maybe Int), Int, a)
219− nav <- tabNavigation
220− runLayout (pure Orientation_Column) 0 nav child
350+col child = runLayoutD (pure Orientation_Column) (Just 0) child
222-- | A version of 'runLayout' that arranges tiles in a row and uses 'tabNavigation' to
352-- | A version of 'runLayout' that arranges tiles in a row and uses 'tabNavigation' to
223-- change tile focus.
353-- change tile focus.
225 :: (MonadFix m, MonadHold t m, PostBuild t m, MonadNodeId m)
355 :: (MonadFix m, MonadHold t m, PostBuild t m, MonadNodeId m)
226 => Layout t m a
356 => Layout t m a
227− -> VtyWidget t m a
357+ -> LayoutVtyWidget t m (LayoutDebugTree t, Dynamic t (Maybe Int), Int, a)
229− nav <- tabNavigation
230− runLayout (pure Orientation_Row) 0 nav child
358+row child = runLayoutD (pure Orientation_Row) (Just 0) child
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, ())
232-- | Produces an 'Event' that navigates forward one tile when the Tab key is pressed
364-- | Produces an 'Event' that navigates forward one tile when the Tab key is pressed
233-- and backward one tile when Shift+Tab is pressed.
365-- and backward one tile when Shift+Tab is pressed.
@@ -240,14 +372,33 @@ tabNavigation = do
240-- | Captures the click event in a 'VtyWidget' context and returns it. Useful for
372-- | Captures the click event in a 'VtyWidget' context and returns it. Useful for
241-- requesting focus when using 'tile'.
373-- requesting focus when using 'tile'.
243− :: (Reflex t, Monad m)
375+ :: (Reflex t, IsLayoutVtyWidget widget t m, Monad m)
244− => VtyWidget t m a
376+ => widget t m a
245− -> VtyWidget t m (Event t (), a)
377+ -> LayoutVtyWidget t m (Event t (), a)
246−clickable child = do
378+clickable child = LayoutVtyWidget . ReaderT $ \focusEv -> do
247 click <- mouseDown V.BLeft
379 click <- mouseDown V.BLeft
248− a <- child
380+ a <- runIsLayoutVtyWidget child focusEv
249 return (() <$ click, a)
381 return (() <$ click, a)
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
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
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)
400+beginLayout = fmap snd . beginLayoutD
251-- | Retrieve the current orientation of a 'Layout'
402-- | Retrieve the current orientation of a 'Layout'
252askOrientation :: Monad m => Layout t m (Dynamic t Orientation)
403askOrientation :: Monad m => Layout t m (Dynamic t Orientation)
253askOrientation = Layout $ asks _layoutCtx_orientation
404askOrientation = Layout $ asks _layoutCtx_orientation
@@ -273,13 +424,74 @@ computeSizes available constraints =
273 adjustment = max 0 $ available - minTotal - szStretch * numStretch
424 adjustment = max 0 $ available - minTotal - szStretch * numStretch
274 in snd $ Map.mapAccum (\adj (a, c) -> case c of
425 in snd $ Map.mapAccum (\adj (a, c) -> case c of
275 Constraint_Fixed n -> (adj, (a, n))
426 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
278 isMin (Constraint_Min _) = True
429 isMin (Constraint_Min _) = True
279− isMin _ = False
430+ isMin _ = False
281computeEdges :: (Ord k) => Map k (a, Int) -> Map k (a, (Int, Int))
432computeEdges :: (Ord k) => Map k (a, Int) -> Map k (a, (Int, Int))
282computeEdges = fst . Map.foldlWithKey' (\(m, offset) k (a, sz) ->
433computeEdges = fst . Map.foldlWithKey' (\(m, offset) k (a, sz) ->
283 (Map.insert k (a, (offset, sz)) m, sz + offset)) (Map.empty, 0)
434 (Map.insert k (a, (offset, sz)) m, sz + offset)) (Map.empty, 0)
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
447+emptyLayoutDebugTree :: LayoutDebugTree t
448+emptyLayoutDebugTree = LayoutDebugTree_Leaf
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
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
463+instance Reflex t => IsLayoutReturn t a a where
464+ getLayoutResult = id
465+ getLayoutNumChildren _ = 1
466+ getLayoutFocussedDyn _ = constDyn Nothing
467+ getLayoutTree _ = emptyLayoutDebugTree
469+class IsLayoutVtyWidget l t (m :: * -> *) where
470+ runIsLayoutVtyWidget :: l t m a -> Event t (Maybe Int) -> VtyWidget t m a
472+newtype LayoutVtyWidget t m a = LayoutVtyWidget {
473+ unLayoutVtyWidget :: ReaderT (Event t (Maybe Int)) (VtyWidget t m) a
484+ , MonadReflexCreateTrigger t
490+instance MonadTrans (LayoutVtyWidget t) where
491+ lift x = LayoutVtyWidget $ lift $ lift x
493+instance IsLayoutVtyWidget VtyWidget t m where
494+ runIsLayoutVtyWidget w _ = w
496+instance IsLayoutVtyWidget LayoutVtyWidget t m where
497+ runIsLayoutVtyWidget = runReaderT . unLayoutVtyWidget