@@ -1,6 +1,8 @@
11{-# LANGUAGE FlexibleContexts #-}
2+{-# LANGUAGE FlexibleInstances #-}
23{-# LANGUAGE GADTs #-}
34{-# LANGUAGE LambdaCase #-}
5+{-# LANGUAGE MultiParamTypeClasses #-}
46{-# LANGUAGE OverloadedStrings #-}
57{-# LANGUAGE RankNTypes #-}
68{-# LANGUAGE RecursiveDo #-}
@@ -8,18 +10,16 @@
810{-# LANGUAGE TupleSections #-}
911{-# OPTIONS_GHC -threaded #-}
1012
13+import Control.Applicative
1114import Control.Monad.Fix
12−import Data.Foldable
1315import Data.Map (Map)
1416import qualified Data.Map as Map
15−import Data.Sequence (Seq)
16−import qualified Data.Sequence as Seq
1717import Data.Text (Text)
1818import qualified Data.Text as T
1919import qualified Data.Text.Zipper as TZ
2020import qualified Graphics.Vty as V
2121import Reflex
22−import Reflex.Network
22+import Reflex.Class.Switchable
2323import Reflex.NotReady.Class
2424import Reflex.Vty
2525
@@ -30,8 +30,13 @@ main = mainWidget $ do
3030 V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
3131 _ -> Nothing
3232 let btn = button $ pure "Add another task"
33− rec let todos'' = todos' [Todo "First" True, Todo "Second" False, Todo "Third" False] $ () <$ e
34− (m, (e, _)) <- splitV (pure (subtract 6)) (pure (True, True)) todos'' $ do
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
3540 splitV (pure (subtract 3)) (pure (True, True)) btn (display $ current m)
3641 return ()
3742
@@ -64,7 +69,6 @@ testStringBox :: (Reflex t, Monad m) => VtyWidget t m ()
6469testStringBox = box singleBoxStyle .
6570 text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z'])
6671
67−
6872data Todo = Todo
6973 { _todo_label :: Text
7074 , _todo_done :: Bool
@@ -88,57 +92,52 @@ button t = do
8892 box roundedBoxStyle $ text t
8993 fmap (() <$) mouseUp
9094
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+
91105todo
92106 :: (MonadHold t m, MonadFix m, Reflex t)
93107 => Todo
94− -> VtyWidget t m (Dynamic t Todo)
108+ -> VtyWidget t m (TodoOutput t)
95109todo t0 = do
96110 w <- displayWidth
97111 let checkboxWidth = 3
98112 checkboxRegion = pure $ Region 0 0 checkboxWidth 1
99113 labelRegion = ffor w $ \w' -> Region (checkboxWidth + 1) 0 (w' - 1 - checkboxWidth) 1
100114 value <- pane checkboxRegion (pure True) $ checkbox $ _todo_done t0
101− label <- pane labelRegion (pure True) $
102− textInput $ def { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }
103− return $ Todo <$> label <*> value
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
104128
105129todos
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)
134131 => [Todo]
135132 -> Event t ()
136133 -> VtyWidget t m (Dynamic t (Map Int Todo))
137−todos' todos0 newTodo = do
134+todos todos0 newTodo = do
138135 let todosMap0 = Map.fromList $ zip [0..] todos0
139136 w <- displayWidth
140− rec listOut <- listHoldWithKey todosMap0 insert $ \row t -> do
141− let reg = fmap (\w' -> Region 0 row w' 1) w
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
142141 pane reg (fmap (==row) selected) $ do
143142 e <- mouseUp
144143 r <- todo t
@@ -146,10 +145,21 @@ todos' todos0 newTodo = do
146145 let selectionClick = switch . current $ fmap (leftmost . Map.elems . fmap fst) listOut
147146 selected <- holdDyn 0 $ leftmost
148147 [ selectionClick
149− , Map.size <$> tag (current todosMap) newTodo
148+ , fmapMaybe (fmap fst . Map.lookupMax) insert
149+ , selectOnDelete
150150 ]
151− let todosMap = joinDynThroughMap $ fmap (fmap snd) listOut
152− let insert = ffor (tagPromptlyDyn todosMap newTodo) $ \m -> case Map.lookupMax m of
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
153160 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]
155165 return todosMap