git.iko.soy/reflex-vty
on develop help sign in
Sublayout and subfocus support; Make widgets more polymorphic
commit9bb4bc239710cddce59536dd8bc2581000952810 authorAli Abrar <aliabrar@gmail.com> dateMon 15 Mar 2021, 23:31 (6 years ago) parent9fb317f
4 files changed+222−125
compare with develop
unifiedsplit
src/Reflex/Vty/Widget.hs+61−49 src/Reflex/Vty/Widget/Input.hs+16−16 src/Reflex/Vty/Widget/Input/Text.hs+6−6 src/Reflex/Vty/Widget/Layout.hs+139−54
src/Reflex/Vty/Widget.hs+61−49
@@ -15,6 +15,7 @@ module Reflex.Vty.Widget
1515 , HasDisplaySize(..)
1616 , HasFocus(..)
1717 , HasVtyInput(..)
18+ , HasVtyWidgetCtx(..)
1819 , Region(..)
1920 , regionSize
2021 , regionBlankImage
@@ -57,7 +58,8 @@ module Reflex.Vty.Widget
5758import Control.Applicative (liftA2)
5859import Control.Monad.Fix (MonadFix)
5960import Control.Monad.IO.Class (MonadIO)
60−import Control.Monad.Reader (ReaderT, ask, asks, runReaderT)
61+import Control.Monad.NodeId
62+import Control.Monad.Reader (ReaderT, ask, asks, local, runReaderT)
6163import Control.Monad.Trans (MonadTrans, lift)
6264import Data.Default (Default(..))
6365import Data.Set (Set)
@@ -70,11 +72,8 @@ import qualified Graphics.Vty as V
7072import Reflex
7173import Reflex.Class ()
7274import Reflex.Host.Class (MonadReflexCreateTrigger)
73−
7475import Reflex.Vty.Host
7576
76−import Control.Monad.NodeId
77−
7877-- | The context within which a 'VtyWidget' runs
7978data VtyWidgetCtx t = VtyWidgetCtx
8079 { _vtyWidgetCtx_width :: Dynamic t Int
@@ -131,6 +130,19 @@ instance MonadNodeId m => MonadNodeId (VtyWidget t m) where
131130 getNextNodeId = VtyWidget $ do
132131 lift $ lift getNextNodeId
133132
133+class HasVtyWidgetCtx t m | m -> t where
134+ askCtx :: m (VtyWidgetCtx t)
135+ default askCtx :: (f m' ~ m, Monad m', MonadTrans f, HasVtyWidgetCtx t m') => m (VtyWidgetCtx t)
136+ askCtx = lift askCtx
137+ localCtx :: (VtyWidgetCtx t -> VtyWidgetCtx t) -> (Behavior t [Image] -> Behavior t [Image]) -> m a -> m a
138+
139+instance (Monad m, Reflex t) => HasVtyWidgetCtx t (VtyWidget t m) where
140+ askCtx = VtyWidget $ lift ask
141+ localCtx f g (VtyWidget x) = VtyWidget $ do
142+ (a, images) :: (a, Behavior t [Image]) <- lift $ local f $ runBehaviorWriterT x
143+ tellImages $ g images
144+ pure a
145+
134146-- | Runs a 'VtyWidget' with a given context
135147runVtyWidget
136148 :: (Reflex t, MonadNodeId m)
@@ -208,6 +220,8 @@ instance (Reflex t, Monad m) => HasVtyInput t (VtyWidget t m) where
208220-- | A class for things that can dynamically gain and lose focus
209221class HasFocus t m | m -> t where
210222 focus :: m (Dynamic t Bool)
223+ default focus :: (f m' ~ m, Monad m', MonadTrans f, HasFocus t m') => m (Dynamic t Bool)
224+ focus = lift focus
211225
212226instance (Reflex t, Monad m) => HasFocus t (VtyWidget t m) where
213227 focus = VtyWidget . lift $ asks _vtyWidgetCtx_focus
@@ -216,6 +230,8 @@ instance (Reflex t, Monad m) => HasFocus t (VtyWidget t m) where
216230class (Reflex t, Monad m) => ImageWriter t m | m -> t where
217231 -- | Send images upstream for rendering
218232 tellImages :: Behavior t [Image] -> m ()
233+ default tellImages :: (f m' ~ m, Monad m', MonadTrans f, ImageWriter t m') => Behavior t [Image] -> m ()
234+ tellImages = lift . tellImages
219235
220236instance (Monad m, Reflex t) => ImageWriter t (BehaviorWriterT t [Image] m) where
221237 tellImages = tellBehavior
@@ -255,18 +271,16 @@ withinImage (Region left top width height)
255271-- * mouse inputs outside the region are ignored
256272-- * mouse inputs inside the region have their coordinates translated such
257273-- that (0,0) is the top-left corner of the region
258−-- TODO make this polymorphic
259274pane
260− :: (Reflex t, Monad m, MonadNodeId m)
275+ :: (Reflex t, Monad m, MonadNodeId m, HasVtyWidgetCtx t m)
261276 => Dynamic t Region
262277 -> Dynamic t Bool -- ^ Whether the widget should be focused when the parent is.
263− -> VtyWidget t m a
264− -> VtyWidget t m a
265−pane dr foc child = VtyWidget $ do
266− ctx <- lift ask
278+ -> m a
279+ -> m a
280+pane dr foc child = do
267281 let reg = current dr
268− let ctx' = VtyWidgetCtx
269− { _vtyWidgetCtx_input = leftmost -- TODO: think about this leftmost more.
282+ let subContext ctx = VtyWidgetCtx
283+ { _vtyWidgetCtx_input = leftmost
270284 [ fmapMaybe id $
271285 attachWith (\(r,f) e -> filterInput r f e)
272286 (liftA2 (,) reg (current foc))
@@ -276,10 +290,8 @@ pane dr foc child = VtyWidget $ do
276290 , _vtyWidgetCtx_width = _region_width <$> dr
277291 , _vtyWidgetCtx_height = _region_height <$> dr
278292 }
279− (result, images) <- lift . lift $ runVtyWidget ctx' child -- TODO can we use a local-based implementation?
280− let images' = liftA2 (\r is -> map (withinImage r) is) reg images
281− tellImages images'
282− return result
293+ let imagesWithinRegion images = liftA2 (\is r -> map (withinImage r) is) images reg
294+ localCtx subContext imagesWithinRegion child
283295 where
284296 filterInput :: Region -> Bool -> VtyEvent -> Maybe VtyEvent
285297 filterInput (Region l t w h) focused e = case e of
@@ -424,16 +436,16 @@ keyCombos ks = do
424436
425437-- | A plain split of the available space into vertically stacked panes.
426438-- No visual separator is built in here.
427−splitV :: (Reflex t, Monad m, MonadNodeId m)
439+splitV :: (Reflex t, Monad m, MonadNodeId m, HasVtyWidgetCtx t m, HasDisplaySize t m)
428440 => Dynamic t (Int -> Int)
429441 -- ^ Function used to determine size of first pane based on available size
430442 -> Dynamic t (Bool, Bool)
431443 -- ^ How to focus the two sub-panes, given that we are focused.
432− -> VtyWidget t m a
444+ -> m a
433445 -- ^ Widget for first pane
434− -> VtyWidget t m b
446+ -> m b
435447 -- ^ Widget for second pane
436− -> VtyWidget t m (a,b)
448+ -> m (a,b)
437449splitV sizeFunD focD wA wB = do
438450 dw <- displayWidth
439451 dh <- displayHeight
@@ -445,16 +457,16 @@ splitV sizeFunD focD wA wB = do
445457
446458-- | A plain split of the available space into horizontally stacked panes.
447459-- No visual separator is built in here.
448−splitH :: (Reflex t, Monad m, MonadNodeId m)
460+splitH :: (Reflex t, Monad m, MonadNodeId m, HasDisplaySize t m, HasVtyWidgetCtx t m)
449461 => Dynamic t (Int -> Int)
450462 -- ^ Function used to determine size of first pane based on available size
451463 -> Dynamic t (Bool, Bool)
452464 -- ^ How to focus the two sub-panes, given that we are focused.
453− -> VtyWidget t m a
465+ -> m a
454466 -- ^ Widget for first pane
455− -> VtyWidget t m b
467+ -> m b
456468 -- ^ Widget for second pane
457− -> VtyWidget t m (a,b)
469+ -> m (a,b)
458470splitH sizeFunD focD wA wB = do
459471 dw <- displayWidth
460472 dh <- displayHeight
@@ -465,11 +477,11 @@ splitH sizeFunD focD wA wB = do
465477-- | A split of the available space into two parts with a draggable separator.
466478-- Starts with half the space allocated to each, and the first pane has focus.
467479-- Clicking in a pane switches focus.
468−splitVDrag :: (Reflex t, MonadFix m, MonadHold t m, MonadNodeId m)
469− => VtyWidget t m ()
470− -> VtyWidget t m a
471− -> VtyWidget t m b
472− -> VtyWidget t m (a,b)
480+splitVDrag :: (Reflex t, MonadFix m, MonadHold t m, MonadNodeId m, HasDisplaySize t m, HasVtyInput t m, HasVtyWidgetCtx t m)
481+ => m ()
482+ -> m a
483+ -> m b
484+ -> m (a,b)
473485splitVDrag wS wA wB = do
474486 dh <- displayHeight
475487 dw <- displayWidth
@@ -503,7 +515,7 @@ splitVDrag wS wA wB = do
503515 return (m, x')
504516
505517-- | Fill the background with a particular character.
506−fill :: (Reflex t, Monad m) => Char -> VtyWidget t m ()
518+fill :: (HasDisplaySize t m, ImageWriter t m) => Char -> m ()
507519fill c = do
508520 dw <- displayWidth
509521 dh <- displayHeight
@@ -511,7 +523,7 @@ fill c = do
511523 tellImages fillImg
512524
513525-- | Fill the background with the bottom
514−hRule :: (Reflex t, Monad m) => BoxStyle -> VtyWidget t m ()
526+hRule :: (HasDisplaySize t m, ImageWriter t m) => BoxStyle -> m ()
515527hRule boxStyle = fill (_boxStyle_s boxStyle)
516528
517529-- | Defines a set of symbols to use to draw the outlines of boxes
@@ -552,11 +564,11 @@ roundedBoxStyle :: BoxStyle
552564roundedBoxStyle = BoxStyle '╭' '─' '╮' '│' '╯' '─' '╰' '│'
553565
554566-- | Draws a titled box in the provided style and a child widget inside of that box
555−boxTitle :: (Monad m, Reflex t, MonadNodeId m)
567+boxTitle :: (Monad m, Reflex t, MonadNodeId m, HasDisplaySize t m, ImageWriter t m, HasVtyWidgetCtx t m)
556568 => Behavior t BoxStyle
557569 -> Text
558− -> VtyWidget t m a
559− -> VtyWidget t m a
570+ -> m a
571+ -> m a
560572boxTitle boxStyle title child = do
561573 dh <- displayHeight
562574 dw <- displayWidth
@@ -604,18 +616,18 @@ boxTitle boxStyle title child = do
604616 right = mkHalf delta
605617
606618-- | A box without a title
607−box :: (Monad m, Reflex t, MonadNodeId m)
619+box :: (Monad m, Reflex t, MonadNodeId m, HasDisplaySize t m, ImageWriter t m, HasVtyWidgetCtx t m)
608620 => Behavior t BoxStyle
609− -> VtyWidget t m a
610− -> VtyWidget t m a
621+ -> m a
622+ -> m a
611623box boxStyle = boxTitle boxStyle mempty
612624
613625-- | A box whose style is static
614626boxStatic
615− :: (Reflex t, Monad m, MonadNodeId m)
627+ :: (Monad m, Reflex t, MonadNodeId m, HasDisplaySize t m, ImageWriter t m, HasVtyWidgetCtx t m)
616628 => BoxStyle
617− -> VtyWidget t m a
618− -> VtyWidget t m a
629+ -> m a
630+ -> m a
619631boxStatic = box . pure
620632
621633-- | Configuration options for displaying "rich" text
@@ -628,10 +640,10 @@ instance Reflex t => Default (RichTextConfig t) where
628640
629641-- | A widget that displays text with custom time-varying attributes
630642richText
631− :: (Reflex t, Monad m)
643+ :: (Reflex t, Monad m, HasDisplaySize t m, ImageWriter t m)
632644 => RichTextConfig t
633645 -> Behavior t Text
634− -> VtyWidget t m ()
646+ -> m ()
635647richText cfg t = do
636648 dw <- displayWidth
637649 let img = (\w a s -> [wrapText w a s])
@@ -646,19 +658,19 @@ richText cfg t = do
646658
647659-- | Renders text, wrapped to the container width
648660text
649− :: (Reflex t, Monad m)
661+ :: (Reflex t, Monad m, HasDisplaySize t m, ImageWriter t m)
650662 => Behavior t Text
651− -> VtyWidget t m ()
663+ -> m ()
652664text = richText def
653665
654666-- | Scrollable text widget. The output pair exposes the current scroll position and total number of lines (including those
655667-- that are hidden)
656668scrollableText
657− :: forall t m. (Reflex t, MonadHold t m, MonadFix m)
669+ :: forall t m. (Reflex t, MonadHold t m, MonadFix m, HasDisplaySize t m, HasVtyInput t m, ImageWriter t m)
658670 => Event t Int
659671 -- ^ Number of lines to scroll by
660672 -> Behavior t Text
661− -> VtyWidget t m (Behavior t (Int, Int))
673+ -> m (Behavior t (Int, Int))
662674 -- ^ (Current scroll position, total number of lines)
663675scrollableText scrollBy t = do
664676 dw <- displayWidth
@@ -686,11 +698,11 @@ scrollableText scrollBy t = do
686698-- | Renders any behavior whose value can be converted to
687699-- 'String' as text
688700display
689− :: (Reflex t, Monad m, Show a)
701+ :: (Reflex t, Monad m, Show a, HasDisplaySize t m, ImageWriter t m)
690702 => Behavior t a
691− -> VtyWidget t m ()
703+ -> m ()
692704display a = text $ T.pack . show <$> a
693705
694706-- | A widget that draws nothing
695−blank :: Monad m => VtyWidget t m ()
707+blank :: Monad m => m ()
696708blank = return ()
src/Reflex/Vty/Widget/Input.hs+16−16
@@ -30,10 +30,10 @@ instance Reflex t => Default (ButtonConfig t) where
3030
3131-- | A button widget that contains a sub-widget
3232button
33− :: (Reflex t, Monad m, MonadNodeId m)
33+ :: (Reflex t, Monad m, MonadNodeId m, HasFocus t m, HasDisplaySize t m, ImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)
3434 => ButtonConfig t
35− -> VtyWidget t m ()
36− -> VtyWidget t m (Event t ())
35+ -> m ()
36+ -> m (Event t ())
3737button cfg child = do
3838 f <- focus
3939 let style = do
@@ -48,25 +48,25 @@ button cfg child = do
4848
4949-- | A button widget that displays text that can change
5050textButton
51− :: (Reflex t, Monad m, MonadNodeId m)
51+ :: (Reflex t, Monad m, MonadNodeId m, HasDisplaySize t m, HasFocus t m, ImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)
5252 => ButtonConfig t
5353 -> Behavior t Text
54− -> VtyWidget t m (Event t ())
54+ -> m (Event t ())
5555textButton cfg = button cfg . text -- TODO Centering etc.
5656
5757-- | A button widget that displays a static bit of text
5858textButtonStatic
59− :: (Reflex t, Monad m, MonadNodeId m)
59+ :: (Reflex t, Monad m, MonadNodeId m, HasDisplaySize t m, HasFocus t m, ImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)
6060 => ButtonConfig t
6161 -> Text
62− -> VtyWidget t m (Event t ())
62+ -> m (Event t ())
6363textButtonStatic cfg = textButton cfg . pure
6464
6565-- | A clickable link widget
6666link
67− :: (Reflex t, Monad m)
67+ :: (Reflex t, Monad m, HasDisplaySize t m, ImageWriter t m, HasVtyInput t m)
6868 => Behavior t Text
69− -> VtyWidget t m (Event t MouseUp)
69+ -> m (Event t MouseUp)
7070link t = do
7171 let cfg = RichTextConfig
7272 { _richTextConfig_attributes = pure $ V.withStyle V.defAttr V.underline
@@ -76,9 +76,9 @@ link t = do
7676
7777-- | A clickable link widget with a static label
7878linkStatic
79− :: (Reflex t, Monad m)
79+ :: (Reflex t, Monad m, ImageWriter t m, HasDisplaySize t m, HasVtyInput t m)
8080 => Text
81− -> VtyWidget t m (Event t MouseUp)
81+ -> m (Event t MouseUp)
8282linkStatic = link . pure
8383
8484-- | Characters used to render checked and unchecked textboxes
@@ -118,10 +118,10 @@ instance (Reflex t) => Default (CheckboxConfig t) where
118118
119119-- | A checkbox widget
120120checkbox
121− :: (MonadHold t m, MonadFix m, Reflex t)
121+ :: (MonadHold t m, MonadFix m, Reflex t, HasVtyInput t m, HasDisplaySize t m, ImageWriter t m)
122122 => CheckboxConfig t
123123 -> Bool
124− -> VtyWidget t m (Dynamic t Bool)
124+ -> m (Dynamic t Bool)
125125checkbox cfg v0 = do
126126 md <- mouseDown V.BLeft
127127 mu <- mouseUp
@@ -130,9 +130,9 @@ checkbox cfg v0 = do
130130 [ V.withStyle mempty V.bold <$ md
131131 , mempty <$ mu
132132 ]
133− let attrs = (<>) <$> (_checkboxConfig_attributes cfg) <*> depressed
133+ let attrs = (<>) <$> _checkboxConfig_attributes cfg <*> depressed
134134 richText (RichTextConfig attrs) $ join . current $ ffor v $ \checked ->
135135 if checked
136− then fmap _checkboxStyle_checked $ _checkboxConfig_checkboxStyle cfg
137− else fmap _checkboxStyle_unchecked $ _checkboxConfig_checkboxStyle cfg
136+ then _checkboxStyle_checked <$> _checkboxConfig_checkboxStyle cfg
137+ else _checkboxStyle_unchecked <$> _checkboxConfig_checkboxStyle cfg
138138 return v
src/Reflex/Vty/Widget/Input/Text.hs+6−6
@@ -81,9 +81,9 @@ textInput cfg = do
8181
8282-- | A widget that allows multiline text input
8383multilineTextInput
84− :: (Reflex t, MonadHold t m, MonadFix m)
84+ :: (Reflex t, MonadHold t m, MonadFix m, HasVtyInput t m, HasFocus t m, HasDisplaySize t m, ImageWriter t m)
8585 => TextInputConfig t
86− -> VtyWidget t m (TextInput t)
86+ -> m (TextInput t)
8787multilineTextInput cfg = do
8888 i <- input
8989 textInput $ cfg
@@ -99,13 +99,13 @@ multilineTextInput cfg = do
9999-- the computed line count to greedily size the tile when vertically
100100-- oriented, and uses the fallback width when horizontally oriented.
101101textInputTile
102− :: (Monad m, MonadNodeId m, Reflex t, MonadFix m)
103− => VtyWidget t m (TextInput t)
102+ :: (Monad m, MonadNodeId m, Reflex t, MonadFix m, MonadLayout t m, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m)
103+ => m (TextInput t)
104104 -> Dynamic t Int
105− -> Layout t (Focus t (VtyWidget t m)) (TextInput t)
105+ -> m (TextInput t)
106106textInputTile txt width = do
107107 o <- askOrientation
108− rec (_, t) <- tileC (Constraint_Fixed <$> sz) txt
108+ rec (_, t) <- tile (Constraint_Fixed <$> sz) txt
109109 let sz = join $ ffor o $ \case
110110 Orientation_Column -> _textInput_lines t
111111 Orientation_Row -> width
src/Reflex/Vty/Widget/Layout.hs+139−54
@@ -6,9 +6,10 @@ Description: Monad transformer and tools for arranging widgets and building scre
66
77module Reflex.Vty.Widget.Layout where
88
9+import Control.Applicative (liftA2)
910import Control.Monad.NodeId (MonadNodeId(..), NodeId)
1011import Control.Monad.Reader
11−import Data.List
12+import Data.List (mapAccumL)
1213import Data.Map.Ordered (OMap)
1314import qualified Data.Map.Ordered as OMap
1415import Data.Ratio ((%))
@@ -46,7 +47,7 @@ data Refocus = Refocus_Shift Int
4647
4748newtype Focus t m a = Focus
4849 { unFocus :: DynamicWriterT t FocusSet
49− (ReaderT (Demux t (Maybe FocusId))
50+ (ReaderT (Dynamic t (Maybe FocusId)) -- TODO Demux?
5051 (EventWriterT t (First Refocus) m)) a
5152 }
5253 deriving
@@ -69,6 +70,16 @@ instance MonadTrans (Focus t) where
6970 lift = Focus . lift . lift . lift
7071
7172instance (HasVtyInput t m, Monad m) => HasVtyInput t (Focus t m)
73+instance (HasVtyWidgetCtx t m, Reflex t, MonadFix m) => HasVtyWidgetCtx t (Focus t m) where
74+ localCtx f g (Focus w) = Focus $ do
75+ d <- ask
76+ ((a, fs), e) <- lift $ lift $ lift $ localCtx f g $ runEventWriterT $ flip runReaderT d $ runDynamicWriterT w
77+ tellEvent e
78+ tellDyn fs
79+ return a
80+
81+instance ImageWriter t m => ImageWriter t (Focus t m)
82+instance (HasFocus t m, Monad m) => HasFocus t (Focus t m)
7283
7384newtype FocusId = FocusId NodeId
7485 deriving (Eq, Ord)
@@ -77,8 +88,10 @@ class (Monad m, Reflex t) => MonadFocus t m | m -> t where
7788 focusId :: m FocusId
7889 requestFocus :: Event t Refocus -> m ()
7990 isFocused :: FocusId -> m (Dynamic t Bool)
91+ subFoci :: m a -> m (a, Dynamic t FocusSet)
92+ focusedId :: m (Dynamic t (Maybe FocusId))
8093
81−instance (Reflex t, Monad m, MonadNodeId m) => MonadFocus t (Focus t m) where
94+instance (Reflex t, MonadFix m, MonadNodeId m) => MonadFocus t (Focus t m) where
8295 focusId = do
8396 fid <- FocusId <$> lift getNextNodeId
8497 Focus $ tellDyn $ pure $ singletonFS fid
@@ -86,14 +99,19 @@ instance (Reflex t, Monad m, MonadNodeId m) => MonadFocus t (Focus t m) where
8699 requestFocus = Focus . tellEvent . fmap First
87100 isFocused fid = do
88101 sel <- Focus ask
89− pure $ demuxed sel $ Just fid
102+ pure $ (== Just fid) <$> sel
103+ subFoci (Focus child) = Focus $ do
104+ (a, fs) <- lift $ runDynamicWriterT child
105+ tellDyn fs
106+ return (a, fs)
107+ focusedId = Focus ask
90108
91109runFocus
92110 :: (MonadFix m, MonadHold t m, Reflex t)
93111 => Focus t m a
94112 -> m (a, Dynamic t FocusSet)
95113runFocus (Focus x) = do
96− rec ((a, focusIds), focusRequests) <- runEventWriterT $ flip runReaderT (demux sel) $ runDynamicWriterT x
114+ rec ((a, focusIds), focusRequests) <- runEventWriterT $ flip runReaderT sel $ runDynamicWriterT x
97115 sel <- foldDyn f Nothing $ attach (current focusIds) focusRequests
98116 pure (a, focusIds)
99117 where
@@ -103,40 +121,41 @@ runFocus (Focus x) = do
103121 Refocus_Id fid -> Just fid
104122 Refocus_Shift n -> shiftFS fs mf n
105123
106−-- TODO unify this with tile, perhaps
107−tileC
108− :: (MonadNodeId m, MonadFix m, Reflex t)
124+tile
125+ :: (MonadNodeId m, MonadFix m, Reflex t, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m)
109126 => Dynamic t Constraint
110− -> VtyWidget t m a
111− -> Layout t (Focus t (VtyWidget t m)) (FocusId, a)
112−tileC c w = do
127+ -> m a
128+ -> m (FocusId, a)
129+tile c w = do
113130 fid <- focusId
114− focused <- isFocused fid
115131 r <- leaf c
116− (click, result) <- lift $ lift $ pane r focused $ do
117− click <- mouseDown V.BLeft
118− result <- w
119− pure (click, result)
132+ fid' <- focusedId
133+ parentFocused <- isFocused fid
134+ rec (click, result, subs) <- pane r focused $ do
135+ m <- mouseDown V.BLeft
136+ (x, sf) <- subFoci w
137+ pure (m, x, sf)
138+ let childFocused = liftA2 (\f s -> case f of
139+ Nothing -> False
140+ Just f' -> OSet.member f' $ unFocusSet s) fid' subs
141+ let focused = (||) <$> parentFocused <*> childFocused
120142 requestFocus $ Refocus_Id fid <$ click
121143 pure (fid, result)
122144
123−tile
124− :: (MonadNodeId m, MonadFix m, Reflex t)
125− => VtyWidget t m a
126− -> Layout t (Focus t (VtyWidget t m)) (FocusId, a)
127−tile = tileC (pure $ Constraint_Min 0)
128−
129145tile_
130− :: (MonadNodeId m, MonadFix m, Reflex t)
131− => VtyWidget t m a
132− -> Layout t (Focus t (VtyWidget t m)) a
133−tile_ = fmap snd . tile
146+ :: (MonadNodeId m, MonadFix m, Reflex t, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m)
147+ => Dynamic t Constraint
148+ -> m a
149+ -> m a
150+tile_ c = fmap snd . tile c
134151
135152-- * Layout
136153
137154data LTree a = LTree a (LForest a)
155+ deriving (Show)
138156
139157newtype LForest a = LForest { unLForest :: OMap NodeId (LTree a) }
158+ deriving (Show)
140159
141160instance Semigroup (LForest a) where
142161 LForest a <> LForest b = LForest $ a OMap.|<> b
@@ -182,7 +201,19 @@ newtype Layout t m a = Layout
182201instance MonadTrans (Layout t) where
183202 lift = Layout . lift . lift
184203
204+instance (HasVtyWidgetCtx t m, HasDisplaySize t m, Reflex t, MonadFix m) => HasVtyWidgetCtx t (Layout t m) where
205+ localCtx f g x = do
206+ solution <- Layout ask
207+ let orientation = snd . ltreeRoot <$> solution
208+ lift $ localCtx f g $ do
209+ dw <- displayWidth
210+ dh <- displayHeight
211+ let region = Region 0 0 <$> dw <*> dh
212+ runLayout orientation region x
213+
185214instance (HasVtyInput t m, Monad m) => HasVtyInput t (Layout t m)
215+instance ImageWriter t m => ImageWriter t (Layout t m)
216+instance (HasFocus t m, Monad m) => HasFocus t (Layout t m)
186217
187218-- TODO Naming: To Has or not to Has?
188219class Monad m => MonadLayout t m | m -> t where
@@ -200,13 +231,19 @@ instance (Monad m, MonadNodeId m, Reflex t, MonadFix m) => MonadLayout t (Layout
200231 nodeId <- lift getNextNodeId
201232 Layout $ tellDyn $ ffor c $ \c' -> singletonLF nodeId $ LTree (c', Orientation_Row) mempty
202233 solutions <- Layout ask
203− pure $ maybe (Region 0 0 0 0) (fst . ltreeRoot) . lookupLF nodeId . ltreeForest <$> solutions
234+ pure $ maybe (error "leaf: could not find layout solution") (fst . ltreeRoot) . lookupLF nodeId . ltreeForest <$> solutions
204235 askOrientation = Layout $ asks $ fmap (snd . ltreeRoot)
205236
206−instance MonadFocus t m => MonadFocus t (Layout t m) where
237+instance (MonadFix m, MonadFocus t m) => MonadFocus t (Layout t m) where
207238 focusId = lift focusId
208239 requestFocus = lift . requestFocus
209240 isFocused = lift . isFocused
241+ focusedId = lift focusedId
242+ subFoci (Layout x) = Layout $ do
243+ y <- ask
244+ ((a, w), sf) <- lift $ lift $ subFoci $ flip runReaderT y $ runDynamicWriterT x
245+ tellDyn w
246+ pure (a, sf)
210247
211248-- | Datatype representing constraints on a widget's size along the main axis (see 'Orientation')
212249data Constraint = Constraint_Fixed Int
@@ -220,24 +257,51 @@ data Orientation = Orientation_Column
220257
221258
222259row, col
223− :: (Reflex t, MonadLayout t m)
260+ :: (Reflex t, MonadNodeId m, MonadFix m, MonadLayout t m)
224261 => m a
225262 -> m a
226263row = axis (pure Orientation_Row) (pure $ Constraint_Min 0)
227264col = axis (pure Orientation_Column) (pure $ Constraint_Min 0)
228265
229−-- TODO possibly get rid of this and stretch
230266fixed
231− :: (Reflex t, MonadLayout t m)
267+ :: (Reflex t, MonadNodeId m, MonadFix m, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m)
232268 => Dynamic t Int
233− -> m (Dynamic t Region)
234−fixed = leaf . fmap Constraint_Fixed
269+ -> m a
270+ -> m (FocusId, a)
271+fixed n = tile (Constraint_Fixed <$> n)
272+
273+fixed_
274+ :: (Reflex t, MonadNodeId m, MonadFix m, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m)
275+ => Dynamic t Int
276+ -> m a
277+ -> m a
278+fixed_ n = fmap snd . fixed n
235279
236280stretch
237− :: (Reflex t, MonadLayout t m)
281+ :: (Reflex t, MonadNodeId m, MonadFix m, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m)
238282 => Dynamic t Int
239− -> m (Dynamic t Region)
240−stretch minSz = leaf (Constraint_Min <$> minSz)
283+ -> m a
284+ -> m (FocusId, a)
285+stretch minSz = tile (Constraint_Min <$> minSz)
286+
287+stretch_
288+ :: (Reflex t, MonadNodeId m, MonadFix m, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m)
289+ => Dynamic t Int
290+ -> m a
291+ -> m a
292+stretch_ minSz = fmap snd . tile (Constraint_Min <$> minSz)
293+
294+flex
295+ :: (Reflex t, MonadNodeId m, MonadFix m, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m)
296+ => m a
297+ -> m (FocusId, a)
298+flex = tile (pure $ Constraint_Min 0)
299+
300+flex_
301+ :: (Reflex t,MonadNodeId m, MonadFix m, HasVtyWidgetCtx t m, HasVtyInput t m, MonadFocus t m, MonadLayout t m)
302+ => m a
303+ -> m a
304+flex_ = fmap snd . flex
241305
242306ltreeConstraint :: LTree (Constraint, a) -> Constraint
243307ltreeConstraint (LTree (c, _) _) = c
@@ -281,7 +345,7 @@ computeSizes available constraints =
281345 (_, Constraint_Min n) -> n
282346 leftover = max 0 (available - minTotal)
283347 numStretch = length $ filter (isMin . snd) constraints
284− szStretch = floor $ leftover % (max numStretch 1)
348+ szStretch = floor $ leftover % max numStretch 1
285349 adjustment = max 0 $ available - minTotal - szStretch * numStretch
286350 in snd $ mapAccumL (\adj (a, c) -> case c of
287351 Constraint_Fixed n -> (adj, (a, n))
@@ -314,25 +378,46 @@ tabNavigation = do
314378test :: IO ()
315379test = mainWidget $ do
316380 inp <- input
317− dw <- displayWidth
318− dh <- displayHeight
319− let r = Region <$> 0 <*> 0 <*> dw <*> dh
381+ let box' w = do
382+ f <- focus
383+ box (ffor (current f) $ \x -> if x then doubleBoxStyle else singleBoxStyle) $ w
320384 text' t = do
321385 f <- focus
322− richText (RichTextConfig $ current $ (\x -> if x then V.withStyle V.defAttr V.bold else V.defAttr) <$> f) t
323− rec (_, _) <- runFocus $ do
324− tabNavigation
325− runLayout (pure Orientation_Column) r $ do
326− col $ do
327− tile_ $ text' "asdf"
328− tile_ $ text' "asdf"
329− row $ do
330− tile_ $ text' "xyz"
331− tile_ $ text' "xyz"
332− tile_ $ text' "xyz"
333− tile_ $ text' "xyz"
334− tile_ $ text' "asdf"
335− tile_ $ text' "asdf"
386+ box' $ richText (RichTextConfig $ current $ (\x -> if x then V.withStyle V.defAttr V.underline else V.defAttr) <$> f) t
387+ initManager_ $ do
388+ tabNavigation
389+ col $ do
390+ fixed_ 5 $ box' $ row $ do
391+ flex_ $ do
392+ text' "asdf"
393+ flex_ $ text' "xyz"
394+ fixed_ 5 $ do
395+ text' " 1"
396+ row $ do
397+ tile_ (pure $ Constraint_Min 0) $ do
398+ text' "2"
399+ flex_ $ text' "3"
400+ flex_ $ text' "xyz"
401+ flex_ $ text' "xyz"
402+ flex_ $ text' "asdf"
403+ flex_ $ text' "asdf"
336404 return $ fforMaybe inp $ \case
337405 V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
338406 _ -> Nothing
407+
408+-- TODO: 'Manager'? as in "window manager"
409+initManager
410+ :: (HasDisplaySize t m, Reflex t, MonadHold t m, MonadFix m)
411+ => Layout t (Focus t m) a
412+ -> m (a, Dynamic t FocusSet)
413+initManager f = do
414+ dw <- displayWidth
415+ dh <- displayHeight
416+ let r = Region 0 0 <$> dw <*> dh
417+ runFocus $ runLayout (pure Orientation_Column) r f
418+
419+initManager_
420+ :: (HasDisplaySize t m, Reflex t, MonadHold t m, MonadFix m)
421+ => Layout t (Focus t m) a
422+ -> m a
423+initManager_ = fmap fst . initManager