git.iko.soy/reflex-vty
on ed6ffff help sign in
reflex-vty/src-bin/example.hs
195 lines 7.1 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. Esc will bring you back here. 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) $ textButtonStatic def "Todo List"
45 editor <- pane region2 (pure True) $ textButtonStatic def "Text Editor"
46 return $ leftmost
47 [ Left Example_TextEditor <$ editor
48 , Left Example_Todo <$ todo'
49 ]
50 escapable w = do
51 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 Right () -> buttons
60 return ()
62taskList
63 :: (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, NotReady t m, PostBuild t m)
64 => VtyWidget t m ()
65taskList = do
66 let btn = textButtonStatic def "Add another task"
67 inp <- input
68 rec let todos' = todos [Todo "First" True, Todo "Second" False, Todo "Third" False] $ leftmost
69 [ () <$ e
70 , fforMaybe inp $ \case
71 V.EvKey V.KEnter [] -> Just ()
72 _ -> Nothing
73 ]
74 (m, (e, _)) <- splitV (pure (subtract 6)) (pure (True, True)) todos' $ do
75 splitV (pure (subtract 3)) (pure (True, True)) btn (display $ current m)
76 return ()
78testBoxes :: (Reflex t, MonadHold t m, MonadFix m) => VtyWidget t m ()
79testBoxes = do
80 size <- displaySize
81 let region1 = fmap (\(w,h) -> Region (w `div` 6) (h `div` 6) (w `div` 2) (h `div` 2)) size
82 region2 = fmap (\(w,h) -> Region (w `div` 4) (h `div` 4) (2 * (w `div` 3)) (2*(h `div` 3))) size
83 pane region1 (constDyn False) . boxStatic singleBoxStyle $ debugInput
84 _ <- pane region2 (constDyn True) . boxStatic singleBoxStyle $
85 splitVDrag (hRule doubleBoxStyle) (boxStatic roundedBoxStyle $ multilineTextInput def) (boxStatic roundedBoxStyle dragTest)
86 return ()
88debugFocus :: (Reflex t, Monad m) => VtyWidget t m ()
89debugFocus = do
90 f <- focus
91 text $ T.pack . show <$> current f
93debugInput :: (Reflex t, MonadHold t m) => VtyWidget t m ()
94debugInput = do
95 lastEvent <- hold "No event yet" . fmap show =<< input
96 text $ T.pack <$> lastEvent
98dragTest :: (Reflex t, MonadHold t m, MonadFix m) => VtyWidget t m ()
99dragTest = do
100 lastEvent <- hold "No event yet" . fmap show =<< drag V.BLeft
101 text $ T.pack <$> lastEvent
103testStringBox :: (Reflex t, Monad m) => VtyWidget t m ()
104testStringBox = boxStatic singleBoxStyle .
105 text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z'])
107data Todo = Todo
108 { _todo_label :: Text
109 , _todo_done :: Bool
110 }
111 deriving (Show, Read, Eq, Ord)
113checkbox
114 :: (MonadHold t m, MonadFix m, Reflex t)
115 => Bool
116 -> VtyWidget t m (Dynamic t Bool)
117checkbox v0 = do
118 i <- input
119 v <- toggle v0 $ fforMaybe i $ \case
120 V.EvMouseUp _ _ _ -> Just ()
121 _ -> Nothing
122 text $ current $ ffor v $ \v' -> if v' then "[x]" else "[ ]"
123 return v
125data TodoOutput t = TodoOutput
126 { _todoOutput_todo :: Dynamic t Todo
127 , _todoOutput_delete :: Event t ()
128 }
130instance Reflex t => Switchable t (TodoOutput t) where
131 switching t0 e = TodoOutput
132 <$> switching (_todoOutput_todo t0) (_todoOutput_todo <$> e)
133 <*> switching (_todoOutput_delete t0) (_todoOutput_delete <$> e)
135todo
136 :: (MonadHold t m, MonadFix m, Reflex t)
137 => Todo
138 -> VtyWidget t m (TodoOutput t)
139todo t0 = do
140 w <- displayWidth
141 let checkboxWidth = 3
142 checkboxRegion = pure $ Region 0 0 checkboxWidth 1
143 labelRegion = ffor w $ \w' -> Region (checkboxWidth + 1) 0 (w' - 1 - checkboxWidth) 1
144 value <- pane checkboxRegion (pure True) $ checkbox $ _todo_done t0
145 (label, d) <- pane labelRegion (pure True) $ do
146 i <- input
147 v <- textInput $ def { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }
148 let deleteSelf = attachWithMaybe backspaceOnEmpty (current v) i
149 return (v, deleteSelf)
150 return $ TodoOutput
151 { _todoOutput_todo = Todo <$> label <*> value
152 , _todoOutput_delete = d
153 }
154 where
155 backspaceOnEmpty v = \case
156 V.EvKey V.KBS _ | T.null v -> Just ()
157 _ -> Nothing
159todos
160 :: forall t m. (MonadHold t m, MonadFix m, Reflex t, Adjustable t m, NotReady t m, PostBuild t m)
161 => [Todo]
162 -> Event t ()
163 -> VtyWidget t m (Dynamic t (Map Int Todo))
164todos todos0 newTodo = do
165 let todosMap0 = Map.fromList $ zip [0..] todos0
166 w <- displayWidth
167 rec listOut <- listHoldWithKey todosMap0 updates $ \row t -> do
168 let reg = zipDynWith (\w' ts ->
169 let l = Map.size $ Map.takeWhileAntitone (<row) ts
170 in Region 0 l w' 1) w todosMap
171 pane reg (fmap (==row) selected) $ do
172 e <- mouseUp
173 r <- todo t
174 return (row <$ e, r)
175 let selectionClick = switch . current $ fmap (leftmost . Map.elems . fmap fst) listOut
176 selected <- holdDyn 0 $ leftmost
177 [ selectionClick
178 , fmapMaybe (fmap fst . Map.lookupMax) insert
179 , selectOnDelete
180 ]
181 let todosMap = joinDynThroughMap $ fmap (fmap (_todoOutput_todo . snd)) listOut
182 todoDelete = switch . current $
183 leftmost . Map.elems . Map.mapWithKey (\k -> (k <$) . _todoOutput_delete . snd) <$> listOut
184 selectOnDelete = attachWithMaybe
185 (\m k -> let (before, after) = Map.split k m
186 in fmap fst $ Map.lookupMax before <|> Map.lookupMin after)
187 (current todosMap)
188 todoDelete
189 insert = ffor (tag (current todosMap) newTodo) $ \m -> case Map.lookupMax m of
190 Nothing -> Map.singleton 0 $ Just $ Todo "" False
191 Just (k, _) -> Map.union (Just <$> m) $ Map.singleton (k+1) $ Just $ Todo "" False
192 delete = ffor (attach (current todosMap) todoDelete) $ \(m, k) ->
193 Map.union (Map.singleton k Nothing) $ Just <$> m
194 updates = leftmost [insert, delete]
195 return todosMap