@@ -9,40 +9,38 @@ Description: Monad transformer and tools for arranging widgets and building scre
99{-# LANGUAGE RecursiveDo #-}
1010{-# LANGUAGE ScopedTypeVariables #-}
1111{-# LANGUAGE OverloadedStrings #-}
12−{-# LANGUAGE TupleSections #-}
1312{-# LANGUAGE UndecidableInstances #-}
1413
15−module Reflex.Vty.Widget.Layout where
16− -- ( Orientation(..)
17− -- , Constraint(..)
18− -- , Layout
19− -- , runLayout
20− -- , TileConfig(..)
21− -- , tile
22− -- , fixed
23− -- , stretch
24− -- , col
25− -- , row
26− -- , tabNavigation
27− -- , askOrientation
28− -- ) where
29−
30−import Control.Monad.NodeId (MonadNodeId(..), NodeId, NodeIdT)
14+module Reflex.Vty.Widget.Layout
15+ ( Orientation(..)
16+ , Constraint(..)
17+ , Layout(..)
18+ , runLayout
19+ , TileConfig(..)
20+ , tile
21+ , fixed
22+ , stretch
23+ , col
24+ , row
25+ , tabNavigation
26+ , askOrientation
27+ , Focus(..)
28+ , runFocus
29+ , focusId
30+ , LForest(..)
31+
32+ , test
33+ ) where
34+
35+import Control.Monad.NodeId (MonadNodeId(..), NodeId)
3136import Control.Monad.Reader
32−import Data.Bimap (Bimap)
33−import qualified Data.Bimap as Bimap
3437import Data.Default (Default(..))
3538import Data.List
36−import Data.Map (Map)
37−import qualified Data.Map as Map
38−import Data.Maybe (fromMaybe)
39−import Data.Monoid hiding (First(..))
4039import Data.Ratio ((%))
41−import Data.Semigroup (First(..))
4240import Data.Sequence (Seq)
4341import qualified Data.Sequence as Seq
4442import qualified Graphics.Vty as V
45−import Data.Map.Ordered (OMap, Bias(..), L)
43+import Data.Map.Ordered (OMap)
4644import qualified Data.Map.Ordered as OMap
4745import qualified Graphics.Vty.Attributes as V
4846
@@ -93,18 +91,13 @@ runFocus e (Focus x) = do
9391 sel <- holdDyn Nothing e
9492 pure (a, focusIds)
9593
96−withFocus
94+isFocused
9795 :: (Reflex t, Monad m)
9896 => FocusId
99− -> (Dynamic t Bool -> Focus t m a) -- TODO unnecessary: just return the dynamic bool
100− -> Focus t m a
101−withFocus focusId builder = do
97+ -> Focus t m (Dynamic t Bool)
98+isFocused fid = do
10299 sel <- Focus ask
103− builder $ demuxed sel $ Just focusId
104−
105−-- focus builder = do
106−-- fid <- focusId
107−-- withFocus fid builder
100+ pure $ demuxed sel $ Just fid
108101
109102-- | Configuration options for and constraints on 'tile'
110103data TileConfig t = TileConfig
@@ -123,7 +116,7 @@ tile
123116 -> Layout t (Focus t (VtyWidget t m)) a
124117tile w = do
125118 fid <- lift focusId
126− focused <- lift $ withFocus fid return
119+ focused <- lift $ isFocused fid
127120 stretch $ \r -> lift $ pane r focused w
128121
129122-- * Layout
@@ -194,7 +187,7 @@ axis
194187 -> Layout t m a
195188axis o c (Layout x) = Layout $ do
196189 nodeId <- getNextNodeId
197− (result, forest) <- lift $ local (\t -> (\(Just x) -> x) . lookupLF nodeId . ltreeForest <$> t) $ runDynamicWriterT x -- TODO?
190+ (result, forest) <- lift $ local (\t -> (\(Just x) -> x) . lookupLF nodeId . ltreeForest <$> t) $ runDynamicWriterT x
198191 tellDyn $ fmap (singletonLF nodeId . LTree (c, o)) forest
199192 pure result
200193
@@ -209,28 +202,29 @@ col = axis Orientation_Column
209202leaf
210203 :: (Monad m, MonadNodeId m, Reflex t, MonadFix m)
211204 => Dynamic t Constraint
212− -> (DynRegion t -> m a)
205+ -> (Dynamic t Region -> m a)
213206 -> Layout t m a
214207leaf c f = do
215208 nodeId <- lift getNextNodeId
216209 Layout $ tellDyn $ ffor c $ \c' -> singletonLF nodeId $ LTree (c', Orientation_Row) mempty
217210 solutions <- Layout ask
218211 let r = maybe (Region 0 0 0 0) (fst . ltreeRoot) . lookupLF nodeId . ltreeForest <$> solutions -- TODO revisit this fromMaybe
219− lift $ f $ dynRegion r
212+ lift $ f r
220213
221214fixed
222215 :: (Monad m, MonadNodeId m, Reflex t, MonadFix m)
223216 => Dynamic t Int
224− -> (DynRegion t -> m a)
217+ -> (Dynamic t Region -> m a)
225218 -> Layout t m a
226219fixed = leaf . fmap Constraint_Fixed
227220
228221stretch
229222 :: (Monad m, MonadNodeId m, Reflex t, MonadFix m)
230− => (DynRegion t -> m a)
223+ => (Dynamic t Region -> m a)
231224 -> Layout t m a
232225stretch = leaf (pure $ Constraint_Min 0)
233226
227+-- | Retrieve the current orientation of a 'Layout'
234228askOrientation :: (Monad m, Reflex t) => Layout t m (Dynamic t Orientation)
235229askOrientation = Layout $ asks $ fmap (snd . ltreeRoot)
236230
@@ -301,197 +295,6 @@ runLayout o r (Layout x) = do
301295 return result
302296
303297{-
304−data LayoutSegment = LayoutSegment
305− { _layoutSegment_offset :: Int
306− , _layoutSegment_size :: Int
307− }
308−
309−data LayoutCtx t = LayoutCtx
310− { _layoutCtx_regions :: Dynamic t (Map NodeId LayoutSegment)
311− , _layoutCtx_focusDemux :: Demux t (Maybe NodeId)
312− , _layoutCtx_orientation :: Dynamic t Orientation
313− }
314−
315−-- | The Layout monad transformer keeps track of the configuration (e.g., 'Orientation') and
316−-- 'Constraint's of its child widgets, apportions vty real estate to each, and acts as a
317−-- switchboard for focus requests. See 'tile' and 'runLayout'.
318−newtype Layout t m a = Layout
319− { unLayout :: EventWriterT t (First NodeId)
320− (DynamicWriterT t (Endo [(NodeId, (Bool, Constraint))])
321− (ReaderT (LayoutCtx t)
322− (VtyWidget t m))) a
323− } deriving
324− ( Functor
325− , Applicative
326− , Monad
327− , MonadHold t
328− , MonadSample t
329− , MonadFix
330− , TriggerEvent t
331− , PerformEvent t
332− , NotReady t
333− , MonadReflexCreateTrigger t
334− , HasDisplaySize t
335− , MonadNodeId
336− , PostBuild t
337− )
338−
339−instance MonadTrans (Layout t) where
340− lift x = Layout $ lift $ lift $ lift $ lift x
341−
342−instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (Layout t m) where
343− runWithReplace (Layout a) e = Layout $ runWithReplace a $ fmap unLayout e
344− traverseIntMapWithKeyWithAdjust f m e = Layout $ traverseIntMapWithKeyWithAdjust (\k v -> unLayout $ f k v) m e
345− traverseDMapWithKeyWithAdjust f m e = Layout $ traverseDMapWithKeyWithAdjust (\k v -> unLayout $ f k v) m e
346− traverseDMapWithKeyWithAdjustWithMove f m e = Layout $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unLayout $ f k v) m e
347−
348−-- | Run a 'Layout' action
349−runLayout
350− :: (MonadFix m, MonadHold t m, PostBuild t m, Monad m, MonadNodeId m)
351− => Dynamic t Orientation -- ^ The main-axis 'Orientation' of this 'Layout'
352− -> Int -- ^ The positional index of the initially focused tile
353− -> Event t Int -- ^ An event that shifts focus by a given number of tiles
354− -> Layout t m a -- ^ The 'Layout' widget
355− -> VtyWidget t m a
356−runLayout ddir focus0 focusShift (Layout child) = do
357− dw <- displayWidth
358− dh <- displayHeight
359− let main = ffor3 ddir dw dh $ \d w h -> case d of
360− Orientation_Column -> h
361− Orientation_Row -> w
362− pb <- getPostBuild
363− rec ((a, focusReq), queriesEndo) <- runReaderT (runDynamicWriterT $ runEventWriterT child) $ LayoutCtx solutionMap focusDemux ddir
364− let queries = flip appEndo [] <$> queriesEndo
365− solution = ffor2 main queries $ \sz qs -> Map.fromList
366− . Map.elems
367− . computeEdges
368− . computeSizes sz
369− . fmap (fmap snd)
370− . Map.fromList
371− . zip [0::Integer ..]
372− $ qs
373− solutionMap = ffor solution $ \ss -> ffor ss $ \(offset, sz) -> LayoutSegment
374− { _layoutSegment_offset = offset
375− , _layoutSegment_size = sz
376− }
377− -- focusable = fmap (Bimap.fromList . zip [0..]) $
378− -- ffor queries $ \qs -> fforMaybe qs $ \(nodeId, (f, _)) ->
379− -- if f then Just nodeId else Nothing
380− -- adjustFocus
381− -- :: (Bimap Int NodeId, (Int, Maybe NodeId))
382− -- -> Either Int NodeId
383− -- -> (Int, Maybe NodeId)
384− -- adjustFocus (fm, (cur, _)) (Left shift) =
385− -- let ix = (cur + shift) `mod` (max 1 $ Bimap.size fm)
386− -- in (ix, Bimap.lookup ix fm)
387− -- adjustFocus (fm, (cur, _)) (Right goto) =
388− -- let ix = fromMaybe cur $ Bimap.lookupR goto fm
389− -- in (ix, Just goto)
390− -- focusChange = attachWith
391− -- adjustFocus
392− -- (current $ (,) <$> focusable <*> focussed)
393− -- $ leftmost [Left <$> focusShift, Left 0 <$ pb, Right . getFirst <$> focusReq]
394− -- A pair (Int, Maybe NodeId) which represents the index
395− -- that we're trying to focus, and the node that actually gets
396− -- focused (at that index) if it exists
397− focussed <- holdDyn (focus0, Nothing) focusChange
398− let focusDemux = demux $ snd <$> focussed
399− return a
400−
401−-- | Tiles are the basic building blocks of 'Layout' widgets. Each tile has a constraint
402−-- on its size and ability to grow and on whether it can be focused. It also allows its child
403−-- widget to request focus.
404−tile
405− :: (Reflex t, Monad m, MonadNodeId m)
406− => TileConfig t -- ^ The tile's configuration
407− -> VtyWidget t m (Event t x, a) -- ^ A child widget. The 'Event' that it returns is used to request that it be focused.
408− -> Layout t m a
409−tile (TileConfig con focusable) child = do
410− nodeId <- getNextNodeId
411− Layout $ tellDyn $ ffor2 con focusable $ \c f -> Endo ((nodeId, (f, c)):)
412− seg <- Layout $ asks $
413− fmap (Map.findWithDefault (LayoutSegment 0 0) nodeId) . _layoutCtx_regions
414− dw <- displayWidth
415− dh <- displayHeight
416− o <- askOrientation
417− let cross = join $ ffor o $ \case
418− Orientation_Column -> dw
419− Orientation_Row -> dh
420− let reg = DynRegion
421− { _dynRegion_top = ffor2 seg o $ \s -> \case
422− Orientation_Column -> _layoutSegment_offset s
423− Orientation_Row -> 0
424− , _dynRegion_left = ffor2 seg o $ \s -> \case
425− Orientation_Column -> 0
426− Orientation_Row -> _layoutSegment_offset s
427− , _dynRegion_width = ffor3 seg cross o $ \s c -> \case
428− Orientation_Column -> c
429− Orientation_Row -> _layoutSegment_size s
430− , _dynRegion_height = ffor3 seg cross o $ \s c -> \case
431− Orientation_Column -> _layoutSegment_size s
432− Orientation_Row -> c
433− }
434− focussed <- Layout $ asks _layoutCtx_focusDemux
435− (focusReq, a) <- Layout $ lift $ lift $ lift $
436− pane reg (demuxed focussed $ Just nodeId) $ child
437− Layout $ tellEvent $ First nodeId <$ focusReq
438− return a
439−
440−-- | Configuration options for and constraints on 'tile'
441−data TileConfig t = TileConfig
442− { _tileConfig_constraint :: Dynamic t Constraint
443− -- ^ 'Constraint' on the tile's size
444− , _tileConfig_focusable :: Dynamic t Bool
445− -- ^ Whether the tile is focusable
446− }
447−
448−instance Reflex t => Default (TileConfig t) where
449− def = TileConfig (pure $ Constraint_Min 0) (pure True)
450−
451−-- | A 'tile' of a fixed size that is focusable and gains focus on click
452−fixed
453− :: (Reflex t, Monad m, MonadNodeId m)
454− => Dynamic t Int
455− -> VtyWidget t m a
456− -> Layout t m a
457−fixed sz = tile (def { _tileConfig_constraint = Constraint_Fixed <$> sz }) . clickable
458−
459−-- | A 'tile' that can stretch (i.e., has no fixed size) and has a minimum size of 0.
460−-- This tile is focusable and gains focus on click.
461−stretch
462− :: (Reflex t, Monad m, MonadNodeId m)
463− => VtyWidget t m a
464− -> Layout t m a
465−stretch = tile def . clickable
466−
467−-- | A version of 'runLayout' that arranges tiles in a column and uses 'tabNavigation' to
468−-- change tile focus.
469−col
470− :: (MonadFix m, MonadHold t m, PostBuild t m, MonadNodeId m)
471− => Layout t m a
472− -> VtyWidget t m a
473−col child = do
474− nav <- tabNavigation
475− runLayout (pure Orientation_Column) 0 nav child
476−
477−-- | A version of 'runLayout' that arranges tiles in a row and uses 'tabNavigation' to
478−-- change tile focus.
479−row
480− :: (MonadFix m, MonadHold t m, PostBuild t m, MonadNodeId m)
481− => Layout t m a
482− -> VtyWidget t m a
483−row child = do
484− nav <- tabNavigation
485− runLayout (pure Orientation_Row) 0 nav child
486−
487−-- | Produces an 'Event' that navigates forward one tile when the Tab key is pressed
488−-- and backward one tile when Shift+Tab is pressed.
489−tabNavigation :: (Reflex t, Monad m) => VtyWidget t m (Event t Int)
490−tabNavigation = do
491− fwd <- fmap (const 1) <$> key (V.KChar '\t')
492− back <- fmap (const (-1)) <$> key V.KBackTab
493− return $ leftmost [fwd, back]
494−
495298-- | Captures the click event in a 'VtyWidget' context and returns it. Useful for
496299-- requesting focus when using 'tile'.
497300clickable
@@ -503,10 +306,6 @@ clickable child = do
503306 a <- child
504307 return (() <$ click, a)
505308
506−-- | Retrieve the current orientation of a 'Layout'
507−askOrientation :: Monad m => Layout t m (Dynamic t Orientation)
508−askOrientation = Layout $ asks _layoutCtx_orientation
509−
510309-}
511310
512311-- | Produces an 'Event' that navigates forward one tile when the Tab key is pressed
@@ -545,3 +344,4 @@ test = mainWidget $ do
545344 _ -> Nothing
546345
547346 -- TODO These functions shouldn't be so higher order
347+ -- TODO request focus