@@ -0,0 +1,204 @@
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+ , Patch (p' (Behavior t w))
142+ , Monoid w
143+ , Reflex t
144+ , MonadHold t m
145+ , Functor p
146+ , p ~ p'
147+ )
148+ => ( (IntMap.Key -> v -> m (v', Behavior t w))
149+ -> IntMap v
150+ -> Event t (p v)
151+ -> m (IntMap (v', Behavior t w), Event t (p (v', Behavior t w)))
152+ )
153+ -> (IntMap.Key -> v -> BehaviorWriterT t w m v')
154+ -> IntMap v
155+ -> Event t (p v)
156+ -> BehaviorWriterT t w m (IntMap v', Event t (p v'))
157+traverseIntMapWithKeyWithAdjustImpl base f (dm0 :: IntMap v) dm' = do
158+ (result0, result') <- lift $ base (\k v -> runBehaviorWriterT $ f k v) dm0 dm'
159+ let liftedResult0 = fmap fst result0
160+ liftedResult' = fmap (fmap fst) result'
161+ liftedWritten0 :: IntMap (Behavior t w)
162+ liftedWritten0 = fmap snd result0
163+ liftedWritten' = fmap (fmap snd) result'
164+ i <- holdIncremental liftedWritten0 liftedWritten'
165+ tellBehavior $ pull $ do
166+ m <- sample $ currentIncremental i
167+ mconcat . IntMap.elems <$> traverse sample m
168+ return (liftedResult0, liftedResult')
169+
170+newtype BehaviorWriterTLoweredResult t w v a = BehaviorWriterTLoweredResult (v a, Behavior t w)
171+
172+traverseDMapWithKeyWithAdjustImpl
173+ :: forall t w k v' p p' v m.
174+ ( PatchTarget (p' (Some k) (Behavior t w)) ~ Map (Some k) (Behavior t w)
175+ , Patch (p' (Some k) (Behavior t w))
176+ , Monoid w
177+ , Reflex t
178+ , MonadHold t m
179+ )
180+ => ( (forall a. k a -> v a -> m (BehaviorWriterTLoweredResult t w v' a))
181+ -> DMap k v
182+ -> Event t (p k v)
183+ -> m (DMap k (BehaviorWriterTLoweredResult t w v'), Event t (p k (BehaviorWriterTLoweredResult t w v')))
184+ )
185+ -> ((forall a. BehaviorWriterTLoweredResult t w v' a -> v' a) -> p k (BehaviorWriterTLoweredResult t w v') -> p k v')
186+ -> ((forall a. BehaviorWriterTLoweredResult t w v' a -> Behavior t w) -> p k (BehaviorWriterTLoweredResult t w v') -> p' (Some k) (Behavior t w))
187+ -> (forall a. k a -> v a -> BehaviorWriterT t w m (v' a))
188+ -> DMap k v
189+ -> Event t (p k v)
190+ -> BehaviorWriterT t w m (DMap k v', Event t (p k v'))
191+traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith f (dm0 :: DMap k v) dm' = do
192+ (result0, result') <- lift $ base (\k v -> fmap BehaviorWriterTLoweredResult $ runBehaviorWriterT $ f k v) dm0 dm'
193+ let getValue (BehaviorWriterTLoweredResult (v, _)) = v
194+ getWritten (BehaviorWriterTLoweredResult (_, w)) = w
195+ liftedResult0 = DMap.map getValue result0
196+ liftedResult' = ffor result' $ mapPatch getValue
197+ liftedWritten0 :: Map (Some k) (Behavior t w)
198+ liftedWritten0 = weakenDMapWith getWritten result0
199+ liftedWritten' = ffor result' $ weakenPatchWith getWritten
200+ i <- holdIncremental liftedWritten0 liftedWritten'
201+ tellBehavior $ pull $ do
202+ m <- sample $ currentIncremental i
203+ mconcat . Map.elems <$> traverse sample m
204+ return (liftedResult0, liftedResult')