88d12d9 · patch · git.iko.soy

git.iko.soy/patch

Merge branch 'develop' into phadej-haskell-ci

88d12d9Ali Abrar7 years ago

CONTRIBUTING.md+4

@@ -45,6 +45,10 @@ Your pull request should add no new warnings to the project. It should also gene

46Make sure the project builds and that the tests pass! This will generally also be checked by CI before merge, but trying it yourself first means you'll catch problems earlier and your contribution can be merged that much sooner!

48+#### Dependencies

49+

50+Include version bounds whenever adding a dependency to the library stanza of the cabal file. Note that libraries added to reflex.cabal also need to be added to default.nix.

51+

48### Documentation

52### Documentation

50#### In the code

54#### In the code

reflex.cabal+2

@@ -64,6 +64,7 @@ library

64 mtl >= 2.1 && < 2.3,

65 prim-uniq >= 0.1.0.1 && < 0.2,

66 primitive >= 0.5 && < 0.8,

67+ profunctors,

67 random == 1.1.*,

68 random == 1.1.*,

68 ref-tf == 0.4.*,

69 ref-tf == 0.4.*,

69 reflection == 2.1.*,

70 reflection == 2.1.*,

@@ -84,6 +85,7 @@ library

84 monoidal-containers == 0.5.0.0

85 monoidal-containers == 0.5.0.0

86 exposed-modules:

87 exposed-modules:

88+ Control.Monad.ReaderIO

87 Data.AppendMap,

89 Data.AppendMap,

88 Data.FastMutableIntMap,

90 Data.FastMutableIntMap,

89 Data.FastWeakBag,

91 Data.FastWeakBag,

src/Control/Monad/ReaderIO.hsnew file+60

@@ -0,0 +1,60 @@

