@@ -11,27 +11,7 @@ Description: Monad transformer and tools for arranging widgets and building scre
1111{-# LANGUAGE OverloadedStrings #-}
1212{-# LANGUAGE UndecidableInstances #-}
1313
14−module Reflex.Vty.Widget.Layout
15− ( Orientation(..)
16− , Constraint(..)
17− , Layout(..)
18− , runLayout
19− , tile
20− , fixed
21− , stretch
22− , col
23− , row
24− , tabNavigation
25− , askOrientation
26− , Focus(..)
27− , runFocus
28− , focusId
29− , LForest(..)
30− , LTree
31− , FocusSet(..)
32−
33− , test
34− ) where
14+module Reflex.Vty.Widget.Layout where
3515
3616import Control.Monad.NodeId (MonadNodeId(..), NodeId)
3717import Control.Monad.Reader
@@ -67,10 +47,14 @@ shiftFS (FocusSet s) fid n = case OSet.findIndex <$> fid <*> pure s of
6747 Just Nothing -> OSet.elemAt s 0
6848 Just (Just ix) -> OSet.elemAt s $ mod (ix + n) (OSet.size s)
6949
50+data Refocus = Refocus_Shift Int
51+ | Refocus_Id FocusId
52+ | Refocus_Clear
53+
7054newtype Focus t m a = Focus
7155 { unFocus :: DynamicWriterT t FocusSet
7256 (ReaderT (Demux t (Maybe FocusId))
73− (EventWriterT t (First (Maybe FocusId)) m)) a
57+ (EventWriterT t (First Refocus) m)) a
7458 }
7559 deriving
7660 ( Functor
@@ -91,12 +75,14 @@ newtype Focus t m a = Focus
9175instance MonadTrans (Focus t) where
9276 lift = Focus . lift . lift . lift
9377
78+instance (HasVtyInput t m, Monad m) => HasVtyInput t (Focus t m)
79+
9480newtype FocusId = FocusId NodeId
9581 deriving (Eq, Ord)
9682
9783class (Monad m, Reflex t) => MonadFocus t m | m -> t where
9884 focusId :: m FocusId
99− requestFocus :: Event t (Maybe FocusId) -> m ()
85+ requestFocus :: Event t Refocus -> m ()
10086 isFocused :: FocusId -> m (Dynamic t Bool)
10187
10288instance (Reflex t, Monad m, MonadNodeId m) => MonadFocus t (Focus t m) where
@@ -115,20 +101,38 @@ runFocus
115101 -> m (a, Dynamic t FocusSet)
116102runFocus (Focus x) = do
117103 rec ((a, focusIds), focusRequests) <- runEventWriterT $ flip runReaderT (demux sel) $ runDynamicWriterT x
118− sel <- holdDyn Nothing $ getFirst <$> focusRequests
104+ sel <- foldDyn f Nothing $ attach (current focusIds) focusRequests
119105 pure (a, focusIds)
120−
121−tile
106+ where
107+ f :: (FocusSet, First Refocus) -> Maybe FocusId -> Maybe FocusId
108+ f (fs, rf) mf = case getFirst rf of
109+ Refocus_Clear -> Nothing
110+ Refocus_Id fid -> Just fid
111+ Refocus_Shift n -> shiftFS fs mf n
112+
113+-- TODO unify this with tile, perhaps
114+tileC
122115 :: (MonadNodeId m, MonadFix m, Reflex t)
123− => VtyWidget t m a
116+ => Dynamic t Constraint
117+ -> VtyWidget t m a
124118 -> Layout t (Focus t (VtyWidget t m)) (FocusId, a)
125−tile w = do
119+tileC c w = do
126120 fid <- focusId
127121 focused <- isFocused fid
128− r <- stretch 0
129− result <- lift $ lift $ pane r focused w
122+ r <- leaf c
123+ (click, result) <- lift $ lift $ pane r focused $ do
124+ click <- mouseDown V.BLeft
125+ result <- w
126+ pure (click, result)
127+ requestFocus $ Refocus_Id fid <$ click
130128 pure (fid, result)
131129
130+tile
131+ :: (MonadNodeId m, MonadFix m, Reflex t)
132+ => VtyWidget t m a
133+ -> Layout t (Focus t (VtyWidget t m)) (FocusId, a)
134+tile = tileC (pure $ Constraint_Min 0)
135+
132136tile_
133137 :: (MonadNodeId m, MonadFix m, Reflex t)
134138 => VtyWidget t m a
@@ -185,6 +189,9 @@ newtype Layout t m a = Layout
185189instance MonadTrans (Layout t) where
186190 lift = Layout . lift . lift
187191
192+instance (HasVtyInput t m, Monad m) => HasVtyInput t (Layout t m)
193+
194+-- TODO Naming: To Has or not to Has?
188195class Monad m => MonadLayout t m | m -> t where
189196 axis :: Dynamic t Orientation -> Dynamic t Constraint -> m a -> m a
190197 leaf :: Dynamic t Constraint -> m (Dynamic t Region)
@@ -193,7 +200,7 @@ class Monad m => MonadLayout t m | m -> t where
193200instance (Monad m, MonadNodeId m, Reflex t, MonadFix m) => MonadLayout t (Layout t m) where
194201 axis o c (Layout x) = Layout $ do
195202 nodeId <- getNextNodeId
196− (result, forest) <- lift $ local (\t -> (\(Just x) -> x) . lookupLF nodeId . ltreeForest <$> t) $ runDynamicWriterT x
203+ (result, forest) <- lift $ local (\t -> (\(Just a) -> a) . lookupLF nodeId . ltreeForest <$> t) $ runDynamicWriterT x
197204 tellDyn $ singletonLF nodeId <$> (LTree <$> ((,) <$> c <*> o) <*> forest)
198205 pure result
199206 leaf c = do
@@ -226,6 +233,7 @@ row, col
226233row = axis (pure Orientation_Row) (pure $ Constraint_Min 0)
227234col = axis (pure Orientation_Column) (pure $ Constraint_Min 0)
228235
236+-- TODO possibly get rid of this and stretch
229237fixed
230238 :: (Reflex t, MonadLayout t m)
231239 => Dynamic t Int
@@ -304,27 +312,11 @@ runLayout o r (Layout x) = do
304312 let solutions = solve <$> o <*> r <*> w
305313 return result
306314
307−{-
308−-- | Captures the click event in a 'VtyWidget' context and returns it. Useful for
309−-- requesting focus when using 'tile'.
310−clickable
311− :: (Reflex t, Monad m)
312− => VtyWidget t m a
313− -> VtyWidget t m (Event t (), a)
314−clickable child = do
315− click <- mouseDown V.BLeft
316− a <- child
317− return (() <$ click, a)
318−
319−-}
320−
321−-- | Produces an 'Event' that navigates forward one tile when the Tab key is pressed
322−-- and backward one tile when Shift+Tab is pressed.
323−tabNavigation :: (Reflex t, Monad m) => VtyWidget t m (Event t Int)
315+tabNavigation :: (Reflex t, MonadNodeId m, HasVtyInput t m, MonadFocus t m) => m ()
324316tabNavigation = do
325317 fwd <- fmap (const 1) <$> key (V.KChar '\t')
326318 back <- fmap (const (-1)) <$> key V.KBackTab
327− return $ leftmost [fwd, back]
319+ requestFocus $ Refocus_Shift <$> leftmost [fwd, back]
328320
329321test :: IO ()
330322test = mainWidget $ do
@@ -335,19 +327,14 @@ test = mainWidget $ do
335327 text' t = do
336328 f <- focus
337329 richText (RichTextConfig $ current $ (\x -> if x then V.withStyle V.defAttr V.bold else V.defAttr) <$> f) t
338− tab <- tabNavigation
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
330+ rec (_, _) <- runFocus $ do
331+ tabNavigation
342332 runLayout (pure Orientation_Column) r $ do
343333 col $ do
344334 tile_ $ text' "asdf"
345335 tile_ $ text' "asdf"
346336 row $ do
347− (fid, click) <- tile $ do
348− text' "CLICK ME"
349− mouseDown V.BLeft
350− requestFocus $ Just fid <$ click
337+ tile_ $ text' "xyz"
351338 tile_ $ text' "xyz"
352339 tile_ $ text' "xyz"
353340 tile_ $ text' "xyz"