@@ -17,13 +17,12 @@ import Control.Monad.NodeId
1717import Data.Functor.Misc
1818import Data.Map (Map)
1919import qualified Data.Map as Map
20−import Data.Maybe
20+import qualified Data.Set as Set
2121import Data.Text (Text)
2222import qualified Data.Text as T
2323import qualified Data.Text.Zipper as TZ
2424import qualified Graphics.Vty as V
2525import Reflex
26−import Reflex.Class.Switchable
2726import Reflex.Network
2827import Reflex.Vty
2928
@@ -75,7 +74,7 @@ main = mainWidget $ do
7574 V.EvKey V.KEsc [] -> Just $ Right ()
7675 _ -> Nothing
7776 rec out <- networkHold buttons $ ffor (switch (current out)) $ \case
78− Left Example_Todo -> escapable blank -- taskList
77+ Left Example_Todo -> escapable taskList
7978 Left Example_TextEditor -> escapable testBoxes
8079 Left Example_ScrollableTextDisplay -> escapable scrolling
8180 Right () -> buttons
@@ -83,74 +82,23 @@ main = mainWidget $ do
8382 return $ fforMaybe inp $ \case
8483 V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
8584 _ -> Nothing
86−
87− {-
85+
86+-- * Task list example
8887taskList
89− :: (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, NotReady t m, PostBuild t m, MonadNodeId m)
90− => VtyWidget t m ()
91−taskList = do
92− let btn = textButtonStatic def "Add another task"
93− inp <- input
88+ :: (VtyExample t m, Manager t m, MonadHold t m, Adjustable t m, PostBuild t m)
89+ => m ()
90+taskList = col $ do
9491 let todos0 =
9592 [ Todo "Find reflex-vty" True
9693 , Todo "Become functional reactive" False
9794 , Todo "Make vty apps" False
9895 ]
99− rec let todos' = todos todos0 $ leftmost
100− [ () <$ e
101− , fforMaybe inp $ \case
102− V.EvKey V.KEnter [] -> Just ()
103− _ -> Nothing
104− ]
105− (m, (e, _)) <- splitV (pure (subtract 6)) (pure (True, True)) todos' $
106− splitV (pure (subtract 3)) (pure (True, True)) btn (display $ Map.size <$> current m)
96+ btn = textButtonStatic def "Add another task"
97+ enter <- fmap (const ()) <$> key V.KEnter
98+ rec void $ grout flex $ todos todos0 $ enter <> click
99+ click <- tile (fixed 3) btn
107100 return ()
108−-}
109−
110−
111−testBoxes
112− :: (MonadHold t m, MonadNodeId m, VtyExample t m)
113− => m ()
114−testBoxes = do
115− dw <- displayWidth
116− dh <- displayHeight
117− let region1 = Region <$> (div' dw 6) <*> (div' dh 6) <*> (div' dw 2) <*> (div' dh 2)
118− region2 = Region <$> (div' dw 4) <*> (div' dh 4) <*> (2 * div' dw 3) <*> (2 * div' dh 3)
119− pane region1 (constDyn False) . boxStatic singleBoxStyle $ debugInput
120− _ <- pane region2 (constDyn True) . boxStatic singleBoxStyle $
121− let cfg = def
122− { _textInputConfig_initialValue =
123− "This box is a text input. The box below responds to mouse drag inputs. You can also drag the separator between the boxes to resize them."
124− }
125− textBox = boxTitle (pure roundedBoxStyle) "Text Edit" $
126− multilineTextInput cfg
127− dragBox = boxStatic roundedBoxStyle dragTest
128− in splitVDrag (hRule doubleBoxStyle) textBox dragBox
129− return ()
130− where
131− div' :: (Integral a, Applicative f) => f a -> f a -> f a
132− div' = liftA2 div
133−
134−debugFocus :: (VtyExample t m) => m ()
135−debugFocus = do
136− f <- focus
137− text $ T.pack . show <$> current f
138101
139−debugInput :: (VtyExample t m, MonadHold t m) => m ()
140−debugInput = do
141− lastEvent <- hold "No event yet" . fmap show =<< input
142− text $ T.pack <$> lastEvent
143−
144−dragTest :: (VtyExample t m, MonadHold t m) => m ()
145−dragTest = do
146− lastEvent <- hold "No event yet" . fmap show =<< drag V.BLeft
147− text $ T.pack <$> lastEvent
148−
149−testStringBox :: VtyExample t m => m ()
150−testStringBox = boxStatic singleBoxStyle .
151− text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z'])
152−
153−{-
154102data Todo = Todo
155103 { _todo_label :: Text
156104 , _todo_done :: Bool
@@ -161,92 +109,132 @@ data TodoOutput t = TodoOutput
161109 { _todoOutput_todo :: Dynamic t Todo
162110 , _todoOutput_delete :: Event t ()
163111 , _todoOutput_height :: Dynamic t Int
112+ , _todoOutput_focusId :: FocusId
164113 }
165114
166−instance Reflex t => Switchable t (TodoOutput t) where
167− switching t0 e = TodoOutput
168− <$> switching (_todoOutput_todo t0) (_todoOutput_todo <$> e)
169− <*> switching (_todoOutput_delete t0) (_todoOutput_delete <$> e)
170− <*> switching (_todoOutput_height t0) (_todoOutput_height <$> e)
171−
172115todo
173− :: (MonadHold t m, MonadFix m, Reflex t, MonadNodeId m)
116+ :: (VtyExample t m, Manager t m, MonadHold t m)
174117 => Todo
175− -> VtyWidget t m (TodoOutput t)
176−todo t0 = do
177− w <- displayWidth
178− rec let checkboxWidth = 3
179− checkboxRegion = DynRegion 0 0 checkboxWidth 1
180− labelHeight = _textInput_lines ti
181− labelWidth = w - 1 - checkboxWidth
182− labelLeft = checkboxWidth + 1
183− labelTop = constDyn 0
184− labelRegion = DynRegion labelLeft labelTop labelWidth labelHeight
185− value <- pane checkboxRegion (pure True) $ checkbox def $ _todo_done t0
186− (ti, d) <- pane labelRegion (pure True) $ do
118+ -> m (TodoOutput t)
119+todo t0 = row $ do
120+ let getToggleEvent = keyCombos $ Set.fromList
121+ [ (V.KChar ' ', [V.MCtrl])
122+ , (V.KChar '@', [V.MCtrl])
123+ ]
124+ rec let cfg = def
125+ { _checkboxConfig_setValue = setVal
126+ }
127+ (toggleCB, value) <- tile (fixed 4) $ do
128+ e <- getToggleEvent
129+ v <- checkbox cfg $ _todo_done t0
130+ pure (e, v)
131+ let setVal = attachWith (\v _ -> not v) (current value) $ leftmost
132+ [ toggleCB
133+ , toggleTI
134+ ]
135+ (fid, (ti, toggleTI, d)) <- tile' flex $ do
187136 i <- input
188− v <- textInput $ def { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }
137+ e <- getToggleEvent
138+ v <- textInput $ def
139+ { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }
189140 let deleteSelf = attachWithMaybe backspaceOnEmpty (current $ _textInput_value v) i
190− return (v, deleteSelf)
141+ return (v, e, deleteSelf)
191142 return $ TodoOutput
192143 { _todoOutput_todo = Todo <$> _textInput_value ti <*> value
193144 , _todoOutput_delete = d
194145 , _todoOutput_height = _textInput_lines ti
146+ , _todoOutput_focusId = fid
195147 }
196148 where
197149 backspaceOnEmpty v = \case
198150 V.EvKey V.KBS _ | T.null v -> Just ()
199151 _ -> Nothing
200−-}
201−
202−scrolling :: (VtyExample t m, MonadHold t m, Manager t m, PostBuild t m) => m ()
203−scrolling = col $ do
204− grout (fixed 2) $ text "Use your mouse wheel or up and down arrows to scroll:"
205− (fid, out) <- tile' (fixed 5) $ boxStatic def $ scrollableText never $ "Gallia est omnis divisa in partes tres, quarum unam incolunt Belgae, aliam Aquitani, tertiam qui ipsorum lingua Celtae, nostra Galli appellantur. Hi omnes lingua, institutis, legibus inter se differunt. Gallos ab Aquitanis Garumna flumen, a Belgis Matrona et Sequana dividit. Horum omnium fortissimi sunt Belgae, propterea quod a cultu atque humanitate provinciae longissime absunt, minimeque ad eos mercatores saepe commeant atque ea quae ad effeminandos animos pertinent important, proximique sunt Germanis, qui trans Rhenum incolunt, quibuscum continenter bellum gerunt. Qua de causa Helvetii quoque reliquos Gallos virtute praecedunt, quod fere cotidianis proeliis cum Germanis contendunt, cum aut suis finibus eos prohibent aut ipsi in eorum finibus bellum gerunt. Eorum una pars, quam Gallos obtinere dictum est, initium capit a flumine Rhodano, continetur Garumna flumine, Oceano, finibus Belgarum, attingit etiam ab Sequanis et Helvetiis flumen Rhenum, vergit ad septentriones. Belgae ab extremis Galliae finibus oriuntur, pertinent ad inferiorem partem fluminis Rheni, spectant in septentrionem et orientem solem. Aquitania a Garumna flumine ad Pyrenaeos montes et eam partem Oceani quae est ad Hispaniam pertinet; spectat inter occasum solis et septentriones.\nApud Helvetios longe nobilissimus fuit et ditissimus Orgetorix. Is M. Messala, [et P.] M. Pisone consulibus regni cupiditate inductus coniurationem nobilitatis fecit et civitati persuasit ut de finibus suis cum omnibus copiis exirent: perfacile esse, cum virtute omnibus praestarent, totius Galliae imperio potiri. Id hoc facilius iis persuasit, quod undique loci natura Helvetii continentur: una ex parte flumine Rheno latissimo atque altissimo, qui agrum Helvetium a Germanis dividit; altera ex parte monte Iura altissimo, qui est inter Sequanos et Helvetios; tertia lacu Lemanno et flumine Rhodano, qui provinciam nostram ab Helvetiis dividit. His rebus fiebat ut et minus late vagarentur et minus facile finitimis bellum inferre possent; qua ex parte homines bellandi cupidi magno dolore adficiebantur. Pro multitudine autem hominum et pro gloria belli atque fortitudinis angustos se fines habere arbitrabantur, qui in longitudinem milia passuum CCXL, in latitudinem CLXXX patebant."
206− pb <- getPostBuild
207− requestFocus $ Refocus_Id fid <$ pb
208− grout (fixed 1) $ text $ ffor out $ \(ix, total) -> "Scrolled to line " <> T.pack (show ix) <> " of " <> T.pack (show total)
209152
210−{-
211153todos
212154 :: forall t m.
213155 ( MonadHold t m
214− , MonadFix m
215− , Reflex t
156+ , Manager t m
157+ , VtyExample t m
216158 , Adjustable t m
217− , NotReady t m
218159 , PostBuild t m
219− , MonadNodeId m
220160 )
221161 => [Todo]
222162 -> Event t ()
223− -> VtyWidget t m (Dynamic t (Map Int (TodoOutput t)))
163+ -> m (Dynamic t (Map Int (TodoOutput t)))
224164todos todos0 newTodo = do
225165 let todosMap0 = Map.fromList $ zip [0..] todos0
226− rec tabNav <- tabNavigation
227− let insertNav = 1 <$ insert
228− nav = leftmost [tabNav, insertNav]
229− tileCfg = def { _tileConfig_constraint = pure $ Constraint_Fixed 1}
230− listOut <- runLayout (pure Orientation_Column) 0 nav $
231− listHoldWithKey todosMap0 updates $ \k t -> tile tileCfg $ do
232− let sel = select selectOnDelete $ Const2 k
233− click <- void <$> mouseDown V.BLeft
234− pb <- getPostBuild
235− let focusMe = leftmost [ click, sel, pb ]
236− r <- todo t
237− return (focusMe, r)
238− let delete = ffor todoDelete $ \k -> Map.singleton k Nothing
166+ rec listOut <- listHoldWithKey todosMap0 updates $ \k t -> grout (fixed 1) $ do
167+ to <- todo t
168+ let sel = select selectOnDelete $ Const2 k
169+ pb <- getPostBuild
170+ requestFocus $ Refocus_Id (_todoOutput_focusId to) <$ leftmost [pb, sel]
171+ pure to
172+ let delete = flip Map.singleton Nothing <$> todoDelete
173+ todosMap = joinDynThroughMap $ fmap _todoOutput_todo <$> listOut
174+ insert = ffor (tag (current todosMap) newTodo) $ \m -> case Map.lookupMax m of
175+ Nothing -> Map.singleton 0 $ Just $ Todo "" False
176+ Just (k, _) -> Map.singleton (k+1) $ Just $ Todo "" False
239177 updates = leftmost [insert, delete]
240178 todoDelete = switch . current $
241179 leftmost . Map.elems . Map.mapWithKey (\k -> (k <$) . _todoOutput_delete) <$> listOut
242− todosMap = joinDynThroughMap $ fmap _todoOutput_todo <$> listOut
243− insert = ffor (tag (current todosMap) newTodo) $ \m -> case Map.lookupMax m of
244− Nothing -> Map.singleton 0 $ Just $ Todo "" False
245− Just (k, _) -> Map.singleton (k+1) $ Just $ Todo "" False
180+
246181 selectOnDelete = fanMap $ (`Map.singleton` ()) <$> attachWithMaybe
247182 (\m k -> let (before, after) = Map.split k m
248183 in fmap fst $ Map.lookupMax before <|> Map.lookupMin after)
249184 (current todosMap)
250185 todoDelete
251186 return listOut
252−-}
187+
188+-- * Scrollable text example
189+
190+scrolling :: (VtyExample t m, MonadHold t m, Manager t m, PostBuild t m) => m ()
191+scrolling = col $ do
192+ grout (fixed 2) $ text "Use your mouse wheel or up and down arrows to scroll:"
193+ (fid, out) <- tile' (fixed 5) $ boxStatic def $ scrollableText never $ "Gallia est omnis divisa in partes tres, quarum unam incolunt Belgae, aliam Aquitani, tertiam qui ipsorum lingua Celtae, nostra Galli appellantur. Hi omnes lingua, institutis, legibus inter se differunt. Gallos ab Aquitanis Garumna flumen, a Belgis Matrona et Sequana dividit. Horum omnium fortissimi sunt Belgae, propterea quod a cultu atque humanitate provinciae longissime absunt, minimeque ad eos mercatores saepe commeant atque ea quae ad effeminandos animos pertinent important, proximique sunt Germanis, qui trans Rhenum incolunt, quibuscum continenter bellum gerunt. Qua de causa Helvetii quoque reliquos Gallos virtute praecedunt, quod fere cotidianis proeliis cum Germanis contendunt, cum aut suis finibus eos prohibent aut ipsi in eorum finibus bellum gerunt. Eorum una pars, quam Gallos obtinere dictum est, initium capit a flumine Rhodano, continetur Garumna flumine, Oceano, finibus Belgarum, attingit etiam ab Sequanis et Helvetiis flumen Rhenum, vergit ad septentriones. Belgae ab extremis Galliae finibus oriuntur, pertinent ad inferiorem partem fluminis Rheni, spectant in septentrionem et orientem solem. Aquitania a Garumna flumine ad Pyrenaeos montes et eam partem Oceani quae est ad Hispaniam pertinet; spectat inter occasum solis et septentriones.\nApud Helvetios longe nobilissimus fuit et ditissimus Orgetorix. Is M. Messala, [et P.] M. Pisone consulibus regni cupiditate inductus coniurationem nobilitatis fecit et civitati persuasit ut de finibus suis cum omnibus copiis exirent: perfacile esse, cum virtute omnibus praestarent, totius Galliae imperio potiri. Id hoc facilius iis persuasit, quod undique loci natura Helvetii continentur: una ex parte flumine Rheno latissimo atque altissimo, qui agrum Helvetium a Germanis dividit; altera ex parte monte Iura altissimo, qui est inter Sequanos et Helvetios; tertia lacu Lemanno et flumine Rhodano, qui provinciam nostram ab Helvetiis dividit. His rebus fiebat ut et minus late vagarentur et minus facile finitimis bellum inferre possent; qua ex parte homines bellandi cupidi magno dolore adficiebantur. Pro multitudine autem hominum et pro gloria belli atque fortitudinis angustos se fines habere arbitrabantur, qui in longitudinem milia passuum CCXL, in latitudinem CLXXX patebant."
194+ pb <- getPostBuild
195+ requestFocus $ Refocus_Id fid <$ pb
196+ grout (fixed 1) $ text $ ffor out $ \(ix, total) -> "Scrolled to line " <> T.pack (show ix) <> " of " <> T.pack (show total)
197+
198+-- * Text editor example with resizable boxes
199+
200+testBoxes
201+ :: (MonadHold t m, MonadNodeId m, VtyExample t m)
202+ => m ()
203+testBoxes = do
204+ dw <- displayWidth
205+ dh <- displayHeight
206+ let region1 = Region <$> (div' dw 6) <*> (div' dh 6) <*> (div' dw 2) <*> (div' dh 2)
207+ region2 = Region <$> (div' dw 4) <*> (div' dh 4) <*> (2 * div' dw 3) <*> (2 * div' dh 3)
208+ pane region1 (constDyn False) . boxStatic singleBoxStyle $ debugInput
209+ _ <- pane region2 (constDyn True) . boxStatic singleBoxStyle $
210+ let cfg = def
211+ { _textInputConfig_initialValue =
212+ "This box is a text input. The box below responds to mouse drag inputs. You can also drag the separator between the boxes to resize them."
213+ }
214+ textBox = boxTitle (pure roundedBoxStyle) "Text Edit" $
215+ multilineTextInput cfg
216+ dragBox = boxStatic roundedBoxStyle dragTest
217+ in splitVDrag (hRule doubleBoxStyle) textBox dragBox
218+ return ()
219+ where
220+ div' :: (Integral a, Applicative f) => f a -> f a -> f a
221+ div' = liftA2 div
222+
223+debugFocus :: (VtyExample t m) => m ()
224+debugFocus = do
225+ f <- focus
226+ text $ T.pack . show <$> current f
227+
228+debugInput :: (VtyExample t m, MonadHold t m) => m ()
229+debugInput = do
230+ lastEvent <- hold "No event yet" . fmap show =<< input
231+ text $ T.pack <$> lastEvent
232+
233+dragTest :: (VtyExample t m, MonadHold t m) => m ()
234+dragTest = do
235+ lastEvent <- hold "No event yet" . fmap show =<< drag V.BLeft
236+ text $ T.pack <$> lastEvent
237+
238+testStringBox :: VtyExample t m => m ()
239+testStringBox = boxStatic singleBoxStyle .
240+ text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z'])