git.iko.soy/reflex-vty
on 396cddd help sign in
reflex-vty/src-bin/example.hs
184 lines 6.9 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 (void)
15import Control.Monad.Fix
16import Data.Map (Map)
17import qualified Data.Map as Map
18import Data.Text (Text)
19import qualified Data.Text as T
20import qualified Data.Text.Zipper as TZ
21import qualified Graphics.Vty as V
22import Reflex
23import Reflex.Network
24import Reflex.Class.Switchable
25import Reflex.NotReady.Class
26import Reflex.Vty
28data Example = Example_TextEditor
29 | Example_Todo
30 deriving (Show, Read, Eq, Ord, Enum, Bounded)
32main :: IO ()
33main = mainWidget $ do
34 inp <- input
35 size <- displaySize
36 tellShutdown . fforMaybe inp $ \case
37 V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
38 _ -> Nothing
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
61 return ()
63taskList
64 :: (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, NotReady t m, PostBuild t m)
65 => VtyWidget t m ()
66taskList = do
67 let btn = textButtonStatic def "Add another task"
68 inp <- input
69 rec let todos' = todos [Todo "Find reflex-vty" True, Todo "Become functional reactive" False, Todo "Make vty apps" False] $ leftmost
70 [ () <$ e
71 , fforMaybe inp $ \case
72 V.EvKey V.KEnter [] -> Just ()
73 _ -> Nothing
74 ]
75 (m, (e, _)) <- splitV (pure (subtract 6)) (pure (True, True)) todos' $ do
76 splitV (pure (subtract 3)) (pure (True, True)) btn (display $ current m)
77 return ()
79testBoxes :: (Reflex t, MonadHold t m, MonadFix m) => VtyWidget t m ()
80testBoxes = do
81 size <- displaySize
82 let region1 = fmap (\(w,h) -> Region (w `div` 6) (h `div` 6) (w `div` 2) (h `div` 2)) size
83 region2 = fmap (\(w,h) -> Region (w `div` 4) (h `div` 4) (2 * (w `div` 3)) (2*(h `div` 3))) size
84 pane region1 (constDyn False) . boxStatic singleBoxStyle $ debugInput
85 _ <- pane region2 (constDyn True) . boxStatic singleBoxStyle $
86 splitVDrag (hRule doubleBoxStyle) (boxStatic roundedBoxStyle $ multilineTextInput def) (boxStatic roundedBoxStyle dragTest)
87 return ()
89debugFocus :: (Reflex t, Monad m) => VtyWidget t m ()
90debugFocus = do
91 f <- focus
92 text $ T.pack . show <$> current f
94debugInput :: (Reflex t, MonadHold t m) => VtyWidget t m ()
95debugInput = do
96 lastEvent <- hold "No event yet" . fmap show =<< input
97 text $ T.pack <$> lastEvent
99dragTest :: (Reflex t, MonadHold t m, MonadFix m) => VtyWidget t m ()
100dragTest = do
101 lastEvent <- hold "No event yet" . fmap show =<< drag V.BLeft
102 text $ T.pack <$> lastEvent
104testStringBox :: (Reflex t, Monad m) => VtyWidget t m ()
105testStringBox = boxStatic singleBoxStyle .
106 text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z'])
108data Todo = Todo
109 { _todo_label :: Text
110 , _todo_done :: Bool
111 }
112 deriving (Show, Read, Eq, Ord)
114data TodoOutput t = TodoOutput
115 { _todoOutput_todo :: Dynamic t Todo
116 , _todoOutput_delete :: Event t ()
117 }
119instance Reflex t => Switchable t (TodoOutput t) where
120 switching t0 e = TodoOutput
121 <$> switching (_todoOutput_todo t0) (_todoOutput_todo <$> e)
122 <*> switching (_todoOutput_delete t0) (_todoOutput_delete <$> e)
124todo
125 :: (MonadHold t m, MonadFix m, Reflex t)
126 => Todo
127 -> VtyWidget t m (TodoOutput t)
128todo t0 = do
129 w <- displayWidth
130 let checkboxWidth = 3
131 checkboxRegion = pure $ Region 0 0 checkboxWidth 1
132 labelRegion = ffor w $ \w' -> Region (checkboxWidth + 1) 0 (w' - 1 - checkboxWidth) 1
133 value <- pane checkboxRegion (pure True) $ checkbox def $ _todo_done t0
134 (label, d) <- pane labelRegion (pure True) $ do
135 i <- input
136 v <- textInput $ def { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }
137 let deleteSelf = attachWithMaybe backspaceOnEmpty (current v) i
138 return (v, deleteSelf)
139 return $ TodoOutput
140 { _todoOutput_todo = Todo <$> label <*> value
141 , _todoOutput_delete = d
142 }
143 where
144 backspaceOnEmpty v = \case
145 V.EvKey V.KBS _ | T.null v -> Just ()
146 _ -> Nothing
148todos
149 :: forall t m. (MonadHold t m, MonadFix m, Reflex t, Adjustable t m, NotReady t m, PostBuild t m)
150 => [Todo]
151 -> Event t ()
152 -> VtyWidget t m (Dynamic t (Map Int Todo))
153todos todos0 newTodo = do
154 let todosMap0 = Map.fromList $ zip [0..] todos0
155 w <- displayWidth
156 rec listOut <- listHoldWithKey todosMap0 updates $ \row t -> do
157 let reg = zipDynWith (\w' ts ->
158 let l = Map.size $ Map.takeWhileAntitone (<row) ts
159 in Region 0 l w' 1) w todosMap
160 pane reg (fmap (==row) selected) $ do
161 e <- mouseUp
162 r <- todo t
163 return (row <$ e, r)
164 let selectionClick = switch . current $ fmap (leftmost . Map.elems . fmap fst) listOut
165 selected <- holdDyn 0 $ leftmost
166 [ selectionClick
167 , fmapMaybe (fmap fst . Map.lookupMax) insert
168 , selectOnDelete
169 ]
170 let todosMap = joinDynThroughMap $ fmap (fmap (_todoOutput_todo . snd)) listOut
171 todoDelete = switch . current $
172 leftmost . Map.elems . Map.mapWithKey (\k -> (k <$) . _todoOutput_delete . snd) <$> listOut
173 selectOnDelete = attachWithMaybe
174 (\m k -> let (before, after) = Map.split k m
175 in fmap fst $ Map.lookupMax before <|> Map.lookupMin after)
176 (current todosMap)
177 todoDelete
178 insert = ffor (tag (current todosMap) newTodo) $ \m -> case Map.lookupMax m of
179 Nothing -> Map.singleton 0 $ Just $ Todo "" False
180 Just (k, _) -> Map.union (Just <$> m) $ Map.singleton (k+1) $ Just $ Todo "" False
181 delete = ffor (attach (current todosMap) todoDelete) $ \(m, k) ->
182 Map.union (Map.singleton k Nothing) $ Just <$> m
183 updates = leftmost [insert, delete]
184 return todosMap