git.iko.soy/reflex-vty
on 34847fb help sign in
reflex-vty/src-bin/example.hs
256 lines 12 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE GADTs #-}
4{-# LANGUAGE LambdaCase #-}
5{-# LANGUAGE MultiParamTypeClasses #-}
6{-# LANGUAGE OverloadedStrings #-}
7{-# LANGUAGE RankNTypes #-}
8{-# LANGUAGE RecursiveDo #-}
9{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE RecordWildCards #-}
13{-# OPTIONS_GHC -threaded #-}
15import Control.Applicative
16import Control.Monad
17import Control.Monad.Fix
18import Control.Monad.NodeId
19import Data.Functor
20import Data.Functor.Misc
21import Data.Map (Map)
22import Data.Maybe
23import qualified Data.Map as Map
24import Data.Text (Text)
25import qualified Data.Text as T
26import qualified Data.Text.Zipper as TZ
27import qualified Graphics.Vty as V
28import Reflex
29import Reflex.Network
30import Reflex.Class.Switchable
31import Reflex.Vty
33easyExample :: IO ()
34easyExample = mainWidget $ do
35 beginLayout $ row $ fixedL 39 $ col $ do
36 (a1,b1,c1) <- fixedL 3 $ row $ do
37 a <- stretch $ textButtonStatic def "POTATO"
38 b <- stretch $ textButtonStatic def "TOMATO"
39 c <- stretch $ textButtonStatic def "EGGPLANT"
40 return (a,b,c)
41 (a2,b2,c2) <- fixedL 3 $ row $ do
42 a <- stretch $ textButtonStatic def "CHEESE"
43 b <- stretch $ textButtonStatic def "BEES"
44 c <- stretch $ textButtonStatic def "MY KNEES"
45 return (a,b,c)
46 (a3,b3,c3) <- fixedL 3 $ row $ do
47 a <- stretch $ textButtonStatic def "TIME"
48 b <- stretch $ textButtonStatic def "RHYME"
49 c <- stretch $ textButtonStatic def "A BIG CRIME"
50 return (a,b,c)
51 -- NOTE the box will most likely not render correctly once you put emoji's
52 -- you need to initialize vty with an updated char width map to fix this
53 fixed 7 $ boxTitle (constant def) "CLICK BUTTONS TO DRAW" $ do
54 outputDyn <- foldDyn (<>) "" $ mergeWith (<>)
55 [a1 $> "\129364", b1 $> "🍅", c1 $> "🍆", a2 $> "\129472", b2 $> "🐝🐝", c2 $> "💘", a3 $> "⏰", b3 $> "📜", c3 $> "💰🔪🔒"]
56 text (current outputDyn)
57 inp <- input
58 return $ fforMaybe inp $ \case
59 V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
60 _ -> Nothing
63data Example = Example_TextEditor
64 | Example_Todo
65 | Example_ScrollableTextDisplay
66 deriving (Show, Read, Eq, Ord, Enum, Bounded)
68main :: IO ()
69main = mainWidget $ do
70 inp <- input
71 let buttons = beginLayout $ col $ do
72 fixedL 4 $ col $ do
73 fixed 1 $ text "Select an example."
74 fixed 1 $ text "Esc will bring you back here."
75 fixed 1 $ text "Ctrl+c to quit."
76 a <- fixed 5 $ textButtonStatic def "Todo List"
77 b <- fixed 5 $ textButtonStatic def "Text Editor"
78 c <- fixed 5 $ textButtonStatic def "Scrollable text display"
79 return $ leftmost
80 [ Left Example_Todo <$ a
81 , Left Example_TextEditor <$ b
82 , Left Example_ScrollableTextDisplay <$ c
83 ]
84 escapable w = do
85 void w
86 i <- input
87 return $ fforMaybe i $ \case
88 V.EvKey V.KEsc [] -> Just $ Right ()
89 _ -> Nothing
90 rec out <- networkHold buttons $ ffor (switch (current out)) $ \case
91 Left Example_TextEditor -> escapable testBoxes
92 Left Example_Todo -> escapable taskList
93 Left Example_ScrollableTextDisplay -> escapable scrolling
94 Right () -> buttons
95 return $ fforMaybe inp $ \case
96 V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
97 _ -> Nothing
99taskList
100 :: (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, NotReady t m, PostBuild t m, MonadNodeId m)
101 => VtyWidget t m ()
102taskList = do
103 let btn = textButtonStatic def "Add another task"
104 inp <- input
105 let todos0 =
106 [ Todo "Find reflex-vty" True
107 , Todo "Become functional reactive" False
108 , Todo "Make vty apps" False
109 ]
110 rec let todos' = todos todos0 $ leftmost
111 [ () <$ e
112 , fforMaybe inp $ \case
113 V.EvKey V.KEnter [] -> Just ()
114 _ -> Nothing
115 ]
116 (m, (e, _)) <- splitV (pure (subtract 6)) (pure (True, True)) todos' $
117 splitV (pure (subtract 3)) (pure (True, True)) btn (display $ Map.size <$> current m)
118 return ()
120testBoxes
121 :: (Reflex t, MonadHold t m, MonadFix m, MonadNodeId m)
122 => VtyWidget t m ()
123testBoxes = do
124 dw <- displayWidth
125 dh <- displayHeight
126 let region1 = DynRegion (div' dw 6) (div' dh 6) (div' dw 2) (div' dh 2)
127 region2 = DynRegion (div' dw 4) (div' dh 4) (2 * div' dw 3) (2 * div' dh 3)
128 pane region1 (constDyn False) . boxStatic singleBoxStyle $ debugInput
129 _ <- pane region2 (constDyn True) . boxStatic singleBoxStyle $
130 let cfg = def
131 { _textInputConfig_initialValue =
132 "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."
133 }
134 textBox = boxTitle (pure roundedBoxStyle) "Text Edit" $
135 multilineTextInput cfg
136 dragBox = boxStatic roundedBoxStyle dragTest
137 in splitVDrag (hRule doubleBoxStyle) textBox dragBox
138 return ()
139 where
140 div' :: (Integral a, Applicative f) => f a -> f a -> f a
141 div' = liftA2 div
143debugFocus :: (Reflex t, Monad m) => VtyWidget t m ()
144debugFocus = do
145 f <- focus
146 text $ T.pack . show <$> current f
148debugInput :: (Reflex t, MonadHold t m) => VtyWidget t m ()
149debugInput = do
150 lastEvent <- hold "No event yet" . fmap show =<< input
151 text $ T.pack <$> lastEvent
153dragTest :: (Reflex t, MonadHold t m, MonadFix m) => VtyWidget t m ()
154dragTest = do
155 lastEvent <- hold "No event yet" . fmap show =<< drag V.BLeft
156 text $ T.pack <$> lastEvent
158testStringBox :: (Reflex t, Monad m, MonadNodeId m) => VtyWidget t m ()
159testStringBox = boxStatic singleBoxStyle .
160 text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z'])
162data Todo = Todo
163 { _todo_label :: Text
164 , _todo_done :: Bool
165 }
166 deriving (Show, Read, Eq, Ord)
168data TodoOutput t = TodoOutput
169 { _todoOutput_todo :: Dynamic t Todo
170 , _todoOutput_delete :: Event t ()
171 , _todoOutput_height :: Dynamic t Int
172 }
174instance Reflex t => Switchable t (TodoOutput t) where
175 switching t0 e = TodoOutput
176 <$> switching (_todoOutput_todo t0) (_todoOutput_todo <$> e)
177 <*> switching (_todoOutput_delete t0) (_todoOutput_delete <$> e)
178 <*> switching (_todoOutput_height t0) (_todoOutput_height <$> e)
180todo
181 :: (MonadHold t m, MonadFix m, Reflex t, MonadNodeId m)
182 => Todo
183 -> VtyWidget t m (TodoOutput t)
184todo t0 = do
185 w <- displayWidth
186 rec let checkboxWidth = 3
187 checkboxRegion = DynRegion 0 0 checkboxWidth 1
188 labelHeight = _textInput_lines ti
189 labelWidth = w - 1 - checkboxWidth
190 labelLeft = checkboxWidth + 1
191 labelTop = constDyn 0
192 labelRegion = DynRegion labelLeft labelTop labelWidth labelHeight
193 value <- pane checkboxRegion (pure True) $ checkbox def $ _todo_done t0
194 (ti, d) <- pane labelRegion (pure True) $ do
195 i <- input
196 v <- textInput $ def { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }
197 let deleteSelf = attachWithMaybe backspaceOnEmpty (current $ _textInput_value v) i
198 return (v, deleteSelf)
199 return $ TodoOutput
200 { _todoOutput_todo = Todo <$> _textInput_value ti <*> value
201 , _todoOutput_delete = d
202 , _todoOutput_height = _textInput_lines ti
203 }
204 where
205 backspaceOnEmpty v = \case
206 V.EvKey V.KBS _ | T.null v -> Just ()
207 _ -> Nothing
209scrolling :: (Reflex t, MonadHold t m, MonadFix m, PostBuild t m, MonadNodeId m) => VtyWidget t m ()
210scrolling = beginLayout $ col $ do
211 fixed 2 $ text "Use your mouse wheel or up and down arrows to scroll:"
212 out <- 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."
213 fixed 1 $ text $ ffor out $ \(ix, total) -> "Scrolled to line " <> T.pack (show ix) <> " of " <> T.pack (show total)
215todos
216 :: forall t m.
217 ( MonadHold t m
218 , MonadFix m
219 , Reflex t
220 , Adjustable t m
221 , NotReady t m
222 , PostBuild t m
223 , MonadNodeId m
224 )
225 => [Todo]
226 -> Event t ()
227 -> VtyWidget t m (Dynamic t (Map Int (TodoOutput t)))
228todos todos0 newTodo = do
229 let todosMap0 = Map.fromList $ zip [0..] todos0
230 rec tabNav <- tabNavigation
231 let insertNav = 1 <$ insert
232 navEv = leftmost [tabNav, insertNav]
233 focusEv = layoutFocusEvFromNavigation navEv never lrd
234 tileCfg = def { _tileConfig_constraint = pure $ Constraint_Fixed 1}
235 lrd@LayoutReturnData {..} <- flip runIsLayoutVtyWidget focusEv $ runLayoutL (pure Orientation_Column) (Just 0) $
236 listHoldWithKey todosMap0 updates $ \k t -> tile tileCfg $ do
237 let sel = select selectOnDelete $ Const2 k
238 click <- void <$> mouseDown V.BLeft
239 pb <- getPostBuild
240 let focusMe = leftmost [ click, sel, pb ]
241 r <- todo t
242 return (focusMe, r)
243 let delete = ffor todoDelete $ \k -> Map.singleton k Nothing
244 updates = leftmost [insert, delete]
245 todoDelete = switch . current $
246 leftmost . Map.elems . Map.mapWithKey (\k -> (k <$) . _todoOutput_delete) <$> _layoutReturnData_value
247 todosMap = joinDynThroughMap $ fmap _todoOutput_todo <$> _layoutReturnData_value
248 insert = ffor (tag (current todosMap) newTodo) $ \m -> case Map.lookupMax m of
249 Nothing -> Map.singleton 0 $ Just $ Todo "" False
250 Just (k, _) -> Map.singleton (k+1) $ Just $ Todo "" False
251 selectOnDelete = fanMap $ (`Map.singleton` ()) <$> attachWithMaybe
252 (\m k -> let (before, after) = Map.split k m
253 in fmap fst $ Map.lookupMax before <|> Map.lookupMin after)
254 (current todosMap)
255 todoDelete
256 return _layoutReturnData_value