git.iko.soy/reflex
on develop help sign in
Revert "Less unsafeCoerce (#322)"
b3ad64aMatthew Bauer
reflex.cabal−1
compare with develop
unifiedsplit
@@ -85,7 +85,6 @@ library
85 monoidal-containers == 0.4.0.0
85 monoidal-containers == 0.4.0.0
86
86
87 exposed-modules:
87 exposed-modules:
88− Control.Monad.ReaderIO
89 Data.AppendMap,
88 Data.AppendMap,
90 Data.FastMutableIntMap,
89 Data.FastMutableIntMap,
91 Data.FastWeakBag,
90 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
36 , coerceBehavior
36 , coerceBehavior
37 , coerceEvent
37 , coerceEvent
38 , coerceDynamic
38 , coerceDynamic
39− , coerceIncremental
40 , MonadSample (..)
39 , MonadSample (..)
41 , MonadHold (..)
40 , MonadHold (..)
42 -- ** 'fan' related types
41 -- ** 'fan' related types
@@ -317,10 +316,6 @@ class ( MonadHold t (PushM t)
317 -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its
316 -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its
318 -- occurrence type
317 -- occurrence type
319 dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b)
318 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)
324 mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)
319 mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)
325 fanInt :: Event t (IntMap a) -> EventSelectorInt t a
320 fanInt :: Event t (IntMap a) -> EventSelectorInt t a
326
321
@@ -342,12 +337,6 @@ coerceEvent = coerceWith $ eventCoercion Coercion
342coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b
337coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b
343coerceDynamic = coerceWith $ dynamicCoercion Coercion
338coerceDynamic = coerceWith $ dynamicCoercion Coercion
344
339
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−
351-- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior'
340-- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior'
352-- __must__ change when and only when the 'Event' fires, such that the
341-- __must__ change when and only when the 'Event' fires, such that the
353-- 'Behavior''s value is always equal to the most recent firing of the 'Event';
342-- 'Behavior''s value is always equal to the most recent firing of the 'Event';
src/Reflex/Profiled.hs+7−11
@@ -9,7 +9,6 @@
9{-# LANGUAGE TypeFamilies #-}
9{-# LANGUAGE TypeFamilies #-}
10{-# LANGUAGE UndecidableInstances #-}
10{-# LANGUAGE UndecidableInstances #-}
11{-# LANGUAGE PolyKinds #-}
11{-# LANGUAGE PolyKinds #-}
12−{-# LANGUAGE TypeApplications #-}
13{-# LANGUAGE RankNTypes #-}
12{-# LANGUAGE RankNTypes #-}
14-- |
13-- |
15-- Module:
14-- Module:
@@ -152,16 +151,13 @@ instance Reflex t => Reflex (ProfiledTimeline t) where
152 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i
151 currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i
153 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i
152 updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i
154 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i
153 incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i
155− behaviorCoercion c =
154+ behaviorCoercion (c :: Coercion a b) = case behaviorCoercion c :: Coercion (Behavior t a) (Behavior t b) of
156− Coercion `trans` behaviorCoercion @t c `trans` Coercion
155+ Coercion -> unsafeCoerce (Coercion :: Coercion (Behavior (ProfiledTimeline t) a) (Behavior (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
157− eventCoercion c =
156+ eventCoercion (c :: Coercion a b) = case eventCoercion c :: Coercion (Event t a) (Event t b) of
158− Coercion `trans` eventCoercion @t c `trans` Coercion
157+ Coercion -> unsafeCoerce (Coercion :: Coercion (Event (ProfiledTimeline t) a) (Event (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce
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
163− mergeIntIncremental = Event_Profiled . mergeIntIncremental .
160+ mergeIntIncremental = Event_Profiled . mergeIntIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchIntMap (Event (ProfiledTimeline t) a)) -> Incremental t (PatchIntMap (Event t a)))
164− coerceWith (Coercion `trans` incrementalCoercion Coercion Coercion `trans` Coercion)
165 fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e
161 fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e
166
162
167deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t))
163deriving 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
128 behaviorCoercion Coercion = Coercion
128 behaviorCoercion Coercion = Coercion
129 eventCoercion Coercion = Coercion
129 eventCoercion Coercion = Coercion
130 dynamicCoercion Coercion = Coercion
130 dynamicCoercion Coercion = Coercion
131− incrementalCoercion Coercion Coercion = Coercion
132
131
133 fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k
132 fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k
134
133
src/Reflex/Spider/Internal.hs+46−66
@@ -17,8 +17,6 @@
17{-# LANGUAGE TypeOperators #-}
17{-# LANGUAGE TypeOperators #-}
18{-# LANGUAGE UndecidableInstances #-}
18{-# LANGUAGE UndecidableInstances #-}
19{-# LANGUAGE PolyKinds #-}
19{-# LANGUAGE PolyKinds #-}
20−{-# LANGUAGE DeriveFunctor #-}
21−{-# LANGUAGE StandaloneDeriving #-}
22{-# LANGUAGE InstanceSigs #-}
20{-# LANGUAGE InstanceSigs #-}
23#ifdef USE_REFLEX_OPTIMIZER
21#ifdef USE_REFLEX_OPTIMIZER
24{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
22{-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
@@ -37,10 +35,7 @@ import Control.Monad hiding (forM, forM_, mapM, mapM_)
37import Control.Monad.Exception
35import Control.Monad.Exception
38import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)
36import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_)
39import Control.Monad.Primitive
37import Control.Monad.Primitive
40−--import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_)
38+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
44import Control.Monad.Ref
39import Control.Monad.Ref
45import Data.Align
40import Data.Align
46import Data.Coerce
41import Data.Coerce
@@ -562,11 +557,6 @@ propagateFast a subscribers = withIncreasedDepth $ do
562toAny :: a -> Any
557toAny :: a -> Any
563toAny = unsafeCoerce
558toAny = unsafeCoerce
564
559
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.
570data EventSubscribed x = EventSubscribed
560data EventSubscribed x = EventSubscribed
571 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
561 { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height)
572 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
562 , eventSubscribedRetained :: {-# NOUNPACK #-} !Any
@@ -690,7 +680,7 @@ behaviorPull !p = Behavior $ do
690 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
680 wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull"
691 parentsRef <- liftIO $ newIORef []
681 parentsRef <- liftIO $ newIORef []
692 holdInits <- askBehaviorHoldInits
682 holdInits <- askBehaviorHoldInits
693− a <- liftIO $ runReaderIO (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
683+ a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits)
694 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
684 invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator
695 parents <- liftIO $ readIORef parentsRef
685 parents <- liftIO $ readIORef parentsRef
696 let subscribed = PullSubscribed
686 let subscribed = PullSubscribed
@@ -725,46 +715,42 @@ readBehaviorUntracked b = do
725-- Dynamic
715-- Dynamic
726--------------------------------------------------------------------------------
716--------------------------------------------------------------------------------
727
717
728−type DynamicS x p = Dynamic x (PatchTarget p) p
729−
730−data Dynamic x target p = Dynamic
718+data Dynamic x p = Dynamic
731− { dynamicCurrent :: !(Behavior x target)
719+ { dynamicCurrent :: !(Behavior x (PatchTarget p))
732 , 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`?
733 }
721 }
734
722
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
741dynamicHold !h = Dynamic
724dynamicHold !h = Dynamic
742 { dynamicCurrent = behaviorHold h
725 { dynamicCurrent = behaviorHold h
743 , dynamicUpdated = eventHold h
726 , dynamicUpdated = eventHold h
744 }
727 }
745
728
746−dynamicHoldIdentity :: Hold x (Identity a) -> DynamicS x (Identity a)
729+dynamicHoldIdentity :: Hold x (Identity a) -> Dynamic x (Identity a)
747dynamicHoldIdentity = dynamicHold
730dynamicHoldIdentity = dynamicHold
748
731
749−dynamicConst :: PatchTarget p -> DynamicS x p
732+dynamicConst :: PatchTarget p -> Dynamic x p
750dynamicConst !a = Dynamic
733dynamicConst !a = Dynamic
751 { dynamicCurrent = behaviorConst a
734 { dynamicCurrent = behaviorConst a
752 , dynamicUpdated = eventNever
735 , dynamicUpdated = eventNever
753 }
736 }
754
737
755−dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> DynamicS x p
738+dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p
756dynamicDyn !d = Dynamic
739dynamicDyn !d = Dynamic
757 { dynamicCurrent = behaviorDyn d
740 { dynamicCurrent = behaviorDyn d
758 , dynamicUpdated = eventDyn d
741 , dynamicUpdated = eventDyn d
759 }
742 }
760
743
761−dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> DynamicS x (Identity a)
744+dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a)
762dynamicDynIdentity = dynamicDyn
745dynamicDynIdentity = dynamicDyn
763
746
764--------------------------------------------------------------------------------
747--------------------------------------------------------------------------------
765-- Combinators
748-- Combinators
766--------------------------------------------------------------------------------
749--------------------------------------------------------------------------------
767
750
751+--TODO: Figure out why certain things are not 'representational', then make them
752+--representational so we can use coerce
753+
768--type role Hold representational
754--type role Hold representational
769data Hold x p
755data Hold x p
770 = Hold { holdValue :: !(IORef (PatchTarget p))
756 = Hold { holdValue :: !(IORef (PatchTarget p))
@@ -785,25 +771,20 @@ globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv
785
771
786-- | Stores all global data relevant to a particular Spider timeline; only one
772-- | Stores all global data relevant to a particular Spider timeline; only one
787-- value should exist for each type @x@
773-- 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
794 { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
775 { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ())
795 , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
776 , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x)
796#ifdef DEBUG
777#ifdef DEBUG
797 , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
778 , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int)
798#endif
779#endif
799 }
780 }
800−type role SpiderTimelineEnv' phantom
781+type role SpiderTimelineEnv nominal
801
782
802instance Eq (SpiderTimelineEnv x) where
783instance Eq (SpiderTimelineEnv x) where
803 _ == _ = True -- Since only one exists of each type
784 _ == _ = True -- Since only one exists of each type
804
785
805instance GEq SpiderTimelineEnv where
786instance 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
807 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
788 then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments
808 else Nothing
789 else Nothing
809
790
@@ -826,7 +807,7 @@ runEventM :: EventM x a -> IO a
826runEventM = unEventM
807runEventM = unEventM
827
808
828asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a
809asksEventEnv :: 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)
830
811
831class MonadIO m => Defer a m where
812class MonadIO m => Defer a m where
832 getDeferralQueue :: m (IORef [a])
813 getDeferralQueue :: m (IORef [a])
@@ -964,9 +945,9 @@ getHoldEventSubscription h = do
964
945
965type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
946type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x])
966
947
948+--type role BehaviorM representational
967-- BehaviorM can sample behaviors
949-- BehaviorM can sample behaviors
968−newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderIO (BehaviorEnv x) a }
950+newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderT (BehaviorEnv x) IO a } deriving (Functor, Applicative, MonadIO, MonadFix)
969− deriving (Functor, Applicative, MonadIO, MonadFix, MonadReader (BehaviorEnv x))
970
951
971instance Monad (BehaviorM x) where
952instance Monad (BehaviorM x) where
972 {-# INLINE (>>=) #-}
953 {-# INLINE (>>=) #-}
@@ -1183,11 +1164,11 @@ data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p)
1183
1164
1184newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }
1165newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) }
1185
1166
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)
1187newMapDyn 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)
1188
1169
1189--TODO: Avoid the duplication between this and R.zipDynWith
1170--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)
1191zipDynWith f da db =
1172zipDynWith f da db =
1192 let eab = align (dynamicUpdated da) (dynamicUpdated db)
1173 let eab = align (dynamicUpdated da) (dynamicUpdated db)
1193 ec = flip push eab $ \o -> do
1174 ec = flip push eab $ \o -> do
@@ -1260,7 +1241,7 @@ run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> Res
1260run roots after = do
1241run roots after = do
1261 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
1242 tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events"
1262 let t = spiderTimeline :: SpiderTimelineEnv x
1243 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
1264 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
1245 rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do
1265 occBefore <- liftIO $ do
1246 occBefore <- liftIO $ do
1266 occBefore <- readIORef occRef
1247 occBefore <- readIORef occRef
@@ -1324,9 +1305,9 @@ type WeakList a = [Weak a]
1324withIncreasedDepth :: CanTrace x m => m a -> m a
1305withIncreasedDepth :: CanTrace x m => m a -> m a
1325withIncreasedDepth a = do
1306withIncreasedDepth a = do
1326 spiderTimeline <- askSpiderTimelineEnv
1307 spiderTimeline <- askSpiderTimelineEnv
1327− liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) succ
1308+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ
1328 result <- a
1309 result <- a
1329− liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) pred
1310+ liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred
1330 return result
1311 return result
1331#else
1312#else
1332withIncreasedDepth :: m a -> m a
1313withIncreasedDepth :: m a -> m a
@@ -1353,7 +1334,7 @@ traceMWhen _ b getMessage = when b $ do
1353 message <- getMessage
1334 message <- getMessage
1354#ifdef DEBUG
1335#ifdef DEBUG
1355 spiderTimeline <- askSpiderTimelineEnv
1336 spiderTimeline <- askSpiderTimelineEnv
1356− d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE spiderTimeline
1337+ d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline
1357#else
1338#else
1358 let d = 0
1339 let d = 0
1359#endif
1340#endif
@@ -1394,25 +1375,25 @@ propagateSubscriberHold h a = do
1394data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1375data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset
1395
1376
1396runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a
1377runBehaviorM :: 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)
1398
1379
1399askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
1380askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x)))
1400askInvalidator = do
1381askInvalidator = do
1401− (!m, _) <- ask
1382+ (!m, _) <- BehaviorM ask
1402 case m of
1383 case m of
1403 Nothing -> return Nothing
1384 Nothing -> return Nothing
1404 Just (!wi, _) -> return $ Just wi
1385 Just (!wi, _) -> return $ Just wi
1405
1386
1406askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
1387askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x]))
1407askParentsRef = do
1388askParentsRef = do
1408− (!m, _) <- ask
1389+ (!m, _) <- BehaviorM ask
1409 case m of
1390 case m of
1410 Nothing -> return Nothing
1391 Nothing -> return Nothing
1411 Just (_, !p) -> return $ Just p
1392 Just (_, !p) -> return $ Just p
1412
1393
1413askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
1394askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x])
1414askBehaviorHoldInits = do
1395askBehaviorHoldInits = do
1415− (_, !his) <- ask
1396+ (_, !his) <- BehaviorM ask
1416 return his
1397 return his
1417
1398
1418{-# INLINE getDynHold #-}
1399{-# INLINE getDynHold #-}
@@ -1730,20 +1711,20 @@ subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceS
1730{-# INLINE mergeG #-}
1711{-# INLINE mergeG #-}
1731mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)
1712mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k)
1732 => (forall a. q a -> Event x (v a))
1713 => (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)
1734mergeG nt d = cacheEvent (mergeCheap nt d)
1715mergeG nt d = cacheEvent (mergeCheap nt d)
1735
1716
1736{-# INLINE mergeWithMove #-}
1717{-# INLINE mergeWithMove #-}
1737mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)
1718mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k)
1738 => (forall a. q a -> Event x (v a))
1719 => (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)
1740mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)
1721mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d)
1741
1722
1742{-# INLINE [1] mergeCheap #-}
1723{-# INLINE [1] mergeCheap #-}
1743mergeCheap
1724mergeCheap
1744 :: forall k x q v. (HasSpiderTimeline x, GCompare k)
1725 :: forall k x q v. (HasSpiderTimeline x, GCompare k)
1745 => (forall a. q a -> Event x (v a))
1726 => (forall a. q a -> Event x (v a))
1746− -> DynamicS x (PatchDMap k q)
1727+ -> Dynamic x (PatchDMap k q)
1747 -> Event x (DMap k v)
1728 -> Event x (DMap k v)
1748mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy
1729mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy
1749 where
1730 where
@@ -1783,7 +1764,7 @@ mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy
1783{-# INLINE [1] mergeCheapWithMove #-}
1764{-# INLINE [1] mergeCheapWithMove #-}
1784mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)
1765mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k)
1785 => (forall a. q a -> Event x (v a))
1766 => (forall a. q a -> Event x (v a))
1786− -> DynamicS x (PatchDMapWithMove k q)
1767+ -> Dynamic x (PatchDMapWithMove k q)
1787 -> Event x (DMap k v)
1768 -> Event x (DMap k v)
1788mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy
1769mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy
1789 where
1770 where
@@ -1931,7 +1912,7 @@ updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m)
1931
1912
1932{-# INLINE mergeGCheap' #-}
1913{-# INLINE mergeGCheap' #-}
1933mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q)
1914mergeGCheap' :: 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)
1935mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1916mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1936 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1917 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1937 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
1918 accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized"
@@ -1980,11 +1961,11 @@ mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do
1980 , occ
1961 , occ
1981 )
1962 )
1982
1963
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)
1984mergeInt = cacheEvent . mergeIntCheap
1965mergeInt = cacheEvent . mergeIntCheap
1985
1966
1986{-# INLINABLE mergeIntCheap #-}
1967{-# 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)
1988mergeIntCheap d = Event $ \sub -> do
1969mergeIntCheap d = Event $ \sub -> do
1989 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1970 initialParents <- readBehaviorUntracked $ dynamicCurrent d
1990 accum <- liftIO $ FastMutableIntMap.newEmpty
1971 accum <- liftIO $ FastMutableIntMap.newEmpty
@@ -2142,7 +2123,7 @@ clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeI
2142-- | Run an event action outside of a frame
2123-- | Run an event action outside of a frame
2143runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
2124runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex
2144runFrame a = SpiderHost $ do
2125runFrame a = SpiderHost $ do
2145− let env = _spiderTimeline_eventEnv $ unSTE (spiderTimeline :: SpiderTimelineEnv x)
2126+ let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x)
2146 let go = do
2127 let go = do
2147 result <- a
2128 result <- a
2148 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
2129 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))
2353 fail _ = error "Dynamic does not support 'fail'"
2334 fail _ = error "Dynamic does not support 'fail'"
2354
2335
2355{-# INLINABLE newJoinDyn #-}
2336{-# 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)
2357newJoinDyn d =
2338newJoinDyn d =
2358 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)
2339 let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d)
2359 eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d
2340 eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d
@@ -2503,7 +2484,7 @@ unsafeNewSpiderTimelineEnv = do
2503#ifdef DEBUG
2484#ifdef DEBUG
2504 depthRef <- newIORef 0
2485 depthRef <- newIORef 0
2505#endif
2486#endif
2506− return $ STE $ SpiderTimelineEnv
2487+ return $ SpiderTimelineEnv
2507 { _spiderTimeline_lock = lock
2488 { _spiderTimeline_lock = lock
2508 , _spiderTimeline_eventEnv = env
2489 , _spiderTimeline_eventEnv = env
2509#ifdef DEBUG
2490#ifdef DEBUG
@@ -2519,13 +2500,13 @@ data LocalSpiderTimeline (x :: Type) s
2519
2500
2520instance Reifies s (SpiderTimelineEnv x) =>
2501instance Reifies s (SpiderTimelineEnv x) =>
2521 HasSpiderTimeline (LocalSpiderTimeline x s) where
2502 HasSpiderTimeline (LocalSpiderTimeline x s) where
2522− spiderTimeline = localSpiderTimeline Proxy $ reflect (Proxy :: Proxy s)
2503+ spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s)
2523
2504
2524localSpiderTimeline
2505localSpiderTimeline
2525− :: proxy s
2506+ :: Proxy s
2526 -> SpiderTimelineEnv x
2507 -> SpiderTimelineEnv x
2527 -> SpiderTimelineEnv (LocalSpiderTimeline x s)
2508 -> SpiderTimelineEnv (LocalSpiderTimeline x s)
2528−localSpiderTimeline _ = coerce
2509+localSpiderTimeline _ = unsafeCoerce
2529
2510
2530-- | Pass a new timeline to the given function.
2511-- | Pass a new timeline to the given function.
2531withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r
2512withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r
@@ -2543,8 +2524,8 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2543 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
2524 {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-}
2544 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
2525 newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a }
2545 newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a }
2526 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)
2527+ newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad)
2547− newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: DynamicS x p }
2528+ newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p }
2548 type PullM (SpiderTimeline x) = SpiderPullM x
2529 type PullM (SpiderTimeline x) = SpiderPullM x
2549 type PushM (SpiderTimeline x) = SpiderPushM x
2530 type PushM (SpiderTimeline x) = SpiderPushM x
2550 {-# INLINABLE never #-}
2531 {-# INLINABLE never #-}
@@ -2573,7 +2554,7 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2573 {-# INLINABLE current #-}
2554 {-# INLINABLE current #-}
2574 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
2555 current = SpiderBehavior . dynamicCurrent . unSpiderDynamic
2575 {-# INLINABLE updated #-}
2556 {-# INLINABLE updated #-}
2576− updated = SpiderEvent #. dynamicUpdated .# fmap coerce . unSpiderDynamic
2557+ updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic
2577 {-# INLINABLE unsafeBuildDynamic #-}
2558 {-# INLINABLE unsafeBuildDynamic #-}
2578 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
2559 unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v'
2579 {-# INLINABLE unsafeBuildIncremental #-}
2560 {-# INLINABLE unsafeBuildIncremental #-}
@@ -2592,10 +2573,9 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where
2592 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
2573 return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply'
2593 eventCoercion Coercion = Coercion
2574 eventCoercion Coercion = Coercion
2594 behaviorCoercion Coercion = Coercion
2575 behaviorCoercion Coercion = Coercion
2595− dynamicCoercion 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
2596− incrementalCoercion Coercion Coercion = Coercion
2597 {-# INLINABLE mergeIntIncremental #-}
2577 {-# 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
2599 {-# INLINABLE fanInt #-}
2579 {-# INLINABLE fanInt #-}
2600 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))
2580 fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e))
2601
2581
test/Reflex/Bench/Focused.hs−12
@@ -130,16 +130,6 @@ 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−
143combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
133combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word)
144combineDynChain = iterM (\d -> return $ zipDynWith (+) d d)
134combineDynChain = iterM (\d -> return $ zipDynWith (+) d d)
145
135
@@ -318,8 +308,6 @@ dynamics :: Word -> [(String, TestCase)]
318dynamics n =
308dynamics n =
319 [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d
309 [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d
320 , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d
310 , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d
321− , testE "holdDynChain" $ fmap updated $ holdDynChain n =<< d
322− , testE "buildDynChain" $ fmap updated $ buildDynChain n =<< d
323 , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d
311 , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d
324 , testE "dense mergeTree" $ fmap (updated . mergeTreeDyn 8) dense
312 , testE "dense mergeTree" $ fmap (updated . mergeTreeDyn 8) dense
325 , testE "sparse mergeTree" $ fmap (updated . mergeTreeDyn 8) sparse
313 , testE "sparse mergeTree" $ fmap (updated . mergeTreeDyn 8) sparse