efe18b1 · reflex-vty · git.iko.soy

git.iko.soy/reflex-vty

on develop help sign in

Convert image output to BehaviorWriter

efe18b1Ali Abrar8 years ago

reflex-vty.cabal+3

compare with develop

unifiedsplit

@@ -23,6 +23,8 @@ library

23 , Reflex.Vty.Widget.Input.Text

24 , Data.Text.Zipper

25 , Control.Monad.Writer.Adjustable

26+ , Reflex.BehaviorWriter.Base

27+ , Reflex.BehaviorWriter.Class

26 , Reflex.Class.Switchable

28 , Reflex.Class.Switchable

27 , Reflex.NotReady.Class.Orphans

29 , Reflex.NotReady.Class.Orphans

28 , Reflex.Spider.Orphans

30 , Reflex.Spider.Orphans

@@ -32,6 +34,7 @@ library

32 data-default,

34 data-default,

33 dependent-map,

35 dependent-map,

34 dependent-sum,

36 dependent-sum,

37+ exception-transformers,

35 mtl,

38 mtl,

36 primitive,

39 primitive,

37 ref-tf,

40 ref-tf,

src-bin/example.hs+5−7

@@ -33,9 +33,6 @@ main :: IO ()

33main = mainWidget $ do

34 inp <- input

35 size <- displaySize

36− tellShutdown . fforMaybe inp $ \case

37− V.EvKey (V.KChar 'c') [V.MCtrl] -> Just ()

38− _ -> Nothing

39 let buttons = do

36 let buttons = do

40 text $ pure "Select an example. Esc will bring you back here. Ctrl+c to quit."

37 text $ pure "Select an example. Esc will bring you back here. Ctrl+c to quit."

41 let region1 = ffor size $ \(w,h) ->

38 let region1 = ffor size $ \(w,h) ->

@@ -58,7 +55,9 @@ main = mainWidget $ do

58 Left Example_TextEditor -> escapable testBoxes

55 Left Example_TextEditor -> escapable testBoxes

59 Left Example_Todo -> escapable taskList

56 Left Example_Todo -> escapable taskList

60 Right () -> buttons

57 Right () -> buttons

61− return ()

58+ return $ fforMaybe inp $ \case

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

60+ _ -> Nothing

63taskList

62taskList

64 :: (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, NotReady t m, PostBuild t m)

63 :: (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, NotReady t m, PostBuild t m)

@@ -177,8 +176,7 @@ todos todos0 newTodo = do

177 todoDelete

176 todoDelete

178 insert = ffor (tag (current todosMap) newTodo) $ \m -> case Map.lookupMax m of

177 insert = ffor (tag (current todosMap) newTodo) $ \m -> case Map.lookupMax m of

179 Nothing -> Map.singleton 0 $ Just $ Todo "" False

178 Nothing -> Map.singleton 0 $ Just $ Todo "" False

180− Just (k, _) -> Map.union (Just <$> m) $ Map.singleton (k+1) $ Just $ Todo "" False

179+ Just (k, _) -> Map.singleton (k+1) $ Just $ Todo "" False

181− delete = ffor (attach (current todosMap) todoDelete) $ \(m, k) ->

182− Map.union (Map.singleton k Nothing) $ Just <$> m

180+ delete = ffor todoDelete $ \k -> Map.singleton k Nothing

183 updates = leftmost [insert, delete]

181 updates = leftmost [insert, delete]

184 return todosMap

182 return todosMap

src/Control/Monad/Writer/Adjustable.hs+11−11

@@ -20,16 +20,16 @@ import Reflex.Class.Switchable