1+{-# language RoleAnnotations #-}

2+{-# language MultiParamTypeClasses #-}

3+{-# language FlexibleInstances #-}

4+{-# language CPP #-}

5+module Control.Monad.ReaderIO

6+ (

7+ ReaderIO (..)

8+ )

9+ where

10+

11+import Control.Monad.Fix

12+#if MIN_VERSION_base(4,10,0)

13+import Control.Applicative

14+#endif

15+import Control.Monad

16+import Control.Monad.Reader.Class

17+import Control.Monad.IO.Class

18+

19+-- | An approximate clone of @RIO@ from the @rio@ package, but not based on

20+-- @ReaderT@. The trouble with @ReaderT@ is that its third type argument has a

21+-- @nominal@ role, so we can't coerce through it when it's wrapped in some

22+-- other @data@ type. Ugh.

23+newtype ReaderIO e a = ReaderIO { runReaderIO :: e -> IO a }

24+type role ReaderIO representational representational

25+

26+instance Functor (ReaderIO e) where

27+ fmap = liftM

28+ {-# INLINE fmap #-}

29+ a <$ m = m >> pure a

30+ {-# INLINE (<$) #-}

31+

32+instance Applicative (ReaderIO e) where

33+ pure a = ReaderIO $ \_ -> pure a

34+ {-# INLINE pure #-}

35+ (<*>) = ap

36+ {-# INLINE (<*>) #-}

37+#if MIN_VERSION_base(4,10,0)

38+ liftA2 = liftM2

39+ {-# INLINE liftA2 #-}

40+#endif

41+ (*>) = (>>)

42+ {-# INLINE (*>) #-}

43+

44+instance Monad (ReaderIO e) where

45+ ReaderIO q >>= f = ReaderIO $ \e -> q e >>= \a -> runReaderIO (f a) e

46+ {-# INLINE (>>=) #-}

47+

48+instance MonadFix (ReaderIO e) where

49+ mfix f = ReaderIO $ \e -> mfix $ \r -> runReaderIO (f r) e

50+ {-# INLINE mfix #-}

51+

52+instance MonadIO (ReaderIO e) where

53+ liftIO m = ReaderIO $ \_ -> m

54+ {-# INLINE liftIO #-}

55+

56+instance MonadReader e (ReaderIO e) where

57+ ask = ReaderIO pure

58+ {-# INLINE ask #-}

59+ local f (ReaderIO m) = ReaderIO (m . f)

60+ {-# INLINE local #-}

src/Reflex/Class.hs+11

@@ -36,6 +36,7 @@ module Reflex.Class

36 , coerceBehavior

37 , coerceEvent

38 , coerceDynamic

39+ , coerceIncremental

39 , MonadSample (..)

40 , MonadSample (..)

40 , MonadHold (..)

41 , MonadHold (..)

41 -- ** 'fan' related types

42 -- ** 'fan' related types

@@ -319,6 +320,10 @@ class ( MonadHold t (PushM t)

319 -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its

320 -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its

320 -- occurrence type

321 -- occurrence type

321 dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)

322 dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)

323+ -- | Construct a 'Coercion' for an 'Incremental' given 'Coercion's for its

324+ -- patch target and patch types.

325+ incrementalCoercion

326+ :: Coercion (PatchTarget a) (PatchTarget b) -> Coercion a b -> Coercion (Incremental t a) (Incremental t b)

322 mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)

327 mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)

323 fanInt :: Event t (IntMap a) -> EventSelectorInt t a

328 fanInt :: Event t (IntMap a) -> EventSelectorInt t a

324

329

@@ -352,6 +357,12 @@ coerceEvent = coerceWith $ eventCoercion Coercion

352coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b

357coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b

353coerceDynamic = coerceWith $ dynamicCoercion Coercion

358coerceDynamic = coerceWith $ dynamicCoercion Coercion

354

359

360+-- | Coerce an 'Incremental' between representationally-equivalent value types

361+coerceIncremental

362+ :: (Reflex t, Coercible a b, Coercible (PatchTarget a) (PatchTarget b))

363+ => Incremental t a -> Incremental t b

364+coerceIncremental = coerceWith $ incrementalCoercion Coercion Coercion

365+

355-- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior'

366-- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior'

356-- __must__ change when and only when the 'Event' fires, such that the

367-- __must__ change when and only when the 'Event' fires, such that the

357-- 'Behavior''s value is always equal to the most recent firing of the 'Event';

368-- 'Behavior''s value is always equal to the most recent firing of the 'Event';

src/Reflex/Profiled.hs+11−7

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

9{-# LANGUAGE TypeFamilies #-}

10{-# LANGUAGE UndecidableInstances #-}

11{-# LANGUAGE PolyKinds #-}

12+{-# LANGUAGE TypeApplications #-}

12{-# LANGUAGE RankNTypes #-}

13{-# LANGUAGE RankNTypes #-}

13-- |

14-- |

14-- Module:

15-- Module:

@@ -151,13 +152,16 @@ instance Reflex t => Reflex (ProfiledTimeline t) where

151 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i

152 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i

152 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i

153 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i

153 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i

154 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i

154− behaviorCoercion (c :: Coercion a b) = case behaviorCoercion c :: Coercion (Behavior t a) (Behavior t b) of

155+ behaviorCoercion c =

155− Coercion -> unsafeCoerce (Coercion :: Coercion (Behavior (ProfiledTimeline t) a) (Behavior (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce

156+ Coercion `trans` behaviorCoercion @t c `trans` Coercion

156− eventCoercion (c :: Coercion a b) = case eventCoercion c :: Coercion (Event t a) (Event t b) of

157+ eventCoercion c =

157− Coercion -> unsafeCoerce (Coercion :: Coercion (Event (ProfiledTimeline t) a) (Event (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce

158+ Coercion `trans` eventCoercion @t c `trans` Coercion

159+ dynamicCoercion c =

158− dynamicCoercion (c :: Coercion a b) = case dynamicCoercion c :: Coercion (Dynamic t a) (Dynamic t b) of

160+ Coercion `trans` dynamicCoercion @t c `trans` Coercion

159− Coercion -> unsafeCoerce (Coercion :: Coercion (Dynamic (ProfiledTimeline t) a) (Dynamic (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce

161+ incrementalCoercion c d =

162+ Coercion `trans` incrementalCoercion @t c d `trans` Coercion

160− mergeIntIncremental = Event_Profiled . mergeIntIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchIntMap (Event (ProfiledTimeline t) a)) -> Incremental t (PatchIntMap (Event t a)))

163+ mergeIntIncremental = Event_Profiled . mergeIntIncremental .

164+ coerceWith (Coercion `trans` incrementalCoercion Coercion Coercion `trans` Coercion)

161 fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e

165 fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e

162

166

163deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t))

167deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t))

src/Reflex/Pure.hs+1

@@ -128,6 +128,7 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where

128 behaviorCoercion Coercion = Coercion

129 eventCoercion Coercion = Coercion

130 dynamicCoercion Coercion = Coercion

131+ incrementalCoercion Coercion Coercion = Coercion

131

132

132 fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k

133 fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k

133

134

src/Reflex/Spider/Internal.hs+66−46

@@ -17,6 +17,8 @@

17{-# LANGUAGE TypeOperators #-}

18{-# LANGUAGE UndecidableInstances #-}

19{-# LANGUAGE PolyKinds #-}

20+{-# LANGUAGE DeriveFunctor #-}

21+{-# LANGUAGE StandaloneDeriving #-}

20{-# LANGUAGE InstanceSigs #-}

22{-# LANGUAGE InstanceSigs #-}

22#ifdef USE_REFLEX_OPTIMIZER

24#ifdef USE_REFLEX_OPTIMIZER

@@ -36,7 +38,10 @@ import Control.Monad hiding (forM, forM_, mapM, mapM_)

36import Control.Monad.Exception

38import Control.Monad.Exception

37import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)

39import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)

38import Control.Monad.Primitive

40import Control.Monad.Primitive

39−import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_)

41+--import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_)

42+import Control.Monad.Reader.Class

43+import Control.Monad.IO.Class

44+import Control.Monad.ReaderIO

40import Control.Monad.Ref

45import Control.Monad.Ref

41import Data.Align

46import Data.Align

42import Data.Coerce

47import Data.Coerce

@@ -550,6 +555,11 @@ propagateFast a subscribers = withIncreasedDepth $ do

550toAny :: a -> Any

555toAny :: a -> Any

551toAny = unsafeCoerce

556toAny = unsafeCoerce

552

557

558+-- Why do we use Any here, instead of just giving eventSubscribedRetained an

559+-- existential type? Sadly, GHC does not currently know how to unbox types

560+-- with existentially quantified fields. So instead we just coerce values

561+-- to type Any on the way in. Since we never coerce them back, this is

562+-- perfectly safe.

553data EventSubscribed x = EventSubscribed

563data EventSubscribed x = EventSubscribed

554 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)

564 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)

555 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any

565 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any

@@ -673,7 +683,7 @@ behaviorPull !p = Behavior $ do

673 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"

683 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"

674 parentsRef <- liftIO $ newIORef []

684 parentsRef <- liftIO $ newIORef []

675 holdInits <- askBehaviorHoldInits

685 holdInits <- askBehaviorHoldInits

676− a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)

686+ a <- liftIO $ runReaderIO (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)

677 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator

687 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator

678 parents <- liftIO $ readIORef parentsRef

688 parents <- liftIO $ readIORef parentsRef

679 let subscribed = PullSubscribed

689 let subscribed = PullSubscribed

@@ -708,42 +718,46 @@ readBehaviorUntracked b = do

708-- Dynamic

718-- Dynamic

709--------------------------------------------------------------------------------

719--------------------------------------------------------------------------------

710

720

721+type DynamicS x p = Dynamic x (PatchTarget p) p

722+

711−data Dynamic x p = Dynamic

723+data Dynamic x target p = Dynamic

712− { dynamicCurrent :: !(Behavior x (PatchTarget p))

724+ { dynamicCurrent :: !(Behavior x target)

713 , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`?

725 , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`?

714 }

726 }

715

727

728+deriving instance (HasSpiderTimeline x) => Functor (Dynamic x target)

729+

730+

731+

732+

716−dynamicHold :: Hold x p -> Dynamic x p

733+dynamicHold :: Hold x p -> DynamicS x p

717dynamicHold !h = Dynamic

734dynamicHold !h = Dynamic

718 { dynamicCurrent = behaviorHold h

735 { dynamicCurrent = behaviorHold h

719 , dynamicUpdated = eventHold h

736 , dynamicUpdated = eventHold h

720 }

737 }

721

738

722−dynamicHoldIdentity :: Hold x (Identity a) -> Dynamic x (Identity a)

739+dynamicHoldIdentity :: Hold x (Identity a) -> DynamicS x (Identity a)

723dynamicHoldIdentity = dynamicHold

740dynamicHoldIdentity = dynamicHold

724

741

725−dynamicConst :: PatchTarget p -> Dynamic x p

742+dynamicConst :: PatchTarget p -> DynamicS x p

726dynamicConst !a = Dynamic

743dynamicConst !a = Dynamic

727 { dynamicCurrent = behaviorConst a

744 { dynamicCurrent = behaviorConst a

728 , dynamicUpdated = eventNever

745 , dynamicUpdated = eventNever

729 }

746 }

730

747

731−dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p

748+dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> DynamicS x p

732dynamicDyn !d = Dynamic

749dynamicDyn !d = Dynamic

733 { dynamicCurrent = behaviorDyn d

750 { dynamicCurrent = behaviorDyn d

734 , dynamicUpdated = eventDyn d

751 , dynamicUpdated = eventDyn d

735 }

752 }

736

753

737−dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)

754+dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> DynamicS x (Identity a)

738dynamicDynIdentity = dynamicDyn

755dynamicDynIdentity = dynamicDyn

739

756

740--------------------------------------------------------------------------------

757--------------------------------------------------------------------------------

741-- Combinators

758-- Combinators

742--------------------------------------------------------------------------------

759--------------------------------------------------------------------------------

743

760

744−--TODO: Figure out why certain things are not 'representational', then make them

745−--representational so we can use coerce

746−

747--type role Hold representational

761--type role Hold representational

748data Hold x p

762data Hold x p

749 = Hold { holdValue :: !(IORef (PatchTarget p))

763 = Hold { holdValue :: !(IORef (PatchTarget p))

@@ -764,20 +778,25 @@ globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv

764

778

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

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

766-- value should exist for each type @x@

780-- value should exist for each type @x@

781+newtype SpiderTimelineEnv x = STE {unSTE :: SpiderTimelineEnv' x}

782+-- We implement SpiderTimelineEnv with a newtype wrapper so

783+-- we can get the coercions we want safely.

784+type role SpiderTimelineEnv nominal

785+

767−data SpiderTimelineEnv x = SpiderTimelineEnv

786+data SpiderTimelineEnv' x = SpiderTimelineEnv

768 { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())

787 { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())

769 , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)

788 , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)

770#ifdef DEBUG

789#ifdef DEBUG

771 , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)

790 , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)

772#endif

791#endif

773 }

792 }

774−type role SpiderTimelineEnv nominal

793+type role SpiderTimelineEnv' phantom

775

794

776instance Eq (SpiderTimelineEnv x) where

795instance Eq (SpiderTimelineEnv x) where

777 _ == _ = True -- Since only one exists of each type

796 _ == _ = True -- Since only one exists of each type

778

797

779instance GEq SpiderTimelineEnv where

798instance GEq SpiderTimelineEnv where

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

799+ a `geq` b = if _spiderTimeline_lock (unSTE a) == _spiderTimeline_lock (unSTE b)

781 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments

800 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments

782 else Nothing

801 else Nothing

783

802

@@ -800,7 +819,7 @@ runEventM :: EventM x a -> IO a

800runEventM = unEventM

819runEventM = unEventM

801

820

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

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

803−asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)

822+asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (unSTE (spiderTimeline :: SpiderTimelineEnv x))

804

823

805class MonadIO m => Defer a m where

824class MonadIO m => Defer a m where

806 getDeferralQueue :: m (IORef [a])

825 getDeferralQueue :: m (IORef [a])

@@ -938,9 +957,9 @@ getHoldEventSubscription h = do

938

957

939type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])

958type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])

940

959

941−--type role BehaviorM representational

942-- BehaviorM can sample behaviors

960-- BehaviorM can sample behaviors

943−newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderT (BehaviorEnv x) IO a } deriving (Functor, Applicative, MonadIO, MonadFix)

961+newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderIO (BehaviorEnv x) a }

962+ deriving (Functor, Applicative, MonadIO, MonadFix, MonadReader (BehaviorEnv x))

944

963

945instance Monad (BehaviorM x) where

964instance Monad (BehaviorM x) where

946 {-# INLINE (>>=) #-}

965 {-# INLINE (>>=) #-}

@@ -1154,11 +1173,11 @@ data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)

1154

1173

1155newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }

1174newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }

1156

1175

1157−newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)

1176+newMapDyn :: HasSpiderTimeline x => (a -> b) -> DynamicS x (Identity a) -> DynamicS x (Identity b)

1158newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)

1177newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)

1159

1178

1160--TODO: Avoid the duplication between this and R.zipDynWith

1179--TODO: Avoid the duplication between this and R.zipDynWith

1161−zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)

1180+zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> DynamicS x (Identity a) -> DynamicS x (Identity b) -> DynamicS x (Identity c)

1162zipDynWith f da db =

1181zipDynWith f da db =

1163 let eab = align (dynamicUpdated da) (dynamicUpdated db)

1182 let eab = align (dynamicUpdated da) (dynamicUpdated db)

1164 ec = flip push eab $ \o -> do

1183 ec = flip push eab $ \o -> do

@@ -1234,7 +1253,7 @@ run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> Res

1234run roots after = do

1253run roots after = do

1235 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"

1254 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"

1236 let t = spiderTimeline :: SpiderTimelineEnv x

1255 let t = spiderTimeline :: SpiderTimelineEnv x

1237− result <- SpiderHost $ withMVar (_spiderTimeline_lock t) $ \_ -> unSpiderHost $ runFrame $ do

1256+ result <- SpiderHost $ withMVar (_spiderTimeline_lock (unSTE t)) $ \_ -> unSpiderHost $ runFrame $ do

1238 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do

1257 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do

1239 occBefore <- liftIO $ do

1258 occBefore <- liftIO $ do

1240 occBefore <- readIORef occRef

1259 occBefore <- readIORef occRef

@@ -1298,9 +1317,9 @@ type WeakList a = [Weak a]

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

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

1299withIncreasedDepth a = do

1318withIncreasedDepth a = do

1300 spiderTimeline <- askSpiderTimelineEnv

1319 spiderTimeline <- askSpiderTimelineEnv

1301− liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ

1320+ liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) succ

1302 result <- a

1321 result <- a

1303− liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred

1322+ liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) pred

1304 return result

1323 return result

1305#else

1324#else

1306withIncreasedDepth :: m a -> m a

1325withIncreasedDepth :: m a -> m a

@@ -1327,7 +1346,7 @@ traceMWhen _ b getMessage = when b $ do

1327 message <- getMessage

1346 message <- getMessage

1328#ifdef DEBUG

1347#ifdef DEBUG

1329 spiderTimeline <- askSpiderTimelineEnv

1348 spiderTimeline <- askSpiderTimelineEnv

1330− d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline

1349+ d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE spiderTimeline

1331#else

1350#else

1332 let d = 0

1351 let d = 0

1333#endif

1352#endif

@@ -1368,25 +1387,25 @@ propagateSubscriberHold h a = do

1368data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset

1387data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset

1369

1388

1370runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a

1389runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a

1371−runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)

1390+runBehaviorM a mwi holdInits = runReaderIO (unBehaviorM a) (mwi, holdInits)

1372

1391

1373askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))

