eae5179 · reflex · git.iko.soy

git.iko.soy/reflex

on develop help sign in

Add specialize-to-spidertimeline-global flag

eae5179Ryan Trinkle10 years ago

reflex.cabal+10−1

compare with develop

unifiedsplit

@@ -13,6 +13,11 @@ Cabal-version: >=1.9.2

13homepage: https://github.com/reflex-frp/reflex

14bug-reports: https://github.com/reflex-frp/reflex/issues

16+flag specialize-to-spidertimeline-global

17+ description: Specialize all Reflex functions to the SpiderTimeline Global implementation. This may improve performance, but will disable all other implementations.

18+ default: False

19+ manual: True

20+

16library

21library

17 hs-source-dirs: src

22 hs-source-dirs: src

18 build-depends:

23 build-depends:

@@ -55,7 +60,6 @@ library

55 Reflex.PerformEvent.Base,

60 Reflex.PerformEvent.Base,

56 Reflex.PerformEvent.Class,

61 Reflex.PerformEvent.Class,

57 Reflex.PostBuild.Class,

62 Reflex.PostBuild.Class,

58− Reflex.Pure,

59 Reflex.Spider,

63 Reflex.Spider,

60 Reflex.Spider.Internal

64 Reflex.Spider.Internal

@@ -63,6 +67,11 @@ library

63 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2

67 ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -O2

64 ghc-prof-options: -auto-all

68 ghc-prof-options: -auto-all

70+ if flag(specialize-to-spidertimeline-global)

71+ cpp-options: -DSPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

72+ else

73+ exposed-modules: Reflex.Pure

74+

66test-suite semantics

75test-suite semantics

67 type: exitcode-stdio-1.0

76 type: exitcode-stdio-1.0

68 main-is: semantics.hs

77 main-is: semantics.hs

src/Reflex/Class.hs+17−4

@@ -1,5 +1,6 @@

