git.iko.soy/reflex-vty
on develop help sign in
reflex-vty/src-bin/example.hs
283 lines 12 kB history raw
1import Control.Applicative
2import Control.Monad
3import Control.Monad.Fix
4import Data.Functor
5import Data.Functor.Misc
6import Data.Map (Map)
7import qualified Data.Map as Map
8import qualified Data.Set as Set
9import Data.Text (Text)
10import qualified Data.Text as T
11import qualified Data.Text.Zipper as TZ
12import qualified Graphics.Vty as V
13import Reflex
14import Reflex.Network
15import Reflex.Vty
17import Example.CPU
19type VtyExample t m =
20 ( MonadFix m
21 , Reflex t
22 , HasInput t m
23 , HasImageWriter t m
24 , HasDisplayRegion t m
25 , HasFocus t m
26 , HasFocusReader t m, HasTheme t m
27 )
29type Manager t m =
30 ( HasLayout t m
31 , HasFocus t m
32 )
34data Example = Example_TextEditor
35 | Example_Todo
36 | Example_ScrollableTextDisplay
37 | Example_ClickButtonsGetEmojis
38 | Example_CPUStat
39 deriving (Show, Read, Eq, Ord, Enum, Bounded)
41withCtrlC :: (Monad m, HasInput t m, Reflex t) => m () -> m (Event t ())
42withCtrlC f = do
43 inp <- input
44 f
45 return $ fforMaybe inp $ \case
46 V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
47 _ -> Nothing
49darkTheme :: V.Attr
50darkTheme = V.Attr {
51 V.attrStyle = V.SetTo V.standout
52 , V.attrForeColor = V.SetTo V.black
53 , V.attrBackColor = V.Default
54 , V.attrURL = V.Default
57main :: IO ()
58main = mainWidget $ withCtrlC $ do
59 initManager_ $ do
60 tabNavigation
61 let gf = grout . fixed
62 t = tile flex
63 buttons = col $ do
64 gf 3 $ col $ do
65 gf 1 $ text "Select an example."
66 gf 1 $ text "Esc will bring you back here."
67 gf 1 $ text "Ctrl+c to quit."
68 a <- t $ textButtonStatic def "Todo List"
69 b <- t $ textButtonStatic def "Text Editor"
70 c <- t $ textButtonStatic def "Scrollable text display"
71 d <- t $ textButtonStatic def "Clickable buttons"
72 e <- t $ textButtonStatic def "CPU Usage"
73 return $ leftmost
74 [ Left Example_Todo <$ a
75 , Left Example_TextEditor <$ b
76 , Left Example_ScrollableTextDisplay <$ c
77 , Left Example_ClickButtonsGetEmojis <$ d
78 , Left Example_CPUStat <$ e
79 ]
80 let escapable w = do
81 void w
82 i <- input
83 return $ fforMaybe i $ \case
84 V.EvKey V.KEsc [] -> Just $ Right ()
85 _ -> Nothing
86 rec out <- networkHold buttons $ ffor (switch (current out)) $ \case
87 Left Example_Todo -> escapable taskList
88 Left Example_TextEditor -> escapable $ localTheme (const (constant darkTheme)) testBoxes
89 Left Example_ScrollableTextDisplay -> escapable scrolling
90 Left Example_ClickButtonsGetEmojis -> escapable easyExample
91 Left Example_CPUStat -> escapable cpuStats
92 Right () -> buttons
93 return ()
95-- * Mouse button and emojis example
96easyExample :: (VtyExample t m, Manager t m, MonadHold t m) => m (Event t ())
97easyExample = do
98 row $ grout (fixed 39) $ col $ do
99 (a1,b1,c1) <- grout (fixed 3) $ row $ do
100 a <- tile flex $ btn "POTATO"
101 b <- tile flex $ btn "TOMATO"
102 c <- tile flex $ btn "EGGPLANT"
103 return (a,b,c)
104 (a2,b2,c2) <- grout (fixed 3) $ row $ do
105 a <- tile flex $ btn "CHEESE"
106 b <- tile flex $ btn "BEES"
107 c <- tile flex $ btn "MY KNEES"
108 return (a,b,c)
109 (a3,b3,c3) <- grout (fixed 3) $ row $ do
110 a <- tile flex $ btn "TIME"
111 b <- tile flex $ btn "RHYME"
112 c <- tile flex $ btn "A BIG CRIME"
113 return (a,b,c)
114 tile (fixed 7) $ boxTitle (constant def) "CLICK BUTTONS TO DRAW*" $ do
115 outputDyn <- foldDyn (<>) "" $ mergeWith (<>)
116 [a1 $> "\129364", b1 $> "🍅", c1 $> "🍆", a2 $> "\129472", b2 $> "🐝🐝", c2 $> "💘", a3 $> "⏰", b3 $> "📜", c3 $> "💰🔪🔒"]
117 text (current outputDyn)
118 tile flex $ text "* Requires font support for emojis. Box may render incorrectly unless your vty is initialized with an updated char width map."
119 inp <- input
120 return $ fforMaybe inp $ \case
121 V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
122 _ -> Nothing
123 where
124 btn label = do
125 let cfg = def { _buttonConfig_focusStyle = pure doubleBoxStyle }
126 buttonClick <- textButtonStatic cfg label
127 keyPress <- keyCombos $ Set.fromList
128 [ (V.KEnter, [])
129 , (V.KChar ' ', [])
130 ]
131 pure $ leftmost [() <$ buttonClick, () <$ keyPress]
133-- * Task list example
134taskList
135 :: (VtyExample t m, Manager t m, MonadHold t m, Adjustable t m, PostBuild t m)
136 => m ()
137taskList = col $ do
138 let todos0 =
139 [ Todo "Find reflex-vty" True
140 , Todo "Become functional reactive" False
141 , Todo "Make vty apps" False
142 ]
143 btn = textButtonStatic def "Add another task"
144 enter <- fmap (const ()) <$> key V.KEnter
145 rec void $ grout flex $ todos todos0 $ enter <> click
146 click <- tile (fixed 3) btn
147 return ()
149data Todo = Todo
150 { _todo_label :: Text
151 , _todo_done :: Bool
152 }
153 deriving (Show, Read, Eq, Ord)
155data TodoOutput t = TodoOutput
156 { _todoOutput_todo :: Dynamic t Todo
157 , _todoOutput_delete :: Event t ()
158 , _todoOutput_height :: Dynamic t Int
159 , _todoOutput_focusId :: FocusId
160 }
162todo
163 :: (VtyExample t m, Manager t m, MonadHold t m)
164 => Todo
165 -> m (TodoOutput t)
166todo t0 = row $ do
167 let toggleKeys = Set.fromList
168 [ (V.KChar ' ', [V.MCtrl])
169 , (V.KChar '@', [V.MCtrl])
170 ]
171 anyChildFocused $ \focused -> do
172 toggleE <- keyCombos toggleKeys
173 filterKeys (flip Set.notMember $ Set.insert (V.KChar '\t', []) toggleKeys) $ do
174 rec let cfg = def
175 { _checkboxConfig_setValue = setVal
176 }
177 value <- tile (fixed 4) $ checkbox cfg $ _todo_done t0
178 let setVal = attachWith (\v _ -> not v) (current value) $ gate (current focused) toggleE
179 (fid, (ti, d)) <- tile' flex $ do
180 i <- input
181 v <- textInput $ def
182 { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }
183 let deleteSelf = attachWithMaybe backspaceOnEmpty (current $ _textInput_value v) i
184 return (v, deleteSelf)
185 return $ TodoOutput
186 { _todoOutput_todo = Todo <$> _textInput_value ti <*> value
187 , _todoOutput_delete = d
188 , _todoOutput_height = _textInput_lines ti
189 , _todoOutput_focusId = fid
190 }
191 where
192 backspaceOnEmpty v = \case
193 V.EvKey V.KBS _ | T.null v -> Just ()
194 _ -> Nothing
196todos
197 :: forall t m.
198 ( MonadHold t m
199 , Manager t m
200 , VtyExample t m
201 , Adjustable t m
202 , PostBuild t m
203 )
204 => [Todo]
205 -> Event t ()
206 -> m (Dynamic t (Map Int (TodoOutput t)))
207todos todos0 newTodo = do
208 let todosMap0 = Map.fromList $ zip [0..] todos0
209 rec listOut <- listHoldWithKey todosMap0 updates $ \k t -> grout (fixed 1) $ do
210 to <- todo t
211 let sel = select selectOnDelete $ Const2 k
212 pb <- getPostBuild
213 requestFocus $ Refocus_Id (_todoOutput_focusId to) <$ leftmost [pb, sel]
214 pure to
215 let delete = flip Map.singleton Nothing <$> todoDelete
216 todosMap = joinDynThroughMap $ fmap _todoOutput_todo <$> listOut
217 insert = ffor (tag (current todosMap) newTodo) $ \m -> case Map.lookupMax m of
218 Nothing -> Map.singleton 0 $ Just $ Todo "" False
219 Just (k, _) -> Map.singleton (k+1) $ Just $ Todo "" False
220 updates = leftmost [insert, delete]
221 todoDelete = switch . current $
222 leftmost . Map.elems . Map.mapWithKey (\k -> (k <$) . _todoOutput_delete) <$> listOut
224 selectOnDelete = fanMap $ (`Map.singleton` ()) <$> attachWithMaybe
225 (\m k -> let (before, after) = Map.split k m
226 in fmap fst $ Map.lookupMax before <|> Map.lookupMin after)
227 (current todosMap)
228 todoDelete
229 return listOut
231-- * Scrollable text example
233scrolling :: (VtyExample t m, MonadHold t m, Manager t m, PostBuild t m) => m ()
234scrolling = col $ do
235 grout (fixed 2) $ text "Use your mouse wheel or up and down arrows to scroll:"
236 (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."
237 pb <- getPostBuild
238 requestFocus $ Refocus_Id fid <$ pb
239 grout (fixed 1) $ text $ ffor out $ \(ix, total) -> "Scrolled to line " <> T.pack (show ix) <> " of " <> T.pack (show total)
241-- * Text editor example with resizable boxes
243testBoxes
244 :: (MonadHold t m, VtyExample t m)
245 => m ()
246testBoxes = do
247 dw <- displayWidth
248 dh <- displayHeight
249 let region1 = Region <$> (div' dw 6) <*> (div' dh 6) <*> (div' dw 2) <*> (div' dh 2)
250 region2 = Region <$> (div' dw 4) <*> (div' dh 4) <*> (2 * div' dw 3) <*> (2 * div' dh 3)
251 pane region1 (constDyn False) . boxStatic singleBoxStyle $ debugInput
252 _ <- pane region2 (constDyn True) . boxStatic singleBoxStyle $
253 let cfg = def
254 { _textInputConfig_initialValue =
255 "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."
256 }
257 textBox = boxTitle (pure roundedBoxStyle) "Text Edit" $
258 multilineTextInput cfg
259 dragBox = boxStatic roundedBoxStyle dragTest
260 in splitVDrag (hRule doubleBoxStyle) textBox dragBox
261 return ()
262 where
263 div' :: (Integral a, Applicative f) => f a -> f a -> f a
264 div' = liftA2 div
266debugFocus :: (VtyExample t m) => m ()
267debugFocus = do
268 f <- focus
269 text $ T.pack . show <$> current f
271debugInput :: (VtyExample t m, MonadHold t m) => m ()
272debugInput = do
273 lastEvent <- hold "No event yet" . fmap show =<< input
274 text $ T.pack <$> lastEvent
276dragTest :: (VtyExample t m, MonadHold t m) => m ()
277dragTest = do
278 lastEvent <- hold "No event yet" . fmap show =<< drag V.BLeft
279 text $ T.pack <$> lastEvent
281testStringBox :: VtyExample t m => m ()
282testStringBox = boxStatic singleBoxStyle .
283 text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z'])