git.iko.soy/reflex-vty
on d333d0c help sign in
reflex-vty/src-bin/example.hs
193 lines 7.0 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 TupleSections #-}
11{-# OPTIONS_GHC -threaded #-}
13import Control.Applicative
14import Control.Monad.Fix
15import Data.Map (Map)
16import qualified Data.Map as Map
17import Data.Text (Text)
18import qualified Data.Text as T
19import qualified Data.Text.Zipper as TZ
20import qualified Graphics.Vty as V
21import Reflex
22import Reflex.Network
23import Reflex.Class.Switchable
24import Reflex.NotReady.Class
25import Reflex.Vty
27data Example = Example_TextEditor
28 | Example_Todo
29 deriving (Show, Read, Eq, Ord, Enum, Bounded)
31main :: IO ()
32main = mainWidget $ do
33 inp <- input
34 size <- displaySize
35 tellShutdown . fforMaybe inp $ \case
36 V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
37 _ -> Nothing
38 let buttons = do
39 text $ pure "Select an example. Ctrl+c to quit."
40 let region1 = ffor size $ \(w,h) ->
41 Region (w `div` 6) (h `div` 6) (w `div` 6) (h `div` 6)
42 region2 = ffor size $ \(w,h) ->
43 Region (2 * w `div` 6) (h `div` 6) (w `div` 6) (h `div` 6)
44 todo' <- pane region1 (pure True) $ button "Todo List"
45 editor <- pane region2 (pure True) $ button "Text Editor"
46 return $ leftmost
47 [ Example_TextEditor <$ editor
48 , Example_Todo <$ todo'
49 ]
50 rec out <- networkHold buttons $ ffor (switch $ current out) $ \case
51 Example_TextEditor -> testBoxes >> return never
52 Example_Todo -> taskList >> return never
53 return ()
55taskList
56 :: (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, NotReady t m, PostBuild t m)
57 => VtyWidget t m ()
58taskList = do
59 let btn = button $ pure "Add another task"
60 inp <- input
61 rec let todos' = todos [Todo "First" True, Todo "Second" False, Todo "Third" False] $ leftmost
62 [ () <$ e
63 , fforMaybe inp $ \case
64 V.EvKey V.KEnter [] -> Just ()
65 _ -> Nothing
66 ]
67 (m, (e, _)) <- splitV (pure (subtract 6)) (pure (True, True)) todos' $ do
68 splitV (pure (subtract 3)) (pure (True, True)) btn (display $ current m)
69 return ()
71testBoxes :: (Reflex t, MonadHold t m, MonadFix m) => VtyWidget t m ()
72testBoxes = do
73 size <- displaySize
74 let region1 = fmap (\(w,h) -> Region (w `div` 6) (h `div` 6) (w `div` 2) (h `div` 2)) size
75 region2 = fmap (\(w,h) -> Region (w `div` 4) (h `div` 4) (2 * (w `div` 3)) (2*(h `div` 3))) size
76 pane region1 (constDyn False) . box singleBoxStyle $ debugInput
77 _ <- pane region2 (constDyn True) . box singleBoxStyle $
78 splitVDrag (hRule doubleBoxStyle) (box roundedBoxStyle $ multilineTextInput def) (box roundedBoxStyle dragTest)
79 return ()
81debugFocus :: (Reflex t, Monad m) => VtyWidget t m ()
82debugFocus = do
83 f <- focus
84 text $ T.pack . show <$> current f
86debugInput :: (Reflex t, MonadHold t m) => VtyWidget t m ()
87debugInput = do
88 lastEvent <- hold "No event yet" . fmap show =<< input
89 text $ T.pack <$> lastEvent
91dragTest :: (Reflex t, MonadHold t m, MonadFix m) => VtyWidget t m ()
92dragTest = do
93 lastEvent <- hold "No event yet" . fmap show =<< drag V.BLeft
94 text $ T.pack <$> lastEvent
96testStringBox :: (Reflex t, Monad m) => VtyWidget t m ()
97testStringBox = box singleBoxStyle .
98 text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z'])
100data Todo = Todo
101 { _todo_label :: Text
102 , _todo_done :: Bool
103 }
104 deriving (Show, Read, Eq, Ord)
106checkbox
107 :: (MonadHold t m, MonadFix m, Reflex t)
108 => Bool
109 -> VtyWidget t m (Dynamic t Bool)
110checkbox v0 = do
111 i <- input
112 v <- toggle v0 $ fforMaybe i $ \case
113 V.EvMouseUp _ _ _ -> Just ()
114 _ -> Nothing
115 text $ current $ ffor v $ \v' -> if v' then "[x]" else "[ ]"
116 return v
118button :: (Reflex t, Monad m) => Behavior t Text -> VtyWidget t m (Event t ())
119button t = do
120 box roundedBoxStyle $ text t
121 fmap (() <$) mouseUp
123data TodoOutput t = TodoOutput
124 { _todoOutput_todo :: Dynamic t Todo
125 , _todoOutput_delete :: Event t ()
126 }
128instance Reflex t => Switchable t (TodoOutput t) where
129 switching t0 e = TodoOutput
130 <$> switching (_todoOutput_todo t0) (_todoOutput_todo <$> e)
131 <*> switching (_todoOutput_delete t0) (_todoOutput_delete <$> e)
133todo
134 :: (MonadHold t m, MonadFix m, Reflex t)
135 => Todo
136 -> VtyWidget t m (TodoOutput t)
137todo t0 = do
138 w <- displayWidth
139 let checkboxWidth = 3
140 checkboxRegion = pure $ Region 0 0 checkboxWidth 1
141 labelRegion = ffor w $ \w' -> Region (checkboxWidth + 1) 0 (w' - 1 - checkboxWidth) 1
142 value <- pane checkboxRegion (pure True) $ checkbox $ _todo_done t0
143 (label, d) <- pane labelRegion (pure True) $ do
144 i <- input
145 v <- textInput $ def { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }
146 let deleteSelf = attachWithMaybe backspaceOnEmpty (current v) i
147 return (v, deleteSelf)
148 return $ TodoOutput
149 { _todoOutput_todo = Todo <$> label <*> value
150 , _todoOutput_delete = d
151 }
152 where
153 backspaceOnEmpty v = \case
154 V.EvKey V.KBS _ | T.null v -> Just ()
155 _ -> Nothing
157todos
158 :: forall t m. (MonadHold t m, MonadFix m, Reflex t, Adjustable t m, NotReady t m, PostBuild t m)
159 => [Todo]
160 -> Event t ()
161 -> VtyWidget t m (Dynamic t (Map Int Todo))
162todos todos0 newTodo = do
163 let todosMap0 = Map.fromList $ zip [0..] todos0
164 w <- displayWidth
165 rec listOut <- listHoldWithKey todosMap0 updates $ \row t -> do
166 let reg = zipDynWith (\w' ts ->
167 let l = Map.size $ Map.takeWhileAntitone (<row) ts
168 in Region 0 l w' 1) w todosMap
169 pane reg (fmap (==row) selected) $ do
170 e <- mouseUp
171 r <- todo t
172 return (row <$ e, r)
173 let selectionClick = switch . current $ fmap (leftmost . Map.elems . fmap fst) listOut
174 selected <- holdDyn 0 $ leftmost
175 [ selectionClick
176 , fmapMaybe (fmap fst . Map.lookupMax) insert
177 , selectOnDelete
178 ]
179 let todosMap = joinDynThroughMap $ fmap (fmap (_todoOutput_todo . snd)) listOut
180 todoDelete = switch . current $
181 leftmost . Map.elems . Map.mapWithKey (\k -> (k <$) . _todoOutput_delete . snd) <$> listOut
182 selectOnDelete = attachWithMaybe
183 (\m k -> let (before, after) = Map.split k m
184 in fmap fst $ Map.lookupMax before <|> Map.lookupMin after)
185 (current todosMap)
186 todoDelete
187 insert = ffor (tag (current todosMap) newTodo) $ \m -> case Map.lookupMax m of
188 Nothing -> Map.singleton 0 $ Just $ Todo "" False
189 Just (k, _) -> Map.union (Just <$> m) $ Map.singleton (k+1) $ Just $ Todo "" False
190 delete = ffor (attach (current todosMap) todoDelete) $ \(m, k) ->
191 Map.union (Map.singleton k Nothing) $ Just <$> m
192 updates = leftmost [insert, delete]
193 return todosMap