@@ -1,4 +1,4 @@
1−{-# LANGUAGE CPP, ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, LambdaCase #-}
1+{-# LANGUAGE CPP, ExistentialQuantification, GADTs, ScopedTypeVariables, TypeFamilies, FlexibleInstances, MultiParamTypeClasses, GeneralizedNewtypeDeriving, RankNTypes, BangPatterns, UndecidableInstances, EmptyDataDecls, RecursiveDo, RoleAnnotations, LambdaCase, TypeOperators #-}
22module Reflex.Spider.Internal where
33
44import qualified Reflex.Class as R
@@ -109,6 +109,7 @@ data EventEnv
109109 = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment])
110110 , eventEnvHoldInits :: !(IORef [SomeHoldInit])
111111 , eventEnvClears :: !(IORef [SomeMaybeIORef])
112+ , eventEnvRootClears :: !(IORef [SomeDMapIORef])
112113 , eventEnvCurrentHeight :: !(IORef Int)
113114 , eventEnvCoincidenceInfos :: !(IORef [SomeCoincidenceInfo])
114115 , eventEnvDelayedMerges :: !(IORef (IntMap [DelayedMerge]))
@@ -138,6 +139,11 @@ scheduleClear r = EventM $ do
138139 clears <- asks eventEnvClears
139140 liftIO $ modifyIORef' clears (SomeMaybeIORef r :)
140141
142+scheduleRootClear :: IORef (DMap k) -> EventM ()
143+scheduleRootClear r = EventM $ do
144+ clears <- asks eventEnvRootClears
145+ liftIO $ modifyIORef' clears (SomeDMapIORef r :)
146+
141147scheduleMerge :: Int -> MergeSubscribed a -> EventM ()
142148scheduleMerge height subscribed = EventM $ do
143149 delayedRef <- asks eventEnvDelayedMerges
@@ -213,13 +219,13 @@ data Invalidator
213219
214220data RootSubscribed a
215221 = RootSubscribed { rootSubscribedSubscribers :: !(IORef [WeakSubscriber a])
216− , rootSubscribedOccurrence :: !(IORef (Maybe a)) -- Alias to rootOccurrence
222+ , rootSubscribedOccurrence :: !(IO (Maybe a)) -- Lookup from rootOccurrence
217223 }
218224
219−data Root a
220− = Root { rootOccurrence :: !(IORef (Maybe a)) -- The currently-firing occurrence of this event
221− , rootSubscribed :: !(IORef (Maybe (RootSubscribed a)))
222− , rootInit :: !(RootTrigger a -> IO (IO ()))
225+data Root (k :: * -> *)
226+ = Root { rootOccurrence :: !(IORef (DMap k)) -- The currently-firing occurrence of this event
227+ , rootSubscribed :: !(IORef (DMap (WrapArg RootSubscribed k)))
228+ , rootInit :: !(forall a. k a -> RootTrigger a -> IO (IO ()))
223229 }
224230
225231data SomeHoldInit = forall a. SomeHoldInit (Event a) (Hold a)
@@ -365,7 +371,7 @@ showSubscriberType = \case
365371 SubscriberCoincidenceInner _ -> "SubscriberCoincidenceInner"
366372
367373data Event a
368− = EventRoot !(Root a)
374+ = forall k. GCompare k => EventRoot !(k a) !(Root k)
369375 | EventNever
370376 | forall b. EventPush !(Push b a)
371377 | forall k. (GCompare k, a ~ DMap k) => EventMerge !(Merge k)
@@ -375,7 +381,7 @@ data Event a
375381
376382showEventType :: Event a -> String
377383showEventType = \case
378− EventRoot _ -> "EventRoot"
384+ EventRoot _ _ -> "EventRoot"
379385 EventNever -> "EventNever"
380386 EventPush _ -> "EventPush"
381387 EventMerge _ -> "EventMerge"
@@ -402,7 +408,7 @@ data EventSubscribed a
402408-- the weak pointer to it in some cases.
403409
404410{-# NOINLINE newRootSubscribed #-}
405−newRootSubscribed :: IORef (Maybe a) -> IORef [WeakSubscriber a] -> IO (RootSubscribed a)
411+newRootSubscribed :: IO (Maybe a) -> IORef [WeakSubscriber a] -> IO (RootSubscribed a)
406412newRootSubscribed occ subs =
407413 return $! RootSubscribed
408414 { rootSubscribedOccurrence = occ
@@ -495,14 +501,14 @@ coincidence a = EventCoincidence $ Coincidence
495501 , coincidenceSubscribed = unsafeNewIORef a Nothing
496502 }
497503
498−newRoot :: IO (Root a)
504+newRoot :: IO (Root k)
499505newRoot = do
500− occRef <- newIORef Nothing
501− subscribedRef <- newIORef Nothing
506+ occRef <- newIORef DMap.empty
507+ subscribedRef <- newIORef DMap.empty
502508 return $ Root
503509 { rootOccurrence = occRef
504510 , rootSubscribed = subscribedRef
505− , rootInit = const $ return $ return ()
511+ , rootInit = \_ _ -> return $ return ()
506512 }
507513
508514propagateAndUpdateSubscribersRef :: IORef [WeakSubscriber a] -> a -> EventM ()
@@ -517,10 +523,16 @@ run :: [DSum RootTrigger] -> ResultM b -> IO b
517523run roots after = do
518524 when debugPropagate $ putStrLn "Running an event frame"
519525 result <- runFrame $ do
520− forM_ roots $ \(RootTrigger (_, occRef) :=> a) -> do
521− liftIO $ writeIORef occRef $ Just a
522− scheduleClear occRef
523− forM_ roots $ \(RootTrigger (subscribersRef, _) :=> a) -> do
526+ rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
527+ occBefore <- liftIO $ do
528+ occBefore <- readIORef occRef
529+ writeIORef occRef $ DMap.insert k a occBefore
530+ return occBefore
531+ if DMap.null occBefore
532+ then do scheduleRootClear occRef
533+ return $ Just r
534+ else return Nothing
535+ forM_ (catMaybes rootsToPropagate) $ \(RootTrigger (subscribersRef, _, k) :=> a) -> do
524536 propagateAndUpdateSubscribersRef subscribersRef a
525537 delayedRef <- EventM $ asks eventEnvDelayedMerges
526538 let go = do
@@ -553,6 +565,8 @@ run roots after = do
553565
554566data SomeMaybeIORef = forall a. SomeMaybeIORef (IORef (Maybe a))
555567
568+data SomeDMapIORef = forall k. SomeDMapIORef (IORef (DMap k))
569+
556570data SomeAssignment = forall a. SomeAssignment (Hold a) a
557571
558572data DelayedMerge = forall k. DelayedMerge (MergeSubscribed k)
@@ -717,7 +731,7 @@ readBehaviorTracked b = case b of
717731
718732readEvent :: Event a -> ResultM (Maybe a)
719733readEvent e = case e of
720− EventRoot r -> liftIO $ readIORef $ rootOccurrence r
734+ EventRoot k r -> liftIO $ liftM (DMap.lookup k) $ readIORef $ rootOccurrence r
721735 EventNever -> return Nothing
722736 EventPush p -> do
723737 subscribed <- getPushSubscribed p
@@ -756,7 +770,7 @@ zeroRef = unsafePerformIO $ newIORef 0
756770
757771getEventSubscribed :: Event a -> EventM (EventSubscribed a)
758772getEventSubscribed e = case e of
759− EventRoot r -> liftM EventSubscribedRoot $ getRootSubscribed r
773+ EventRoot k r -> liftM EventSubscribedRoot $ getRootSubscribed k r
760774 EventNever -> return EventSubscribedNever
761775 EventPush p -> liftM EventSubscribedPush $ getPushSubscribed p
762776 EventFan k f -> liftM (EventSubscribedFan k) $ getFanSubscribed f
@@ -793,7 +807,7 @@ subscribeEventSubscribed es ws = case es of
793807
794808getEventSubscribedOcc :: EventSubscribed a -> IO (Maybe a)
795809getEventSubscribedOcc es = case es of
796− EventSubscribedRoot r -> readIORef $ rootSubscribedOccurrence r
810+ EventSubscribedRoot r -> rootSubscribedOccurrence r
797811 EventSubscribedNever -> return Nothing
798812 EventSubscribedPush subscribed -> readIORef $ pushSubscribedOccurrence subscribed
799813 EventSubscribedFan k subscribed -> do
@@ -824,21 +838,21 @@ noinlineFalse :: Bool
824838noinlineFalse = False
825839{-# NOINLINE noinlineFalse #-}
826840
827−getRootSubscribed :: Root a -> EventM (RootSubscribed a)
828−getRootSubscribed r = do
841+getRootSubscribed :: GCompare k => k a -> Root k -> EventM (RootSubscribed a)
842+getRootSubscribed k r = do
829843 mSubscribed <- liftIO $ readIORef $ rootSubscribed r
830− case mSubscribed of
844+ case DMap.lookup (WrapArg k) mSubscribed of
831845 Just subscribed -> return subscribed
832846 Nothing -> liftIO $ do
833847 subscribersRef <- newIORef []
834− subscribed <- newRootSubscribed (rootOccurrence r) subscribersRef
848+ subscribed <- newRootSubscribed (liftM (DMap.lookup k) $ readIORef $ rootOccurrence r) subscribersRef
835849 -- Strangely, init needs the same stuff as a RootSubscribed has, but it must not be the same as the one that everyone's subscribing to, or it'll leak memory
836− uninit <- rootInit r $ RootTrigger (subscribersRef, rootOccurrence r)
850+ uninit <- rootInit r k $ RootTrigger (subscribersRef, rootOccurrence r, k)
837851 addFinalizer subscribed $ do
838852 when noinlineFalse $ putStr "" -- For some reason, without this line, the finalizer will run earlier than it should
839853-- putStrLn "Uninit root"
840854 uninit
841− liftIO $ writeIORef (rootSubscribed r) $ Just subscribed
855+ liftIO $ modifyIORef' (rootSubscribed r) $ DMap.insert (WrapArg k) subscribed
842856 return subscribed
843857
844858-- When getPushSubscribed returns, the PushSubscribed returned will have a fully filled-in
@@ -1057,9 +1071,10 @@ runFrame a = do
10571071 holdInitRef <- newIORef []
10581072 heightRef <- newIORef 0
10591073 toClearRef <- newIORef []
1074+ toClearRootRef <- newIORef []
10601075 coincidenceInfosRef <- newIORef []
10611076 delayedRef <- liftIO $ newIORef IntMap.empty
1062− result <- flip runEventM (EventEnv toAssignRef holdInitRef toClearRef heightRef coincidenceInfosRef delayedRef) $ do
1077+ result <- flip runEventM (EventEnv toAssignRef holdInitRef toClearRef toClearRootRef heightRef coincidenceInfosRef delayedRef) $ do
10631078 result <- a
10641079 let runHoldInits = do
10651080 holdInits <- liftIO $ readIORef holdInitRef
@@ -1071,6 +1086,8 @@ runFrame a = do
10711086 return result
10721087 toClear <- readIORef toClearRef
10731088 forM_ toClear $ \(SomeMaybeIORef ref) -> writeIORef ref Nothing
1089+ toClearRoot <- readIORef toClearRootRef
1090+ forM_ toClearRoot $ \(SomeDMapIORef ref) -> writeIORef ref DMap.empty
10741091 toAssign <- readIORef toAssignRef
10751092 toReconnectRef <- newIORef []
10761093 forM_ toAssign $ \(SomeAssignment h v) -> do
@@ -1323,7 +1340,7 @@ instance R.MonadHold Spider EventM where
13231340 {-# INLINE hold #-}
13241341 hold v0 e = SpiderBehavior <$> hold v0 (unSpiderEvent e)
13251342
1326−newtype RootTrigger a = RootTrigger (IORef [WeakSubscriber a], IORef (Maybe a))
1343+data RootTrigger a = forall k. GCompare k => RootTrigger (IORef [WeakSubscriber a], IORef (DMap k), k a)
13271344newtype SpiderEventHandle a = SpiderEventHandle { unEventHandle :: Event a }
13281345
13291346instance R.ReflexHost Spider where
@@ -1359,22 +1376,33 @@ instance R.MonadHold Spider SpiderHostFrame where
13591376 {-# INLINE hold #-}
13601377 hold v0 e = SpiderHostFrame $ R.hold v0 e
13611378
1362−newEventWithTriggerIO :: (RootTrigger a -> IO (IO ())) -> IO (R.Event Spider a)
1379+newEventWithTriggerIO :: forall a. (RootTrigger a -> IO (IO ())) -> IO (Event a)
13631380newEventWithTriggerIO f = do
1364− occRef <- newIORef Nothing
1365− subscribedRef <- newIORef Nothing
1381+ es <- newFanEventWithTriggerIO $ \Refl -> f
1382+ return $ select es Refl
1383+
1384+newFanEventWithTriggerIO :: GCompare k => (forall a. k a -> RootTrigger a -> IO (IO ())) -> IO (EventSelector k)
1385+newFanEventWithTriggerIO f = do
1386+ occRef <- newIORef DMap.empty
1387+ subscribedRef <- newIORef DMap.empty
13661388 let !r = Root
13671389 { rootOccurrence = occRef
13681390 , rootSubscribed = subscribedRef
13691391 , rootInit = f
13701392 }
1371− return $ SpiderEvent $ EventRoot r
1393+ return $ EventSelector $ \k -> EventRoot k r
13721394
13731395instance R.MonadReflexCreateTrigger Spider SpiderHost where
1374− newEventWithTrigger = SpiderHost . newEventWithTriggerIO
1396+ newEventWithTrigger = SpiderHost . liftM SpiderEvent . newEventWithTriggerIO
1397+ newFanEventWithTrigger f = SpiderHost $ do
1398+ es <- newFanEventWithTriggerIO f
1399+ return $ R.EventSelector $ SpiderEvent . select es
13751400
13761401instance R.MonadReflexCreateTrigger Spider SpiderHostFrame where
1377− newEventWithTrigger = SpiderHostFrame . EventM . liftIO . newEventWithTriggerIO
1402+ newEventWithTrigger = SpiderHostFrame . EventM . liftIO . liftM SpiderEvent . newEventWithTriggerIO
1403+ newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do
1404+ es <- newFanEventWithTriggerIO f
1405+ return $ R.EventSelector $ SpiderEvent . select es
13781406
13791407instance R.MonadReflexHost Spider SpiderHost where
13801408 fireEventsAndRead es a = SpiderHost $ run es a