7faa08b · reflex-vty · git.iko.soy

git.iko.soy/reflex-vty

Add Control.Monad.NodeId and fix bugs in focus handling

commit7faa08b6951c75c0e253efcc3c0bf6ab70fac824 authorAli Abrar <aliabrar@gmail.com> dateSat 3 Aug 2019, 20:00 (7 years ago) parent88af14f

9 files changed+170−117

compare with develop

unifiedsplit

reflex-vty.cabal+2−2 src-bin/example.hs+31−44 src/Control/Monad/NodeId.hs+66 src/Data/Text/Zipper.hs+1−1 src/Reflex/Vty.hs+3 src/Reflex/Vty/Widget.hs+61−45 src/Reflex/Vty/Widget/Input.hs+4−3 src/Reflex/Vty/Widget/Input/Text.hs+2−1 src/Unsafe/NodeId.hs−21

reflex-vty.cabal+2−2

@@ -24,7 +24,7 @@ library

2424 , Data.Text.Zipper

2525 , Reflex.Class.Switchable

2626 , Reflex.Spider.Orphans

27− other-modules: Unsafe.NodeId

27+ , Control.Monad.NodeId

2828 build-depends:

2929 base,

3030 bimap,

@@ -36,7 +36,7 @@ library

3636 mtl,

3737 primitive,

3838 ref-tf,

39− reflex,

39+ reflex >= 0.6.1,

4040 stm,

4141 text,

4242 time,

src-bin/example.hs+31−44

@@ -13,7 +13,8 @@

1313import Control.Applicative

1414import Control.Monad

1515import Control.Monad.Fix

16−import Data.Either

16+import Control.Monad.NodeId

17+import Data.Functor.Misc

1718import Data.Map (Map)

1819import Data.Maybe

1920import qualified Data.Map as Map

@@ -24,12 +25,10 @@ import qualified Graphics.Vty as V

2425import Reflex

2526import Reflex.Network

2627import Reflex.Class.Switchable

27−import Reflex.NotReady.Class

2828import Reflex.Vty

2929

3030data Example = Example_TextEditor

3131 | Example_Todo

32− | Example_Stack

3332 deriving (Show, Read, Eq, Ord, Enum, Bounded)

3433

3534div' :: (Integral a, Applicative f) => f a -> f a -> f a

@@ -38,10 +37,6 @@ div' = liftA2 div

3837main :: IO ()

3938main = mainWidget $ do

4039 inp <- input

41−

42− w <- displayWidth

43− h <- displayHeight

44−

4540 let buttons = col $ do

4641 fixed 4 $ col $ do

4742 fixed 1 $ text "Select an example."

@@ -68,7 +63,7 @@ main = mainWidget $ do

6863 _ -> Nothing

6964

7065taskList

71− :: (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, NotReady t m, PostBuild t m)

66+ :: (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, NotReady t m, PostBuild t m, MonadNodeId m)

7267 => VtyWidget t m ()

7368taskList = do

7469 let btn = textButtonStatic def "Add another task"

@@ -80,10 +75,12 @@ taskList = do

8075 _ -> Nothing

8176 ]

8277 (m, (e, _)) <- splitV (pure (subtract 6)) (pure (True, True)) todos' $ do

83− splitV (pure (subtract 3)) (pure (True, True)) btn (display $ current m)

78+ splitV (pure (subtract 3)) (pure (True, True)) btn (display $ Map.size <$> current m)

8479 return ()

8580

86−testBoxes :: (Reflex t, MonadHold t m, MonadFix m) => VtyWidget t m ()

81+testBoxes

82+ :: (Reflex t, MonadHold t m, MonadFix m, MonadNodeId m)

83+ => VtyWidget t m ()

8784testBoxes = do

8885 dw <- displayWidth

8986 dh <- displayHeight

@@ -109,7 +106,7 @@ dragTest = do

109106 lastEvent <- hold "No event yet" . fmap show =<< drag V.BLeft

