@@ -16,9 +16,15 @@
16{-# LANGUAGE TypeFamilies #-}
16{-# LANGUAGE TypeFamilies #-}
17{-# LANGUAGE TypeOperators #-}
17{-# LANGUAGE TypeOperators #-}
18{-# LANGUAGE UndecidableInstances #-}
18{-# LANGUAGE UndecidableInstances #-}
19+{-# LANGUAGE PolyKinds #-}
20+{-# LANGUAGE DeriveFunctor #-}
21+{-# LANGUAGE StandaloneDeriving #-}
22+{-# LANGUAGE InstanceSigs #-}
19#ifdef USE_REFLEX_OPTIMIZER
24#ifdef USE_REFLEX_OPTIMIZER
20{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
25{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
27+{-# OPTIONS_GHC -Wunused-binds #-}
22-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
28-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
23-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
29-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
24module Reflex.Spider.Internal (module Reflex.Spider.Internal) where
30module Reflex.Spider.Internal (module Reflex.Spider.Internal) where
@@ -32,7 +38,10 @@ import Control.Monad hiding (forM, forM_, mapM, mapM_)
32import Control.Monad.Exception
38import Control.Monad.Exception
33import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)
39import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)
34import Control.Monad.Primitive
40import Control.Monad.Primitive
35−import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_)
41+--import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_)
42+import Control.Monad.Reader.Class
43+import Control.Monad.IO.Class
44+import Control.Monad.ReaderIO
36import Control.Monad.Ref
45import Control.Monad.Ref
37import Data.Align
46import Data.Align
38import Data.Coerce
47import Data.Coerce
@@ -48,6 +57,7 @@ import Data.GADT.Compare
48import Data.IntMap.Strict (IntMap)
57import Data.IntMap.Strict (IntMap)
49import qualified Data.IntMap.Strict as IntMap
58import qualified Data.IntMap.Strict as IntMap
50import Data.IORef
59import Data.IORef
60+import Data.Kind (Type)
51import Data.Maybe hiding (mapMaybe)
61import Data.Maybe hiding (mapMaybe)
52import Data.Monoid ((<>))
62import Data.Monoid ((<>))
53import Data.Proxy
63import Data.Proxy
@@ -62,6 +72,15 @@ import System.IO.Unsafe
62import System.Mem.Weak
72import System.Mem.Weak
63import Unsafe.Coerce
73import Unsafe.Coerce
75+#ifdef MIN_VERSION_semialign
76+#if MIN_VERSION_these(0,8,0)
77+import Data.These.Combinators (justThese)
79+#if MIN_VERSION_semialign(1,1,0)
80+import Data.Zip (Zip (..))
65#ifdef DEBUG_CYCLES
84#ifdef DEBUG_CYCLES
66import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)
85import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence)
67import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
86import Data.List.NonEmpty (NonEmpty (..), nonEmpty)
@@ -73,9 +92,9 @@ import Data.Tree (Forest, Tree (..), drawForest)
73import Data.FastWeakBag (FastWeakBag)
92import Data.FastWeakBag (FastWeakBag)
74import qualified Data.FastWeakBag as FastWeakBag
93import qualified Data.FastWeakBag as FastWeakBag
75import Data.Reflection
94import Data.Reflection
76−import Data.Some (Some)
95+import Data.Some (Some(Some))
77−import qualified Data.Some as Some
78import Data.Type.Coercion
96import Data.Type.Coercion
97+import Data.Profunctor.Unsafe ((#.), (.#))
79import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)
98import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)
80import qualified Data.WeakBag as WeakBag
99import qualified Data.WeakBag as WeakBag
81import qualified Reflex.Class
100import qualified Reflex.Class
@@ -84,6 +103,7 @@ import qualified Reflex.Host.Class
84import Reflex.NotReady.Class
103import Reflex.NotReady.Class
85import Reflex.Patch
104import Reflex.Patch
86import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
105import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
106+import Reflex.PerformEvent.Base (PerformEventT)
88#ifdef DEBUG_TRACE_EVENTS
108#ifdef DEBUG_TRACE_EVENTS
89import qualified Data.ByteString.Char8 as BS8
109import qualified Data.ByteString.Char8 as BS8
@@ -192,12 +212,6 @@ nextNodeIdRef = unsafePerformIO $ newIORef 1
193newNodeId :: IO Int
213newNodeId :: IO Int
194newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
214newNodeId = atomicModifyIORef' nextNodeIdRef $ \n -> (succ n, n)
196−{-# NOINLINE unsafeNodeId #-}
197−unsafeNodeId :: a -> Int
198−unsafeNodeId a = unsafePerformIO $ do
203--------------------------------------------------------------------------------
217--------------------------------------------------------------------------------
@@ -301,9 +315,10 @@ cacheEvent e =
318+ unsafePerformIO $ do
304− let mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))
319+ mSubscribedRef :: IORef (FastWeak (CacheSubscribed x a))
305− !mSubscribedRef = unsafeNewIORef e emptyFastWeak
320+ <- newIORef emptyFastWeak
306− in \sub -> {-# SCC "cacheEvent" #-} do
321+ pure $ \sub -> {-# SCC "cacheEvent" #-} do
307#ifdef DEBUG_TRACE_EVENTS
322#ifdef DEBUG_TRACE_EVENTS
308 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite
323 unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite
@@ -318,9 +333,9 @@ cacheEvent e =
318 scheduleClear occRef
333 scheduleClear occRef
319 propagateFast a subscribers
334 propagateFast a subscribers
320 , subscriberInvalidateHeight = \old -> do
335 , subscriberInvalidateHeight = \old -> do
321− FastWeakBag.traverse subscribers $ invalidateSubscriberHeight old
336+ FastWeakBag.traverse_ subscribers $ invalidateSubscriberHeight old
322 , subscriberRecalculateHeight = \new -> do
337 , subscriberRecalculateHeight = \new -> do
323− FastWeakBag.traverse subscribers $ recalculateSubscriberHeight new
338+ FastWeakBag.traverse_ subscribers $ recalculateSubscriberHeight new
325 when (isJust occ) $ do
340 when (isJust occ) $ do
326 liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing
341 liftIO $ writeIORef occRef occ -- Set the initial value of occRef; we don't need to do this if occ is Nothing
@@ -369,7 +384,7 @@ eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed
369eventNever :: Event x a
384eventNever :: Event x a
370eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
385eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing)
372−eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x a
387+eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k v -> Event x (v a)
373eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
388eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f
375eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
390eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a
@@ -421,14 +436,14 @@ newSubscriberHold h = return $ Subscriber
421 , subscriberRecalculateHeight = \_ -> return ()
436 , subscriberRecalculateHeight = \_ -> return ()
424−newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity))
439+newSubscriberFan :: forall x k v. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k v -> IO (Subscriber x (DMap k v))
425newSubscriberFan subscribed = return $ Subscriber
440newSubscriberFan subscribed = return $ Subscriber
426 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
441 { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do
427 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
442 subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed
428 tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
443 tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing"
429 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
444 liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a
430 scheduleClear $ fanSubscribedOccurrence subscribed
445 scheduleClear $ fanSubscribedOccurrence subscribed
431− let f _ (Pair (Identity v) subsubs) = do
446+ let f _ (Pair v subsubs) = do
432 propagate v $ _fanSubscribedChildren_list subsubs
447 propagate v $ _fanSubscribedChildren_list subsubs
433 return $ Constant ()
448 return $ Constant ()
434 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
449 _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_
@@ -436,12 +451,12 @@ newSubscriberFan subscribed = return $ Subscriber
436 , subscriberInvalidateHeight = \old -> do
451 , subscriberInvalidateHeight = \old -> do
437 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
452 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
438 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
453 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
439− forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old
454+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ invalidateSubscriberHeight old
440 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
455 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
441 , subscriberRecalculateHeight = \new -> do
456 , subscriberRecalculateHeight = \new -> do
442 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
457 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed
443 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
458 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
444− forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new
459+ forM_ (DMap.toList subscribers) $ \(_ :=> v) -> WeakBag.traverse_ (_fanSubscribedChildren_list v) $ recalculateSubscriberHeight new
445 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
460 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberFan" <> showNodeId subscribed <> " done"
@@ -457,7 +472,7 @@ newSubscriberSwitch subscribed = return $ Subscriber
457 oldHeight <- readIORef $ switchSubscribedHeight subscribed
472 oldHeight <- readIORef $ switchSubscribedHeight subscribed
458 when (oldHeight /= invalidHeight) $ do
473 when (oldHeight /= invalidHeight) $ do
459 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
474 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
460− WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
475+ WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
461 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
476 when debugInvalidateHeight $ putStrLn $ "invalidateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed <> " done"
462 , subscriberRecalculateHeight = \new -> do
477 , subscriberRecalculateHeight = \new -> do
463 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
478 when debugInvalidateHeight $ putStrLn $ "recalculateSubscriberHeight: SubscriberSwitch" <> showNodeId subscribed
@@ -480,8 +495,8 @@ newSubscriberCoincidenceOuter subscribed = return $ Subscriber
480 Nothing -> do
495 Nothing -> do
481 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
496 when (innerHeight > outerHeight) $ liftIO $ do -- If the event fires, it will fire at a later height
482 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight
497 writeIORef (coincidenceSubscribedHeight subscribed) $! innerHeight
483− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight
498+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight outerHeight
484− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight
499+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight innerHeight
485 Just o -> do -- Since it's already firing, no need to adjust height
500 Just o -> do -- Since it's already firing, no need to adjust height
486 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
501 liftIO $ writeIORef (coincidenceSubscribedOccurrence subscribed) occ
487 scheduleClear $ coincidenceSubscribedOccurrence subscribed
502 scheduleClear $ coincidenceSubscribedOccurrence subscribed
@@ -528,14 +543,14 @@ propagate :: a -> WeakBag (Subscriber x a) -> EventM x ()
528propagate a subscribers = withIncreasedDepth $ do
543propagate a subscribers = withIncreasedDepth $ do
529 -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them
544 -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them
530 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
545 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
531− WeakBag.traverse subscribers $ \s -> subscriberPropagate s a
546+ WeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a
533-- | Propagate everything at the current height
548-- | Propagate everything at the current height
534propagateFast :: a -> FastWeakBag (Subscriber x a) -> EventM x ()
549propagateFast :: a -> FastWeakBag (Subscriber x a) -> EventM x ()
535propagateFast a subscribers = withIncreasedDepth $ do
550propagateFast a subscribers = withIncreasedDepth $ do
536 -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them
551 -- Note: in the following traversal, we do not visit nodes that are added to the list during our traversal; they are new events, which will necessarily have full information already, so there is no need to traverse them
537 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
552 --TODO: Should we check if nodes already have their values before propagating? Maybe we're re-doing work
538− FastWeakBag.traverse subscribers $ \s -> subscriberPropagate s a
553+ FastWeakBag.traverse_ subscribers $ \s -> subscriberPropagate s a
540--------------------------------------------------------------------------------
555--------------------------------------------------------------------------------
541-- EventSubscribed
556-- EventSubscribed
@@ -544,6 +559,11 @@ propagateFast a subscribers = withIncreasedDepth $ do
544toAny :: a -> Any
559toAny :: a -> Any
545toAny = unsafeCoerce
560toAny = unsafeCoerce
562+-- Why do we use Any here, instead of just giving eventSubscribedRetained an
563+-- existential type? Sadly, GHC does not currently know how to unbox types
564+-- with existentially quantified fields. So instead we just coerce values
565+-- to type Any on the way in. Since we never coerce them back, this is
547data EventSubscribed x = EventSubscribed
567data EventSubscribed x = EventSubscribed
548 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
568 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
549 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
569 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
@@ -576,12 +596,12 @@ eventSubscribedNever = EventSubscribed
579−eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x
599+eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x
580eventSubscribedFan !subscribed = EventSubscribed
600eventSubscribedFan !subscribed = EventSubscribed
581 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
601 { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed
582 , eventSubscribedRetained = toAny subscribed
602 , eventSubscribedRetained = toAny subscribed
583#ifdef DEBUG_CYCLES
603#ifdef DEBUG_CYCLES
584− , eventSubscribedGetParents = return [Some.This $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
604+ , eventSubscribedGetParents = return [Some $ _eventSubscription_subscribed $ fanSubscribedParent subscribed]
585 , eventSubscribedHasOwnHeightRef = False
605 , eventSubscribedHasOwnHeightRef = False
586 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
606 , eventSubscribedWhoCreated = whoCreatedIORef $ fanSubscribedCachedSubscribed subscribed
@@ -594,7 +614,7 @@ eventSubscribedSwitch !subscribed = EventSubscribed
594#ifdef DEBUG_CYCLES
614#ifdef DEBUG_CYCLES
595 , eventSubscribedGetParents = do
615 , eventSubscribedGetParents = do
596 s <- readIORef $ switchSubscribedCurrentParent subscribed
616 s <- readIORef $ switchSubscribedCurrentParent subscribed
597− return [Some.This $ _eventSubscription_subscribed s]
617+ return [Some $ _eventSubscription_subscribed s]
598 , eventSubscribedHasOwnHeightRef = True
618 , eventSubscribedHasOwnHeightRef = True
599 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
619 , eventSubscribedWhoCreated = whoCreatedIORef $ switchSubscribedCachedSubscribed subscribed
@@ -607,8 +627,8 @@ eventSubscribedCoincidence !subscribed = EventSubscribed
607#ifdef DEBUG_CYCLES
627#ifdef DEBUG_CYCLES
608 , eventSubscribedGetParents = do
628 , eventSubscribedGetParents = do
609 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
629 innerSubscription <- readIORef $ coincidenceSubscribedInnerParent subscribed
610− let outerParent = Some.This $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
630+ let outerParent = Some $ _eventSubscription_subscribed $ coincidenceSubscribedOuterParent subscribed
611− innerParents = maybeToList $ fmap Some.This innerSubscription
631+ innerParents = maybeToList $ fmap Some innerSubscription
612 return $ outerParent : innerParents
632 return $ outerParent : innerParents
613 , eventSubscribedHasOwnHeightRef = True
633 , eventSubscribedHasOwnHeightRef = True
614 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
634 , eventSubscribedWhoCreated = whoCreatedIORef $ coincidenceSubscribedCachedSubscribed subscribed
@@ -624,13 +644,13 @@ whoCreatedEventSubscribed = eventSubscribedWhoCreated
625walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)]
645walkInvalidHeightParents :: EventSubscribed x -> IO [Some (EventSubscribed x)]
626walkInvalidHeightParents s0 = do
646walkInvalidHeightParents s0 = do
627− subscribers <- flip execStateT mempty $ ($ Some.This s0) $ fix $ \loop (Some.This s) -> do
647+ subscribers <- flip execStateT mempty $ ($ Some s0) $ fix $ \loop (Some s) -> do
628 h <- liftIO $ readIORef $ eventSubscribedHeightRef s
648 h <- liftIO $ readIORef $ eventSubscribedHeightRef s
629 when (h == invalidHeight) $ do
649 when (h == invalidHeight) $ do
630 when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed
650 when (eventSubscribedHasOwnHeightRef s) $ liftIO $ writeIORef (eventSubscribedHeightRef s) $! invalidHeightBeingTraversed
631− modify (Some.This s :)
651+ modify (Some s :)
632 mapM_ loop =<< liftIO (eventSubscribedGetParents s)
652 mapM_ loop =<< liftIO (eventSubscribedGetParents s)
633− forM_ subscribers $ \(Some.This s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
653+ forM_ subscribers $ \(Some s) -> writeIORef (eventSubscribedHeightRef s) $! invalidHeight
634 return subscribers
654 return subscribers
@@ -658,7 +678,7 @@ behaviorPull !p = Behavior $ do
658 val <- liftIO $ readIORef $ pullValue p
678 val <- liftIO $ readIORef $ pullValue p
659 case val of
679 case val of
660 Just subscribed -> do
680 Just subscribed -> do
661− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some.This (BehaviorSubscribedPull subscribed)) :))
681+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedPull subscribed)) :))
662 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))
682 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))
663 liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
683 liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
664 return $ pullSubscribedValue subscribed
684 return $ pullSubscribedValue subscribed
@@ -667,7 +687,7 @@ behaviorPull !p = Behavior $ do
667 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
687 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
668 parentsRef <- liftIO $ newIORef []
688 parentsRef <- liftIO $ newIORef []
669 holdInits <- askBehaviorHoldInits
689 holdInits <- askBehaviorHoldInits
670− a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
690+ a <- liftIO $ runReaderIO (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
671 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
691 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
672 parents <- liftIO $ readIORef parentsRef
692 parents <- liftIO $ readIORef parentsRef
673 let subscribed = PullSubscribed
693 let subscribed = PullSubscribed
@@ -677,7 +697,7 @@ behaviorPull !p = Behavior $ do
677 , pullSubscribedParents = parents
697 , pullSubscribedParents = parents
679 liftIO $ writeIORef (pullValue p) $ Just subscribed
699 liftIO $ writeIORef (pullValue p) $ Just subscribed
680− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some.This (BehaviorSubscribedPull subscribed)) :))
700+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedPull subscribed)) :))
683behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)
703behaviorDyn :: Patch p => Dyn x p -> Behavior x (PatchTarget p)
@@ -688,7 +708,7 @@ readHoldTracked :: Hold x p -> BehaviorM x (PatchTarget p)
688readHoldTracked h = do
708readHoldTracked h = do
689 result <- liftIO $ readIORef $ holdValue h
709 result <- liftIO $ readIORef $ holdValue h
690 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
710 askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
691− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some.This (BehaviorSubscribedHold h)) :))
711+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (Some (BehaviorSubscribedHold h)) :))
692 liftIO $ touch h -- Otherwise, if this gets inlined enough, the hold's parent reference may get collected
712 liftIO $ touch h -- Otherwise, if this gets inlined enough, the hold's parent reference may get collected
693 return result
713 return result
@@ -702,42 +722,46 @@ readBehaviorUntracked b = do
702-- Dynamic
722-- Dynamic
703--------------------------------------------------------------------------------
723--------------------------------------------------------------------------------
725+type DynamicS x p = Dynamic x (PatchTarget p) p
705−data Dynamic x p = Dynamic
727+data Dynamic x target p = Dynamic
706− { dynamicCurrent :: !(Behavior x (PatchTarget p))
728+ { dynamicCurrent :: !(Behavior x target)
707 , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`?
729 , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`?
732+deriving instance (HasSpiderTimeline x) => Functor (Dynamic x target)
710−dynamicHold :: Hold x p -> Dynamic x p
737+dynamicHold :: Hold x p -> DynamicS x p
711dynamicHold !h = Dynamic
738dynamicHold !h = Dynamic
712 { dynamicCurrent = behaviorHold h
739 { dynamicCurrent = behaviorHold h
713 , dynamicUpdated = eventHold h
740 , dynamicUpdated = eventHold h
716−dynamicHoldIdentity :: Hold x (Identity a) -> Dynamic x (Identity a)
743+dynamicHoldIdentity :: Hold x (Identity a) -> DynamicS x (Identity a)
717dynamicHoldIdentity = dynamicHold
744dynamicHoldIdentity = dynamicHold
719−dynamicConst :: PatchTarget p -> Dynamic x p
746+dynamicConst :: PatchTarget p -> DynamicS x p
720dynamicConst !a = Dynamic
747dynamicConst !a = Dynamic
721 { dynamicCurrent = behaviorConst a
748 { dynamicCurrent = behaviorConst a
722 , dynamicUpdated = eventNever
749 , dynamicUpdated = eventNever
725−dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p
752+dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> DynamicS x p
726dynamicDyn !d = Dynamic
753dynamicDyn !d = Dynamic
727 { dynamicCurrent = behaviorDyn d
754 { dynamicCurrent = behaviorDyn d
728 , dynamicUpdated = eventDyn d
755 , dynamicUpdated = eventDyn d
731−dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)
758+dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> DynamicS x (Identity a)
732dynamicDynIdentity = dynamicDyn
759dynamicDynIdentity = dynamicDyn
734--------------------------------------------------------------------------------
761--------------------------------------------------------------------------------
735-- Combinators
762-- Combinators
736--------------------------------------------------------------------------------
763--------------------------------------------------------------------------------
738−--TODO: Figure out why certain things are not 'representational', then make them
739−--representational so we can use coerce
741--type role Hold representational
765--type role Hold representational
742data Hold x p
766data Hold x p
743 = Hold { holdValue :: !(IORef (PatchTarget p))
767 = Hold { holdValue :: !(IORef (PatchTarget p))
@@ -758,20 +782,25 @@ globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv
759-- | Stores all global data relevant to a particular Spider timeline; only one
783-- | Stores all global data relevant to a particular Spider timeline; only one
760-- value should exist for each type @x@
784-- value should exist for each type @x@
785+newtype SpiderTimelineEnv x = STE {unSTE :: SpiderTimelineEnv' x}
786+-- We implement SpiderTimelineEnv with a newtype wrapper so
787+-- we can get the coercions we want safely.
788+type role SpiderTimelineEnv nominal
761−data SpiderTimelineEnv x = SpiderTimelineEnv
790+data SpiderTimelineEnv' x = SpiderTimelineEnv
762 { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
791 { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
763 , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
792 , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
764#ifdef DEBUG
793#ifdef DEBUG
765 , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
794 , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
768−type role SpiderTimelineEnv nominal
797+type role SpiderTimelineEnv' phantom
770instance Eq (SpiderTimelineEnv x) where
799instance Eq (SpiderTimelineEnv x) where
771 _ == _ = True -- Since only one exists of each type
800 _ == _ = True -- Since only one exists of each type
773instance GEq SpiderTimelineEnv where
802instance GEq SpiderTimelineEnv where
774− a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b
803+ a `geq` b = if _spiderTimeline_lock (unSTE a) == _spiderTimeline_lock (unSTE b)
775 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
804 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
776 else Nothing
805 else Nothing
@@ -794,7 +823,7 @@ runEventM :: EventM x a -> IO a
794runEventM = unEventM
823runEventM = unEventM
796asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
825asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
797−asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
826+asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (unSTE (spiderTimeline :: SpiderTimelineEnv x))
799class MonadIO m => Defer a m where
828class MonadIO m => Defer a m where
800 getDeferralQueue :: m (IORef [a])
829 getDeferralQueue :: m (IORef [a])
@@ -861,7 +890,7 @@ instance HasSpiderTimeline x => Defer (Some Clear) (EventM x) where
862{-# INLINE scheduleClear #-}
891{-# INLINE scheduleClear #-}
863scheduleClear :: Defer (Some Clear) m => IORef (Maybe a) -> m ()
892scheduleClear :: Defer (Some Clear) m => IORef (Maybe a) -> m ()
864−scheduleClear r = defer $ Some.This $ Clear r
893+scheduleClear r = defer $ Some $ Clear r
866instance HasSpiderTimeline x => Defer (Some IntClear) (EventM x) where
895instance HasSpiderTimeline x => Defer (Some IntClear) (EventM x) where
867 {-# INLINE getDeferralQueue #-}
896 {-# INLINE getDeferralQueue #-}
@@ -869,7 +898,7 @@ instance HasSpiderTimeline x => Defer (Some IntClear) (EventM x) where
870{-# INLINE scheduleIntClear #-}
899{-# INLINE scheduleIntClear #-}
871scheduleIntClear :: Defer (Some IntClear) m => IORef (IntMap a) -> m ()
900scheduleIntClear :: Defer (Some IntClear) m => IORef (IntMap a) -> m ()
872−scheduleIntClear r = defer $ Some.This $ IntClear r
901+scheduleIntClear r = defer $ Some $ IntClear r
874instance HasSpiderTimeline x => Defer (Some RootClear) (EventM x) where
903instance HasSpiderTimeline x => Defer (Some RootClear) (EventM x) where
875 {-# INLINE getDeferralQueue #-}
904 {-# INLINE getDeferralQueue #-}
@@ -877,7 +906,7 @@ instance HasSpiderTimeline x => Defer (Some RootClear) (EventM x) where
878{-# INLINE scheduleRootClear #-}
907{-# INLINE scheduleRootClear #-}
879scheduleRootClear :: Defer (Some RootClear) m => IORef (DMap k Identity) -> m ()
908scheduleRootClear :: Defer (Some RootClear) m => IORef (DMap k Identity) -> m ()
880−scheduleRootClear r = defer $ Some.This $ RootClear r
909+scheduleRootClear r = defer $ Some $ RootClear r
882instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where
911instance HasSpiderTimeline x => Defer (SomeResetCoincidence x) (EventM x) where
883 {-# INLINE getDeferralQueue #-}
912 {-# INLINE getDeferralQueue #-}
@@ -932,9 +961,9 @@ getHoldEventSubscription h = do
933type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
962type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
935−--type role BehaviorM representational
936-- BehaviorM can sample behaviors
964-- BehaviorM can sample behaviors
937−newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderT (BehaviorEnv x) IO a } deriving (Functor, Applicative, MonadIO, MonadFix)
965+newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderIO (BehaviorEnv x) a }
966+ deriving (Functor, Applicative, MonadIO, MonadFix, MonadReader (BehaviorEnv x))
939instance Monad (BehaviorM x) where
968instance Monad (BehaviorM x) where
940 {-# INLINE (>>=) #-}
969 {-# INLINE (>>=) #-}
@@ -985,7 +1014,7 @@ data RootSubscribed x a = forall k. GCompare k => RootSubscribed
988−data Root x (k :: * -> *)
1017+data Root x k
989 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
1018 = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event
990 , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))
1019 , rootSubscribed :: !(IORef (DMap k (RootSubscribed x)))
991 , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))
1020 , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ()))
@@ -1055,25 +1084,25 @@ heightBagVerify b@(HeightBag s c) = if
1055heightBagVerify = id
1084heightBagVerify = id
1058−data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren
1087+data FanSubscribedChildren x k v a = FanSubscribedChildren
1059− { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a))
1088+ { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x (v a)))
1060− , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k)
1089+ , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k v)
1061− , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k)))
1090+ , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k v)))
1064−data FanSubscribed (x :: *) k
1093+data FanSubscribed x k v
1065− = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1094+ = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))
1066− , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity)))
1095+ , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k v)))
1067− , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty
1096+ , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k v))) -- This DMap should never be empty
1068 , fanSubscribedParent :: !(EventSubscription x)
1097 , fanSubscribedParent :: !(EventSubscription x)
1069#ifdef DEBUG_NODEIDS
1098#ifdef DEBUG_NODEIDS
1070 , fanSubscribedNodeId :: Int
1099 , fanSubscribedNodeId :: Int
1074−data Fan x k
1103+data Fan x k v
1075− = Fan { fanParent :: !(Event x (DMap k Identity))
1104+ = Fan { fanParent :: !(Event x (DMap k v))
1076− , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k)))
1105+ , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k v)))
1079data SwitchSubscribed x a
1108data SwitchSubscribed x a
@@ -1135,19 +1164,27 @@ instance HasSpiderTimeline x => Align (Event x) where
1135#if MIN_VERSION_these(0, 8, 0)
1164#if MIN_VERSION_these(0, 8, 0)
1136instance HasSpiderTimeline x => Semialign (Event x) where
1165instance HasSpiderTimeline x => Semialign (Event x) where
1167+ align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $
1138− align ea eb = mapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
1168+ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb]
1170+#ifdef MIN_VERSION_semialign
1171+#if MIN_VERSION_semialign(1,1,0)
1172+instance HasSpiderTimeline x => Zip (Event x) where
1174+ zip x y = mapMaybe justThese $ align x y
1140data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)
1177data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)
1141 | BuildDyn !(EventM x (PatchTarget p), Event x p)
1178 | BuildDyn !(EventM x (PatchTarget p), Event x p)
1142 | HoldDyn !(Hold x p)
1179 | HoldDyn !(Hold x p)
1144−newtype Dyn x p = Dyn { unDyn :: IORef (DynType x p) }
1181+newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }
1146−newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)
1183+newMapDyn :: HasSpiderTimeline x => (a -> b) -> DynamicS x (Identity a) -> DynamicS x (Identity b)
1147newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
1184newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
1149--TODO: Avoid the duplication between this and R.zipDynWith
1186--TODO: Avoid the duplication between this and R.zipDynWith
1150−zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)
1187+zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> DynamicS x (Identity a) -> DynamicS x (Identity b) -> DynamicS x (Identity c)
1151zipDynWith f da db =
1188zipDynWith f da db =
1152 let eab = align (dynamicUpdated da) (dynamicUpdated db)
1189 let eab = align (dynamicUpdated da) (dynamicUpdated db)
1153 ec = flip push eab $ \o -> do
1190 ec = flip push eab $ \o -> do
@@ -1170,18 +1207,12 @@ buildDynamic readV0 v' = do
1170 return d
1207 return d
1172unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
1209unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
1173−unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ UnsafeDyn x
1210+unsafeBuildDynamic readV0 v' =
1174− where x = (readV0, v')
1211+ Dyn $ unsafePerformIO $ newIORef $ UnsafeDyn (readV0, v')
1176-- ResultM can read behaviors and events
1213-- ResultM can read behaviors and events
1177type ResultM = EventM
1214type ResultM = EventM
1179−{-# NOINLINE unsafeNewIORef #-}
1180−unsafeNewIORef :: a -> b -> IORef b
1181−unsafeNewIORef a b = unsafePerformIO $ do
1185instance HasSpiderTimeline x => Functor (Event x) where
1216instance HasSpiderTimeline x => Functor (Event x) where
1186 fmap f = push $ return . Just . f
1217 fmap f = push $ return . Just . f
@@ -1194,33 +1225,42 @@ push f e = cacheEvent (pushCheap f e)
1195{-# INLINABLE pull #-}
1226{-# INLINABLE pull #-}
1196pull :: BehaviorM x a -> Behavior x a
1227pull :: BehaviorM x a -> Behavior x a
1197−pull a = behaviorPull $ Pull
1228+pull a = unsafePerformIO $ do
1198− { pullCompute = a
1229+ ref <- newIORef Nothing
1199− , pullValue = unsafeNewIORef a Nothing
1200#ifdef DEBUG_NODEIDS
1230#ifdef DEBUG_NODEIDS
1201− , pullNodeId = unsafeNodeId a
1231+ nid <- newNodeId
1233+ pure $ behaviorPull $ Pull
1236+#ifdef DEBUG_NODEIDS
1205{-# INLINABLE switch #-}
1241{-# INLINABLE switch #-}
1206switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
1242switch :: HasSpiderTimeline x => Behavior x (Event x a) -> Event x a
1243+switch a = unsafePerformIO $ do
1244+ ref <- newIORef Nothing
1207−switch a = eventSwitch $ Switch
1245+ pure $ eventSwitch $ Switch
1208− { switchParent = a
1246+ { switchParent = a
1209− , switchSubscribed = unsafeNewIORef a Nothing
1247+ , switchSubscribed = ref
1212coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
1250coincidence :: HasSpiderTimeline x => Event x (Event x a) -> Event x a
1251+coincidence a = unsafePerformIO $ do
1252+ ref <- newIORef Nothing
1213−coincidence a = eventCoincidence $ Coincidence
1253+ pure $ eventCoincidence $ Coincidence
1214− { coincidenceParent = a
1254+ { coincidenceParent = a
1215− , coincidenceSubscribed = unsafeNewIORef a Nothing
1255+ , coincidenceSubscribed = ref
1218-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
1258-- Propagate the given event occurrence; before cleaning up, run the given action, which may read the state of events and behaviors
1219run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
1259run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> ResultM x b -> SpiderHost x b
1220run roots after = do
1260run roots after = do
1221 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
1261 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
1222 let t = spiderTimeline :: SpiderTimelineEnv x
1262 let t = spiderTimeline :: SpiderTimelineEnv x
1223− result <- SpiderHost $ withMVar (_spiderTimeline_lock t) $ \_ -> unSpiderHost $ runFrame $ do
1263+ result <- SpiderHost $ withMVar (_spiderTimeline_lock (unSTE t)) $ \_ -> unSpiderHost $ runFrame $ do
1224 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
1264 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
1225 occBefore <- liftIO $ do
1265 occBefore <- liftIO $ do
1226 occBefore <- readIORef occRef
1266 occBefore <- readIORef occRef
@@ -1284,9 +1324,9 @@ type WeakList a = [Weak a]
1284withIncreasedDepth :: CanTrace x m => m a -> m a
1324withIncreasedDepth :: CanTrace x m => m a -> m a
1285withIncreasedDepth a = do
1325withIncreasedDepth a = do
1286 spiderTimeline <- askSpiderTimelineEnv
1326 spiderTimeline <- askSpiderTimelineEnv
1287− liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ
1327+ liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) succ
1288 result <- a
1328 result <- a
1289− liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred
1329+ liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) pred
1290 return result
1330 return result
1292withIncreasedDepth :: m a -> m a
1332withIncreasedDepth :: m a -> m a
@@ -1313,7 +1353,7 @@ traceMWhen _ b getMessage = when b $ do
1313 message <- getMessage
1353 message <- getMessage
1314#ifdef DEBUG
1354#ifdef DEBUG
1315 spiderTimeline <- askSpiderTimelineEnv
1355 spiderTimeline <- askSpiderTimelineEnv
1316− d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline
1356+ d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE spiderTimeline
1318 let d = 0
1358 let d = 0
@@ -1354,25 +1394,25 @@ propagateSubscriberHold h a = do
1354data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1394data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1356runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a
1396runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a
1357−runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)
1397+runBehaviorM a mwi holdInits = runReaderIO (unBehaviorM a) (mwi, holdInits)
1359askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
1399askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
1360askInvalidator = do
1400askInvalidator = do
1361− (!m, _) <- BehaviorM ask
1401+ (!m, _) <- ask
1362 case m of
1402 case m of
1363 Nothing -> return Nothing
1403 Nothing -> return Nothing
1364 Just (!wi, _) -> return $ Just wi
1404 Just (!wi, _) -> return $ Just wi
1366askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
1406askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
1367askParentsRef = do
1407askParentsRef = do
1368− (!m, _) <- BehaviorM ask
1408+ (!m, _) <- ask
1369 case m of
1409 case m of
1370 Nothing -> return Nothing
1410 Nothing -> return Nothing
1371 Just (_, !p) -> return $ Just p
1411 Just (_, !p) -> return $ Just p
1373askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
1413askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
1374askBehaviorHoldInits = do
1414askBehaviorHoldInits = do
1375− (_, !his) <- BehaviorM ask
1415+ (_, !his) <- ask
1376 return his
1416 return his
1378{-# INLINE getDynHold #-}
1418{-# INLINE getDynHold #-}
@@ -1417,6 +1457,9 @@ getRootSubscribed k r sub = do
1417 when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
1457 when debugPropagate $ putStrLn $ "getRootSubscribed: calling rootInit"
1418 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1458 uninit <- rootInit r k $ RootTrigger (subs, rootOccurrence r, k)
1419 writeIORef uninitRef $! uninit
1459 writeIORef uninitRef $! uninit
1460+#ifdef DEBUG_NODEIDS
1420 let !subscribed = RootSubscribed
1463 let !subscribed = RootSubscribed
1421 { rootSubscribedKey = k
1464 { rootSubscribedKey = k
1422 , rootSubscribedCachedSubscribed = cached
1465 , rootSubscribedCachedSubscribed = cached
@@ -1425,7 +1468,7 @@ getRootSubscribed k r sub = do
1425 , rootSubscribedUninit = uninit
1468 , rootSubscribedUninit = uninit
1426 , rootSubscribedWeakSelf = weakSelf
1469 , rootSubscribedWeakSelf = weakSelf
1427#ifdef DEBUG_NODEIDS
1470#ifdef DEBUG_NODEIDS
1428− , rootSubscribedNodeId = unsafeNodeId (k, r, subs)
1471+ , rootSubscribedNodeId = nid
1431 -- If we die at the same moment that all our children die, they will
1474 -- If we die at the same moment that all our children die, they will
@@ -1474,16 +1517,10 @@ newFanInt = do
1474 , _fanInt_occRef = occRef
1517 , _fanInt_occRef = occRef
1477−{-# NOINLINE unsafeNewFanInt #-}
1478−unsafeNewFanInt :: b -> FanInt x a
1479−unsafeNewFanInt b = unsafePerformIO $ do
1483fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
1520fanInt :: HasSpiderTimeline x => Event x (IntMap a) -> EventSelectorInt x a
1484−fanInt p =
1521+fanInt p = unsafePerformIO $ do
1485− let self = unsafeNewFanInt p
1522+ self <- newFanInt
1486− in EventSelectorInt $ \k -> Event $ \sub -> do
1523+ pure $ EventSelectorInt $ \k -> Event $ \sub -> do
1487 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
1524 isEmpty <- liftIO $ FastMutableIntMap.isEmpty (_fanInt_subscribers self)
1488 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input
1525 when isEmpty $ do -- This is the first subscriber, so we need to subscribe to our input
1489 (subscription, parentOcc) <- subscribeAndRead p $ Subscriber
1526 (subscription, parentOcc) <- subscribeAndRead p $ Subscriber
@@ -1491,15 +1528,15 @@ fanInt p =
1491 liftIO $ writeIORef (_fanInt_occRef self) m
1528 liftIO $ writeIORef (_fanInt_occRef self) m
1492 scheduleIntClear $ _fanInt_occRef self
1529 scheduleIntClear $ _fanInt_occRef self
1493 FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do --TODO: Do we need to know that no subscribers are being added as we traverse?
1530 FastMutableIntMap.forIntersectionWithImmutable_ (_fanInt_subscribers self) m $ \b v -> do --TODO: Do we need to know that no subscribers are being added as we traverse?
1494− FastWeakBag.traverse b $ \s -> do
1531+ FastWeakBag.traverse_ b $ \s -> do
1495 subscriberPropagate s v
1532 subscriberPropagate s v
1496 , subscriberInvalidateHeight = \old -> do
1533 , subscriberInvalidateHeight = \old -> do
1497 FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1534 FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1498− FastWeakBag.traverse b $ \s -> do
1535+ FastWeakBag.traverse_ b $ \s -> do
1499 subscriberInvalidateHeight s old
1536 subscriberInvalidateHeight s old
1500 , subscriberRecalculateHeight = \new -> do
1537 , subscriberRecalculateHeight = \new -> do
1501 FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1538 FastMutableIntMap.for_ (_fanInt_subscribers self) $ \b -> do
1502− FastWeakBag.traverse b $ \s -> do
1539+ FastWeakBag.traverse_ b $ \s -> do
1503 subscriberRecalculateHeight s new
1540 subscriberRecalculateHeight s new
1505 liftIO $ do
1542 liftIO $ do
@@ -1519,7 +1556,7 @@ fanInt p =
1519 return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)
1556 return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc)
1521{-# INLINABLE getFanSubscribed #-}
1558{-# INLINABLE getFanSubscribed #-}
1522−getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket, FanSubscribed x k, Maybe a)
1559+getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a))
1523getFanSubscribed k f sub = do
1560getFanSubscribed k f sub = do
1524 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
1561 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
1525 case mSubscribed of
1562 case mSubscribed of
@@ -1537,13 +1574,16 @@ getFanSubscribed k f sub = do
1537 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
1574 subscribersRef <- liftIO $ newIORef $ error "getFanSubscribed: subscribersRef not yet initialized"
1538 occRef <- liftIO $ newIORef parentOcc
1575 occRef <- liftIO $ newIORef parentOcc
1539 when (isJust parentOcc) $ scheduleClear occRef
1576 when (isJust parentOcc) $ scheduleClear occRef
1577+#ifdef DEBUG_NODEIDS
1578+ nid <- liftIO newNodeId
1540 let subscribed = FanSubscribed
1580 let subscribed = FanSubscribed
1541 { fanSubscribedCachedSubscribed = fanSubscribed f
1581 { fanSubscribedCachedSubscribed = fanSubscribed f
1542 , fanSubscribedOccurrence = occRef
1582 , fanSubscribedOccurrence = occRef
1543 , fanSubscribedParent = subscription
1583 , fanSubscribedParent = subscription
1544 , fanSubscribedSubscribers = subscribersRef
1584 , fanSubscribedSubscribers = subscribersRef
1545#ifdef DEBUG_NODEIDS
1585#ifdef DEBUG_NODEIDS
1546− , fanSubscribedNodeId = unsafeNodeId f
1586+ , fanSubscribedNodeId = nid
1549 let !self = (k, subscribed)
1589 let !self = (k, subscribed)
@@ -1553,7 +1593,7 @@ getFanSubscribed k f sub = do
1553 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
1593 liftIO $ writeIORef (fanSubscribed f) $ Just subscribed
1554 return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
1594 return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc)
1556−cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO ()
1596+cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k v) -> IO ()
1557cleanupFanSubscribed (k, subscribed) = do
1597cleanupFanSubscribed (k, subscribed) = do
1558 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1598 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1559 let reducedSubscribers = DMap.delete k subscribers
1599 let reducedSubscribers = DMap.delete k subscribers
@@ -1565,7 +1605,7 @@ cleanupFanSubscribed (k, subscribed) = do
1565 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
1605 else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers
1567{-# INLINE subscribeFanSubscribed #-}
1607{-# INLINE subscribeFanSubscribed #-}
1568−subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket
1608+subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k v -> Subscriber x (v a) -> IO WeakBagTicket
1569subscribeFanSubscribed k subscribed sub = do
1609subscribeFanSubscribed k subscribed sub = do
1570 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1610 subscribers <- readIORef $ fanSubscribedSubscribers subscribed
1571 case DMap.lookup k subscribers of
1611 case DMap.lookup k subscribers of
@@ -1603,6 +1643,9 @@ getSwitchSubscribed s sub = do
1603 when (isJust parentOcc) $ scheduleClear occRef
1643 when (isJust parentOcc) $ scheduleClear occRef
1604 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1644 weakSelf <- liftIO $ newIORef $ error "getSwitchSubscribed: weakSelf not yet initialized"
1605 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1645 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupSwitchSubscribed
1646+#ifdef DEBUG_NODEIDS
1647+ nid <- liftIO newNodeId
1606 let !subscribed = SwitchSubscribed
1649 let !subscribed = SwitchSubscribed
1607 { switchSubscribedCachedSubscribed = switchSubscribed s
1650 { switchSubscribedCachedSubscribed = switchSubscribed s
1608 , switchSubscribedOccurrence = occRef
1651 , switchSubscribedOccurrence = occRef
@@ -1615,7 +1658,7 @@ getSwitchSubscribed s sub = do
1615 , switchSubscribedCurrentParent = subscriptionRef
1658 , switchSubscribedCurrentParent = subscriptionRef
1616 , switchSubscribedWeakSelf = weakSelf
1659 , switchSubscribedWeakSelf = weakSelf
1617#ifdef DEBUG_NODEIDS
1660#ifdef DEBUG_NODEIDS
1618− , switchSubscribedNodeId = unsafeNodeId s
1661+ , switchSubscribedNodeId = nid
1621 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
1664 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "switchSubscribedWeakSelf"
@@ -1660,6 +1703,9 @@ getCoincidenceSubscribed c sub = do
1660 scheduleClear innerSubdRef
1703 scheduleClear innerSubdRef
1661 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
1704 weakSelf <- liftIO $ newIORef $ error "getCoincidenceSubscribed: weakSelf not yet implemented"
1662 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1705 (subs, slnForSub) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCoincidenceSubscribed
1706+#ifdef DEBUG_NODEIDS
1707+ nid <- liftIO newNodeId
1663 let subscribed = CoincidenceSubscribed
1709 let subscribed = CoincidenceSubscribed
1664 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
1710 { coincidenceSubscribedCachedSubscribed = coincidenceSubscribed c
1665 , coincidenceSubscribedOccurrence = occRef
1711 , coincidenceSubscribedOccurrence = occRef
@@ -1670,7 +1716,7 @@ getCoincidenceSubscribed c sub = do
1670 , coincidenceSubscribedInnerParent = innerSubdRef
1716 , coincidenceSubscribedInnerParent = innerSubdRef
1671 , coincidenceSubscribedWeakSelf = weakSelf
1717 , coincidenceSubscribedWeakSelf = weakSelf
1672#ifdef DEBUG_NODEIDS
1718#ifdef DEBUG_NODEIDS
1673− , coincidenceSubscribedNodeId = unsafeNodeId c
1719+ , coincidenceSubscribedNodeId = nid
1676 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
1722 liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "CoincidenceSubscribed"
@@ -1687,26 +1733,34 @@ cleanupCoincidenceSubscribed subscribed = do
1687subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1733subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket
1688subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
1734subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed
1690−{-# INLINE merge #-}
1736+{-# INLINE mergeG #-}
1691−merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1737+mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)
1738+ => (forall a. q a -> Event x (v a))
1739+ -> DynamicS x (PatchDMap k q) -> Event x (DMap k v)
1692−merge d = cacheEvent (mergeCheap d)
1740+mergeG nt d = cacheEvent (mergeCheap nt d)
1694{-# INLINE mergeWithMove #-}
1742{-# INLINE mergeWithMove #-}
1695−mergeWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1743+mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)
1744+ => (forall a. q a -> Event x (v a))
1745+ -> DynamicS x (PatchDMapWithMove k q) -> Event x (DMap k v)
1696−mergeWithMove d = cacheEvent (mergeCheapWithMove d)
1746+mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)
1698{-# INLINE [1] mergeCheap #-}
1748{-# INLINE [1] mergeCheap #-}
1699−mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity)
1750+ :: forall k x q v. (HasSpiderTimeline x, GCompare k)
1751+ => (forall a. q a -> Event x (v a))
1752+ -> DynamicS x (PatchDMap k q)
1753+ -> Event x (DMap k v)
1700−mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy
1754+mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy
1702− updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x)
1756+ updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x)
1703 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
1757 updateMe subscriber heightBagRef oldParents (PatchDMap p) = do
1704 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do
1758 let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do
1705 (mOldSubd, newPs) <- case me of
1759 (mOldSubd, newPs) <- case me of
1706 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1760 Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps
1707 Just e -> do
1761 Just e -> do
1708 let s = subscriber $ return k
1762 let s = subscriber $ return k
1709− subscription@(EventSubscription _ subd) <- subscribe e s
1763+ subscription@(EventSubscription _ subd) <- subscribe (nt e) s
1710 newParentHeight <- liftIO $ getEventSubscribedHeight subd
1764 newParentHeight <- liftIO $ getEventSubscribedHeight subd
1711 let newParent = MergeSubscribedParent subscription
1765 let newParent = MergeSubscribedParent subscription
1712 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1766 liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight
@@ -1716,28 +1770,33 @@ mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy
1716 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1770 liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight
1717 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
1771 return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs)
1718 foldM f ([], oldParents) $ DMap.toList p
1772 foldM f ([], oldParents) $ DMap.toList p
1719− getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x)
1774+ getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParent x)
1720 getInitialSubscribers initialParents subscriber = do
1775 getInitialSubscribers initialParents subscriber = do
1721 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1776 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1722 let s = subscriber $ return k
1777 let s = subscriber $ return k
1723− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1778+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s
1724 height <- liftIO $ getEventSubscribedHeight parentSubd
1779 height <- liftIO $ getEventSubscribedHeight parentSubd
1725− return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription)
1780+ return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParent subscription)
1726 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1781 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1727 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1782 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1728 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1783 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1730 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)
1786 destroy :: MergeDestroyFunc k (MergeSubscribedParent x)
1731 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub
1787 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub
1733{-# INLINE [1] mergeCheapWithMove #-}
1789{-# INLINE [1] mergeCheapWithMove #-}
1734−mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity)
1790+mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)
1791+ => (forall a. q a -> Event x (v a))
1792+ -> DynamicS x (PatchDMapWithMove k q)
1793+ -> Event x (DMap k v)
1735−mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
1794+mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy
1737− updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k)
1796+ updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k)
1738 updateMe subscriber heightBagRef oldParents p = do
1797 updateMe subscriber heightBagRef oldParents p = do
1739 -- Prepare new parents for insertion
1798 -- Prepare new parents for insertion
1740− let subscribeParent :: forall a. k a -> Event x a -> EventM x (MergeSubscribedParentWithMove x k a)
1799+ let subscribeParent :: forall a. k a -> Event x (v a) -> EventM x (MergeSubscribedParentWithMove x k a)
1741 subscribeParent k e = do
1800 subscribeParent k e = do
1742 keyRef <- liftIO $ newIORef k
1801 keyRef <- liftIO $ newIORef k
1743 let s = subscriber $ liftIO $ readIORef keyRef
1802 let s = subscriber $ liftIO $ readIORef keyRef
@@ -1746,9 +1805,9 @@ mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
1746 newParentHeight <- getEventSubscribedHeight subd
1805 newParentHeight <- getEventSubscribedHeight subd
1747 modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1806 modifyIORef' heightBagRef $ heightBagAdd newParentHeight
1748 return $ MergeSubscribedParentWithMove subscription keyRef
1807 return $ MergeSubscribedParentWithMove subscription keyRef
1749− p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p
1808+ p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey (\k q -> subscribeParent k (nt q)) p
1750 -- Collect old parents for deletion and update the keys of moved parents
1809 -- Collect old parents for deletion and update the keys of moved parents
1751− let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
1810+ let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a
1752 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
1811 moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of
1753 Nothing -> do
1812 Nothing -> do
1754 oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent
1813 oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent
@@ -1759,46 +1818,47 @@ mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy
1759 return Nothing
1818 return Nothing
1760 toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1819 toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents
1761 return (toDelete, applyAlways p' oldParents)
1820 return (toDelete, applyAlways p' oldParents)
1762− getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k)
1821+ getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k)
1763 getInitialSubscribers initialParents subscriber = do
1822 getInitialSubscribers initialParents subscriber = do
1764 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1823 subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do
1765 keyRef <- liftIO $ newIORef k
1824 keyRef <- liftIO $ newIORef k
1766 let s = subscriber $ liftIO $ readIORef keyRef
1825 let s = subscriber $ liftIO $ readIORef keyRef
1767− (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s
1826+ (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s
1768 height <- liftIO $ getEventSubscribedHeight parentSubd
1827 height <- liftIO $ getEventSubscribedHeight parentSubd
1769− return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
1828+ return (fmap (k :=>) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef)
1770 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1829 return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers
1771 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1830 , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here
1772 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1831 , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers
1774 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)
1834 destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k)
1775 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub
1835 destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub
1777−type MergeUpdateFunc k x p s
1837+type MergeUpdateFunc k v x p s
1778− = (forall a. EventM x (k a) -> Subscriber x a)
1838+ = (forall a. EventM x (k a) -> Subscriber x (v a))
1779 -> IORef HeightBag
1839 -> IORef HeightBag
1780 -> DMap k s
1840 -> DMap k s
1782 -> EventM x ([EventSubscription x], DMap k s)
1842 -> EventM x ([EventSubscription x], DMap k s)
1784−type MergeInitFunc k x s
1844+type MergeInitFunc k v q x s
1785− = DMap k (Event x)
1845+ = DMap k q
1786− -> (forall a. EventM x (k a) -> Subscriber x a)
1846+ -> (forall a. EventM x (k a) -> Subscriber x (v a))
1787− -> EventM x (DMap k Identity, [Height], DMap k s)
1847+ -> EventM x (DMap k v, [Height], DMap k s)
1789type MergeDestroyFunc k s
1849type MergeDestroyFunc k s
1790 = DMap k s
1850 = DMap k s
1791 -> IO ()
1851 -> IO ()
1793−data Merge x k s = Merge
1853+data Merge x k v s = Merge
1794 { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))
1854 { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s))
1795 , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)
1855 , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag)
1796 , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)
1856 , _merge_heightRef :: {-# UNPACK #-} !(IORef Height)
1797− , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k Identity))
1857+ , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k v))
1798− , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity))
1858+ , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k v))
1801−invalidateMergeHeight :: Merge x k s -> IO ()
1861+invalidateMergeHeight :: Merge x k v s -> IO ()
1802invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)
1862invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m)
1804invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
1864invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO ()
@@ -1808,8 +1868,7 @@ invalidateMergeHeight' heightRef sub = do
1808 writeIORef heightRef $! invalidHeight
1868 writeIORef heightRef $! invalidHeight
1809 subscriberInvalidateHeight sub oldHeight
1869 subscriberInvalidateHeight sub oldHeight
1812−revalidateMergeHeight :: Merge x k s -> IO ()
1871+revalidateMergeHeight :: Merge x k v s -> IO ()
1813revalidateMergeHeight m = do
1872revalidateMergeHeight m = do
1814 currentHeight <- readIORef $ _merge_heightRef m
1873 currentHeight <- readIORef $ _merge_heightRef m
1815 when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
1874 when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check
@@ -1825,19 +1884,19 @@ revalidateMergeHeight m = do
1825 subscriberRecalculateHeight (_merge_sub m) height
1884 subscriberRecalculateHeight (_merge_sub m) height
1826 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
1885 GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge"
1828−scheduleMergeSelf :: HasSpiderTimeline x => Merge x k s -> Height -> EventM x ()
1887+scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x ()
1829scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
1888scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do
1830 vals <- liftIO $ readIORef $ _merge_accumRef m
1889 vals <- liftIO $ readIORef $ _merge_accumRef m
1831 liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us, it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers
1890 liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us, it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers
1832 --TODO: Assert that m is not empty
1891 --TODO: Assert that m is not empty
1833 subscriberPropagate (_merge_sub m) vals
1892 subscriberPropagate (_merge_sub m) vals
1835−mergeSubscriber :: forall x k s a. (HasSpiderTimeline x, GCompare k) => Merge x k s -> EventM x (k a) -> Subscriber x a
1894+mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => Merge x k v s -> EventM x (k a) -> Subscriber x (v a)
1836mergeSubscriber m getKey = Subscriber
1895mergeSubscriber m getKey = Subscriber
1837 { subscriberPropagate = \a -> do
1896 { subscriberPropagate = \a -> do
1838 oldM <- liftIO $ readIORef $ _merge_accumRef m
1897 oldM <- liftIO $ readIORef $ _merge_accumRef m
1839 k <- getKey
1898 k <- getKey
1840− let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM
1899+ let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k a oldM
1841 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
1900 tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM)
1842 liftIO $ writeIORef (_merge_accumRef m) $! newM
1901 liftIO $ writeIORef (_merge_accumRef m) $! newM
1843 when (DMap.null oldM) $ do -- Only schedule the firing once
1902 when (DMap.null oldM) $ do -- Only schedule the firing once
@@ -1852,7 +1911,7 @@ mergeSubscriber m getKey = Subscriber
1852 else liftIO $ do
1911 else liftIO $ do
1853#ifdef DEBUG_CYCLES
1912#ifdef DEBUG_CYCLES
1854 nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1913 nodesInvolvedInCycle <- walkInvalidHeightParents $ eventSubscribedMerge subscribed
1855− stacks <- forM nodesInvolvedInCycle $ \(Some.This es) -> whoCreatedEventSubscribed es
1914+ stacks <- forM nodesInvolvedInCycle $ \(Some es) -> whoCreatedEventSubscribed es
1856 let cycleInfo = ":\n" <> drawForest (listsToForest stacks)
1915 let cycleInfo = ":\n" <> drawForest (listsToForest stacks)
1858 let cycleInfo = ""
1917 let cycleInfo = ""
@@ -1868,7 +1927,7 @@ mergeSubscriber m getKey = Subscriber
1870--TODO: Be able to run as much of this as possible promptly
1929--TODO: Be able to run as much of this as possible promptly
1871−updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k s -> MergeUpdateFunc k x p s -> p -> SomeMergeUpdate x
1930+updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x
1872updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
1931updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m)
1873 where updateMe = do
1932 where updateMe = do
1874 oldParents <- liftIO $ readIORef $ _merge_parentsRef m
1933 oldParents <- liftIO $ readIORef $ _merge_parentsRef m
@@ -1876,9 +1935,10 @@ updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m)
1876 liftIO $ writeIORef (_merge_parentsRef m) $! newParents
1935 liftIO $ writeIORef (_merge_parentsRef m) $! newParents
1877 return subscriptionsToKill
1936 return subscriptionsToKill
1879−{-# INLINE mergeCheap' #-}
1938+{-# INLINE mergeGCheap' #-}
1939+mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)
1880−mergeCheap' :: forall k x p s. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k (Event x)) => MergeInitFunc k x s -> MergeUpdateFunc k x p s -> MergeDestroyFunc k s -> Dynamic x p -> Event x (DMap k Identity)
1940+ => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v)
1881−mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1941+mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1882 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1942 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1883 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
1943 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
1884 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
1944 heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized"
@@ -1926,11 +1986,11 @@ mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1929−mergeInt :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1989+mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1930mergeInt = cacheEvent . mergeIntCheap
1990mergeInt = cacheEvent . mergeIntCheap
1932{-# INLINABLE mergeIntCheap #-}
1992{-# INLINABLE mergeIntCheap #-}
1933−mergeIntCheap :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1993+mergeIntCheap :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)
1934mergeIntCheap d = Event $ \sub -> do
1994mergeIntCheap d = Event $ \sub -> do
1935 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1995 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1936 accum <- liftIO $ FastMutableIntMap.newEmpty
1996 accum <- liftIO $ FastMutableIntMap.newEmpty
@@ -2027,14 +2087,16 @@ mergeIntCheap d = Event $ \sub -> do
2029newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
2089newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a }
2090+newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) }
2031−fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k
2092+fanG :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k v) -> EventSelectorG x k v
2032−fan e =
2093+fanG e = unsafePerformIO $ do
2094+ ref <- newIORef Nothing
2033 let f = Fan
2095 let f = Fan
2034 { fanParent = e
2096 { fanParent = e
2035− , fanSubscribed = unsafeNewIORef e Nothing
2097+ , fanSubscribed = ref
2037− in EventSelector $ \k -> eventFan k f
2099+ pure $ EventSelectorG $ \k -> eventFan k f
2039runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()
2101runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x ()
2040runHoldInits holdInitRef dynInitRef mergeInitRef = do
2102runHoldInits holdInitRef dynInitRef mergeInitRef = do
@@ -2088,18 +2150,18 @@ clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeI
2088-- | Run an event action outside of a frame
2150-- | Run an event action outside of a frame
2089runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
2151runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
2090runFrame a = SpiderHost $ do
2152runFrame a = SpiderHost $ do
2091− let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
2153+ let env = _spiderTimeline_eventEnv $ unSTE (spiderTimeline :: SpiderTimelineEnv x)
2092 let go = do
2154 let go = do
2093 result <- a
2155 result <- a
2094 runHoldInits (eventEnvHoldInits env) (eventEnvDynInits env) (eventEnvMergeInits env) -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events
2156 runHoldInits (eventEnvHoldInits env) (eventEnvDynInits env) (eventEnvMergeInits env) -- This must happen before doing the assignments, in case subscribing a Hold causes existing Holds to be read by the newly-propagated events
2095 return result
2157 return result
2096 result <- runEventM go
2158 result <- runEventM go
2097 toClear <- readIORef $ eventEnvClears env
2159 toClear <- readIORef $ eventEnvClears env
2098− forM_ toClear $ \(Some.This (Clear ref)) -> {-# SCC "clear" #-} writeIORef ref Nothing
2160+ forM_ toClear $ \(Some (Clear ref)) -> {-# SCC "clear" #-} writeIORef ref Nothing
2099 toClearInt <- readIORef $ eventEnvIntClears env
2161 toClearInt <- readIORef $ eventEnvIntClears env
2100− forM_ toClearInt $ \(Some.This (IntClear ref)) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty
2162+ forM_ toClearInt $ \(Some (IntClear ref)) -> {-# SCC "intClear" #-} writeIORef ref $! IntMap.empty
2101 toClearRoot <- readIORef $ eventEnvRootClears env
2163 toClearRoot <- readIORef $ eventEnvRootClears env
2102− forM_ toClearRoot $ \(Some.This (RootClear ref)) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
2164+ forM_ toClearRoot $ \(Some (RootClear ref)) -> {-# SCC "rootClear" #-} writeIORef ref $! DMap.empty
2103 toAssign <- readIORef $ eventEnvAssignments env
2165 toAssign <- readIORef $ eventEnvAssignments env
2104 toReconnectRef <- newIORef []
2166 toReconnectRef <- newIORef []
2105 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env
2167 coincidenceInfos <- readIORef $ eventEnvResetCoincidences env
@@ -2146,7 +2208,7 @@ runFrame a = SpiderHost $ do
2146 myHeight <- readIORef $ switchSubscribedHeight subscribed
2208 myHeight <- readIORef $ switchSubscribedHeight subscribed
2147 when (parentHeight /= myHeight) $ do
2209 when (parentHeight /= myHeight) $ do
2148 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
2210 writeIORef (switchSubscribedHeight subscribed) $! invalidHeight
2149− WeakBag.traverse (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
2211+ WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ invalidateSubscriberHeight myHeight
2150 mapM_ _someMergeUpdate_invalidateHeight mergeUpdates --TODO: In addition to when the patch is completely empty, we should also not run this if it has some Nothing values, but none of them have actually had any effect; potentially, we could even check for Just values with no effect (e.g. by comparing their IORefs and ignoring them if they are unchanged); actually, we could just check if the new height is different
2212 mapM_ _someMergeUpdate_invalidateHeight mergeUpdates --TODO: In addition to when the patch is completely empty, we should also not run this if it has some Nothing values, but none of them have actually had any effect; potentially, we could even check for Just values with no effect (e.g. by comparing their IORefs and ignoring them if they are unchanged); actually, we could just check if the new height is different
2151 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
2213 forM_ coincidenceInfos $ \(SomeResetCoincidence subscription mcs) -> do
2152 unsubscribe subscription
2214 unsubscribe subscription
@@ -2187,7 +2249,7 @@ invalidateCoincidenceHeight subscribed = do
2187 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
2249 oldHeight <- readIORef $ coincidenceSubscribedHeight subscribed
2188 when (oldHeight /= invalidHeight) $ do
2250 when (oldHeight /= invalidHeight) $ do
2189 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight
2251 writeIORef (coincidenceSubscribedHeight subscribed) $! invalidHeight
2190− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
2252+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ invalidateSubscriberHeight oldHeight
2192updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()
2254updateSwitchHeight :: Height -> SwitchSubscribed x a -> IO ()
2193updateSwitchHeight new subscribed = do
2255updateSwitchHeight new subscribed = do
@@ -2195,7 +2257,7 @@ updateSwitchHeight new subscribed = do
2195 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2257 when (oldHeight == invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2196 when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2258 when (new /= invalidHeight) $ do --TODO: This 'when' should probably be an assertion
2197 writeIORef (switchSubscribedHeight subscribed) $! new
2259 writeIORef (switchSubscribedHeight subscribed) $! new
2198− WeakBag.traverse (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
2260+ WeakBag.traverse_ (switchSubscribedSubscribers subscribed) $ recalculateSubscriberHeight new
2200recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
2262recalculateCoincidenceHeight :: CoincidenceSubscribed x a -> IO ()
2201recalculateCoincidenceHeight subscribed = do
2263recalculateCoincidenceHeight subscribed = do
@@ -2204,7 +2266,7 @@ recalculateCoincidenceHeight subscribed = do
2204 height <- calculateCoincidenceHeight subscribed
2266 height <- calculateCoincidenceHeight subscribed
2205 when (height /= invalidHeight) $ do
2267 when (height /= invalidHeight) $ do
2206 writeIORef (coincidenceSubscribedHeight subscribed) $! height
2268 writeIORef (coincidenceSubscribedHeight subscribed) $! height
2207− WeakBag.traverse (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
2269+ WeakBag.traverse_ (coincidenceSubscribedSubscribers subscribed) $ recalculateSubscriberHeight height
2209calculateSwitchHeight :: SwitchSubscribed x a -> IO Height
2271calculateSwitchHeight :: SwitchSubscribed x a -> IO Height
2210calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
2272calculateSwitchHeight subscribed = getEventSubscribedHeight . _eventSubscription_subscribed =<< readIORef (switchSubscribedCurrentParent subscribed)
@@ -2299,7 +2361,7 @@ instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x))
2299 fail _ = error "Dynamic does not support 'fail'"
2361 fail _ = error "Dynamic does not support 'fail'"
2301{-# INLINABLE newJoinDyn #-}
2363{-# INLINABLE newJoinDyn #-}
2302−newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)
2364+newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)
2303newJoinDyn d =
2365newJoinDyn d =
2304 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)
2366 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)
2305 eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d
2367 eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d
@@ -2449,7 +2511,7 @@ unsafeNewSpiderTimelineEnv = do
2449#ifdef DEBUG
2511#ifdef DEBUG
2450 depthRef <- newIORef 0
2512 depthRef <- newIORef 0
2452− return $ SpiderTimelineEnv
2514+ return $ STE $ SpiderTimelineEnv
2453 { _spiderTimeline_lock = lock
2515 { _spiderTimeline_lock = lock
2454 , _spiderTimeline_eventEnv = env
2516 , _spiderTimeline_eventEnv = env
2455#ifdef DEBUG
2517#ifdef DEBUG
@@ -2459,19 +2521,19 @@ unsafeNewSpiderTimelineEnv = do
2460-- | Create a new SpiderTimelineEnv
2522-- | Create a new SpiderTimelineEnv
2461newSpiderTimeline :: IO (Some SpiderTimelineEnv)
2523newSpiderTimeline :: IO (Some SpiderTimelineEnv)
2462−newSpiderTimeline = withSpiderTimeline (pure . Some.This)
2524+newSpiderTimeline = withSpiderTimeline (pure . Some)
2464−data LocalSpiderTimeline x s
2526+data LocalSpiderTimeline (x :: Type) s
2466instance Reifies s (SpiderTimelineEnv x) =>
2528instance Reifies s (SpiderTimelineEnv x) =>
2467 HasSpiderTimeline (LocalSpiderTimeline x s) where
2529 HasSpiderTimeline (LocalSpiderTimeline x s) where
2468− spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s)
2530+ spiderTimeline = localSpiderTimeline Proxy $ reflect (Proxy :: Proxy s)
2470localSpiderTimeline
2532localSpiderTimeline
2471− :: Proxy s
2533+ :: proxy s
2472 -> SpiderTimelineEnv x
2534 -> SpiderTimelineEnv x
2473 -> SpiderTimelineEnv (LocalSpiderTimeline x s)
2535 -> SpiderTimelineEnv (LocalSpiderTimeline x s)
2474−localSpiderTimeline _ = unsafeCoerce
2536+localSpiderTimeline _ = coerce
2476-- | Pass a new timeline to the given function.
2538-- | Pass a new timeline to the given function.
2477withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r
2539withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r
@@ -2479,18 +2541,18 @@ withSpiderTimeline k = do
2479 env <- unsafeNewSpiderTimelineEnv
2541 env <- unsafeNewSpiderTimelineEnv
2480 reify env $ \s -> k $ localSpiderTimeline s env
2542 reify env $ \s -> k $ localSpiderTimeline s env
2482−newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2544+newtype SpiderPullM (x :: Type) a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2484type ComputeM = EventM
2546type ComputeM = EventM
2486−newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2548+newtype SpiderPushM (x :: Type) a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
2488instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2550instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2489 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
2551 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
2490 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
2552 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
2491 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
2553 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
2492− newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)
2554+ newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: DynamicS x (Identity a) } -- deriving (Functor, Applicative, Monad)
2493− newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }
2555+ newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: DynamicS x p }
2494 type PullM (SpiderTimeline x) = SpiderPullM x
2556 type PullM (SpiderTimeline x) = SpiderPullM x
2495 type PushM (SpiderTimeline x) = SpiderPushM x
2557 type PushM (SpiderTimeline x) = SpiderPushM x
2496 {-# INLINABLE never #-}
2558 {-# INLINABLE never #-}
@@ -2503,10 +2565,15 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2503 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
2565 pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
2504 {-# INLINABLE pull #-}
2566 {-# INLINABLE pull #-}
2505 pull = SpiderBehavior . pull . coerce
2567 pull = SpiderBehavior . pull . coerce
2506− {-# INLINABLE merge #-}
2568+ {-# INLINABLE fanG #-}
2507− merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x))
2508− {-# INLINABLE fan #-}
2509− fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e))
2569+ fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e))
2570+ {-# INLINABLE mergeG #-}
2572+ :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k
2573+ => (forall a. q a -> R.Event (SpiderTimeline x) (v a))
2575+ -> R.Event (SpiderTimeline x) (DMap k v)
2576+ mergeG nt = SpiderEvent . mergeG (unSpiderEvent #. nt) . dynamicConst
2510 {-# INLINABLE switch #-}
2577 {-# INLINABLE switch #-}
2511 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
2578 switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
2512 {-# INLINABLE coincidence #-}
2579 {-# INLINABLE coincidence #-}
@@ -2514,15 +2581,15 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2514 {-# INLINABLE current #-}
2581 {-# INLINABLE current #-}
2515 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
2582 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
2516 {-# INLINABLE updated #-}
2583 {-# INLINABLE updated #-}
2517− updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic
2584+ updated = SpiderEvent #. dynamicUpdated .# fmap coerce . unSpiderDynamic
2518 {-# INLINABLE unsafeBuildDynamic #-}
2585 {-# INLINABLE unsafeBuildDynamic #-}
2519 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
2586 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
2520 {-# INLINABLE unsafeBuildIncremental #-}
2587 {-# INLINABLE unsafeBuildIncremental #-}
2521 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv
2588 unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv
2522− {-# INLINABLE mergeIncremental #-}
2589+ {-# INLINABLE mergeIncrementalG #-}
2523− mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental
2590+ mergeIncrementalG nt = SpiderEvent #. mergeG (coerce #. nt) .# unSpiderIncremental
2524− {-# INLINABLE mergeIncrementalWithMove #-}
2591+ {-# INLINABLE mergeIncrementalWithMoveG #-}
2525− mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental
2592+ mergeIncrementalWithMoveG nt = SpiderEvent #. mergeWithMove (coerce #. nt) .# unSpiderIncremental
2526 {-# INLINABLE currentIncremental #-}
2593 {-# INLINABLE currentIncremental #-}
2527 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
2594 currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental
2528 {-# INLINABLE updatedIncremental #-}
2595 {-# INLINABLE updatedIncremental #-}
@@ -2533,9 +2600,10 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2533 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
2600 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
2534 eventCoercion Coercion = Coercion
2601 eventCoercion Coercion = Coercion
2535 behaviorCoercion Coercion = Coercion
2602 behaviorCoercion Coercion = Coercion
2536− dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance
2603+ dynamicCoercion Coercion = Coercion
2604+ incrementalCoercion Coercion Coercion = Coercion
2537 {-# INLINABLE mergeIntIncremental #-}
2605 {-# INLINABLE mergeIntIncremental #-}
2538− mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental
2606+ mergeIntIncremental = SpiderEvent . mergeInt . coerce
2539 {-# INLINABLE fanInt #-}
2607 {-# INLINABLE fanInt #-}
2540 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))
2608 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))
@@ -2560,7 +2628,7 @@ instance MonadAtomicRef (EventM x) where
2560 atomicModifyRef r f = liftIO $ atomicModifyRef r f
2628 atomicModifyRef r f = liftIO $ atomicModifyRef r f
2562-- | The monad for actions that manipulate a Spider timeline identified by @x@
2630-- | The monad for actions that manipulate a Spider timeline identified by @x@
2563−newtype SpiderHost x a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2631+newtype SpiderHost (x :: Type) a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2565instance Monad (SpiderHost x) where
2633instance Monad (SpiderHost x) where
2566 {-# INLINABLE (>>=) #-}
2634 {-# INLINABLE (>>=) #-}
@@ -2582,7 +2650,7 @@ runSpiderHost (SpiderHost a) = a
2582runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
2650runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
2583runSpiderHostForTimeline (SpiderHost a) _ = a
2651runSpiderHostForTimeline (SpiderHost a) _ = a
2585−newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }
2653+newtype SpiderHostFrame (x :: Type) a = SpiderHostFrame { runSpiderHostFrame :: EventM x a }
2586 deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2654 deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2588instance Monad (SpiderHostFrame x) where
2656instance Monad (SpiderHostFrame x) where
@@ -2638,3 +2706,11 @@ instance MonadAtomicRef (SpiderHostFrame x) where
2638instance PrimMonad (SpiderHostFrame x) where
2706instance PrimMonad (SpiderHostFrame x) where
2639 type PrimState (SpiderHostFrame x) = PrimState IO
2707 type PrimState (SpiderHostFrame x) = PrimState IO
2640 primitive = SpiderHostFrame . EventM . primitive
2708 primitive = SpiderHostFrame . EventM . primitive
2710+instance NotReady (SpiderTimeline x) (SpiderHost x) where
2711+ notReadyUntil _ = return ()
2712+ notReady = return ()
2714+instance HasSpiderTimeline x => NotReady (SpiderTimeline x) (PerformEventT (SpiderTimeline x) (SpiderHost x)) where
2715+ notReadyUntil _ = return ()
2716+ notReady = return ()