git.iko.soy/reflex-vty
on efe7df8 help sign in
reflex-vty/src-bin/example.hs
219 lines 8.2 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
15import Control.Monad.Fix
16import Data.Map (Map)
17import Data.Maybe
18import qualified Data.Map as Map
19import Data.Text (Text)
20import qualified Data.Text as T
21import qualified Data.Text.Zipper as TZ
22import qualified Graphics.Vty as V
23import Reflex
24import Reflex.Class.Orphans
25import Reflex.Network
26import Reflex.Class.Switchable
27import Reflex.NotReady.Class
28import Reflex.Vty
30data Example = Example_TextEditor
31 | Example_Todo
32 | Example_Stack
33 deriving (Show, Read, Eq, Ord, Enum, Bounded)
35div' :: (Integral a, Applicative f) => f a -> f a -> f a
36div' = liftA2 div
38main :: IO ()
39main = mainWidget $ do
40 inp <- input
42 w <- displayWidth
43 h <- displayHeight
45 row $ sized (div' w 2) $ col $ do
46 sized 5 $ display (current w)
47 sized 5 $ textButtonStatic def "A"
48 sized 5 $ textButtonStatic def "B"
49 -- (th, label) <- StackWidget $ \_ -> do
50 -- (TextInput value lines) <- multilineTextInput def
51 -- return (lines, (lines, value))
52 -- sized (th+4) $ textButton def ("\n" <> current label)
53 sized 5 $ textButtonStatic def "E"
54 sized 1 $ text "asdf"
55 sized 1 $ text "zxcv"
57 {-
58 let buttons = do
59 text $ pure "Select an example. Esc will bring you back here. Ctrl+c to quit."
60 let w' = fmap (`div`6) w
61 h' = fmap (`div`6) h
62 region1 = DynRegion w' h' w' h'
63 region2 = DynRegion (2 * w') h' w' h'
64 todo' <- pane region1 (pure True) $ textButtonStatic def "Todo List"
65 editor <- pane region2 (pure True) $ textButtonStatic def "Text Editor"
66 return $ leftmost
67 [ Left Example_TextEditor <$ editor
68 , Left Example_Todo <$ todo'
69 ]
70 escapable w = do
71 void w
72 i <- input
73 return $ fforMaybe i $ \case
74 V.EvKey V.KEsc [] -> Just $ Right ()
75 _ -> Nothing
76 rec out <- networkHold buttons $ ffor (switch (current out)) $ \case
77 Left Example_TextEditor -> escapable testBoxes
78 Left Example_Todo -> escapable taskList
79 Right () -> buttons
80 -}
81 return $ fforMaybe inp $ \case
82 V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
83 _ -> Nothing
85taskList
86 :: (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, NotReady t m, PostBuild t m)
87 => VtyWidget t m ()
88taskList = do
89 let btn = textButtonStatic def "Add another task"
90 inp <- input
91 rec let todos' = todos [Todo "Find reflex-vty" True, Todo "Become functional reactive" False, Todo "Make vty apps" False] $ leftmost
92 [ () <$ e
93 , fforMaybe inp $ \case
94 V.EvKey V.KEnter [] -> Just ()
95 _ -> Nothing
96 ]
97 (m, (e, _)) <- splitV (pure (subtract 6)) (pure (True, True)) todos' $ do
98 splitV (pure (subtract 3)) (pure (True, True)) btn (display $ current m)
99 return ()
101testBoxes :: (Reflex t, MonadHold t m, MonadFix m) => VtyWidget t m ()
102testBoxes = do
103 dw <- displayWidth
104 dh <- displayHeight
105 let region1 = DynRegion (div' dw 6) (div' dh 6) (div' dw 2) (div' dh 2)
106 region2 = DynRegion (div' dw 4) (div' dh 4) (2 * div' dw 3) (2 * div' dh 3)
107 pane region1 (constDyn False) . boxStatic singleBoxStyle $ debugInput
108 _ <- pane region2 (constDyn True) . boxStatic singleBoxStyle $
109 splitVDrag (hRule doubleBoxStyle) (boxStatic roundedBoxStyle $ multilineTextInput def) (boxStatic roundedBoxStyle dragTest)
110 return ()
112debugFocus :: (Reflex t, Monad m) => VtyWidget t m ()
113debugFocus = do
114 f <- focus
115 text $ T.pack . show <$> current f
117debugInput :: (Reflex t, MonadHold t m) => VtyWidget t m ()
118debugInput = do
119 lastEvent <- hold "No event yet" . fmap show =<< input
120 text $ T.pack <$> lastEvent
122dragTest :: (Reflex t, MonadHold t m, MonadFix m) => VtyWidget t m ()
123dragTest = do
124 lastEvent <- hold "No event yet" . fmap show =<< drag V.BLeft
125 text $ T.pack <$> lastEvent
127testStringBox :: (Reflex t, Monad m) => VtyWidget t m ()
128testStringBox = boxStatic singleBoxStyle .
129 text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z'])
131data Todo = Todo
132 { _todo_label :: Text
133 , _todo_done :: Bool
134 }
135 deriving (Show, Read, Eq, Ord)
137data TodoOutput t = TodoOutput
138 { _todoOutput_todo :: Dynamic t Todo
139 , _todoOutput_delete :: Event t ()
140 , _todoOutput_height :: Dynamic t Int
141 }
143instance Reflex t => Switchable t (TodoOutput t) where
144 switching t0 e = TodoOutput
145 <$> switching (_todoOutput_todo t0) (_todoOutput_todo <$> e)
146 <*> switching (_todoOutput_delete t0) (_todoOutput_delete <$> e)
147 <*> switching (_todoOutput_height t0) (_todoOutput_height <$> e)
149todo
150 :: (MonadHold t m, MonadFix m, Reflex t)
151 => Todo
152 -> VtyWidget t m (TodoOutput t)
153todo t0 = do
154 w <- displayWidth
155 rec let checkboxWidth = 3
156 checkboxRegion = DynRegion 0 0 checkboxWidth 1
157 labelHeight = _textInput_lines ti
158 labelWidth = w - 1 - checkboxWidth
159 labelLeft = checkboxWidth + 1
160 labelTop = constDyn 0
161 labelRegion = DynRegion labelLeft labelTop labelWidth labelHeight
162 value <- pane checkboxRegion (pure True) $ checkbox def $ _todo_done t0
163 (ti, d) <- pane labelRegion (pure True) $ do
164 i <- input
165 v <- textInput $ def { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }
166 let deleteSelf = attachWithMaybe backspaceOnEmpty (current $ _textInput_value v) i
167 return (v, deleteSelf)
168 return $ TodoOutput
169 { _todoOutput_todo = Todo <$> (_textInput_value ti) <*> value
170 , _todoOutput_delete = d
171 , _todoOutput_height = _textInput_lines ti
172 }
173 where
174 backspaceOnEmpty v = \case
175 V.EvKey V.KBS _ | T.null v -> Just ()
176 _ -> Nothing
178todos
179 :: forall t m. (MonadHold t m, MonadFix m, Reflex t, Adjustable t m, NotReady t m, PostBuild t m)
180 => [Todo]
181 -> Event t ()
182 -> VtyWidget t m (Dynamic t (Map Int Todo))
183todos todos0 newTodo = do
184 let todosMap0 = Map.fromList $ zip [0..] todos0
185 w <- displayWidth
186 rec listOut <- listHoldWithKey todosMap0 updates $ \row t -> do
187 let reg = zipDynWith (\w' ts ->
188 let l = Map.size $ Map.takeWhileAntitone (<row) ts
189 in Region 0 l w' 1) w todosMap
190 pane (DynRegion 0 (fromMaybe 0 . Map.lookup row <$> offsets) w (fromMaybe 1 . Map.lookup row <$> heights))
191 (fmap (==row) selected) $ do
192 e <- mouseUp
193 r <- todo t
194 return (row <$ e, r)
195 let heights :: Dynamic t (Map Int Int) = joinDynThroughMap $ fmap (fmap (_todoOutput_height . snd)) listOut
196 offsets :: Dynamic t (Map Int Int) = ffor heights $ \m ->
197 let l = Map.toList m
198 o = scanl (+) 0 $ map snd l
199 in Map.fromList $ zipWith (\(k, _) o' -> (k, o')) l o
200 let selectionClick = switch . current $ fmap (leftmost . Map.elems . fmap fst) listOut
201 selected <- holdDyn 0 $ leftmost
202 [ selectionClick
203 , fmapMaybe (fmap fst . Map.lookupMax) insert
204 , selectOnDelete
205 ]
206 let todosMap = joinDynThroughMap $ fmap (fmap (_todoOutput_todo . snd)) listOut
207 todoDelete = switch . current $
208 leftmost . Map.elems . Map.mapWithKey (\k -> (k <$) . _todoOutput_delete . snd) <$> listOut
209 selectOnDelete = attachWithMaybe
210 (\m k -> let (before, after) = Map.split k m
211 in fmap fst $ Map.lookupMax before <|> Map.lookupMin after)
212 (current todosMap)
213 todoDelete
214 insert = ffor (tag (current todosMap) newTodo) $ \m -> case Map.lookupMax m of
215 Nothing -> Map.singleton 0 $ Just $ Todo "" False
216 Just (k, _) -> Map.singleton (k+1) $ Just $ Todo "" False
217 delete = ffor todoDelete $ \k -> Map.singleton k Nothing
218 updates = leftmost [insert, delete]
219 return todosMap