1392askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))

1374askInvalidator = do

1393askInvalidator = do

1375− (!m, _) <- BehaviorM ask

1394+ (!m, _) <- ask

1376 case m of

1395 case m of

1377 Nothing -> return Nothing

1396 Nothing -> return Nothing

1378 Just (!wi, _) -> return $ Just wi

1397 Just (!wi, _) -> return $ Just wi

1379

1398

1380askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))

1399askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))

1381askParentsRef = do

1400askParentsRef = do

1382− (!m, _) <- BehaviorM ask

1401+ (!m, _) <- ask

1383 case m of

1402 case m of

1384 Nothing -> return Nothing

1403 Nothing -> return Nothing

1385 Just (_, !p) -> return $ Just p

1404 Just (_, !p) -> return $ Just p

1386

1405

1387askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])

1406askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])

1388askBehaviorHoldInits = do

1407askBehaviorHoldInits = do

1389− (_, !his) <- BehaviorM ask

1408+ (_, !his) <- ask

1390 return his

1409 return his

1391

1410

1392{-# INLINE getDynHold #-}

1411{-# INLINE getDynHold #-}

@@ -1710,20 +1729,20 @@ subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceS

1710{-# INLINE mergeG #-}

1729{-# INLINE mergeG #-}

1711mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)

1730mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)

1712 => (forall a. q a -> Event x (v a))

1731 => (forall a. q a -> Event x (v a))

1713− -> Dynamic x (PatchDMap k q) -> Event x (DMap k v)

1732+ -> DynamicS x (PatchDMap k q) -> Event x (DMap k v)

1714mergeG nt d = cacheEvent (mergeCheap nt d)

1733mergeG nt d = cacheEvent (mergeCheap nt d)

1715

1734

1716{-# INLINE mergeWithMove #-}

1735{-# INLINE mergeWithMove #-}

1717mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)

1736mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)

1718 => (forall a. q a -> Event x (v a))

1737 => (forall a. q a -> Event x (v a))

1719− -> Dynamic x (PatchDMapWithMove k q) -> Event x (DMap k v)

1738+ -> DynamicS x (PatchDMapWithMove k q) -> Event x (DMap k v)

1720mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)

1739mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)

