b3ad64a · reflex · git.iko.soy

git.iko.soy/reflex

Revert "Less unsafeCoerce (#322)"

This reverts commit 5e037c06c86023c73245b38275c9949e0fb27940.

commitb3ad64aed1244f6cf841ee7fae06aad33cb9a96d authorMatthew Bauer <mjbauer95@gmail.com> dateFri 31 Jan 2020, 16:53 (7 years ago) parent8064382

7 files changed+53−162

compare with develop

unifiedsplit

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

reflex.cabal−1

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

8585 monoidal-containers == 0.4.0.0

8686

8787 exposed-modules:

88− Control.Monad.ReaderIO

8988 Data.AppendMap,

9089 Data.FastMutableIntMap,

9190 Data.FastWeakBag,

src/Control/Monad/ReaderIO.hsdeleted−60

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

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,7 +36,6 @@ module Reflex.Class

3636 , coerceBehavior

3737 , coerceEvent

3838 , coerceDynamic

39− , coerceIncremental

4039 , MonadSample (..)

4140 , MonadHold (..)

4241 -- ** 'fan' related types

@@ -317,10 +316,6 @@ class ( MonadHold t (PushM t)

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

318317 -- occurrence type

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

320− -- | Construct a 'Coercion' for an 'Incremental' given 'Coercion's for its

321− -- patch target and patch types.

322− incrementalCoercion

323− :: Coercion (PatchTarget a) (PatchTarget b) -> Coercion a b -> Coercion (Incremental t a) (Incremental t b)

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

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

326321

@@ -342,12 +337,6 @@ coerceEvent = coerceWith $ eventCoercion Coercion

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

343338coerceDynamic = coerceWith $ dynamicCoercion Coercion

344339

345−-- | Coerce an 'Incremental' between representationally-equivalent value types

346−coerceIncremental

347− :: (Reflex t, Coercible a b, Coercible (PatchTarget a) (PatchTarget b))

348− => Incremental t a -> Incremental t b

349−coerceIncremental = coerceWith $ incrementalCoercion Coercion Coercion

350−

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

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

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

src/Reflex/Profiled.hs+7−11

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

99{-# LANGUAGE TypeFamilies #-}

1010{-# LANGUAGE UndecidableInstances #-}

1111{-# LANGUAGE PolyKinds #-}

12−{-# LANGUAGE TypeApplications #-}

1312{-# LANGUAGE RankNTypes #-}

1413-- |

1514-- Module:

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

152151 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i

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

154153 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i

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)

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

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

166162

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

src/Reflex/Pure.hs−1

@@ -128,7 +128,6 @@ 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

132131

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

134133

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

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

1717{-# LANGUAGE TypeOperators #-}

1818{-# LANGUAGE UndecidableInstances #-}

1919{-# LANGUAGE PolyKinds #-}

20−{-# LANGUAGE DeriveFunctor #-}

21−{-# LANGUAGE StandaloneDeriving #-}

2220{-# LANGUAGE InstanceSigs #-}

2321#ifdef USE_REFLEX_OPTIMIZER

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

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

3735import Control.Monad.Exception

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

3937import Control.Monad.Primitive

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

41−import Control.Monad.Reader.Class

42−import Control.Monad.IO.Class

43−import Control.Monad.ReaderIO

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

4439import Control.Monad.Ref

4540import Data.Align

4641import Data.Coerce

@@ -562,11 +557,6 @@ propagateFast a subscribers = withIncreasedDepth $ do

562557toAny :: a -> Any

563558toAny = unsafeCoerce

564559

565−-- Why do we use Any here, instead of just giving eventSubscribedRetained an

566−-- existential type? Sadly, GHC does not currently know how to unbox types

567−-- with existentially quantified fields. So instead we just coerce values

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

569−-- perfectly safe.

570560data EventSubscribed x = EventSubscribed

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

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

@@ -690,7 +680,7 @@ behaviorPull !p = Behavior $ do

690680 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"

691681 parentsRef <- liftIO $ newIORef []

692682 holdInits <- askBehaviorHoldInits

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

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

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

695685 parents <- liftIO $ readIORef parentsRef

696686 let subscribed = PullSubscribed

@@ -725,46 +715,42 @@ readBehaviorUntracked b = do

725715-- Dynamic

726716--------------------------------------------------------------------------------

727717

728−type DynamicS x p = Dynamic x (PatchTarget p) p

729−

730−data Dynamic x target p = Dynamic

731− { dynamicCurrent :: !(Behavior x target)

718+data Dynamic x p = Dynamic

719+ { dynamicCurrent :: !(Behavior x (PatchTarget p))

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

733721 }

734722

735−deriving instance (HasSpiderTimeline x) => Functor (Dynamic x target)

736−

737−

738−

739−

740−dynamicHold :: Hold x p -> DynamicS x p

723+dynamicHold :: Hold x p -> Dynamic x p

741724dynamicHold !h = Dynamic

742725 { dynamicCurrent = behaviorHold h

743726 , dynamicUpdated = eventHold h

744727 }

745728

746−dynamicHoldIdentity :: Hold x (Identity a) -> DynamicS x (Identity a)

729+dynamicHoldIdentity :: Hold x (Identity a) -> Dynamic x (Identity a)

747730dynamicHoldIdentity = dynamicHold

748731

749−dynamicConst :: PatchTarget p -> DynamicS x p

732+dynamicConst :: PatchTarget p -> Dynamic x p

750733dynamicConst !a = Dynamic

751734 { dynamicCurrent = behaviorConst a

752735 , dynamicUpdated = eventNever

753736 }

754737

755−dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> DynamicS x p

738+dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p

756739dynamicDyn !d = Dynamic

757740 { dynamicCurrent = behaviorDyn d

758741 , dynamicUpdated = eventDyn d

759742 }

760743

761−dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> DynamicS x (Identity a)

744+dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)

762745dynamicDynIdentity = dynamicDyn

763746

764747--------------------------------------------------------------------------------

765748-- Combinators

766749--------------------------------------------------------------------------------

767750

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

752+--representational so we can use coerce

753+

768754--type role Hold representational

769755data Hold x p

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

@@ -785,25 +771,20 @@ globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv

785771

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

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

788−newtype SpiderTimelineEnv x = STE {unSTE :: SpiderTimelineEnv' x}

789−-- We implement SpiderTimelineEnv with a newtype wrapper so

790−-- we can get the coercions we want safely.

791−type role SpiderTimelineEnv nominal

792−

793−data SpiderTimelineEnv' x = SpiderTimelineEnv

774+data SpiderTimelineEnv x = SpiderTimelineEnv

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

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

796777#ifdef DEBUG

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

798779#endif

799780 }

800−type role SpiderTimelineEnv' phantom

781+type role SpiderTimelineEnv nominal

801782

802783instance Eq (SpiderTimelineEnv x) where

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

804785

805786instance GEq SpiderTimelineEnv where

806− a `geq` b = if _spiderTimeline_lock (unSTE a) == _spiderTimeline_lock (unSTE b)

787+ a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b

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

808789 else Nothing

809790

@@ -826,7 +807,7 @@ runEventM :: EventM x a -> IO a

826807runEventM = unEventM

827808

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

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

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

830811

831812class MonadIO m => Defer a m where

832813 getDeferralQueue :: m (IORef [a])

@@ -964,9 +945,9 @@ getHoldEventSubscription h = do

964945

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

966947

948+--type role BehaviorM representational

967949-- BehaviorM can sample behaviors

968−newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderIO (BehaviorEnv x) a }

969− deriving (Functor, Applicative, MonadIO, MonadFix, MonadReader (BehaviorEnv x))

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

970951

971952instance Monad (BehaviorM x) where

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

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

11831164

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

11851166

1186−newMapDyn :: HasSpiderTimeline x => (a -> b) -> DynamicS x (Identity a) -> DynamicS x (Identity b)

1167+newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b)

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

11881169

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

1190−zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> DynamicS x (Identity a) -> DynamicS x (Identity b) -> DynamicS x (Identity c)

1171+zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c)

11911172zipDynWith f da db =

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

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

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

12601241run roots after = do

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

12621243 let t = spiderTimeline :: SpiderTimelineEnv x

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

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

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

12651246 occBefore <- liftIO $ do

12661247 occBefore <- readIORef occRef

@@ -1324,9 +1305,9 @@ type WeakList a = [Weak a]

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

13251306withIncreasedDepth a = do

13261307 spiderTimeline <- askSpiderTimelineEnv

1327− liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) succ

1308+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ

13281309 result <- a

1329− liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) pred

1310+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred

13301311 return result

13311312#else

13321313withIncreasedDepth :: m a -> m a

@@ -1353,7 +1334,7 @@ traceMWhen _ b getMessage = when b $ do

13531334 message <- getMessage

13541335#ifdef DEBUG

13551336 spiderTimeline <- askSpiderTimelineEnv

1356− d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE spiderTimeline

1337+ d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline

13571338#else

13581339 let d = 0

13591340#endif

@@ -1394,25 +1375,25 @@ propagateSubscriberHold h a = do

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

13951376

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

1397−runBehaviorM a mwi holdInits = runReaderIO (unBehaviorM a) (mwi, holdInits)

1378+runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits)

13981379

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

14001381askInvalidator = do

1401− (!m, _) <- ask

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

14021383 case m of

14031384 Nothing -> return Nothing

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

14051386

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

14071388askParentsRef = do

1408− (!m, _) <- ask

1389+ (!m, _) <- BehaviorM ask

14091390 case m of

14101391 Nothing -> return Nothing

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

14121393

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

14141395askBehaviorHoldInits = do

1415− (_, !his) <- ask

1396+ (_, !his) <- BehaviorM ask

14161397 return his

14171398

14181399{-# INLINE getDynHold #-}

@@ -1730,20 +1711,20 @@ subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceS

17301711{-# INLINE mergeG #-}

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

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

1733− -> DynamicS x (PatchDMap k q) -> Event x (DMap k v)

1714+ -> Dynamic x (PatchDMap k q) -> Event x (DMap k v)

17341715mergeG nt d = cacheEvent (mergeCheap nt d)

17351716

17361717{-# INLINE mergeWithMove #-}

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

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

1739− -> DynamicS x (PatchDMapWithMove k q) -> Event x (DMap k v)

1720+ -> Dynamic x (PatchDMapWithMove k q) -> Event x (DMap k v)

17401721mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)

17411722

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

17431724mergeCheap

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

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

1746− -> DynamicS x (PatchDMap k q)

1727+ -> Dynamic x (PatchDMap k q)

17471728 -> Event x (DMap k v)

17481729mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy

17491730 where

@@ -1783,7 +1764,7 @@ mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy

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

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

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

1786− -> DynamicS x (PatchDMapWithMove k q)

1767+ -> Dynamic x (PatchDMapWithMove k q)

17871768 -> Event x (DMap k v)

17881769mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy

17891770 where

@@ -1931,7 +1912,7 @@ updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m)

19311912

19321913{-# INLINE mergeGCheap' #-}

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

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

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

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

19361917 initialParents <- readBehaviorUntracked $ dynamicCurrent d

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

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

19801961 , occ

19811962 )

19821963

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

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

19841965mergeInt = cacheEvent . mergeIntCheap

19851966

19861967{-# INLINABLE mergeIntCheap #-}

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

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

19881969mergeIntCheap d = Event $ \sub -> do

19891970 initialParents <- readBehaviorUntracked $ dynamicCurrent d

19901971 accum <- liftIO $ FastMutableIntMap.newEmpty

@@ -2142,7 +2123,7 @@ clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeI

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

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

21442125runFrame a = SpiderHost $ do

2145− let env = _spiderTimeline_eventEnv $ unSTE (spiderTimeline :: SpiderTimelineEnv x)

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

21462127 let go = do

21472128 result <- a

21482129 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

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

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

23542335

23552336{-# INLINABLE newJoinDyn #-}

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

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

23572338newJoinDyn d =

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

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

@@ -2503,7 +2484,7 @@ unsafeNewSpiderTimelineEnv = do

25032484#ifdef DEBUG

25042485 depthRef <- newIORef 0

25052486#endif

2506− return $ STE $ SpiderTimelineEnv

2487+ return $ SpiderTimelineEnv

25072488 { _spiderTimeline_lock = lock

25082489 , _spiderTimeline_eventEnv = env

25092490#ifdef DEBUG

@@ -2519,13 +2500,13 @@ data LocalSpiderTimeline (x :: Type) s

25192500

25202501instance Reifies s (SpiderTimelineEnv x) =>

25212502 HasSpiderTimeline (LocalSpiderTimeline x s) where

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

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

25232504

25242505localSpiderTimeline

2525− :: proxy s

2506+ :: Proxy s

25262507 -> SpiderTimelineEnv x

25272508 -> SpiderTimelineEnv (LocalSpiderTimeline x s)

2528−localSpiderTimeline _ = coerce

2509+localSpiderTimeline _ = unsafeCoerce

25292510

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

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

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

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

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

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

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

2547− newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: DynamicS x p }

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

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

25482529 type PullM (SpiderTimeline x) = SpiderPullM x

25492530 type PushM (SpiderTimeline x) = SpiderPushM x

25502531 {-# INLINABLE never #-}

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

25732554 {-# INLINABLE current #-}

25742555 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic

25752556 {-# INLINABLE updated #-}

2576− updated = SpiderEvent #. dynamicUpdated .# fmap coerce . unSpiderDynamic

2557+ updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic

25772558 {-# INLINABLE unsafeBuildDynamic #-}

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

25792560 {-# INLINABLE unsafeBuildIncremental #-}

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

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

25932574 eventCoercion Coercion = Coercion

25942575 behaviorCoercion Coercion = Coercion

2595− dynamicCoercion Coercion = Coercion

2596− incrementalCoercion Coercion Coercion = Coercion

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

25972577 {-# INLINABLE mergeIntIncremental #-}

2598− mergeIntIncremental = SpiderEvent . mergeInt . coerce

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

25992579 {-# INLINABLE fanInt #-}

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

26012581

test/Reflex/Bench/Focused.hs−12

@@ -130,16 +130,6 @@ 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−

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

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

145135

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

318308dynamics n =

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

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

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

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

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

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

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