110107 text $ T.pack <$> lastEvent

111108

112−testStringBox :: (Reflex t, Monad m) => VtyWidget t m ()

109+testStringBox :: (Reflex t, Monad m, MonadNodeId m) => VtyWidget t m ()

113110testStringBox = boxStatic singleBoxStyle .

114111 text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z'])

115112

@@ -132,7 +129,7 @@ instance Reflex t => Switchable t (TodoOutput t) where

132129 <*> switching (_todoOutput_height t0) (_todoOutput_height <$> e)

133130

134131todo

135− :: (MonadHold t m, MonadFix m, Reflex t)

132+ :: (MonadHold t m, MonadFix m, Reflex t, MonadNodeId m)

136133 => Todo

137134 -> VtyWidget t m (TodoOutput t)

138135todo t0 = do

@@ -161,44 +158,34 @@ todo t0 = do

161158 _ -> Nothing

162159

163160todos

164− :: forall t m. (MonadHold t m, MonadFix m, Reflex t, Adjustable t m, NotReady t m, PostBuild t m)

161+ :: forall t m. (MonadHold t m, MonadFix m, Reflex t, Adjustable t m, NotReady t m, PostBuild t m, MonadNodeId m)

165162 => [Todo]

166163 -> Event t ()

167− -> VtyWidget t m (Dynamic t (Map Int Todo))

164+ -> VtyWidget t m (Dynamic t (Map Int (TodoOutput t)))

168165todos todos0 newTodo = do

169166 let todosMap0 = Map.fromList $ zip [0..] todos0

170− w <- displayWidth

171− rec listOut <- listHoldWithKey todosMap0 updates $ \row t -> do

172− let reg = zipDynWith (\w' ts ->

173− let l = Map.size $ Map.takeWhileAntitone (<row) ts

174− in Region 0 l w' 1) w todosMap

175− pane (DynRegion 0 (fromMaybe 0 . Map.lookup row <$> offsets) w (fromMaybe 1 . Map.lookup row <$> heights))

176− (fmap (==row) selected) $ do

177− e <- mouseUp

178− r <- todo t

179− return (row <$ e, r)

180− let heights :: Dynamic t (Map Int Int) = joinDynThroughMap $ fmap (fmap (_todoOutput_height . snd)) listOut

181− offsets :: Dynamic t (Map Int Int) = ffor heights $ \m ->

182− let l = Map.toList m

183− o = scanl (+) 0 $ map snd l

184− in Map.fromList $ zipWith (\(k, _) o' -> (k, o')) l o

185− let selectionClick = switch . current $ fmap (leftmost . Map.elems . fmap fst) listOut

186− selected <- holdDyn 0 $ leftmost

187− [ selectionClick

188− , fmapMaybe (fmap fst . Map.lookupMax) insert

189− , selectOnDelete

190− ]

191− let todosMap = joinDynThroughMap $ fmap (fmap (_todoOutput_todo . snd)) listOut

167+ rec tabNav <- tabNavigation

168+ let insertNav = 1 <$ insert

169+ nav = leftmost [tabNav, insertNav]

170+ listOut <- runLayout (pure Orientation_Column) 0 nav $

171+ listHoldWithKey todosMap0 updates $ \k t -> tile (pure $ Constraint_Fixed 1) (pure True) $ do

172+ let sel = select selectOnDelete $ Const2 k

173+ click <- fmap (const ()) <$> mouseDown V.BLeft

174+ pb <- getPostBuild

175+ let focusMe = leftmost [ click, sel, pb ]

176+ r <- todo t

177+ return (focusMe, r)

178+ let delete = ffor todoDelete $ \k -> Map.singleton k Nothing

179+ updates = leftmost [insert, delete]

192180 todoDelete = switch . current $

193− leftmost . Map.elems . Map.mapWithKey (\k -> (k <$) . _todoOutput_delete . snd) <$> listOut

194− selectOnDelete = attachWithMaybe

