git.iko.soy/reflex-vty
on develop help sign in
Add localInput, anyChildFocused, and filterKeys for input filtering
0b0828aAli Abrar
src-bin/example.hs+21−25
compare with develop
unifiedsplit
@@ -159,34 +159,30 @@ todo
159 => Todo
159 => Todo
160 -> m (TodoOutput t)
160 -> m (TodoOutput t)
161todo t0 = row $ do
161todo t0 = row $ do
162− let getToggleEvent = keyCombos $ Set.fromList
162+ let toggleKeys = Set.fromList
163 [ (V.KChar ' ', [V.MCtrl])
163 [ (V.KChar ' ', [V.MCtrl])
164 , (V.KChar '@', [V.MCtrl])
164 , (V.KChar '@', [V.MCtrl])
165 ]
165 ]
166+ anyChildFocused $ \focused -> do
167+ toggleE <- keyCombos toggleKeys
168+ filterKeys (flip Set.notMember $ Set.insert (V.KChar '\t', []) toggleKeys) $ do
166− rec let cfg = def
169+ rec let cfg = def
167− { _checkboxConfig_setValue = setVal
170+ { _checkboxConfig_setValue = setVal
168− }
171+ }
169− (toggleCB, value) <- tile (fixed 4) $ do
170− e <- getToggleEvent
171− v <- checkbox cfg $ _todo_done t0
172+ value <- tile (fixed 4) $ checkbox cfg $ _todo_done t0
172− pure (e, v)
173− let setVal = attachWith (\v _ -> not v) (current value) $ leftmost
173+ let setVal = attachWith (\v _ -> not v) (current value) $ gate (current focused) toggleE
174− [ toggleCB
175− , toggleTI
176− ]
177− (fid, (ti, toggleTI, d)) <- tile' flex $ do
174+ (fid, (ti, d)) <- tile' flex $ do
178− i <- input
175+ i <- input
179− e <- getToggleEvent
180− v <- textInput $ def
176+ v <- textInput $ def
181− { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }
177+ { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }
182− let deleteSelf = attachWithMaybe backspaceOnEmpty (current $ _textInput_value v) i
178+ let deleteSelf = attachWithMaybe backspaceOnEmpty (current $ _textInput_value v) i
183− return (v, e, deleteSelf)
179+ return (v, deleteSelf)
184− return $ TodoOutput
180+ return $ TodoOutput
185− { _todoOutput_todo = Todo <$> _textInput_value ti <*> value
181+ { _todoOutput_todo = Todo <$> _textInput_value ti <*> value
186− , _todoOutput_delete = d
182+ , _todoOutput_delete = d
187− , _todoOutput_height = _textInput_lines ti
183+ , _todoOutput_height = _textInput_lines ti
188− , _todoOutput_focusId = fid
184+ , _todoOutput_focusId = fid
189− }
185+ }
190 where
186 where
191 backspaceOnEmpty v = \case
187 backspaceOnEmpty v = \case
192 V.EvKey V.KBS _ | T.null v -> Just ()
188 V.EvKey V.KBS _ | T.null v -> Just ()
src/Reflex/Vty/Widget.hs+35−26
@@ -47,6 +47,7 @@ module Reflex.Vty.Widget
47 , doubleBoxStyle
47 , doubleBoxStyle
48 , fill
48 , fill
49 , hRule
49 , hRule
50+ , filterKeys
50 , KeyCombo
51 , KeyCombo
51 , key
52 , key
52 , keys
53 , keys
@@ -82,12 +83,6 @@ data VtyWidgetCtx t = VtyWidgetCtx
82 -- ^ The height of the region allocated to the widget.
83 -- ^ The height of the region allocated to the widget.
83 , _vtyWidgetCtx_focus :: Dynamic t Bool
84 , _vtyWidgetCtx_focus :: Dynamic t Bool
84 -- ^ Whether the widget should behave as if it has focus for keyboard input.
85 -- ^ Whether the widget should behave as if it has focus for keyboard input.
85− , _vtyWidgetCtx_input :: Event t VtyEvent
86− -- ^ User input events that the widget's parent chooses to share. These will generally
87− -- be filtered for relevance:
88− -- * Keyboard inputs are restricted to focused widgets
89− -- * Mouse inputs are restricted to the region in which the widget resides and are
90− -- translated into its internal coordinates.
91 }
86 }
92
87
93-- | The output of a 'VtyWidget'
88-- | The output of a 'VtyWidget'
@@ -106,7 +101,9 @@ instance (Adjustable t m, MonadHold t m, Reflex t) => Adjustable t (VtyWidget t
106
101
107-- | A widget that can read its context and produce image output
102-- | A widget that can read its context and produce image output
108newtype VtyWidget t m a = VtyWidget
103newtype VtyWidget t m a = VtyWidget
109− { unVtyWidget :: BehaviorWriterT t [Image] (ReaderT (VtyWidgetCtx t) m) a
104+ { unVtyWidget :: BehaviorWriterT t [Image]
105+ (ReaderT (VtyWidgetCtx t)
106+ (ReaderT (Event t VtyEvent) m)) a
110 } deriving
107 } deriving
111 ( Functor
108 ( Functor
112 , Applicative
109 , Applicative
@@ -124,7 +121,7 @@ newtype VtyWidget t m a = VtyWidget
124
121
125deriving instance PerformEvent t m => PerformEvent t (VtyWidget t m)
122deriving instance PerformEvent t m => PerformEvent t (VtyWidget t m)
126instance MonadTrans (VtyWidget t) where
123instance MonadTrans (VtyWidget t) where
127− lift f = VtyWidget $ lift $ lift f
124+ lift f = VtyWidget $ lift $ lift $ lift f
128
125
129instance MonadNodeId m => MonadNodeId (VtyWidget t m) where
126instance MonadNodeId m => MonadNodeId (VtyWidget t m) where
130 getNextNodeId = VtyWidget $ do
127 getNextNodeId = VtyWidget $ do
@@ -147,10 +144,11 @@ instance (Monad m, Reflex t) => HasVtyWidgetCtx t (VtyWidget t m) where
147-- | Runs a 'VtyWidget' with a given context
144-- | Runs a 'VtyWidget' with a given context
148runVtyWidget
145runVtyWidget
149 :: (Reflex t, MonadNodeId m)
146 :: (Reflex t, MonadNodeId m)
147+ => Event t VtyEvent
150− => VtyWidgetCtx t
148+ -> VtyWidgetCtx t
151 -> VtyWidget t m a
149 -> VtyWidget t m a
152 -> m (a, Behavior t [Image])
150 -> m (a, Behavior t [Image])
153−runVtyWidget ctx w = runReaderT (runBehaviorWriterT (unVtyWidget w)) ctx
151+runVtyWidget e ctx w = runReaderT (runReaderT (runBehaviorWriterT (unVtyWidget w)) ctx) e
154
152
155-- | Sets up the top-level context for a 'VtyWidget' and runs it with that context
153-- | Sets up the top-level context for a 'VtyWidget' and runs it with that context
156mainWidgetWithHandle
154mainWidgetWithHandle
@@ -168,10 +166,9 @@ mainWidgetWithHandle vty child =
168 let ctx = VtyWidgetCtx
166 let ctx = VtyWidgetCtx
169 { _vtyWidgetCtx_width = fmap fst size
167 { _vtyWidgetCtx_width = fmap fst size
170 , _vtyWidgetCtx_height = fmap snd size
168 , _vtyWidgetCtx_height = fmap snd size
171− , _vtyWidgetCtx_input = inp'
172 , _vtyWidgetCtx_focus = constDyn True
169 , _vtyWidgetCtx_focus = constDyn True
173 }
170 }
174− (shutdown, images) <- runNodeIdT $ runVtyWidget ctx $ do
171+ (shutdown, images) <- runNodeIdT $ runVtyWidget inp' ctx $ do
175 tellImages . ffor (current size) $ \(w, h) -> [V.charFill V.defAttr ' ' w h]
172 tellImages . ffor (current size) $ \(w, h) -> [V.charFill V.defAttr ' ' w h]
176 child
173 child
177 return $ VtyResult
174 return $ VtyResult
@@ -206,7 +203,6 @@ instance HasDisplaySize t m => HasDisplaySize t (ReaderT x m)
206instance HasDisplaySize t m => HasDisplaySize t (BehaviorWriterT t x m)
203instance HasDisplaySize t m => HasDisplaySize t (BehaviorWriterT t x m)
207instance HasDisplaySize t m => HasDisplaySize t (DynamicWriterT t x m)
204instance HasDisplaySize t m => HasDisplaySize t (DynamicWriterT t x m)
208instance HasDisplaySize t m => HasDisplaySize t (EventWriterT t x m)
205instance HasDisplaySize t m => HasDisplaySize t (EventWriterT t x m)
209−
210instance HasDisplaySize t m => HasDisplaySize t (NodeIdT m)
206instance HasDisplaySize t m => HasDisplaySize t (NodeIdT m)
211
207
212-- | A class for things that can receive vty events as input
208-- | A class for things that can receive vty events as input
@@ -214,9 +210,23 @@ class HasVtyInput t m | m -> t where
214 input :: m (Event t VtyEvent)
210 input :: m (Event t VtyEvent)
215 default input :: (f m' ~ m, Monad m', MonadTrans f, HasVtyInput t m') => m (Event t VtyEvent)
211 default input :: (f m' ~ m, Monad m', MonadTrans f, HasVtyInput t m') => m (Event t VtyEvent)
216 input = lift input
212 input = lift input
213+ -- | User input events that the widget's parent chooses to share. These will generally
214+ -- be filtered for relevance.
215+ localInput :: (Event t VtyEvent -> Event t VtyEvent) -> m a -> m a
216+
217+-- | Filter the keyboard input that a child widget may receive
218+filterKeys :: (Reflex t, HasVtyInput t m) => (KeyCombo -> Bool) -> m a -> m a
219+filterKeys f x = localInput (ffilter (\case
220+ V.EvKey k mods -> f (k, mods)
221+ _ -> True)) x
217
222
218instance (Reflex t, Monad m) => HasVtyInput t (VtyWidget t m) where
223instance (Reflex t, Monad m) => HasVtyInput t (VtyWidget t m) where
219− input = VtyWidget . lift $ asks _vtyWidgetCtx_input
224+ input = VtyWidget . lift $ lift $ ask
225+ localInput f (VtyWidget m) = VtyWidget $ do
226+ ctx <- ask
227+ (a, images) <- lift $ lift $ local f $ runReaderT (runBehaviorWriterT m) ctx
228+ tellImages images
229+ pure a
220
230
221-- | A class for things that can dynamically gain and lose focus
231-- | A class for things that can dynamically gain and lose focus
222class HasFocus t m | m -> t where
232class HasFocus t m | m -> t where
@@ -273,7 +283,7 @@ withinImage (Region left top width height)
273-- * mouse inputs inside the region have their coordinates translated such
283-- * mouse inputs inside the region have their coordinates translated such
274-- that (0,0) is the top-left corner of the region
284-- that (0,0) is the top-left corner of the region
275pane
285pane
276− :: (Reflex t, Monad m, MonadNodeId m, HasVtyWidgetCtx t m)
286+ :: (Reflex t, Monad m, MonadNodeId m, HasVtyWidgetCtx t m, HasVtyInput t m)
277 => Dynamic t Region
287 => Dynamic t Region
278 -> Dynamic t Bool -- ^ Whether the widget should be focused when the parent is.
288 -> Dynamic t Bool -- ^ Whether the widget should be focused when the parent is.
279 -> m a
289 -> m a
@@ -281,16 +291,15 @@ pane
281pane dr foc child = do
291pane dr foc child = do
282 let reg = current dr
292 let reg = current dr
283 let subContext ctx = VtyWidgetCtx
293 let subContext ctx = VtyWidgetCtx
284− { _vtyWidgetCtx_input = fmapMaybe id $
285− attachWith (\(r,f) e -> filterInput r f e)
286− (liftA2 (,) reg (current foc))
287− (_vtyWidgetCtx_input ctx)
288− , _vtyWidgetCtx_focus = liftA2 (&&) (_vtyWidgetCtx_focus ctx) foc
294+ { _vtyWidgetCtx_focus = liftA2 (&&) (_vtyWidgetCtx_focus ctx) foc
289 , _vtyWidgetCtx_width = _region_width <$> dr
295 , _vtyWidgetCtx_width = _region_width <$> dr
290 , _vtyWidgetCtx_height = _region_height <$> dr
296 , _vtyWidgetCtx_height = _region_height <$> dr
291 }
297 }
298+ inputFilter = fmapMaybe id .
299+ attachWith (\(r,f) e -> filterInput r f e)
300+ (liftA2 (,) reg (current foc))
292 let imagesWithinRegion images = liftA2 (\is r -> map (withinImage r) is) images reg
301 let imagesWithinRegion images = liftA2 (\is r -> map (withinImage r) is) images reg
293− localCtx subContext imagesWithinRegion child
302+ localInput inputFilter $ localCtx subContext imagesWithinRegion child
294 where
303 where
295 filterInput :: Region -> Bool -> VtyEvent -> Maybe VtyEvent
304 filterInput :: Region -> Bool -> VtyEvent -> Maybe VtyEvent
296 filterInput (Region l t w h) focused e = case e of
305 filterInput (Region l t w h) focused e = case e of
@@ -435,7 +444,7 @@ keyCombos ks = do
435
444
436-- | A plain split of the available space into vertically stacked panes.
445-- | A plain split of the available space into vertically stacked panes.
437-- No visual separator is built in here.
446-- No visual separator is built in here.
438−splitV :: (Reflex t, Monad m, MonadNodeId m, HasVtyWidgetCtx t m, HasDisplaySize t m)
447+splitV :: (Reflex t, Monad m, MonadNodeId m, HasVtyWidgetCtx t m, HasDisplaySize t m, HasVtyInput t m)
439 => Dynamic t (Int -> Int)
448 => Dynamic t (Int -> Int)
440 -- ^ Function used to determine size of first pane based on available size
449 -- ^ Function used to determine size of first pane based on available size
441 -> Dynamic t (Bool, Bool)
450 -> Dynamic t (Bool, Bool)
@@ -456,7 +465,7 @@ splitV sizeFunD focD wA wB = do
456
465
457-- | A plain split of the available space into horizontally stacked panes.
466-- | A plain split of the available space into horizontally stacked panes.
458-- No visual separator is built in here.
467-- No visual separator is built in here.
459−splitH :: (Reflex t, Monad m, MonadNodeId m, HasDisplaySize t m, HasVtyWidgetCtx t m)
468+splitH :: (Reflex t, Monad m, MonadNodeId m, HasDisplaySize t m, HasVtyWidgetCtx t m, HasVtyInput t m)
460 => Dynamic t (Int -> Int)
469 => Dynamic t (Int -> Int)
461 -- ^ Function used to determine size of first pane based on available size
470 -- ^ Function used to determine size of first pane based on available size
462 -> Dynamic t (Bool, Bool)
471 -> Dynamic t (Bool, Bool)
@@ -563,7 +572,7 @@ roundedBoxStyle :: BoxStyle
563roundedBoxStyle = BoxStyle '╭' '─' '╮' '│' '╯' '─' '╰' '│'
572roundedBoxStyle = BoxStyle '╭' '─' '╮' '│' '╯' '─' '╰' '│'
564
573
565-- | Draws a titled box in the provided style and a child widget inside of that box
574-- | Draws a titled box in the provided style and a child widget inside of that box
566−boxTitle :: (Monad m, Reflex t, MonadNodeId m, HasDisplaySize t m, ImageWriter t m, HasVtyWidgetCtx t m)
575+boxTitle :: (Monad m, Reflex t, MonadNodeId m, HasDisplaySize t m, ImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)
567 => Behavior t BoxStyle
576 => Behavior t BoxStyle
568 -> Text
577 -> Text
569 -> m a
578 -> m a
@@ -615,7 +624,7 @@ boxTitle boxStyle title child = do
615 right = mkHalf delta
624 right = mkHalf delta
616
625
617-- | A box without a title
626-- | A box without a title
618−box :: (Monad m, Reflex t, MonadNodeId m, HasDisplaySize t m, ImageWriter t m, HasVtyWidgetCtx t m)
627+box :: (Monad m, Reflex t, MonadNodeId m, HasDisplaySize t m, ImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)
619 => Behavior t BoxStyle
628 => Behavior t BoxStyle
620 -> m a
629 -> m a
621 -> m a
630 -> m a
@@ -623,7 +632,7 @@ box boxStyle = boxTitle boxStyle mempty
623
632
624-- | A box whose style is static
633-- | A box whose style is static
625boxStatic
634boxStatic
626− :: (Monad m, Reflex t, MonadNodeId m, HasDisplaySize t m, ImageWriter t m, HasVtyWidgetCtx t m)
635+ :: (Monad m, Reflex t, MonadNodeId m, HasDisplaySize t m, ImageWriter t m, HasVtyWidgetCtx t m, HasVtyInput t m)
627 => BoxStyle
636 => BoxStyle
628 -> m a
637 -> m a
629 -> m a
638 -> m a
src/Reflex/Vty/Widget/Layout.hs+35−12
@@ -119,7 +119,14 @@ instance (Adjustable t m, MonadHold t m, MonadFix m) => Adjustable t (Focus t m)
119 traverseDMapWithKeyWithAdjust f m e = Focus $ traverseDMapWithKeyWithAdjust (\k v -> unFocus $ f k v) m e
119 traverseDMapWithKeyWithAdjust f m e = Focus $ traverseDMapWithKeyWithAdjust (\k v -> unFocus $ f k v) m e
120 traverseDMapWithKeyWithAdjustWithMove f m e = Focus $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unFocus $ f k v) m e
120 traverseDMapWithKeyWithAdjustWithMove f m e = Focus $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unFocus $ f k v) m e
121
121
122−instance (HasVtyInput t m, Monad m) => HasVtyInput t (Focus t m)
122+instance (Reflex t, MonadFix m, HasVtyInput t m) => HasVtyInput t (Focus t m) where
123+ localInput f (Focus w) = Focus $ do
124+ d <- ask
125+ ((a, fs), e) <- lift $ lift $ lift $
126+ localInput f $ runEventWriterT $ flip runReaderT d $ runDynamicWriterT w
127+ tellEvent e
128+ tellDyn fs
129+ return a
123
130
124instance (HasVtyWidgetCtx t m, Reflex t, MonadFix m) => HasVtyWidgetCtx t (Focus t m) where
131instance (HasVtyWidgetCtx t m, Reflex t, MonadFix m) => HasVtyWidgetCtx t (Focus t m) where
125 localCtx f g (Focus w) = Focus $ do
132 localCtx f g (Focus w) = Focus $ do
@@ -330,8 +337,6 @@ chunk o r (offset, sz) = case o of
330 , _region_width = sz
337 , _region_width = sz
331 }
338 }
332
339
333−
334−
335-- ** The layout monad
340-- ** The layout monad
336
341
337-- | A class of operations for creating screen layouts.
342-- | A class of operations for creating screen layouts.
@@ -387,7 +392,15 @@ instance (HasVtyWidgetCtx t m, HasDisplaySize t m, Reflex t, MonadFix m) => HasV
387 let reg = Region 0 0 <$> dw <*> dh
392 let reg = Region 0 0 <$> dw <*> dh
388 runLayout orientation reg x
393 runLayout orientation reg x
389
394
390−instance (HasVtyInput t m, Monad m) => HasVtyInput t (Layout t m)
395+instance (HasVtyInput t m, HasDisplaySize t m, MonadFix m, Reflex t) => HasVtyInput t (Layout t m) where
396+ localInput f x = do
397+ solution <- Layout ask
398+ let orientation = snd . rootLT <$> solution
399+ lift $ localInput f $ do
400+ dw <- displayWidth
401+ dh <- displayHeight
402+ let reg = Region 0 0 <$> dw <*> dh
403+ runLayout orientation reg x
391
404
392instance ImageWriter t m => ImageWriter t (Layout t m)
405instance ImageWriter t m => ImageWriter t (Layout t m)
393
406
@@ -417,6 +430,20 @@ instance (MonadFix m, MonadFocus t m) => MonadFocus t (Layout t m) where
417 tellDyn w
430 tellDyn w
418 pure (a, sf)
431 pure (a, sf)
419
432
433+-- | Runs an action in the focus monad, providing it with information about
434+-- whether any of the foci created within it are focused.
435+anyChildFocused
436+ :: (MonadFocus t m, MonadFix m)
437+ => (Dynamic t Bool -> m a)
438+ -> m a
439+anyChildFocused f = do
440+ fid <- focusedId
441+ rec (a, fs) <- subFoci (f b)
442+ let b = liftA2 (\foc s -> case foc of
443+ Nothing -> False
444+ Just f' -> OSet.member f' $ unFocusSet s) fid fs
445+ pure a
446+
420-- | Runs a 'Layout' action, using the given orientation and region to
447-- | Runs a 'Layout' action, using the given orientation and region to
421-- calculate layout solutions.
448-- calculate layout solutions.
422runLayout
449runLayout
@@ -475,15 +502,11 @@ tile'
475tile' c w = do
502tile' c w = do
476 fid <- makeFocus
503 fid <- makeFocus
477 r <- region c
504 r <- region c
478− fid' <- focusedId
479 parentFocused <- isFocused fid
505 parentFocused <- isFocused fid
480− rec (click, result, subs) <- pane r focused $ do
506+ rec (click, result, childFocused) <- pane r focused $ anyChildFocused $ \childFoc -> do
481 m <- mouseDown V.BLeft
507 m <- mouseDown V.BLeft
482− (x, sf) <- subFoci w
508+ x <- w
483− pure (m, x, sf)
509+ pure (m, x, childFoc)
484− let childFocused = liftA2 (\f s -> case f of
485− Nothing -> False
486− Just f' -> OSet.member f' $ unFocusSet s) fid' subs
487 let focused = (||) <$> parentFocused <*> childFocused
510 let focused = (||) <$> parentFocused <*> childFocused
488 requestFocus $ Refocus_Id fid <$ click
511 requestFocus $ Refocus_Id fid <$ click
489 pure (fid, result)
512 pure (fid, result)
@@ -502,7 +525,7 @@ tile c = fmap snd . tile' c
502-- | A widget that is not focusable and occupies a layout region based on the
525-- | A widget that is not focusable and occupies a layout region based on the
503-- provided constraint.
526-- provided constraint.
504grout
527grout
505− :: (Reflex t, MonadNodeId m, HasVtyWidgetCtx t m, MonadLayout t m)
528+ :: (Reflex t, MonadNodeId m, HasVtyWidgetCtx t m, MonadLayout t m, HasVtyInput t m)
506 => Dynamic t Constraint
529 => Dynamic t Constraint
507 -> m a
530 -> m a
508 -> m a
531 -> m a