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