181+ leftmost . Map.elems . Map.mapWithKey (\k -> (k <$) . _todoOutput_delete) <$> listOut

182+ todosMap = joinDynThroughMap $ fmap (_todoOutput_todo) <$> listOut

183+ insert = ffor (tag (current todosMap) newTodo) $ \m -> case Map.lookupMax m of

184+ Nothing -> Map.singleton 0 $ Just $ Todo "" False

185+ Just (k, _) -> Map.singleton (k+1) $ Just $ Todo "" False

186+ selectOnDelete = fanMap $ fmap (flip Map.singleton ()) $ attachWithMaybe

195187 (\m k -> let (before, after) = Map.split k m

196188 in fmap fst $ Map.lookupMax before <|> Map.lookupMin after)

197189 (current todosMap)

198190 todoDelete

199− insert = ffor (tag (current todosMap) newTodo) $ \m -> case Map.lookupMax m of

200− Nothing -> Map.singleton 0 $ Just $ Todo "" False

201− Just (k, _) -> Map.singleton (k+1) $ Just $ Todo "" False

202− delete = ffor todoDelete $ \k -> Map.singleton k Nothing

203− updates = leftmost [insert, delete]

204− return todosMap

191+ return listOut

src/Control/Monad/NodeId.hsnew file+66

@@ -0,0 +1,66 @@

