git.iko.soy/reflex
on develop help sign in
Merge pull request #83 from reflex-frp/event-writer

Add EventWriter

commit4c9d7568a403fbec0fdd7cee0128eb60fa20198e authorRyan Trinkle <ryan.trinkle@gmail.com> dateSat 24 Dec 2016, 19:03 (10 years ago) parent91299fc9fe075a
6 files changed+375−99
compare with develop
unifiedsplit
reflex.cabal+23−1 src/Reflex.hs+1 src/Reflex/EventWriter.hs+169 src/Reflex/Requester/Base.hs+51−98 test/EventWriterT.hs+61 test/RequesterT.hs+70
reflex.cabal+23−1
@@ -31,7 +31,7 @@ library
3131 bifunctors >= 5.2 && < 5.5,
3232 containers == 0.5.*,
3333 data-default >= 0.5 && < 0.8,
34− dependent-map >= 0.2.2 && < 0.3,
34+ dependent-map >= 0.2.4 && < 0.3,
3535 dependent-sum == 0.3.*,
3636 exception-transformers == 0.4.*,
3737 haskell-src-exts >= 1.16 && < 1.18,
@@ -57,6 +57,7 @@ library
5757 Data.WeakBag,
5858 Reflex,
5959 Reflex.Class,
60+ Reflex.EventWriter,
6061 Reflex.Dynamic,
6162 Reflex.Dynamic.TH,
6263 Reflex.Dynamic.Uniq,
@@ -117,6 +118,27 @@ test-suite hlint
117118 if impl(ghcjs)
118119 buildable: False
119120
121+test-suite EventWriterT
122+ type: exitcode-stdio-1.0
123+ main-is: EventWriterT.hs
124+ hs-source-dirs: test
125+ build-depends: base
126+ , dependent-sum
127+ , transformers
128+ , reflex
129+ , ref-tf
130+
131+test-suite RequesterT
132+ type: exitcode-stdio-1.0
133+ main-is: RequesterT.hs
134+ hs-source-dirs: test
135+ build-depends: base
136+ , dependent-sum
137+ , dependent-map
138+ , transformers
139+ , reflex
140+ , ref-tf
141+
120142benchmark spider-bench
121143 type: exitcode-stdio-1.0
122144 hs-source-dirs: bench
src/Reflex.hs+1
@@ -5,6 +5,7 @@ module Reflex
55 ) where
66
77import Reflex.Class as X
8+import Reflex.EventWriter as X
89import Reflex.Dynamic as X
910import Reflex.Dynamic.TH as X
1011import Reflex.Dynamic.Uniq as X
src/Reflex/EventWriter.hsnew file+169
@@ -0,0 +1,169 @@
1+-- | This module provides 'EventWriterT', the standard implementation of
2+-- 'EventWriter'.
3+{-# LANGUAGE CPP #-}
4+{-# LANGUAGE ExistentialQuantification #-}
5+{-# LANGUAGE FlexibleInstances #-}
6+{-# LANGUAGE FunctionalDependencies #-}
7+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
8+{-# LANGUAGE KindSignatures #-}
9+{-# LANGUAGE MultiParamTypeClasses #-}
10+{-# LANGUAGE Rank2Types #-}
11+{-# LANGUAGE ScopedTypeVariables #-}
12+{-# LANGUAGE TypeFamilies #-}
13+{-# LANGUAGE UndecidableInstances #-}
14+#ifdef USE_REFLEX_OPTIMIZER
15+{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
16+#endif
17+module Reflex.EventWriter
18+ ( EventWriterT (..)
19+ , runEventWriterT
20+ , EventWriter(..)
21+ , runWithReplaceEventWriterTWith
22+ , sequenceDMapWithAdjustEventWriterTWith
23+ ) where
24+
25+import Reflex.Class
26+import Reflex.Host.Class
27+import Reflex.PerformEvent.Class
28+import Reflex.PostBuild.Class
29+import Reflex.TriggerEvent.Class
30+
31+import Control.Monad.Exception
32+import Control.Monad.Identity
33+import Control.Monad.Reader
34+import Control.Monad.Ref
35+import Control.Monad.State.Strict
36+import Data.Dependent.Map (DMap, DSum (..))
37+import qualified Data.Dependent.Map as DMap
38+import Data.Foldable
39+import Data.Functor.Misc
40+import qualified Data.List.NonEmpty as NonEmpty
41+import Data.Maybe
42+import Data.Semigroup
43+import Data.Sequence
44+import Data.Some (Some)
45+import qualified Data.Some as Some
46+import Data.Tuple
47+import Data.Unique.Tag
48+
49+-- | 'EventWriter' efficiently collects 'Event' values using 'tellEvent'
50+-- and combines them monoidally to provide an 'Event' result.
51+class (Monad m, Monoid w) => EventWriter t w m | m -> t w where
52+ tellEvent :: Event t w -> m ()
53+
54+-- | A basic implementation of 'EventWriter'.
55+newtype EventWriterT t w m a = EventWriterT { unEventWriterT :: StateT (Seq (Event t w)) m a }
56+ deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException)
57+
58+-- | Run a 'EventWriterT' action.
59+runEventWriterT :: (Reflex t, Monad m, Semigroup w) => EventWriterT t w m a -> m (a, Event t w)
60+runEventWriterT (EventWriterT a) = do
61+ (result, requests) <- runStateT a mempty
62+ return (result, mconcat $ toList requests)
63+
64+instance (Reflex t, Monad m, Monoid w) => EventWriter t w (EventWriterT t w m) where
65+ tellEvent w = EventWriterT $ modify (|> w)
66+
67+instance MonadTrans (EventWriterT t w) where
68+ lift = EventWriterT . lift
69+
70+instance MonadSample t m => MonadSample t (EventWriterT t w m) where
71+ sample = lift . sample
72+
73+instance MonadHold t m => MonadHold t (EventWriterT t w m) where
74+ hold v0 = lift . hold v0
75+ holdDyn v0 = lift . holdDyn v0
76+ holdIncremental v0 = lift . holdIncremental v0
77+
78+instance (Reflex t, MonadAdjust t m, MonadHold t m, Monoid w, Semigroup w) => MonadAdjust t (EventWriterT t w m) where
79+ runWithReplace = runWithReplaceEventWriterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
80+ sequenceDMapWithAdjust = sequenceDMapWithAdjustEventWriterTWith $ \dm0 dm' -> lift $ sequenceDMapWithAdjust dm0 dm'
81+
82+-- | Given a function like 'runWithReplace' for the underlying monad, implement
83+-- 'runWithReplace' for 'EventWriterT'. This is necessary when the underlying
84+-- monad doesn't have a 'MonadAdjust' instance or to override the default
85+-- 'MonadAdjust' behavior.
86+runWithReplaceEventWriterTWith :: forall m t w a b. (Reflex t, MonadHold t m, Monoid w)
87+ => (forall a' b'. m a' -> Event t (m b') -> EventWriterT t w m (a', Event t b'))
88+ -> EventWriterT t w m a
89+ -> Event t (EventWriterT t w m b)
90+ -> EventWriterT t w m (a, Event t b)
91+runWithReplaceEventWriterTWith f a0 a' = do
92+ let g :: EventWriterT t w m c -> m (c, Seq (Event t w))
93+ g (EventWriterT r) = runStateT r mempty
94+ (result0, result') <- f (g a0) $ g <$> a'
95+ request <- holdDyn (fmap (mconcat . NonEmpty.toList) $ mergeList $ toList $ snd result0) $ fmap (mconcat . NonEmpty.toList) . mergeList . toList . snd <$> result'
96+ -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)
97+ EventWriterT $ modify $ flip (|>) $ coincidence $ updated request
98+ EventWriterT $ modify $ flip (|>) $ switch $ current request
99+ return (fst result0, fst <$> result')
100+
101+-- | Like 'runWithReplaceEventWriterTWith', but for 'sequenceDMapWithAdjust'.
102+sequenceDMapWithAdjustEventWriterTWith :: (GCompare k, Reflex t, MonadHold t m, Monoid w, Semigroup w)
103+ => (forall k'. GCompare k'
104+ => DMap k' m
105+ -> Event t (PatchDMap k' m)
106+ -> EventWriterT t w m (DMap k' Identity, Event t (PatchDMap k' Identity))
107+ )
108+ -> DMap k (EventWriterT t w m)
109+ -> Event t (PatchDMap k (EventWriterT t w m))
110+ -> EventWriterT t w m (DMap k Identity, Event t (PatchDMap k Identity))
111+sequenceDMapWithAdjustEventWriterTWith f (dm0 :: DMap k (EventWriterT t w m)) dm' = do
112+ let inputTransform :: forall a. DMapTransform a k (WrapArg ((,) (Seq (Event t w))) k) (EventWriterT t w m) m
113+ inputTransform = DMapTransform WrapArg (\(EventWriterT v) -> swap <$> runStateT v mempty)
114+ (children0, children') <- f (mapKeysAndValuesMonotonic inputTransform dm0) $ mapPatchKeysAndValuesMonotonic inputTransform <$> dm'
115+ let result0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, v)) -> k :=> Identity v) children0
116+ result' = ffor children' $ \(PatchDMap p) -> PatchDMap $
117+ mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mv) -> k :=> ComposeMaybe (fmap (Identity . snd . runIdentity) mv)) p
118+ requests0 :: DMap (Const2 (Some k) w) (Event t)
119+ requests0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (r, _)) -> Const2 (Some.This k) :=> mconcat (toList r)) children0
120+ requests' :: Event t (PatchDMap (Const2 (Some k) w) (Event t))
121+ requests' = ffor children' $ \(PatchDMap p) -> PatchDMap $
122+ mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mv) -> Const2 (Some.This k) :=> ComposeMaybe (fmap (mconcat . toList . fst . runIdentity) mv)) p
123+ childRequestMap <- holdIncremental requests0 requests'
124+ -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)
125+ EventWriterT $ modify $ flip (|>) $ coincidence $ ffor requests' $ \(PatchDMap p) -> mconcat $ toList $ catMaybes $ ffor (DMap.toList p) $ \(Const2 _ :=> ComposeMaybe me) -> me
126+ EventWriterT $ modify $ flip (|>) $ ffor (mergeIncremental childRequestMap) $ \m ->
127+ mconcat $ (\(Const2 _ :=> Identity reqs) -> reqs) <$> DMap.toList m
128+ return (result0, result')
129+
130+instance PerformEvent t m => PerformEvent t (EventWriterT t w m) where
131+ type Performable (EventWriterT t w m) = Performable m
132+ performEvent_ = lift . performEvent_
133+ performEvent = lift . performEvent
134+
135+instance PostBuild t m => PostBuild t (EventWriterT t w m) where
136+ getPostBuild = lift getPostBuild
137+
138+instance TriggerEvent t m => TriggerEvent t (EventWriterT t w m) where
139+ newTriggerEvent = lift newTriggerEvent
140+ newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
141+ newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
142+
143+instance MonadReader r m => MonadReader r (EventWriterT t w m) where
144+ ask = lift ask
145+ local f (EventWriterT a) = EventWriterT $ mapStateT (local f) a
146+ reader = lift . reader
147+
148+instance MonadRef m => MonadRef (EventWriterT t w m) where
149+ type Ref (EventWriterT t w m) = Ref m
150+ newRef = lift . newRef
151+ readRef = lift . readRef
152+ writeRef r = lift . writeRef r
153+
154+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (EventWriterT t w m) where
155+ newEventWithTrigger = lift . newEventWithTrigger
156+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
157+
158+--------------------------------------------------------------------------------
159+-- Internal functions
160+--------------------------------------------------------------------------------
161+
162+data DMapTransform (a :: *) k k' v v' = forall (b :: *). DMapTransform !(k a -> k' b) !(v a -> v' b)
163+
164+mapPatchKeysAndValuesMonotonic :: (forall a. DMapTransform a k k' v v') -> PatchDMap k v -> PatchDMap k' v'
165+mapPatchKeysAndValuesMonotonic x (PatchDMap p) = PatchDMap $ mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mv) -> case x of DMapTransform f g -> f k :=> ComposeMaybe (fmap g mv)) p
166+
167+mapKeysAndValuesMonotonic :: (forall a. DMapTransform a k k' v v') -> DMap k v -> DMap k' v'
168+mapKeysAndValuesMonotonic x = mapKeyValuePairsMonotonic $ \(k :=> v) -> case x of
169+ DMapTransform f g -> f k :=> g v
src/Reflex/Requester/Base.hs+51−98
@@ -4,12 +4,12 @@
44{-# LANGUAGE ExistentialQuantification #-}
55{-# LANGUAGE FlexibleInstances #-}
66{-# LANGUAGE GeneralizedNewtypeDeriving #-}
7−{-# LANGUAGE KindSignatures #-}
87{-# LANGUAGE MultiParamTypeClasses #-}
98{-# LANGUAGE Rank2Types #-}
109{-# LANGUAGE ScopedTypeVariables #-}
1110{-# LANGUAGE TypeFamilies #-}
1211{-# LANGUAGE UndecidableInstances #-}
12+{-# LANGUAGE StandaloneDeriving #-}
1313#ifdef USE_REFLEX_OPTIMIZER
1414{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
1515#endif
@@ -21,6 +21,7 @@ module Reflex.Requester.Base
2121 ) where
2222
2323import Reflex.Class
24+import Reflex.EventWriter
2425import Reflex.Host.Class
2526import Reflex.PerformEvent.Class
2627import Reflex.PostBuild.Class
@@ -33,31 +34,34 @@ import Control.Monad.Primitive
3334import Control.Monad.Reader
3435import Control.Monad.Ref
3536import Control.Monad.State.Strict
37+import Data.Coerce
3638import Data.Dependent.Map (DMap, DSum (..))
3739import qualified Data.Dependent.Map as DMap
3840import Data.Functor.Misc
39−import qualified Data.List.NonEmpty as NonEmpty
40−import Data.Maybe
41−import Data.Some (Some)
42−import qualified Data.Some as Some
43−import Data.Tuple
4441import Data.Unique.Tag
4542
4643-- | A basic implementation of 'Requester'.
47−newtype RequesterT t request response m a = RequesterT { unRequesterT :: StateT [Event t (DMap (Tag (PrimState m)) request)] (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) a }
44+newtype RequesterT t request response m a = RequesterT { unRequesterT :: EventWriterT t (DMap (Tag (PrimState m)) request) (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) a }
4845 deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException)
4946
47+deriving instance MonadSample t m => MonadSample t (RequesterT t request response m)
48+deriving instance MonadHold t m => MonadHold t (RequesterT t request response m)
49+deriving instance PostBuild t m => PostBuild t (RequesterT t request response m)
50+deriving instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m)
51+
5052-- | Run a 'RequesterT' action. The resulting 'Event' will fire whenever
5153-- requests are made, and responses should be provided in the input 'Event'.
5254-- The 'Tag' keys will be used to return the responses to the same place the
5355-- requests were issued.
56+
5457runRequesterT :: (Reflex t, Monad m)
5558 => RequesterT t request response m a
5659 -> Event t (DMap (Tag (PrimState m)) response)
5760 -> m (a, Event t (DMap (Tag (PrimState m)) request))
5861runRequesterT (RequesterT a) responses = do
59− (result, requests) <- runReaderT (runStateT a mempty) $ fan $ mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e) <$> responses
60− return (result, mergeWith DMap.union requests)
62+ (result, requests) <- runReaderT (runEventWriterT a) $ fan $
63+ mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e) <$> responses
64+ return (result, requests)
6165
6266instance (Reflex t, PrimMonad m) => Requester t (RequesterT t request response m) where
6367 type Request (RequesterT t request response m) = request
@@ -66,96 +70,17 @@ instance (Reflex t, PrimMonad m) => Requester t (RequesterT t request response m
6670 t <- lift newTag
6771 s <- RequesterT ask
6872 (req, result) <- a $ select s $ WrapArg t
69− RequesterT $ modify $ (:) $ DMap.singleton t <$> req
73+ RequesterT $ tellEvent $ DMap.singleton t <$> req
7074 return result
7175
7276instance MonadTrans (RequesterT t request response) where
7377 lift = RequesterT . lift . lift
7478
75−instance MonadSample t m => MonadSample t (RequesterT t request response m) where
76− sample = lift . sample
77−
78−instance MonadHold t m => MonadHold t (RequesterT t request response m) where
79− hold v0 = lift . hold v0
80− holdDyn v0 = lift . holdDyn v0
81− holdIncremental v0 = lift . holdIncremental v0
82−
83−instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (RequesterT t request response m) where
84− runWithReplace = runWithReplaceRequesterTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
85− sequenceDMapWithAdjust = sequenceDMapWithAdjustRequesterTWith $ \dm0 dm' -> lift $ sequenceDMapWithAdjust dm0 dm'
86−
87−-- | Given a function like 'runWithReplace' for the underlying monad, implement
88−-- 'runWithReplace' for 'RequesterT'. This is necessary when the underlying
89−-- monad doesn't have a 'MonadAdjust' instance or to override the default
90−-- 'MonadAdjust' behavior.
91−runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m)
92− => (forall a' b'.
93− m a'
94− -> Event t (m b')
95− -> RequesterT t request response m (a', Event t b')
96− )
97− -> RequesterT t request response m a
98− -> Event t (RequesterT t request response m b)
99− -> RequesterT t request response m (a, Event t b)
100−runWithReplaceRequesterTWith f a0 a' = do
101− response <- RequesterT ask
102− let g :: RequesterT t request response m c -> m (c, [Event t (DMap (Tag (PrimState m)) request)])
103− g (RequesterT r) = runReaderT (runStateT r mempty) response
104− (result0, result') <- f (g a0) $ g <$> a'
105− request <- holdDyn (fmap (mconcat . NonEmpty.toList) $ mergeList $ snd result0) $ fmap (mconcat . NonEmpty.toList) . mergeList . snd <$> result'
106− -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)
107− RequesterT $ modify $ (:) $ coincidence $ updated request
108− RequesterT $ modify $ (:) $ switch $ current request
109− return (fst result0, fst <$> result')
110−
111−-- | Like 'runWithReplaceRequesterTWith', but for 'sequenceDMapWithAdjust'.
112−sequenceDMapWithAdjustRequesterTWith :: (GCompare k, Reflex t, MonadHold t m)
113− => (forall k'. GCompare k'
114− => DMap k' m
115− -> Event t (PatchDMap k' m)
116− -> RequesterT t request response m (DMap k' Identity, Event t (PatchDMap k' Identity))
117− )
118− -> DMap k (RequesterT t request response m)
119− -> Event t (PatchDMap k (RequesterT t request response m))
120− -> RequesterT t request response m (DMap k Identity, Event t (PatchDMap k Identity))
121−sequenceDMapWithAdjustRequesterTWith f (dm0 :: DMap k (RequesterT t request response m)) dm' = do
122− response <- RequesterT ask
123− let inputTransform :: forall a. DMapTransform a k (WrapArg ((,) [Event t (DMap (Tag (PrimState m)) request)]) k) (RequesterT t request response m) m
124− inputTransform = DMapTransform WrapArg (\(RequesterT v) -> swap <$> runReaderT (runStateT v mempty) response)
125− (children0, children') <- f (mapKeysAndValuesMonotonic inputTransform dm0) $ mapPatchKeysAndValuesMonotonic inputTransform <$> dm'
126− let result0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, v)) -> k :=> Identity v) children0
127− result' = ffor children' $ \(PatchDMap p) -> PatchDMap $
128− mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mv) -> k :=> ComposeMaybe (fmap (Identity . snd . runIdentity) mv)) p
129− requests0 :: DMap (Const2 (Some k) (DMap (Tag (PrimState m)) request)) (Event t)
130− requests0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (r, _)) -> Const2 (Some.This k) :=> mergeWith DMap.union r) children0
131− requests' :: Event t (PatchDMap (Const2 (Some k) (DMap (Tag (PrimState m)) request)) (Event t))
132− requests' = ffor children' $ \(PatchDMap p) -> PatchDMap $
133− mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mv) -> Const2 (Some.This k) :=> ComposeMaybe (fmap (mergeWith DMap.union . fst . runIdentity) mv)) p
134− childRequestMap <- holdIncremental requests0 requests'
135− -- We add these two separately to take advantage of the free merge being done later. The coincidence case must come first so that it has precedence if both fire simultaneously. (Really, we should probably block the 'switch' whenever 'updated' fires, but switchPromptlyDyn has the same issue.)
136− RequesterT $ modify $ (:) $ coincidence $ ffor requests' $ \(PatchDMap p) -> mergeWith DMap.union $ catMaybes $ ffor (DMap.toList p) $ \(Const2 _ :=> ComposeMaybe me) -> me
137− RequesterT $ modify $ (:) $ ffor (mergeIncremental childRequestMap) $ \m ->
138− mconcat $ (\(Const2 _ :=> Identity reqs) -> reqs) <$> DMap.toList m
139− return (result0, result')
140−
14179instance PerformEvent t m => PerformEvent t (RequesterT t request response m) where
14280 type Performable (RequesterT t request response m) = Performable m
14381 performEvent_ = lift . performEvent_
14482 performEvent = lift . performEvent
14583
146−instance PostBuild t m => PostBuild t (RequesterT t request response m) where
147− getPostBuild = lift getPostBuild
148−
149−instance TriggerEvent t m => TriggerEvent t (RequesterT t request response m) where
150− newTriggerEvent = lift newTriggerEvent
151− newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
152− newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
153−
154−instance MonadReader r m => MonadReader r (RequesterT t request response m) where
155− ask = lift ask
156− local f (RequesterT a) = RequesterT $ mapStateT (mapReaderT $ local f) a
157− reader = lift . reader
158−
15984instance MonadRef m => MonadRef (RequesterT t request response m) where
16085 type Ref (RequesterT t request response m) = Ref m
16186 newRef = lift . newRef
@@ -166,15 +91,43 @@ instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequesterT
16691 newEventWithTrigger = lift . newEventWithTrigger
16792 newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
16893
169−--------------------------------------------------------------------------------
170−-- Internal functions
171−--------------------------------------------------------------------------------
94+instance MonadReader r m => MonadReader r (RequesterT t request response m) where
95+ ask = lift ask
96+ local f (RequesterT (EventWriterT a)) = RequesterT $ EventWriterT $ mapStateT (mapReaderT $ local f) a
97+ reader = lift . reader
17298
173−data DMapTransform (a :: *) k k' v v' = forall (b :: *). DMapTransform !(k a -> k' b) !(v a -> v' b)
99+instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (RequesterT t request response m) where
100+ runWithReplace (RequesterT a) em = RequesterT $ runWithReplace a (coerceEvent em)
101+ sequenceDMapWithAdjust dm edm = RequesterT $ sequenceDMapWithAdjust (coerce dm) (coerceEvent edm)
174102
175−mapPatchKeysAndValuesMonotonic :: (forall a. DMapTransform a k k' v v') -> PatchDMap k v -> PatchDMap k' v'
176−mapPatchKeysAndValuesMonotonic x (PatchDMap p) = PatchDMap $ mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mv) -> case x of DMapTransform f g -> f k :=> ComposeMaybe (fmap g mv)) p
103+runWithReplaceRequesterTWith :: forall m t request response a b. (Reflex t, MonadHold t m)
104+ => (forall a' b'. m a' -> Event t (m b') -> RequesterT t request response m (a', Event t b'))
105+ -> RequesterT t request response m a
106+ -> Event t (RequesterT t request response m b)
107+ -> RequesterT t request response m (a, Event t b)
108+runWithReplaceRequesterTWith f a0 a' =
109+ let f' :: forall a' b'. ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m a'
110+ -> Event t (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m b')
111+ -> EventWriterT t (DMap (Tag (PrimState m)) request) (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) (a', Event t b')
112+ f' x y = do
113+ r <- EventWriterT $ ask
114+ unRequesterT (f (runReaderT x r) (fmap (`runReaderT` r) y))
115+ in RequesterT $ runWithReplaceEventWriterTWith f' (coerce a0) (coerceEvent a')
177116
178−mapKeysAndValuesMonotonic :: (forall a. DMapTransform a k k' v v') -> DMap k v -> DMap k' v'
179−mapKeysAndValuesMonotonic x = mapKeyValuePairsMonotonic $ \(k :=> v) -> case x of
180− DMapTransform f g -> f k :=> g v
117+sequenceDMapWithAdjustRequesterTWith :: (GCompare k, Reflex t, MonadHold t m)
118+ => (forall k'. GCompare k' => DMap k' m -> Event t (PatchDMap k' m) -> RequesterT t request response m (DMap k' Identity, Event t (PatchDMap k' Identity)))
119+ -> DMap k (RequesterT t request response m)
120+ -> Event t (PatchDMap k (RequesterT t request response m))
121+ -> RequesterT t request response m (DMap k Identity, Event t (PatchDMap k Identity))
122+sequenceDMapWithAdjustRequesterTWith f (dm0 :: DMap k (RequesterT t request response m)) dm' =
123+ let dmapUnwrap r = mapKeyValuePairsMonotonic $ \(k :=> v) -> k :=> runReaderT v r
124+ patchDmapUnwrap r (PatchDMap p) = PatchDMap $ mapKeyValuePairsMonotonic
125+ (\(k :=> ComposeMaybe mv) -> k :=> ComposeMaybe (fmap (`runReaderT` r) mv)) p
126+ f' :: forall k'. GCompare k'
127+ => DMap k' (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m)
128+ -> Event t (PatchDMap k' (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m))
129+ -> EventWriterT t (DMap (Tag (PrimState m)) request) (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) (DMap k' Identity, Event t (PatchDMap k' Identity))
130+ f' x y = do
131+ r <- EventWriterT $ ask
132+ unRequesterT (f (dmapUnwrap r x) (fmap (patchDmapUnwrap r) y))
133+ in RequesterT $ sequenceDMapWithAdjustEventWriterTWith f' (coerce dm0) (coerceEvent dm')
test/EventWriterT.hsnew file+61
@@ -0,0 +1,61 @@
1+{-# LANGUAGE FlexibleContexts, GADTs #-}
2+module Main where
3+
4+import Control.Monad
5+import Control.Monad.IO.Class
6+import Control.Monad.Ref
7+import Data.Dependent.Sum
8+import Data.IORef
9+import Data.List
10+import Data.Functor.Identity
11+
12+import Reflex
13+import Reflex.EventWriter
14+import Reflex.Host.Class
15+import Reflex.PerformEvent.Base
16+
17+import System.Exit (exitFailure, exitSuccess)
18+
19+main :: IO ()
20+main = do
21+ (Just out1, Nothing) <- runApp app1
22+ print out1
23+ (Just out2, Just (out3, out4)) <- runApp app2
24+ print out2
25+ print out3
26+ print out4
27+ when (sort out1 /= out1 || map (+1) out2 /= out3 || out3 /= out4) exitFailure
28+
29+runApp :: (Show a, t ~ SpiderTimeline Global, m ~ SpiderHost Global)
30+ => (Event t () -> EventWriterT t [a] (PerformEventT t m) (Maybe (Ref m (Maybe (EventTrigger t ())))))
31+ -> IO (Maybe [a], Maybe ([a], [a]))
32+runApp x = runSpiderHost $ do
33+ (pulseE, pulseTriggerRef) <- newEventWithTriggerRef
34+ ((mactuateRef, e), FireCommand fire) <- hostPerformEventT $ runEventWriterT (x pulseE)
35+ hnd <- subscribeEvent e
36+ out1 <- fireEventRefAndRead pulseTriggerRef () hnd
37+ out2 <- fmap join $ forM mactuateRef $ \actuateRef -> do
38+ let readPhase = do
39+ mGetValue <- readEvent hnd
40+ case mGetValue of
41+ Nothing -> return Nothing
42+ Just getValue -> fmap Just getValue
43+ mactuate <- readRef actuateRef
44+ mpulse <- readRef pulseTriggerRef
45+ forM ((,) <$> mactuate <*> mpulse) $ \(actuate, pulse) -> do
46+ _ <- fire [actuate :=> Identity ()] $ return ()
47+ [Just a] <- fire [pulse :=> Identity ()] $ readPhase
48+ [Just b, Nothing] <- fire [actuate :=> Identity (), pulse :=> Identity ()] $ readPhase
49+ return (a,b)
50+ return (out1, out2)
51+
52+app1 :: (Reflex t, Ref m ~ IORef, EventWriter t [Int] m) => Event t () -> m (Maybe (Ref m (Maybe (EventTrigger t ()))))
53+app1 e = do
54+ forM_ [1..10] $ \i -> tellEvent ([i] <$ e)
55+ return Nothing
56+
57+app2 :: (Reflex t, Ref m ~ IORef, EventWriter t [Int] m, MonadAdjust t m, MonadReflexCreateTrigger t m, MonadRef m) => Event t () -> m (Maybe (Ref m (Maybe (EventTrigger t ()))))
58+app2 e = do
59+ (pulse, pulseTriggerRef) <- newEventWithTriggerRef
60+ forM_ [1,3..9] $ \i -> runWithReplace (tellEvent ([i] <$ e)) $ ffor pulse $ \_ -> tellEvent ([i+1] <$ e)
61+ return (Just pulseTriggerRef)
test/RequesterT.hsnew file+70
@@ -0,0 +1,70 @@
1+{-# LANGUAGE FlexibleContexts, GADTs #-}
2+module Main where
3+
4+import Control.Monad
5+import Control.Monad.IO.Class
6+import Control.Monad.Ref
7+import qualified Data.Dependent.Map as DMap
8+import Data.Dependent.Sum
9+import Data.IORef
10+import Data.List
11+import Data.Functor.Identity
12+
13+import Reflex
14+import Reflex.Host.Class
15+import Reflex.PerformEvent.Base
16+import Reflex.Requester.Base
17+import Reflex.Requester.Class
18+
19+import System.Exit (exitFailure, exitSuccess)
20+
21+data RequestInt a where
22+ RequestInt :: Int -> RequestInt Int
23+
24+main :: IO ()
25+main = do
26+ (Just out1, Nothing) <- runApp app1
27+ print out1
28+ (Just out2, Just (out3, out4)) <- runApp app2
29+ print out2
30+ print out3
31+ print out4
32+ when (sort out1 /= out1 || map (+1) out2 /= out3 || out3 /= out4) exitFailure
33+
34+runApp :: (t ~ SpiderTimeline Global, m ~ SpiderHost Global)
35+ => (Event t () -> RequesterT t RequestInt Identity (PerformEventT t m) (Maybe (Ref m (Maybe (EventTrigger t ())))))
36+ -> IO (Maybe [Int], Maybe ([Int], [Int]))
37+runApp x = runSpiderHost $ do
38+ (pulseE, pulseTriggerRef) <- newEventWithTriggerRef
39+ ((mactuateRef, e), FireCommand fire) <- hostPerformEventT $ runRequesterT (x pulseE) never
40+ hnd <- subscribeEvent (map unwrapRequest . DMap.toList <$> e)
41+ out1 <- fireEventRefAndRead pulseTriggerRef () hnd
42+ out2 <- fmap join $ forM mactuateRef $ \actuateRef -> do
43+ let readPhase = do
44+ mGetValue <- readEvent hnd
45+ case mGetValue of
46+ Nothing -> return Nothing
47+ Just getValue -> fmap Just getValue
48+ mactuate <- readRef actuateRef
49+ mpulse <- readRef pulseTriggerRef
50+ forM ((,) <$> mactuate <*> mpulse) $ \(actuate, pulse) -> do
51+ _ <- fire [actuate :=> Identity ()] $ return ()
52+ [Just a] <- fire [pulse :=> Identity ()] $ readPhase
53+ [Just b, Nothing] <- fire [actuate :=> Identity (), pulse :=> Identity ()] $ readPhase
54+ return (a,b)
55+ return (out1, out2)
56+
57+unwrapRequest :: DSum tag RequestInt -> Int
58+unwrapRequest (_ :=> RequestInt i) = i
59+
60+app1 :: (Reflex t, Ref m ~ IORef, Requester t m, Response m ~ Identity, Request m ~ RequestInt) => Event t () -> m (Maybe (Ref m (Maybe (EventTrigger t ()))))
61+app1 e = do
62+ forM_ [1..10] $ \i -> requestingIdentity (RequestInt i <$ e)
63+ return Nothing
64+
65+app2 :: (Reflex t, Ref m ~ IORef, Requester t m, Response m ~ Identity, Request m ~ RequestInt, MonadAdjust t m, MonadReflexCreateTrigger t m, MonadRef m) => Event t () -> m (Maybe (Ref m (Maybe (EventTrigger t ()))))
66+app2 e = do
67+ (pulse, pulseTriggerRef) <- newEventWithTriggerRef
68+ forM_ [1,3..9] $ \i -> runWithReplace (requestingIdentity (RequestInt i <$ e)) $ ffor pulse $ \_ -> requestingIdentity (RequestInt (i+1) <$ e)
69+ return (Just pulseTriggerRef)
70+