git.iko.soy/reflex-vty
on develop help sign in
examples: Update task list example
b41724cAli Abrar
src-bin/example.hs+105−117
compare with develop
unifiedsplit
@@ -17,13 +17,12 @@ import Control.Monad.NodeId
17import Data.Functor.Misc
17import Data.Functor.Misc
18import Data.Map (Map)
18import Data.Map (Map)
19import qualified Data.Map as Map
19import qualified Data.Map as Map
20−import Data.Maybe
20+import qualified Data.Set as Set
21import Data.Text (Text)
21import Data.Text (Text)
22import qualified Data.Text as T
22import qualified Data.Text as T
23import qualified Data.Text.Zipper as TZ
23import qualified Data.Text.Zipper as TZ
24import qualified Graphics.Vty as V
24import qualified Graphics.Vty as V
25import Reflex
25import Reflex
26−import Reflex.Class.Switchable
27import Reflex.Network
26import Reflex.Network
28import Reflex.Vty
27import Reflex.Vty
29
28
@@ -75,7 +74,7 @@ main = mainWidget $ do
75 V.EvKey V.KEsc [] -> Just $ Right ()
74 V.EvKey V.KEsc [] -> Just $ Right ()
76 _ -> Nothing
75 _ -> Nothing
77 rec out <- networkHold buttons $ ffor (switch (current out)) $ \case
76 rec out <- networkHold buttons $ ffor (switch (current out)) $ \case
78− Left Example_Todo -> escapable blank -- taskList
77+ Left Example_Todo -> escapable taskList
79 Left Example_TextEditor -> escapable testBoxes
78 Left Example_TextEditor -> escapable testBoxes
80 Left Example_ScrollableTextDisplay -> escapable scrolling
79 Left Example_ScrollableTextDisplay -> escapable scrolling
81 Right () -> buttons
80 Right () -> buttons
@@ -83,74 +82,23 @@ main = mainWidget $ do
83 return $ fforMaybe inp $ \case
82 return $ fforMaybe inp $ \case
84 V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
83 V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
85 _ -> Nothing
84 _ -> Nothing
86−
85+
87− {-
86+-- * Task list example
88taskList
87taskList
89− :: (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, NotReady t m, PostBuild t m, MonadNodeId m)
88+ :: (VtyExample t m, Manager t m, MonadHold t m, Adjustable t m, PostBuild t m)
90− => VtyWidget t m ()
89+ => m ()
91−taskList = do
90+taskList = col $ do
92− let btn = textButtonStatic def "Add another task"
93− inp <- input
94 let todos0 =
91 let todos0 =
95 [ Todo "Find reflex-vty" True
92 [ Todo "Find reflex-vty" True
96 , Todo "Become functional reactive" False
93 , Todo "Become functional reactive" False
97 , Todo "Make vty apps" False
94 , Todo "Make vty apps" False
98 ]
95 ]
99− rec let todos' = todos todos0 $ leftmost
96+ btn = textButtonStatic def "Add another task"
100− [ () <$ e
97+ enter <- fmap (const ()) <$> key V.KEnter
101− , fforMaybe inp $ \case
98+ rec void $ grout flex $ todos todos0 $ enter <> click
102− V.EvKey V.KEnter [] -> Just ()
99+ click <- tile (fixed 3) btn
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)
107 return ()
100 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
138
101
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−{-
154data Todo = Todo
102data Todo = Todo
155 { _todo_label :: Text
103 { _todo_label :: Text
156 , _todo_done :: Bool
104 , _todo_done :: Bool
@@ -161,92 +109,132 @@ data TodoOutput t = TodoOutput
161 { _todoOutput_todo :: Dynamic t Todo
109 { _todoOutput_todo :: Dynamic t Todo
162 , _todoOutput_delete :: Event t ()
110 , _todoOutput_delete :: Event t ()
163 , _todoOutput_height :: Dynamic t Int
111 , _todoOutput_height :: Dynamic t Int
112+ , _todoOutput_focusId :: FocusId
164 }
113 }
165
114
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−
172todo
115todo
173− :: (MonadHold t m, MonadFix m, Reflex t, MonadNodeId m)
116+ :: (VtyExample t m, Manager t m, MonadHold t m)
174 => Todo
117 => Todo
175− -> VtyWidget t m (TodoOutput t)
118+ -> m (TodoOutput t)
176−todo t0 = do
119+todo t0 = row $ do
177− w <- displayWidth
120+ let getToggleEvent = keyCombos $ Set.fromList
178− rec let checkboxWidth = 3
121+ [ (V.KChar ' ', [V.MCtrl])
179− checkboxRegion = DynRegion 0 0 checkboxWidth 1
122+ , (V.KChar '@', [V.MCtrl])
180− labelHeight = _textInput_lines ti
123+ ]
181− labelWidth = w - 1 - checkboxWidth
124+ rec let cfg = def
182− labelLeft = checkboxWidth + 1
125+ { _checkboxConfig_setValue = setVal
183− labelTop = constDyn 0
126+ }
184− labelRegion = DynRegion labelLeft labelTop labelWidth labelHeight
127+ (toggleCB, value) <- tile (fixed 4) $ do
185− value <- pane checkboxRegion (pure True) $ checkbox def $ _todo_done t0
128+ e <- getToggleEvent
186− (ti, d) <- pane labelRegion (pure True) $ do
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
187 i <- input
136 i <- input
137+ e <- getToggleEvent
138+ v <- textInput $ def
188− v <- textInput $ def { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }
139+ { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }
189 let deleteSelf = attachWithMaybe backspaceOnEmpty (current $ _textInput_value v) i
140 let deleteSelf = attachWithMaybe backspaceOnEmpty (current $ _textInput_value v) i
190− return (v, deleteSelf)
141+ return (v, e, deleteSelf)
191 return $ TodoOutput
142 return $ TodoOutput
192 { _todoOutput_todo = Todo <$> _textInput_value ti <*> value
143 { _todoOutput_todo = Todo <$> _textInput_value ti <*> value
193 , _todoOutput_delete = d
144 , _todoOutput_delete = d
194 , _todoOutput_height = _textInput_lines ti
145 , _todoOutput_height = _textInput_lines ti
146+ , _todoOutput_focusId = fid
195 }
147 }
196 where
148 where
197 backspaceOnEmpty v = \case
149 backspaceOnEmpty v = \case
198 V.EvKey V.KBS _ | T.null v -> Just ()
150 V.EvKey V.KBS _ | T.null v -> Just ()
199 _ -> Nothing
151 _ -> 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)
209
152
210−{-
211todos
153todos
212 :: forall t m.
154 :: forall t m.
213 ( MonadHold t m
155 ( MonadHold t m
214− , MonadFix m
156+ , Manager t m
215− , Reflex t
157+ , VtyExample t m
216 , Adjustable t m
158 , Adjustable t m
217− , NotReady t m
218 , PostBuild t m
159 , PostBuild t m
219− , MonadNodeId m
220 )
160 )
221 => [Todo]
161 => [Todo]
222 -> Event t ()
162 -> Event t ()
223− -> VtyWidget t m (Dynamic t (Map Int (TodoOutput t)))
163+ -> m (Dynamic t (Map Int (TodoOutput t)))
224todos todos0 newTodo = do
164todos todos0 newTodo = do
225 let todosMap0 = Map.fromList $ zip [0..] todos0
165 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
166+ rec listOut <- listHoldWithKey todosMap0 updates $ \k t -> grout (fixed 1) $ do
167+ to <- todo t
232− let sel = select selectOnDelete $ Const2 k
168+ let sel = select selectOnDelete $ Const2 k
233− click <- void <$> mouseDown V.BLeft
234− pb <- getPostBuild
169+ pb <- getPostBuild
235− let focusMe = leftmost [ click, sel, pb ]
170+ requestFocus $ Refocus_Id (_todoOutput_focusId to) <$ leftmost [pb, sel]
236− r <- todo t
171+ pure to
237− return (focusMe, r)
238− let delete = ffor todoDelete $ \k -> Map.singleton k Nothing
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
239 updates = leftmost [insert, delete]
177 updates = leftmost [insert, delete]
240 todoDelete = switch . current $
178 todoDelete = switch . current $
241 leftmost . Map.elems . Map.mapWithKey (\k -> (k <$) . _todoOutput_delete) <$> listOut
179 leftmost . Map.elems . Map.mapWithKey (\k -> (k <$) . _todoOutput_delete) <$> listOut
242− todosMap = joinDynThroughMap $ fmap _todoOutput_todo <$> listOut
180+
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
246 selectOnDelete = fanMap $ (`Map.singleton` ()) <$> attachWithMaybe
181 selectOnDelete = fanMap $ (`Map.singleton` ()) <$> attachWithMaybe
247 (\m k -> let (before, after) = Map.split k m
182 (\m k -> let (before, after) = Map.split k m
248 in fmap fst $ Map.lookupMax before <|> Map.lookupMin after)
183 in fmap fst $ Map.lookupMax before <|> Map.lookupMin after)
249 (current todosMap)
184 (current todosMap)
250 todoDelete
185 todoDelete
251 return listOut
186 return listOut
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."
252−-}
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'])