1+{-# LANGUAGE DefaultSignatures #-}

2+{-# LANGUAGE FlexibleInstances #-}

3+{-# LANGUAGE GADTs #-}

4+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

5+{-# LANGUAGE MultiParamTypeClasses #-}

6+{-# LANGUAGE UndecidableInstances #-}

7+module Control.Monad.NodeId where

9+import Control.Monad.Reader

10+import Control.Monad.Ref

11+import Data.IORef

12+

13+import Reflex

14+import Reflex.Host.Class

15+

16+newtype NodeId = NodeId Integer

17+ deriving (Eq, Ord, Show)

18+

19+class Monad m => MonadNodeId m where

20+ getNextNodeId :: m NodeId

21+ default getNextNodeId :: (MonadTrans t, MonadNodeId n, m ~ t n) => m NodeId

22+ getNextNodeId = lift getNextNodeId

23+

24+newtype NodeIdT m a = NodeIdT { unNodeIdT :: ReaderT (IORef NodeId) m a }

25+ deriving

26+ ( Functor

27+ , Applicative

28+ , Monad

29+ , MonadFix

30+ , MonadHold t

31+ , MonadIO

32+ , MonadReflexCreateTrigger t

33+ , MonadSample t

34+ , MonadTrans

35+ , NotReady t

36+ , PerformEvent t

37+ , PostBuild t

38+ , TriggerEvent t

39+ , MonadRef

40+ )

41+

42+instance MonadNodeId m => MonadNodeId (ReaderT x m)

43+instance MonadNodeId m => MonadNodeId (BehaviorWriterT t x m)

44+instance MonadNodeId m => MonadNodeId (DynamicWriterT t x m)

45+instance MonadNodeId m => MonadNodeId (EventWriterT t x m)

46+instance MonadNodeId m => MonadNodeId (TriggerEventT t m)

47+instance MonadNodeId m => MonadNodeId (PostBuildT t m)

48+

49+instance Adjustable t m => Adjustable t (NodeIdT m) where

50+ runWithReplace (NodeIdT a) e = NodeIdT $ runWithReplace a $ fmap unNodeIdT e

51+ traverseIntMapWithKeyWithAdjust f m e = NodeIdT $ traverseIntMapWithKeyWithAdjust (\k v -> unNodeIdT $ f k v) m e

52+ traverseDMapWithKeyWithAdjust f m e = NodeIdT $ traverseDMapWithKeyWithAdjust (\k v -> unNodeIdT $ f k v) m e

53+ traverseDMapWithKeyWithAdjustWithMove f m e = NodeIdT $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unNodeIdT $ f k v) m e

54+

55+runNodeIdT :: MonadIO m => NodeIdT m a -> m a

56+runNodeIdT a = do

57+ ref <- liftIO $ newIORef $ NodeId 0

58+ runReaderT (unNodeIdT a) ref

59+

60+instance MonadIO m => MonadNodeId (NodeIdT m) where

61+ getNextNodeId = NodeIdT $ do

62+ ref <- ask

63+ liftIO $ newNodeId ref

64+

65+newNodeId :: IORef NodeId -> IO NodeId

66+newNodeId ref = atomicModifyIORef' ref $ \(NodeId n) -> (NodeId $ succ n, NodeId n)

src/Data/Text/Zipper.hs+1−1

@@ -150,7 +150,7 @@ deleteLeftWord (TextZipper lb b a la) =

150150-- | Insert up to n spaces to get to the next logical column that is a multiple of n

151151tab :: Int -> TextZipper -> TextZipper

152152tab n z@(TextZipper _ b _ _) =

153− insert (T.replicate (fromEnum $ n - (T.length b `mod` n)) " ") z

153+ insert (T.replicate (fromEnum $ n - (T.length b `mod` (max 1 n))) " ") z

154154

155155-- | The plain text contents of the zipper

156156value :: TextZipper -> Text

src/Reflex/Vty.hs+3

@@ -15,9 +15,12 @@ module Reflex.Vty

1515 , module Reflex.Vty.Host

1616 , module Reflex.Vty.Widget

1717 , module Reflex.Vty.Widget.Input

18+ , module Control.Monad.NodeId

1819 ) where

1920

2021import Reflex

2122import Reflex.Vty.Host

2223import Reflex.Vty.Widget

2324import Reflex.Vty.Widget.Input

25+

26+import Control.Monad.NodeId

src/Reflex/Vty/Widget.hs+61−45

@@ -102,7 +102,7 @@ import Reflex.Class ()

102102

103103import Reflex.Vty.Host

104104

105−import Unsafe.NodeId

105+import Control.Monad.NodeId

106106

107107-- | The context within which a 'VtyWidget' runs

108108data VtyWidgetCtx t = VtyWidgetCtx

@@ -149,15 +149,20 @@ newtype VtyWidget t m a = VtyWidget

149149 , PostBuild t

150150 , TriggerEvent t

151151 , MonadReflexCreateTrigger t

152+ , MonadIO

152153 )

153154

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

155156instance MonadTrans (VtyWidget t) where

156157 lift f = VtyWidget $ lift $ lift f

157158

159+instance MonadNodeId m => MonadNodeId (VtyWidget t m) where

160+ getNextNodeId = VtyWidget $ do

161+ lift $ lift $ getNextNodeId

162+

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

159164runVtyWidget

160− :: (Reflex t, Monad m)

165+ :: (Reflex t, MonadNodeId m)

161166 => VtyWidgetCtx t

162167 -> VtyWidget t m a

163168 -> m (a, Behavior t [Image])

@@ -166,7 +171,7 @@ runVtyWidget ctx w = runReaderT (runBehaviorWriterT (unVtyWidget w)) ctx

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

167172mainWidgetWithHandle

168173 :: V.Vty

169− -> (forall t m. MonadVtyApp t m => VtyWidget t m (Event t ()))

174+ -> (forall t m. (MonadVtyApp t m, MonadNodeId m) => VtyWidget t m (Event t ()))

170175 -> IO ()

171176mainWidgetWithHandle vty child =

172177 runVtyAppWithHandle vty $ \dr0 inp -> do

@@ -182,7 +187,7 @@ mainWidgetWithHandle vty child =

182187 , _vtyWidgetCtx_input = inp'

183188 , _vtyWidgetCtx_focus = constDyn True

184189 }

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

190+ (shutdown, images) <- runNodeIdT $ runVtyWidget ctx $ do

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

187192 child

188193 return $ VtyResult

@@ -192,7 +197,7 @@ mainWidgetWithHandle vty child =

192197

193198-- | Like 'mainWidgetWithHandle', but uses a default vty configuration

194199mainWidget

195− :: (forall t m. MonadVtyApp t m => VtyWidget t m (Event t ()))

200+ :: (forall t m. (MonadVtyApp t m, MonadNodeId m) => VtyWidget t m (Event t ()))

196201 -> IO ()

197202mainWidget child = do

198203 vty <- getDefaultVty

@@ -218,6 +223,8 @@ instance HasDisplaySize t m => HasDisplaySize t (BehaviorWriterT t x m)

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

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

220225

226+instance HasDisplaySize t m => HasDisplaySize t (NodeIdT m)

227+

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

222229class HasVtyInput t m | m -> t where

223230 input :: m (Event t VtyEvent)

@@ -257,14 +264,6 @@ data DynRegion t = DynRegion

257264 , _dynRegion_height :: Dynamic t Int

258265 }

