88d12d9 · patch · git.iko.soy

git.iko.soy/patch

Merge branch 'develop' into phadej-haskell-ci

commit88d12d99b9c51ca280efc7f3f7a0cf2056ca79da authorAli Abrar <aliabrar@gmail.com> dateMon 5 Aug 2019, 19:46 (7 years ago) parentdc295b0 0bf106a

8 files changed+167−53

compare with develop

unifiedsplit

CONTRIBUTING.md+4 reflex.cabal+2 src/Control/Monad/ReaderIO.hs+60 src/Reflex/Class.hs+11 src/Reflex/Profiled.hs+11−7 src/Reflex/Pure.hs+1 src/Reflex/Spider/Internal.hs+66−46 test/Reflex/Bench/Focused.hs+12

CONTRIBUTING.md+4

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

4545

4646Make 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!

4747

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+

4852### Documentation

4953

5054#### In the code

reflex.cabal+2

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

6464 mtl >= 2.1 && < 2.3,

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

6666 primitive >= 0.5 && < 0.8,

67+ profunctors,

6768 random == 1.1.*,

6869 ref-tf == 0.4.*,

6970 reflection == 2.1.*,

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

8485 monoidal-containers == 0.5.0.0

8586

8687 exposed-modules:

88+ Control.Monad.ReaderIO

8789 Data.AppendMap,

8890 Data.FastMutableIntMap,

8991 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

3636 , coerceBehavior

3737 , coerceEvent

3838 , coerceDynamic

39+ , coerceIncremental

3940 , MonadSample (..)

4041 , MonadHold (..)

4142 -- ** 'fan' related types

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

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

320321 -- occurrence type

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

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

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

324329

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

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

353358coerceDynamic = coerceWith $ dynamicCoercion Coercion

354359

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+

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

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

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

src/Reflex/Profiled.hs+11−7

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

