git.iko.soy/reflex-vty
on 9bb4bc2 help sign in
reflex-vty/src-bin/example.hs
221 lines 10 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{-# OPTIONS_GHC -threaded #-}
12import Control.Applicative
13import Control.Monad
14import Control.Monad.Fix
15import Control.Monad.NodeId
16import Data.Functor.Misc
17import Data.Map (Map)
18import Data.Maybe
19import qualified Data.Map as Map
20import Data.Text (Text)
21import qualified Data.Text as T
22import qualified Data.Text.Zipper as TZ
23import qualified Graphics.Vty as V
24import Reflex
25import Reflex.Network
26import Reflex.Class.Switchable
27import Reflex.Vty
29data Example = Example_TextEditor
30 | Example_Todo
31 | Example_ScrollableTextDisplay
32 deriving (Show, Read, Eq, Ord, Enum, Bounded)
34main :: IO ()
35main = mainWidget $ do
36 inp <- input
37 let buttons = col $ do
38 fixed 4 $ col $ do
39 fixed 1 $ text "Select an example."
40 fixed 1 $ text "Esc will bring you back here."
41 fixed 1 $ text "Ctrl+c to quit."
42 a <- fixed 5 $ textButtonStatic def "Todo List"
43 b <- fixed 5 $ textButtonStatic def "Text Editor"
44 c <- fixed 5 $ textButtonStatic def "Scrollable text display"
45 return $ leftmost
46 [ Left Example_Todo <$ a
47 , Left Example_TextEditor <$ b
48 , Left Example_ScrollableTextDisplay <$ c
49 ]
50 escapable w = do
51 void w
52 i <- input
53 return $ fforMaybe i $ \case
54 V.EvKey V.KEsc [] -> Just $ Right ()
55 _ -> Nothing
56 rec out <- networkHold buttons $ ffor (switch (current out)) $ \case
57 Left Example_TextEditor -> escapable testBoxes
58 Left Example_Todo -> escapable taskList
59 Left Example_ScrollableTextDisplay -> escapable scrolling
60 Right () -> buttons
61 return $ fforMaybe inp $ \case
62 V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
63 _ -> Nothing
65taskList
66 :: (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, NotReady t m, PostBuild t m, MonadNodeId m)
67 => VtyWidget t m ()
68taskList = do
69 let btn = textButtonStatic def "Add another task"
70 inp <- input
71 let todos0 =
72 [ Todo "Find reflex-vty" True
73 , Todo "Become functional reactive" False
74 , Todo "Make vty apps" False
75 ]
76 rec let todos' = todos todos0 $ leftmost
77 [ () <$ e
78 , fforMaybe inp $ \case
79 V.EvKey V.KEnter [] -> Just ()
80 _ -> Nothing
81 ]
82 (m, (e, _)) <- splitV (pure (subtract 6)) (pure (True, True)) todos' $
83 splitV (pure (subtract 3)) (pure (True, True)) btn (display $ Map.size <$> current m)
84 return ()
86testBoxes
87 :: (Reflex t, MonadHold t m, MonadFix m, MonadNodeId m)
88 => VtyWidget t m ()
89testBoxes = do
90 dw <- displayWidth
91 dh <- displayHeight
92 let region1 = DynRegion (div' dw 6) (div' dh 6) (div' dw 2) (div' dh 2)
93 region2 = DynRegion (div' dw 4) (div' dh 4) (2 * div' dw 3) (2 * div' dh 3)
94 pane region1 (constDyn False) . boxStatic singleBoxStyle $ debugInput
95 _ <- pane region2 (constDyn True) . boxStatic singleBoxStyle $
96 let cfg = def
97 { _textInputConfig_initialValue =
98 "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."
99 }
100 textBox = boxTitle (pure roundedBoxStyle) "Text Edit" $
101 multilineTextInput cfg
102 dragBox = boxStatic roundedBoxStyle dragTest
103 in splitVDrag (hRule doubleBoxStyle) textBox dragBox
104 return ()
105 where
106 div' :: (Integral a, Applicative f) => f a -> f a -> f a
107 div' = liftA2 div
109debugFocus :: (Reflex t, Monad m) => VtyWidget t m ()
110debugFocus = do
111 f <- focus
112 text $ T.pack . show <$> current f
114debugInput :: (Reflex t, MonadHold t m) => VtyWidget t m ()
115debugInput = do
116 lastEvent <- hold "No event yet" . fmap show =<< input
117 text $ T.pack <$> lastEvent
119dragTest :: (Reflex t, MonadHold t m, MonadFix m) => VtyWidget t m ()
120dragTest = do
121 lastEvent <- hold "No event yet" . fmap show =<< drag V.BLeft
122 text $ T.pack <$> lastEvent
124testStringBox :: (Reflex t, Monad m, MonadNodeId m) => VtyWidget t m ()
125testStringBox = boxStatic singleBoxStyle .
126 text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z'])
128data Todo = Todo
129 { _todo_label :: Text
130 , _todo_done :: Bool
131 }
132 deriving (Show, Read, Eq, Ord)
134data TodoOutput t = TodoOutput
135 { _todoOutput_todo :: Dynamic t Todo
136 , _todoOutput_delete :: Event t ()
137 , _todoOutput_height :: Dynamic t Int
138 }
140instance Reflex t => Switchable t (TodoOutput t) where
141 switching t0 e = TodoOutput
142 <$> switching (_todoOutput_todo t0) (_todoOutput_todo <$> e)
143 <*> switching (_todoOutput_delete t0) (_todoOutput_delete <$> e)
144 <*> switching (_todoOutput_height t0) (_todoOutput_height <$> e)
146todo
147 :: (MonadHold t m, MonadFix m, Reflex t, MonadNodeId m)
148 => Todo
149 -> VtyWidget t m (TodoOutput t)
150todo t0 = do
151 w <- displayWidth
152 rec let checkboxWidth = 3
153 checkboxRegion = DynRegion 0 0 checkboxWidth 1
154 labelHeight = _textInput_lines ti
155 labelWidth = w - 1 - checkboxWidth
156 labelLeft = checkboxWidth + 1
157 labelTop = constDyn 0
158 labelRegion = DynRegion labelLeft labelTop labelWidth labelHeight
159 value <- pane checkboxRegion (pure True) $ checkbox def $ _todo_done t0
160 (ti, d) <- pane labelRegion (pure True) $ do
161 i <- input
162 v <- textInput $ def { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }
163 let deleteSelf = attachWithMaybe backspaceOnEmpty (current $ _textInput_value v) i
164 return (v, deleteSelf)
165 return $ TodoOutput
166 { _todoOutput_todo = Todo <$> _textInput_value ti <*> value
167 , _todoOutput_delete = d
168 , _todoOutput_height = _textInput_lines ti
169 }
170 where
171 backspaceOnEmpty v = \case
172 V.EvKey V.KBS _ | T.null v -> Just ()
173 _ -> Nothing
175scrolling :: (Reflex t, MonadHold t m, MonadFix m, PostBuild t m, MonadNodeId m) => VtyWidget t m ()
176scrolling = col $ do
177 fixed 2 $ text "Use your mouse wheel or up and down arrows to scroll:"
178 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."
179 fixed 1 $ text $ ffor out $ \(ix, total) -> "Scrolled to line " <> T.pack (show ix) <> " of " <> T.pack (show total)
181todos
182 :: forall t m.
183 ( MonadHold t m
184 , MonadFix m
185 , Reflex t
186 , Adjustable t m
187 , NotReady t m
188 , PostBuild t m
189 , MonadNodeId m
190 )
191 => [Todo]
192 -> Event t ()
193 -> VtyWidget t m (Dynamic t (Map Int (TodoOutput t)))
194todos todos0 newTodo = do
195 let todosMap0 = Map.fromList $ zip [0..] todos0
196 rec tabNav <- tabNavigation
197 let insertNav = 1 <$ insert
198 nav = leftmost [tabNav, insertNav]
199 tileCfg = def { _tileConfig_constraint = pure $ Constraint_Fixed 1}
200 listOut <- runLayout (pure Orientation_Column) 0 nav $
201 listHoldWithKey todosMap0 updates $ \k t -> tile tileCfg $ do
202 let sel = select selectOnDelete $ Const2 k
203 click <- void <$> mouseDown V.BLeft
204 pb <- getPostBuild
205 let focusMe = leftmost [ click, sel, pb ]
206 r <- todo t
207 return (focusMe, r)
208 let delete = ffor todoDelete $ \k -> Map.singleton k Nothing
209 updates = leftmost [insert, delete]
210 todoDelete = switch . current $
211 leftmost . Map.elems . Map.mapWithKey (\k -> (k <$) . _todoOutput_delete) <$> listOut
212 todosMap = joinDynThroughMap $ fmap _todoOutput_todo <$> listOut
213 insert = ffor (tag (current todosMap) newTodo) $ \m -> case Map.lookupMax m of
214 Nothing -> Map.singleton 0 $ Just $ Todo "" False
215 Just (k, _) -> Map.singleton (k+1) $ Just $ Todo "" False
216 selectOnDelete = fanMap $ (`Map.singleton` ()) <$> attachWithMaybe
217 (\m k -> let (before, after) = Map.split k m
218 in fmap fst $ Map.lookupMax before <|> Map.lookupMin after)
219 (current todosMap)
220 todoDelete
221 return listOut