0b0828a · reflex-vty · git.iko.soy

git.iko.soy/reflex-vty

Add localInput, anyChildFocused, and filterKeys for input filtering

commit0b0828a5222f9747ed05e2c250f8c3f552d2fcd3 authorAli Abrar <aliabrar@gmail.com> dateTue 23 Mar 2021, 00:51 (6 years ago) parentfe6a26e

3 files changed+91−63

compare with develop

unifiedsplit

src-bin/example.hs+21−25 src/Reflex/Vty/Widget.hs+35−26 src/Reflex/Vty/Widget/Layout.hs+35−12

src-bin/example.hs+21−25

@@ -159,34 +159,30 @@ todo

159159 => Todo

160160 -> m (TodoOutput t)

161161todo t0 = row $ do

162− let getToggleEvent = keyCombos $ Set.fromList

162+ let toggleKeys = Set.fromList

163163 [ (V.KChar ' ', [V.MCtrl])

164164 , (V.KChar '@', [V.MCtrl])

165165 ]

166− rec let cfg = def

167− { _checkboxConfig_setValue = setVal

168− }

169− (toggleCB, value) <- tile (fixed 4) $ do

170− e <- getToggleEvent

171− v <- checkbox cfg $ _todo_done t0

172− pure (e, v)

173− let setVal = attachWith (\v _ -> not v) (current value) $ leftmost

174− [ toggleCB

175− , toggleTI

176− ]

177− (fid, (ti, toggleTI, d)) <- tile' flex $ do

178− i <- input

179− e <- getToggleEvent

180− v <- textInput $ def

181− { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }

182− let deleteSelf = attachWithMaybe backspaceOnEmpty (current $ _textInput_value v) i

183− return (v, e, deleteSelf)

184− return $ TodoOutput

185− { _todoOutput_todo = Todo <$> _textInput_value ti <*> value

186− , _todoOutput_delete = d

187− , _todoOutput_height = _textInput_lines ti

188− , _todoOutput_focusId = fid

189− }

166+ anyChildFocused $ \focused -> do

167+ toggleE <- keyCombos toggleKeys

168+ filterKeys (flip Set.notMember $ Set.insert (V.KChar '\t', []) toggleKeys) $ do

169+ rec let cfg = def

170+ { _checkboxConfig_setValue = setVal

171+ }

172+ value <- tile (fixed 4) $ checkbox cfg $ _todo_done t0

173+ let setVal = attachWith (\v _ -> not v) (current value) $ gate (current focused) toggleE

174+ (fid, (ti, d)) <- tile' flex $ do

175+ i <- input

176+ v <- textInput $ def

177+ { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }

178+ let deleteSelf = attachWithMaybe backspaceOnEmpty (current $ _textInput_value v) i

179+ return (v, deleteSelf)

180+ return $ TodoOutput

181+ { _todoOutput_todo = Todo <$> _textInput_value ti <*> value

182+ , _todoOutput_delete = d

183+ , _todoOutput_height = _textInput_lines ti

184+ , _todoOutput_focusId = fid

185+ }

190186 where

191187 backspaceOnEmpty v = \case

192188 V.EvKey V.KBS _ | T.null v -> Just ()

src/Reflex/Vty/Widget.hs+35−26

@@ -47,6 +47,7 @@ module Reflex.Vty.Widget

4747 , doubleBoxStyle

4848 , fill

4949 , hRule

50+ , filterKeys

5051 , KeyCombo

5152 , key

5253 , keys

@@ -82,12 +83,6 @@ data VtyWidgetCtx t = VtyWidgetCtx

8283 -- ^ The height of the region allocated to the widget.

8384 , _vtyWidgetCtx_focus :: Dynamic t Bool

8485 -- ^ 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.

9186 }

9287

9388-- | The output of a 'VtyWidget'

@@ -106,7 +101,9 @@ instance (Adjustable t m, MonadHold t m, Reflex t) => Adjustable t (VtyWidget t

106101

107102-- | A widget that can read its context and produce image output

108103newtype 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

110107 } deriving