99{-# LANGUAGE TypeFamilies #-}

1010{-# LANGUAGE UndecidableInstances #-}

1111{-# LANGUAGE PolyKinds #-}

12+{-# LANGUAGE TypeApplications #-}

1213{-# LANGUAGE RankNTypes #-}

1314-- |

1415-- Module:

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

151152 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i

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

153154 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− Coercion -> unsafeCoerce (Coercion :: Coercion (Behavior (ProfiledTimeline t) a) (Behavior (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce

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

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− dynamicCoercion (c :: Coercion a b) = case dynamicCoercion c :: Coercion (Dynamic t a) (Dynamic t b) of

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

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

155+ behaviorCoercion c =

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

157+ eventCoercion c =

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

159+ dynamicCoercion c =

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

161+ incrementalCoercion c d =

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

163+ mergeIntIncremental = Event_Profiled . mergeIntIncremental .

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

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

162166

163167deriving 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

128128 behaviorCoercion Coercion = Coercion

129129 eventCoercion Coercion = Coercion

130130 dynamicCoercion Coercion = Coercion

131+ incrementalCoercion Coercion Coercion = Coercion

131132

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

133134

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

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

1717{-# LANGUAGE TypeOperators #-}

1818{-# LANGUAGE UndecidableInstances #-}

1919{-# LANGUAGE PolyKinds #-}

20+{-# LANGUAGE DeriveFunctor #-}

21+{-# LANGUAGE StandaloneDeriving #-}

2022{-# LANGUAGE InstanceSigs #-}

2123

2224#ifdef USE_REFLEX_OPTIMIZER

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

3638import Control.Monad.Exception

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

3840import 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

4045import Control.Monad.Ref

4146import Data.Align

4247import Data.Coerce

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

550555toAny :: a -> Any

551556toAny = unsafeCoerce

552557

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.

553563data EventSubscribed x = EventSubscribed

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

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

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

673683 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"

674684 parentsRef <- liftIO $ newIORef []

675685 holdInits <- askBehaviorHoldInits

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

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

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

678688 parents <- liftIO $ readIORef parentsRef

679689 let subscribed = PullSubscribed

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

708718-- Dynamic

709719--------------------------------------------------------------------------------

710720

711−data Dynamic x p = Dynamic

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

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

722+

723+data Dynamic x target p = Dynamic

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

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

714726 }

715727

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

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

729+

730+

731+

732+

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

717734dynamicHold !h = Dynamic

718735 { dynamicCurrent = behaviorHold h

719736 , dynamicUpdated = eventHold h

720737 }

721738

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

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

723740dynamicHoldIdentity = dynamicHold

724741

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

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

726743dynamicConst !a = Dynamic

727744 { dynamicCurrent = behaviorConst a

728745 , dynamicUpdated = eventNever

729746 }

730747

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

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

732749dynamicDyn !d = Dynamic

733750 { dynamicCurrent = behaviorDyn d

734751 , dynamicUpdated = eventDyn d

735752 }

736753

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

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

738755dynamicDynIdentity = dynamicDyn

739756

740757--------------------------------------------------------------------------------

741758-- Combinators

742759--------------------------------------------------------------------------------

743760

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

745−--representational so we can use coerce

746−

747761--type role Hold representational

748762data Hold x p

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

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

764778

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

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

767−data SpiderTimelineEnv x = SpiderTimelineEnv

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+

786+data SpiderTimelineEnv' x = SpiderTimelineEnv

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

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

770789#ifdef DEBUG

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

772791#endif

773792 }

774−type role SpiderTimelineEnv nominal

793+type role SpiderTimelineEnv' phantom

775794

776795instance Eq (SpiderTimelineEnv x) where

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

778797

779798instance 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)

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

782801 else Nothing

783802

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

800819runEventM = unEventM

801820

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

804823

805824class MonadIO m => Defer a m where

806825 getDeferralQueue :: m (IORef [a])

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

938957

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

940959

941−--type role BehaviorM representational

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

944963

945964instance Monad (BehaviorM x) where

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

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

11541173

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

11561175

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)

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

11591178

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

11621181zipDynWith f da db =

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

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

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

12341253run roots after = do

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

12361255 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

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

12391258 occBefore <- liftIO $ do

12401259 occBefore <- readIORef occRef

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

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

12991318withIncreasedDepth a = do

13001319 spiderTimeline <- askSpiderTimelineEnv

1301− liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ

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

13021321 result <- a

1303− liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred

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

13041323 return result

13051324#else

13061325withIncreasedDepth :: m a -> m a

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

13271346 message <- getMessage

13281347#ifdef DEBUG

13291348 spiderTimeline <- askSpiderTimelineEnv

1330− d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline

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

13311350#else

13321351 let d = 0

13331352#endif

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

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

13691388

13701389runBehaviorM :: 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)

13721391

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

13741393askInvalidator = do

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

1394+ (!m, _) <- ask

13761395 case m of

13771396 Nothing -> return Nothing

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

13791398

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

13811400askParentsRef = do

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

1401+ (!m, _) <- ask

13831402 case m of

13841403 Nothing -> return Nothing

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

13861405

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

13881407askBehaviorHoldInits = do

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

1408+ (_, !his) <- ask

13901409 return his

13911410

13921411{-# INLINE getDynHold #-}

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

17101729{-# INLINE mergeG #-}

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

17121731 => (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)

17141733mergeG nt d = cacheEvent (mergeCheap nt d)

17151734

17161735{-# INLINE mergeWithMove #-}

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

17181737 => (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)

17201739mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)

17211740

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

17231742mergeCheap

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

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

1726− -> Dynamic x (PatchDMap k q)

1745+ -> DynamicS x (PatchDMap k q)

17271746 -> Event x (DMap k v)

17281747mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy

17291748 where

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

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

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

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

1766− -> Dynamic x (PatchDMapWithMove k q)

1785+ -> DynamicS x (PatchDMapWithMove k q)

17671786 -> Event x (DMap k v)

17681787mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy

17691788 where

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

19111930

19121931{-# INLINE mergeGCheap' #-}

19131932mergeGCheap' :: 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)

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

19161935 initialParents <- readBehaviorUntracked $ dynamicCurrent d

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

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

19601979 , occ

19611980 )

19621981

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)

19641983mergeInt = cacheEvent . mergeIntCheap

19651984

19661985{-# 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)

19681987mergeIntCheap d = Event $ \sub -> do

19691988 initialParents <- readBehaviorUntracked $ dynamicCurrent d

19701989 accum <- liftIO $ FastMutableIntMap.newEmpty

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

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

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

21262145runFrame a = SpiderHost $ do

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

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

21282147 let go = do

21292148 result <- a

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

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

23362355

23372356{-# 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)

23392358newJoinDyn d =

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

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

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

24852504#ifdef DEBUG

24862505 depthRef <- newIORef 0

24872506#endif

2488− return $ SpiderTimelineEnv

2507+ return $ STE $ SpiderTimelineEnv

24892508 { _spiderTimeline_lock = lock

24902509 , _spiderTimeline_eventEnv = env

24912510#ifdef DEBUG

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

25012520

25022521instance Reifies s (SpiderTimelineEnv x) =>

25032522 HasSpiderTimeline (LocalSpiderTimeline x s) where

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

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

25052524

25062525localSpiderTimeline

2507− :: Proxy s

2526+ :: proxy s

25082527 -> SpiderTimelineEnv x

25092528 -> SpiderTimelineEnv (LocalSpiderTimeline x s)

2510−localSpiderTimeline _ = unsafeCoerce

2529+localSpiderTimeline _ = coerce

25112530

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

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

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

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

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

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

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

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

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

25302549 type PullM (SpiderTimeline x) = SpiderPullM x

25312550 type PushM (SpiderTimeline x) = SpiderPushM x

25322551 {-# INLINABLE never #-}

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

25552574 {-# INLINABLE current #-}

25562575 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic

25572576 {-# INLINABLE updated #-}

2558− updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic

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

25592578 {-# INLINABLE unsafeBuildDynamic #-}

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

25612580 {-# INLINABLE unsafeBuildIncremental #-}

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

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

25752594 eventCoercion Coercion = Coercion

25762595 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

25782598 {-# 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

25802600 {-# INLINABLE fanInt #-}

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

25822602

test/Reflex/Bench/Focused.hs+12

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

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

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

132132

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+

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

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

135145

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

308318dynamics n =

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

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

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

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

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

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

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