@@ -53,31 +53,31 @@ newtype FireCommand t m = FireCommand { runFireCommand :: forall a. [DSum (Event
5353
5454-- | Provides a basic implementation of 'PerformEvent'. Note that, despite the
5555-- name, 'PerformEventT' is not an instance of 'MonadTrans'.
56−newtype PerformEventT t m a = PerformEventT { unPerformEventT :: RequesterT t (HostFrame t) Identity (HostFrame t) a }
57−
58−deriving instance ReflexHost t => Functor (PerformEventT t m)
59−deriving instance ReflexHost t => Applicative (PerformEventT t m)
60−deriving instance ReflexHost t => Monad (PerformEventT t m)
61−deriving instance ReflexHost t => MonadFix (PerformEventT t m)
62−deriving instance (ReflexHost t, MonadIO (HostFrame t)) => MonadIO (PerformEventT t m)
63−deriving instance (ReflexHost t, MonadException (HostFrame t)) => MonadException (PerformEventT t m)
64−deriving instance (ReflexHost t, Monoid a) => Monoid (PerformEventT t m a)
65−deriving instance (ReflexHost t, S.Semigroup a) => S.Semigroup (PerformEventT t m a)
66−
67−instance (PrimMonad (HostFrame t), ReflexHost t) => PrimMonad (PerformEventT t m) where
68− type PrimState (PerformEventT t m) = PrimState (HostFrame t)
69− primitive = PerformEventT . lift . primitive
70−
71−instance (ReflexHost t, Ref m ~ Ref IO) => PerformEvent t (PerformEventT t m) where
72− type Performable (PerformEventT t m) = HostFrame t
56+newtype PerformEventT t m a = PerformEventT { unPerformEventT :: RequesterT t m Identity m a }
57+
58+deriving instance Functor m => Functor (PerformEventT t m)
59+deriving instance Monad m => Applicative (PerformEventT t m)
60+deriving instance Monad m => Monad (PerformEventT t m)
61+deriving instance MonadFix m => MonadFix (PerformEventT t m)
62+deriving instance MonadIO m => MonadIO (PerformEventT t m)
63+deriving instance MonadException m => MonadException (PerformEventT t m)
64+deriving instance (Monad m, Monoid a) => Monoid (PerformEventT t m a)
65+deriving instance (Monad m, S.Semigroup a) => S.Semigroup (PerformEventT t m a)
66+
67+instance (PrimMonad m, ReflexHost t) => PrimMonad (PerformEventT t m) where
68+ type PrimState (PerformEventT t m) = PrimState m
69+ primitive = lift . primitive
70+
71+instance (Monad m, Reflex t, Ref m ~ Ref IO) => PerformEvent t (PerformEventT t m) where
72+ type Performable (PerformEventT t m) = m
7373 {-# INLINABLE performEvent_ #-}
7474 performEvent_ = PerformEventT . requesting_
7575 {-# INLINABLE performEvent #-}
7676 performEvent = PerformEventT . requestingIdentity
7777
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
7979 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)
8181 f a0 a' = do
8282 result0 <- lift a0
8383 result' <- requestingIdentity a'
@@ -86,33 +86,33 @@ instance (ReflexHost t, PrimMonad (HostFrame t)) => Adjustable t (PerformEventT
8686 traverseDMapWithKeyWithAdjust f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithKey) mapPatchDMap weakenPatchDMapWith patchMapNewElementsMap mergeMapIncremental (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
8787 traverseDMapWithKeyWithAdjustWithMove f outerDm0 outerDm' = PerformEventT $ traverseDMapWithKeyWithAdjustRequesterTWith (defaultAdjustBase traversePatchDMapWithMoveWithKey) mapPatchDMapWithMove weakenPatchDMapWithMoveWith patchMapWithMoveNewElementsMap mergeMapIncrementalWithMove (\k v -> unPerformEventT $ f k v) (coerce outerDm0) (coerceEvent outerDm')
8888
89−defaultAdjustBase :: forall t v v2 k' p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)
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 -> HostFrame t (v2 a))
89+defaultAdjustBase :: forall t v v2 k' p m. (Monad m, PrimMonad m, Reflex t)
90+ => ((forall a. k' a -> v a -> m (v2 a)) -> p k' v -> m (p k' v2))
91+ -> (forall a. k' a -> v a -> m (v2 a))
9292 -> DMap k' v
9393 -> 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))
9595defaultAdjustBase traversePatchWithKey f' dm0 dm' = do
9696 result0 <- lift $ DMap.traverseWithKey f' dm0
9797 result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f'
9898 return (result0, result')
9999
100−defaultAdjustIntBase :: forall t v v2 p. (Monad (HostFrame t), PrimMonad (HostFrame t), Reflex t)
101− => ((IntMap.Key -> v -> HostFrame t v2) -> p v -> HostFrame t (p v2))
102− -> (IntMap.Key -> v -> HostFrame t v2)
100+defaultAdjustIntBase :: forall t v v2 p m. (Monad m, PrimMonad m, Reflex t)
101+ => ((IntMap.Key -> v -> m v2) -> p v -> m (p v2))
102+ -> (IntMap.Key -> v -> m v2)
103103 -> IntMap v
104104 -> 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))
106106defaultAdjustIntBase traversePatchWithKey f' dm0 dm' = do
107107 result0 <- lift $ IntMap.traverseWithKey f' dm0
108108 result' <- requestingIdentity $ ffor dm' $ traversePatchWithKey f'
109109 return (result0, result')
110110
111−instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where
111+instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (PerformEventT t m) where
112112 {-# INLINABLE newEventWithTrigger #-}
113− newEventWithTrigger = PerformEventT . lift . newEventWithTrigger
113+ newEventWithTrigger = lift . newEventWithTrigger
114114 {-# INLINABLE newFanEventWithTrigger #-}
115− newFanEventWithTrigger f = PerformEventT $ lift $ newFanEventWithTrigger f
115+ newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
116116
117117-- | Run a 'PerformEventT' action, returning a 'FireCommand' that allows the
118118-- caller to trigger 'Event's while ensuring that 'performEvent' actions are run
@@ -129,7 +129,7 @@ hostPerformEventT :: forall t m a.
129129 -> m (a, FireCommand t m)
130130hostPerformEventT a = do
131131 (response, responseTrigger) <- newEventWithTriggerRef
132− (result, eventToPerform) <- runHostFrame $ runRequesterT (unPerformEventT a) response
132+ (result, eventToPerform) <- runRequesterT (unPerformEventT a) response
133133 eventToPerformHandle <- subscribeEvent eventToPerform
134134 return $ (,) result $ FireCommand $ \triggers (readPhase :: ReadPhase m a') -> do
135135 let go :: [DSum (EventTrigger t) Identity] -> m [a']
@@ -141,7 +141,7 @@ hostPerformEventT a = do
141141 case mToPerform of
142142 Nothing -> return [result']
143143 Just toPerform -> do
144− responses <- runHostFrame $ traverseRequesterData (\v -> Identity <$> v) toPerform
144+ responses <- traverseRequesterData (\v -> Identity <$> v) toPerform
145145 mrt <- readRef responseTrigger
146146 let followupEventTriggers = case mrt of
147147 Just rt -> [rt :=> Identity responses]
@@ -149,31 +149,34 @@ hostPerformEventT a = do
149149 (result':) <$> go followupEventTriggers
150150 go triggers
151151
152−instance ReflexHost t => MonadSample t (PerformEventT t m) where
152+instance MonadSample t m => MonadSample t (PerformEventT t m) where
153153 {-# INLINABLE sample #-}
154− sample = PerformEventT . lift . sample
154+ sample = lift . sample
155155
156156instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where
157157 {-# INLINABLE hold #-}
158− hold v0 v' = PerformEventT $ lift $ hold v0 v'
158+ hold v0 v' = lift $ hold v0 v'
159159 {-# INLINABLE holdDyn #-}
160− holdDyn v0 v' = PerformEventT $ lift $ holdDyn v0 v'
160+ holdDyn v0 v' = lift $ holdDyn v0 v'
161161 {-# INLINABLE holdIncremental #-}
162− holdIncremental v0 v' = PerformEventT $ lift $ holdIncremental v0 v'
162+ holdIncremental v0 v' = lift $ holdIncremental v0 v'
163163 {-# INLINABLE buildDynamic #-}
164− buildDynamic getV0 v' = PerformEventT $ lift $ buildDynamic getV0 v'
164+ buildDynamic getV0 v' = lift $ buildDynamic getV0 v'
165165 {-# INLINABLE headE #-}
166− headE = PerformEventT . lift . headE
166+ headE = lift . headE
167167
168−instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m) where
169− type Ref (PerformEventT t m) = Ref (HostFrame t)
168+instance (MonadRef m, ReflexHost t) => MonadRef (PerformEventT t m) where
169+ type Ref (PerformEventT t m) = Ref m
170170 {-# INLINABLE newRef #-}
171− newRef = PerformEventT . lift . newRef
171+ newRef = lift . newRef
172172 {-# INLINABLE readRef #-}
173− readRef = PerformEventT . lift . readRef
173+ readRef = lift . readRef
174174 {-# INLINABLE writeRef #-}
175− writeRef r = PerformEventT . lift . writeRef r
175+ writeRef r = lift . writeRef r
176176
177−instance (MonadAtomicRef (HostFrame t), ReflexHost t) => MonadAtomicRef (PerformEventT t m) where
177+instance (MonadAtomicRef m, ReflexHost t) => MonadAtomicRef (PerformEventT t m) where
178178 {-# 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