@@ -21,9 +21,6 @@
2121#ifdef USE_REFLEX_OPTIMIZER
2222{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
2323#endif
24−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
25−{-# OPTIONS_GHC -fno-warn-orphans #-}
26−#endif
2724-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses
2825-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.
2926module Reflex.Spider.Internal (module Reflex.Spider.Internal) where
@@ -80,7 +77,6 @@ import Data.FastWeakBag (FastWeakBag)
8077import qualified Data.FastWeakBag as FastWeakBag
8178import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children)
8279import qualified Data.WeakBag as WeakBag
83−#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
8480import Data.Reflection
8581import Data.Some (Some)
8682import qualified Data.Some as Some
@@ -88,7 +84,6 @@ import Data.Type.Coercion
8884import qualified Reflex.Class
8985import qualified Reflex.Class as R
9086import qualified Reflex.Host.Class
91−#endif
9287import Reflex.NotReady.Class
9388import Reflex.Patch
9489import qualified Reflex.Patch.DMapWithMove as PatchDMapWithMove
@@ -760,9 +755,7 @@ data Hold x p
760755#endif
761756 }
762757
763−-- | A statically allocated 'SpiderTimeline'; this is the only instance of
764−-- 'SpiderTimeline' that can used when using
765−-- -fspecialize-to-spidertimeline-global.
758+-- | A statically allocated 'SpiderTimeline'
766759data Global
767760
768761{-# NOINLINE globalSpiderTimelineEnv #-}
@@ -856,11 +849,7 @@ instance HasSpiderTimeline x => HasCurrentHeight x (EventM x) where
856849 delayedRef <- asksEventEnv eventEnvDelayedMerges
857850 liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [subscribed]
858851
859−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
860−class x ~ Global => HasSpiderTimeline x where
861−#else
862852class HasSpiderTimeline x where
863−#endif
864853 -- | Retrieve the current SpiderTimelineEnv
865854 spiderTimeline :: SpiderTimelineEnv x
866855
@@ -2246,13 +2235,203 @@ invalidate toReconnectRef wis = do
22462235-- Reflex integration
22472236--------------------------------------------------------------------------------
22482237
2249−#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
22502238-- When we're specializing, we include this from Reflex.Class instead, because
22512239-- it needs access to these types; when we're not, we want them here, so our
22522240-- instance isn't an orphan instance.
2253−#include "SpiderTimeline.include.hs"
2254−#include "SpiderTimelineHost.include.hs"
2241+-- | Designates the default, global Spider timeline
2242+data SpiderTimeline x
2243+type role SpiderTimeline nominal
2244+
2245+-- | The default, global Spider environment
2246+type Spider = SpiderTimeline Global
2247+
2248+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (EventM x) where
2249+ {-# INLINABLE sample #-}
2250+ sample (SpiderBehavior b) = readBehaviorUntracked b
2251+
2252+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (EventM x) where
2253+ {-# INLINABLE hold #-}
2254+ hold = holdSpiderEventM
2255+ {-# INLINABLE holdDyn #-}
2256+ holdDyn = holdDynSpiderEventM
2257+ {-# INLINABLE holdIncremental #-}
2258+ holdIncremental = holdIncrementalSpiderEventM
2259+ {-# INLINABLE buildDynamic #-}
2260+ buildDynamic = buildDynamicSpiderEventM
2261+ {-# INLINABLE headE #-}
2262+ headE = R.slowHeadE
2263+-- headE (SpiderEvent e) = SpiderEvent <$> Reflex.Spider.Internal.headE e
2264+
2265+instance Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPullM x) where
2266+ {-# INLINABLE sample #-}
2267+ sample = coerce . readBehaviorTracked . unSpiderBehavior
2268+
2269+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderPushM x) where
2270+ {-# INLINABLE sample #-}
2271+ sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b
2272+
2273+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderPushM x) where
2274+ {-# INLINABLE hold #-}
2275+ hold v0 e = Reflex.Class.current <$> Reflex.Class.holdDyn v0 e
2276+ {-# INLINABLE holdDyn #-}
2277+ holdDyn v0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce e
2278+ {-# INLINABLE holdIncremental #-}
2279+ holdIncremental v0 (SpiderEvent e) = SpiderPushM $ SpiderIncremental . dynamicHold <$> Reflex.Spider.Internal.hold v0 e
2280+ {-# INLINABLE buildDynamic #-}
2281+ buildDynamic getV0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce e
2282+ {-# INLINABLE headE #-}
2283+ headE = R.slowHeadE
2284+-- headE (SpiderEvent e) = SpiderPushM $ SpiderEvent <$> Reflex.Spider.Internal.headE e
2285+
2286+instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) where
2287+ {-# INLINE return #-}
2288+ return = pure
2289+ {-# INLINE (>>=) #-}
2290+ x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x
2291+ {-# INLINE (>>) #-}
2292+ (>>) = (*>)
2293+ {-# INLINE fail #-}
2294+ fail _ = error "Dynamic does not support 'fail'"
2295+
2296+{-# INLINABLE newJoinDyn #-}
2297+newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)
2298+newJoinDyn d =
2299+ let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)
2300+ eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d
2301+ eInner = Reflex.Spider.Internal.switch $ dynamicUpdated <$> dynamicCurrent d
2302+ eBoth = Reflex.Spider.Internal.coincidence $ dynamicUpdated . runIdentity <$> dynamicUpdated d
2303+ v' = unSpiderEvent $ Reflex.Class.leftmost $ map SpiderEvent [eBoth, eOuter, eInner]
2304+ in Reflex.Spider.Internal.unsafeBuildDynamic readV0 v'
2305+
2306+instance HasSpiderTimeline x => Functor (Reflex.Class.Dynamic (SpiderTimeline x)) where
2307+ fmap f = SpiderDynamic . newMapDyn f . unSpiderDynamic
2308+ x <$ d = R.unsafeBuildDynamic (return x) $ x <$ R.updated d
2309+
2310+instance HasSpiderTimeline x => Applicative (Reflex.Class.Dynamic (SpiderTimeline x)) where
2311+ pure = SpiderDynamic . dynamicConst
2312+#if MIN_VERSION_base(4,10,0)
2313+ liftA2 f a b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith f (unSpiderDynamic a) (unSpiderDynamic b)
22552314#endif
2315+ SpiderDynamic a <*> SpiderDynamic b = SpiderDynamic $ Reflex.Spider.Internal.zipDynWith ($) a b
2316+ a *> b = R.unsafeBuildDynamic (R.sample $ R.current b) $ R.leftmost [R.updated b, R.tag (R.current b) $ R.updated a]
2317+ (<*) = flip (*>) -- There are no effects, so order doesn't matter
2318+
2319+holdSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Behavior (SpiderTimeline x) a)
2320+holdSpiderEventM v0 e = fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e
2321+
2322+holdDynSpiderEventM :: HasSpiderTimeline x => a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)
2323+holdDynSpiderEventM v0 e = fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e
2324+
2325+holdIncrementalSpiderEventM :: (HasSpiderTimeline x, Patch p) => PatchTarget p -> Reflex.Class.Event (SpiderTimeline x) p -> EventM x (Reflex.Class.Incremental (SpiderTimeline x) p)
2326+holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e
2327+
2328+buildDynamicSpiderEventM :: HasSpiderTimeline x => SpiderPullM x a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)
2329+buildDynamicSpiderEventM getV0 e = fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e
2330+
2331+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHost x) where
2332+ {-# INLINABLE hold #-}
2333+ hold v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.hold v0 e
2334+ {-# INLINABLE holdDyn #-}
2335+ holdDyn v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdDyn v0 e
2336+ {-# INLINABLE holdIncremental #-}
2337+ holdIncremental v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdIncremental v0 e
2338+ {-# INLINABLE buildDynamic #-}
2339+ buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e
2340+ {-# INLINABLE headE #-}
2341+ headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e
2342+
2343+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where
2344+ sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can
2345+
2346+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHostFrame x) where
2347+ {-# INLINABLE hold #-}
2348+ hold v0 e = SpiderHostFrame $ fmap (SpiderBehavior . behaviorHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e
2349+ {-# INLINABLE holdDyn #-}
2350+ holdDyn v0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicHoldIdentity) $ Reflex.Spider.Internal.hold v0 $ coerce $ unSpiderEvent e
2351+ {-# INLINABLE holdIncremental #-}
2352+ holdIncremental v0 e = SpiderHostFrame $ fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e
2353+ {-# INLINABLE buildDynamic #-}
2354+ buildDynamic getV0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e
2355+ {-# INLINABLE headE #-}
2356+ headE = R.slowHeadE
2357+-- headE (SpiderEvent e) = SpiderHostFrame $ SpiderEvent <$> Reflex.Spider.Internal.headE e
2358+
2359+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (SpiderHost x) where
2360+ {-# INLINABLE sample #-}
2361+ sample = runFrame . readBehaviorUntracked . unSpiderBehavior
2362+
2363+instance HasSpiderTimeline x => Reflex.Class.MonadSample (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where
2364+ {-# INLINABLE sample #-}
2365+ sample = Reflex.Spider.Internal.ReadPhase . Reflex.Class.sample
2366+
2367+instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where
2368+ {-# INLINABLE hold #-}
2369+ hold v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.hold v0 e
2370+ {-# INLINABLE holdDyn #-}
2371+ holdDyn v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdDyn v0 e
2372+ {-# INLINABLE holdIncremental #-}
2373+ holdIncremental v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdIncremental v0 e
2374+ {-# INLINABLE buildDynamic #-}
2375+ buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e
2376+ {-# INLINABLE headE #-}
2377+ headE e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.headE e
2378+
2379+--------------------------------------------------------------------------------
2380+-- Deprecated items
2381+--------------------------------------------------------------------------------
2382+
2383+-- | 'SpiderEnv' is the old name for 'SpiderTimeline'
2384+{-# DEPRECATED SpiderEnv "Use 'SpiderTimelineEnv' instead" #-}
2385+type SpiderEnv = SpiderTimeline
2386+instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHostFrame x) where
2387+ {-# INLINABLE subscribeEvent #-}
2388+ subscribeEvent e = SpiderHostFrame $ do
2389+ --TODO: Unsubscribe eventually (manually and/or with weak ref)
2390+ val <- liftIO $ newIORef Nothing
2391+ subscription <- subscribe (unSpiderEvent e) $ Subscriber
2392+ { subscriberPropagate = \a -> do
2393+ liftIO $ writeIORef val $ Just a
2394+ scheduleClear val
2395+ , subscriberInvalidateHeight = \_ -> return ()
2396+ , subscriberRecalculateHeight = \_ -> return ()
2397+ }
2398+ return $ SpiderEventHandle
2399+ { spiderEventHandleSubscription = subscription
2400+ , spiderEventHandleValue = val
2401+ }
2402+
2403+instance HasSpiderTimeline x => Reflex.Host.Class.ReflexHost (SpiderTimeline x) where
2404+ type EventTrigger (SpiderTimeline x) = RootTrigger x
2405+ type EventHandle (SpiderTimeline x) = SpiderEventHandle x
2406+ type HostFrame (SpiderTimeline x) = SpiderHostFrame x
2407+
2408+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReadEvent (SpiderTimeline x) (Reflex.Spider.Internal.ReadPhase x) where
2409+ {-# NOINLINE readEvent #-}
2410+ readEvent h = Reflex.Spider.Internal.ReadPhase $ fmap (fmap return) $ liftIO $ do
2411+ result <- readIORef $ spiderEventHandleValue h
2412+ touch h
2413+ return result
2414+
2415+instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where
2416+ newEventWithTrigger = SpiderHost . lift . fmap SpiderEvent . newEventWithTriggerIO
2417+ newFanEventWithTrigger f = SpiderHost $ lift $ do
2418+ es <- newFanEventWithTriggerIO f
2419+ return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es
2420+
2421+instance Reflex.Host.Class.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where
2422+ newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO
2423+ newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do
2424+ es <- newFanEventWithTriggerIO f
2425+ return $ Reflex.Class.EventSelector $ SpiderEvent . Reflex.Spider.Internal.select es
2426+
2427+instance HasSpiderTimeline x => Reflex.Host.Class.MonadSubscribeEvent (SpiderTimeline x) (SpiderHost x) where
2428+ {-# INLINABLE subscribeEvent #-}
2429+ subscribeEvent = runFrame . runSpiderHostFrame . Reflex.Host.Class.subscribeEvent
2430+
2431+instance HasSpiderTimeline x => Reflex.Host.Class.MonadReflexHost (SpiderTimeline x) (SpiderHost x) where
2432+ type ReadPhase (SpiderHost x) = Reflex.Spider.Internal.ReadPhase x
2433+ fireEventsAndRead es (Reflex.Spider.Internal.ReadPhase a) = run es a
2434+ runHostFrame = runFrame . runSpiderHostFrame
22562435
22572436unsafeNewSpiderTimelineEnv :: forall x. IO (SpiderTimelineEnv x)
22582437unsafeNewSpiderTimelineEnv = do
@@ -2269,7 +2448,6 @@ unsafeNewSpiderTimelineEnv = do
22692448#endif
22702449 }
22712450
2272−#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
22732451-- | Create a new SpiderTimelineEnv
22742452newSpiderTimeline :: IO (Some SpiderTimelineEnv)
22752453newSpiderTimeline = withSpiderTimeline (pure . Some.This)
@@ -2291,7 +2469,6 @@ withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> I
22912469withSpiderTimeline k = do
22922470 env <- unsafeNewSpiderTimelineEnv
22932471 reify env $ \s -> k $ localSpiderTimeline s env
2294−#endif
22952472
22962473newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
22972474
@@ -2299,7 +2476,6 @@ type ComputeM = EventM
22992476
23002477newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
23012478
2302−#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
23032479instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
23042480 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
23052481 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
@@ -2353,7 +2529,6 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
23532529 mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental
23542530 {-# INLINABLE fanInt #-}
23552531 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))
2356−#endif
23572532
23582533data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)
23592534
@@ -2393,12 +2568,10 @@ instance Monad (SpiderHost x) where
23932568runSpiderHost :: SpiderHost Global a -> IO a
23942569runSpiderHost (SpiderHost a) = runReaderT a globalSpiderTimelineEnv
23952570
2396−#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
23972571-- | Run an action affecting a given Spider timeline; this will be guarded by a
23982572-- mutex for that timeline
23992573runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a
24002574runSpiderHostForTimeline (SpiderHost a) = runReaderT a
2401−#endif
24022575
24032576newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)
24042577