@@ -585,6 +585,69 @@ data EventSubscription x a = EventSubscription
585585unsubscribe :: EventSubscription x a -> IO ()
586586unsubscribe (EventSubscription msln _) = forM_ msln $ \sln -> WeakBag.remove sln
587587
588+--------------------------------------------------------------------------------
589+-- Behavior
590+--------------------------------------------------------------------------------
591+
592+newtype Behavior x a = Behavior { readBehaviorTracked :: BehaviorM x a }
593+
594+behaviorHold :: Hold x p a -> Behavior x a
595+behaviorHold !h = Behavior $ readHoldTracked h
596+
597+behaviorHoldIdentity :: Hold x Identity a -> Behavior x a
598+behaviorHoldIdentity = behaviorHold
599+
600+behaviorConst :: a -> Behavior x a
601+behaviorConst !a = Behavior $ return a
602+
603+behaviorPull :: Pull x a -> Behavior x a
604+behaviorPull !p = Behavior $ do
605+ val <- liftIO $ readIORef $ pullValue p
606+ case val of
607+ Just subscribed -> do
608+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
609+ askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))
610+ liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
611+ return $ pullSubscribedValue subscribed
612+ Nothing -> do
613+ i <- liftIO $ newInvalidatorPull p
614+ wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
615+ parentsRef <- liftIO $ newIORef []
616+ holdInits <- askBehaviorHoldInits
617+ a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
618+ invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
619+ parents <- liftIO $ readIORef parentsRef
620+ let subscribed = PullSubscribed
621+ { pullSubscribedValue = a
622+ , pullSubscribedInvalidators = invsRef
623+ , pullSubscribedOwnInvalidator = i
624+ , pullSubscribedParents = parents
625+ }
626+ liftIO $ writeIORef (pullValue p) $ Just subscribed
627+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
628+ return a
629+
630+behaviorDyn :: R.Patch p => Dyn x p a -> Behavior x a
631+behaviorDyn !d = Behavior $ readHoldTracked =<< getDynHold d
632+
633+behaviorDynIdentity :: Dyn x Identity a -> Behavior x a
634+behaviorDynIdentity = behaviorDyn
635+
636+{-# INLINE readHoldTracked #-}
637+readHoldTracked :: Hold x p a -> BehaviorM x a
638+readHoldTracked h = do
639+ result <- liftIO $ readIORef $ holdValue h
640+ askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
641+ askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))
642+ return result
643+
644+{-# SPECIALIZE readBehaviorUntracked :: Behavior x a -> BehaviorM x a #-}
645+{-# SPECIALIZE readBehaviorUntracked :: Behavior x a -> EventM x a #-}
646+readBehaviorUntracked :: Defer (SomeHoldInit x) m => Behavior x a -> m a
647+readBehaviorUntracked b = do
648+ holdInits <- getDeferralQueue
649+ liftIO $ runBehaviorM (readBehaviorTracked b) Nothing holdInits --TODO: Specialize readBehaviorTracked to the Nothing and Just cases
650+
588651--------------------------------------------------------------------------------
589652-- Combinators
590653--------------------------------------------------------------------------------
@@ -996,11 +1059,11 @@ data Dynamic x p a
9961059{-# INLINE current #-}
9971060current :: R.Patch p => Dynamic x p a -> Behavior x a
9981061current = \case
999− DynamicHold h -> BehaviorHold h
1000− DynamicHoldIdentity h -> BehaviorHoldIdentity h
1001− DynamicConst a -> BehaviorConst a
1002− DynamicDyn d -> BehaviorDyn d
1003− DynamicDynIdentity d -> BehaviorDynIdentity d
1062+ DynamicHold h -> behaviorHold h
1063+ DynamicHoldIdentity h -> behaviorHoldIdentity h
1064+ DynamicConst a -> behaviorConst a
1065+ DynamicDyn d -> behaviorDyn d
1066+ DynamicDynIdentity d -> behaviorDynIdentity d
10041067
10051068--TODO: If you only need updated, not current, can we avoid actually constructing the Hold?
10061069{-# INLINE updated #-}
@@ -1051,7 +1114,7 @@ instance Monad (Dynamic x Identity) where
10511114 {-# INLINE return #-}
10521115 return = pure
10531116 {-# INLINE (>>=) #-}
1054− x >>= f = DynamicDynIdentity $ newJoinDyn $ newMapDyn f x --TODO: (>>), fail
1117+ x >>= f = DynamicDynIdentity $ newJoinDyn $ newMapDyn f x
10551118 {-# INLINE (>>) #-}
10561119 _ >> y = y
10571120 {-# INLINE fail #-}
@@ -1072,15 +1135,6 @@ newJoinDyn d =
10721135 v' = unSpiderEvent $ R.leftmost $ map SpiderEvent [eBoth, eOuter, eInner]
10731136 in unsafeDyn readV0 v'
10741137
1075−--type role Behavior representational
1076−data Behavior x a
1077− = forall p. BehaviorHold !(Hold x p a)
1078− | BehaviorHoldIdentity !(Hold x Identity a)
1079− | BehaviorConst !a
1080− | BehaviorPull !(Pull x a)
1081− | BehaviorDynIdentity !(Dyn x Identity a)
1082− | forall p. R.Patch p => BehaviorDyn !(Dyn x p a)
1083−
10841138-- ResultM can read behaviors and events
10851139type ResultM = EventM
10861140
@@ -1105,7 +1159,7 @@ push f e = eventPush $ Push
11051159
11061160{-# NOINLINE pull #-}
11071161pull :: BehaviorM x a -> Behavior x a
1108−pull a = BehaviorPull $ Pull
1162+pull a = behaviorPull $ Pull
11091163 { pullCompute = a
11101164 , pullValue = unsafeNewIORef a Nothing
11111165#ifdef DEBUG_NODEIDS
@@ -1267,13 +1321,6 @@ propagateSubscriberHold h a = do
12671321
12681322data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x a) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
12691323
1270−{-# SPECIALIZE readBehaviorUntracked :: Behavior x a -> BehaviorM x a #-}
1271−{-# SPECIALIZE readBehaviorUntracked :: Behavior x a -> EventM x a #-}
1272−readBehaviorUntracked :: Defer (SomeHoldInit x) m => Behavior x a -> m a
1273−readBehaviorUntracked b = do
1274− holdInits <- getDeferralQueue
1275− liftIO $ runBehaviorM (readBehaviorTracked b) Nothing holdInits --TODO: Specialize readBehaviorTracked to the Nothing and Just cases
1276−
12771324runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a
12781325runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)
12791326
@@ -1296,47 +1343,6 @@ askBehaviorHoldInits = do
12961343 (_, !his) <- BehaviorM ask
12971344 return his
12981345
1299−readBehaviorTracked :: Behavior x a -> BehaviorM x a
1300−readBehaviorTracked b = case b of
1301− BehaviorHold h -> readHoldTracked h
1302− BehaviorHoldIdentity h -> readHoldTracked h
1303− BehaviorConst a -> return a
1304− BehaviorPull p -> do
1305− val <- liftIO $ readIORef $ pullValue p
1306− case val of
1307− Just subscribed -> do
1308− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
1309− askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (pullSubscribedInvalidators subscribed) (wi:))
1310− liftIO $ touch $ pullSubscribedOwnInvalidator subscribed
1311− return $ pullSubscribedValue subscribed
1312− Nothing -> do
1313− i <- liftIO $ newInvalidatorPull p
1314− wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
1315− parentsRef <- liftIO $ newIORef []
1316− holdInits <- askBehaviorHoldInits
1317− a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
1318− invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
1319− parents <- liftIO $ readIORef parentsRef
1320− let subscribed = PullSubscribed
1321− { pullSubscribedValue = a
1322− , pullSubscribedInvalidators = invsRef
1323− , pullSubscribedOwnInvalidator = i
1324− , pullSubscribedParents = parents
1325− }
1326− liftIO $ writeIORef (pullValue p) $ Just subscribed
1327− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedPull subscribed) :))
1328− return a
1329− BehaviorDyn d -> readHoldTracked =<< getDynHold d
1330− BehaviorDynIdentity d -> readHoldTracked =<< getDynHold d
1331−
1332−{-# INLINE readHoldTracked #-}
1333−readHoldTracked :: Hold x p a -> BehaviorM x a
1334−readHoldTracked h = do
1335− result <- liftIO $ readIORef $ holdValue h
1336− askInvalidator >>= mapM_ (\wi -> liftIO $ modifyIORef' (holdInvalidators h) (wi:))
1337− askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))
1338− return result
1339−
13401346{-# INLINE getDynHold #-}
13411347getDynHold :: (Defer (SomeHoldInit x) m, R.Patch p) => Dyn x p a -> m (Hold x p a)
13421348getDynHold d = do
@@ -2020,7 +2026,7 @@ instance R.Reflex (SpiderEnv x) where
20202026 {-# INLINABLE never #-}
20212027 never = SpiderEvent eventNever
20222028 {-# INLINABLE constant #-}
2023− constant = SpiderBehavior . BehaviorConst
2029+ constant = SpiderBehavior . behaviorConst
20242030 {-# INLINABLE push #-}
20252031 push f = SpiderEvent . push (coerce f) . unSpiderEvent
20262032 {-# INLINABLE pull #-}
@@ -2065,7 +2071,7 @@ instance R.MonadHold (SpiderEnv x) (EventM x) where
20652071 holdIncremental = holdIncrementalSpiderEventM
20662072
20672073holdSpiderEventM :: a -> R.Event (SpiderEnv x) a -> EventM x (R.Behavior (SpiderEnv x) a)
2068−holdSpiderEventM v0 e = fmap (SpiderBehavior . BehaviorHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e
2074+holdSpiderEventM v0 e = fmap (SpiderBehavior . behaviorHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e
20692075
20702076holdDynSpiderEventM :: a -> R.Event (SpiderEnv x) a -> EventM x (R.Dynamic (SpiderEnv x) a)
20712077holdDynSpiderEventM v0 e = fmap (SpiderDynamic . DynamicHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e
@@ -2185,7 +2191,7 @@ instance R.MonadSample (SpiderEnv x) (SpiderHostFrame x) where
21852191
21862192instance R.MonadHold (SpiderEnv x) (SpiderHostFrame x) where
21872193 {-# INLINABLE hold #-}
2188− hold v0 e = SpiderHostFrame $ fmap (SpiderBehavior . BehaviorHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e
2194+ hold v0 e = SpiderHostFrame $ fmap (SpiderBehavior . behaviorHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e
21892195 {-# INLINABLE holdDyn #-}
21902196 holdDyn v0 e = SpiderHostFrame $ fmap (SpiderDynamic . DynamicHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e
21912197 {-# INLINABLE holdIncremental #-}