@@ -18,6 +18,9 @@
1818{-# LANGUAGE TypeOperators #-}
1919{-# LANGUAGE UndecidableInstances #-}
2020{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
21+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
22+{-# OPTIONS_GHC -fno-warn-orphans #-}
23+#endif
2124-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
2225-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
2326module Reflex.Spider.Internal where
@@ -71,6 +74,9 @@ import Data.Tree (Forest, Tree (..), drawForest)
7174import Data.WeakBag (WeakBag, WeakBagTicket)
7275import qualified Data.WeakBag as WeakBag
7376import qualified Reflex.Class as R
77+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
78+import Reflex.Class (SpiderTimeline, Global)
79+#endif
7480import Reflex.Patch
7581import qualified Reflex.Host.Class as R
7682
@@ -612,8 +618,7 @@ readHoldTracked h = do
612618 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))
613619 return result
614620
615−{-# SPECIALIZE readBehaviorUntracked :: Behavior x a -> BehaviorM x a #-}
616−{-# SPECIALIZE readBehaviorUntracked :: HasSpiderTimeline x => Behavior x a -> EventM x a #-}
621+{-# INLINABLE readBehaviorUntracked #-}
617622readBehaviorUntracked :: Defer (SomeHoldInit x) m => Behavior x a -> m a
618623readBehaviorUntracked b = do
619624 holdInits <- getDeferralQueue
@@ -670,6 +675,26 @@ data Hold x p
670675#endif
671676 }
672677
678+{-# NOINLINE globalSpiderTimelineEnv #-}
679+globalSpiderTimelineEnv :: SpiderTimelineEnv Global
680+!globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv
681+
682+-- | Stores all global data relevant to a particular Spider timeline; only one
683+-- value should exist for each type @x@
684+data SpiderTimelineEnv x = SpiderTimelineEnv
685+ { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
686+ , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
687+#ifdef DEBUG
688+ , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
689+#endif
690+ }
691+type role SpiderTimelineEnv nominal
692+
693+instance GEq SpiderTimelineEnv where
694+ a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b
695+ then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
696+ else Nothing
697+
673698data EventEnv x
674699 = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe
675700 , eventEnvHoldInits :: !(IORef [SomeHoldInit x]) -- Needed for Subscribe
@@ -687,7 +712,7 @@ runEventM :: EventM x a -> IO a
687712runEventM = unEventM
688713
689714asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
690−asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimeline x)
715+asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
691716
692717class MonadIO m => Defer a m where
693718 getDeferralQueue :: m (IORef [a])
@@ -732,12 +757,16 @@ instance HasSpiderTimeline x => HasCurrentHeight x (EventM x) where
732757 delayedRef <- asksEventEnv eventEnvDelayedMerges
733758 liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [subscribed]
734759
760+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
761+class x ~ Global => HasSpiderTimeline x where
762+#else
735763class HasSpiderTimeline x where
736− -- | Retrieve the current SpiderTimeline
737− spiderTimeline :: SpiderTimeline x
764+#endif
765+ -- | Retrieve the current SpiderTimelineEnv
766+ spiderTimeline :: SpiderTimelineEnv x
738767
739768instance HasSpiderTimeline Global where
740− spiderTimeline = globalSpiderTimeline
769+ spiderTimeline = globalSpiderTimelineEnv
741770
742771putCurrentHeight :: HasSpiderTimeline x => Height -> EventM x ()
743772putCurrentHeight h = do
@@ -891,7 +920,7 @@ newtype ComputeM x a = ComputeM (ReaderT (IORef [SomeHoldInit x]) IO a) deriving
891920instance Defer (SomeHoldInit x) (ComputeM x) where
892921 getDeferralQueue = ComputeM ask
893922
894−{-# SPECIALIZE runComputeM :: HasSpiderTimeline x => ComputeM x a -> EventM x a #-}
923+{-# INLINABLE runComputeM #-}
895924runComputeM :: Defer (SomeHoldInit x) m => ComputeM x a -> m a
896925runComputeM (ComputeM a) = liftIO . runReaderT a =<< getDeferralQueue
897926
@@ -1156,7 +1185,7 @@ type WeakList a = [Weak a]
11561185#ifdef DEBUG
11571186withIncreasedDepth :: CanTrace x m => m a -> m a
11581187withIncreasedDepth a = do
1159− spiderTimeline <- askSpiderTimeline
1188+ spiderTimeline <- askSpiderTimelineEnv
11601189 liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ
11611190 result <- a
11621191 liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred
@@ -1185,7 +1214,7 @@ traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m ()
11851214traceMWhen _ b getMessage = when b $ do
11861215 message <- getMessage
11871216#ifdef DEBUG
1188− spiderTimeline <- askSpiderTimeline
1217+ spiderTimeline <- askSpiderTimelineEnv
11891218 d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline
11901219#else
11911220 let d = 0
@@ -1319,7 +1348,7 @@ cleanupRootSubscribed self@(RootSubscribed { rootSubscribedKey = k, rootSubscrib
13191348subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket
13201349subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed
13211350
1322−{-# SPECIALIZE getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket, FanSubscribed x k, Maybe a) #-}
1351+{-# INLINABLE getFanSubscribed #-}
13231352getFanSubscribed :: (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x, m ~ EventM x, GCompare k) => k a -> Fan x k -> Subscriber x a -> m (WeakBagTicket, FanSubscribed x k, Maybe a)
13241353getFanSubscribed k f sub = do
13251354 mSubscribed <- liftIO $ readIORef $ fanSubscribed f
@@ -1378,7 +1407,7 @@ subscribeFanSubscribed k subscribed sub = do
13781407 return sln
13791408 Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed
13801409
1381−{-# SPECIALIZE getSwitchSubscribed :: HasSpiderTimeline x => Switch x a -> Subscriber x a -> EventM x (WeakBagTicket, SwitchSubscribed x a, Maybe a) #-}
1410+{-# INLINABLE getSwitchSubscribed #-}
13821411getSwitchSubscribed :: (Defer (SomeHoldInit x) m, Defer (SomeAssignment x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, Defer (SomeResetCoincidence x) m, HasCurrentHeight x m, HasSpiderTimeline x, m ~ EventM x) => Switch x a -> Subscriber x a -> m (WeakBagTicket, SwitchSubscribed x a, Maybe a)
13831412getSwitchSubscribed s sub = do
13841413 mSubscribed <- liftIO $ readIORef $ switchSubscribed s
@@ -1434,7 +1463,7 @@ cleanupSwitchSubscribed subscribed = do
14341463subscribeSwitchSubscribed :: SwitchSubscribed x a -> Subscriber x a -> IO WeakBagTicket
14351464subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed
14361465
1437−{-# SPECIALIZE getCoincidenceSubscribed :: HasSpiderTimeline x => Coincidence x a -> Subscriber x a -> EventM x (WeakBagTicket, CoincidenceSubscribed x a, Maybe a) #-}
1466+{-# INLINABLE getCoincidenceSubscribed #-}
14381467getCoincidenceSubscribed :: forall x a m. (Defer (SomeAssignment x) m, Defer (SomeHoldInit x) m, Defer (SomeMergeInit x) m, Defer SomeClear m, HasCurrentHeight x m, Defer (SomeResetCoincidence x) m, HasSpiderTimeline x, m ~ EventM x) => Coincidence x a -> Subscriber x a -> m (WeakBagTicket, CoincidenceSubscribed x a, Maybe a)
14391468getCoincidenceSubscribed c sub = do
14401469 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c
@@ -1670,7 +1699,7 @@ clearEventEnv (EventEnv toAssignRef holdInitRef mergeUpdateRef mergeInitRef toCl
16701699-- | Run an event action outside of a frame
16711700runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
16721701runFrame a = SpiderHost $ ask >>= \_ -> lift $ do
1673− let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimeline x)
1702+ let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
16741703 let go = do
16751704 result <- a
16761705 runHoldInits (eventEnvHoldInits 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
@@ -1824,39 +1853,23 @@ invalidate toReconnectRef wis = do
18241853--------------------------------------------------------------------------------
18251854
18261855-- | The default, global Spider environment
1827−type Spider = SpiderTimeline Global
1828−
1829−-- | Designates the default, global Spider timeline
1830−data Global
1856+type Spider = SpiderTimelineEnv Global
18311857
1832−{-# NOINLINE globalSpiderTimeline #-}
1833−globalSpiderTimeline :: SpiderTimeline Global
1834−!globalSpiderTimeline = unsafePerformIO unsafeNewSpiderTimeline
1835−
1836−-- | Stores all global data relevant to a particular Spider timeline; only one
1837−-- value should exist for each type @x@
1838−data SpiderTimeline x = SpiderTimeline
1839− { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
1840− , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
1841−#ifdef DEBUG
1842− , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
1858+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
1859+-- When we're specializing, we include this from Reflex.Class instead, because
1860+-- it needs access to these types; when we're not, we want them here, so our
1861+-- instance isn't an orphan instance.
1862+#include "SpiderTimeline.include.hs"
18431863#endif
1844− }
1845−type role SpiderTimeline nominal
18461864
1847−instance GEq SpiderTimeline where
1848− a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b
1849− then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimeline can't have two different 'x' arguments
1850− else Nothing
1851−
1852−unsafeNewSpiderTimeline :: forall x. IO (SpiderTimeline x)
1853−unsafeNewSpiderTimeline = do
1865+unsafeNewSpiderTimelineEnv :: forall x. IO (SpiderTimelineEnv x)
1866+unsafeNewSpiderTimelineEnv = do
18541867 lock <- newMVar ()
18551868 env <- newEventEnv
18561869#ifdef DEBUG
18571870 depthRef <- newIORef 0
18581871#endif
1859− return $ SpiderTimeline
1872+ return $ SpiderTimelineEnv
18601873 { _spiderTimeline_lock = lock
18611874 , _spiderTimeline_eventEnv = env
18621875#ifdef DEBUG
@@ -1864,13 +1877,13 @@ unsafeNewSpiderTimeline = do
18641877#endif
18651878 }
18661879
1867−-- | Create a new SpiderTimeline
1868−newSpiderTimeline :: IO (Some SpiderTimeline)
1880+-- | Create a new SpiderTimelineEnv
1881+newSpiderTimeline :: IO (Some SpiderTimelineEnv)
18691882newSpiderTimeline = withSpiderTimeline (pure . Some.This)
18701883
18711884-- | Pass a new timeline to the given function.
1872−withSpiderTimeline :: (forall x. SpiderTimeline x -> IO r) -> IO r
1873−withSpiderTimeline k = unsafeNewSpiderTimeline >>= k
1885+withSpiderTimeline :: (forall x. SpiderTimelineEnv x -> IO r) -> IO r
1886+withSpiderTimeline k = unsafeNewSpiderTimelineEnv >>= k
18741887
18751888newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
18761889
@@ -1895,6 +1908,15 @@ instance HasSpiderTimeline x => Monad (R.Dynamic (SpiderTimeline x)) where
18951908 {-# INLINE fail #-}
18961909 fail _ = error "Dynamic does not support 'fail'"
18971910
1911+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
1912+instance t ~ SpiderTimeline Global => R.Reflex t where
1913+ newtype Behavior t a = SpiderBehavior { unSpiderBehavior :: Behavior Global a }
1914+ newtype Event t a = SpiderEvent { unSpiderEvent :: Event Global a }
1915+ newtype Dynamic t a = SpiderDynamic { unSpiderDynamic :: Dynamic Global (Identity a) } -- deriving (Functor, Applicative, Monad)
1916+ newtype Incremental t p = SpiderIncremental { unSpiderIncremental :: Dynamic Global p }
1917+ type PullM t = SpiderPullM Global
1918+ type PushM t = SpiderPushM Global
1919+#else
18981920instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
18991921 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
19001922 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
@@ -1903,6 +1925,7 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
19031925 newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }
19041926 type PullM (SpiderTimeline x) = SpiderPullM x
19051927 type PushM (SpiderTimeline x) = SpiderPushM x
1928+#endif
19061929 {-# INLINABLE never #-}
19071930 never = SpiderEvent eventNever
19081931 {-# INLINABLE constant #-}
@@ -1974,11 +1997,19 @@ instance HasSpiderTimeline x => R.MonadSample (SpiderTimeline x) (SpiderHost x)
19741997 {-# INLINABLE sample #-}
19751998 sample = runFrame . readBehaviorUntracked . unSpiderBehavior
19761999
1977−instance R.MonadSample (SpiderTimeline x) (SpiderPullM x) where
2000+instance (
2001+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2002+ x ~ Global
2003+#endif
2004+ ) => R.MonadSample (SpiderTimeline x) (SpiderPullM x) where
19782005 {-# INLINABLE sample #-}
19792006 sample = coerce . readBehaviorTracked . unSpiderBehavior
19802007
1981−instance R.MonadSample (SpiderTimeline x) (SpiderPushM x) where
2008+instance (
2009+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2010+ x ~ Global
2011+#endif
2012+ ) => R.MonadSample (SpiderTimeline x) (SpiderPushM x) where
19822013 {-# INLINABLE sample #-}
19832014 sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b
19842015
@@ -2040,7 +2071,7 @@ instance MonadAtomicRef (EventM x) where
20402071 atomicModifyRef r f = liftIO $ atomicModifyRef r f
20412072
20422073-- | The monad for actions that manipulate a Spider timeline identified by @x@
2043−newtype SpiderHost x a = SpiderHost { unSpiderHost :: ReaderT (SpiderTimeline x) IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
2074+newtype SpiderHost x a = SpiderHost { unSpiderHost :: ReaderT (SpiderTimelineEnv x) IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
20442075
20452076instance Monad (SpiderHost x) where
20462077 {-# INLINABLE (>>=) #-}
@@ -2055,11 +2086,11 @@ instance Monad (SpiderHost x) where
20552086-- | Run an action affecting the global Spider timeline; this will be guarded by
20562087-- a mutex for that timeline
20572088runSpiderHost :: SpiderHost Global a -> IO a
2058−runSpiderHost (SpiderHost a) = runReaderT a globalSpiderTimeline
2089+runSpiderHost (SpiderHost a) = runReaderT a globalSpiderTimelineEnv
20592090
20602091-- | Run an action affecting a given Spider timeline; this will be guarded by a
20612092-- mutex for that timeline
2062−runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimeline x -> IO a
2093+runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
20632094runSpiderHostForTimeline (SpiderHost a) = runReaderT a
20642095
20652096newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
@@ -2101,13 +2132,21 @@ newFanEventWithTriggerIO f = do
21012132 }
21022133 return $ EventSelector $ \k -> eventRoot k r
21032134
2104−instance R.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where
2135+instance (
2136+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2137+ x ~ Global
2138+#endif
2139+ ) => R.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where
21052140 newEventWithTrigger = SpiderHost . lift . fmap SpiderEvent . newEventWithTriggerIO
21062141 newFanEventWithTrigger f = SpiderHost $ lift $ do
21072142 es <- newFanEventWithTriggerIO f
21082143 return $ R.EventSelector $ SpiderEvent . select es
21092144
2110−instance R.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where
2145+instance (
2146+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2147+ x ~ Global
2148+#endif
2149+ ) => R.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where
21112150 newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO
21122151 newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do
21132152 es <- newFanEventWithTriggerIO f
@@ -2162,5 +2201,5 @@ instance PrimMonad (SpiderHostFrame x) where
21622201-- Deprecated items
21632202--------------------------------------------------------------------------------
21642203
2165−{-# DEPRECATED SpiderEnv "Use 'SpiderTimeline' instead" #-}
2166−type SpiderEnv = SpiderTimeline
2204+{-# DEPRECATED SpiderEnv "Use 'SpiderTimelineEnv' instead" #-}
2205+type SpiderEnv = SpiderTimelineEnv