@@ -9,40 +9,38 @@ Description: Monad transformer and tools for arranging widgets and building scre
9{-# LANGUAGE RecursiveDo #-}
9{-# LANGUAGE RecursiveDo #-}
10{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE OverloadedStrings #-}
11{-# LANGUAGE OverloadedStrings #-}
12−{-# LANGUAGE TupleSections #-}
13{-# LANGUAGE UndecidableInstances #-}
12{-# LANGUAGE UndecidableInstances #-}
15−module Reflex.Vty.Widget.Layout where
14+module Reflex.Vty.Widget.Layout
16− -- ( Orientation(..)
15+ ( Orientation(..)
17− -- , Constraint(..)
16+ , Constraint(..)
18− -- , Layout
17+ , Layout(..)
19− -- , runLayout
18+ , runLayout
20− -- , TileConfig(..)
19+ , TileConfig(..)
22− -- , fixed
21+ , fixed
23− -- , stretch
22+ , stretch
26− -- , tabNavigation
25+ , tabNavigation
27− -- , askOrientation
26+ , askOrientation
28− -- ) where
33+ ) where
30−import Control.Monad.NodeId (MonadNodeId(..), NodeId, NodeIdT)
35+import Control.Monad.NodeId (MonadNodeId(..), NodeId)
31import Control.Monad.Reader
36import Control.Monad.Reader
32−import Data.Bimap (Bimap)
33−import qualified Data.Bimap as Bimap
34import Data.Default (Default(..))
37import Data.Default (Default(..))
35import Data.List
38import Data.List
37−import qualified Data.Map as Map
38−import Data.Maybe (fromMaybe)
39−import Data.Monoid hiding (First(..))
40import Data.Ratio ((%))
39import Data.Ratio ((%))
41−import Data.Semigroup (First(..))
42import Data.Sequence (Seq)
40import Data.Sequence (Seq)
43import qualified Data.Sequence as Seq
41import qualified Data.Sequence as Seq
44import qualified Graphics.Vty as V
42import qualified Graphics.Vty as V
45−import Data.Map.Ordered (OMap, Bias(..), L)
43+import Data.Map.Ordered (OMap)
46import qualified Data.Map.Ordered as OMap
44import qualified Data.Map.Ordered as OMap
47import qualified Graphics.Vty.Attributes as V
45import qualified Graphics.Vty.Attributes as V
@@ -93,18 +91,13 @@ runFocus e (Focus x) = do
93 sel <- holdDyn Nothing e
91 sel <- holdDyn Nothing e
94 pure (a, focusIds)
92 pure (a, focusIds)
97 :: (Reflex t, Monad m)
95 :: (Reflex t, Monad m)
98 => FocusId
96 => FocusId
99− -> (Dynamic t Bool -> Focus t m a) -- TODO unnecessary: just return the dynamic bool
97+ -> Focus t m (Dynamic t Bool)
100− -> Focus t m a
98+isFocused fid = do
101−withFocus focusId builder = do
102 sel <- Focus ask
99 sel <- Focus ask
103− builder $ demuxed sel $ Just focusId
100+ pure $ demuxed sel $ Just fid
105−-- focus builder = do
107−-- withFocus fid builder
109-- | Configuration options for and constraints on 'tile'
102-- | Configuration options for and constraints on 'tile'
110data TileConfig t = TileConfig
103data TileConfig t = TileConfig
@@ -123,7 +116,7 @@ tile
123 -> Layout t (Focus t (VtyWidget t m)) a
116 -> Layout t (Focus t (VtyWidget t m)) a
124tile w = do
117tile w = do
125 fid <- lift focusId
118 fid <- lift focusId
126− focused <- lift $ withFocus fid return
119+ focused <- lift $ isFocused fid
127 stretch $ \r -> lift $ pane r focused w
120 stretch $ \r -> lift $ pane r focused w
129-- * Layout
122-- * Layout
@@ -194,7 +187,7 @@ axis
194 -> Layout t m a
187 -> Layout t m a
195axis o c (Layout x) = Layout $ do
188axis o c (Layout x) = Layout $ do
196 nodeId <- getNextNodeId
189 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
198 tellDyn $ fmap (singletonLF nodeId . LTree (c, o)) forest
191 tellDyn $ fmap (singletonLF nodeId . LTree (c, o)) forest
199 pure result
192 pure result
@@ -209,28 +202,29 @@ col = axis Orientation_Column
210 :: (Monad m, MonadNodeId m, Reflex t, MonadFix m)
203 :: (Monad m, MonadNodeId m, Reflex t, MonadFix m)
211 => Dynamic t Constraint
204 => Dynamic t Constraint
212− -> (DynRegion t -> m a)
205+ -> (Dynamic t Region -> m a)
213 -> Layout t m a
206 -> Layout t m a
214leaf c f = do
207leaf c f = do
215 nodeId <- lift getNextNodeId
208 nodeId <- lift getNextNodeId
216 Layout $ tellDyn $ ffor c $ \c' -> singletonLF nodeId $ LTree (c', Orientation_Row) mempty
209 Layout $ tellDyn $ ffor c $ \c' -> singletonLF nodeId $ LTree (c', Orientation_Row) mempty
217 solutions <- Layout ask
210 solutions <- Layout ask
218 let r = maybe (Region 0 0 0 0) (fst . ltreeRoot) . lookupLF nodeId . ltreeForest <$> solutions -- TODO revisit this fromMaybe
211 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
222 :: (Monad m, MonadNodeId m, Reflex t, MonadFix m)
215 :: (Monad m, MonadNodeId m, Reflex t, MonadFix m)
223 => Dynamic t Int
216 => Dynamic t Int
224− -> (DynRegion t -> m a)
217+ -> (Dynamic t Region -> m a)
225 -> Layout t m a
218 -> Layout t m a
226fixed = leaf . fmap Constraint_Fixed
219fixed = leaf . fmap Constraint_Fixed
229 :: (Monad m, MonadNodeId m, Reflex t, MonadFix m)
222 :: (Monad m, MonadNodeId m, Reflex t, MonadFix m)
230− => (DynRegion t -> m a)
223+ => (Dynamic t Region -> m a)
231 -> Layout t m a
224 -> Layout t m a
232stretch = leaf (pure $ Constraint_Min 0)
225stretch = leaf (pure $ Constraint_Min 0)
227+-- | Retrieve the current orientation of a 'Layout'
234askOrientation :: (Monad m, Reflex t) => Layout t m (Dynamic t Orientation)
228askOrientation :: (Monad m, Reflex t) => Layout t m (Dynamic t Orientation)
235askOrientation = Layout $ asks $ fmap (snd . ltreeRoot)
229askOrientation = Layout $ asks $ fmap (snd . ltreeRoot)
@@ -301,197 +295,6 @@ runLayout o r (Layout x) = do
301 return result
295 return result
304−data LayoutSegment = LayoutSegment
305− { _layoutSegment_offset :: Int
306− , _layoutSegment_size :: Int
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
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)
333− , MonadReflexCreateTrigger t
339−instance MonadTrans (Layout t) where
340− lift x = Layout $ lift $ lift $ lift $ lift x
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
348−-- | Run a 'Layout' action
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
356−runLayout ddir focus0 focusShift (Layout child) = do
359− let main = ffor3 ddir dw dh $ \d w h -> case d of
360− Orientation_Column -> h
361− Orientation_Row -> w
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
371− . zip [0::Integer ..]
373− solutionMap = ffor solution $ \ss -> ffor ss $ \(offset, sz) -> LayoutSegment
374− { _layoutSegment_offset = offset
375− , _layoutSegment_size = sz
377− -- focusable = fmap (Bimap.fromList . zip [0..]) $
378− -- ffor queries $ \qs -> fforMaybe qs $ \(nodeId, (f, _)) ->
379− -- if f then Just nodeId else Nothing
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
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
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.
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.
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
417− let cross = join $ ffor o $ \case
418− Orientation_Column -> dw
419− Orientation_Row -> dh
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
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
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
448−instance Reflex t => Default (TileConfig t) where
449− def = TileConfig (pure $ Constraint_Min 0) (pure True)
451−-- | A 'tile' of a fixed size that is focusable and gains focus on click
453− :: (Reflex t, Monad m, MonadNodeId m)
457−fixed sz = tile (def { _tileConfig_constraint = Constraint_Fixed <$> sz }) . clickable
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.
462− :: (Reflex t, Monad m, MonadNodeId m)
465−stretch = tile def . clickable
467−-- | A version of 'runLayout' that arranges tiles in a column and uses 'tabNavigation' to
468−-- change tile focus.
470− :: (MonadFix m, MonadHold t m, PostBuild t m, MonadNodeId m)
474− nav <- tabNavigation
475− runLayout (pure Orientation_Column) 0 nav child
477−-- | A version of 'runLayout' that arranges tiles in a row and uses 'tabNavigation' to
478−-- change tile focus.
480− :: (MonadFix m, MonadHold t m, PostBuild t m, MonadNodeId m)
484− nav <- tabNavigation
485− runLayout (pure Orientation_Row) 0 nav child
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)
491− fwd <- fmap (const 1) <$> key (V.KChar '\t')
492− back <- fmap (const (-1)) <$> key V.KBackTab
493− return $ leftmost [fwd, back]
495-- | Captures the click event in a 'VtyWidget' context and returns it. Useful for
298-- | Captures the click event in a 'VtyWidget' context and returns it. Useful for
496-- requesting focus when using 'tile'.
299-- requesting focus when using 'tile'.
@@ -503,10 +306,6 @@ clickable child = do
503 a <- child
306 a <- child
504 return (() <$ click, a)
307 return (() <$ click, a)
506−-- | Retrieve the current orientation of a 'Layout'
507−askOrientation :: Monad m => Layout t m (Dynamic t Orientation)
508−askOrientation = Layout $ asks _layoutCtx_orientation
512-- | Produces an 'Event' that navigates forward one tile when the Tab key is pressed
311-- | Produces an 'Event' that navigates forward one tile when the Tab key is pressed
@@ -545,3 +344,4 @@ test = mainWidget $ do
545 _ -> Nothing
344 _ -> Nothing
547 -- TODO These functions shouldn't be so higher order
346 -- TODO These functions shouldn't be so higher order
347+ -- TODO request focus