git.iko.soy/reflex-vty
on 4e197f2 help sign in
reflex-vty/src-bin/example.hs
127 lines 4.2 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE GADTs #-}
3{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE RankNTypes #-}
6{-# LANGUAGE RecursiveDo #-}
7{-# LANGUAGE ScopedTypeVariables #-}
8{-# LANGUAGE TupleSections #-}
9{-# OPTIONS_GHC -threaded #-}
11import Control.Monad.Fix
12import Data.Foldable
13import Data.Sequence (Seq)
14import qualified Data.Sequence as Seq
15import Data.Text (Text)
16import qualified Data.Text as T
17import qualified Data.Text.Zipper as TZ
18import qualified Graphics.Vty as V
19import Reflex
20import Reflex.Network
21import Reflex.NotReady.Class
22import Reflex.Vty
24main :: IO ()
25main = mainWidget $ do
26 inp <- input
27 tellShutdown . fforMaybe inp $ \case
28 V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()
29 _ -> Nothing
30 rec let todos' = todos [] $ () <$ e
31 btn = button $ pure "Add another task"
32 (_, e) <- splitV (pure (subtract 3)) (pure (True, True)) todos' btn
33 return ()
35testBoxes :: (Reflex t, MonadHold t m, MonadFix m) => VtyWidget t m ()
36testBoxes = do
37 size <- displaySize
38 let region1 = fmap (\(w,h) -> Region (w `div` 6) (h `div` 6) (w `div` 2) (h `div` 2)) size
39 region2 = fmap (\(w,h) -> Region (w `div` 4) (h `div` 4) (2 * (w `div` 3)) (2*(h `div` 3))) size
40 pane region1 (constDyn False) . box singleBoxStyle $ debugInput
41 _ <- pane region2 (constDyn True) . box singleBoxStyle $
42 splitVDrag (hRule doubleBoxStyle) (box roundedBoxStyle $ multilineTextInput def) (box roundedBoxStyle dragTest)
43 return ()
45debugFocus :: (Reflex t, Monad m) => VtyWidget t m ()
46debugFocus = do
47 f <- focus
48 text $ T.pack . show <$> current f
50debugInput :: (Reflex t, MonadHold t m) => VtyWidget t m ()
51debugInput = do
52 lastEvent <- hold "No event yet" . fmap show =<< input
53 text $ T.pack <$> lastEvent
55dragTest :: (Reflex t, MonadHold t m, MonadFix m) => VtyWidget t m ()
56dragTest = do
57 lastEvent <- hold "No event yet" . fmap show =<< drag V.BLeft
58 text $ T.pack <$> lastEvent
60testStringBox :: (Reflex t, Monad m) => VtyWidget t m ()
61testStringBox = box singleBoxStyle .
62 text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z'])
65data Todo = Todo
66 { _todo_label :: Text
67 , _todo_done :: Bool
68 }
69 deriving (Show, Read, Eq, Ord)
71checkbox
72 :: (MonadHold t m, MonadFix m, Reflex t)
73 => Bool
74 -> VtyWidget t m (Dynamic t Bool)
75checkbox v0 = do
76 i <- input
77 v <- toggle v0 $ fforMaybe i $ \case
78 V.EvMouseUp _ _ _ -> Just ()
79 _ -> Nothing
80 text $ current $ ffor v $ \v' -> if v' then "[x]" else "[ ]"
81 return v
83button :: (Reflex t, Monad m) => Behavior t Text -> VtyWidget t m (Event t ())
84button t = do
85 box roundedBoxStyle $ text t
86 fmap (() <$) mouseUp
88todo
89 :: (MonadHold t m, MonadFix m, Reflex t)
90 => Todo
91 -> VtyWidget t m (Dynamic t Todo)
92todo t0 = do
93 w <- displayWidth
94 let checkboxWidth = 3
95 checkboxRegion = pure $ Region 0 0 checkboxWidth 1
96 labelRegion = ffor w $ \w' -> Region (checkboxWidth + 1) 0 (w' - 1 - checkboxWidth) 1
97 value <- pane checkboxRegion (pure True) $ checkbox $ _todo_done t0
98 label <- pane labelRegion (pure True) $
99 textInput $ def { _textInputConfig_initialValue = TZ.fromText $ _todo_label t0 }
100 return $ Todo <$> label <*> value
102todos
103 :: (MonadHold t m, MonadFix m, Reflex t, Adjustable t m, NotReady t m, PostBuild t m)
104 => [Todo]
105 -> Event t ()
106 -> VtyWidget t m (Dynamic t (Seq Todo))
107todos todos0 newTodo = do
108 rec todos <- foldDyn ($) (Seq.fromList todos0) $ leftmost
109 [ (\ts -> ts Seq.|> Todo "" False) <$ newTodo
110 , (\(ix, t) -> Seq.update ix t) <$> updates
111 ]
112 w <- displayWidth
113 listOut <- networkView $ ffor todos $ \ts' ->
114 flip Seq.traverseWithIndex ts' $ \row t -> do
115 let reg = fmap (\w' -> Region 0 row w' 1) w
116 pane reg (fmap (==row) selected) $ do
117 e <- mouseUp
118 r <- todo t
119 return (row <$ e, (row,) <$> updated r)
120 selectionClick <- switchHold never $
121 fmap (leftmost . toList . fmap fst) listOut
122 selected <- holdDyn 0 $ leftmost
123 [ selectionClick
124 , Seq.length <$> tag (current todos) newTodo
125 ]
126 updates <- switchHold never $ fmap (leftmost . toList . fmap snd) listOut
127 return todos