git.iko.soy/reflex-vty
on a239ebf help sign in
reflex-vty/src-bin/example.hs
165 lines 6.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.Class.Switchable
23import Reflex.NotReady.Class
24import Reflex.Vty
26main :: IO ()
27main = mainWidget $ do
28 inp <- input
29 tellShutdown . fforMaybe inp $ \case
30 V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
31 _ -> Nothing
32 let btn = button $ pure "Add another task"
33 rec let todos' = todos [Todo "First" True, Todo "Second" False, Todo "Third" False] $ leftmost
34 [ () <$ e
35 , fforMaybe inp $ \case
36 V.EvKey V.KEnter [] -> Just ()
37 _ -> Nothing
38 ]
39 (m, (e, _)) <- splitV (pure (subtract 6)) (pure (True, True)) todos' $ do
40 splitV (pure (subtract 3)) (pure (True, True)) btn (display $ current m)
41 return ()
43testBoxes :: (Reflex t, MonadHold t m, MonadFix m) => VtyWidget t m ()
44testBoxes = do
45 size <- displaySize
46 let region1 = fmap (\(w,h) -> Region (w `div` 6) (h `div` 6) (w `div` 2) (h `div` 2)) size
47 region2 = fmap (\(w,h) -> Region (w `div` 4) (h `div` 4) (2 * (w `div` 3)) (2*(h `div` 3))) size
48 pane region1 (constDyn False) . box singleBoxStyle $ debugInput
49 _ <- pane region2 (constDyn True) . box singleBoxStyle $
50 splitVDrag (hRule doubleBoxStyle) (box roundedBoxStyle $ multilineTextInput def) (box roundedBoxStyle dragTest)
51 return ()
53debugFocus :: (Reflex t, Monad m) => VtyWidget t m ()
54debugFocus = do
55 f <- focus
56 text $ T.pack . show <$> current f
58debugInput :: (Reflex t, MonadHold t m) => VtyWidget t m ()
59debugInput = do
60 lastEvent <- hold "No event yet" . fmap show =<< input
61 text $ T.pack <$> lastEvent
63dragTest :: (Reflex t, MonadHold t m, MonadFix m) => VtyWidget t m ()
64dragTest = do
65 lastEvent <- hold "No event yet" . fmap show =<< drag V.BLeft
66 text $ T.pack <$> lastEvent
68testStringBox :: (Reflex t, Monad m) => VtyWidget t m ()
69testStringBox = box singleBoxStyle .
70 text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z'])
72data Todo = Todo
73 { _todo_label :: Text
74 , _todo_done :: Bool
75 }
76 deriving (Show, Read, Eq, Ord)
78checkbox
79 :: (MonadHold t m, MonadFix m, Reflex t)
80 => Bool
81 -> VtyWidget t m (Dynamic t Bool)
82checkbox v0 = do
83 i <- input
84 v <- toggle v0 $ fforMaybe i $ \case
85 V.EvMouseUp _ _ _ -> Just ()
86 _ -> Nothing
87 text $ current $ ffor v $ \v' -> if v' then "[x]" else "[ ]"
88 return v
90button :: (Reflex t, Monad m) => Behavior t Text -> VtyWidget t m (Event t ())
91button t = do
92 box roundedBoxStyle $ text t
93 fmap (() <$) mouseUp
95data TodoOutput t = TodoOutput
96 { _todoOutput_todo :: Dynamic t Todo
97 , _todoOutput_delete :: Event t ()
98 }
100instance Reflex t => Switchable t (TodoOutput t) where
101 switching t0 e = TodoOutput
102 <$> switching (_todoOutput_todo t0) (_todoOutput_todo <$> e)
103 <*> switching (_todoOutput_delete t0) (_todoOutput_delete <$> e)
105todo
106 :: (MonadHold t m, MonadFix m, Reflex t)
107 => Todo
108 -> VtyWidget t m (TodoOutput t)
109todo t0 = do
110 w <- displayWidth
111 let checkboxWidth = 3
112 checkboxRegion = pure $ Region 0 0 checkboxWidth 1
113 labelRegion = ffor w $ \w' -> Region (checkboxWidth + 1) 0 (w' - 1 - checkboxWidth) 1
114 value <- pane checkboxRegion (pure True) $ checkbox $ _todo_done t0
115 (label, d) <- pane labelRegion (pure True) $ do
116 i <- input
117 v <- textInput $ def { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }
118 let deleteSelf = attachWithMaybe backspaceOnEmpty (current v) i
119 return (v, deleteSelf)
120 return $ TodoOutput
121 { _todoOutput_todo = Todo <$> label <*> value
122 , _todoOutput_delete = d
123 }
124 where
125 backspaceOnEmpty v = \case
126 V.EvKey V.KBS _ | T.null v -> Just ()
127 _ -> Nothing
129todos
130 :: forall t m. (MonadHold t m, MonadFix m, Reflex t, Adjustable t m, NotReady t m, PostBuild t m)
131 => [Todo]
132 -> Event t ()
133 -> VtyWidget t m (Dynamic t (Map Int Todo))
134todos todos0 newTodo = do
135 let todosMap0 = Map.fromList $ zip [0..] todos0
136 w <- displayWidth
137 rec listOut <- listHoldWithKey todosMap0 updates $ \row t -> do
138 let reg = zipDynWith (\w' ts ->
139 let l = Map.size $ Map.takeWhileAntitone (<row) ts
140 in Region 0 l w' 1) w todosMap
141 pane reg (fmap (==row) selected) $ do
142 e <- mouseUp
143 r <- todo t
144 return (row <$ e, r)
145 let selectionClick = switch . current $ fmap (leftmost . Map.elems . fmap fst) listOut
146 selected <- holdDyn 0 $ leftmost
147 [ selectionClick
148 , fmapMaybe (fmap fst . Map.lookupMax) insert
149 , selectOnDelete
150 ]
151 let todosMap = joinDynThroughMap $ fmap (fmap (_todoOutput_todo . snd)) listOut
152 todoDelete = switch . current $
153 leftmost . Map.elems . Map.mapWithKey (\k -> (k <$) . _todoOutput_delete . snd) <$> listOut
154 selectOnDelete = attachWithMaybe
155 (\m k -> let (before, after) = Map.split k m
156 in fmap fst $ Map.lookupMax before <|> Map.lookupMin after)
157 (current todosMap)
158 todoDelete
159 insert = ffor (tag (current todosMap) newTodo) $ \m -> case Map.lookupMax m of
160 Nothing -> Map.singleton 0 $ Just $ Todo "" False
161 Just (k, _) -> Map.union (Just <$> m) $ Map.singleton (k+1) $ Just $ Todo "" False
162 delete = ffor (attach (current todosMap) todoDelete) $ \(m, k) ->
163 Map.union (Map.singleton k Nothing) $ Just <$> m
164 updates = leftmost [insert, delete]
165 return todosMap