259266

260−switchDynRegion :: Reflex t => Dynamic t (DynRegion t) -> DynRegion t

261−switchDynRegion r = DynRegion

262− { _dynRegion_left = _dynRegion_left =<< r

263− , _dynRegion_top = _dynRegion_top =<< r

264− , _dynRegion_width = _dynRegion_width =<< r

265− , _dynRegion_height = _dynRegion_height =<< r

266− }

267−

268267-- | The width and height of a 'Region'

269268regionSize :: Region -> (Int, Int)

270269regionSize (Region _ _ w h) = (w, h)

@@ -296,7 +295,7 @@ withinImage (Region left top width height)

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

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

298297pane

299− :: (Reflex t, Monad m)

298+ :: (Reflex t, Monad m, MonadNodeId m)

300299 => DynRegion t

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

302301 -> VtyWidget t m a

@@ -440,7 +439,7 @@ keyCombos ks = do

440439

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

442441-- No visual separator is built in here.

443−splitV :: (Reflex t, Monad m)

442+splitV :: (Reflex t, Monad m, MonadNodeId m)

444443 => Dynamic t (Int -> Int)

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

446445 -> Dynamic t (Bool, Bool)

@@ -472,7 +471,7 @@ splitV sizeFunD focD wA wB = do

472471-- | A split of the available space into two parts with a draggable separator.

473472-- Starts with half the space allocated to each, and the first pane has focus.

474473-- Clicking in a pane switches focus.

475−splitVDrag :: (Reflex t, MonadFix m, MonadHold t m)

474+splitVDrag :: (Reflex t, MonadFix m, MonadHold t m, MonadNodeId m)

476475 => VtyWidget t m ()

477476 -> VtyWidget t m a

478477 -> VtyWidget t m b

@@ -486,7 +485,7 @@ splitVDrag wS wA wB = do

486485 rec splitterCheckpoint <- holdDyn splitter0 $ leftmost [fst <$> ffilter snd dragSplitter, resizeSplitter]

487486 splitterPos <- holdDyn splitter0 $ leftmost [fst <$> dragSplitter, resizeSplitter]

488487 splitterFrac <- holdDyn ((1::Double) / 2) $ ffor (attach (current dh) (fst <$> dragSplitter)) $ \(h, x) ->

489− fromIntegral x / fromIntegral h

488+ fromIntegral x / (max 1 (fromIntegral h))

490489 let dragSplitter = fforMaybe (attach (current splitterCheckpoint) dragE) $

491490 \(splitterY, Drag (_, fromY) (_, toY) _ _ end) ->

492491 if splitterY == fromY then Just (toY, end) else Nothing

@@ -559,7 +558,7 @@ roundedBoxStyle :: BoxStyle

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

560559

561560-- | Draws a box in the provided style and a child widget inside of that box

562−box :: (Monad m, Reflex t)

561+box :: (Monad m, Reflex t, MonadNodeId m)

563562 => Behavior t BoxStyle

