git.iko.soy/reflex
on develop help sign in
reflex/src/Reflex/BehaviorWriter/Base.hs
211 lines 8.2 kB history raw
1{-|
2Module: Reflex.BehaviorWriter.Base
3Description: Implementation of BehaviorWriter
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.Morph
28import Control.Monad.Reader
29import Control.Monad.Ref
30import Control.Monad.State.Strict
31import Data.Dependent.Map (DMap)
32import qualified Data.Dependent.Map as DMap
33import Data.Functor.Misc
34import Data.IntMap (IntMap)
35import qualified Data.IntMap as IntMap
36import Data.Map (Map)
37import qualified Data.Map as Map
38import Data.Some (Some)
40import Reflex.Class
41import Reflex.Adjustable.Class
42import Reflex.BehaviorWriter.Class
43import Reflex.Host.Class
44import Reflex.PerformEvent.Class
45import Reflex.PostBuild.Class
46import Reflex.Query.Class
47import Reflex.Requester.Class
48import Reflex.TriggerEvent.Class
50-- | A basic implementation of 'BehaviorWriter'.
51newtype BehaviorWriterT t w m a = BehaviorWriterT { unBehaviorWriterT :: StateT [Behavior t w] m a }
52 -- The list is kept in reverse order
53 deriving
54 ( Functor
55 , Applicative
56 , Monad
57 , MonadTrans
58 , MFunctor
59 , MonadIO
60 , MonadFix
61 , MonadAsyncException
62 , MonadException
63 )
65-- | Run a 'BehaviorWriterT' action. The behavior writer output will be provided
66-- along with the result of the action.
67runBehaviorWriterT :: (Monad m, Reflex t, Monoid w) => BehaviorWriterT t w m a -> m (a, Behavior t w)
68runBehaviorWriterT (BehaviorWriterT a) = do
69 (result, ws) <- runStateT a []
70 return (result, mconcat $ reverse ws)
72-- | Map a function over the output of a 'BehaviorWriterT'.
73withBehaviorWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m)
74 => (w -> w')
75 -> BehaviorWriterT t w m a
76 -> BehaviorWriterT t w' m a
77withBehaviorWriterT f dw = do
78 (r, d) <- lift $ do
79 (r, d) <- runBehaviorWriterT dw
80 let d' = fmap f d
81 return (r, d')
82 tellBehavior d
83 return r
85deriving instance MonadHold t m => MonadHold t (BehaviorWriterT t w m)
86deriving instance MonadSample t m => MonadSample t (BehaviorWriterT t w m)
88instance MonadRef m => MonadRef (BehaviorWriterT t w m) where
89 type Ref (BehaviorWriterT t w m) = Ref m
90 newRef = lift . newRef
91 readRef = lift . readRef
92 writeRef r = lift . writeRef r
94instance MonadAtomicRef m => MonadAtomicRef (BehaviorWriterT t w m) where
95 atomicModifyRef r = lift . atomicModifyRef r
97instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (BehaviorWriterT t w m) where
98 newEventWithTrigger = lift . newEventWithTrigger
99 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
101instance (Monad m, Monoid w, Reflex t) => BehaviorWriter t w (BehaviorWriterT t w m) where
102 tellBehavior w = BehaviorWriterT $ modify (w :)
104instance MonadReader r m => MonadReader r (BehaviorWriterT t w m) where
105 ask = lift ask
106 local f (BehaviorWriterT a) = BehaviorWriterT $ mapStateT (local f) a
107 reader = lift . reader
109instance PerformEvent t m => PerformEvent t (BehaviorWriterT t w m) where
110 type Performable (BehaviorWriterT t w m) = Performable m
111 performEvent_ = lift . performEvent_
112 performEvent = lift . performEvent
114instance TriggerEvent t m => TriggerEvent t (BehaviorWriterT t w m) where
115 newTriggerEvent = lift newTriggerEvent
116 newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
117 newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
119instance PostBuild t m => PostBuild t (BehaviorWriterT t w m) where
120 getPostBuild = lift getPostBuild
122instance MonadState s m => MonadState s (BehaviorWriterT t w m) where
123 get = lift get
124 put = lift . put
126instance Requester t m => Requester t (BehaviorWriterT t w m) where
127 type Request (BehaviorWriterT t w m) = Request m
128 type Response (BehaviorWriterT t w m) = Response m
129 requesting = lift . requesting
130 requesting_ = lift . requesting_
132instance (MonadQuery t q m, Monad m) => MonadQuery t q (BehaviorWriterT t w m) where
133 tellQueryIncremental = lift . tellQueryIncremental
134 askQueryResult = lift askQueryResult
135 queryIncremental = lift . queryIncremental
137instance (Adjustable t m, Monoid w, MonadHold t m, Reflex t) => Adjustable t (BehaviorWriterT t w m) where
138 runWithReplace a0 a' = do
139 (result0, result') <- lift $ runWithReplace (runBehaviorWriterT a0) $ runBehaviorWriterT <$> a'
140 tellBehavior . join =<< hold (snd result0) (snd <$> result')
141 return (fst result0, fst <$> result')
142 traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustImpl traverseIntMapWithKeyWithAdjust
143 traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith
145traverseIntMapWithKeyWithAdjustImpl
146 :: forall t w v' p p' v m.
147 ( PatchTarget (p' (Behavior t w)) ~ IntMap (Behavior t w)
148 , Patch (p' (Behavior t w))
149 , Monoid w
150 , Reflex t
151 , MonadHold t m
152 , Functor p
153 , p ~ p'
154 )
155 => ( (IntMap.Key -> v -> m (v', Behavior t w))
156 -> IntMap v
157 -> Event t (p v)
158 -> m (IntMap (v', Behavior t w), Event t (p (v', Behavior t w)))
159 )
160 -> (IntMap.Key -> v -> BehaviorWriterT t w m v')
161 -> IntMap v
162 -> Event t (p v)
163 -> BehaviorWriterT t w m (IntMap v', Event t (p v'))
164traverseIntMapWithKeyWithAdjustImpl base f (dm0 :: IntMap v) dm' = do
165 (result0, result') <- lift $ base (\k v -> runBehaviorWriterT $ f k v) dm0 dm'
166 let liftedResult0 = fmap fst result0
167 liftedResult' = fmap (fmap fst) result'
168 liftedWritten0 :: IntMap (Behavior t w)
169 liftedWritten0 = fmap snd result0
170 liftedWritten' = fmap (fmap snd) result'
171 i <- holdIncremental liftedWritten0 liftedWritten'
172 tellBehavior $ pull $ do
173 m <- sample $ currentIncremental i
174 mconcat . IntMap.elems <$> traverse sample m
175 return (liftedResult0, liftedResult')
177newtype BehaviorWriterTLoweredResult t w v a = BehaviorWriterTLoweredResult (v a, Behavior t w)
179traverseDMapWithKeyWithAdjustImpl
180 :: forall t w k v' p p' v m.
181 ( PatchTarget (p' (Some k) (Behavior t w)) ~ Map (Some k) (Behavior t w)
182 , Patch (p' (Some k) (Behavior t w))
183 , Monoid w
184 , Reflex t
185 , MonadHold t m
186 )
187 => ( (forall a. k a -> v a -> m (BehaviorWriterTLoweredResult t w v' a))
188 -> DMap k v
189 -> Event t (p k v)
190 -> m (DMap k (BehaviorWriterTLoweredResult t w v'), Event t (p k (BehaviorWriterTLoweredResult t w v')))
191 )
192 -> ((forall a. BehaviorWriterTLoweredResult t w v' a -> v' a) -> p k (BehaviorWriterTLoweredResult t w v') -> p k v')
193 -> ((forall a. BehaviorWriterTLoweredResult t w v' a -> Behavior t w) -> p k (BehaviorWriterTLoweredResult t w v') -> p' (Some k) (Behavior t w))
194 -> (forall a. k a -> v a -> BehaviorWriterT t w m (v' a))
195 -> DMap k v
196 -> Event t (p k v)
197 -> BehaviorWriterT t w m (DMap k v', Event t (p k v'))
198traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith f (dm0 :: DMap k v) dm' = do
199 (result0, result') <- lift $ base (\k v -> fmap BehaviorWriterTLoweredResult $ runBehaviorWriterT $ f k v) dm0 dm'
200 let getValue (BehaviorWriterTLoweredResult (v, _)) = v
201 getWritten (BehaviorWriterTLoweredResult (_, w)) = w
202 liftedResult0 = DMap.map getValue result0
203 liftedResult' = ffor result' $ mapPatch getValue
204 liftedWritten0 :: Map (Some k) (Behavior t w)
205 liftedWritten0 = weakenDMapWith getWritten result0
206 liftedWritten' = ffor result' $ weakenPatchWith getWritten
207 i <- holdIncremental liftedWritten0 liftedWritten'
208 tellBehavior $ pull $ do
209 m <- sample $ currentIncremental i
210 mconcat . Map.elems <$> traverse sample m
211 return (liftedResult0, liftedResult')