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

git.iko.soy/reflex-vty

on develop help sign in

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

4e197f2Ali Abrar8 years ago

reflex-vty.cabal+6−1

compare with develop

unifiedsplit

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

17 , Reflex.Vty.Widget.Input

18 , Reflex.Vty.Widget.Input.Text

19 , Data.Text.Zipper

20+ , Control.Monad.Writer.Adjustable

21+ , Reflex.Class.Switchable

22+ , Reflex.NotReady.Class.Orphans

20− other-modules: Reflex.Spider.Orphans

23+ , Reflex.Spider.Orphans

21 build-depends:

24 build-depends:

22 base,

25 base,

23 containers,

26 containers,

24 data-default,

27 data-default,

28+ dependent-map,

25 dependent-sum,

29 dependent-sum,

26 mtl,

30 mtl,

27 primitive,

31 primitive,

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

41 ghc-options: -threaded

45 ghc-options: -threaded

42 build-depends:

46 build-depends:

43 base,

47 base,

48+ containers,

44 reflex,

49 reflex,

45 reflex-vty,

50 reflex-vty,

46 text,

51 text,

src-bin/example.hs+83−10

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

3{-# LANGUAGE LambdaCase #-}

4{-# LANGUAGE OverloadedStrings #-}

5{-# LANGUAGE RankNTypes #-}

6+{-# LANGUAGE RecursiveDo #-}

6{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE ScopedTypeVariables #-}

8+{-# LANGUAGE TupleSections #-}

7{-# OPTIONS_GHC -threaded #-}

9{-# OPTIONS_GHC -threaded #-}

9import Control.Monad.Fix

11import Control.Monad.Fix

12+import Data.Foldable

13+import Data.Sequence (Seq)

14+import qualified Data.Sequence as Seq

15+import Data.Text (Text)

10import qualified Data.Text as T

16import qualified Data.Text as T

17+import qualified Data.Text.Zipper as TZ

11import qualified Graphics.Vty as V

18import qualified Graphics.Vty as V

12import Reflex

19import Reflex

20+import Reflex.Network

21+import Reflex.NotReady.Class

13import Reflex.Vty

22import Reflex.Vty

15main :: IO ()

24main :: IO ()

16−main =

17− mainWidget $ do

25+main = mainWidget $ do

18− inp <- input

26+ inp <- input

19− tellShutdown . fforMaybe inp $ \case

27+ tellShutdown . fforMaybe inp $ \case

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

28+ V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()

21− _ -> Nothing

29+ _ -> Nothing

22−

30+ rec let todos' = todos [] $ () <$ e

23− debugInput

31+ btn = button $ pure "Add another task"

24− testBoxes

32+ (_, e) <- splitV (pure (subtract 3)) (pure (True, True)) todos' btn

25− return ()

33+ return ()

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

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

28testBoxes = do

36testBoxes = do

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

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

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

53testStringBox = box singleBoxStyle .

61testStringBox = box singleBoxStyle .

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

62 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+-}

1{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FlexibleInstances #-}

2{-# LANGUAGE MultiParamTypeClasses #-}

6{-# LANGUAGE MultiParamTypeClasses #-}

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

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

src/Reflex/Vty.hs−4

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

7Stability : experimental

8Portability : POSIX

9-}

10−

11−{-# LANGUAGE LambdaCase #-}

12−{-# LANGUAGE OverloadedStrings #-}

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

14module Reflex.Vty

10module Reflex.Vty

15 ( module Reflex

11 ( module Reflex

16 , module Reflex.Vty.Host

12 , module Reflex.Vty.Host

src/Reflex/Vty/Host.hs+1

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

75 , PerformEvent t m

76 , MonadIO m

77 , MonadIO (Performable m)

78+ , Adjustable t m

78 )

79 )

80-- | A functional reactive vty application.

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

11{-# LANGUAGE OverloadedStrings #-}

12{-# LANGUAGE RankNTypes #-}

13{-# LANGUAGE RecursiveDo #-}

14+{-# LANGUAGE ScopedTypeVariables #-}

15+{-# LANGUAGE StandaloneDeriving #-}

14{-# LANGUAGE TypeFamilies #-}

16{-# LANGUAGE TypeFamilies #-}

17+{-# LANGUAGE UndecidableInstances #-}

15module Reflex.Vty.Widget

18module Reflex.Vty.Widget

16 ( VtyWidgetCtx(..)

19 ( VtyWidgetCtx(..)

17 , VtyWidget(..)

20 , VtyWidget(..)

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

32 , MouseDown(..)

35 , MouseDown(..)

33 , MouseUp(..)

36 , MouseUp(..)

34 , mouseDown

37 , mouseDown

38+ , mouseUp

35 , pane

39 , pane

36 , modifyImages

40 , modifyImages

37 , tellImages

41 , tellImages

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

55import Control.Monad.Trans (lift)

59import Control.Monad.Trans (lift)

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

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

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

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

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

58import Data.Default (Default(..))

63import Data.Default (Default(..))

59import Data.Text (Text)

64import Data.Text (Text)

60import qualified Data.Text as T

65import qualified Data.Text as T

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

62import Graphics.Vty (Image)

67import Graphics.Vty (Image)

63import qualified Graphics.Vty as V

68import qualified Graphics.Vty as V

64import Reflex

69import Reflex

70+import Reflex.Class.Switchable

71+import Reflex.NotReady.Class

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

66import Reflex.Vty.Host

74import Reflex.Vty.Host

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

96 mempty = VtyWidgetOut mempty mempty

104 mempty = VtyWidgetOut mempty mempty

97 mappend wo wo' = wo <> wo'

105 mappend wo wo' = wo <> wo'

106

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+

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

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

100newtype VtyWidget t m a = VtyWidget

117newtype VtyWidget t m a = VtyWidget

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

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

102 }

119 }

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'

104

133

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

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

106runVtyWidget

135runVtyWidget

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

128 , _vtyWidgetCtx_input = inp'

157 , _vtyWidgetCtx_input = inp'

129 , _vtyWidgetCtx_focus = constDyn True

158 , _vtyWidgetCtx_focus = constDyn True

130 }

159 }

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

132 return $ VtyResult

163 return $ VtyResult

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

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

134 , _vtyResult_shutdown = _vtyWidgetOut_shutdown wo

165 , _vtyResult_shutdown = _vtyWidgetOut_shutdown wo

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

316 else Nothing

347 else Nothing

317 _ -> Nothing

348 _ -> Nothing

318

349

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+

319-- | Information about a mouse down event

360-- | Information about a mouse down event

320data MouseDown = MouseDown

361data MouseDown = MouseDown

321 { _mouseDown_button :: V.Button

362 { _mouseDown_button :: V.Button