564563 -> VtyWidget t m a

565564 -> VtyWidget t m a

@@ -600,7 +599,7 @@ box boxStyle child = do

600599

601600-- | A box whose style is static

602601boxStatic

603− :: (Reflex t, Monad m)

602+ :: (Reflex t, Monad m, MonadNodeId m)

604603 => BoxStyle

605604 -> VtyWidget t m a

606605 -> VtyWidget t m a

@@ -663,7 +662,7 @@ computeSizes available constraints =

663662 (_, Constraint_Min n) -> n

664663 leftover = max 0 (available - minTotal)

665664 numStretch = Map.size $ Map.filter (isMin . snd) constraints

666− szStretch = floor $ leftover % numStretch

665+ szStretch = floor $ leftover % (max numStretch 1)

667666 adjustment = max 0 $ available - minTotal - szStretch * numStretch

668667 in snd $ Map.mapAccum (\adj (a, c) -> case c of

669668 Constraint_Fixed n -> (adj, (a, n))

@@ -684,8 +683,13 @@ data Orientation = Orientation_Column

684683 | Orientation_Row

685684 deriving (Show, Read, Eq, Ord)

686685

686+data LayoutSegment = LayoutSegment

687+ { _layoutSegment_offset :: Int

688+ , _layoutSegment_size :: Int

689+ }

690+

687691data LayoutCtx t = LayoutCtx

688− { _layoutCtx_regions :: Dynamic t (Map NodeId (DynRegion t))

692+ { _layoutCtx_regions :: Dynamic t (Map NodeId LayoutSegment)

689693 , _layoutCtx_focusDemux :: Demux t (Maybe NodeId)

690694 , _layoutCtx_orientation :: Dynamic t Orientation

691695 }

@@ -706,6 +710,8 @@ newtype Layout t m a = Layout

706710 , PerformEvent t

707711 , NotReady t

708712 , MonadReflexCreateTrigger t

713+ , HasDisplaySize t

714+ , MonadNodeId

709715 )

710716

711717instance MonadTrans (Layout t) where

@@ -718,7 +724,7 @@ instance (Adjustable t m, MonadFix m, MonadHold t m) => Adjustable t (Layout t m

718724 traverseDMapWithKeyWithAdjustWithMove f m e = Layout $ traverseDMapWithKeyWithAdjustWithMove (\k v -> unLayout $ f k v) m e

719725

720726runLayout

721− :: (MonadFix m, MonadHold t m, PostBuild t m)

727+ :: (MonadFix m, MonadHold t m, PostBuild t m, Monad m, MonadNodeId m)

722728 => Dynamic t Orientation

723729 -> Int

724730 -> Event t Int

@@ -741,19 +747,9 @@ runLayout ddir focus0 focusShift (Layout child) = do

741747 . Map.fromList

742748 . zip [0::Integer ..]

743749 $ qs

744− solutionMap = ffor solution $ \ss -> ffor ss $ \(offset, sz) -> DynRegion

745− { _dynRegion_left = ffor ddir $ \case

746− Orientation_Column -> 0

747− Orientation_Row -> offset

748− , _dynRegion_width = ffor2 dw ddir $ \w -> \case

749− Orientation_Column -> w

750− Orientation_Row -> sz

751− , _dynRegion_top = ffor ddir $ \case

752− Orientation_Column -> offset

753− Orientation_Row -> 0

754− , _dynRegion_height = ffor2 dh ddir $ \h -> \case

755− Orientation_Column -> sz

756− Orientation_Row -> h

750+ solutionMap = ffor solution $ \ss -> ffor ss $ \(offset, sz) -> LayoutSegment

751+ { _layoutSegment_offset = offset

752+ , _layoutSegment_size = sz

757753 }

758754 focusable = fmap (Bimap.fromList . zip [0..]) $

759755 ffor queries $ \qs -> fforMaybe qs $ \(nodeId, (f, _)) ->

@@ -763,7 +759,7 @@ runLayout ddir focus0 focusShift (Layout child) = do

763759 -> Either Int NodeId

764760 -> (Int, Maybe NodeId)

765761 adjustFocus (fm, (cur, _)) (Left shift) =

766− let ix = (cur + shift) `mod` Bimap.size fm

762+ let ix = (cur + shift) `mod` (max 1 $ Bimap.size fm)

767763 in (ix, Bimap.lookup ix fm)

768764 adjustFocus (fm, (cur, _)) (Right goto) =

769765 let ix = fromMaybe cur $ Bimap.lookupR goto fm

@@ -780,19 +776,39 @@ runLayout ddir focus0 focusShift (Layout child) = do

780776 return a

781777

782778tile

783− :: (Reflex t, Monad m)

779+ :: (Reflex t, Monad m, MonadNodeId m)

784780 => Dynamic t Constraint

785781 -> Dynamic t Bool

786782 -> VtyWidget t m (Event t x, a)

787783 -> Layout t m a

788784tile con focusable child = do

789− let nodeId = unsafeNodeId child

785+ nodeId <- getNextNodeId

790786 Layout $ tellDyn $ ffor2 con focusable $ \c f -> Endo ((nodeId, (f, c)):)

791− reg <- fmap switchDynRegion $ Layout $ asks $

792− fmap (Map.findWithDefault (error "tile: Could not find solution for nodeId. This should be impossible.") nodeId) . _layoutCtx_regions

787+ seg <- Layout $ asks $

788+ fmap (Map.findWithDefault (LayoutSegment 0 0) nodeId) . _layoutCtx_regions

789+ dw <- displayWidth

790+ dh <- displayHeight

791+ o <- askOrientation

792+ let cross = join $ ffor o $ \case

793+ Orientation_Column -> dw

794+ Orientation_Row -> dh

795+ let reg = DynRegion

796+ { _dynRegion_top = ffor2 seg o $ \s -> \case

797+ Orientation_Column -> _layoutSegment_offset s

798+ Orientation_Row -> 0

799+ , _dynRegion_left = ffor2 seg o $ \s -> \case

800+ Orientation_Column -> 0

801+ Orientation_Row -> _layoutSegment_offset s

802+ , _dynRegion_width = ffor3 seg cross o $ \s c -> \case

803+ Orientation_Column -> c

804+ Orientation_Row -> _layoutSegment_size s

805+ , _dynRegion_height = ffor3 seg cross o $ \s c -> \case

806+ Orientation_Column -> _layoutSegment_size s

807+ Orientation_Row -> c

808+ }

793809 focussed <- Layout $ asks _layoutCtx_focusDemux

794810 (focusReq, a) <- Layout $ lift $ lift $ lift $

795− pane reg (demuxed focussed $ Just nodeId) child

811+ pane reg (demuxed focussed $ Just nodeId) $ child

796812 Layout $ tellEvent $ First nodeId <$ focusReq

797813 return a

798814

@@ -806,20 +822,20 @@ instance Reflex t => Default (TileConfig t) where

806822 def = TileConfig (pure $ Constraint_Min 0) (pure True) (pure True)

807823

808824fixed

809− :: (Reflex t, Monad m)

825+ :: (Reflex t, Monad m, MonadNodeId m)

810826 => Dynamic t Int

811827 -> VtyWidget t m a

812828 -> Layout t m a

813829fixed sz = tile (Constraint_Fixed <$> sz) (pure True) . clickable

814830

815831stretch

816− :: (Reflex t, Monad m)

832+ :: (Reflex t, Monad m, MonadNodeId m)

817833 => VtyWidget t m a

818834 -> Layout t m a

819835stretch = tile (Constraint_Min <$> 0) (pure True) . clickable

820836

821837col

822− :: (MonadFix m, MonadHold t m, PostBuild t m)

838+ :: (MonadFix m, MonadHold t m, PostBuild t m, MonadNodeId m)

823839 => Layout t m a

824840 -> VtyWidget t m a

825841col child = do

@@ -827,7 +843,7 @@ col child = do

827843 runLayout (pure Orientation_Column) 0 nav child

828844

829845row

830− :: (MonadFix m, MonadHold t m, PostBuild t m)

846+ :: (MonadFix m, MonadHold t m, PostBuild t m, MonadNodeId m)

831847 => Layout t m a

832848 -> VtyWidget t m a

833849row child = do

src/Reflex/Vty/Widget/Input.hs+4−3

@@ -14,6 +14,7 @@ import Reflex.Vty.Widget.Input.Text as Export

1414

1515import Control.Monad (join)

1616import Control.Monad.Fix (MonadFix)

17+import Control.Monad.NodeId (MonadNodeId)

1718import Data.Default (Default(..))

1819import Data.Text (Text)

1920import qualified Graphics.Vty as V

@@ -31,7 +32,7 @@ instance Reflex t => Default (ButtonConfig t) where

3132

3233-- | A button widget that contains a sub-widget

3334button

34− :: (Reflex t, Monad m)

35+ :: (Reflex t, Monad m, MonadNodeId m)

3536 => ButtonConfig t

3637 -> VtyWidget t m ()

3738 -> VtyWidget t m (Event t ())

@@ -49,7 +50,7 @@ button cfg child = do

4950

5051-- | A button widget that displays text that can change

5152textButton

52− :: (Reflex t, Monad m)

53+ :: (Reflex t, Monad m, MonadNodeId m)

5354 => ButtonConfig t

5455 -> Behavior t Text

5556 -> VtyWidget t m (Event t ())

@@ -57,7 +58,7 @@ textButton cfg = button cfg . text -- TODO Centering etc.

5758

5859-- | A button widget that displays a static bit of text

5960textButtonStatic

60− :: (Reflex t, Monad m)

61+ :: (Reflex t, Monad m, MonadNodeId m)

6162 => ButtonConfig t

6263 -> Text

6364 -> VtyWidget t m (Event t ())

src/Reflex/Vty/Widget/Input/Text.hs+2−1

@@ -14,6 +14,7 @@ module Reflex.Vty.Widget.Input.Text

1414

1515import Control.Monad (join)

1616import Control.Monad.Fix (MonadFix)

17+import Control.Monad.NodeId (MonadNodeId)

1718import Data.Default (Default(..))

1819import Data.Text (Text)

1920import Data.Text.Zipper

@@ -96,7 +97,7 @@ multilineTextInput cfg = do

9697-- the computed line count to greedily size the tile when vertically

9798-- oriented, and uses the fallback width when horizontally oriented.

9899textInputTile

99− :: (Reflex t, MonadHold t m, MonadFix m)

100+ :: (Reflex t, MonadHold t m, MonadFix m, MonadNodeId m)

100101 => VtyWidget t m (TextInput t)

101102 -> Dynamic t Int

102103 -> Layout t m (TextInput t)

src/Unsafe/NodeId.hsdeleted−21

@@ -1,21 +0,0 @@

1−module Unsafe.NodeId where

2−

3−import Control.Monad.Primitive

4−import Data.IORef

5−import System.IO.Unsafe

6−

7−newtype NodeId = NodeId Integer

8− deriving (Eq, Ord, Show)

9−

10−{-# NOINLINE nextNodeIdRef #-}

11−nextNodeIdRef :: IORef NodeId

12−nextNodeIdRef = unsafePerformIO $ newIORef $ NodeId 1

13−

14−newNodeId :: IO NodeId

15−newNodeId = atomicModifyIORef' nextNodeIdRef $ \(NodeId n) -> (NodeId $ succ n, NodeId n)

16−

17−{-# NOINLINE unsafeNodeId #-}

18−unsafeNodeId :: a -> NodeId

19−unsafeNodeId a = unsafePerformIO $ do

20− touch a

21− newNodeId