1{-# LANGUAGE CPP #-}

2{-# LANGUAGE DeriveFunctor #-}

3+{-# LANGUAGE EmptyDataDecls #-}

3{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FlexibleInstances #-}

5{-# LANGUAGE FunctionalDependencies #-}

6{-# LANGUAGE FunctionalDependencies #-}

@@ -9,6 +10,7 @@

9{-# LANGUAGE NoMonomorphismRestriction #-}

10{-# LANGUAGE NoMonomorphismRestriction #-}

10{-# LANGUAGE RankNTypes #-}

11{-# LANGUAGE RankNTypes #-}

11{-# LANGUAGE RecursiveDo #-}

12{-# LANGUAGE RecursiveDo #-}

13+{-# LANGUAGE RoleAnnotations #-}

12{-# LANGUAGE ScopedTypeVariables #-}

14{-# LANGUAGE ScopedTypeVariables #-}

13{-# LANGUAGE StandaloneDeriving #-}

15{-# LANGUAGE StandaloneDeriving #-}

14{-# LANGUAGE TypeFamilies #-}

16{-# LANGUAGE TypeFamilies #-}

@@ -89,6 +91,10 @@ module Reflex.Class

89 , appendEvents

91 , appendEvents

90 , onceE

92 , onceE

91 , sequenceThese

93 , sequenceThese

94+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

95+ , SpiderTimeline

96+ , Global

97+#endif

92 ) where

98 ) where

94import Control.Applicative

100import Control.Applicative

@@ -129,6 +135,10 @@ import Prelude hiding (foldl, mapM, mapM_, sequence, sequence_)

129

135

130import Debug.Trace (trace)

136import Debug.Trace (trace)

131

137

138+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

139+#include "Spider/SpiderTimeline.include.hs"

140+#endif

141+

132-- | The 'Reflex' class contains all the primitive functionality needed for

142-- | The 'Reflex' class contains all the primitive functionality needed for

133-- Functional Reactive Programming (FRP). The @t@ type parameter indicates

143-- Functional Reactive Programming (FRP). The @t@ type parameter indicates

134-- which "timeline" is in use. Timelines are fully-independent FRP contexts,

144-- which "timeline" is in use. Timelines are fully-independent FRP contexts,

@@ -140,6 +150,9 @@ class ( MonadHold t (PushM t)

140 , Functor (Dynamic t)

150 , Functor (Dynamic t)

141 , Applicative (Dynamic t) -- Necessary for GHC <= 7.8

151 , Applicative (Dynamic t) -- Necessary for GHC <= 7.8

142 , Monad (Dynamic t)

152 , Monad (Dynamic t)

153+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

154+ , t ~ SpiderTimeline Global

155+#endif

143 ) => Reflex t where

156 ) => Reflex t where

144 -- | A container for a value that can change over time. 'Behavior's can be

157 -- | A container for a value that can change over time. 'Behavior's can be

145 -- sampled at will, but it is not possible to be notified when they change

158 -- sampled at will, but it is not possible to be notified when they change

@@ -719,21 +732,21 @@ class Reflex t => Accumulator t f | f -> t where

719

732

720-- | Accumulate occurrences of an 'Event', producing an output occurrence each

733-- | Accumulate occurrences of an 'Event', producing an output occurrence each

721-- time. Discard the underlying 'Accumulator'.

734-- time. Discard the underlying 'Accumulator'.

722−mapAccum_ :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Event t c)

735+mapAccum_ :: forall t m a b c. (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (a, c)) -> a -> Event t b -> m (Event t c)

723mapAccum_ f z e = do

736mapAccum_ f z e = do

724 (_ :: Behavior t a, result) <- mapAccum f z e

737 (_ :: Behavior t a, result) <- mapAccum f z e

725 return result

738 return result

726

739

727-- | Accumulate occurrences of an 'Event', possibly producing an output

740-- | Accumulate occurrences of an 'Event', possibly producing an output

728-- occurrence each time. Discard the underlying 'Accumulator'.

741-- occurrence each time. Discard the underlying 'Accumulator'.

729−mapAccumMaybe_ :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (Event t c)

742+mapAccumMaybe_ :: forall t m a b c. (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> (Maybe a, Maybe c)) -> a -> Event t b -> m (Event t c)

730mapAccumMaybe_ f z e = do

743mapAccumMaybe_ f z e = do

731 (_ :: Behavior t a, result) <- mapAccumMaybe f z e

744 (_ :: Behavior t a, result) <- mapAccumMaybe f z e

732 return result

745 return result

733

746

734-- | Accumulate occurrences of an 'Event', using a 'PushM' action and producing

747-- | Accumulate occurrences of an 'Event', using a 'PushM' action and producing

735-- an output occurrence each time. Discard the underlying 'Accumulator'.

748-- an output occurrence each time. Discard the underlying 'Accumulator'.

736−mapAccumM_ :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (Event t c)

749+mapAccumM_ :: forall t m a b c. (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (a, c)) -> a -> Event t b -> m (Event t c)

737mapAccumM_ f z e = do

750mapAccumM_ f z e = do

738 (_ :: Behavior t a, result) <- mapAccumM f z e

751 (_ :: Behavior t a, result) <- mapAccumM f z e

739 return result

752 return result

@@ -741,7 +754,7 @@ mapAccumM_ f z e = do

741-- | Accumulate occurrences of an 'Event', using a 'PushM' action and possibly

754-- | Accumulate occurrences of an 'Event', using a 'PushM' action and possibly

742-- producing an output occurrence each time. Discard the underlying

755-- producing an output occurrence each time. Discard the underlying

743-- 'Accumulator'.

756-- 'Accumulator'.

744−mapAccumMaybeM_ :: (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (Event t c)

757+mapAccumMaybeM_ :: forall t m a b c. (Reflex t, MonadHold t m, MonadFix m) => (a -> b -> PushM t (Maybe a, Maybe c)) -> a -> Event t b -> m (Event t c)

745mapAccumMaybeM_ f z e = do

758mapAccumMaybeM_ f z e = do

746 (_ :: Behavior t a, result) <- mapAccumMaybeM f z e

759 (_ :: Behavior t a, result) <- mapAccumMaybeM f z e

747 return result

760 return result

src/Reflex/Spider.hs+4

@@ -1,3 +1,4 @@

1+{-# LANGUAGE CPP #-}

1-- | This module exports all of the user-facing functionality of the 'Spider'

2-- | This module exports all of the user-facing functionality of the 'Spider'

2-- 'Reflex' engine

3-- 'Reflex' engine

3module Reflex.Spider

4module Reflex.Spider

@@ -13,4 +14,7 @@ module Reflex.Spider

13 , SpiderEnv

14 , SpiderEnv

14 ) where

15 ) where

17+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

18+import Reflex.Class

19+#endif

16import Reflex.Spider.Internal

20import Reflex.Spider.Internal

src/Reflex/Spider/Internal.hs+90−51

@@ -18,6 +18,9 @@

18{-# LANGUAGE TypeOperators #-}

19{-# LANGUAGE UndecidableInstances #-}

20{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}

21+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

22+{-# OPTIONS_GHC -fno-warn-orphans #-}

23+#endif

21-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses

24-- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses

22-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.

25-- a graph traversal algorithm to propagate 'Event's and 'Behavior's.

23module Reflex.Spider.Internal where

26module Reflex.Spider.Internal where

@@ -71,6 +74,9 @@ import Data.Tree (Forest, Tree (..), drawForest)

71import Data.WeakBag (WeakBag, WeakBagTicket)

74import Data.WeakBag (WeakBag, WeakBagTicket)

72import qualified Data.WeakBag as WeakBag

75import qualified Data.WeakBag as WeakBag

73import qualified Reflex.Class as R

76import qualified Reflex.Class as R

77+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

78+import Reflex.Class (SpiderTimeline, Global)

79+#endif

74import Reflex.Patch

80import Reflex.Patch

75import qualified Reflex.Host.Class as R

81import qualified Reflex.Host.Class as R

@@ -612,8 +618,7 @@ readHoldTracked h = do

612 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))

618 askParentsRef >>= mapM_ (\r -> liftIO $ modifyIORef' r (SomeBehaviorSubscribed (BehaviorSubscribedHold h) :))

613 return result

619 return result

614

620

615−{-# SPECIALIZE readBehaviorUntracked :: Behavior x a -> BehaviorM x a #-}

616−{-# SPECIALIZE readBehaviorUntracked :: HasSpiderTimeline x => Behavior x a -> EventM x a #-}

621+{-# INLINABLE readBehaviorUntracked #-}

617readBehaviorUntracked :: Defer (SomeHoldInit x) m => Behavior x a -> m a

622readBehaviorUntracked :: Defer (SomeHoldInit x) m => Behavior x a -> m a

618readBehaviorUntracked b = do

623readBehaviorUntracked b = do

619 holdInits <- getDeferralQueue

624 holdInits <- getDeferralQueue

@@ -670,6 +675,26 @@ data Hold x p

670#endif

675#endif

671 }

676 }

672

677

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+

673data EventEnv x

698data EventEnv x

674 = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe

699 = EventEnv { eventEnvAssignments :: !(IORef [SomeAssignment x]) -- Needed for Subscribe

675 , eventEnvHoldInits :: !(IORef [SomeHoldInit x]) -- Needed for Subscribe

700 , eventEnvHoldInits :: !(IORef [SomeHoldInit x]) -- Needed for Subscribe

@@ -687,7 +712,7 @@ runEventM :: EventM x a -> IO a

687runEventM = unEventM

712runEventM = unEventM

688

713

689asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a

714asksEventEnv :: 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)

691

716

692class MonadIO m => Defer a m where

717class MonadIO m => Defer a m where

693 getDeferralQueue :: m (IORef [a])

718 getDeferralQueue :: m (IORef [a])

@@ -732,12 +757,16 @@ instance HasSpiderTimeline x => HasCurrentHeight x (EventM x) where

732 delayedRef <- asksEventEnv eventEnvDelayedMerges

757 delayedRef <- asksEventEnv eventEnvDelayedMerges

733 liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [subscribed]

758 liftIO $ modifyIORef' delayedRef $ IntMap.insertWith (++) (unHeight height) [subscribed]

734

759

760+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

761+class x ~ Global => HasSpiderTimeline x where

762+#else

735class HasSpiderTimeline x where

763class HasSpiderTimeline x where

764+#endif

736− -- | Retrieve the current SpiderTimeline

765+ -- | Retrieve the current SpiderTimelineEnv

737− spiderTimeline :: SpiderTimeline x

766+ spiderTimeline :: SpiderTimelineEnv x

738

767

739instance HasSpiderTimeline Global where

768instance HasSpiderTimeline Global where

740− spiderTimeline = globalSpiderTimeline

769+ spiderTimeline = globalSpiderTimelineEnv

741

770

742putCurrentHeight :: HasSpiderTimeline x => Height -> EventM x ()

771putCurrentHeight :: HasSpiderTimeline x => Height -> EventM x ()

743putCurrentHeight h = do

772putCurrentHeight h = do

@@ -891,7 +920,7 @@ newtype ComputeM x a = ComputeM (ReaderT (IORef [SomeHoldInit x]) IO a) deriving

891instance Defer (SomeHoldInit x) (ComputeM x) where

920instance Defer (SomeHoldInit x) (ComputeM x) where

892 getDeferralQueue = ComputeM ask

921 getDeferralQueue = ComputeM ask

893

922

894−{-# SPECIALIZE runComputeM :: HasSpiderTimeline x => ComputeM x a -> EventM x a #-}

923+{-# INLINABLE runComputeM #-}

895runComputeM :: Defer (SomeHoldInit x) m => ComputeM x a -> m a

924runComputeM :: Defer (SomeHoldInit x) m => ComputeM x a -> m a

896runComputeM (ComputeM a) = liftIO . runReaderT a =<< getDeferralQueue

925runComputeM (ComputeM a) = liftIO . runReaderT a =<< getDeferralQueue

897

926

@@ -1156,7 +1185,7 @@ type WeakList a = [Weak a]

1156#ifdef DEBUG

1185#ifdef DEBUG

1157withIncreasedDepth :: CanTrace x m => m a -> m a

1186withIncreasedDepth :: CanTrace x m => m a -> m a

1158withIncreasedDepth a = do

1187withIncreasedDepth a = do

1159− spiderTimeline <- askSpiderTimeline

1188+ spiderTimeline <- askSpiderTimelineEnv

1160 liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ

1189 liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ

1161 result <- a

1190 result <- a

1162 liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred

1191 liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred

@@ -1185,7 +1214,7 @@ traceMWhen :: (CanTrace x m) => proxy x -> Bool -> m String -> m ()

1185traceMWhen _ b getMessage = when b $ do

1214traceMWhen _ b getMessage = when b $ do

1186 message <- getMessage

1215 message <- getMessage

1187#ifdef DEBUG

1216#ifdef DEBUG

1188− spiderTimeline <- askSpiderTimeline

1217+ spiderTimeline <- askSpiderTimelineEnv

1189 d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline

1218 d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline

1190#else

1219#else

1191 let d = 0

1220 let d = 0

@@ -1319,7 +1348,7 @@ cleanupRootSubscribed self@(RootSubscribed { rootSubscribedKey = k, rootSubscrib

1319subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket

1348subscribeRootSubscribed :: RootSubscribed x a -> Subscriber x a -> IO WeakBagTicket

1320subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed

1349subscribeRootSubscribed subscribed sub = WeakBag.insert sub (rootSubscribedSubscribers subscribed) (rootSubscribedWeakSelf subscribed) cleanupRootSubscribed

1321

1350

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 #-}

1323getFanSubscribed :: (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)

1352getFanSubscribed :: (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)

1324getFanSubscribed k f sub = do

1353getFanSubscribed k f sub = do

1325 mSubscribed <- liftIO $ readIORef $ fanSubscribed f

1354 mSubscribed <- liftIO $ readIORef $ fanSubscribed f

@@ -1378,7 +1407,7 @@ subscribeFanSubscribed k subscribed sub = do

1378 return sln

1407 return sln

1379 Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed

1408 Just (FanSubscribedChildren list _ weakSelf) -> {-# SCC "hitSubscribeFanSubscribed" #-} WeakBag.insert sub list weakSelf cleanupFanSubscribed

1380

1409

1381−{-# SPECIALIZE getSwitchSubscribed :: HasSpiderTimeline x => Switch x a -> Subscriber x a -> EventM x (WeakBagTicket, SwitchSubscribed x a, Maybe a) #-}

1410+{-# INLINABLE getSwitchSubscribed #-}

1382getSwitchSubscribed :: (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)

1411getSwitchSubscribed :: (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)

1383getSwitchSubscribed s sub = do

1412getSwitchSubscribed s sub = do

1384 mSubscribed <- liftIO $ readIORef $ switchSubscribed s

1413 mSubscribed <- liftIO $ readIORef $ switchSubscribed s

@@ -1434,7 +1463,7 @@ cleanupSwitchSubscribed subscribed = do

1434subscribeSwitchSubscribed :: SwitchSubscribed x a -> Subscriber x a -> IO WeakBagTicket

1463subscribeSwitchSubscribed :: SwitchSubscribed x a -> Subscriber x a -> IO WeakBagTicket

1435subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed

1464subscribeSwitchSubscribed subscribed sub = WeakBag.insert sub (switchSubscribedSubscribers subscribed) (switchSubscribedWeakSelf subscribed) cleanupSwitchSubscribed

1436

1465

1437−{-# SPECIALIZE getCoincidenceSubscribed :: HasSpiderTimeline x => Coincidence x a -> Subscriber x a -> EventM x (WeakBagTicket, CoincidenceSubscribed x a, Maybe a) #-}

1466+{-# INLINABLE getCoincidenceSubscribed #-}

1438getCoincidenceSubscribed :: 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)

1467getCoincidenceSubscribed :: 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)

1439getCoincidenceSubscribed c sub = do

1468getCoincidenceSubscribed c sub = do

1440 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c

1469 mSubscribed <- liftIO $ readIORef $ coincidenceSubscribed c

@@ -1670,7 +1699,7 @@ clearEventEnv (EventEnv toAssignRef holdInitRef mergeUpdateRef mergeInitRef toCl

1670-- | Run an event action outside of a frame

1699-- | Run an event action outside of a frame

1671runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex

1700runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex

1672runFrame a = SpiderHost $ ask >>= \_ -> lift $ do

1701runFrame a = SpiderHost $ ask >>= \_ -> lift $ do

1673− let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimeline x)

1702+ let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)

1674 let go = do

1703 let go = do

1675 result <- a

1704 result <- a

1676 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

1705 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

1824--------------------------------------------------------------------------------

1853--------------------------------------------------------------------------------

1825

1854

1826-- | The default, global Spider environment

1855-- | The default, global Spider environment

1827−type Spider = SpiderTimeline Global

1856+type Spider = SpiderTimelineEnv Global

1828−

1829−-- | Designates the default, global Spider timeline

1830−data Global

1831

1857

1832−{-# NOINLINE globalSpiderTimeline #-}

1858+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

1833−globalSpiderTimeline :: SpiderTimeline Global

1859+-- When we're specializing, we include this from Reflex.Class instead, because

1834−!globalSpiderTimeline = unsafePerformIO unsafeNewSpiderTimeline

1860+-- it needs access to these types; when we're not, we want them here, so our

1835−

1861+-- instance isn't an orphan instance.

1836−-- | Stores all global data relevant to a particular Spider timeline; only one

1862+#include "SpiderTimeline.include.hs"

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)

1843#endif

1863#endif

1844− }

1845−type role SpiderTimeline nominal

1846

1864

1847−instance GEq SpiderTimeline where

1865+unsafeNewSpiderTimelineEnv :: forall x. IO (SpiderTimelineEnv x)

1848− a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b

1866+unsafeNewSpiderTimelineEnv = do

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

1854 lock <- newMVar ()

1867 lock <- newMVar ()

1855 env <- newEventEnv

1868 env <- newEventEnv

1856#ifdef DEBUG

1869#ifdef DEBUG

1857 depthRef <- newIORef 0

1870 depthRef <- newIORef 0

1858#endif

1871#endif

1859− return $ SpiderTimeline

1872+ return $ SpiderTimelineEnv

1860 { _spiderTimeline_lock = lock

1873 { _spiderTimeline_lock = lock

1861 , _spiderTimeline_eventEnv = env

1874 , _spiderTimeline_eventEnv = env

1862#ifdef DEBUG

1875#ifdef DEBUG

@@ -1864,13 +1877,13 @@ unsafeNewSpiderTimeline = do

1864#endif

1877#endif

1865 }

1878 }

1866

1879

1867−-- | Create a new SpiderTimeline

1880+-- | Create a new SpiderTimelineEnv

1868−newSpiderTimeline :: IO (Some SpiderTimeline)

1881+newSpiderTimeline :: IO (Some SpiderTimelineEnv)

1869newSpiderTimeline = withSpiderTimeline (pure . Some.This)

1882newSpiderTimeline = withSpiderTimeline (pure . Some.This)

1870

1883

1871-- | Pass a new timeline to the given function.

1884-- | Pass a new timeline to the given function.

1872−withSpiderTimeline :: (forall x. SpiderTimeline x -> IO r) -> IO r

1885+withSpiderTimeline :: (forall x. SpiderTimelineEnv x -> IO r) -> IO r

1873−withSpiderTimeline k = unsafeNewSpiderTimeline >>= k

1886+withSpiderTimeline k = unsafeNewSpiderTimelineEnv >>= k

1874

1887

1875newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

1888newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)

1876

1889

@@ -1895,6 +1908,15 @@ instance HasSpiderTimeline x => Monad (R.Dynamic (SpiderTimeline x)) where

1895 {-# INLINE fail #-}

1908 {-# INLINE fail #-}

1896 fail _ = error "Dynamic does not support 'fail'"

1909 fail _ = error "Dynamic does not support 'fail'"

1897

1910

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

1898instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

1920instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

1899 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}

1921 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}

1900 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }

1922 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }

@@ -1903,6 +1925,7 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

1903 newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }

1925 newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }

1904 type PullM (SpiderTimeline x) = SpiderPullM x

1926 type PullM (SpiderTimeline x) = SpiderPullM x

1905 type PushM (SpiderTimeline x) = SpiderPushM x

1927 type PushM (SpiderTimeline x) = SpiderPushM x

1928+#endif

1906 {-# INLINABLE never #-}

1929 {-# INLINABLE never #-}

1907 never = SpiderEvent eventNever

1930 never = SpiderEvent eventNever

1908 {-# INLINABLE constant #-}

1931 {-# INLINABLE constant #-}

@@ -1974,11 +1997,19 @@ instance HasSpiderTimeline x => R.MonadSample (SpiderTimeline x) (SpiderHost x)

1974 {-# INLINABLE sample #-}

1997 {-# INLINABLE sample #-}

1975 sample = runFrame . readBehaviorUntracked . unSpiderBehavior

1998 sample = runFrame . readBehaviorUntracked . unSpiderBehavior

1976

1999

2000+instance (

2001+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

2002+ x ~ Global

2003+#endif

1977−instance R.MonadSample (SpiderTimeline x) (SpiderPullM x) where

2004+ ) => R.MonadSample (SpiderTimeline x) (SpiderPullM x) where

1978 {-# INLINABLE sample #-}

2005 {-# INLINABLE sample #-}

1979 sample = coerce . readBehaviorTracked . unSpiderBehavior

2006 sample = coerce . readBehaviorTracked . unSpiderBehavior

1980

2007

2008+instance (

2009+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

2010+ x ~ Global

2011+#endif

1981−instance R.MonadSample (SpiderTimeline x) (SpiderPushM x) where

2012+ ) => R.MonadSample (SpiderTimeline x) (SpiderPushM x) where

1982 {-# INLINABLE sample #-}

2013 {-# INLINABLE sample #-}

1983 sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b

2014 sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b

1984

2015

@@ -2040,7 +2071,7 @@ instance MonadAtomicRef (EventM x) where

2040 atomicModifyRef r f = liftIO $ atomicModifyRef r f

2071 atomicModifyRef r f = liftIO $ atomicModifyRef r f

2041

2072

2042-- | The monad for actions that manipulate a Spider timeline identified by @x@

2073-- | 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)

2044

2075

2045instance Monad (SpiderHost x) where

2076instance Monad (SpiderHost x) where

2046 {-# INLINABLE (>>=) #-}

2077 {-# INLINABLE (>>=) #-}

@@ -2055,11 +2086,11 @@ instance Monad (SpiderHost x) where

2055-- | Run an action affecting the global Spider timeline; this will be guarded by

2086-- | Run an action affecting the global Spider timeline; this will be guarded by

2056-- a mutex for that timeline

2087-- a mutex for that timeline

2057runSpiderHost :: SpiderHost Global a -> IO a

2088runSpiderHost :: SpiderHost Global a -> IO a

2058−runSpiderHost (SpiderHost a) = runReaderT a globalSpiderTimeline

2089+runSpiderHost (SpiderHost a) = runReaderT a globalSpiderTimelineEnv

2059

2090

2060-- | Run an action affecting a given Spider timeline; this will be guarded by a

2091-- | Run an action affecting a given Spider timeline; this will be guarded by a

2061-- mutex for that timeline

2092-- mutex for that timeline

2062−runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimeline x -> IO a

2093+runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a

2063runSpiderHostForTimeline (SpiderHost a) = runReaderT a

2094runSpiderHostForTimeline (SpiderHost a) = runReaderT a

2064

2095

2065newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

2096newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException)

@@ -2101,13 +2132,21 @@ newFanEventWithTriggerIO f = do

2101 }

2132 }

2102 return $ EventSelector $ \k -> eventRoot k r

2133 return $ EventSelector $ \k -> eventRoot k r

2103

2134

2135+instance (

2136+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

2137+ x ~ Global

2138+#endif

2104−instance R.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where

2139+ ) => R.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where

2105 newEventWithTrigger = SpiderHost . lift . fmap SpiderEvent . newEventWithTriggerIO

2140 newEventWithTrigger = SpiderHost . lift . fmap SpiderEvent . newEventWithTriggerIO

2106 newFanEventWithTrigger f = SpiderHost $ lift $ do

2141 newFanEventWithTrigger f = SpiderHost $ lift $ do

2107 es <- newFanEventWithTriggerIO f

2142 es <- newFanEventWithTriggerIO f

2108 return $ R.EventSelector $ SpiderEvent . select es

2143 return $ R.EventSelector $ SpiderEvent . select es

2109

2144

2145+instance (

2146+#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL

2147+ x ~ Global

2148+#endif

2110−instance R.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where

2149+ ) => R.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where

2111 newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO

2150 newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO

2112 newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do

2151 newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do

2113 es <- newFanEventWithTriggerIO f

2152 es <- newFanEventWithTriggerIO f

@@ -2162,5 +2201,5 @@ instance PrimMonad (SpiderHostFrame x) where

2162-- Deprecated items

2201-- Deprecated items

2163--------------------------------------------------------------------------------

2202--------------------------------------------------------------------------------

2164

2203

2165−{-# DEPRECATED SpiderEnv "Use 'SpiderTimeline' instead" #-}

2204+{-# DEPRECATED SpiderEnv "Use 'SpiderTimelineEnv' instead" #-}

2166−type SpiderEnv = SpiderTimeline

2205+type SpiderEnv = SpiderTimelineEnv

src/Reflex/Spider/SpiderTimeline.include.hsnew file+5

@@ -0,0 +1,5 @@

1+-- | Designates the default, global Spider timeline

2+data Global

4+data SpiderTimeline x

5+type role SpiderTimeline nominal