@@ -1,3 +1,5 @@
1+-- | This module provides 'PerformEventT', the standard implementation of
2+-- 'PerformEvent'.
13{-# LANGUAGE CPP #-}
24{-# LANGUAGE ExistentialQuantification #-}
35{-# LANGUAGE FlexibleContexts #-}
@@ -17,12 +19,17 @@
1719#ifdef USE_REFLEX_OPTIMIZER
1820{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
1921#endif
20−module Reflex.PerformEvent.Base where
22+module Reflex.PerformEvent.Base
23+ ( PerformEventT (..)
24+ , FireCommand (..)
25+ , hostPerformEventT
26+ ) where
2127
2228import Reflex.Class
2329import Reflex.Host.Class
2430import Reflex.PerformEvent.Class
25−import Reflex.PostBuild.Class
31+import Reflex.Requester.Base
32+import Reflex.Requester.Class
2633
2734import Control.Lens
2835import Control.Monad.Exception
@@ -30,25 +37,20 @@ import Control.Monad.Identity
3037import Control.Monad.Primitive
3138import Control.Monad.Reader
3239import Control.Monad.Ref
33−import Control.Monad.State.Strict
3440import Data.Coerce
35−import Data.Dependent.Map (DMap, GCompare (..), Some)
41+import Data.Dependent.Map (DMap)
3642import qualified Data.Dependent.Map as DMap
3743import Data.Dependent.Sum
38−import Data.Functor.Misc
39−import qualified Data.List.NonEmpty as NonEmpty
40−import Data.Maybe
41−import Data.Semigroup
42−import qualified Data.Some as Some
43−import Data.These
44−import Data.Tuple
45−import Data.Unique.Tag
46−
47−newtype EventTriggerRef t m a = EventTriggerRef { unEventTriggerRef :: Ref m (Maybe (EventTrigger t a)) }
4844
45+-- | A function that fires events for the given 'EventTrigger's and then runs
46+-- any followup actions provided via 'PerformEvent'. The given 'ReadPhase'
47+-- action will be run once for the initial trigger execution as well as once for
48+-- each followup.
4949newtype FireCommand t m = FireCommand { runFireCommand :: forall a. [DSum (EventTrigger t) Identity] -> ReadPhase m a -> m [a] } --TODO: The handling of this ReadPhase seems wrong, or at least inelegant; how do we actually make the decision about what order frames run in?
5050
51−newtype PerformEventT t m a = PerformEventT { unPerformEventT :: RequestT t (HostFrame t) Identity (HostFrame t) a }
51+-- | Provides a basic implementation of 'PerformEvent'. Note that, despite the
52+-- name, 'PerformEventT' is not an instance of 'MonadTrans'.
53+newtype PerformEventT t m a = PerformEventT { unPerformEventT :: RequesterT t (HostFrame t) Identity (HostFrame t) a }
5254
5355deriving instance ReflexHost t => Functor (PerformEventT t m)
5456deriving instance ReflexHost t => Applicative (PerformEventT t m)
@@ -66,17 +68,17 @@ instance (ReflexHost t, Ref m ~ Ref IO, PrimMonad (HostFrame t)) => PerformEvent
6668 {-# INLINABLE performEvent_ #-}
6769 performEvent_ = PerformEventT . requesting_
6870 {-# INLINABLE performEvent #-}
69− performEvent = PerformEventT . fmap (fmap runIdentity) . requesting
71+ performEvent = PerformEventT . requestingIdentity
7072
7173instance (ReflexHost t, PrimMonad (HostFrame t)) => MonadAdjust t (PerformEventT t m) where
72− runWithReplace outerA0 outerA' = PerformEventT $ runWithReplaceRequestTWith f (coerce outerA0) (coerceEvent outerA')
73− where f :: HostFrame t a -> Event t (HostFrame t b) -> RequestT t (HostFrame t) Identity (HostFrame t) (a, Event t b)
74+ runWithReplace outerA0 outerA' = PerformEventT $ runWithReplaceRequesterTWith f (coerce outerA0) (coerceEvent outerA')
75+ where f :: HostFrame t a -> Event t (HostFrame t b) -> RequesterT t (HostFrame t) Identity (HostFrame t) (a, Event t b)
7476 f a0 a' = do
7577 result0 <- lift a0
7678 result' <- requesting a'
7779 return (result0, fmap runIdentity result')
78− sequenceDMapWithAdjust (outerDm0 :: DMap k (PerformEventT t m)) outerDm' = PerformEventT $ sequenceDMapWithAdjustRequestTWith f (coerce outerDm0) (coerceEvent outerDm')
79− where f :: DMap k' (HostFrame t) -> Event t (PatchDMap k' (HostFrame t)) -> RequestT t (HostFrame t) Identity (HostFrame t) (DMap k' Identity, Event t (PatchDMap k' Identity))
80+ sequenceDMapWithAdjust (outerDm0 :: DMap k (PerformEventT t m)) outerDm' = PerformEventT $ sequenceDMapWithAdjustRequesterTWith f (coerce outerDm0) (coerceEvent outerDm')
81+ where f :: DMap k' (HostFrame t) -> Event t (PatchDMap k' (HostFrame t)) -> RequesterT t (HostFrame t) Identity (HostFrame t) (DMap k' Identity, Event t (PatchDMap k' Identity))
8082 f dm0 dm' = do
8183 result0 <- lift $ DMap.traverseWithKey (\_ v -> Identity <$> v) dm0
8284 result' <- requesting $ ffor dm' $ \(PatchDMap p) -> do
@@ -89,6 +91,9 @@ instance ReflexHost t => MonadReflexCreateTrigger t (PerformEventT t m) where
8991 {-# INLINABLE newFanEventWithTrigger #-}
9092 newFanEventWithTrigger f = PerformEventT $ lift $ newFanEventWithTrigger f
9193
94+-- | Run a 'PerformEventT' action, returning a 'FireCommand' that allows the
95+-- caller to trigger 'Event's while ensuring that 'performEvent' actions are run
96+-- at the appropriate time.
9297{-# INLINABLE hostPerformEventT #-}
9398hostPerformEventT :: forall t m a.
9499 ( Monad m
@@ -101,7 +106,7 @@ hostPerformEventT :: forall t m a.
101106 -> m (a, FireCommand t m)
102107hostPerformEventT a = do
103108 (response, responseTrigger) <- newEventWithTriggerRef
104− (result, eventToPerform) <- runHostFrame $ runRequestT (unPerformEventT a) response
109+ (result, eventToPerform) <- runHostFrame $ runRequesterT (unPerformEventT a) response
105110 eventToPerformHandle <- subscribeEvent eventToPerform
106111 return $ (,) result $ FireCommand $ \triggers (readPhase :: ReadPhase m a') -> do
107112 let go :: [DSum (EventTrigger t) Identity] -> m [a']
@@ -145,177 +150,3 @@ instance (MonadRef (HostFrame t), ReflexHost t) => MonadRef (PerformEventT t m)
145150instance (MonadAtomicRef (HostFrame t), ReflexHost t) => MonadAtomicRef (PerformEventT t m) where
146151 {-# INLINABLE atomicModifyRef #-}
147152 atomicModifyRef r = PerformEventT . lift . atomicModifyRef r
148−
149−--------------------------------------------------------------------------------
150−-- RequestT
151−--------------------------------------------------------------------------------
152−
153−newtype RequestT t request response m a
154− = RequestT { unRequestT :: StateT [Event t (DMap (Tag (PrimState m)) request)] (ReaderT (EventSelector t (WrapArg response (Tag (PrimState m)))) m) a }
155− deriving (Functor, Applicative, Monad, MonadFix, MonadIO, MonadException)
156−
157−instance MonadTrans (RequestT t request response) where
158− lift = RequestT . lift . lift
159−
160−runRequestT :: forall t m a request response.
161− ( Reflex t
162− , Monad m
163− )
164− => RequestT t request response m a
165− -> Event t (DMap (Tag (PrimState m)) response)
166− -> m (a, Event t (DMap (Tag (PrimState m)) request))
167−runRequestT (RequestT a) responses = do
168− (result, requests) <- runReaderT (runStateT a mempty) $ fan $ mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e) <$> responses
169− return (result, mergeWith DMap.union requests)
170−
171−instance (Reflex t, PrimMonad m) => MonadRequest t (RequestT t request response m) where
172− type Request (RequestT t request response m) = request
173− type Response (RequestT t request response m) = response
174− withRequesting a = do
175− t <- lift newTag
176− s <- RequestT ask
177− (req, result) <- a $ select s $ WrapArg t
178− RequestT $ modify $ (:) $ DMap.singleton t <$> req
179− return result
180−
181−data DMapTransform (a :: *) k k' v v' = forall (b :: *). DMapTransform !(k a -> k' b) !(v a -> v' b)
182−
183−mapPatchKeysAndValuesMonotonic :: (forall a. DMapTransform a k k' v v') -> PatchDMap k v -> PatchDMap k' v'
184−mapPatchKeysAndValuesMonotonic x (PatchDMap p) = PatchDMap $ mapKeyValuePairsMonotonic (\(k :=> ComposeMaybe mv) -> case x of DMapTransform f g -> f k :=> ComposeMaybe (fmap g mv)) p
185−
186−mapKeysAndValuesMonotonic :: (forall a. DMapTransform a k k' v v') -> DMap k v -> DMap k' v'
187−mapKeysAndValuesMonotonic x = mapKeyValuePairsMonotonic $ \(k :=> v) -> case x of
188− DMapTransform f g -> f k :=> g v
189−
190−instance MonadSample t m => MonadSample t (RequestT t request response m) where
191− sample = lift . sample
192−
193−instance MonadHold t m => MonadHold t (RequestT t request response m) where
194− hold v0 = lift . hold v0
195− holdDyn v0 = lift . holdDyn v0
196− holdIncremental v0 = lift . holdIncremental v0
197−
198−instance (Reflex t, MonadAdjust t m, MonadHold t m) => MonadAdjust t (RequestT t request response m) where
199− runWithReplace = runWithReplaceRequestTWith $ \dm0 dm' -> lift $ runWithReplace dm0 dm'
200− sequenceDMapWithAdjust = sequenceDMapWithAdjustRequestTWith $ \dm0 dm' -> lift $ sequenceDMapWithAdjust dm0 dm'
201−
202−runWithReplaceRequestTWith :: forall m t request response a b. (Reflex t, MonadHold t m)
203− => (forall a' b'.
204− m a'
205− -> Event t (m b')
206− -> RequestT t request response m (a', Event t b')
207− )
208− -> RequestT t request response m a
209− -> Event t (RequestT t request response m b)
210− -> RequestT t request response m (a, Event t b)
211−runWithReplaceRequestTWith f a0 a' = do
212− response <- RequestT ask
213− let g :: RequestT t request response m c -> m (c, [Event t (DMap (Tag (PrimState m)) request)])
214− g (RequestT r) = runReaderT (runStateT r mempty) response
215− (result0, result') <- f (g a0) $ g <$> a'
216− request <- holdDyn (fmap (mconcat . NonEmpty.toList) $ mergeList $ snd result0) $ fmap (mconcat . NonEmpty.toList) . mergeList . snd <$> result'
217− -- 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.)
218− RequestT $ modify $ (:) $ coincidence $ updated request
219− RequestT $ modify $ (:) $ switch $ current request
220− return (fst result0, fst <$> result')
221−
222−sequenceDMapWithAdjustRequestTWith :: (GCompare k, Reflex t, MonadHold t m)
223− => (forall k'. GCompare k'
224− => DMap k' m
225− -> Event t (PatchDMap k' m)
226− -> RequestT t request response m (DMap k' Identity, Event t (PatchDMap k' Identity))
227− )
228− -> DMap k (RequestT t request response m)
229− -> Event t (PatchDMap k (RequestT t request response m))
230− -> RequestT t request response m (DMap k Identity, Event t (PatchDMap k Identity))
231−sequenceDMapWithAdjustRequestTWith f (dm0 :: DMap k (RequestT t request response m)) dm' = do
232− response <- RequestT ask
233− let inputTransform :: forall a. DMapTransform a k (WrapArg ((,) [Event t (DMap (Tag (PrimState m)) request)]) k) (RequestT t request response m) m
234− inputTransform = DMapTransform WrapArg (\(RequestT v) -> swap <$> runReaderT (runStateT v mempty) response)
235− (children0, children') <- f (mapKeysAndValuesMonotonic inputTransform dm0) $ mapPatchKeysAndValuesMonotonic inputTransform <$> dm'
236− let result0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (_, v)) -> k :=> Identity v) children0
237− result' = ffor children' $ \(PatchDMap p) -> PatchDMap $
238− mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mv) -> k :=> ComposeMaybe (fmap (Identity . snd . runIdentity) mv)) p
239− requests0 :: DMap (Const2 (Some k) (DMap (Tag (PrimState m)) request)) (Event t)
240− requests0 = mapKeyValuePairsMonotonic (\(WrapArg k :=> Identity (r, _)) -> Const2 (Some.This k) :=> mergeWith DMap.union r) children0
241− requests' :: Event t (PatchDMap (Const2 (Some k) (DMap (Tag (PrimState m)) request)) (Event t))
242− requests' = ffor children' $ \(PatchDMap p) -> PatchDMap $
243− mapKeyValuePairsMonotonic (\(WrapArg k :=> ComposeMaybe mv) -> Const2 (Some.This k) :=> ComposeMaybe (fmap (mergeWith DMap.union . fst . runIdentity) mv)) p
244− childRequestMap <- holdIncremental requests0 requests'
245− -- 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.)
246− RequestT $ modify $ (:) $ coincidence $ ffor requests' $ \(PatchDMap p) -> mergeWith DMap.union $ catMaybes $ ffor (DMap.toList p) $ \(Const2 _ :=> ComposeMaybe me) -> me
247− RequestT $ modify $ (:) $ ffor (mergeIncremental childRequestMap) $ \m ->
248− mconcat $ (\(Const2 _ :=> Identity reqs) -> reqs) <$> DMap.toList m
249− return (result0, result')
250−
251−instance PerformEvent t m => PerformEvent t (RequestT t request response m) where
252− type Performable (RequestT t request response m) = Performable m
253− performEvent_ = lift . performEvent_
254− performEvent = lift . performEvent
255−
256−instance PostBuild t m => PostBuild t (RequestT t request response m) where
257− getPostBuild = lift getPostBuild
258−
259−instance TriggerEvent t m => TriggerEvent t (RequestT t request response m) where
260− newTriggerEvent = lift newTriggerEvent
261− newTriggerEventWithOnComplete = lift newTriggerEventWithOnComplete
262− newEventWithLazyTriggerWithOnComplete = lift . newEventWithLazyTriggerWithOnComplete
263−
264−instance MonadReader r m => MonadReader r (RequestT t request response m) where
265− ask = lift ask
266− local f (RequestT a) = RequestT $ mapStateT (mapReaderT $ local f) a
267− reader = lift . reader
268−
269−{-
270−withRequestT :: forall t m a (req :: * -> *) (req' :: * -> *).
271− (Reflex t, MonadHold t m, MonadFix m)
272− => (forall x. request x -> request' x)
273− -> (forall x. response' x -> response x)
274− -> RequestT t request response m a
275− -> RequestT t request' response m a
276−withRequestT f g m = RequestT $ hoist (hoist (withDynamicWriterT f')) (unRequestT m)
277− where
278− f' :: Event t [(y, Some request)] -> Event t [(y, Some request')]
279− f' = fmap . fmap . fmap $ \(SomeRequest req) -> SomeRequest $ f req
280−-}
281−
282−instance MonadRef m => MonadRef (RequestT t request response m) where
283− type Ref (RequestT t request response m) = Ref m
284− newRef = lift . newRef
285− readRef = lift . readRef
286− writeRef r = lift . writeRef r
287−
288−instance MonadReflexCreateTrigger t m => MonadReflexCreateTrigger t (RequestT t request response m) where
289− newEventWithTrigger = lift . newEventWithTrigger
290− newFanEventWithTrigger f = lift $ newFanEventWithTrigger f
291−
292−
293−--------------------------------------------------------------------------------
294−-- Helpers
295−--------------------------------------------------------------------------------
296−
297−{-# INLINABLE numberWith #-}
298−numberWith :: (Enum n, Traversable t) => (n -> a -> b) -> t a -> n -> (t b, n)
299−numberWith f t n0 = flip runState n0 $ forM t $ \x -> state $ \n -> (f n x, succ n)
300−
301−{-# INLINABLE mergeSelfDeletingEvents #-}
302−mergeSelfDeletingEvents :: forall t m k v. (Ord k, Reflex t, MonadFix m, MonadHold t m)
303− => DMap (Const2 k (These v ())) (Event t)
304− -> Event t (PatchDMap (Const2 k (These v ())) (Event t))
305− -> m (Event t [v])
306−mergeSelfDeletingEvents initial eAddNew = do
307− rec events :: Incremental t (PatchDMap (Const2 k (These v ())) (Event t))
308− <- holdIncremental initial $ eAddNew <> eDelete --TODO: Eliminate empty firings
309− let event = mergeWith DMap.union
310− [ mergeIncremental events
311− , coincidence $ ffor eAddNew $ \(PatchDMap m) -> merge $ DMap.mapMaybeWithKey (const getComposeMaybe) m
312− ]
313− eDelete :: Event t (PatchDMap (Const2 k (These v ())) (Event t))
314− eDelete = fforMaybe event $
315− fmap (PatchDMap . DMap.fromDistinctAscList) .
316− (\l -> if null l then Nothing else Just l) .
317− fmapMaybe (\(Const2 k :=> Identity x) -> (Const2 k :=> ComposeMaybe Nothing) <$ x ^? there) .
318− DMap.toList
319− return $ ffor event $
320− fmapMaybe (\(Const2 _ :=> Identity x) -> x ^? here) .
321− DMap.toList