1721

1740

1722{-# INLINE [1] mergeCheap #-}

1741{-# INLINE [1] mergeCheap #-}

1723mergeCheap

1742mergeCheap

1724 :: forall k x q v. (HasSpiderTimeline x, GCompare k)

1743 :: forall k x q v. (HasSpiderTimeline x, GCompare k)

1725 => (forall a. q a -> Event x (v a))

1744 => (forall a. q a -> Event x (v a))

1726− -> Dynamic x (PatchDMap k q)

1745+ -> DynamicS x (PatchDMap k q)

1727 -> Event x (DMap k v)

1746 -> Event x (DMap k v)

1728mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy

1747mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy

1729 where

1748 where

@@ -1763,7 +1782,7 @@ mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy

1763{-# INLINE [1] mergeCheapWithMove #-}

1782{-# INLINE [1] mergeCheapWithMove #-}

1764mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)

1783mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)

1765 => (forall a. q a -> Event x (v a))

1784 => (forall a. q a -> Event x (v a))

1766− -> Dynamic x (PatchDMapWithMove k q)

1785+ -> DynamicS x (PatchDMapWithMove k q)

1767 -> Event x (DMap k v)

1786 -> Event x (DMap k v)

1768mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy

1787mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy

1769 where

1788 where

@@ -1911,7 +1930,7 @@ updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m)

1911

1930

1912{-# INLINE mergeGCheap' #-}

1931{-# INLINE mergeGCheap' #-}

1913mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)

1932mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)

1914− => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> Dynamic x p -> Event x (DMap k v)

1933+ => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v)

