@@ -7,59 +7,61 @@
77{-# LANGUAGE RecordWildCards #-}
88{-# LANGUAGE RecursiveDo #-}
99{-# LANGUAGE UndecidableInstances #-}
10+{-# LANGUAGE TypeApplications #-}
11+{-# LANGUAGE RankNTypes #-}
12+{-# LANGUAGE ScopedTypeVariables #-}
1013
1114
12−module Potato.Reflex.Vty.Widget.Layout2
13− ( Orientation(..)
15+module Reflex.Vty.Widget.Layout
16+ ( Orientation(..)
1417 , Constraint(..)
1518 , Layout
19+ , runLayoutL
1620 , runLayout
1721 , TileConfig(..)
1822 , tile
1923 , fixed
20− , fixedD
24+ , fixedL
2125 , stretch
22− , stretchD
26+ , stretchL
2327 , col
2428 , row
25− , dummy
29+ , dummyCell
2630 , beginLayout
27− , beginLayoutD
31+ , beginLayoutL
2832 , tabNavigation
2933 , askOrientation
34+ , LayoutVtyWidget(..)
35+ , LayoutDebugTree(..)
36+ , IsLayoutVtyWidget(..)
37+ , LayoutReturnData(..)
3038 ) where
3139
3240import Prelude
3341
34−import qualified Relude as R
35−
3642import Control.Monad.Identity (Identity (..))
37−import Control.Monad.NodeId (MonadNodeId (..), NodeId (..))
43+import Control.Monad.NodeId (MonadNodeId (..), NodeId)
3844import Control.Monad.Reader
3945import Data.Bimap (Bimap)
4046import qualified Data.Bimap as Bimap
4147import Data.Default (Default (..))
42−import Data.Dependent.Map (DMap, DSum ((:=>)))
4348import qualified Data.Dependent.Map as DMap
49+import Data.Dependent.Sum (DSum((:=>)))
4450import Data.Functor.Misc
4551import Data.Map (Map)
4652import qualified Data.Map as Map
4753import qualified Data.Map.Internal as Map (Map (Bin, Tip))
48−import Data.Maybe (fromMaybe, isJust)
54+import Data.Maybe (fromMaybe)
4955import Data.Monoid hiding (First (..))
5056import Data.Ratio ((%))
5157import Data.Semigroup (First (..))
5258import Data.Traversable (mapAccumL)
53−import Data.Tuple.Extra
5459import qualified Graphics.Vty as V
55−import Unsafe.Coerce
5660
5761import Reflex
5862import Reflex.Host.Class (MonadReflexCreateTrigger)
5963import Reflex.Vty.Widget
6064
61−import Control.Exception (assert)
62−
6365-- | The main-axis orientation of a 'Layout' widget
6466data Orientation = Orientation_Column
6567 | Orientation_Row
@@ -80,7 +82,7 @@ data LayoutCtx t = LayoutCtx
8082
8183-- | The Layout monad transformer keeps track of the configuration (e.g., 'Orientation') and
8284-- 'Constraint's of its child widgets, apportions vty real estate to each, and acts as a
83−-- switchboard for focus requests. See 'tile' and 'runLayout'.
85+-- switchboard for focus requests. See 'tile_' and 'runLayout'.
8486newtype Layout t m a = Layout
8587 { unLayout :: EventWriterT t (First (NodeId, Int))
8688 (DynamicWriterT t (Endo [(NodeId, (Bool, Constraint), LayoutDebugTree t, Int)])
@@ -111,17 +113,16 @@ instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (Layout t m
111113 traverseDMapWithKeyWithAdjust f m e = Layout $ traverseDMapWithKeyWithAdjust (\k v -> unLayout $ f k v) m e
112114 traverseDMapWithKeyWithAdjustWithMove f m e = Layout $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unLayout $ f k v) m e
113115
114−
115116findNearestFloor_ :: (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+findNearestFloor_ target leftValue parent Map.Tip = if target < fst leftValue
117118 then Nothing -- error $ "Map.findNearestFloorSure: map has no element <= " <> show target
118119 else if target < fst parent
119− then Just leftmost
120+ then Just leftValue
120121 else Just parent
121−findNearestFloor_ target leftmost _ (Map.Bin _ k a l r) = if target == k
122+findNearestFloor_ target leftValue _ (Map.Bin _ k a l r) = if target == k
122123 then Just (k, a)
123124 else if target < k
124− then findNearestFloor_ target leftmost (k, a) l
125+ then findNearestFloor_ target leftValue (k, a) l
125126 else findNearestFloor_ target (k, a) (k, a) r
126127
127128findNearestFloor :: (Ord k) => k -> Map k a -> Maybe (k,a)
@@ -129,29 +130,27 @@ findNearestFloor _ Map.Tip = Nothing
129130-- TODO I don't think we need to do findMin here, just pass in (k,x) as a placeholder value
130131findNearestFloor target m@(Map.Bin _ k x _ _) = findNearestFloor_ target (Map.findMin m) (k, x) m
131132
132−
133−
134133fanFocusEv :: (Reflex t) => Behavior t (Maybe (NodeId, Int)) -> Event t (Maybe (NodeId, Int)) -> EventSelector t (Const2 NodeId (Maybe Int))
135134fanFocusEv focussed focusReqIx = fan $ attachWith attachfn focussed focusReqIx where
136135 attachfn mkv0 mkv1 = case mkv1 of
137136 Nothing -> case mkv0 of
138137 Nothing -> DMap.empty
139− Just (k0,v0) -> DMap.fromList [Const2 k0 :=> Identity Nothing]
138+ Just (k0,_) -> DMap.fromList [Const2 k0 :=> Identity Nothing]
140139 Just (k1,v1) -> case mkv0 of
141140 Nothing -> DMap.fromList [Const2 k1 :=> Identity (Just v1)]
142141 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,
142+ Just (k0,_) | k0 == k1 -> DMap.fromList [Const2 k1 :=> Identity (Just v1)]
143+ Just (k0,_) -> DMap.fromList [Const2 k0 :=> Identity Nothing,
145144 Const2 k1 :=> Identity (Just v1)]
146145
147146-- | Run a 'Layout' action
148−runLayoutD
149− :: forall t m a. (Reflex t, MonadFix m, MonadHold t m, Monad m, MonadNodeId m)
147+runLayoutL
148+ :: forall t m a. (Reflex t, MonadFix m, MonadHold t m)
150149 => Dynamic t Orientation -- ^ The main-axis 'Orientation' of this 'Layout'
151− -> Maybe Int -- ^ The positional index of the initially focused tile
150+ -> Maybe Int -- ^ The positional index of the initially focused tile_
152151 -> Layout t m a -- ^ The 'Layout' widget
153− -> LayoutVtyWidget t m (LayoutDebugTree t, Dynamic t (Maybe Int), Int, a)
154−runLayoutD ddir mfocus0 (Layout child) = LayoutVtyWidget . ReaderT $ \focusReqIx -> mdo
152+ -> LayoutVtyWidget t m (LayoutReturnData t a)
153+runLayoutL ddir mfocus0 (Layout child) = LayoutVtyWidget . ReaderT $ \focusReqIx -> mdo
155154 dw <- displayWidth
156155 dh <- displayHeight
157156 let main = ffor3 ddir dw dh $ \d w h -> case d of
@@ -228,29 +227,34 @@ runLayoutD ddir mfocus0 (Layout child) = LayoutVtyWidget . ReaderT $ \focusReqIx
228227 focusReqWithNodeId = attachWith (\fm mix -> mix >>= \ix -> findChildFocus fm ix) (current focusable) (focusReqIx)
229228 focusChildSelector = fanFocusEv (current $ fmap (fmap snd) focussed) (focusReqWithNodeId)
230229
231− return (emptyLayoutDebugTree, (fmap (fmap fst)) focussed, totalKiddos, a)
230+ return LayoutReturnData {
231+ _layoutReturnData_tree = emptyLayoutDebugTree
232+ , _layoutReturnData_focus = (fmap (fmap fst)) focussed
233+ , _layoutReturnData_children = totalKiddos
234+ , _layoutReturnData_value = a
235+ }
232236
233237-- | Run a 'Layout' action
234238runLayout
235− :: (MonadFix m, MonadHold t m, PostBuild t m, Monad m, MonadNodeId m)
239+ :: forall t m a. (Reflex t, MonadFix m, MonadHold t m, Monad m, MonadNodeId m)
236240 => Dynamic t Orientation -- ^ The main-axis 'Orientation' of this 'Layout'
237− -> Maybe Int -- ^ The positional index of the initially focused tile
241+ -> Maybe Int -- ^ The positional index of the initially focused tile_
238242 -> Layout t m a -- ^ The 'Layout' widget
239243 -> LayoutVtyWidget t m a
240−runLayout ddir mfocus0 layout = fmap (\(_,_,_,a)->a) $ runLayoutD ddir mfocus0 layout
244+runLayout ddir mfocus0 layout = fmap _layoutReturnData_value $ runLayoutL ddir mfocus0 layout
241245
242−-- | Tiles are the basic building blocks of 'Layout' widgets. Each tile has a constraint
243−-- on its size and ability to grow and on whether it can be focused. It also allows its child
244−-- widget to request focus.
245−tile
246− :: forall t b widget x m a. (Reflex t, IsLayoutReturn t b a, IsLayoutVtyWidget widget t m, Monad m, MonadFix m, MonadNodeId m)
247− => TileConfig t -- ^ The tile's configuration
246+swap :: (a,b) -> (b,a)
247+swap (a,b) = (b,a)
248+
249+tile_
250+ :: forall t b widget m a x. (Reflex t, IsLayoutReturn t b a, IsLayoutVtyWidget widget t m, MonadFix m, MonadNodeId m)
251+ => TileConfig t -- ^ The tile_'s configuration
248252 -> widget t m (Event t x, b) -- ^ A child widget. The 'Event' that it returns is used to request that it be focused.
249253 -> Layout t m a
250−tile (TileConfig con focusable) child = mdo
254+tile_ (TileConfig con focusable) child = mdo
251255 nodeId <- getNextNodeId
252256 -- by calling getLayoutTree/getLayoutNumChildren here, we store the children's layout info inside the DynamicWriter
253− -- runLayoutD will extract this info later
257+ -- runLayoutL will extract this info later
254258 Layout $ tellDyn $ ffor2 con focusable $ \c f -> Endo ((nodeId, (f, c), getLayoutTree @t @b @a b, nKiddos):)
255259 seg <- Layout $ asks $
256260 fmap (Map.findWithDefault (LayoutSegment 0 0) nodeId) . _layoutCtx_regions
@@ -286,80 +290,95 @@ tile (TileConfig con focusable) child = mdo
286290 else never
287291 return $ getLayoutResult @t b
288292
293+-- | Tiles are the basic building blocks of 'Layout' widgets. Each tile has a constraint
294+-- on its size and ability to grow and on whether it can be focused. It also allows its child
295+-- widget to request focus.
296+tile
297+ :: (Reflex t, IsLayoutVtyWidget widget t m, MonadFix m, MonadNodeId m)
298+ => TileConfig t -- ^ The tile's configuration
299+ -> widget t m (Event t x, a) -- ^ A child widget. The 'Event' that it returns is used to request that it be focused.
300+ -> Layout t m a
301+tile = tile_
302+
289303
290−-- | Configuration options for and constraints on 'tile'
304+-- | Configuration options for and constraints on 'tile_'
291305data TileConfig t = TileConfig
292306 { _tileConfig_constraint :: Dynamic t Constraint
293− -- ^ 'Constraint' on the tile's size
294− , _tileConfig_focusable :: Dynamic t Bool
295− -- ^ Whether the tile is focusable
307+ -- ^ 'Constraint' on the tile_'s size
308+ , _tile_Config_focusable :: Dynamic t Bool
309+ -- ^ Whether the tile_ is focusable
296310 }
297311
298−
299312instance Reflex t => Default (TileConfig t) where
300313 def = TileConfig (pure $ Constraint_Min 0) (pure True)
301314
302−-- | 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)
315+
316+fixed_
317+ :: (Reflex t, IsLayoutReturn t b a, IsLayoutVtyWidget widget t m, MonadFix m, MonadNodeId m)
305318 => Dynamic t Int
306319 -> widget t m b
307320 -> Layout t m a
308−fixed' sz = tile (def { _tileConfig_constraint = Constraint_Fixed <$> sz }) . clickable
321+fixed_ sz = tile_ (def { _tileConfig_constraint = Constraint_Fixed <$> sz }) . clickable
309322
310−fixedD
311− :: (Reflex t, Monad m, MonadFix m, MonadNodeId m)
323+-- | Use this variant to start a sub layout.
324+fixedL
325+ :: (Reflex t, MonadFix m, MonadNodeId m)
312326 => Dynamic t Int
313− -> LayoutVtyWidget t m (LayoutDebugTree t, Dynamic t (Maybe Int), Int, a)
327+ -> LayoutVtyWidget t m (LayoutReturnData t a)
314328 -> Layout t m a
315−fixedD = fixed'
329+fixedL = fixed_
316330
331+-- | A 'tile' of a fixed size that is focusable and gains focus on click
317332fixed
318− :: (Reflex t, IsLayoutVtyWidget widget t m, Monad m, MonadFix m, MonadNodeId m)
333+ :: (Reflex t, MonadFix m, MonadNodeId m)
319334 => Dynamic t Int
320− -> widget t m a
335+ -> VtyWidget t m a
321336 -> Layout t m a
322−fixed = fixed'
337+fixed = fixed_
323338
324−-- | A 'tile' that can stretch (i.e., has no fixed size) and has a minimum size of 0.
325−-- 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)
339+stretch_
340+ :: (Reflex t, IsLayoutReturn t b a, IsLayoutVtyWidget widget t m, MonadFix m, MonadNodeId m)
328341 => widget t m b
329342 -> Layout t m a
330−stretch' = tile def . clickable
343+stretch_ = tile_ def . clickable
331344
332−stretchD
333− :: (Reflex t, Monad m, MonadFix m, MonadNodeId m)
334− => LayoutVtyWidget t m (LayoutDebugTree t, Dynamic t (Maybe Int), Int, a)
345+-- | Use this variant to start a sub layout.
346+stretchL
347+ :: (Reflex t, MonadFix m, MonadNodeId m)
348+ => LayoutVtyWidget t m (LayoutReturnData t a)
335349 -> Layout t m a
336−stretchD = stretch'
350+stretchL = stretch_
337351
352+-- | A 'tile' that can stretch (i.e., has no fixed size) and has a minimum size of 0.
353+-- This tile is focusable and gains focus on click.
338354stretch
339− :: (Reflex t, IsLayoutVtyWidget widget t m, Monad m, MonadFix m, MonadNodeId m)
340− => widget t m a
355+ :: (Reflex t, MonadFix m, MonadNodeId m)
356+ => VtyWidget t m a
341357 -> Layout t m a
342−stretch = stretch'
358+stretch = stretch_
343359
344−-- | A version of 'runLayout' that arranges tiles in a column and uses 'tabNavigation' to
345−-- change tile focus.
360+-- | A version of 'runLayout' that arranges tiles in a column
346361col
347− :: (MonadFix m, MonadHold t m, PostBuild t m, MonadNodeId m)
362+ :: (Reflex t, MonadFix m, MonadHold t m, MonadNodeId m)
348363 => Layout t m a
349− -> LayoutVtyWidget t m (LayoutDebugTree t, Dynamic t (Maybe Int), Int, a)
350−col child = runLayoutD (pure Orientation_Column) (Just 0) child
364+ -> LayoutVtyWidget t m (LayoutReturnData t a)
365+col child = runLayoutL (pure Orientation_Column) (Just 0) child
351366
352−-- | A version of 'runLayout' that arranges tiles in a row and uses 'tabNavigation' to
353−-- change tile focus.
367+-- | A version of 'runLayout' that arranges tiles in a row
354368row
355− :: (MonadFix m, MonadHold t m, PostBuild t m, MonadNodeId m)
369+ :: (Reflex t, MonadFix m, MonadHold t m, MonadNodeId m)
356370 => Layout t m a
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, ())
371+ -> LayoutVtyWidget t m (LayoutReturnData t a)
372+row child = runLayoutL (pure Orientation_Row) (Just 0) child
373+
374+-- | Use to make placeholder empty cells in sub layouts.
375+dummyCell :: (Reflex t, Monad m) => LayoutVtyWidget t m (LayoutReturnData t ())
376+dummyCell = return LayoutReturnData {
377+ _layoutReturnData_tree = emptyLayoutDebugTree
378+ , _layoutReturnData_focus = constDyn Nothing
379+ , _layoutReturnData_children = 0
380+ , _layoutReturnData_value = ()
381+ }
363382
364383-- | Produces an 'Event' that navigates forward one tile when the Tab key is pressed
365384-- and backward one tile when Shift+Tab is pressed.
@@ -380,24 +399,26 @@ clickable child = LayoutVtyWidget . ReaderT $ \focusEv -> do
380399 a <- runIsLayoutVtyWidget child focusEv
381400 return (() <$ click, a)
382401
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
402+-- TODO look into making a variant of this function that takes a navigation event
403+-- | Use this variant to begin a layout if you need its "LayoutReturnData"
404+beginLayoutL
405+ :: (Reflex t, MonadHold t m, MonadFix m)
406+ => LayoutVtyWidget t m (LayoutReturnData t a)
407+ -> VtyWidget t m (LayoutReturnData t a)
408+beginLayoutL child = mdo
388409 -- TODO consider unfocusing if this loses focus
389410 --focussed <- focus
390411 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)
412+ let focusChildEv = fmap (\(mcur, shift) -> maybe (Just 0) (\cur -> Just $ (shift + cur) `mod` _layoutReturnData_children) mcur) (attach (current _layoutReturnData_focus) tabEv)
413+ lrd@LayoutReturnData{..} <- runIsLayoutVtyWidget child focusChildEv
414+ return lrd
415+
416+-- | Begin a layout using tab and shift-tab to navigate
417+beginLayout
418+ :: (Reflex t, MonadHold t m, MonadFix m, MonadNodeId m)
419+ => LayoutVtyWidget t m (LayoutReturnData t a)
399420 -> VtyWidget t m a
400−beginLayout = fmap snd . beginLayoutD
421+beginLayout = fmap _layoutReturnData_value . beginLayoutL
401422
402423-- | Retrieve the current orientation of a 'Layout'
403424askOrientation :: Monad m => Layout t m (Dynamic t Orientation)
@@ -410,8 +431,7 @@ data Constraint = Constraint_Fixed Int
410431
411432-- | Compute the size of each widget "@k@" based on the total set of 'Constraint's
412433computeSizes
413− :: Ord k
414− => Int
434+ :: Int
415435 -> Map k (a, Constraint)
416436 -> Map k (a, Int)
417437computeSizes available constraints =
@@ -433,15 +453,9 @@ computeEdges :: (Ord k) => Map k (a, Int) -> Map k (a, (Int, Int))
433453computeEdges = fst . Map.foldlWithKey' (\(m, offset) k (a, sz) ->
434454 (Map.insert k (a, (offset, sz)) m, sz + offset)) (Map.empty, 0)
435455
436−
437−
438−
439−
440−
441−
442−
443−-- TODO should prob be (Branch [LayoutDebugTree] | Leaf PosDim
456+-- TODO FINISH
444457-- but it's weird cuz a leaf node won't know it's PosDim until combined with a Region...
458+-- | Dynamic sizing information on a layout hierarchy (intended for testing)
445459data LayoutDebugTree t = LayoutDebugTree_Branch [LayoutDebugTree t] | LayoutDebugTree_Leaf
446460
447461emptyLayoutDebugTree :: LayoutDebugTree t
@@ -453,12 +467,18 @@ class IsLayoutReturn t b a where
453467 getLayoutFocussedDyn :: b -> Dynamic t (Maybe Int)
454468 getLayoutTree :: b -> LayoutDebugTree t
455469
470+data LayoutReturnData t a = LayoutReturnData {
471+ _layoutReturnData_tree :: LayoutDebugTree t
472+ , _layoutReturnData_focus :: Dynamic t (Maybe Int)
473+ , _layoutReturnData_children :: Int
474+ , _layoutReturnData_value :: a
475+ }
456476
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
477+instance IsLayoutReturn t (LayoutReturnData t a) a where
478+ getLayoutResult lrd = _layoutReturnData_value lrd
479+ getLayoutNumChildren lrd = _layoutReturnData_children lrd
480+ getLayoutFocussedDyn lrd = _layoutReturnData_focus lrd
481+ getLayoutTree lrd = _layoutReturnData_tree lrd
462482
463483instance Reflex t => IsLayoutReturn t a a where
464484 getLayoutResult = id
@@ -466,7 +486,7 @@ instance Reflex t => IsLayoutReturn t a a where
466486 getLayoutFocussedDyn _ = constDyn Nothing
467487 getLayoutTree _ = emptyLayoutDebugTree
468488
469−class IsLayoutVtyWidget l t (m :: * -> *) where
489+class IsLayoutVtyWidget l t m where
470490 runIsLayoutVtyWidget :: l t m a -> Event t (Maybe Int) -> VtyWidget t m a
471491
472492newtype LayoutVtyWidget t m a = LayoutVtyWidget {