@@ -26,7 +26,7 @@
2626#endif
2727-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
2828-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
29−module Reflex.Spider.Internal where
29+module Reflex.Spider.Internal (module Reflex.Spider.Internal) where
3030
3131import Control.Applicative
3232import Control.Concurrent
@@ -89,6 +89,20 @@ import Reflex.Patch
8989-- Note: must come last to silence warnings due to AMP on GHC < 7.10
9090import Prelude hiding (any, concat, mapM, mapM_, sequence)
9191
92+#ifdef DEBUG_TRACE_EVENTS
93+import System.IO (stderr)
94+import qualified Data.ByteString.Char8 as BS8
95+#endif
96+
97+#ifdef DEBUG_TRACE_EVENTS
98+
99+withStackOneLine :: (BS8.ByteString -> a) -> a
100+withStackOneLine expr = unsafePerformIO $ do
101+ stack <- currentCallStack
102+ return (expr (BS8.pack (unwords (reverse stack))))
103+
104+#endif
105+
92106debugPropagate :: Bool
93107
94108debugInvalidateHeight :: Bool
@@ -190,6 +204,20 @@ unsafeNodeId a = unsafePerformIO $ do
190204 newNodeId
191205#endif
192206
207+--------------------------------------------------------------------------------
208+-- EventSubscription
209+--------------------------------------------------------------------------------
210+
211+--NB: Once you subscribe to an Event, you must always hold on the the WHOLE EventSubscription you get back
212+-- If you do not retain the subscription, you may be prematurely unsubscribed from the parent event.
213+data EventSubscription x = EventSubscription
214+ { _eventSubscription_unsubscribe :: !(IO ())
215+ , _eventSubscription_subscribed :: {-# UNPACK #-} !(EventSubscribed x)
216+ }
217+
218+unsubscribe :: EventSubscription x -> IO ()
219+unsubscribe (EventSubscription u _) = u
220+
193221--------------------------------------------------------------------------------
194222-- Event
195223--------------------------------------------------------------------------------
@@ -236,44 +264,53 @@ data CacheSubscribed x a
236264--subscriber joins
237265{-# NOINLINE cacheEvent #-}
238266cacheEvent :: HasSpiderTimeline x => Event x a -> Event x a
239−cacheEvent e = Event $ \sub -> {-# SCC "cacheEvent" #-} do
240− let !mSubscribedRef = unsafeNewIORef e Nothing
241− mSubscribed <- liftIO $ readIORef mSubscribedRef
242− case mSubscribed of
243− Just subscribed -> liftIO $ do
244− ticket <- WeakBag.insert sub (_cacheSubscribed_subscribers subscribed) (_cacheSubscribed_weakSelf subscribed) cleanupCacheSubscribed
245− occ <- readIORef $ _cacheSubscribed_occurrence subscribed
246− let es = EventSubscribed
247− { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed
248− , eventSubscribedRetained = toAny subscribed
249− }
250− return (EventSubscription (WeakBag.remove ticket >> touch ticket) es, occ)
251− Nothing -> do
252− weakSelf <- liftIO $ newIORef $ error "cacheEvent: weakSelf not yet intialized"
253− (subscribers, ticket) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCacheSubscribed
254− occRef <- liftIO $ newIORef undefined
255− (parentSub, occ) <- subscribeAndRead e $ Subscriber
256− { subscriberPropagate = \a -> do
257− liftIO $ writeIORef occRef $ Just a
258− scheduleClear occRef
259− propagate a subscribers
260− , subscriberInvalidateHeight = \old -> do
261− WeakBag.traverse subscribers $ invalidateSubscriberHeight old
262− , subscriberRecalculateHeight = \new -> do
263− WeakBag.traverse subscribers $ recalculateSubscriberHeight new
264− }
265− liftIO $ writeIORef occRef occ
266− when (isJust occ) $ scheduleClear occRef
267− let !subscribed = CacheSubscribed
268− { _cacheSubscribed_subscribers = subscribers
269− , _cacheSubscribed_weakSelf = weakSelf
270− , _cacheSubscribed_parent = parentSub
271− , _cacheSubscribed_cached = mSubscribedRef
272− , _cacheSubscribed_occurrence = occRef
273− }
274− liftIO $ writeIORef mSubscribedRef $ Just subscribed
275− liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "PushSubscribed"
276− return (EventSubscription (WeakBag.remove ticket >> touch ticket) (EventSubscribed (eventSubscribedHeightRef $ _eventSubscription_subscribed parentSub) (toAny subscribed)), occ)
267+cacheEvent e =
268+#ifdef DEBUG_TRACE_EVENTS
269+ withStackOneLine $ \callSite -> Event $
270+#else
271+ Event $
272+#endif
273+ let !mSubscribedRef = unsafeNewIORef e Nothing
274+ in \sub -> {-# SCC "cacheEvent" #-} do
275+#ifdef DEBUG_TRACE_EVENTS
276+ unless (BS8.null callSite) $ liftIO $ BS8.hPutStrLn stderr callSite
277+#endif
278+ mSubscribed <- liftIO $ readIORef mSubscribedRef
279+ case mSubscribed of
280+ Just subscribed -> liftIO $ do
281+ ticket <- WeakBag.insert sub (_cacheSubscribed_subscribers subscribed) (_cacheSubscribed_weakSelf subscribed) cleanupCacheSubscribed
282+ occ <- readIORef $ _cacheSubscribed_occurrence subscribed
283+ let es = EventSubscribed
284+ { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ _cacheSubscribed_parent subscribed
285+ , eventSubscribedRetained = toAny subscribed
286+ }
287+ return (EventSubscription (WeakBag.remove ticket >> touch ticket) es, occ)
288+ Nothing -> do
289+ weakSelf <- liftIO $ newIORef $ error "cacheEvent: weakSelf not yet intialized"
290+ (subscribers, ticket) <- liftIO $ WeakBag.singleton sub weakSelf cleanupCacheSubscribed
291+ occRef <- liftIO $ newIORef undefined
292+ (parentSub, occ) <- subscribeAndRead e $ Subscriber
293+ { subscriberPropagate = \a -> do
294+ liftIO $ writeIORef occRef $ Just a
295+ scheduleClear occRef
296+ propagate a subscribers
297+ , subscriberInvalidateHeight = \old -> do
298+ WeakBag.traverse subscribers $ invalidateSubscriberHeight old
299+ , subscriberRecalculateHeight = \new -> do
300+ WeakBag.traverse subscribers $ recalculateSubscriberHeight new
301+ }
302+ liftIO $ writeIORef occRef occ
303+ when (isJust occ) $ scheduleClear occRef
304+ let !subscribed = CacheSubscribed
305+ { _cacheSubscribed_subscribers = subscribers
306+ , _cacheSubscribed_weakSelf = weakSelf
307+ , _cacheSubscribed_parent = parentSub
308+ , _cacheSubscribed_cached = mSubscribedRef
309+ , _cacheSubscribed_occurrence = occRef
310+ }
311+ liftIO $ writeIORef mSubscribedRef $ Just subscribed
312+ liftIO $ writeIORef weakSelf =<< evaluate =<< mkWeakPtrWithDebug subscribed "PushSubscribed"
313+ return (EventSubscription (WeakBag.remove ticket >> touch ticket) (EventSubscribed (eventSubscribedHeightRef $ _eventSubscription_subscribed parentSub) (toAny subscribed)), occ)
277314
278315cleanupCacheSubscribed :: CacheSubscribed x a -> IO ()
279316cleanupCacheSubscribed self = do
@@ -558,18 +595,6 @@ walkInvalidHeightParents s0 = do
558595subscribeHoldEvent :: CanSubscribe x m => Hold x p -> Subscriber x p -> m (EventSubscription x, Maybe p)
559596subscribeHoldEvent = subscribeAndRead . holdEvent
560597
561−--------------------------------------------------------------------------------
562−-- EventSubscription
563−--------------------------------------------------------------------------------
564−
565−data EventSubscription x = EventSubscription
566− { _eventSubscription_unsubscribe :: !(IO ())
567− , _eventSubscription_subscribed :: {-# UNPACK #-} !(EventSubscribed x)
568− }
569−
570−unsubscribe :: EventSubscription x -> IO ()
571−unsubscribe (EventSubscription u _) = u
572−
573598--------------------------------------------------------------------------------
574599-- Behavior
575600--------------------------------------------------------------------------------
@@ -1344,7 +1369,7 @@ getRootSubscribed k r sub = do
13441369{-# ANN cleanupRootSubscribed "HLint: ignore Redundant bracket" #-}
13451370#endif
13461371cleanupRootSubscribed :: RootSubscribed x a -> IO ()
1347−cleanupRootSubscribed self@(RootSubscribed { rootSubscribedKey = k, rootSubscribedCachedSubscribed = cached }) = do
1372+cleanupRootSubscribed self@RootSubscribed { rootSubscribedKey = k, rootSubscribedCachedSubscribed = cached } = do
13481373 rootSubscribedUninit self
13491374 modifyIORef' cached $ DMap.delete k
13501375
@@ -1641,9 +1666,12 @@ mergeCheap d = Event $ \sub -> do
16411666 , subscriberInvalidateHeight = \_ -> return ()
16421667 , subscriberRecalculateHeight = \_ -> return ()
16431668 }
1644− (EventSubscription _ changeSubd, change) <- subscribeAndRead (dynamicUpdated d) s
1669+ (changeSubscription, change) <- subscribeAndRead (dynamicUpdated d) s
16451670 forM_ change $ \c -> defer $ SomeMergeUpdate (updateMe c) invalidateMyHeight revalidateMyHeight
1646− liftIO $ writeIORef changeSubdRef (s, changeSubd)
1671+ -- We explicitly hold on to the unsubscribe function from subscribing to the update event.
1672+ -- If we don't do this, there are certain cases where mergeCheap will fail to properly retain
1673+ -- its subscription.
1674+ liftIO $ writeIORef changeSubdRef (s, changeSubscription)
16471675 let unsubscribeAll = do
16481676 parents <- readIORef parentsRef
16491677 forM_ (DMap.toList parents) $ \(_ :=> MergeSubscribedParent s) -> unsubscribe s
@@ -1922,6 +1950,8 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
19221950 constant = SpiderBehavior . behaviorConst
19231951 {-# INLINE push #-}
19241952 push f = SpiderEvent . push (coerce f) . unSpiderEvent
1953+ {-# INLINE pushCheap #-}
1954+ pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent
19251955 {-# INLINABLE pull #-}
19261956 pull = SpiderBehavior . pull . coerce
19271957 {-# INLINABLE merge #-}
@@ -1935,7 +1965,7 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
19351965 {-# INLINABLE current #-}
19361966 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
19371967 {-# INLINABLE updated #-}
1938− updated = SpiderEvent . fmap runIdentity . dynamicUpdated . unSpiderDynamic
1968+ updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic
19391969 {-# INLINABLE unsafeBuildDynamic #-}
19401970 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeDyn (coerce readV0) $ coerce $ unSpiderEvent v'
19411971 {-# INLINABLE unsafeBuildIncremental #-}