4e197f2 · reflex-vty · git.iko.soy

git.iko.soy/reflex-vty

Adjustable instance for VtyWidget, and various supporting bits; Start of todo example

commit4e197f2d60a5cf434296f3d0f68d8e0999123384 authorAli Abrar <aliabrar@gmail.com> dateSun 4 Nov 2018, 20:56 (8 years ago) parentd589d9e

9 files changed+219−17

compare with develop

unifiedsplit

reflex-vty.cabal+6−1 src-bin/example.hs+83−10 src/Control/Monad/Writer/Adjustable.hs+35 src/Reflex/Class/Switchable.hs+30 src/Reflex/NotReady/Class/Orphans.hs+17 src/Reflex/Spider/Orphans.hs+4 src/Reflex/Vty.hs−4 src/Reflex/Vty/Host.hs+1 src/Reflex/Vty/Widget.hs+43−2

reflex-vty.cabal+6−1

@@ -17,11 +17,15 @@ library

1717 , Reflex.Vty.Widget.Input

1818 , Reflex.Vty.Widget.Input.Text

1919 , Data.Text.Zipper

20− other-modules: Reflex.Spider.Orphans

20+ , Control.Monad.Writer.Adjustable

21+ , Reflex.Class.Switchable

22+ , Reflex.NotReady.Class.Orphans

23+ , Reflex.Spider.Orphans

2124 build-depends:

2225 base,

2326 containers,

2427 data-default,

28+ dependent-map,

2529 dependent-sum,

2630 mtl,

2731 primitive,

@@ -41,6 +45,7 @@ executable example

4145 ghc-options: -threaded

4246 build-depends:

4347 base,

48+ containers,

4449 reflex,

4550 reflex-vty,

4651 text,

src-bin/example.hs+83−10

@@ -3,26 +3,34 @@

