@@ -41,6 +41,7 @@ import qualified Data.Dependent.Map as DMap
4141import Data.Foldable hiding (concat, elem, sequence_)
4242import Data.Function
4343import Data.Functor.Constant
44+import Data.Functor.Misc
4445import Data.Functor.Product
4546import Data.GADT.Compare
4647import Data.IntMap.Strict (IntMap)
@@ -54,11 +55,11 @@ import Data.Some (Some)
5455import qualified Data.Some as Some
5556import Data.These
5657import Data.Traversable
57−import Data.Type.Coercion
5858import Data.Word
5959import GHC.Exts
6060import GHC.IORef (IORef (..))
6161import GHC.Stack
62+import Reflex.FunctorMaybe
6263import System.IO.Unsafe
6364import System.Mem.Weak
6465import Unsafe.Coerce
@@ -73,12 +74,13 @@ import Data.Tree (Forest, Tree (..), drawForest)
7374
7475import Data.WeakBag (WeakBag, WeakBagTicket)
7576import qualified Data.WeakBag as WeakBag
77+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
78+import Data.Type.Coercion
79+import qualified Reflex.Class
7680import qualified Reflex.Class as R
77−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
78−import Reflex.Class (SpiderTimeline, Global)
81+import qualified Reflex.Host.Class
7982#endif
8083import Reflex.Patch
81−import qualified Reflex.Host.Class as R
8284
8385-- Note: must come last to silence warnings due to AMP on GHC < 7.10
8486import Prelude hiding (any, concat, mapM, mapM_, sequence)
@@ -678,6 +680,8 @@ data Hold x p
678680#endif
679681 }
680682
683+data Global
684+
681685{-# NOINLINE globalSpiderTimelineEnv #-}
682686globalSpiderTimelineEnv :: SpiderTimelineEnv Global
683687!globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv
@@ -1041,12 +1045,12 @@ newInvalidatorSwitch subd = return $! InvalidatorSwitch subd
10411045newInvalidatorPull :: Pull x a -> IO (Invalidator x)
10421046newInvalidatorPull p = return $! InvalidatorPull p
10431047
1044−instance HasSpiderTimeline x => R.FunctorMaybe (Event x) where
1048+instance HasSpiderTimeline x => FunctorMaybe (Event x) where
10451049 fmapMaybe f = push $ return . f
10461050
10471051instance HasSpiderTimeline x => Align (Event x) where
10481052 nil = eventNever
1049− align ea eb = R.fmapMaybe R.dmapToThese $ merge $ dynamicConst $ DMap.fromList [R.LeftTag :=> ea, R.RightTag :=> eb]
1053+ align ea eb = fmapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromList [LeftTag :=> ea, RightTag :=> eb]
10501054
10511055newtype Dyn x p = Dyn { unDyn :: IORef (Either (BehaviorM x (PatchTarget p), Event x p) (Hold x p)) }
10521056
@@ -1073,15 +1077,6 @@ unsafeDyn :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
10731077unsafeDyn readV0 v' = Dyn $ unsafeNewIORef x $ Left x
10741078 where x = (readV0, v')
10751079
1076−newJoinDyn :: HasSpiderTimeline x => Dynamic x (Identity (Dynamic x (Identity a))) -> Dyn x (Identity a)
1077−newJoinDyn d =
1078− let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)
1079− eOuter = push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d
1080− eInner = switch $ dynamicUpdated <$> dynamicCurrent d
1081− eBoth = coincidence $ dynamicUpdated . runIdentity <$> dynamicUpdated d
1082− v' = unSpiderEvent $ R.leftmost $ map SpiderEvent [eBoth, eOuter, eInner]
1083− in unsafeDyn readV0 v'
1084−
10851080-- ResultM can read behaviors and events
10861081type ResultM = EventM
10871082
@@ -1855,14 +1850,12 @@ invalidate toReconnectRef wis = do
18551850-- Reflex integration
18561851--------------------------------------------------------------------------------
18571852
1858−-- | The default, global Spider environment
1859−type Spider = SpiderTimeline Global
1860−
18611853#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
18621854-- When we're specializing, we include this from Reflex.Class instead, because
18631855-- it needs access to these types; when we're not, we want them here, so our
18641856-- instance isn't an orphan instance.
18651857#include "SpiderTimeline.include.hs"
1858+#include "SpiderTimelineHost.include.hs"
18661859#endif
18671860
18681861unsafeNewSpiderTimelineEnv :: forall x. IO (SpiderTimelineEnv x)
@@ -1892,34 +1885,7 @@ newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applica
18921885
18931886newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix)
18941887
1895−instance HasSpiderTimeline x => Functor (R.Dynamic (SpiderTimeline x)) where
1896− fmap f = SpiderDynamic . newMapDyn f . unSpiderDynamic
1897−
1898−instance HasSpiderTimeline x => Applicative (R.Dynamic (SpiderTimeline x)) where
1899− pure = SpiderDynamic . dynamicConst
1900− SpiderDynamic a <*> SpiderDynamic b = SpiderDynamic $ zipDynWith ($) a b
1901− _ *> b = b
1902− a <* _ = a
1903−
1904−instance HasSpiderTimeline x => Monad (R.Dynamic (SpiderTimeline x)) where
1905− {-# INLINE return #-}
1906− return = pure
1907− {-# INLINE (>>=) #-}
1908− x >>= f = SpiderDynamic $ dynamicDynIdentity $ newJoinDyn $ newMapDyn (unSpiderDynamic . f) $ unSpiderDynamic x
1909− {-# INLINE (>>) #-}
1910− _ >> y = y
1911− {-# INLINE fail #-}
1912− fail _ = error "Dynamic does not support 'fail'"
1913−
1914−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
1915−instance t ~ SpiderTimeline Global => R.Reflex t where
1916− newtype Behavior t a = SpiderBehavior { unSpiderBehavior :: Behavior Global a }
1917− newtype Event t a = SpiderEvent { unSpiderEvent :: Event Global a }
1918− newtype Dynamic t a = SpiderDynamic { unSpiderDynamic :: Dynamic Global (Identity a) } -- deriving (Functor, Applicative, Monad)
1919− newtype Incremental t p = SpiderIncremental { unSpiderIncremental :: Dynamic Global p }
1920− type PullM t = SpiderPullM Global
1921− type PushM t = SpiderPushM Global
1922−#else
1888+#ifndef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
19231889instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
19241890 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
19251891 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
@@ -1928,7 +1894,6 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
19281894 newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }
19291895 type PullM (SpiderTimeline x) = SpiderPullM x
19301896 type PushM (SpiderTimeline x) = SpiderPushM x
1931−#endif
19321897 {-# INLINABLE never #-}
19331898 never = SpiderEvent eventNever
19341899 {-# INLINABLE constant #-}
@@ -1966,63 +1931,7 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
19661931 eventCoercion Coercion = Coercion
19671932 behaviorCoercion Coercion = Coercion
19681933 dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance
1969−
1970−instance HasSpiderTimeline x => R.MonadSample (SpiderTimeline x) (EventM x) where
1971− {-# INLINABLE sample #-}
1972− sample (SpiderBehavior b) = readBehaviorUntracked b
1973−
1974−instance HasSpiderTimeline x => R.MonadHold (SpiderTimeline x) (EventM x) where
1975− {-# INLINABLE hold #-}
1976− hold = holdSpiderEventM
1977− {-# INLINABLE holdDyn #-}
1978− holdDyn = holdDynSpiderEventM
1979− {-# INLINABLE holdIncremental #-}
1980− holdIncremental = holdIncrementalSpiderEventM
1981−
1982−holdSpiderEventM :: HasSpiderTimeline x => a -> R.Event (SpiderTimeline x) a -> EventM x (R.Behavior (SpiderTimeline x) a)
1983−holdSpiderEventM v0 e = fmap (SpiderBehavior . behaviorHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e
1984−
1985−holdDynSpiderEventM :: HasSpiderTimeline x => a -> R.Event (SpiderTimeline x) a -> EventM x (R.Dynamic (SpiderTimeline x) a)
1986−holdDynSpiderEventM v0 e = fmap (SpiderDynamic . dynamicHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e
1987−
1988−holdIncrementalSpiderEventM :: (HasSpiderTimeline x, Patch p) => PatchTarget p -> R.Event (SpiderTimeline x) p -> EventM x (R.Incremental (SpiderTimeline x) p)
1989−holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ hold v0 $ unSpiderEvent e
1990−
1991−instance HasSpiderTimeline x => R.MonadHold (SpiderTimeline x) (SpiderHost x) where
1992− {-# INLINABLE hold #-}
1993− hold v0 e = R.runHostFrame $ R.hold v0 e
1994− {-# INLINABLE holdDyn #-}
1995− holdDyn v0 e = R.runHostFrame $ R.holdDyn v0 e
1996− {-# INLINABLE holdIncremental #-}
1997− holdIncremental v0 e = R.runHostFrame $ R.holdIncremental v0 e
1998−
1999−instance HasSpiderTimeline x => R.MonadSample (SpiderTimeline x) (SpiderHost x) where
2000− {-# INLINABLE sample #-}
2001− sample = runFrame . readBehaviorUntracked . unSpiderBehavior
2002−
2003−instance (
2004−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2005− x ~ Global
2006−#endif
2007− ) => R.MonadSample (SpiderTimeline x) (SpiderPullM x) where
2008− {-# INLINABLE sample #-}
2009− sample = coerce . readBehaviorTracked . unSpiderBehavior
2010−
2011−instance (
2012−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2013− x ~ Global
20141934#endif
2015− ) => R.MonadSample (SpiderTimeline x) (SpiderPushM x) where
2016− {-# INLINABLE sample #-}
2017− sample (SpiderBehavior b) = SpiderPushM $ readBehaviorUntracked b
2018−
2019−instance HasSpiderTimeline x => R.MonadHold (SpiderTimeline x) (SpiderPushM x) where
2020− {-# INLINABLE hold #-}
2021− hold v0 e = R.current <$> R.holdDyn v0 e
2022− {-# INLINABLE holdDyn #-}
2023− holdDyn v0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicHoldIdentity) $ hold v0 $ coerce e
2024− {-# INLINABLE holdIncremental #-}
2025− holdIncremental v0 (SpiderEvent e) = SpiderPushM $ SpiderIncremental . dynamicHold <$> hold v0 e
20261935
20271936data RootTrigger x a = forall k. GCompare k => RootTrigger (WeakBag (Subscriber x a), IORef (DMap k Identity), k a)
20281937
@@ -2031,35 +1940,6 @@ data SpiderEventHandle x a = SpiderEventHandle
20311940 , spiderEventHandleValue :: IORef (Maybe a)
20321941 }
20331942
2034−instance HasSpiderTimeline x => R.MonadSubscribeEvent (SpiderTimeline x) (SpiderHostFrame x) where
2035− {-# INLINABLE subscribeEvent #-}
2036− subscribeEvent e = SpiderHostFrame $ do
2037− --TODO: Unsubscribe eventually (manually and/or with weak ref)
2038− val <- liftIO $ newIORef Nothing
2039− subscription <- subscribe (unSpiderEvent e) $ Subscriber
2040− { subscriberPropagate = \a -> do
2041− liftIO $ writeIORef val $ Just a
2042− scheduleClear val
2043− , subscriberInvalidateHeight = \_ -> return ()
2044− , subscriberRecalculateHeight = \_ -> return ()
2045− }
2046− return $ SpiderEventHandle
2047− { spiderEventHandleSubscription = subscription
2048− , spiderEventHandleValue = val
2049− }
2050−
2051−instance HasSpiderTimeline x => R.ReflexHost (SpiderTimeline x) where
2052− type EventTrigger (SpiderTimeline x) = RootTrigger x
2053− type EventHandle (SpiderTimeline x) = SpiderEventHandle x
2054− type HostFrame (SpiderTimeline x) = SpiderHostFrame x
2055−
2056−instance HasSpiderTimeline x => R.MonadReadEvent (SpiderTimeline x) (ReadPhase x) where
2057− {-# NOINLINE readEvent #-}
2058− readEvent h = ReadPhase $ fmap (fmap return) $ liftIO $ do
2059− result <- readIORef $ spiderEventHandleValue h
2060− touch h
2061− return result
2062−
20631943instance MonadRef (EventM x) where
20641944 type Ref (EventM x) = Ref IO
20651945 {-# INLINABLE newRef #-}
@@ -2108,17 +1988,6 @@ instance Monad (SpiderHostFrame x) where
21081988 {-# INLINABLE fail #-}
21091989 fail s = SpiderHostFrame $ fail s
21101990
2111−instance HasSpiderTimeline x => R.MonadSample (SpiderTimeline x) (SpiderHostFrame x) where
2112− sample = SpiderHostFrame . readBehaviorUntracked . unSpiderBehavior --TODO: This can cause problems with laziness, so we should get rid of it if we can
2113−
2114−instance HasSpiderTimeline x => R.MonadHold (SpiderTimeline x) (SpiderHostFrame x) where
2115− {-# INLINABLE hold #-}
2116− hold v0 e = SpiderHostFrame $ fmap (SpiderBehavior . behaviorHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e
2117− {-# INLINABLE holdDyn #-}
2118− holdDyn v0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicHoldIdentity) $ hold v0 $ coerce $ unSpiderEvent e
2119− {-# INLINABLE holdIncremental #-}
2120− holdIncremental v0 e = SpiderHostFrame $ fmap (SpiderIncremental . dynamicHold) $ hold v0 $ unSpiderEvent e
2121−
21221991newEventWithTriggerIO :: (RootTrigger x a -> IO (IO ())) -> IO (Event x a)
21231992newEventWithTriggerIO f = do
21241993 es <- newFanEventWithTriggerIO $ \Refl -> f
@@ -2135,49 +2004,8 @@ newFanEventWithTriggerIO f = do
21352004 }
21362005 return $ EventSelector $ \k -> eventRoot k r
21372006
2138−instance (
2139−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2140− x ~ Global
2141−#endif
2142− ) => R.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHost x) where
2143− newEventWithTrigger = SpiderHost . lift . fmap SpiderEvent . newEventWithTriggerIO
2144− newFanEventWithTrigger f = SpiderHost $ lift $ do
2145− es <- newFanEventWithTriggerIO f
2146− return $ R.EventSelector $ SpiderEvent . select es
2147−
2148−instance (
2149−#ifdef SPECIALIZE_TO_SPIDERTIMELINE_GLOBAL
2150− x ~ Global
2151−#endif
2152− ) => R.MonadReflexCreateTrigger (SpiderTimeline x) (SpiderHostFrame x) where
2153− newEventWithTrigger = SpiderHostFrame . EventM . liftIO . fmap SpiderEvent . newEventWithTriggerIO
2154− newFanEventWithTrigger f = SpiderHostFrame $ EventM $ liftIO $ do
2155− es <- newFanEventWithTriggerIO f
2156− return $ R.EventSelector $ SpiderEvent . select es
2157−
2158−instance HasSpiderTimeline x => R.MonadSubscribeEvent (SpiderTimeline x) (SpiderHost x) where
2159− {-# INLINABLE subscribeEvent #-}
2160− subscribeEvent = runFrame . runSpiderHostFrame . R.subscribeEvent
2161−
21622007newtype ReadPhase x a = ReadPhase (ResultM x a) deriving (Functor, Applicative, Monad, MonadFix)
21632008
2164−instance HasSpiderTimeline x => R.MonadSample (SpiderTimeline x) (ReadPhase x) where
2165− {-# INLINABLE sample #-}
2166− sample = ReadPhase . R.sample
2167−
2168−instance HasSpiderTimeline x => R.MonadHold (SpiderTimeline x) (ReadPhase x) where
2169− {-# INLINABLE hold #-}
2170− hold v0 e = ReadPhase $ R.hold v0 e
2171− {-# INLINABLE holdDyn #-}
2172− holdDyn v0 e = ReadPhase $ R.holdDyn v0 e
2173− {-# INLINABLE holdIncremental #-}
2174− holdIncremental v0 e = ReadPhase $ R.holdIncremental v0 e
2175−
2176−instance HasSpiderTimeline x => R.MonadReflexHost (SpiderTimeline x) (SpiderHost x) where
2177− type ReadPhase (SpiderHost x) = ReadPhase x
2178− fireEventsAndRead es (ReadPhase a) = run es a
2179− runHostFrame = runFrame . runSpiderHostFrame
2180−
21812009instance MonadRef (SpiderHost x) where
21822010 type Ref (SpiderHost x) = Ref IO
21832011 newRef = SpiderHost . newRef
@@ -2199,10 +2027,3 @@ instance MonadAtomicRef (SpiderHostFrame x) where
21992027instance PrimMonad (SpiderHostFrame x) where
22002028 type PrimState (SpiderHostFrame x) = PrimState IO
22012029 primitive = SpiderHostFrame . EventM . primitive
2202−
2203−--------------------------------------------------------------------------------
2204−-- Deprecated items
2205−--------------------------------------------------------------------------------
2206−
2207−{-# DEPRECATED SpiderEnv "Use 'SpiderTimelineEnv' instead" #-}
2208−type SpiderEnv = SpiderTimeline