git.iko.soy/patch
on develop help sign in
Make PerformEventT a transformer again; misc cleanup
abb0fd9Ryan Trinkle
src/Reflex/NotReady/Class.hs+9−33
compare with develop
unifiedsplit
@@ -19,8 +19,7 @@ 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
23−import Reflex.PerformEvent.Base (PerformEventT (..))
22+import Reflex.PerformEvent.Base (PerformEventT)
24import Reflex.PostBuild.Base (PostBuildT)
23import Reflex.PostBuild.Base (PostBuildT)
25import Reflex.Query.Base (QueryT)
24import Reflex.Query.Base (QueryT)
26import Reflex.Requester.Base (RequesterT)
25import Reflex.Requester.Base (RequesterT)
@@ -35,34 +34,11 @@ class Monad m => NotReady t m | m -> t where
35 default notReady :: (MonadTrans f, m ~ f m', NotReady t m') => m ()
34 default notReady :: (MonadTrans f, m ~ f m', NotReady t m') => m ()
36 notReady = lift notReady
35 notReady = lift notReady
37
36
38−instance NotReady t m => NotReady t (ReaderT r m) where
37+instance NotReady t m => NotReady t (ReaderT r m)
39− notReadyUntil = lift . notReadyUntil
40− notReady = lift notReady
41−
42−instance NotReady t m => NotReady t (PostBuildT t m) where
38+instance NotReady t m => NotReady t (PostBuildT t m)
43− notReadyUntil = lift . notReadyUntil
44− notReady = lift notReady
45−
46−instance NotReady t m => NotReady t (EventWriterT t w m) where
39+instance NotReady t m => NotReady t (EventWriterT t w m)
47− notReadyUntil = lift . notReadyUntil
48− notReady = lift notReady
49−
50−instance NotReady t m => NotReady t (DynamicWriterT t w m) where
40+instance NotReady t m => NotReady t (DynamicWriterT t w m)
51− notReadyUntil = lift . notReadyUntil
52− notReady = lift notReady
53−
54−instance NotReady t m => NotReady t (QueryT t q m) where
41+instance NotReady t m => NotReady t (QueryT t q m)
55− notReadyUntil = lift . notReadyUntil
56− notReady = lift notReady
57−
58−instance (ReflexHost t, NotReady t (HostFrame t)) => NotReady t (PerformEventT t m) where
42+instance NotReady t m => NotReady t (PerformEventT t m)
59− notReadyUntil = PerformEventT . notReadyUntil
60− notReady = PerformEventT notReady
61−
62−instance NotReady t m => NotReady t (RequesterT t request response m) where
43+instance NotReady t m => NotReady t (RequesterT t request response m)
63− notReadyUntil = lift . notReadyUntil
64− notReady = lift notReady
65−
66−instance NotReady t m => NotReady t (TriggerEventT t m) where
44+instance NotReady t m => NotReady t (TriggerEventT t m)
67− notReadyUntil = lift . notReadyUntil
68− notReady = lift notReady
src/Reflex/PerformEvent/Base.hs+49−46
@@ -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 (HostFrame t) Identity (HostFrame t) a }
56+newtype PerformEventT t m a = PerformEventT { unPerformEventT :: RequesterT t m Identity m a }
57−
57+
58−deriving instance ReflexHost t => Functor (PerformEventT t m)
58+deriving instance Functor m => Functor (PerformEventT t m)
59−deriving instance ReflexHost t => Applicative (PerformEventT t m)
59+deriving instance Monad m => Applicative (PerformEventT t m)
60−deriving instance ReflexHost t => Monad (PerformEventT t m)
60+deriving instance Monad m => Monad (PerformEventT t m)
61−deriving instance ReflexHost t => MonadFix (PerformEventT t m)
61+deriving instance MonadFix m => MonadFix (PerformEventT t m)
62−deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (PerformEventT t m)
62+deriving instance MonadIO m => MonadIO (PerformEventT t m)
63−deriving instance (ReflexHost t, MonadException (HostFrame t)) => MonadException (PerformEventT t m)
63+deriving instance MonadException m => MonadException (PerformEventT t m)
64−deriving instance (ReflexHost t, Monoid a) => Monoid (PerformEventT t m a)
64+deriving instance (Monad m, Monoid a) => Monoid (PerformEventT t m a)
65−deriving instance (ReflexHost t, S.Semigroup a) => S.Semigroup (PerformEventT t m a)
65+deriving instance (Monad m, S.Semigroup a) => S.Semigroup (PerformEventT t m a)
66−
66+
67−instance (PrimMonad (HostFrame t), ReflexHost t) => PrimMonad (PerformEventT t m) where
67+instance (PrimMonad m, ReflexHost t) => PrimMonad (PerformEventT t m) where
68− type PrimState (PerformEventT t m) = PrimState (HostFrame t)
68+ type PrimState (PerformEventT t m) = PrimState m
69− primitive = PerformEventT . lift . primitive
69+ primitive = lift . primitive
70−
70+
71−instance (ReflexHost t, Ref m ~ Ref IO) => PerformEvent t (PerformEventT t m) where
71+instance (Monad m, Reflex t, Ref m ~ Ref IO) => PerformEvent t (PerformEventT t m) where
72− type Performable (PerformEventT t m) = HostFrame t
72+ type Performable (PerformEventT t m) = m
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 (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT t m) where
78+instance (Reflex t, MonadHold t m, MonadFix m, PrimMonad m) => 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 :: HostFrame t a -> Event t (HostFrame t b) -> RequesterT t (HostFrame t) Identity (HostFrame t) (a, Event t b)
80+ where f :: m a -> Event t (m b) -> RequesterT t m Identity m (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 (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT
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. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)
89+defaultAdjustBase :: forall t v v2 k' p m. (Monad m, PrimMonad m, Reflex t)
90− => ((forall a. k' a -> v a -> HostFrame t (v2 a)) -> p k' v -> HostFrame t (p k' v2))
90+ => ((forall a. k' a -> v a -> m (v2 a)) -> p k' v -> m (p k' v2))
91− -> (forall a. k' a -> v a -> HostFrame t (v2 a))
91+ -> (forall a. k' a -> v a -> m (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 (HostFrame t) Identity (HostFrame t) (DMap k' v2, Event t (p k' v2))
94+ -> RequesterT t m Identity m (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. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)
100+defaultAdjustIntBase :: forall t v v2 p m. (Monad m, PrimMonad m, Reflex t)
101− => ((IntMap.Key -> v -> HostFrame t v2) -> p v -> HostFrame t (p v2))
101+ => ((IntMap.Key -> v -> m v2) -> p v -> m (p v2))
102− -> (IntMap.Key -> v -> HostFrame t v2)
102+ -> (IntMap.Key -> v -> m v2)
103 -> IntMap v
103 -> IntMap v
104 -> Event t (p v)
104 -> Event t (p v)
105− -> RequesterT t (HostFrame t) Identity (HostFrame t) (IntMap v2, Event t (p v2))
105+ -> RequesterT t m Identity m (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 ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where
111+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (PerformEventT t m) where
112 {-# INLINABLE newEventWithTrigger #-}
112 {-# INLINABLE newEventWithTrigger #-}
113− newEventWithTrigger = PerformEventT . lift . newEventWithTrigger
113+ newEventWithTrigger = lift . newEventWithTrigger
114 {-# INLINABLE newFanEventWithTrigger #-}
114 {-# INLINABLE newFanEventWithTrigger #-}
115− newFanEventWithTrigger f = PerformEventT $ lift $ newFanEventWithTrigger f
115+ newFanEventWithTrigger f = 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) <- runHostFrame $ runRequesterT (unPerformEventT a) response
132+ (result, eventToPerform) <- 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 <- runHostFrame $ traverseRequesterData (\v -> Identity <$> v) toPerform
144+ responses <- 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,31 +149,34 @@ hostPerformEventT a = do
149 (result':) <$> go followupEventTriggers
149 (result':) <$> go followupEventTriggers
150 go triggers
150 go triggers
151
151
152−instance ReflexHost t => MonadSample t (PerformEventT t m) where
152+instance MonadSample t m => MonadSample t (PerformEventT t m) where
153 {-# INLINABLE sample #-}
153 {-# INLINABLE sample #-}
154− sample = PerformEventT . lift . sample
154+ sample = 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' = PerformEventT $ lift $ hold v0 v'
158+ hold v0 v' = lift $ hold v0 v'
159 {-# INLINABLE holdDyn #-}
159 {-# INLINABLE holdDyn #-}
160− holdDyn v0 v' = PerformEventT $ lift $ holdDyn v0 v'
160+ holdDyn v0 v' = lift $ holdDyn v0 v'
161 {-# INLINABLE holdIncremental #-}
161 {-# INLINABLE holdIncremental #-}
162− holdIncremental v0 v' = PerformEventT $ lift $ holdIncremental v0 v'
162+ holdIncremental v0 v' = lift $ holdIncremental v0 v'
163 {-# INLINABLE buildDynamic #-}
163 {-# INLINABLE buildDynamic #-}
164− buildDynamic getV0 v' = PerformEventT $ lift $ buildDynamic getV0 v'
164+ buildDynamic getV0 v' = lift $ buildDynamic getV0 v'
165 {-# INLINABLE headE #-}
165 {-# INLINABLE headE #-}
166− headE = PerformEventT . lift . headE
166+ headE = lift . headE
167
167
168−instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where
168+instance (MonadRef m, ReflexHost t) => MonadRef (PerformEventT t m) where
169− type Ref (PerformEventT t m) = Ref (HostFrame t)
169+ type Ref (PerformEventT t m) = Ref m
170 {-# INLINABLE newRef #-}
170 {-# INLINABLE newRef #-}
171− newRef = PerformEventT . lift . newRef
171+ newRef = lift . newRef
172 {-# INLINABLE readRef #-}
172 {-# INLINABLE readRef #-}
173− readRef = PerformEventT . lift . readRef
173+ readRef = lift . readRef
174 {-# INLINABLE writeRef #-}
174 {-# INLINABLE writeRef #-}
175− writeRef r = PerformEventT . lift . writeRef r
175+ writeRef r = lift . writeRef r
176
176
177−instance (MonadAtomicRef (HostFrame t), ReflexHost t) => MonadAtomicRef (PerformEventT t m) where
177+instance (MonadAtomicRef m, ReflexHost t) => MonadAtomicRef (PerformEventT t m) where
178 {-# INLINABLE atomicModifyRef #-}
178 {-# INLINABLE atomicModifyRef #-}
179− atomicModifyRef r = PerformEventT . lift . atomicModifyRef r
179+ atomicModifyRef r = lift . atomicModifyRef r
180+
181+instance MonadTrans (PerformEventT t) where
182+ lift = PerformEventT . lift