git.iko.soy/reflex-vty
on develop help sign in
Todo example: Add and delete elements
a239ebfAli Abrar
src-bin/example.hs+56−46
compare with develop
unifiedsplit
@@ -1,6 +1,8 @@
1{-# LANGUAGE FlexibleContexts #-}
1{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE FlexibleInstances #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE GADTs #-}
3{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE LambdaCase #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE OverloadedStrings #-}
6{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE RankNTypes #-}
7{-# LANGUAGE RankNTypes #-}
6{-# LANGUAGE RecursiveDo #-}
8{-# LANGUAGE RecursiveDo #-}
@@ -8,18 +10,16 @@
8{-# LANGUAGE TupleSections #-}
10{-# LANGUAGE TupleSections #-}
9{-# OPTIONS_GHC -threaded #-}
11{-# OPTIONS_GHC -threaded #-}
10
12
13+import Control.Applicative
11import Control.Monad.Fix
14import Control.Monad.Fix
12−import Data.Foldable
13import Data.Map (Map)
15import Data.Map (Map)
14import qualified Data.Map as Map
16import qualified Data.Map as Map
15−import Data.Sequence (Seq)
16−import qualified Data.Sequence as Seq
17import Data.Text (Text)
17import Data.Text (Text)
18import qualified Data.Text as T
18import qualified Data.Text as T
19import qualified Data.Text.Zipper as TZ
19import qualified Data.Text.Zipper as TZ
20import qualified Graphics.Vty as V
20import qualified Graphics.Vty as V
21import Reflex
21import Reflex
22−import Reflex.Network
22+import Reflex.Class.Switchable
23import Reflex.NotReady.Class
23import Reflex.NotReady.Class
24import Reflex.Vty
24import Reflex.Vty
25
25
@@ -30,8 +30,13 @@ main = mainWidget $ do
30 V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
30 V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
31 _ -> Nothing
31 _ -> Nothing
32 let btn = button $ pure "Add another task"
32 let btn = button $ pure "Add another task"
33− rec let todos'' = todos' [Todo "First" True, Todo "Second" False, Todo "Third" False] $ () <$ e
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+ ]
34− (m, (e, _)) <- splitV (pure (subtract 6)) (pure (True, True)) todos'' $ do
39+ (m, (e, _)) <- splitV (pure (subtract 6)) (pure (True, True)) todos' $ do
35 splitV (pure (subtract 3)) (pure (True, True)) btn (display $ current m)
40 splitV (pure (subtract 3)) (pure (True, True)) btn (display $ current m)
36 return ()
41 return ()
37
42
@@ -64,7 +69,6 @@ testStringBox :: (Reflex t, Monad m) => VtyWidget t m ()
64testStringBox = box singleBoxStyle .
69testStringBox = box singleBoxStyle .
65 text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z'])
70 text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z'])
66
71
67−
68data Todo = Todo
72data Todo = Todo
69 { _todo_label :: Text
73 { _todo_label :: Text
70 , _todo_done :: Bool
74 , _todo_done :: Bool
@@ -88,57 +92,52 @@ button t = do
88 box roundedBoxStyle $ text t
92 box roundedBoxStyle $ text t
89 fmap (() <$) mouseUp
93 fmap (() <$) mouseUp
90
94
95+data TodoOutput t = TodoOutput
96+ { _todoOutput_todo :: Dynamic t Todo
97+ , _todoOutput_delete :: Event t ()
98+ }
99+
100+instance 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)
104+
91todo
105todo
92 :: (MonadHold t m, MonadFix m, Reflex t)
106 :: (MonadHold t m, MonadFix m, Reflex t)
93 => Todo
107 => Todo
94− -> VtyWidget t m (Dynamic t Todo)
108+ -> VtyWidget t m (TodoOutput t)
95todo t0 = do
109todo t0 = do
96 w <- displayWidth
110 w <- displayWidth
97 let checkboxWidth = 3
111 let checkboxWidth = 3
98 checkboxRegion = pure $ Region 0 0 checkboxWidth 1
112 checkboxRegion = pure $ Region 0 0 checkboxWidth 1
99 labelRegion = ffor w $ \w' -> Region (checkboxWidth + 1) 0 (w' - 1 - checkboxWidth) 1
113 labelRegion = ffor w $ \w' -> Region (checkboxWidth + 1) 0 (w' - 1 - checkboxWidth) 1
100 value <- pane checkboxRegion (pure True) $ checkbox $ _todo_done t0
114 value <- pane checkboxRegion (pure True) $ checkbox $ _todo_done t0
101− label <- pane labelRegion (pure True) $
115+ (label, d) <- pane labelRegion (pure True) $ do
116+ i <- input
102− textInput $ def { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }
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
103− return $ Todo <$> label <*> value
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
104
128
105todos
129todos
106− :: (MonadHold t m, MonadFix m, Reflex t, Adjustable t m, NotReady t m, PostBuild t m)
107− => [Todo]
108− -> Event t ()
109− -> VtyWidget t m (Dynamic t (Seq Todo))
110−todos todos0 newTodo = do
111− rec todos <- foldDyn ($) (Seq.fromList todos0) $ leftmost
112− [ (\ts -> ts Seq.|> Todo "" False) <$ newTodo
113− , (\(ix, t) -> Seq.update ix t) <$> updates
114− ]
115− w <- displayWidth
116− listOut <- networkView $ ffor todos $ \ts' ->
117− flip Seq.traverseWithIndex ts' $ \row t -> do
118− let reg = fmap (\w' -> Region 0 row w' 1) w
119− pane reg (fmap (==row) selected) $ do
120− e <- mouseUp
121− r <- todo t
122− return (row <$ e, (row,) <$> updated r)
123− selectionClick <- switchHold never $
124− fmap (leftmost . toList . fmap fst) listOut
125− selected <- holdDyn 0 $ leftmost
126− [ selectionClick
127− , Seq.length <$> tag (current todos) newTodo
128− ]
129− updates <- switchHold never $ fmap (leftmost . toList . fmap snd) listOut
130− return todos
131−
132−todos'
133− :: (MonadHold t m, MonadFix m, Reflex t, Adjustable t m, NotReady t m, PostBuild t m)
130+ :: forall t m. (MonadHold t m, MonadFix m, Reflex t, Adjustable t m, NotReady t m, PostBuild t m)
134 => [Todo]
131 => [Todo]
135 -> Event t ()
132 -> Event t ()
136 -> VtyWidget t m (Dynamic t (Map Int Todo))
133 -> VtyWidget t m (Dynamic t (Map Int Todo))
137−todos' todos0 newTodo = do
134+todos todos0 newTodo = do
138 let todosMap0 = Map.fromList $ zip [0..] todos0
135 let todosMap0 = Map.fromList $ zip [0..] todos0
139 w <- displayWidth
136 w <- displayWidth
140− rec listOut <- listHoldWithKey todosMap0 insert $ \row t -> do
137+ rec listOut <- listHoldWithKey todosMap0 updates $ \row t -> do
138+ let reg = zipDynWith (\w' ts ->
139+ let l = Map.size $ Map.takeWhileAntitone (<row) ts
141− let reg = fmap (\w' -> Region 0 row w' 1) w
140+ in Region 0 l w' 1) w todosMap
142 pane reg (fmap (==row) selected) $ do
141 pane reg (fmap (==row) selected) $ do
143 e <- mouseUp
142 e <- mouseUp
144 r <- todo t
143 r <- todo t
@@ -146,10 +145,21 @@ todos' todos0 newTodo = do
146 let selectionClick = switch . current $ fmap (leftmost . Map.elems . fmap fst) listOut
145 let selectionClick = switch . current $ fmap (leftmost . Map.elems . fmap fst) listOut
147 selected <- holdDyn 0 $ leftmost
146 selected <- holdDyn 0 $ leftmost
148 [ selectionClick
147 [ selectionClick
149− , Map.size <$> tag (current todosMap) newTodo
148+ , fmapMaybe (fmap fst . Map.lookupMax) insert
149+ , selectOnDelete
150 ]
150 ]
151− let todosMap = joinDynThroughMap $ fmap (fmap snd) listOut
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
152− let insert = ffor (tagPromptlyDyn todosMap newTodo) $ \m -> case Map.lookupMax m of
159+ insert = ffor (tag (current todosMap) newTodo) $ \m -> case Map.lookupMax m of
153 Nothing -> Map.singleton 0 $ Just $ Todo "" False
160 Nothing -> Map.singleton 0 $ Just $ Todo "" False
154− Just (k, _) -> {- Map.union (Just <$> m) $ -} Map.singleton (k+1) $ 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]
155 return todosMap
165 return todosMap