git.iko.soy/reflex
on ae@dev-script help sign in
reflex/src/Reflex/BehaviorWriter/Base.hs
202 lines 8.2 kB history raw
1{-|
2Module: Reflex.BehaviorWriter.Base
3Description: Implementation of MonadBehaviorWriter
4-}
5{-# LANGUAGE CPP #-}
6{-# LANGUAGE FlexibleInstances #-}
7{-# LANGUAGE GADTs #-}
8{-# LANGUAGE GeneralizedNewtypeDeriving #-}
9{-# LANGUAGE MultiParamTypeClasses #-}
10{-# LANGUAGE RankNTypes #-}
11{-# LANGUAGE ScopedTypeVariables #-}
12{-# LANGUAGE TypeFamilies #-}
13{-# LANGUAGE UndecidableInstances #-}
14{-# LANGUAGE StandaloneDeriving #-}
15#ifdef USE_REFLEX_OPTIMIZER
16{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
17#endif
18module Reflex.BehaviorWriter.Base
19 ( BehaviorWriterT (..)
20 , runBehaviorWriterT
21 , withBehaviorWriterT
22 ) where
24import Control.Monad.Exception
25import Control.Monad.Identity
26import Control.Monad.IO.Class
27import Control.Monad.Reader
28import Control.Monad.Ref
29import Control.Monad.State.Strict
30import Data.Dependent.Map (DMap)
31import qualified Data.Dependent.Map as DMap
32import Data.Functor.Misc
33import Data.IntMap (IntMap)
34import qualified Data.IntMap as IntMap
35import Data.Map (Map)
36import qualified Data.Map as Map
37import Data.Some (Some)
39import Reflex.Class
40import Reflex.Adjustable.Class
41import Reflex.BehaviorWriter.Class
42import Reflex.Host.Class
43import Reflex.PerformEvent.Class
44import Reflex.PostBuild.Class
45import Reflex.Query.Class
46import Reflex.Requester.Class
47import Reflex.TriggerEvent.Class
49-- | A basic implementation of 'MonadBehaviorWriter'.
50newtype BehaviorWriterT t w m a = BehaviorWriterT { unBehaviorWriterT :: StateT [Behavior t w] m a }
51 deriving (Functor, Applicative, Monad, MonadIO, MonadFix, MonadAsyncException, MonadException) -- The list is kept in reverse order
53-- | Run a 'BehaviorWriterT' action. The behavior writer output will be provided
54-- along with the result of the action.
55runBehaviorWriterT :: (Monad m, Reflex t, Monoid w) => BehaviorWriterT t w m a -> m (a, Behavior t w)
56runBehaviorWriterT (BehaviorWriterT a) = do
57 (result, ws) <- runStateT a []
58 return (result, mconcat $ reverse ws)
60-- | Map a function over the output of a 'BehaviorWriterT'.
61withBehaviorWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m)
62 => (w -> w')
63 -> BehaviorWriterT t w m a
64 -> BehaviorWriterT t w' m a
65withBehaviorWriterT f dw = do
66 (r, d) <- lift $ do
67 (r, d) <- runBehaviorWriterT dw
68 let d' = fmap f d
69 return (r, d')
70 tellBehavior d
71 return r
73deriving instance MonadHold t m => MonadHold t (BehaviorWriterT t w m)
74deriving instance MonadSample t m => MonadSample t (BehaviorWriterT t w m)
76instance MonadTrans (BehaviorWriterT t w) where
77 lift = BehaviorWriterT . lift
79instance MonadRef m => MonadRef (BehaviorWriterT t w m) where
80 type Ref (BehaviorWriterT t w m) = Ref m
81 newRef = lift . newRef
82 readRef = lift . readRef
83 writeRef r = lift . writeRef r
85instance MonadAtomicRef m => MonadAtomicRef (BehaviorWriterT t w m) where
86 atomicModifyRef r = lift . atomicModifyRef r
88instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (BehaviorWriterT t w m) where
89 newEventWithTrigger = lift . newEventWithTrigger
90 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
92instance (Monad m, Monoid w, Reflex t) => MonadBehaviorWriter t w (BehaviorWriterT t w m) where
93 tellBehavior w = BehaviorWriterT $ modify (w :)
95instance MonadReader r m => MonadReader r (BehaviorWriterT t w m) where
96 ask = lift ask
97 local f (BehaviorWriterT a) = BehaviorWriterT $ mapStateT (local f) a
98 reader = lift . reader
100instance PerformEvent t m => PerformEvent t (BehaviorWriterT t w m) where
101 type Performable (BehaviorWriterT t w m) = Performable m
102 performEvent_ = lift . performEvent_
103 performEvent = lift . performEvent
105instance TriggerEvent t m => TriggerEvent t (BehaviorWriterT t w m) where
106 newTriggerEvent = lift newTriggerEvent
107 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
108 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
110instance PostBuild t m => PostBuild t (BehaviorWriterT t w m) where
111 getPostBuild = lift getPostBuild
113instance MonadState s m => MonadState s (BehaviorWriterT t w m) where
114 get = lift get
115 put = lift . put
117instance Requester t m => Requester t (BehaviorWriterT t w m) where
118 type Request (BehaviorWriterT t w m) = Request m
119 type Response (BehaviorWriterT t w m) = Response m
120 requesting = lift . requesting
121 requesting_ = lift . requesting_
123instance (MonadQuery t q m, Monad m) => MonadQuery t q (BehaviorWriterT t w m) where
124 tellQueryIncremental = lift . tellQueryIncremental
125 askQueryResult = lift askQueryResult
126 queryIncremental = lift . queryIncremental
128instance (Adjustable t m, Monoid w, MonadHold t m, Reflex t) => Adjustable t (BehaviorWriterT t w m) where
129 runWithReplace a0 a' = do
130 (result0, result') <- lift $ runWithReplace (runBehaviorWriterT a0) $ runBehaviorWriterT <$> a'
131 tellBehavior . join =<< hold (snd result0) (snd <$> result')
132 return (fst result0, fst <$> result')
133 traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustImpl traverseIntMapWithKeyWithAdjust
134 traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith
136traverseIntMapWithKeyWithAdjustImpl
137 :: forall t w v' p p' v m.
138 ( PatchTarget (p' (Behavior t w)) ~ IntMap (Behavior t w)
139 , Patch (p' (Behavior t w))
140 , Monoid w
141 , Reflex t
142 , MonadHold t m
143 , Functor p
144 , p ~ p'
145 )
146 => ( (IntMap.Key -> v -> m (v', Behavior t w))
147 -> IntMap v
148 -> Event t (p v)
149 -> m (IntMap (v', Behavior t w), Event t (p (v', Behavior t w)))
150 )
151 -> (IntMap.Key -> v -> BehaviorWriterT t w m v')
152 -> IntMap v
153 -> Event t (p v)
154 -> BehaviorWriterT t w m (IntMap v', Event t (p v'))
155traverseIntMapWithKeyWithAdjustImpl base f (dm0 :: IntMap v) dm' = do
156 (result0, result') <- lift $ base (\k v -> runBehaviorWriterT $ f k v) dm0 dm'
157 let liftedResult0 = fmap fst result0
158 liftedResult' = fmap (fmap fst) result'
159 liftedWritten0 :: IntMap (Behavior t w)
160 liftedWritten0 = fmap snd result0
161 liftedWritten' = fmap (fmap snd) result'
162 i <- holdIncremental liftedWritten0 liftedWritten'
163 tellBehavior $ pull $ do
164 m <- sample $ currentIncremental i
165 mconcat . IntMap.elems <$> traverse sample m
166 return (liftedResult0, liftedResult')
168newtype BehaviorWriterTLoweredResult t w v a = BehaviorWriterTLoweredResult (v a, Behavior t w)
170traverseDMapWithKeyWithAdjustImpl
171 :: forall t w k v' p p' v m.
172 ( PatchTarget (p' (Some k) (Behavior t w)) ~ Map (Some k) (Behavior t w)
173 , Patch (p' (Some k) (Behavior t w))
174 , Monoid w
175 , Reflex t
176 , MonadHold t m
177 )
178 => ( (forall a. k a -> v a -> m (BehaviorWriterTLoweredResult t w v' a))
179 -> DMap k v
180 -> Event t (p k v)
181 -> m (DMap k (BehaviorWriterTLoweredResult t w v'), Event t (p k (BehaviorWriterTLoweredResult t w v')))
182 )
183 -> ((forall a. BehaviorWriterTLoweredResult t w v' a -> v' a) -> p k (BehaviorWriterTLoweredResult t w v') -> p k v')
184 -> ((forall a. BehaviorWriterTLoweredResult t w v' a -> Behavior t w) -> p k (BehaviorWriterTLoweredResult t w v') -> p' (Some k) (Behavior t w))
185 -> (forall a. k a -> v a -> BehaviorWriterT t w m (v' a))
186 -> DMap k v
187 -> Event t (p k v)
188 -> BehaviorWriterT t w m (DMap k v', Event t (p k v'))
189traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith f (dm0 :: DMap k v) dm' = do
190 (result0, result') <- lift $ base (\k v -> fmap BehaviorWriterTLoweredResult $ runBehaviorWriterT $ f k v) dm0 dm'
191 let getValue (BehaviorWriterTLoweredResult (v, _)) = v
192 getWritten (BehaviorWriterTLoweredResult (_, w)) = w
193 liftedResult0 = DMap.map getValue result0
194 liftedResult' = ffor result' $ mapPatch getValue
195 liftedWritten0 :: Map (Some k) (Behavior t w)
196 liftedWritten0 = weakenDMapWith getWritten result0
197 liftedWritten' = ffor result' $ weakenPatchWith getWritten
198 i <- holdIncremental liftedWritten0 liftedWritten'
199 tellBehavior $ pull $ do
200 m <- sample $ currentIncremental i
201 mconcat . Map.elems <$> traverse sample m
202 return (liftedResult0, liftedResult')