1915mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do

1934mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do

1916 initialParents <- readBehaviorUntracked $ dynamicCurrent d

1935 initialParents <- readBehaviorUntracked $ dynamicCurrent d

1917 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"

1936 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"

@@ -1960,11 +1979,11 @@ mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do

1960 , occ

1979 , occ

1961 )

1980 )

1962

1981

1963−mergeInt :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)

1982+mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)

1964mergeInt = cacheEvent . mergeIntCheap

1983mergeInt = cacheEvent . mergeIntCheap

1965

1984

1966{-# INLINABLE mergeIntCheap #-}

1985{-# INLINABLE mergeIntCheap #-}

1967−mergeIntCheap :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a)

1986+mergeIntCheap :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a)

1968mergeIntCheap d = Event $ \sub -> do

1987mergeIntCheap d = Event $ \sub -> do

1969 initialParents <- readBehaviorUntracked $ dynamicCurrent d

1988 initialParents <- readBehaviorUntracked $ dynamicCurrent d

1970 accum <- liftIO $ FastMutableIntMap.newEmpty

1989 accum <- liftIO $ FastMutableIntMap.newEmpty

@@ -2124,7 +2143,7 @@ clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeI

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

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

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

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

2126runFrame a = SpiderHost $ do

2145runFrame a = SpiderHost $ do