111108 ( Functor

112109 , Applicative

@@ -124,7 +121,7 @@ newtype VtyWidget t m a = VtyWidget

124121

125122deriving instance PerformEvent t m => PerformEvent t (VtyWidget t m)

126123instance MonadTrans (VtyWidget t) where

127− lift f = VtyWidget $ lift $ lift f

124+ lift f = VtyWidget $ lift $ lift $ lift f

128125

129126instance MonadNodeId m => MonadNodeId (VtyWidget t m) where

130127 getNextNodeId = VtyWidget $ do

@@ -147,10 +144,11 @@ instance (Monad m, Reflex t) => HasVtyWidgetCtx t (VtyWidget t m) where

147144-- | Runs a 'VtyWidget' with a given context

148145runVtyWidget

149146 :: (Reflex t, MonadNodeId m)

150− => VtyWidgetCtx t

147+ => Event t VtyEvent

148+ -> VtyWidgetCtx t

151149 -> VtyWidget t m a

152150 -> 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

154152

155153-- | Sets up the top-level context for a 'VtyWidget' and runs it with that context

156154mainWidgetWithHandle

@@ -168,10 +166,9 @@ mainWidgetWithHandle vty child =

168166 let ctx = VtyWidgetCtx

169167 { _vtyWidgetCtx_width = fmap fst size

170168 , _vtyWidgetCtx_height = fmap snd size

171− , _vtyWidgetCtx_input = inp'

172169 , _vtyWidgetCtx_focus = constDyn True

173170 }

174− (shutdown, images) <- runNodeIdT $ runVtyWidget ctx $ do

171+ (shutdown, images) <- runNodeIdT $ runVtyWidget inp' ctx $ do

175172 tellImages . ffor (current size) $ \(w, h) -> [V.charFill V.defAttr ' ' w h]

176173 child

177174 return $ VtyResult

@@ -206,7 +203,6 @@ instance HasDisplaySize t m => HasDisplaySize t (ReaderT x m)

206203instance HasDisplaySize t m => HasDisplaySize t (BehaviorWriterT t x m)

207204instance HasDisplaySize t m => HasDisplaySize t (DynamicWriterT t x m)

208205instance HasDisplaySize t m => HasDisplaySize t (EventWriterT t x m)

209−

210206instance HasDisplaySize t m => HasDisplaySize t (NodeIdT m)

211207

212208-- | A class for things that can receive vty events as input

@@ -214,9 +210,23 @@ class HasVtyInput t m | m -> t where

214210 input :: m (Event t VtyEvent)

215211 default input :: (f m' ~ m, Monad m', MonadTrans f, HasVtyInput t m') => m (Event t VtyEvent)

216212 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

217222

218223instance (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

220230

221231-- | A class for things that can dynamically gain and lose focus

222232class HasFocus t m | m -> t where

@@ -273,7 +283,7 @@ withinImage (Region left top width height)

273283-- * mouse inputs inside the region have their coordinates translated such

274284-- that (0,0) is the top-left corner of the region

275285pane

276− :: (Reflex t, Monad m, MonadNodeId m, HasVtyWidgetCtx t m)

286+ :: (Reflex t, Monad m, MonadNodeId m, HasVtyWidgetCtx t m, HasVtyInput t m)

277287 => Dynamic t Region

278288 -> Dynamic t Bool -- ^ Whether the widget should be focused when the parent is.

279289 -> m a

@@ -281,16 +291,15 @@ pane

281291pane dr foc child = do

282292 let reg = current dr

283293 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

289295 , _vtyWidgetCtx_width = _region_width <$> dr

290296 , _vtyWidgetCtx_height = _region_height <$> dr

291297 }

298+ inputFilter = fmapMaybe id .

299+ attachWith (\(r,f) e -> filterInput r f e)

300+ (liftA2 (,) reg (current foc))

292301 let imagesWithinRegion images = liftA2 (\is r -> map (withinImage r) is) images reg

293− localCtx subContext imagesWithinRegion child

302+ localInput inputFilter $ localCtx subContext imagesWithinRegion child

294303 where

295304 filterInput :: Region -> Bool -> VtyEvent -> Maybe VtyEvent

296305 filterInput (Region l t w h) focused e = case e of

@@ -435,7 +444,7 @@ keyCombos ks = do

435444

436445-- | A plain split of the available space into vertically stacked panes.

437446-- 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)

439448 => Dynamic t (Int -> Int)

440449 -- ^ Function used to determine size of first pane based on available size

441450 -> Dynamic t (Bool, Bool)

@@ -456,7 +465,7 @@ splitV sizeFunD focD wA wB = do

456465

457466-- | A plain split of the available space into horizontally stacked panes.

458467-- 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)

