@@ -1,208 +0,0 @@
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')