@@ -7,6 +7,7 @@
7{-# LANGUAGE RankNTypes #-}
7{-# LANGUAGE RankNTypes #-}
8{-# LANGUAGE RecursiveDo #-}
8{-# LANGUAGE RecursiveDo #-}
9{-# LANGUAGE ScopedTypeVariables #-}
9{-# LANGUAGE ScopedTypeVariables #-}
10+{-# LANGUAGE ConstraintKinds #-}
10{-# OPTIONS_GHC -threaded #-}
11{-# OPTIONS_GHC -threaded #-}
12import Control.Applicative
13import Control.Applicative
@@ -15,17 +16,28 @@ import Control.Monad.Fix
15import Control.Monad.NodeId
16import Control.Monad.NodeId
16import Data.Functor.Misc
17import Data.Functor.Misc
17import Data.Map (Map)
18import Data.Map (Map)
19import qualified Data.Map as Map
19import qualified Data.Map as Map
20import Data.Text (Text)
21import Data.Text (Text)
21import qualified Data.Text as T
22import qualified Data.Text as T
22import qualified Data.Text.Zipper as TZ
23import qualified Data.Text.Zipper as TZ
23import qualified Graphics.Vty as V
24import qualified Graphics.Vty as V
24import Reflex
25import Reflex
26import Reflex.Class.Switchable
26import Reflex.Class.Switchable
27import Reflex.Vty
28import Reflex.Vty
34+ , HasVtyWidgetCtx t m
29data Example = Example_TextEditor
41data Example = Example_TextEditor
30 | Example_Todo
42 | Example_Todo
31 | Example_ScrollableTextDisplay
43 | Example_ScrollableTextDisplay
@@ -34,34 +46,40 @@ data Example = Example_TextEditor
34main :: IO ()
46main :: IO ()
35main = mainWidget $ do
47main = mainWidget $ do
36 inp <- input
48 inp <- input
51+ let gf = grout . fixed
37− let buttons = col $ do
53+ buttons = col $ do
38− fixed 4 $ col $ do
54+ gf 4 $ col $ do
39− fixed 1 $ text "Select an example."
55+ gf 1 $ text "Select an example."
40− fixed 1 $ text "Esc will bring you back here."
56+ gf 1 $ text "Esc will bring you back here."
41− fixed 1 $ text "Ctrl+c to quit."
57+ gf 1 $ text "Ctrl+c to quit."
42− a <- fixed 5 $ textButtonStatic def "Todo List"
58+ a <- tf 5 $ textButtonStatic def "Todo List"
43− b <- fixed 5 $ textButtonStatic def "Text Editor"
59+ b <- tf 5 $ textButtonStatic def "Text Editor"
44− c <- fixed 5 $ textButtonStatic def "Scrollable text display"
60+ c <- tf 5 $ textButtonStatic def "Scrollable text display"
45− return $ leftmost
61+ return $ leftmost
46− [ Left Example_Todo <$ a
62+ [ Left Example_Todo <$ a
47− , Left Example_TextEditor <$ b
63+ , Left Example_TextEditor <$ b
48− , Left Example_ScrollableTextDisplay <$ c
64+ , Left Example_ScrollableTextDisplay <$ c
50− escapable w = do
66+ let escapable w = do
52− i <- input
68+ i <- input
53− return $ fforMaybe i $ \case
69+ return $ fforMaybe i $ \case
54− V.EvKey V.KEsc [] -> Just $ Right ()
70+ V.EvKey V.KEsc [] -> Just $ Right ()
55− _ -> Nothing
71+ _ -> Nothing
56− rec out <- networkHold buttons $ ffor (switch (current out)) $ \case
72+ rec out <- networkHold buttons $ ffor (switch (current out)) $ \case
73+ Left Example_Todo -> escapable blank -- taskList
57− Left Example_TextEditor -> escapable testBoxes
74+ Left Example_TextEditor -> escapable testBoxes
58− Left Example_Todo -> escapable taskList
75+ Left Example_ScrollableTextDisplay -> escapable blank -- scrolling
59− Left Example_ScrollableTextDisplay -> escapable scrolling
60− Right () -> buttons
76+ Right () -> buttons
61 return $ fforMaybe inp $ \case
78 return $ fforMaybe inp $ \case
62 V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
79 V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
63 _ -> Nothing
80 _ -> Nothing
66 :: (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, NotReady t m, PostBuild t m, MonadNodeId m)
84 :: (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, NotReady t m, PostBuild t m, MonadNodeId m)
67 => VtyWidget t m ()
85 => VtyWidget t m ()
@@ -82,15 +100,17 @@ taskList = do
82 (m, (e, _)) <- splitV (pure (subtract 6)) (pure (True, True)) todos' $
100 (m, (e, _)) <- splitV (pure (subtract 6)) (pure (True, True)) todos' $
83 splitV (pure (subtract 3)) (pure (True, True)) btn (display $ Map.size <$> current m)
101 splitV (pure (subtract 3)) (pure (True, True)) btn (display $ Map.size <$> current m)
84 return ()
102 return ()
87− :: (Reflex t, MonadHold t m, MonadFix m, MonadNodeId m)
107+ :: (MonadHold t m, MonadNodeId m, VtyExample t m)
88− => VtyWidget t m ()
108+ => m ()
89testBoxes = do
109testBoxes = do
90 dw <- displayWidth
110 dw <- displayWidth
91 dh <- displayHeight
111 dh <- displayHeight
92− let region1 = DynRegion (div' dw 6) (div' dh 6) (div' dw 2) (div' dh 2)
112+ let region1 = Region <$> (div' dw 6) <*> (div' dh 6) <*> (div' dw 2) <*> (div' dh 2)
93− region2 = DynRegion (div' dw 4) (div' dh 4) (2 * div' dw 3) (2 * div' dh 3)
113+ region2 = Region <$> (div' dw 4) <*> (div' dh 4) <*> (2 * div' dw 3) <*> (2 * div' dh 3)
94 pane region1 (constDyn False) . boxStatic singleBoxStyle $ debugInput
114 pane region1 (constDyn False) . boxStatic singleBoxStyle $ debugInput
95 _ <- pane region2 (constDyn True) . boxStatic singleBoxStyle $
115 _ <- pane region2 (constDyn True) . boxStatic singleBoxStyle $
96 let cfg = def
116 let cfg = def
@@ -106,25 +126,26 @@ testBoxes = do
106 div' :: (Integral a, Applicative f) => f a -> f a -> f a
126 div' :: (Integral a, Applicative f) => f a -> f a -> f a
107 div' = liftA2 div
127 div' = liftA2 div
109−debugFocus :: (Reflex t, Monad m) => VtyWidget t m ()
129+debugFocus :: (VtyExample t m) => m ()
110debugFocus = do
130debugFocus = do
111 f <- focus
131 f <- focus
112 text $ T.pack . show <$> current f
132 text $ T.pack . show <$> current f
114−debugInput :: (Reflex t, MonadHold t m) => VtyWidget t m ()
134+debugInput :: (VtyExample t m, MonadHold t m) => m ()
115debugInput = do
135debugInput = do
116 lastEvent <- hold "No event yet" . fmap show =<< input
136 lastEvent <- hold "No event yet" . fmap show =<< input
117 text $ T.pack <$> lastEvent
137 text $ T.pack <$> lastEvent
119−dragTest :: (Reflex t, MonadHold t m, MonadFix m) => VtyWidget t m ()
139+dragTest :: (VtyExample t m, MonadHold t m) => m ()
120dragTest = do
140dragTest = do
121 lastEvent <- hold "No event yet" . fmap show =<< drag V.BLeft
141 lastEvent <- hold "No event yet" . fmap show =<< drag V.BLeft
122 text $ T.pack <$> lastEvent
142 text $ T.pack <$> lastEvent
124−testStringBox :: (Reflex t, Monad m, MonadNodeId m) => VtyWidget t m ()
144+testStringBox :: VtyExample t m => m ()
125testStringBox = boxStatic singleBoxStyle .
145testStringBox = boxStatic singleBoxStyle .
126 text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z'])
146 text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z'])
128data Todo = Todo
149data Todo = Todo
129 { _todo_label :: Text
150 { _todo_label :: Text
130 , _todo_done :: Bool
151 , _todo_done :: Bool
@@ -219,3 +240,4 @@ todos todos0 newTodo = do
219 (current todosMap)
240 (current todosMap)
220 todoDelete
241 todoDelete
221 return listOut
242 return listOut