460469 => Dynamic t (Int -> Int)

461470 -- ^ Function used to determine size of first pane based on available size

462471 -> Dynamic t (Bool, Bool)

@@ -563,7 +572,7 @@ roundedBoxStyle :: BoxStyle

563572roundedBoxStyle = BoxStyle '╭' '─' '╮' '│' '╯' '─' '╰' '│'

564573

565574-- | 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)

567576 => Behavior t BoxStyle

568577 -> Text

569578 -> m a

@@ -615,7 +624,7 @@ boxTitle boxStyle title child = do

615624 right = mkHalf delta

616625

617626-- | 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)

619628 => Behavior t BoxStyle

620629 -> m a

621630 -> m a

@@ -623,7 +632,7 @@ box boxStyle = boxTitle boxStyle mempty

623632

624633-- | A box whose style is static

625634boxStatic

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)

627636 => BoxStyle

628637 -> m a

629638 -> 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)

119119 traverseDMapWithKeyWithAdjust f m e = Focus $ traverseDMapWithKeyWithAdjust (\k v -> unFocus $ f k v) m e

120120 traverseDMapWithKeyWithAdjustWithMove f m e = Focus $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unFocus $ f k v) m e

121121

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

123130

124131instance (HasVtyWidgetCtx t m, Reflex t, MonadFix m) => HasVtyWidgetCtx t (Focus t m) where

125132 localCtx f g (Focus w) = Focus $ do

@@ -330,8 +337,6 @@ chunk o r (offset, sz) = case o of

330337 , _region_width = sz

331338 }

332339

333−

334−

335340-- ** The layout monad

336341

337342-- | A class of operations for creating screen layouts.

@@ -387,7 +392,15 @@ instance (HasVtyWidgetCtx t m, HasDisplaySize t m, Reflex t, MonadFix m) => HasV

387392 let reg = Region 0 0 <$> dw <*> dh

388393 runLayout orientation reg x

389394

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

391404

392405instance ImageWriter t m => ImageWriter t (Layout t m)

393406

@@ -417,6 +430,20 @@ instance (MonadFix m, MonadFocus t m) => MonadFocus t (Layout t m) where

417430 tellDyn w

418431 pure (a, sf)

419432

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+

420447-- | Runs a 'Layout' action, using the given orientation and region to

421448-- calculate layout solutions.

422449runLayout

@@ -475,15 +502,11 @@ tile'

475502tile' c w = do

476503 fid <- makeFocus

477504 r <- region c

478− fid' <- focusedId

479505 parentFocused <- isFocused fid

480− rec (click, result, subs) <- pane r focused $ do

506+ rec (click, result, childFocused) <- pane r focused $ anyChildFocused $ \childFoc -> do

481507 m <- mouseDown V.BLeft

482− (x, sf) <- subFoci w

483− pure (m, x, sf)

484− let childFocused = liftA2 (\f s -> case f of

485− Nothing -> False

486− Just f' -> OSet.member f' $ unFocusSet s) fid' subs

508+ x <- w

509+ pure (m, x, childFoc)

487510 let focused = (||) <$> parentFocused <*> childFocused

488511 requestFocus $ Refocus_Id fid <$ click

489512 pure (fid, result)

@@ -502,7 +525,7 @@ tile c = fmap snd . tile' c

502525-- | A widget that is not focusable and occupies a layout region based on the

503526-- provided constraint.

504527grout

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)

506529 => Dynamic t Constraint

507530 -> m a

508531 -> m a