2127− let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)

2146+ let env = _spiderTimeline_eventEnv $ unSTE (spiderTimeline :: SpiderTimelineEnv x)

2128 let go = do

2147 let go = do

2129 result <- a

2148 result <- a

2130 runHoldInits (eventEnvHoldInits env) (eventEnvDynInits 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

2149 runHoldInits (eventEnvHoldInits env) (eventEnvDynInits 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

@@ -2335,7 +2354,7 @@ instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x))

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

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

2336

2355

2337{-# INLINABLE newJoinDyn #-}

2356{-# INLINABLE newJoinDyn #-}

2338−newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)

2357+newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a)

2339newJoinDyn d =

2358newJoinDyn d =

2340 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)

2359 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)

2341 eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d

2360 eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d

@@ -2485,7 +2504,7 @@ unsafeNewSpiderTimelineEnv = do

2485#ifdef DEBUG

2504#ifdef DEBUG

2486 depthRef <- newIORef 0

2505 depthRef <- newIORef 0

2487#endif

2506#endif

2488− return $ SpiderTimelineEnv

2507+ return $ STE $ SpiderTimelineEnv

2489 { _spiderTimeline_lock = lock

2508 { _spiderTimeline_lock = lock

2490 , _spiderTimeline_eventEnv = env

2509 , _spiderTimeline_eventEnv = env

2491#ifdef DEBUG

2510#ifdef DEBUG

@@ -2501,13 +2520,13 @@ data LocalSpiderTimeline (x :: Type) s

2501

2520

2502instance Reifies s (SpiderTimelineEnv x) =>

2521instance Reifies s (SpiderTimelineEnv x) =>

2503 HasSpiderTimeline (LocalSpiderTimeline x s) where

2522 HasSpiderTimeline (LocalSpiderTimeline x s) where

2504− spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s)

2523+ spiderTimeline = localSpiderTimeline Proxy $ reflect (Proxy :: Proxy s)

2505

2524

2506localSpiderTimeline

2525localSpiderTimeline

2507− :: Proxy s

2526+ :: proxy s

2508 -> SpiderTimelineEnv x

2527 -> SpiderTimelineEnv x

2509 -> SpiderTimelineEnv (LocalSpiderTimeline x s)

2528 -> SpiderTimelineEnv (LocalSpiderTimeline x s)

2510−localSpiderTimeline _ = unsafeCoerce

2529+localSpiderTimeline _ = coerce

2511

2530

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

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

2513withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r

2532withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r

@@ -2525,8 +2544,8 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

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

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

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

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

2527 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }

