git.iko.soy/reflex
on develop help sign in
Merge pull request #220 from reflex-frp/revert-make-PerformEventT-a-transformer
2d67124Ryan Trinkle
src/Reflex/NotReady/Class.hs+33−9
compare with develop
unifiedsplit
@@ -19,7 +19,8 @@ import Control.Monad.Trans
19import Reflex.Class
19import Reflex.Class
20import Reflex.DynamicWriter.Base (DynamicWriterT)
20import Reflex.DynamicWriter.Base (DynamicWriterT)
21import Reflex.EventWriter.Base (EventWriterT)
21import Reflex.EventWriter.Base (EventWriterT)
22+import Reflex.Host.Class
22−import Reflex.PerformEvent.Base (PerformEventT)
23+import Reflex.PerformEvent.Base (PerformEventT (..))
23import Reflex.PostBuild.Base (PostBuildT)
24import Reflex.PostBuild.Base (PostBuildT)
24import Reflex.Query.Base (QueryT)
25import Reflex.Query.Base (QueryT)
25import Reflex.Requester.Base (RequesterT)
26import Reflex.Requester.Base (RequesterT)
@@ -34,11 +35,34 @@ class Monad m => NotReady t m | m -> t where
34 default notReady :: (MonadTrans f, m ~ f m', NotReady t m') => m ()
35 default notReady :: (MonadTrans f, m ~ f m', NotReady t m') => m ()
35 notReady = lift notReady
36 notReady = lift notReady
36
37
37−instance NotReady t m => NotReady t (ReaderT r m)
38+instance NotReady t m => NotReady t (ReaderT r m) where
39+ notReadyUntil = lift . notReadyUntil
40+ notReady = lift notReady
41+
38−instance NotReady t m => NotReady t (PostBuildT t m)
42+instance NotReady t m => NotReady t (PostBuildT t m) where
43+ notReadyUntil = lift . notReadyUntil
44+ notReady = lift notReady
45+
39−instance NotReady t m => NotReady t (EventWriterT t w m)
46+instance NotReady t m => NotReady t (EventWriterT t w m) where
47+ notReadyUntil = lift . notReadyUntil
48+ notReady = lift notReady
49+
40−instance NotReady t m => NotReady t (DynamicWriterT t w m)
50+instance NotReady t m => NotReady t (DynamicWriterT t w m) where
51+ notReadyUntil = lift . notReadyUntil
52+ notReady = lift notReady
53+
41−instance NotReady t m => NotReady t (QueryT t q m)
54+instance NotReady t m => NotReady t (QueryT t q m) where
55+ notReadyUntil = lift . notReadyUntil
56+ notReady = lift notReady
57+
42−instance NotReady t m => NotReady t (PerformEventT t m)
58+instance (ReflexHost t, NotReady t (HostFrame t)) => NotReady t (PerformEventT t m) where
59+ notReadyUntil = PerformEventT . notReadyUntil
60+ notReady = PerformEventT notReady
61+
43−instance NotReady t m => NotReady t (RequesterT t request response m)
62+instance NotReady t m => NotReady t (RequesterT t request response m) where
63+ notReadyUntil = lift . notReadyUntil
64+ notReady = lift notReady
65+
44−instance NotReady t m => NotReady t (TriggerEventT t m)
66+instance NotReady t m => NotReady t (TriggerEventT t m) where
67+ notReadyUntil = lift . notReadyUntil
68+ notReady = lift notReady
src/Reflex/PerformEvent/Base.hs+46−49
@@ -53,31 +53,31 @@ newtype FireCommand t m = FireCommand { runFireCommand :: forall a. [DSum (Event
53
53
54-- | Provides a basic implementation of 'PerformEvent'. Note that, despite the
54-- | Provides a basic implementation of 'PerformEvent'. Note that, despite the
55-- name, 'PerformEventT' is not an instance of 'MonadTrans'.
55-- name, 'PerformEventT' is not an instance of 'MonadTrans'.
56−newtype PerformEventT t m a = PerformEventT { unPerformEventT :: RequesterT t m Identity m a }
56+newtype PerformEventT t m a = PerformEventT { unPerformEventT :: RequesterT t (HostFrame t) Identity (HostFrame t) a }
57−
57+
58−deriving instance Functor m => Functor (PerformEventT t m)
58+deriving instance ReflexHost t => Functor (PerformEventT t m)
59−deriving instance Monad m => Applicative (PerformEventT t m)
59+deriving instance ReflexHost t => Applicative (PerformEventT t m)
60−deriving instance Monad m => Monad (PerformEventT t m)
60+deriving instance ReflexHost t => Monad (PerformEventT t m)
61−deriving instance MonadFix m => MonadFix (PerformEventT t m)
61+deriving instance ReflexHost t => MonadFix (PerformEventT t m)
62−deriving instance MonadIO m => MonadIO (PerformEventT t m)
62+deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (PerformEventT t m)
63−deriving instance MonadException m => MonadException (PerformEventT t m)
63+deriving instance (ReflexHost t, MonadException (HostFrame t)) => MonadException (PerformEventT t m)
64−deriving instance (Monad m, Monoid a) => Monoid (PerformEventT t m a)
64+deriving instance (ReflexHost t, Monoid a) => Monoid (PerformEventT t m a)
65−deriving instance (Monad m, S.Semigroup a) => S.Semigroup (PerformEventT t m a)
65+deriving instance (ReflexHost t, S.Semigroup a) => S.Semigroup (PerformEventT t m a)
66−
66+
67−instance (PrimMonad m, ReflexHost t) => PrimMonad (PerformEventT t m) where
67+instance (PrimMonad (HostFrame t), ReflexHost t) => PrimMonad (PerformEventT t m) where
68− type PrimState (PerformEventT t m) = PrimState m
68+ type PrimState (PerformEventT t m) = PrimState (HostFrame t)
69− primitive = lift . primitive
69+ primitive = PerformEventT . lift . primitive
70−
70+
71−instance (Monad m, Reflex t, Ref m ~ Ref IO) => PerformEvent t (PerformEventT t m) where
71+instance (ReflexHost t, Ref m ~ Ref IO) => PerformEvent t (PerformEventT t m) where
72− type Performable (PerformEventT t m) = m
72+ type Performable (PerformEventT t m) = HostFrame t
73 {-# INLINABLE performEvent_ #-}
73 {-# INLINABLE performEvent_ #-}
74 performEvent_ = PerformEventT . requesting_
74 performEvent_ = PerformEventT . requesting_
75 {-# INLINABLE performEvent #-}
75 {-# INLINABLE performEvent #-}
76 performEvent = PerformEventT . requestingIdentity
76 performEvent = PerformEventT . requestingIdentity
77
77
78−instance (Reflex t, MonadHold t m, MonadFix m, PrimMonad m) => Adjustable t (PerformEventT t m) where
78+instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT t m) where
79 runWithReplace outerA0 outerA' = PerformEventT $ runWithReplaceRequesterTWith f (coerce outerA0) (coerceEvent outerA')
79 runWithReplace outerA0 outerA' = PerformEventT $ runWithReplaceRequesterTWith f (coerce outerA0) (coerceEvent outerA')
80− where f :: m a -> Event t (m b) -> RequesterT t m Identity m (a, Event t b)
80+ where f :: HostFrame t a -> Event t (HostFrame t b) -> RequesterT t (HostFrame t) Identity (HostFrame t) (a, Event t b)
81 f a0 a' = do
81 f a0 a' = do
82 result0 <- lift a0
82 result0 <- lift a0
83 result' <- requestingIdentity a'
83 result' <- requestingIdentity a'
@@ -86,33 +86,33 @@ instance (Reflex t, MonadHold t m, MonadFix m, PrimMonad m) => Adjustable t (Per
86 traverseDMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithKey) mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
86 traverseDMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithKey) mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
87 traverseDMapWithKeyWithAdjustWithMove f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithMoveWithKey) mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
87 traverseDMapWithKeyWithAdjustWithMove f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithMoveWithKey) mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
88
88
89−defaultAdjustBase :: forall t v v2 k' p m. (Monad m, PrimMonad m, Reflex t)
89+defaultAdjustBase :: forall t v v2 k' p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)
90− => ((forall a. k' a -> v a -> m (v2 a)) -> p k' v -> m (p k' v2))
90+ => ((forall a. k' a -> v a -> HostFrame t (v2 a)) -> p k' v -> HostFrame t (p k' v2))
91− -> (forall a. k' a -> v a -> m (v2 a))
91+ -> (forall a. k' a -> v a -> HostFrame t (v2 a))
92 -> DMap k' v
92 -> DMap k' v
93 -> Event t (p k' v)
93 -> Event t (p k' v)
94− -> RequesterT t m Identity m (DMap k' v2, Event t (p k' v2))
94+ -> RequesterT t (HostFrame t) Identity (HostFrame t) (DMap k' v2, Event t (p k' v2))
95defaultAdjustBase traversePatchWithKey f' dm0 dm' = do
95defaultAdjustBase traversePatchWithKey f' dm0 dm' = do
96 result0 <- lift $ DMap.traverseWithKey f' dm0
96 result0 <- lift $ DMap.traverseWithKey f' dm0
97 result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f'
97 result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f'
98 return (result0, result')
98 return (result0, result')
99
99
100−defaultAdjustIntBase :: forall t v v2 p m. (Monad m, PrimMonad m, Reflex t)
100+defaultAdjustIntBase :: forall t v v2 p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)
101− => ((IntMap.Key -> v -> m v2) -> p v -> m (p v2))
101+ => ((IntMap.Key -> v -> HostFrame t v2) -> p v -> HostFrame t (p v2))
102− -> (IntMap.Key -> v -> m v2)
102+ -> (IntMap.Key -> v -> HostFrame t v2)
103 -> IntMap v
103 -> IntMap v
104 -> Event t (p v)
104 -> Event t (p v)
105− -> RequesterT t m Identity m (IntMap v2, Event t (p v2))
105+ -> RequesterT t (HostFrame t) Identity (HostFrame t) (IntMap v2, Event t (p v2))
106defaultAdjustIntBase traversePatchWithKey f' dm0 dm' = do
106defaultAdjustIntBase traversePatchWithKey f' dm0 dm' = do
107 result0 <- lift $ IntMap.traverseWithKey f' dm0
107 result0 <- lift $ IntMap.traverseWithKey f' dm0
108 result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f'
108 result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f'
109 return (result0, result')
109 return (result0, result')
110
110
111−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (PerformEventT t m) where
111+instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where
112 {-# INLINABLE newEventWithTrigger #-}
112 {-# INLINABLE newEventWithTrigger #-}
113− newEventWithTrigger = lift . newEventWithTrigger
113+ newEventWithTrigger = PerformEventT . lift . newEventWithTrigger
114 {-# INLINABLE newFanEventWithTrigger #-}
114 {-# INLINABLE newFanEventWithTrigger #-}
115− newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
115+ newFanEventWithTrigger f = PerformEventT $ lift $ newFanEventWithTrigger f
116
116
117-- | Run a 'PerformEventT' action, returning a 'FireCommand' that allows the
117-- | Run a 'PerformEventT' action, returning a 'FireCommand' that allows the
118-- caller to trigger 'Event's while ensuring that 'performEvent' actions are run
118-- caller to trigger 'Event's while ensuring that 'performEvent' actions are run
@@ -129,7 +129,7 @@ hostPerformEventT :: forall t m a.
129 -> m (a, FireCommand t m)
129 -> m (a, FireCommand t m)
130hostPerformEventT a = do
130hostPerformEventT a = do
131 (response, responseTrigger) <- newEventWithTriggerRef
131 (response, responseTrigger) <- newEventWithTriggerRef
132− (result, eventToPerform) <- runRequesterT (unPerformEventT a) response
132+ (result, eventToPerform) <- runHostFrame $ runRequesterT (unPerformEventT a) response
133 eventToPerformHandle <- subscribeEvent eventToPerform
133 eventToPerformHandle <- subscribeEvent eventToPerform
134 return $ (,) result $ FireCommand $ \triggers (readPhase :: ReadPhase m a') -> do
134 return $ (,) result $ FireCommand $ \triggers (readPhase :: ReadPhase m a') -> do
135 let go :: [DSum (EventTrigger t) Identity] -> m [a']
135 let go :: [DSum (EventTrigger t) Identity] -> m [a']
@@ -141,7 +141,7 @@ hostPerformEventT a = do
141 case mToPerform of
141 case mToPerform of
142 Nothing -> return [result']
142 Nothing -> return [result']
143 Just toPerform -> do
143 Just toPerform -> do
144− responses <- traverseRequesterData (\v -> Identity <$> v) toPerform
144+ responses <- runHostFrame $ traverseRequesterData (\v -> Identity <$> v) toPerform
145 mrt <- readRef responseTrigger
145 mrt <- readRef responseTrigger
146 let followupEventTriggers = case mrt of
146 let followupEventTriggers = case mrt of
147 Just rt -> [rt :=> Identity responses]
147 Just rt -> [rt :=> Identity responses]
@@ -149,34 +149,31 @@ hostPerformEventT a = do
149 (result':) <$> go followupEventTriggers
149 (result':) <$> go followupEventTriggers
150 go triggers
150 go triggers
151
151
152−instance MonadSample t m => MonadSample t (PerformEventT t m) where
152+instance ReflexHost t => MonadSample t (PerformEventT t m) where
153 {-# INLINABLE sample #-}
153 {-# INLINABLE sample #-}
154− sample = lift . sample
154+ sample = PerformEventT . lift . sample
155
155
156instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where
156instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where
157 {-# INLINABLE hold #-}
157 {-# INLINABLE hold #-}
158− hold v0 v' = lift $ hold v0 v'
158+ hold v0 v' = PerformEventT $ lift $ hold v0 v'
159 {-# INLINABLE holdDyn #-}
159 {-# INLINABLE holdDyn #-}
160− holdDyn v0 v' = lift $ holdDyn v0 v'
160+ holdDyn v0 v' = PerformEventT $ lift $ holdDyn v0 v'
161 {-# INLINABLE holdIncremental #-}
161 {-# INLINABLE holdIncremental #-}
162− holdIncremental v0 v' = lift $ holdIncremental v0 v'
162+ holdIncremental v0 v' = PerformEventT $ lift $ holdIncremental v0 v'
163 {-# INLINABLE buildDynamic #-}
163 {-# INLINABLE buildDynamic #-}
164− buildDynamic getV0 v' = lift $ buildDynamic getV0 v'
164+ buildDynamic getV0 v' = PerformEventT $ lift $ buildDynamic getV0 v'
165 {-# INLINABLE headE #-}
165 {-# INLINABLE headE #-}
166− headE = lift . headE
166+ headE = PerformEventT . lift . headE
167
167
168−instance (MonadRef m, ReflexHost t) => MonadRef (PerformEventT t m) where
168+instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where
169− type Ref (PerformEventT t m) = Ref m
169+ type Ref (PerformEventT t m) = Ref (HostFrame t)
170 {-# INLINABLE newRef #-}
170 {-# INLINABLE newRef #-}
171− newRef = lift . newRef
171+ newRef = PerformEventT . lift . newRef
172 {-# INLINABLE readRef #-}
172 {-# INLINABLE readRef #-}
173− readRef = lift . readRef
173+ readRef = PerformEventT . lift . readRef
174 {-# INLINABLE writeRef #-}
174 {-# INLINABLE writeRef #-}
175− writeRef r = lift . writeRef r
175+ writeRef r = PerformEventT . lift . writeRef r
176
176
177−instance (MonadAtomicRef m, ReflexHost t) => MonadAtomicRef (PerformEventT t m) where
177+instance (MonadAtomicRef (HostFrame t), ReflexHost t) => MonadAtomicRef (PerformEventT t m) where
178 {-# INLINABLE atomicModifyRef #-}
178 {-# INLINABLE atomicModifyRef #-}
179− atomicModifyRef r = lift . atomicModifyRef r
179+ atomicModifyRef r = PerformEventT . lift . atomicModifyRef r
180−
181−instance MonadTrans (PerformEventT t) where
182− lift = PerformEventT . lift
src/Reflex/Spider/Internal.hs−4
@@ -2566,10 +2566,6 @@ instance Monad (SpiderHost x) where
2566 {-# INLINABLE fail #-}
2566 {-# INLINABLE fail #-}
2567 fail s = SpiderHost $ fail s
2567 fail s = SpiderHost $ fail s
2568
2568
2569−instance PrimMonad (SpiderHost x) where
2570− type PrimState (SpiderHost x) = PrimState IO
2571− primitive = SpiderHost . primitive
2572−
2573-- | Run an action affecting the global Spider timeline; this will be guarded by
2569-- | Run an action affecting the global Spider timeline; this will be guarded by
2574-- a mutex for that timeline
2570-- a mutex for that timeline
2575runSpiderHost :: SpiderHost Global a -> IO a
2571runSpiderHost :: SpiderHost Global a -> IO a