git.iko.soy/patch
on develop help sign in
Less unsafeCoerce (#322)
5e037c0David Feuer
reflex.cabal+2
compare with develop
unifiedsplit
@@ -56,6 +56,7 @@ library
56 mtl >= 2.1 && < 2.3,
56 mtl >= 2.1 && < 2.3,
57 prim-uniq >= 0.1.0.1 && < 0.2,
57 prim-uniq >= 0.1.0.1 && < 0.2,
58 primitive >= 0.5 && < 0.7,
58 primitive >= 0.5 && < 0.7,
59+ profunctors,
59 random == 1.1.*,
60 random == 1.1.*,
60 ref-tf == 0.4.*,
61 ref-tf == 0.4.*,
61 reflection == 2.1.*,
62 reflection == 2.1.*,
@@ -71,6 +72,7 @@ library
71 witherable >= 0.2 && < 0.4
72 witherable >= 0.2 && < 0.4
72
73
73 exposed-modules:
74 exposed-modules:
75+ Control.Monad.ReaderIO
74 Data.AppendMap,
76 Data.AppendMap,
75 Data.FastMutableIntMap,
77 Data.FastMutableIntMap,
76 Data.FastWeakBag,
78 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
37 , coerceBehavior
37 , coerceBehavior
38 , coerceEvent
38 , coerceEvent
39 , coerceDynamic
39 , coerceDynamic
40+ , coerceIncremental
40 , MonadSample (..)
41 , MonadSample (..)
41 , MonadHold (..)
42 , MonadHold (..)
42 -- ** 'fan' related types
43 -- ** 'fan' related types
@@ -312,6 +313,10 @@ class ( MonadHold t (PushM t)
312 -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its
313 -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its
313 -- occurrence type
314 -- occurrence type
314 dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)
315 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)
315 mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)
320 mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)
316 fanInt :: Event t (IntMap a) -> EventSelectorInt t a
321 fanInt :: Event t (IntMap a) -> EventSelectorInt t a
317
322
@@ -345,6 +350,12 @@ coerceEvent = coerceWith $ eventCoercion Coercion
345coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b
350coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b
346coerceDynamic = coerceWith $ dynamicCoercion Coercion
351coerceDynamic = coerceWith $ dynamicCoercion Coercion
347
352
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+
348-- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior'
359-- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior'
349-- __must__ change when and only when the 'Event' fires, such that the
360-- __must__ change when and only when the 'Event' fires, such that the
350-- 'Behavior''s value is always equal to the most recent firing of the 'Event';
361-- '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 #-}
9{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE UndecidableInstances #-}
10{-# LANGUAGE UndecidableInstances #-}
11{-# LANGUAGE PolyKinds #-}
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
@@ -133,6 +133,7 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where
133 behaviorCoercion Coercion = Coercion
133 behaviorCoercion Coercion = Coercion
134 eventCoercion Coercion = Coercion
134 eventCoercion Coercion = Coercion
135 dynamicCoercion Coercion = Coercion
135 dynamicCoercion Coercion = Coercion
136+ incrementalCoercion Coercion Coercion = Coercion
136
137
137 fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k
138 fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k
138
139
src/Reflex/Spider/Internal.hs+66−46
@@ -18,6 +18,8 @@
18{-# LANGUAGE TypeOperators #-}
18{-# LANGUAGE TypeOperators #-}
19{-# LANGUAGE UndecidableInstances #-}
19{-# LANGUAGE UndecidableInstances #-}
20{-# LANGUAGE PolyKinds #-}
20{-# LANGUAGE PolyKinds #-}
21+{-# LANGUAGE DeriveFunctor #-}
22+{-# LANGUAGE StandaloneDeriving #-}
21{-# LANGUAGE InstanceSigs #-}
23{-# LANGUAGE InstanceSigs #-}
22
24
23#ifdef USE_REFLEX_OPTIMIZER
25#ifdef USE_REFLEX_OPTIMIZER
@@ -37,7 +39,10 @@ import Control.Monad hiding (forM, forM_, mapM, mapM_)
37import Control.Monad.Exception
39import Control.Monad.Exception
38import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)
40import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)
39import Control.Monad.Primitive
41import 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
41import Control.Monad.Ref
46import Control.Monad.Ref
42import Data.Align
47import Data.Align
43import Data.Coerce
48import Data.Coerce
@@ -545,6 +550,11 @@ propagateFast a subscribers = withIncreasedDepth $ do
545toAny :: a -> Any
550toAny :: a -> Any
546toAny = unsafeCoerce
551toAny = unsafeCoerce
547
552
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.
548data EventSubscribed x = EventSubscribed
558data EventSubscribed x = EventSubscribed
549 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
559 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
550 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
560 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
@@ -668,7 +678,7 @@ behaviorPull !p = Behavior $ do
668 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
678 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
669 parentsRef <- liftIO $ newIORef []
679 parentsRef <- liftIO $ newIORef []
670 holdInits <- askBehaviorHoldInits
680 holdInits <- askBehaviorHoldInits
671− a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
681+ a <- liftIO $ runReaderIO (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
672 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
682 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
673 parents <- liftIO $ readIORef parentsRef
683 parents <- liftIO $ readIORef parentsRef
674 let subscribed = PullSubscribed
684 let subscribed = PullSubscribed
@@ -703,42 +713,46 @@ readBehaviorUntracked b = do
703-- Dynamic
713-- Dynamic
704--------------------------------------------------------------------------------
714--------------------------------------------------------------------------------
705
715
716+type DynamicS x p = Dynamic x (PatchTarget p) p
717+
706−data Dynamic x p = Dynamic
718+data Dynamic x target p = Dynamic
707− { dynamicCurrent :: !(Behavior x (PatchTarget p))
719+ { dynamicCurrent :: !(Behavior x target)
708 , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`?
720 , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`?
709 }
721 }
710
722
723+deriving instance (HasSpiderTimeline x) => Functor (Dynamic x target)
724+
725+
726+
727+
711−dynamicHold :: Hold x p -> Dynamic x p
728+dynamicHold :: Hold x p -> DynamicS x p
712dynamicHold !h = Dynamic
729dynamicHold !h = Dynamic
713 { dynamicCurrent = behaviorHold h
730 { dynamicCurrent = behaviorHold h
714 , dynamicUpdated = eventHold h
731 , dynamicUpdated = eventHold h
715 }
732 }
716
733
717−dynamicHoldIdentity :: Hold x (Identity a) -> Dynamic x (Identity a)
734+dynamicHoldIdentity :: Hold x (Identity a) -> DynamicS x (Identity a)
718dynamicHoldIdentity = dynamicHold
735dynamicHoldIdentity = dynamicHold
719
736
720−dynamicConst :: PatchTarget p -> Dynamic x p
737+dynamicConst :: PatchTarget p -> DynamicS x p
721dynamicConst !a = Dynamic
738dynamicConst !a = Dynamic
722 { dynamicCurrent = behaviorConst a
739 { dynamicCurrent = behaviorConst a
723 , dynamicUpdated = eventNever
740 , dynamicUpdated = eventNever
724 }
741 }
725
742
726−dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p
743+dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> DynamicS x p
727dynamicDyn !d = Dynamic
744dynamicDyn !d = Dynamic
728 { dynamicCurrent = behaviorDyn d
745 { dynamicCurrent = behaviorDyn d
729 , dynamicUpdated = eventDyn d
746 , dynamicUpdated = eventDyn d
730 }
747 }
731
748
732−dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)
749+dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> DynamicS x (Identity a)
733dynamicDynIdentity = dynamicDyn
750dynamicDynIdentity = dynamicDyn
734
751
735--------------------------------------------------------------------------------
752--------------------------------------------------------------------------------
736-- Combinators
753-- Combinators
737--------------------------------------------------------------------------------
754--------------------------------------------------------------------------------
738
755
739−--TODO: Figure out why certain things are not 'representational', then make them
740−--representational so we can use coerce
741−
742--type role Hold representational
756--type role Hold representational
743data Hold x p
757data Hold x p
744 = Hold { holdValue :: !(IORef (PatchTarget p))
758 = Hold { holdValue :: !(IORef (PatchTarget p))
@@ -759,20 +773,25 @@ globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv
759
773
760-- | Stores all global data relevant to a particular Spider timeline; only one
774-- | Stores all global data relevant to a particular Spider timeline; only one
761-- value should exist for each type @x@
775-- value should exist for each type @x@
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+
762−data SpiderTimelineEnv x = SpiderTimelineEnv
781+data SpiderTimelineEnv' x = SpiderTimelineEnv
763 { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
782 { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
764 , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
783 , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
765#ifdef DEBUG
784#ifdef DEBUG
766 , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
785 , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
767#endif
786#endif
768 }
787 }
769−type role SpiderTimelineEnv nominal
788+type role SpiderTimelineEnv' phantom
770
789
771instance Eq (SpiderTimelineEnv x) where
790instance Eq (SpiderTimelineEnv x) where
772 _ == _ = True -- Since only one exists of each type
791 _ == _ = True -- Since only one exists of each type
773
792
774instance GEq SpiderTimelineEnv where
793instance 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)
776 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
795 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
777 else Nothing
796 else Nothing
778
797
@@ -795,7 +814,7 @@ runEventM :: EventM x a -> IO a
795runEventM = unEventM
814runEventM = unEventM
796
815
797asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
816asksEventEnv :: 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))
799
818
800class MonadIO m => Defer a m where
819class MonadIO m => Defer a m where
801 getDeferralQueue :: m (IORef [a])
820 getDeferralQueue :: m (IORef [a])
@@ -933,9 +952,9 @@ getHoldEventSubscription h = do
933
952
934type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
953type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
935
954
936−--type role BehaviorM representational
937-- BehaviorM can sample behaviors
955-- 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))
939
958
940instance Monad (BehaviorM x) where
959instance Monad (BehaviorM x) where
941 {-# INLINE (>>=) #-}
960 {-# INLINE (>>=) #-}
@@ -1145,11 +1164,11 @@ data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)
1145
1164
1146newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }
1165newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }
1147
1166
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)
1149newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
1168newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d)
1150
1169
1151--TODO: Avoid the duplication between this and R.zipDynWith
1170--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)
1153zipDynWith f da db =
1172zipDynWith f da db =
1154 let eab = align (dynamicUpdated da) (dynamicUpdated db)
1173 let eab = align (dynamicUpdated da) (dynamicUpdated db)
1155 ec = flip push eab $ \o -> do
1174 ec = flip push eab $ \o -> do
@@ -1225,7 +1244,7 @@ run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> Res
1225run roots after = do
1244run roots after = do
1226 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
1245 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
1227 let t = spiderTimeline :: SpiderTimelineEnv x
1246 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
1229 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
1248 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
1230 occBefore <- liftIO $ do
1249 occBefore <- liftIO $ do
1231 occBefore <- readIORef occRef
1250 occBefore <- readIORef occRef
@@ -1289,9 +1308,9 @@ type WeakList a = [Weak a]
1289withIncreasedDepth :: CanTrace x m => m a -> m a
1308withIncreasedDepth :: CanTrace x m => m a -> m a
1290withIncreasedDepth a = do
1309withIncreasedDepth a = do
1291 spiderTimeline <- askSpiderTimelineEnv
1310 spiderTimeline <- askSpiderTimelineEnv
1292− liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ
1311+ liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) succ
1293 result <- a
1312 result <- a
1294− liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred
1313+ liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) pred
1295 return result
1314 return result
1296#else
1315#else
1297withIncreasedDepth :: m a -> m a
1316withIncreasedDepth :: m a -> m a
@@ -1318,7 +1337,7 @@ traceMWhen _ b getMessage = when b $ do
1318 message <- getMessage
1337 message <- getMessage
1319#ifdef DEBUG
1338#ifdef DEBUG
1320 spiderTimeline <- askSpiderTimelineEnv
1339 spiderTimeline <- askSpiderTimelineEnv
1321− d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline
1340+ d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE spiderTimeline
1322#else
1341#else
1323 let d = 0
1342 let d = 0
1324#endif
1343#endif
@@ -1359,25 +1378,25 @@ propagateSubscriberHold h a = do
1359data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1378data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1360
1379
1361runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a
1380runBehaviorM :: 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)
1363
1382
1364askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
1383askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
1365askInvalidator = do
1384askInvalidator = do
1366− (!m, _) <- BehaviorM ask
1385+ (!m, _) <- ask
1367 case m of
1386 case m of
1368 Nothing -> return Nothing
1387 Nothing -> return Nothing
1369 Just (!wi, _) -> return $ Just wi
1388 Just (!wi, _) -> return $ Just wi
1370
1389
1371askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
1390askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
1372askParentsRef = do
1391askParentsRef = do
1373− (!m, _) <- BehaviorM ask
1392+ (!m, _) <- ask
1374 case m of
1393 case m of
1375 Nothing -> return Nothing
1394 Nothing -> return Nothing
1376 Just (_, !p) -> return $ Just p
1395 Just (_, !p) -> return $ Just p
1377
1396
1378askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
1397askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
1379askBehaviorHoldInits = do
1398askBehaviorHoldInits = do
1380− (_, !his) <- BehaviorM ask
1399+ (_, !his) <- ask
1381 return his
1400 return his
1382
1401
1383{-# INLINE getDynHold #-}
1402{-# INLINE getDynHold #-}
@@ -1701,20 +1720,20 @@ subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceS
1701{-# INLINE mergeG #-}
1720{-# INLINE mergeG #-}
1702mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)
1721mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)
1703 => (forall a. q a -> Event x (v a))
1722 => (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)
1705mergeG nt d = cacheEvent (mergeCheap nt d)
1724mergeG nt d = cacheEvent (mergeCheap nt d)
1706
1725
1707{-# INLINE mergeWithMove #-}
1726{-# INLINE mergeWithMove #-}
1708mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)
1727mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)
1709 => (forall a. q a -> Event x (v a))
1728 => (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)
1711mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)
1730mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)
1712
1731
1713{-# INLINE [1] mergeCheap #-}
1732{-# INLINE [1] mergeCheap #-}
1714mergeCheap
1733mergeCheap
1715 :: forall k x q v. (HasSpiderTimeline x, GCompare k)
1734 :: forall k x q v. (HasSpiderTimeline x, GCompare k)
1716 => (forall a. q a -> Event x (v a))
1735 => (forall a. q a -> Event x (v a))
1717− -> Dynamic x (PatchDMap k q)
1736+ -> DynamicS x (PatchDMap k q)
1718 -> Event x (DMap k v)
1737 -> Event x (DMap k v)
1719mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy
1738mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy
1720 where
1739 where
@@ -1754,7 +1773,7 @@ mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy
1754{-# INLINE [1] mergeCheapWithMove #-}
1773{-# INLINE [1] mergeCheapWithMove #-}
1755mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)
1774mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)
1756 => (forall a. q a -> Event x (v a))
1775 => (forall a. q a -> Event x (v a))
1757− -> Dynamic x (PatchDMapWithMove k q)
1776+ -> DynamicS x (PatchDMapWithMove k q)
1758 -> Event x (DMap k v)
1777 -> Event x (DMap k v)
1759mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy
1778mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy
1760 where
1779 where
@@ -1902,7 +1921,7 @@ updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m)
1902
1921
1903{-# INLINE mergeGCheap' #-}
1922{-# INLINE mergeGCheap' #-}
1904mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)
1923mergeGCheap' :: 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)
1906mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1925mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1907 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1926 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1908 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
1927 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
@@ -1951,11 +1970,11 @@ mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1951 , occ
1970 , occ
1952 )
1971 )
1953
1972
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)
1955mergeInt = cacheEvent . mergeIntCheap
1974mergeInt = cacheEvent . mergeIntCheap
1956
1975
1957{-# INLINABLE mergeIntCheap #-}
1976{-# 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)
1959mergeIntCheap d = Event $ \sub -> do
1978mergeIntCheap d = Event $ \sub -> do
1960 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1979 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1961 accum <- liftIO $ FastMutableIntMap.newEmpty
1980 accum <- liftIO $ FastMutableIntMap.newEmpty
@@ -2115,7 +2134,7 @@ clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeI
2115-- | Run an event action outside of a frame
2134-- | Run an event action outside of a frame
2116runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
2135runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
2117runFrame a = SpiderHost $ do
2136runFrame a = SpiderHost $ do
2118− let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
2137+ let env = _spiderTimeline_eventEnv $ unSTE (spiderTimeline :: SpiderTimelineEnv x)
2119 let go = do
2138 let go = do
2120 result <- a
2139 result <- a
2121 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
2140 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))
2326 fail _ = error "Dynamic does not support 'fail'"
2345 fail _ = error "Dynamic does not support 'fail'"
2327
2346
2328{-# INLINABLE newJoinDyn #-}
2347{-# 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)
2330newJoinDyn d =
2349newJoinDyn d =
2331 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)
2350 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)
2332 eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d
2351 eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d
@@ -2476,7 +2495,7 @@ unsafeNewSpiderTimelineEnv = do
2476#ifdef DEBUG
2495#ifdef DEBUG
2477 depthRef <- newIORef 0
2496 depthRef <- newIORef 0
2478#endif
2497#endif
2479− return $ SpiderTimelineEnv
2498+ return $ STE $ SpiderTimelineEnv
2480 { _spiderTimeline_lock = lock
2499 { _spiderTimeline_lock = lock
2481 , _spiderTimeline_eventEnv = env
2500 , _spiderTimeline_eventEnv = env
2482#ifdef DEBUG
2501#ifdef DEBUG
@@ -2492,13 +2511,13 @@ data LocalSpiderTimeline (x :: Type) s
2492
2511
2493instance Reifies s (SpiderTimelineEnv x) =>
2512instance Reifies s (SpiderTimelineEnv x) =>
2494 HasSpiderTimeline (LocalSpiderTimeline x s) where
2513 HasSpiderTimeline (LocalSpiderTimeline x s) where
2495− spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s)
2514+ spiderTimeline = localSpiderTimeline Proxy $ reflect (Proxy :: Proxy s)
2496
2515
2497localSpiderTimeline
2516localSpiderTimeline
2498− :: Proxy s
2517+ :: proxy s
2499 -> SpiderTimelineEnv x
2518 -> SpiderTimelineEnv x
2500 -> SpiderTimelineEnv (LocalSpiderTimeline x s)
2519 -> SpiderTimelineEnv (LocalSpiderTimeline x s)
2501−localSpiderTimeline _ = unsafeCoerce
2520+localSpiderTimeline _ = coerce
2502
2521
2503-- | Pass a new timeline to the given function.
2522-- | Pass a new timeline to the given function.
2504withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r
2523withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r
@@ -2516,8 +2535,8 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2516 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
2535 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
2517 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
2536 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
2518 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
2537 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)
2538+ newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: DynamicS x (Identity a) } -- deriving (Functor, Applicative, Monad)
2520− newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }
2539+ newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: DynamicS x p }
2521 type PullM (SpiderTimeline x) = SpiderPullM x
2540 type PullM (SpiderTimeline x) = SpiderPullM x
2522 type PushM (SpiderTimeline x) = SpiderPushM x
2541 type PushM (SpiderTimeline x) = SpiderPushM x
2523 {-# INLINABLE never #-}
2542 {-# INLINABLE never #-}
@@ -2546,7 +2565,7 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2546 {-# INLINABLE current #-}
2565 {-# INLINABLE current #-}
2547 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
2566 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
2548 {-# INLINABLE updated #-}
2567 {-# INLINABLE updated #-}
2549− updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic
2568+ updated = SpiderEvent #. dynamicUpdated .# fmap coerce . unSpiderDynamic
2550 {-# INLINABLE unsafeBuildDynamic #-}
2569 {-# INLINABLE unsafeBuildDynamic #-}
2551 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
2570 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
2552 {-# INLINABLE unsafeBuildIncremental #-}
2571 {-# INLINABLE unsafeBuildIncremental #-}
@@ -2565,9 +2584,10 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2565 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
2584 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
2566 eventCoercion Coercion = Coercion
2585 eventCoercion Coercion = Coercion
2567 behaviorCoercion Coercion = Coercion
2586 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
2569 {-# INLINABLE mergeIntIncremental #-}
2589 {-# 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
2571 {-# INLINABLE fanInt #-}
2591 {-# INLINABLE fanInt #-}
2572 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))
2592 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))
2573
2593
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)
130joinDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
131joinDynChain = iterM (\d -> return $ join $ fmap (const d) d)
131joinDynChain = iterM (\d -> return $ join $ fmap (const d) d)
132
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