21instance (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'

23+ (result0, result) <- lift $ runWithReplace (runWriterT a0) $ fmap (runWriterT) a'

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

24+ tell =<< switching (snd result0) (snd <$> result)

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

25+ return $ (fst result0, fst <$> result)

26 traverseIntMapWithKeyWithAdjust f dm0 dm' = do

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

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

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

28+ tell =<< switching (fold $ fmap snd result0) (fmap (mconcat . patchIntMapNewElements . fmap snd) result)

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

29+ return (fmap fst result0, fmap (fmap fst) result)

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'

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

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

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

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

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

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

34+ tell =<< switching (snd result0') (fmap snd result')

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

35+ return (fst result0', fmap fst result')

src/Reflex/BehaviorWriter/Base.hsnew file+208

@@ -0,0 +1,208 @@

1+{-|

2+Module: Reflex.BehaviorWriter.Base

3+Description: Implementation of MonadBehaviorWriter

4+-}

5+{-# LANGUAGE CPP #-}

6+{-# LANGUAGE FlexibleInstances #-}

7+{-# LANGUAGE GADTs #-}

8+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

9+{-# LANGUAGE LambdaCase #-}

10+{-# LANGUAGE MultiParamTypeClasses #-}

11+{-# LANGUAGE RankNTypes #-}

12+{-# LANGUAGE ScopedTypeVariables #-}

13+{-# LANGUAGE TupleSections #-}

14+{-# LANGUAGE TypeFamilies #-}

15+{-# LANGUAGE UndecidableInstances #-}

16+{-# LANGUAGE StandaloneDeriving #-}

17+#ifdef USE_REFLEX_OPTIMIZER

18+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

19+#endif

20+module Reflex.BehaviorWriter.Base

21+ ( BehaviorWriterT (..)

22+ , runBehaviorWriterT

23+ , withBehaviorWriterT

24+ ) where

25+

26+import Control.Monad.Exception

27+import Control.Monad.Identity

28+import Control.Monad.IO.Class

29+import Control.Monad.Reader

30+import Control.Monad.Ref

31+import Control.Monad.State.Strict

32+import Data.Dependent.Map (DMap)

33+import qualified Data.Dependent.Map as DMap

34+import Data.Functor.Misc

35+import Data.IntMap (IntMap)

36+import qualified Data.IntMap as IntMap

37+import Data.Map (Map)

38+import qualified Data.Map as Map

39+import Data.Some (Some)

40+

41+import Reflex.Class

42+import Reflex.Adjustable.Class

43+import Reflex.BehaviorWriter.Class

44+import Reflex.Host.Class

45+import Reflex.PerformEvent.Class

46+import Reflex.PostBuild.Class

47+import Reflex.Query.Class

48+import Reflex.Requester.Class

49+import Reflex.TriggerEvent.Class

50+

51+-- | A basic implementation of 'MonadBehaviorWriter'.

52+newtype BehaviorWriterT t w m a = BehaviorWriterT { unBehaviorWriterT :: StateT [Behavior t w] m a }

53+ deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadAsyncException, MonadException) -- The list is kept in reverse order

54+

55+-- | Run a 'BehaviorWriterT' action. The behavior writer output will be provided

56+-- along with the result of the action.

57+runBehaviorWriterT :: (Monad m, Reflex t, Monoid w) => BehaviorWriterT t w m a -> m (a, Behavior t w)

58+runBehaviorWriterT (BehaviorWriterT a) = do

59+ (result, ws) <- runStateT a []

60+ return (result, mconcat $ reverse ws)

61+

62+-- | Map a function over the output of a 'BehaviorWriterT'.

63+withBehaviorWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m)

64+ => (w -> w')

65+ -> BehaviorWriterT t w m a

66+ -> BehaviorWriterT t w' m a

67+withBehaviorWriterT f dw = do

68+ (r, d) <- lift $ do

69+ (r, d) <- runBehaviorWriterT dw

70+ let d' = fmap f d

71+ return (r, d')

72+ tellBehavior d

73+ return r

74+

75+deriving instance MonadHold t m => MonadHold t (BehaviorWriterT t w m)

76+deriving instance MonadSample t m => MonadSample t (BehaviorWriterT t w m)

77+

78+instance MonadTrans (BehaviorWriterT t w) where

79+ lift = BehaviorWriterT . lift

80+

81+instance MonadRef m => MonadRef (BehaviorWriterT t w m) where

82+ type Ref (BehaviorWriterT t w m) = Ref m

83+ newRef = lift . newRef

84+ readRef = lift . readRef

85+ writeRef r = lift . writeRef r

86+

87+instance MonadAtomicRef m => MonadAtomicRef (BehaviorWriterT t w m) where

88+ atomicModifyRef r = lift . atomicModifyRef r

89+

90+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (BehaviorWriterT t w m) where

91+ newEventWithTrigger = lift . newEventWithTrigger

92+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f

93+

94+instance (Monad m, Monoid w, Reflex t) => MonadBehaviorWriter t w (BehaviorWriterT t w m) where

95+ tellBehavior w = BehaviorWriterT $ modify (w :)

96+

97+instance MonadReader r m => MonadReader r (BehaviorWriterT t w m) where

98+ ask = lift ask

99+ local f (BehaviorWriterT a) = BehaviorWriterT $ mapStateT (local f) a

100+ reader = lift . reader

101+

102+instance PerformEvent t m => PerformEvent t (BehaviorWriterT t w m) where

103+ type Performable (BehaviorWriterT t w m) = Performable m

104+ performEvent_ = lift . performEvent_

105+ performEvent = lift . performEvent

106+

107+instance TriggerEvent t m => TriggerEvent t (BehaviorWriterT t w m) where

108+ newTriggerEvent = lift newTriggerEvent

109+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete

110+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete

111+

112+instance PostBuild t m => PostBuild t (BehaviorWriterT t w m) where

113+ getPostBuild = lift getPostBuild

114+

115+instance MonadState s m => MonadState s (BehaviorWriterT t w m) where

116+ get = lift get

117+ put = lift . put

118+

119+instance Requester t m => Requester t (BehaviorWriterT t w m) where

120+ type Request (BehaviorWriterT t w m) = Request m

121+ type Response (BehaviorWriterT t w m) = Response m

122+ requesting = lift . requesting

123+ requesting_ = lift . requesting_

124+

125+instance (MonadQuery t q m, Monad m) => MonadQuery t q (BehaviorWriterT t w m) where

126+ tellQueryIncremental = lift . tellQueryIncremental

127+ askQueryResult = lift askQueryResult

128+ queryIncremental = lift . queryIncremental

129+

130+instance (Adjustable t m, Monoid w, MonadHold t m, Reflex t) => Adjustable t (BehaviorWriterT t w m) where

131+ runWithReplace a0 a' = do

132+ (result0, result') <- lift $ runWithReplace (runBehaviorWriterT a0) $ runBehaviorWriterT <$> a'

133+ tellBehavior . join =<< hold (snd result0) (snd <$> result')

134+ return (fst result0, fst <$> result')

135+ traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustImpl traverseIntMapWithKeyWithAdjust

136+ traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith

137+

138+traverseIntMapWithKeyWithAdjustImpl

139+ :: forall t w v' p p' v m.

140+ ( PatchTarget (p' (Behavior t w)) ~ IntMap (Behavior t w)

141+ , PatchTarget (p' w) ~ IntMap w

142+ , Patch (p' w)

143+ , Patch (p' (Behavior t w))

144+ , Monoid w

145+ , Reflex t

146+ , MonadHold t m

147+ , Functor p

148+ , p ~ p'

149+ )

150+ => ( (IntMap.Key -> v -> m (v', Behavior t w))

151+ -> IntMap v

152+ -> Event t (p v)

153+ -> m (IntMap (v', Behavior t w), Event t (p (v', Behavior t w)))

154+ )

155+ -> (IntMap.Key -> v -> BehaviorWriterT t w m v')

156+ -> IntMap v

157+ -> Event t (p v)

158+ -> BehaviorWriterT t w m (IntMap v', Event t (p v'))

159+traverseIntMapWithKeyWithAdjustImpl base f (dm0 :: IntMap v) dm' = do

160+ (result0, result') <- lift $ base (\k v -> runBehaviorWriterT $ f k v) dm0 dm'

161+ let liftedResult0 = fmap fst result0

162+ liftedResult' = fmap (fmap fst) result'

163+ liftedWritten0 :: IntMap (Behavior t w)

164+ liftedWritten0 = fmap snd result0

165+ liftedWritten' = fmap (fmap snd) result'

166+ i <- holdIncremental liftedWritten0 liftedWritten'

167+ tellBehavior $ pull $ do

168+ m <- sample $ currentIncremental i

169+ mconcat . IntMap.elems <$> traverse sample m

170+ return (liftedResult0, liftedResult')

171+

172+newtype BehaviorWriterTLoweredResult t w v a = BehaviorWriterTLoweredResult (v a, Behavior t w)

173+

174+traverseDMapWithKeyWithAdjustImpl

175+ :: forall t w k v' p p' v m.

176+ ( PatchTarget (p' (Some k) (Behavior t w)) ~ Map (Some k) (Behavior t w)

177+ , PatchTarget (p' (Some k) w) ~ Map (Some k) w

178+ , Patch (p' (Some k) w)

179+ , Patch (p' (Some k) (Behavior t w))

180+ , Monoid w

181+ , Reflex t

182+ , MonadHold t m

183+ )

184+ => ( (forall a. k a -> v a -> m (BehaviorWriterTLoweredResult t w v' a))

185+ -> DMap k v

186+ -> Event t (p k v)

187+ -> m (DMap k (BehaviorWriterTLoweredResult t w v'), Event t (p k (BehaviorWriterTLoweredResult t w v')))

188+ )

189+ -> ((forall a. BehaviorWriterTLoweredResult t w v' a -> v' a) -> p k (BehaviorWriterTLoweredResult t w v') -> p k v')

190+ -> ((forall a. BehaviorWriterTLoweredResult t w v' a -> Behavior t w) -> p k (BehaviorWriterTLoweredResult t w v') -> p' (Some k) (Behavior t w))

191+ -> (forall a. k a -> v a -> BehaviorWriterT t w m (v' a))

192+ -> DMap k v

193+ -> Event t (p k v)

194+ -> BehaviorWriterT t w m (DMap k v', Event t (p k v'))

195+traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith f (dm0 :: DMap k v) dm' = do

196+ (result0, result') <- lift $ base (\k v -> fmap BehaviorWriterTLoweredResult $ runBehaviorWriterT $ f k v) dm0 dm'

197+ let getValue (BehaviorWriterTLoweredResult (v, _)) = v

198+ getWritten (BehaviorWriterTLoweredResult (_, w)) = w

199+ liftedResult0 = DMap.map getValue result0

200+ liftedResult' = ffor result' $ mapPatch getValue

201+ liftedWritten0 :: Map (Some k) (Behavior t w)

202+ liftedWritten0 = weakenDMapWith getWritten result0

203+ liftedWritten' = ffor result' $ weakenPatchWith getWritten

204+ i <- holdIncremental liftedWritten0 liftedWritten'

205+ tellBehavior $ pull $ do

206+ m <- sample $ currentIncremental i

207+ mconcat . Map.elems <$> traverse sample m

208+ return (liftedResult0, liftedResult')

src/Reflex/BehaviorWriter/Class.hsnew file+27

@@ -0,0 +1,27 @@

1+{-|

2+Module: Reflex.BehaviorWriter.Class

3+Description: This module defines the 'MonadBehaviorWriter' class

4+-}

5+{-# LANGUAGE CPP #-}

6+{-# LANGUAGE FlexibleInstances #-}

7+{-# LANGUAGE FunctionalDependencies #-}

8+{-# LANGUAGE MultiParamTypeClasses #-}

9+{-# LANGUAGE UndecidableInstances #-}

10+#ifdef USE_REFLEX_OPTIMIZER

11+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

12+#endif

13+module Reflex.BehaviorWriter.Class

14+ ( MonadBehaviorWriter (..)

15+ ) where

16+

17+import Control.Monad.Reader (ReaderT, lift)

18+import Reflex.Class (Behavior)

19+

20+-- | 'MonadBehaviorWriter' efficiently collects 'Behavior' values using 'tellBehavior'

21+-- and combines them monoidally to provide a 'Behavior' result.

22+class (Monad m, Monoid w) => MonadBehaviorWriter t w m | m -> t w where

23+ tellBehavior :: Behavior t w -> m ()

24+

25+instance MonadBehaviorWriter t w m => MonadBehaviorWriter t w (ReaderT r m) where

26+ tellBehavior = lift . tellBehavior

27+

src/Reflex/NotReady/Class/Orphans.hs+5

@@ -11,7 +11,12 @@ module Reflex.NotReady.Class.Orphans where

11import Control.Monad.Trans

12import Control.Monad.Trans.Writer

13import Reflex.NotReady.Class

14+import Reflex.BehaviorWriter.Base

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

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

16 notReadyUntil = lift . notReadyUntil

17 notReadyUntil = lift . notReadyUntil

17 notReady = lift notReady

18 notReady = lift notReady

19+

20+instance (NotReady t m, Monoid w) => NotReady t (BehaviorWriterT t w m) where

21+ notReadyUntil = lift . notReadyUntil

22+ notReady = lift notReady

src/Reflex/Vty/Widget.hs+22−68

@@ -37,9 +37,7 @@ module Reflex.Vty.Widget

37 , mouseDown

38 , mouseUp

39 , pane

40− , modifyImages

41 , tellImages

40 , tellImages

42− , tellShutdown

43 , splitV

41 , splitV

44 , splitVDrag

42 , splitVDrag

45 , box

43 , box

@@ -62,8 +60,6 @@ import Control.Applicative (liftA2)

62import Control.Monad.Fix (MonadFix)

60import Control.Monad.Fix (MonadFix)

63import Control.Monad.Trans (lift)

61import Control.Monad.Trans (lift)

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

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

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

66−import Control.Monad.Writer.Adjustable ()

67import Data.Default (Default(..))

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

68import Data.Text (Text)

64import Data.Text (Text)

69import qualified Data.Text as T

65import qualified Data.Text as T

@@ -71,9 +67,10 @@ import qualified Data.Text.Zipper as TZ

71import Graphics.Vty (Image)

67import Graphics.Vty (Image)

72import qualified Graphics.Vty as V

68import qualified Graphics.Vty as V

73import Reflex

69import Reflex

74−import Reflex.Class.Switchable

75import Reflex.NotReady.Class

70import Reflex.NotReady.Class

76import Reflex.NotReady.Class.Orphans ()

71import Reflex.NotReady.Class.Orphans ()

72+import Reflex.BehaviorWriter.Class (tellBehavior)

73+import Reflex.BehaviorWriter.Base (BehaviorWriterT, runBehaviorWriterT)

78import Reflex.Vty.Host

75import Reflex.Vty.Host

@@ -93,39 +90,9 @@ data VtyWidgetCtx t = VtyWidgetCtx

94-- | The output of a 'VtyWidget'

91-- | The output of a 'VtyWidget'

95data VtyWidgetOut t = VtyWidgetOut

92data VtyWidgetOut t = VtyWidgetOut

96− { _vtyWidgetOut_images :: Behavior t [Image]

97− -- ^ The visual output of the 'VtyWidget'

98− , _vtyWidgetOut_shutdown :: Event t ()

93+ { _vtyWidgetOut_shutdown :: Event t ()

99 }

94 }

100

101−instance Reflex t => Semigroup (VtyWidgetOut t) where

102− wo <> wo' = VtyWidgetOut

103− { _vtyWidgetOut_images = _vtyWidgetOut_images wo <> _vtyWidgetOut_images wo'

104− , _vtyWidgetOut_shutdown = _vtyWidgetOut_shutdown wo <> _vtyWidgetOut_shutdown wo'

105− }

106−

107−instance (Reflex t) => Monoid (VtyWidgetOut t) where

108− mempty = VtyWidgetOut mempty mempty

109− mappend wo wo' = wo <> wo'

110−

111−instance Reflex t => Switchable t (VtyWidgetOut t) where

112− switching e0 e = do

113− shutdown <- switching (_vtyWidgetOut_shutdown e0) $ fmap _vtyWidgetOut_shutdown e

114− images <- switching (_vtyWidgetOut_images e0) $ fmap _vtyWidgetOut_images e

115− return $ VtyWidgetOut

116− { _vtyWidgetOut_images = images

117− , _vtyWidgetOut_shutdown = shutdown

118− }

119−

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

121−newtype VtyWidget t m a = VtyWidget

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

123− }

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

125−

126−instance (PostBuild t m, Reflex t) => PostBuild t (VtyWidget t m) where

127− getPostBuild = VtyWidget $ lift getPostBuild

128−

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

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

130 runWithReplace a0 a' = VtyWidget $ runWithReplace (unVtyWidget a0) $ fmap unVtyWidget a'

97 runWithReplace a0 a' = VtyWidget $ runWithReplace (unVtyWidget a0) $ fmap unVtyWidget a'

131 traverseIntMapWithKeyWithAdjust f dm0 dm' = VtyWidget $

98 traverseIntMapWithKeyWithAdjust f dm0 dm' = VtyWidget $

@@ -135,18 +102,24 @@ instance (Adjustable t m, MonadHold t m, Reflex t) => Adjustable t (VtyWidget t

135 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = VtyWidget $ do

102 traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = VtyWidget $ do

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

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

137

104

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

106+newtype VtyWidget t m a = VtyWidget

107+ { unVtyWidget :: BehaviorWriterT t [Image] (ReaderT (VtyWidgetCtx t) m) a

108+ }

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

110+

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

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

139runVtyWidget

112runVtyWidget

140− :: Reflex t

113+ :: (Reflex t, Monad m)

141 => VtyWidgetCtx t

114 => VtyWidgetCtx t

142 -> VtyWidget t m a

115 -> VtyWidget t m a

143− -> m (a, VtyWidgetOut t)

116+ -> m (a, Behavior t [Image])

144−runVtyWidget ctx w = runReaderT (runWriterT (unVtyWidget w)) ctx

117+runVtyWidget ctx w = runReaderT (runBehaviorWriterT (unVtyWidget w)) ctx

145

118

146-- | Sets up the top-level context for a 'VtyWidget' and runs it with that context

119-- | Sets up the top-level context for a 'VtyWidget' and runs it with that context

147mainWidgetWithHandle

120mainWidgetWithHandle

148 :: V.Vty

121 :: V.Vty

149− -> (forall t m. MonadVtyApp t m => VtyWidget t m ())

122+ -> (forall t m. MonadVtyApp t m => VtyWidget t m (Event t ()))

150 -> IO ()

123 -> IO ()

151mainWidgetWithHandle vty child =

124mainWidgetWithHandle vty child =

152 runVtyAppWithHandle vty $ \dr0 inp -> do

125 runVtyAppWithHandle vty $ \dr0 inp -> do

@@ -161,17 +134,17 @@ mainWidgetWithHandle vty child =

161 , _vtyWidgetCtx_input = inp'

134 , _vtyWidgetCtx_input = inp'

162 , _vtyWidgetCtx_focus = constDyn True

135 , _vtyWidgetCtx_focus = constDyn True

163 }

136 }

164− ((), wo) <- runVtyWidget ctx $ do

137+ (shutdown, images) <- runVtyWidget ctx $ do

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

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

166 child

139 child

167 return $ VtyResult

140 return $ VtyResult

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

141+ { _vtyResult_picture = fmap (V.picForLayers . reverse) images

169− , _vtyResult_shutdown = _vtyWidgetOut_shutdown wo

142+ , _vtyResult_shutdown = shutdown

170 }

143 }

171

144

172-- | Like 'mainWidgetWithHandle', but uses a default vty configuration

145-- | Like 'mainWidgetWithHandle', but uses a default vty configuration

173mainWidget

146mainWidget

174− :: (forall t m. MonadVtyApp t m => VtyWidget t m ())

147+ :: (forall t m. MonadVtyApp t m => VtyWidget t m (Event t ()))

175 -> IO ()

148 -> IO ()

176mainWidget child = do

149mainWidget child = do

177 vty <- getDefaultVty

150 vty <- getDefaultVty

@@ -211,16 +184,8 @@ class (Reflex t, Monad m) => ImageWriter t m | m -> t where

211 -- | Send images upstream for rendering

184 -- | Send images upstream for rendering

212 tellImages :: Behavior t [Image] -> m ()

185 tellImages :: Behavior t [Image] -> m ()

213

186

214−instance (Reflex t, Monad m) => ImageWriter t (VtyWidget t m) where

187+instance (Monad m, Reflex t) => ImageWriter t (BehaviorWriterT t [Image] m) where

215− tellImages imgs = VtyWidget $ tell (mempty { _vtyWidgetOut_images = imgs })

188+ tellImages = tellBehavior

216−

217−-- | A class for things that can shut down the vty application

218−class (Reflex t, Monad m) => Shutdown t m where

219− -- | Signals that the vty application should shut down

220− tellShutdown :: Event t () -> m ()

221−

222−instance (Reflex t, Monad m) => Shutdown t (VtyWidget t m) where

223− tellShutdown sd = VtyWidget $ tell (mempty { _vtyWidgetOut_shutdown = sd })

224

189

225-- | A chunk of the display area

190-- | A chunk of the display area

226data Region = Region

191data Region = Region

@@ -274,11 +239,9 @@ pane reg foc child = VtyWidget $ do

274 ]

239 ]

275 , _vtyWidgetCtx_focus = liftA2 (&&) (_vtyWidgetCtx_focus ctx) foc

240 , _vtyWidgetCtx_focus = liftA2 (&&) (_vtyWidgetCtx_focus ctx) foc

276 , _vtyWidgetCtx_size = fmap regionSize reg }

241 , _vtyWidgetCtx_size = fmap regionSize reg }

277− (result, wo) <- lift . lift $ runVtyWidget ctx' child

242+ (result, images) <- lift . lift $ runVtyWidget ctx' child

278− let images = _vtyWidgetOut_images wo

279− images' = liftA2 (\r is -> map (withinImage r) is) (current reg) images

243+ let images' = liftA2 (\r is -> map (withinImage r) is) (current reg) images

280− wo' = wo { _vtyWidgetOut_images = images' }

244+ tellImages images'

281− tell wo'

282 return result

245 return result

283 where

246 where

284 filterInput :: Region -> Bool -> VtyEvent -> Maybe VtyEvent

247 filterInput :: Region -> Bool -> VtyEvent -> Maybe VtyEvent

@@ -445,15 +408,6 @@ fill c = do

445hRule :: (Reflex t, Monad m) => BoxStyle -> VtyWidget t m ()

408hRule :: (Reflex t, Monad m) => BoxStyle -> VtyWidget t m ()

446hRule boxStyle = fill (_boxStyle_s boxStyle)

409hRule boxStyle = fill (_boxStyle_s boxStyle)

447

410

448−-- | Transform the images produces by a widget

449−modifyImages

450− :: (Reflex t, MonadHold t m, MonadFix m)

451− => Behavior t ([Image] -> [Image])

452− -> VtyWidget t m a

453− -> VtyWidget t m a

454−modifyImages f (VtyWidget w) = VtyWidget $ flip censor w $ \wo ->

455− wo { _vtyWidgetOut_images = f <*> (_vtyWidgetOut_images wo) }

456−

457-- | Defines a set of symbols to use to draw the outlines of boxes

411-- | Defines a set of symbols to use to draw the outlines of boxes

458-- C.f. https://en.wikipedia.org/wiki/Box-drawing_character

412-- C.f. https://en.wikipedia.org/wiki/Box-drawing_character

459data BoxStyle = BoxStyle

413data BoxStyle = BoxStyle