33{-# LANGUAGE LambdaCase #-}

44{-# LANGUAGE OverloadedStrings #-}

55{-# LANGUAGE RankNTypes #-}

6+{-# LANGUAGE RecursiveDo #-}

67{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE TupleSections #-}

79{-# OPTIONS_GHC -threaded #-}

810

911import Control.Monad.Fix

12+import Data.Foldable

13+import Data.Sequence (Seq)

14+import qualified Data.Sequence as Seq

15+import Data.Text (Text)

1016import qualified Data.Text as T

17+import qualified Data.Text.Zipper as TZ

1118import qualified Graphics.Vty as V

1219import Reflex

20+import Reflex.Network

21+import Reflex.NotReady.Class

1322import Reflex.Vty

1423

1524main :: IO ()

16−main =

17− mainWidget $ do

18− inp <- input

19− tellShutdown . fforMaybe inp $ \case

20− V.EvKey V.KEsc _ -> Just ()

21− _ -> Nothing

22−

23− debugInput

24− testBoxes

25− return ()

25+main = 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 ()

2634

2735testBoxes :: (Reflex t, MonadHold t m, MonadFix m) => VtyWidget t m ()

2836testBoxes = do

@@ -52,3 +60,68 @@ dragTest = do

5260testStringBox :: (Reflex t, Monad m) => VtyWidget t m ()

5361testStringBox = box singleBoxStyle .

5462 text . pure . T.pack . take 500 $ cycle ('\n' : ['a'..'z'])

63+

64+

65+data Todo = Todo

66+ { _todo_label :: Text

67+ , _todo_done :: Bool

68+ }

69+ deriving (Show, Read, Eq, Ord)

70+

71+checkbox

72+ :: (MonadHold t m, MonadFix m, Reflex t)

73+ => Bool

74+ -> VtyWidget t m (Dynamic t Bool)

75+checkbox 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

82+

83+button :: (Reflex t, Monad m) => Behavior t Text -> VtyWidget t m (Event t ())

84+button t = do

85+ box roundedBoxStyle $ text t

86+ fmap (() <$) mouseUp

87+

88+todo

89+ :: (MonadHold t m, MonadFix m, Reflex t)

90+ => Todo

91+ -> VtyWidget t m (Dynamic t Todo)

92+todo 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

101+

102+todos

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))

107+todos 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

src/Control/Monad/Writer/Adjustable.hsnew file+35

@@ -0,0 +1,35 @@

1+{-|

2+Module: Control.Monad.Writer.Adjustable

3+Description: An Adjustable instance for WriterT

4+-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE UndecidableInstances #-}

9+{-# OPTIONS_GHC -fno-warn-orphans #-} -- TODO find a better home for this

10+module Control.Monad.Writer.Adjustable where

11+

12+import Control.Monad.Trans

13+import Control.Monad.Trans.Writer

14+import qualified Data.Dependent.Map as DMap

15+import Data.Foldable (fold)

16+import Data.Functor.Compose

17+import Reflex

18+import Reflex.Patch.DMapWithMove

19+import Reflex.Class.Switchable

20+

21+instance (Adjustable t m, MonadHold t m, Switchable t w, Monoid w) => Adjustable t (WriterT w m) where

22+ runWithReplace a0 a' = do

23+ (w, r) <- lift $ runWithReplace (runWriterT a0) $ fmap (runWriterT) a'

24+ tell =<< switching (snd w) (snd <$> r)

25+ return $ (fst w, fst <$> r)

26+ traverseIntMapWithKeyWithAdjust f dm0 dm' = do

27+ (w, r) <- lift $ traverseIntMapWithKeyWithAdjust (\k v -> runWriterT (f k v)) dm0 dm'

28+ tell =<< switching (fold $ fmap snd w) (fmap (mconcat . patchIntMapNewElements . fmap snd) r)

29+ return (fmap fst w, fmap (fmap fst) r)

30+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do

31+ (w, r) <- lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> fmap (\(x, w') -> Compose (w', x)) $ runWriterT (f k v)) dm0 dm'

32+ let w' = runWriter $ DMap.traverseWithKey (\_ (Compose (w'', x)) -> tell w'' >> return x) w

33+ r' = fmap (runWriter . traversePatchDMapWithMove (\(Compose (w'', x)) -> tell w'' >> return x)) r

34+ tell =<< switching (snd w') (fmap snd r')

35+ return (fst w', fmap fst r')

src/Reflex/Class/Switchable.hsnew file+30

@@ -0,0 +1,30 @@

1+{-|

2+Module: Reflex.Class.Switchable

3+Description: A class for things that can be switched on the firing of an event

4+-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE FunctionalDependencies #-}

7+{-# LANGUAGE MultiParamTypeClasses #-}

8+{-# LANGUAGE UndecidableInstances #-}

9+module Reflex.Class.Switchable where

10+

11+import Control.Monad

12+import Reflex

13+

14+-- | Class representing things that can be switched when the provided event occurs

15+class Reflex t => Switchable t w | w -> t where

16+ switching :: MonadHold t m => w -> Event t w -> m w

17+

18+instance Reflex t => Switchable t (Event t a) where

19+ switching = switchHold

20+

21+instance Reflex t => Switchable t (Dynamic t a) where

22+ switching a e = fmap join $ holdDyn a e

23+

24+instance Reflex t => Switchable t (Behavior t a) where

25+ switching = switcher

26+

27+instance (Reflex t, Switchable t a, Switchable t b) => Switchable t (a, b) where

28+ switching (a, b) e = (,)

29+ <$> (switching a $ fmap fst e)

30+ <*> (switching b $ fmap snd e)

src/Reflex/NotReady/Class/Orphans.hsnew file+17

@@ -0,0 +1,17 @@

1+{-|

2+Module: Reflex.NotReady.Class.Orphans

3+Description: Orphan instances for NotReady

4+-}

5+{-# LANGUAGE FlexibleInstances #-}

6+{-# LANGUAGE MultiParamTypeClasses #-}

7+{-# LANGUAGE UndecidableInstances #-}

8+{-# OPTIONS_GHC -fno-warn-orphans #-}

9+module Reflex.NotReady.Class.Orphans where

10+

11+import Control.Monad.Trans

12+import Control.Monad.Trans.Writer

13+import Reflex.NotReady.Class

14+

15+instance (NotReady t m, Monoid w) => NotReady t (WriterT w m) where

16+ notReadyUntil = lift . notReadyUntil

17+ notReady = lift notReady

src/Reflex/Spider/Orphans.hs+4

@@ -1,3 +1,7 @@

1+{-|

2+Module: Reflex.Spider.Orphans

3+Description: Orphan instances for SpiderTimeline and SpiderHost

4+-}

15{-# LANGUAGE FlexibleInstances #-}

26{-# LANGUAGE MultiParamTypeClasses #-}

37{-# OPTIONS_GHC -fno-warn-orphans #-}

src/Reflex/Vty.hs−4

@@ -7,10 +7,6 @@ Maintainer : maintainer@obsidian.systems

77Stability : experimental

88Portability : POSIX

99-}

10−

11−{-# LANGUAGE LambdaCase #-}

12−{-# LANGUAGE OverloadedStrings #-}

13−{-# OPTIONS_GHC -fno-warn-unused-top-binds #-}

1410module Reflex.Vty

1511 ( module Reflex

1612 , module Reflex.Vty.Host

src/Reflex/Vty/Host.hs+1

@@ -75,6 +75,7 @@ type MonadVtyApp t m =

7575 , PerformEvent t m

7676 , MonadIO m

7777 , MonadIO (Performable m)

78+ , Adjustable t m

7879 )

7980

8081-- | A functional reactive vty application.

src/Reflex/Vty/Widget.hs+43−2

@@ -11,7 +11,10 @@ Description: Basic set of widgets and building blocks for reflex-vty application

1111{-# LANGUAGE OverloadedStrings #-}

1212{-# LANGUAGE RankNTypes #-}

1313{-# LANGUAGE RecursiveDo #-}

14+{-# LANGUAGE ScopedTypeVariables #-}

15+{-# LANGUAGE StandaloneDeriving #-}

1416{-# LANGUAGE TypeFamilies #-}

17+{-# LANGUAGE UndecidableInstances #-}

1518module Reflex.Vty.Widget

1619 ( VtyWidgetCtx(..)

1720 , VtyWidget(..)

@@ -32,6 +35,7 @@ module Reflex.Vty.Widget

3235 , MouseDown(..)

3336 , MouseUp(..)

3437 , mouseDown

38+ , mouseUp

3539 , pane

3640 , modifyImages

3741 , tellImages

@@ -55,6 +59,7 @@ import Control.Monad.Fix (MonadFix)

5559import Control.Monad.Trans (lift)

5660import Control.Monad.Trans.Reader (ReaderT, runReaderT, asks, ask)

5761import Control.Monad.Trans.Writer (WriterT, runWriterT, censor, tell)

62+import Control.Monad.Writer.Adjustable ()

5863import Data.Default (Default(..))

5964import Data.Text (Text)

6065import qualified Data.Text as T

@@ -62,6 +67,9 @@ import qualified Data.Text.Zipper as TZ

6267import Graphics.Vty (Image)

6368import qualified Graphics.Vty as V

6469import Reflex

70+import Reflex.Class.Switchable

71+import Reflex.NotReady.Class

72+import Reflex.NotReady.Class.Orphans ()

6573

6674import Reflex.Vty.Host

6775

@@ -96,11 +104,32 @@ instance (Reflex t) => Monoid (VtyWidgetOut t) where

96104 mempty = VtyWidgetOut mempty mempty

97105 mappend wo wo' = wo <> wo'

98106

107+instance Reflex t => Switchable t (VtyWidgetOut t) where

108+ switching e0 e = do

109+ shutdown <- switching (_vtyWidgetOut_shutdown e0) $ fmap _vtyWidgetOut_shutdown e

110+ images <- switching (_vtyWidgetOut_images e0) $ fmap _vtyWidgetOut_images e

111+ return $ VtyWidgetOut

112+ { _vtyWidgetOut_images = images

113+ , _vtyWidgetOut_shutdown = shutdown

114+ }

115+

99116-- | A widget that can read its context and produce image output

100117newtype VtyWidget t m a = VtyWidget

101118 { unVtyWidget :: WriterT (VtyWidgetOut t) (ReaderT (VtyWidgetCtx t) m) a

102119 }

103− deriving (Functor, Applicative, Monad, MonadSample t, MonadHold t, MonadFix)

120+ deriving (Functor, Applicative, Monad, MonadSample t, MonadHold t, MonadFix, NotReady t)

121+

122+instance (PostBuild t m, Reflex t) => PostBuild t (VtyWidget t m) where

123+ getPostBuild = VtyWidget $ lift getPostBuild

124+

125+instance (Adjustable t m, MonadHold t m, Reflex t) => Adjustable t (VtyWidget t m) where

126+ runWithReplace a0 a' = VtyWidget $ runWithReplace (unVtyWidget a0) $ fmap unVtyWidget a'

127+ traverseIntMapWithKeyWithAdjust f dm0 dm' = VtyWidget $

128+ traverseIntMapWithKeyWithAdjust (\k v -> unVtyWidget (f k v)) dm0 dm'

129+ traverseDMapWithKeyWithAdjust f dm0 dm' = VtyWidget $ do

130+ traverseDMapWithKeyWithAdjust (\k v -> unVtyWidget (f k v)) dm0 dm'

131+ traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = VtyWidget $ do

132+ traverseDMapWithKeyWithAdjustWithMove (\k v -> unVtyWidget (f k v)) dm0 dm'

104133

105134-- | Runs a 'VtyWidget' with a given context

106135runVtyWidget

@@ -128,7 +157,9 @@ mainWidgetWithHandle vty child =

128157 , _vtyWidgetCtx_input = inp'

129158 , _vtyWidgetCtx_focus = constDyn True

130159 }

131− ((), wo) <- runVtyWidget ctx child

160+ ((), wo) <- runVtyWidget ctx $ do

161+ tellImages . ffor (current size) $ \(w, h) -> [V.charFill V.defAttr ' ' w h]

162+ child

132163 return $ VtyResult

133164 { _vtyResult_picture = fmap (V.picForLayers . reverse) (_vtyWidgetOut_images wo)

134165 , _vtyResult_shutdown = _vtyWidgetOut_shutdown wo

@@ -316,6 +347,16 @@ mouseDown btn = do

316347 else Nothing

317348 _ -> Nothing

318349

350+-- | Mouse up events for a particular mouse button

351+mouseUp

352+ :: (Reflex t, Monad m)

353+ => VtyWidget t m (Event t MouseUp)

354+mouseUp = do

355+ i <- input

356+ return $ fforMaybe i $ \case

357+ V.EvMouseUp x y btn' -> Just $ MouseUp btn' (x, y)

358+ _ -> Nothing

359+

319360-- | Information about a mouse down event

320361data MouseDown = MouseDown

321362 { _mouseDown_button :: V.Button