@@ -3,9 +3,9 @@ Module: Reflex.Vty.Widget.Layout
33Description: Monad transformer and tools for arranging widgets and building screen layouts
44-}
55{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE FunctionalDependencies #-}
67{-# LANGUAGE GeneralizedNewtypeDeriving #-}
78{-# LANGUAGE LambdaCase #-}
8−{-# LANGUAGE MultiParamTypeClasses #-}
99{-# LANGUAGE RecursiveDo #-}
1010{-# LANGUAGE ScopedTypeVariables #-}
1111{-# LANGUAGE OverloadedStrings #-}
@@ -16,7 +16,6 @@ module Reflex.Vty.Widget.Layout
1616 , Constraint(..)
1717 , Layout(..)
1818 , runLayout
19− , TileConfig(..)
2019 , tile
2120 , fixed
2221 , stretch
@@ -28,23 +27,22 @@ module Reflex.Vty.Widget.Layout
2827 , runFocus
2928 , focusId
3029 , LForest(..)
30+ , LTree
31+ , FocusSet(..)
3132
3233 , test
3334 ) where
3435
3536import Control.Monad.NodeId (MonadNodeId(..), NodeId)
3637import Control.Monad.Reader
37−import Data.Default (Default(..))
3838import Data.List
39−import Data.Ratio ((%))
40−import Data.Sequence (Seq)
41−import qualified Data.Sequence as Seq
42−import qualified Graphics.Vty as V
4339import Data.Map.Ordered (OMap)
4440import qualified Data.Map.Ordered as OMap
45−import qualified Graphics.Vty.Attributes as V
41+import Data.Ratio ((%))
42+import Data.Semigroup (First(..))
4643import Data.Set.Ordered (OSet)
4744import qualified Data.Set.Ordered as OSet
45+import qualified Graphics.Vty as V
4846
4947import Reflex
5048import Reflex.Host.Class (MonadReflexCreateTrigger)
@@ -70,7 +68,9 @@ shiftFS (FocusSet s) fid n = case OSet.findIndex <$> fid <*> pure s of
7068 Just (Just ix) -> OSet.elemAt s $ mod (ix + n) (OSet.size s)
7169
7270newtype Focus t m a = Focus
73− { unFocus :: DynamicWriterT t FocusSet (ReaderT (Demux t (Maybe FocusId)) m) a
71+ { unFocus :: DynamicWriterT t FocusSet
72+ (ReaderT (Demux t (Maybe FocusId))
73+ (EventWriterT t (First (Maybe FocusId)) m)) a
7474 }
7575 deriving
7676 ( Functor
@@ -89,54 +89,51 @@ newtype Focus t m a = Focus
8989 )
9090
9191instance MonadTrans (Focus t) where
92− lift = Focus . lift . lift
92+ lift = Focus . lift . lift . lift
9393
9494newtype FocusId = FocusId NodeId
9595 deriving (Eq, Ord)
9696
97−focusId :: (MonadNodeId m, Reflex t) => Focus t m FocusId
98−focusId = do
99− fid <- FocusId <$> lift getNextNodeId
100− Focus $ tellDyn $ pure $ singletonFS fid
101− pure fid
97+class (Monad m, Reflex t) => MonadFocus t m | m -> t where
98+ focusId :: m FocusId
99+ requestFocus :: Event t (Maybe FocusId) -> m ()
100+ isFocused :: FocusId -> m (Dynamic t Bool)
101+
102+instance (Reflex t, Monad m, MonadNodeId m) => MonadFocus t (Focus t m) where
103+ focusId = do
104+ fid <- FocusId <$> lift getNextNodeId
105+ Focus $ tellDyn $ pure $ singletonFS fid
106+ pure fid
107+ requestFocus = Focus . tellEvent . fmap First
108+ isFocused fid = do
109+ sel <- Focus ask
110+ pure $ demuxed sel $ Just fid
102111
103112runFocus
104113 :: (MonadFix m, MonadHold t m, Reflex t)
105− => Event t (Maybe FocusId)
106− -> Focus t m a
114+ => Focus t m a
107115 -> m (a, Dynamic t FocusSet)
108−runFocus e (Focus x) = do
109− rec (a, focusIds) <- flip runReaderT (demux sel) $ runDynamicWriterT x
110− sel <- holdDyn Nothing e
116+runFocus (Focus x) = do
117+ rec ((a, focusIds), focusRequests) <- runEventWriterT $ flip runReaderT (demux sel) $ runDynamicWriterT x
118+ sel <- holdDyn Nothing $ getFirst <$> focusRequests
111119 pure (a, focusIds)
112120
113−isFocused
114− :: (Reflex t, Monad m)
115− => FocusId
116− -> Focus t m (Dynamic t Bool)
117−isFocused fid = do
118− sel <- Focus ask
119− pure $ demuxed sel $ Just fid
120−
121−-- | Configuration options for and constraints on 'tile'
122−data TileConfig t = TileConfig
123− { _tileConfig_constraint :: Dynamic t Constraint
124− -- ^ 'Constraint' on the tile's size
125− , _tileConfig_focusable :: Dynamic t Bool
126− -- ^ Whether the tile is focusable
127− }
128−
129−instance Reflex t => Default (TileConfig t) where
130− def = TileConfig (pure $ Constraint_Min 0) (pure True)
131−
132121tile
133122 :: (MonadNodeId m, MonadFix m, Reflex t)
134123 => VtyWidget t m a
135− -> Layout t (Focus t (VtyWidget t m)) a
124+ -> Layout t (Focus t (VtyWidget t m)) (FocusId, a)
136125tile w = do
137− fid <- lift focusId
138− focused <- lift $ isFocused fid
139− stretch $ \r -> lift $ pane r focused w
126+ fid <- focusId
127+ focused <- isFocused fid
128+ r <- stretch 0
129+ result <- lift $ lift $ pane r focused w
130+ pure (fid, result)
131+
132+tile_
133+ :: (MonadNodeId m, MonadFix m, Reflex t)
134+ => VtyWidget t m a
135+ -> Layout t (Focus t (VtyWidget t m)) a
136+tile_ = fmap snd . tile
140137
141138-- * Layout
142139
@@ -188,6 +185,29 @@ newtype Layout t m a = Layout
188185instance MonadTrans (Layout t) where
189186 lift = Layout . lift . lift
190187
188+class Monad m => MonadLayout t m | m -> t where
189+ axis :: Dynamic t Orientation -> Dynamic t Constraint -> m a -> m a
190+ leaf :: Dynamic t Constraint -> m (Dynamic t Region)
191+ askOrientation :: m (Dynamic t Orientation)
192+
193+instance (Monad m, MonadNodeId m, Reflex t, MonadFix m) => MonadLayout t (Layout t m) where
194+ axis o c (Layout x) = Layout $ do
195+ nodeId <- getNextNodeId
196+ (result, forest) <- lift $ local (\t -> (\(Just x) -> x) . lookupLF nodeId . ltreeForest <$> t) $ runDynamicWriterT x
197+ tellDyn $ singletonLF nodeId <$> (LTree <$> ((,) <$> c <*> o) <*> forest)
198+ pure result
199+ leaf c = do
200+ nodeId <- lift getNextNodeId
201+ Layout $ tellDyn $ ffor c $ \c' -> singletonLF nodeId $ LTree (c', Orientation_Row) mempty
202+ solutions <- Layout ask
203+ pure $ maybe (Region 0 0 0 0) (fst . ltreeRoot) . lookupLF nodeId . ltreeForest <$> solutions
204+ askOrientation = Layout $ asks $ fmap (snd . ltreeRoot)
205+
206+instance MonadFocus t m => MonadFocus t (Layout t m) where
207+ focusId = lift focusId
208+ requestFocus = lift . requestFocus
209+ isFocused = lift . isFocused
210+
191211-- | Datatype representing constraints on a widget's size along the main axis (see 'Orientation')
192212data Constraint = Constraint_Fixed Int
193213 | Constraint_Min Int
@@ -198,54 +218,25 @@ data Orientation = Orientation_Column
198218 | Orientation_Row
199219 deriving (Show, Read, Eq, Ord)
200220
201−axis
202− :: (Monad m, MonadNodeId m, Reflex t, MonadFix m)
203− => Orientation
204− -> Constraint
205− -> Layout t m a
206− -> Layout t m a
207−axis o c (Layout x) = Layout $ do
208− nodeId <- getNextNodeId
209− (result, forest) <- lift $ local (\t -> (\(Just x) -> x) . lookupLF nodeId . ltreeForest <$> t) $ runDynamicWriterT x
210− tellDyn $ fmap (singletonLF nodeId . LTree (c, o)) forest
211− pure result
212221
213222row, col
214− :: (Monad m, MonadNodeId m, Reflex t, MonadFix m)
215− => Constraint
216− -> Layout t m a
217− -> Layout t m a
218−row = axis Orientation_Row
219−col = axis Orientation_Column
220−
221−leaf
222− :: (Monad m, MonadNodeId m, Reflex t, MonadFix m)
223− => Dynamic t Constraint
224− -> (Dynamic t Region -> m a)
225− -> Layout t m a
226−leaf c f = do
227− nodeId <- lift getNextNodeId
228− Layout $ tellDyn $ ffor c $ \c' -> singletonLF nodeId $ LTree (c', Orientation_Row) mempty
229− solutions <- Layout ask
230− let r = maybe (Region 0 0 0 0) (fst . ltreeRoot) . lookupLF nodeId . ltreeForest <$> solutions -- TODO revisit this fromMaybe
231− lift $ f r
223+ :: (Reflex t, MonadLayout t m)
224+ => m a
225+ -> m a
226+row = axis (pure Orientation_Row) (pure $ Constraint_Min 0)
227+col = axis (pure Orientation_Column) (pure $ Constraint_Min 0)
232228
233229fixed
234− :: (Monad m, MonadNodeId m, Reflex t, MonadFix m)
230+ :: (Reflex t, MonadLayout t m)
235231 => Dynamic t Int
236− -> (Dynamic t Region -> m a)
237− -> Layout t m a
232+ -> m (Dynamic t Region)
238233fixed = leaf . fmap Constraint_Fixed
239234
240235stretch
241− :: (Monad m, MonadNodeId m, Reflex t, MonadFix m)
242− => (Dynamic t Region -> m a)
243− -> Layout t m a
244−stretch = leaf (pure $ Constraint_Min 0)
245−
246−-- | Retrieve the current orientation of a 'Layout'
247−askOrientation :: (Monad m, Reflex t) => Layout t m (Dynamic t Orientation)
248−askOrientation = Layout $ asks $ fmap (snd . ltreeRoot)
236+ :: (Reflex t, MonadLayout t m)
237+ => Dynamic t Int
238+ -> m (Dynamic t Region)
239+stretch minSz = leaf (Constraint_Min <$> minSz)
249240
250241ltreeConstraint :: LTree (Constraint, a) -> Constraint
251242ltreeConstraint (LTree (c, _) _) = c
@@ -345,21 +336,23 @@ test = mainWidget $ do
345336 f <- focus
346337 richText (RichTextConfig $ current $ (\x -> if x then V.withStyle V.defAttr V.bold else V.defAttr) <$> f) t
347338 tab <- tabNavigation
348− rec (_, focusSet) <- runFocus (updated sel) $ runLayout (pure Orientation_Column) r $ do -- TODO start focused
349− col (Constraint_Min 0) $ do
350− tile $ text' "asdf"
351− tile $ text' "asdf"
352− row (Constraint_Min 0) $ do
353− tile $ text' "xyz"
354− tile $ text' "xyz"
355− tile $ text' "xyz"
356− tile $ text' "xyz"
357− tile $ text' "asdf"
358− tile $ text' "asdf"
359− sel <- holdDyn Nothing $ attachWith (\(fs, s) t -> shiftFS fs s t) (current $ (,) <$> focusSet <*> sel) tab
339+ rec (_, focusSet) <- runFocus $ do
340+ rec sel <- holdDyn Nothing $ attachWith (\(fs, s) t -> shiftFS fs s t) (current $ (,) <$> focusSet <*> sel) tab
341+ requestFocus $ updated sel
342+ runLayout (pure Orientation_Column) r $ do
343+ col $ do
344+ tile_ $ text' "asdf"
345+ tile_ $ text' "asdf"
346+ row $ do
347+ (fid, click) <- tile $ do
348+ text' "CLICK ME"
349+ mouseDown V.BLeft
350+ requestFocus $ Just fid <$ click
351+ tile_ $ text' "xyz"
352+ tile_ $ text' "xyz"
353+ tile_ $ text' "xyz"
354+ tile_ $ text' "asdf"
355+ tile_ $ text' "asdf"
360356 return $ fforMaybe inp $ \case
361357 V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
362358 _ -> Nothing
363−
364− -- TODO These functions shouldn't be so higher order
365− -- TODO request focus