5e037c0 · reflex · git.iko.soy

git.iko.soy/reflex

Less unsafeCoerce (#322)

* Reduce the use of unsafeCoerce Remove most uses of `unsafeCoerce`. Most of the rest are taken care of in my `mergeG` pull request.

commit5e037c06c86023c73245b38275c9949e0fb27940 authorDavid Feuer <David.Feuer@gmail.com> dateMon 5 Aug 2019, 09:35 (7 years ago) parentc477539

7 files changed+163−53

compare with develop

unifiedsplit

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

reflex.cabal+2

@@ -56,6 +56,7 @@ library

5656 mtl >= 2.1 && < 2.3,

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

5858 primitive >= 0.5 && < 0.7,

59+ profunctors,

5960 random == 1.1.*,

6061 ref-tf == 0.4.*,

6162 reflection == 2.1.*,

@@ -71,6 +72,7 @@ library

7172 witherable >= 0.2 && < 0.4

7273

7374 exposed-modules:

75+ Control.Monad.ReaderIO

7476 Data.AppendMap,

7577 Data.FastMutableIntMap,

7678 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

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

3737 , coerceBehavior

3838 , coerceEvent

3939 , coerceDynamic

40+ , coerceIncremental

4041 , MonadSample (..)

4142 , MonadHold (..)

4243 -- ** 'fan' related types

@@ -312,6 +313,10 @@ class ( MonadHold t (PushM t)

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

313314 -- occurrence type

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

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

317+ -- patch target and patch types.

318+ incrementalCoercion

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

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

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

317322

@@ -345,6 +350,12 @@ coerceEvent = coerceWith $ eventCoercion Coercion

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

346351coerceDynamic = coerceWith $ dynamicCoercion Coercion

347352

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

354+coerceIncremental

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

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

357+coerceIncremental = coerceWith $ incrementalCoercion Coercion Coercion

358+

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

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

350361-- '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

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

133133 behaviorCoercion Coercion = Coercion

134134 eventCoercion Coercion = Coercion

135135 dynamicCoercion Coercion = Coercion

136+ incrementalCoercion Coercion Coercion = Coercion

136137

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

138139

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

@@ -18,6 +18,8 @@

1818{-# LANGUAGE TypeOperators #-}

1919{-# LANGUAGE UndecidableInstances #-}

2020{-# LANGUAGE PolyKinds #-}

21+{-# LANGUAGE DeriveFunctor #-}

22+{-# LANGUAGE StandaloneDeriving #-}

2123{-# LANGUAGE InstanceSigs #-}

2224

2325#ifdef USE_REFLEX_OPTIMIZER

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

3739import Control.Monad.Exception

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

3941import Control.Monad.Primitive

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

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

43+import Control.Monad.Reader.Class

44+import Control.Monad.IO.Class

45+import Control.Monad.ReaderIO

4146import Control.Monad.Ref

4247import Data.Align

4348import Data.Coerce

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

545550toAny :: a -> Any

546551toAny = unsafeCoerce

547552

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

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

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

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

557+-- perfectly safe.

548558data EventSubscribed x = EventSubscribed

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

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

@@ -668,7 +678,7 @@ behaviorPull !p = Behavior $ do

668678 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"

669679 parentsRef <- liftIO $ newIORef []

670680 holdInits <- askBehaviorHoldInits

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

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

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

673683 parents <- liftIO $ readIORef parentsRef

674684 let subscribed = PullSubscribed

@@ -703,42 +713,46 @@ readBehaviorUntracked b = do

703713-- Dynamic

704714--------------------------------------------------------------------------------

705715

706−data Dynamic x p = Dynamic

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

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

717+

718+data Dynamic x target p = Dynamic

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

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

709721 }

710722

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

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

724+

725+

726+

727+

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

712729dynamicHold !h = Dynamic

713730 { dynamicCurrent = behaviorHold h

714731 , dynamicUpdated = eventHold h

715732 }

716733

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

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

718735dynamicHoldIdentity = dynamicHold

719736

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

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

721738dynamicConst !a = Dynamic

722739 { dynamicCurrent = behaviorConst a

723740 , dynamicUpdated = eventNever

724741 }

725742

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

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

727744dynamicDyn !d = Dynamic

728745 { dynamicCurrent = behaviorDyn d

729746 , dynamicUpdated = eventDyn d

730747 }

731748

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

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

733750dynamicDynIdentity = dynamicDyn

734751

735752--------------------------------------------------------------------------------

736753-- Combinators

737754--------------------------------------------------------------------------------

738755

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

740−--representational so we can use coerce

741−

742756--type role Hold representational

743757data Hold x p

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

@@ -759,20 +773,25 @@ globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv

759773

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

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

762−data SpiderTimelineEnv x = SpiderTimelineEnv

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

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

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

779+type role SpiderTimelineEnv nominal

780+

781+data SpiderTimelineEnv' x = SpiderTimelineEnv

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

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

765784#ifdef DEBUG

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

767786#endif

768787 }

769−type role SpiderTimelineEnv nominal

788+type role SpiderTimelineEnv' phantom

770789

771790instance Eq (SpiderTimelineEnv x) where

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

773792

774793instance GEq SpiderTimelineEnv where

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

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

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

777796 else Nothing

778797

@@ -795,7 +814,7 @@ runEventM :: EventM x a -> IO a

795814runEventM = unEventM

796815

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

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

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

799818

800819class MonadIO m => Defer a m where

801820 getDeferralQueue :: m (IORef [a])

@@ -933,9 +952,9 @@ getHoldEventSubscription h = do

933952

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

935954

936−--type role BehaviorM representational

937955-- BehaviorM can sample behaviors

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

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

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

939958

940959instance Monad (BehaviorM x) where

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

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

11451164

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

11471166

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

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

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

11501169

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

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

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

11531172zipDynWith f da db =

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

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

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

12251244run roots after = do

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

12271246 let t = spiderTimeline :: SpiderTimelineEnv x

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

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

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

12301249 occBefore <- liftIO $ do

12311250 occBefore <- readIORef occRef

@@ -1289,9 +1308,9 @@ type WeakList a = [Weak a]

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

12901309withIncreasedDepth a = do

12911310 spiderTimeline <- askSpiderTimelineEnv

1292− liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ

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

12931312 result <- a

1294− liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred

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

12951314 return result

12961315#else

12971316withIncreasedDepth :: m a -> m a

@@ -1318,7 +1337,7 @@ traceMWhen _ b getMessage = when b $ do

13181337 message <- getMessage

13191338#ifdef DEBUG

13201339 spiderTimeline <- askSpiderTimelineEnv

1321− d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline

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

13221341#else

13231342 let d = 0

13241343#endif

@@ -1359,25 +1378,25 @@ propagateSubscriberHold h a = do

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

13601379

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

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

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

13631382

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

13651384askInvalidator = do

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

1385+ (!m, _) <- ask

13671386 case m of

13681387 Nothing -> return Nothing

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

13701389

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

13721391askParentsRef = do

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

1392+ (!m, _) <- ask

13741393 case m of

13751394 Nothing -> return Nothing

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

13771396

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

13791398askBehaviorHoldInits = do

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

1399+ (_, !his) <- ask

13811400 return his

13821401

13831402{-# INLINE getDynHold #-}

@@ -1701,20 +1720,20 @@ subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceS

17011720{-# INLINE mergeG #-}

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

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

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

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

17051724mergeG nt d = cacheEvent (mergeCheap nt d)

17061725

17071726{-# INLINE mergeWithMove #-}

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

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

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

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

17111730mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)

17121731

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

17141733mergeCheap

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

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

1717− -> Dynamic x (PatchDMap k q)

1736+ -> DynamicS x (PatchDMap k q)

17181737 -> Event x (DMap k v)

17191738mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy

17201739 where

@@ -1754,7 +1773,7 @@ mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy

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

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

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

1757− -> Dynamic x (PatchDMapWithMove k q)

1776+ -> DynamicS x (PatchDMapWithMove k q)

17581777 -> Event x (DMap k v)

17591778mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy

17601779 where

@@ -1902,7 +1921,7 @@ updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m)

19021921

19031922{-# INLINE mergeGCheap' #-}

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

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

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

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

19071926 initialParents <- readBehaviorUntracked $ dynamicCurrent d

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

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

19511970 , occ

19521971 )

19531972

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

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

19551974mergeInt = cacheEvent . mergeIntCheap

19561975

19571976{-# INLINABLE mergeIntCheap #-}

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

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

19591978mergeIntCheap d = Event $ \sub -> do

19601979 initialParents <- readBehaviorUntracked $ dynamicCurrent d

19611980 accum <- liftIO $ FastMutableIntMap.newEmpty

@@ -2115,7 +2134,7 @@ clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeI

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

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

21172136runFrame a = SpiderHost $ do

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

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

21192138 let go = do

21202139 result <- a

21212140 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

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

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

23272346

23282347{-# INLINABLE newJoinDyn #-}

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

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

23302349newJoinDyn d =

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

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

@@ -2476,7 +2495,7 @@ unsafeNewSpiderTimelineEnv = do

24762495#ifdef DEBUG

24772496 depthRef <- newIORef 0

24782497#endif

2479− return $ SpiderTimelineEnv

2498+ return $ STE $ SpiderTimelineEnv

24802499 { _spiderTimeline_lock = lock

24812500 , _spiderTimeline_eventEnv = env

24822501#ifdef DEBUG

@@ -2492,13 +2511,13 @@ data LocalSpiderTimeline (x :: Type) s

24922511

24932512instance Reifies s (SpiderTimelineEnv x) =>

24942513 HasSpiderTimeline (LocalSpiderTimeline x s) where

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

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

24962515

24972516localSpiderTimeline

2498− :: Proxy s

2517+ :: proxy s

24992518 -> SpiderTimelineEnv x

25002519 -> SpiderTimelineEnv (LocalSpiderTimeline x s)

2501−localSpiderTimeline _ = unsafeCoerce

2520+localSpiderTimeline _ = coerce

25022521

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

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

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

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

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

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

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

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

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

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

25212540 type PullM (SpiderTimeline x) = SpiderPullM x

25222541 type PushM (SpiderTimeline x) = SpiderPushM x

25232542 {-# INLINABLE never #-}

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

25462565 {-# INLINABLE current #-}

25472566 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic

25482567 {-# INLINABLE updated #-}

2549− updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic

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

25502569 {-# INLINABLE unsafeBuildDynamic #-}

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

25522571 {-# INLINABLE unsafeBuildIncremental #-}

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

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

25662585 eventCoercion Coercion = Coercion

25672586 behaviorCoercion Coercion = Coercion

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

2587+ dynamicCoercion Coercion = Coercion

2588+ incrementalCoercion Coercion Coercion = Coercion

25692589 {-# INLINABLE mergeIntIncremental #-}

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

2590+ mergeIntIncremental = SpiderEvent . mergeInt . coerce

25712591 {-# INLINABLE fanInt #-}

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

25732593

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