2546 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }

2528− newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)

2547+ newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: DynamicS x (Identity a) } -- deriving (Functor, Applicative, Monad)

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

2548+ newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: DynamicS x p }

2530 type PullM (SpiderTimeline x) = SpiderPullM x

2549 type PullM (SpiderTimeline x) = SpiderPullM x

2531 type PushM (SpiderTimeline x) = SpiderPushM x

2550 type PushM (SpiderTimeline x) = SpiderPushM x

2532 {-# INLINABLE never #-}

2551 {-# INLINABLE never #-}

@@ -2555,7 +2574,7 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2555 {-# INLINABLE current #-}

2574 {-# INLINABLE current #-}

2556 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic

2575 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic

2557 {-# INLINABLE updated #-}

2576 {-# INLINABLE updated #-}

2558− updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic

2577+ updated = SpiderEvent #. dynamicUpdated .# fmap coerce . unSpiderDynamic

2559 {-# INLINABLE unsafeBuildDynamic #-}

2578 {-# INLINABLE unsafeBuildDynamic #-}

2560 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'

2579 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'

2561 {-# INLINABLE unsafeBuildIncremental #-}

2580 {-# INLINABLE unsafeBuildIncremental #-}

@@ -2574,9 +2593,10 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where

2574 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'

2593 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'

2575 eventCoercion Coercion = Coercion

2594 eventCoercion Coercion = Coercion

2576 behaviorCoercion Coercion = Coercion

2595 behaviorCoercion Coercion = Coercion

2577− dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance

2596+ dynamicCoercion Coercion = Coercion

2597+ incrementalCoercion Coercion Coercion = Coercion

2578 {-# INLINABLE mergeIntIncremental #-}

2598 {-# INLINABLE mergeIntIncremental #-}

2579− mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental

2599+ mergeIntIncremental = SpiderEvent . mergeInt . coerce

2580 {-# INLINABLE fanInt #-}

2600 {-# INLINABLE fanInt #-}

2581 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))

2601 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))

2582

2602

test/Reflex/Bench/Focused.hs+12

@@ -130,6 +130,16 @@ mapDynChain = iterM (return . fmap (+1))

130joinDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

131joinDynChain = iterM (\d -> return $ join $ fmap (const d) d)

132

133+holdDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

134+holdDynChain = iterM (\d -> sample (current d) >>= flip holdDyn (updated d))

135+

136+buildDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

137+buildDynChain = iterM (\d -> do

138+ let b = fmap (+1) (current d)

139+ e = fmap (*2) (updated d)

140+ buildDynamic (sample b) e)

141+

142+

133combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

143combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)

134combineDynChain = iterM (\d -> return $ zipDynWith (+) d d)

144combineDynChain = iterM (\d -> return $ zipDynWith (+) d d)

135

145

@@ -308,6 +318,8 @@ dynamics :: Word -> [(String, TestCase)]

308dynamics n =

318dynamics n =

309 [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d

319 [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d

310 , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d

320 , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d

321+ , testE "holdDynChain" $ fmap updated $ holdDynChain n =<< d

322+ , testE "buildDynChain" $ fmap updated $ buildDynChain n =<< d

311 , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d

323 , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d

312 , testE "dense mergeTree" $ fmap (updated . mergeTreeDyn 8) dense

324 , testE "dense mergeTree" $ fmap (updated . mergeTreeDyn 8) dense

313 , testE "sparse mergeTree" $ fmap (updated . mergeTreeDyn 8) sparse

325 , testE "sparse mergeTree" $ fmap (updated . mergeTreeDyn 8) sparse