From d8d7897b9eb0a2227612b952feeb379510d6b0a5 Mon Sep 17 00:00:00 2001 From: David Feuer Date: Tue, 9 Jul 2019 14:53:14 -0400 Subject: [PATCH 1/2] Reduce the use of unsafeCoerce Remove most uses of `unsafeCoerce`. Most of the rest are taken care of in my `mergeG` pull request. --- reflex.cabal | 2 + src/Control/Monad/ReaderIO.hs | 55 ++++++++++++++++++++ src/Reflex/Class.hs | 11 ++++ src/Reflex/Profiled.hs | 18 ++++--- src/Reflex/Pure.hs | 1 + src/Reflex/Spider/Internal.hs | 98 ++++++++++++++++++++--------------- 6 files changed, 137 insertions(+), 48 deletions(-) create mode 100644 src/Control/Monad/ReaderIO.hs diff --git a/reflex.cabal b/reflex.cabal index 807c20b7..4e4012a8 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -56,6 +56,7 @@ library mtl >= 2.1 && < 2.3, prim-uniq >= 0.1.0.1 && < 0.2, primitive >= 0.5 && < 0.7, + profunctors, random == 1.1.*, ref-tf == 0.4.*, reflection == 2.1.*, @@ -71,6 +72,7 @@ library witherable >= 0.2 && < 0.4 exposed-modules: + Control.Monad.ReaderIO Data.AppendMap, Data.FastMutableIntMap, Data.FastWeakBag, diff --git a/src/Control/Monad/ReaderIO.hs b/src/Control/Monad/ReaderIO.hs new file mode 100644 index 00000000..59964780 --- /dev/null +++ b/src/Control/Monad/ReaderIO.hs @@ -0,0 +1,55 @@ +{-# language RoleAnnotations #-} +{-# language MultiParamTypeClasses #-} +{-# language FlexibleInstances #-} +module Control.Monad.ReaderIO + ( + ReaderIO (..) + ) + where + +import Control.Monad.Fix +import Control.Applicative +import Control.Monad +import Control.Monad.Reader.Class +import Control.Monad.IO.Class + +-- | An approximate clone of @RIO@ from the @rio@ package, but not based on +-- @ReaderT@. The trouble with @ReaderT@ is that its third type argument has a +-- @nominal@ role, so we can't coerce through it when it's wrapped in some +-- other @data@ type. Ugh. +newtype ReaderIO e a = ReaderIO { runReaderIO :: e -> IO a } +type role ReaderIO representational representational + +instance Functor (ReaderIO e) where + fmap = liftM + {-# INLINE fmap #-} + a <$ m = m >> pure a + {-# INLINE (<$) #-} + +instance Applicative (ReaderIO e) where + pure a = ReaderIO $ \_ -> pure a + {-# INLINE pure #-} + (<*>) = ap + {-# INLINE (<*>) #-} + liftA2 = liftM2 + {-# INLINE liftA2 #-} + (*>) = (>>) + {-# INLINE (*>) #-} + +instance Monad (ReaderIO e) where + ReaderIO q >>= f = ReaderIO $ \e -> q e >>= \a -> runReaderIO (f a) e + {-# INLINE (>>=) #-} + +instance MonadFix (ReaderIO e) where + mfix f = ReaderIO $ \e -> mfix $ \r -> runReaderIO (f r) e + {-# INLINE mfix #-} + +instance MonadIO (ReaderIO e) where + liftIO m = ReaderIO $ \_ -> m + {-# INLINE liftIO #-} + +instance MonadReader e (ReaderIO e) where + ask = ReaderIO pure + {-# INLINE ask #-} + local f (ReaderIO m) = ReaderIO (m . f) + {-# INLINE local #-} diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index af36a244..916f60c1 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -37,6 +37,7 @@ module Reflex.Class , coerceBehavior , coerceEvent , coerceDynamic + , coerceIncremental , MonadSample (..) , MonadHold (..) -- ** 'fan' related types @@ -312,6 +313,10 @@ class ( MonadHold t (PushM t) -- | Construct a 'Coercion' for a 'Dynamic' given an 'Coercion' for its -- occurrence type dynamicCoercion :: Coercion a b -> Coercion (Dynamic t a) (Dynamic t b) + -- | Construct a 'Coercion' for an 'Incremental' given 'Coercion's for its + -- patch target and patch types. + incrementalCoercion + :: Coercion (PatchTarget a) (PatchTarget b) -> Coercion a b -> Coercion (Incremental t a) (Incremental t b) mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a) fanInt :: Event t (IntMap a) -> EventSelectorInt t a @@ -345,6 +350,12 @@ coerceEvent = coerceWith $ eventCoercion Coercion coerceDynamic :: (Reflex t, Coercible a b) => Dynamic t a -> Dynamic t b coerceDynamic = coerceWith $ dynamicCoercion Coercion +-- | Coerce an 'Incremental' between representationally-equivalent value types +coerceIncremental + :: (Reflex t, Coercible a b, Coercible (PatchTarget a) (PatchTarget b)) + => Incremental t a -> Incremental t b +coerceIncremental = coerceWith $ incrementalCoercion Coercion Coercion + -- | Construct a 'Dynamic' from a 'Behavior' and an 'Event'. The 'Behavior' -- __must__ change when and only when the 'Event' fires, such that the -- 'Behavior''s value is always equal to the most recent firing of the 'Event'; diff --git a/src/Reflex/Profiled.hs b/src/Reflex/Profiled.hs index 6a9b19d6..3fa07d58 100644 --- a/src/Reflex/Profiled.hs +++ b/src/Reflex/Profiled.hs @@ -9,6 +9,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE RankNTypes #-} -- | -- Module: @@ -151,13 +152,16 @@ instance Reflex t => Reflex (ProfiledTimeline t) where currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i - behaviorCoercion (c :: Coercion a b) = case behaviorCoercion c :: Coercion (Behavior t a) (Behavior t b) of - Coercion -> unsafeCoerce (Coercion :: Coercion (Behavior (ProfiledTimeline t) a) (Behavior (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce - eventCoercion (c :: Coercion a b) = case eventCoercion c :: Coercion (Event t a) (Event t b) of - Coercion -> unsafeCoerce (Coercion :: Coercion (Event (ProfiledTimeline t) a) (Event (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce - dynamicCoercion (c :: Coercion a b) = case dynamicCoercion c :: Coercion (Dynamic t a) (Dynamic t b) of - Coercion -> unsafeCoerce (Coercion :: Coercion (Dynamic (ProfiledTimeline t) a) (Dynamic (ProfiledTimeline t) a)) --TODO: Figure out how to make this typecheck without the unsafeCoerce - mergeIntIncremental = Event_Profiled . mergeIntIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchIntMap (Event (ProfiledTimeline t) a)) -> Incremental t (PatchIntMap (Event t a))) + behaviorCoercion c = + Coercion `trans` behaviorCoercion @t c `trans` Coercion + eventCoercion c = + Coercion `trans` eventCoercion @t c `trans` Coercion + dynamicCoercion c = + Coercion `trans` dynamicCoercion @t c `trans` Coercion + incrementalCoercion c d = + Coercion `trans` incrementalCoercion @t c d `trans` Coercion + mergeIntIncremental = Event_Profiled . mergeIntIncremental . + coerceWith (Coercion `trans` incrementalCoercion Coercion Coercion `trans` Coercion) fanInt (Event_Profiled e) = coerce $ fanInt $ profileEvent e deriving instance Functor (Dynamic t) => Functor (Dynamic (ProfiledTimeline t)) diff --git a/src/Reflex/Pure.hs b/src/Reflex/Pure.hs index 73574703..f24b5196 100644 --- a/src/Reflex/Pure.hs +++ b/src/Reflex/Pure.hs @@ -133,6 +133,7 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where behaviorCoercion Coercion = Coercion eventCoercion Coercion = Coercion dynamicCoercion Coercion = Coercion + incrementalCoercion Coercion Coercion = Coercion fanInt e = EventSelectorInt $ \k -> Event $ \t -> unEvent e t >>= IntMap.lookup k diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index f130a635..931ac679 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -18,6 +18,7 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE PolyKinds #-} +{-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE InstanceSigs #-} #ifdef USE_REFLEX_OPTIMIZER @@ -37,7 +38,10 @@ import Control.Monad hiding (forM, forM_, mapM, mapM_) import Control.Monad.Exception import Control.Monad.Identity hiding (forM, forM_, mapM, mapM_) import Control.Monad.Primitive -import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_) +--import Control.Monad.Reader hiding (forM, forM_, mapM, mapM_) +import Control.Monad.Reader.Class +import Control.Monad.IO.Class +import Control.Monad.ReaderIO import Control.Monad.Ref import Data.Align import Data.Coerce @@ -67,6 +71,7 @@ import Reflex.FastWeak import System.IO.Unsafe import System.Mem.Weak import Unsafe.Coerce +import Data.Profunctor.Unsafe #ifdef DEBUG_CYCLES import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence) @@ -545,6 +550,11 @@ propagateFast a subscribers = withIncreasedDepth $ do toAny :: a -> Any toAny = unsafeCoerce +-- Why do we use Any here, instead of just giving eventSubscribedRetained an +-- existential type? Sadly, GHC does not currently know how to unbox types +-- with existentially quantified fields. So instead we just coerce values +-- to type Any on the way in. Since we never coerce them back, this is +-- perfectly safe. data EventSubscribed x = EventSubscribed { eventSubscribedHeightRef :: {-# UNPACK #-} !(IORef Height) , eventSubscribedRetained :: {-# NOUNPACK #-} !Any @@ -668,7 +678,7 @@ behaviorPull !p = Behavior $ do wi <- liftIO $ mkWeakPtrWithDebug i "InvalidatorPull" parentsRef <- liftIO $ newIORef [] holdInits <- askBehaviorHoldInits - a <- liftIO $ runReaderT (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits) + a <- liftIO $ runReaderIO (unBehaviorM $ pullCompute p) (Just (wi, parentsRef), holdInits) invsRef <- liftIO . newIORef . maybeToList =<< askInvalidator parents <- liftIO $ readIORef parentsRef let subscribed = PullSubscribed @@ -703,42 +713,42 @@ readBehaviorUntracked b = do -- Dynamic -------------------------------------------------------------------------------- -data Dynamic x p = Dynamic - { dynamicCurrent :: !(Behavior x (PatchTarget p)) +type DynamicS x p = Dynamic x (PatchTarget p) p + +data Dynamic x target p = Dynamic + { dynamicCurrent :: !(Behavior x target) , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`? } + deriving (Functor) -dynamicHold :: Hold x p -> Dynamic x p +dynamicHold :: Hold x p -> DynamicS x p dynamicHold !h = Dynamic { dynamicCurrent = behaviorHold h , dynamicUpdated = eventHold h } -dynamicHoldIdentity :: Hold x (Identity a) -> Dynamic x (Identity a) +dynamicHoldIdentity :: Hold x (Identity a) -> DynamicS x (Identity a) dynamicHoldIdentity = dynamicHold -dynamicConst :: PatchTarget p -> Dynamic x p +dynamicConst :: PatchTarget p -> DynamicS x p dynamicConst !a = Dynamic { dynamicCurrent = behaviorConst a , dynamicUpdated = eventNever } -dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> Dynamic x p +dynamicDyn :: (HasSpiderTimeline x, Patch p) => Dyn x p -> DynamicS x p dynamicDyn !d = Dynamic { dynamicCurrent = behaviorDyn d , dynamicUpdated = eventDyn d } -dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> Dynamic x (Identity a) +dynamicDynIdentity :: HasSpiderTimeline x => Dyn x (Identity a) -> DynamicS x (Identity a) dynamicDynIdentity = dynamicDyn -------------------------------------------------------------------------------- -- Combinators -------------------------------------------------------------------------------- ---TODO: Figure out why certain things are not 'representational', then make them ---representational so we can use coerce - --type role Hold representational data Hold x p = Hold { holdValue :: !(IORef (PatchTarget p)) @@ -759,20 +769,25 @@ globalSpiderTimelineEnv = unsafePerformIO unsafeNewSpiderTimelineEnv -- | Stores all global data relevant to a particular Spider timeline; only one -- value should exist for each type @x@ -data SpiderTimelineEnv x = SpiderTimelineEnv +newtype SpiderTimelineEnv x = STE {unSTE :: SpiderTimelineEnv' x} +-- We implement SpiderTimelineEnv with a newtype wrapper so +-- we can get the coercions we want safely. +type role SpiderTimelineEnv nominal + +data SpiderTimelineEnv' x = SpiderTimelineEnv { _spiderTimeline_lock :: {-# UNPACK #-} !(MVar ()) , _spiderTimeline_eventEnv :: {-# UNPACK #-} !(EventEnv x) #ifdef DEBUG , _spiderTimeline_depth :: {-# UNPACK #-} !(IORef Int) #endif } -type role SpiderTimelineEnv nominal +type role SpiderTimelineEnv' phantom instance Eq (SpiderTimelineEnv x) where _ == _ = True -- Since only one exists of each type instance GEq SpiderTimelineEnv where - a `geq` b = if _spiderTimeline_lock a == _spiderTimeline_lock b + a `geq` b = if _spiderTimeline_lock (unSTE a) == _spiderTimeline_lock (unSTE b) then Just $ unsafeCoerce Refl -- This unsafeCoerce is safe because the same SpiderTimelineEnv can't have two different 'x' arguments else Nothing @@ -795,7 +810,7 @@ runEventM :: EventM x a -> IO a runEventM = unEventM asksEventEnv :: forall x a. HasSpiderTimeline x => (EventEnv x -> a) -> EventM x a -asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x) +asksEventEnv f = return $ f $ _spiderTimeline_eventEnv (unSTE (spiderTimeline :: SpiderTimelineEnv x)) class MonadIO m => Defer a m where getDeferralQueue :: m (IORef [a]) @@ -933,9 +948,9 @@ getHoldEventSubscription h = do type BehaviorEnv x = (Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]), IORef [SomeHoldInit x]) ---type role BehaviorM representational -- BehaviorM can sample behaviors -newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderT (BehaviorEnv x) IO a } deriving (Functor, Applicative, MonadIO, MonadFix) +newtype BehaviorM x a = BehaviorM { unBehaviorM :: ReaderIO (BehaviorEnv x) a } + deriving (Functor, Applicative, MonadIO, MonadFix, MonadReader (BehaviorEnv x)) instance Monad (BehaviorM x) where {-# INLINE (>>=) #-} @@ -1145,11 +1160,11 @@ data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p) newtype Dyn (x :: Type) p = Dyn { unDyn :: IORef (DynType x p) } -newMapDyn :: HasSpiderTimeline x => (a -> b) -> Dynamic x (Identity a) -> Dynamic x (Identity b) +newMapDyn :: HasSpiderTimeline x => (a -> b) -> DynamicS x (Identity a) -> DynamicS x (Identity b) newMapDyn f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d) --TODO: Avoid the duplication between this and R.zipDynWith -zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> Dynamic x (Identity a) -> Dynamic x (Identity b) -> Dynamic x (Identity c) +zipDynWith :: HasSpiderTimeline x => (a -> b -> c) -> DynamicS x (Identity a) -> DynamicS x (Identity b) -> DynamicS x (Identity c) zipDynWith f da db = let eab = align (dynamicUpdated da) (dynamicUpdated db) ec = flip push eab $ \o -> do @@ -1225,7 +1240,7 @@ run :: forall x b. HasSpiderTimeline x => [DSum (RootTrigger x) Identity] -> Res run roots after = do tracePropagate (Proxy :: Proxy x) $ "Running an event frame with " <> show (length roots) <> " events" let t = spiderTimeline :: SpiderTimelineEnv x - result <- SpiderHost $ withMVar (_spiderTimeline_lock t) $ \_ -> unSpiderHost $ runFrame $ do + result <- SpiderHost $ withMVar (_spiderTimeline_lock (unSTE t)) $ \_ -> unSpiderHost $ runFrame $ do rootsToPropagate <- forM roots $ \r@(RootTrigger (_, occRef, k) :=> a) -> do occBefore <- liftIO $ do occBefore <- readIORef occRef @@ -1289,9 +1304,9 @@ type WeakList a = [Weak a] withIncreasedDepth :: CanTrace x m => m a -> m a withIncreasedDepth a = do spiderTimeline <- askSpiderTimelineEnv - liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) succ + liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) succ result <- a - liftIO $ modifyIORef' (_spiderTimeline_depth spiderTimeline) pred + liftIO $ modifyIORef' (_spiderTimeline_depth (unSTE spiderTimeline)) pred return result #else withIncreasedDepth :: m a -> m a @@ -1318,7 +1333,7 @@ traceMWhen _ b getMessage = when b $ do message <- getMessage #ifdef DEBUG spiderTimeline <- askSpiderTimelineEnv - d <- liftIO $ readIORef $ _spiderTimeline_depth spiderTimeline + d <- liftIO $ readIORef $ _spiderTimeline_depth $ unSTE spiderTimeline #else let d = 0 #endif @@ -1359,25 +1374,25 @@ propagateSubscriberHold h a = do data SomeResetCoincidence x = forall a. SomeResetCoincidence !(EventSubscription x) !(Maybe (CoincidenceSubscribed x a)) -- The CoincidenceSubscriber will be present only if heights need to be reset runBehaviorM :: BehaviorM x a -> Maybe (Weak (Invalidator x), IORef [SomeBehaviorSubscribed x]) -> IORef [SomeHoldInit x] -> IO a -runBehaviorM a mwi holdInits = runReaderT (unBehaviorM a) (mwi, holdInits) +runBehaviorM a mwi holdInits = runReaderIO (unBehaviorM a) (mwi, holdInits) askInvalidator :: BehaviorM x (Maybe (Weak (Invalidator x))) askInvalidator = do - (!m, _) <- BehaviorM ask + (!m, _) <- ask case m of Nothing -> return Nothing Just (!wi, _) -> return $ Just wi askParentsRef :: BehaviorM x (Maybe (IORef [SomeBehaviorSubscribed x])) askParentsRef = do - (!m, _) <- BehaviorM ask + (!m, _) <- ask case m of Nothing -> return Nothing Just (_, !p) -> return $ Just p askBehaviorHoldInits :: BehaviorM x (IORef [SomeHoldInit x]) askBehaviorHoldInits = do - (_, !his) <- BehaviorM ask + (_, !his) <- ask return his {-# INLINE getDynHold #-} @@ -1951,11 +1966,11 @@ mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do , occ ) -mergeInt :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a) +mergeInt :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a) mergeInt = cacheEvent . mergeIntCheap {-# INLINABLE mergeIntCheap #-} -mergeIntCheap :: forall x a. (HasSpiderTimeline x) => Dynamic x (PatchIntMap (Event x a)) -> Event x (IntMap a) +mergeIntCheap :: forall x a. (HasSpiderTimeline x) => DynamicS x (PatchIntMap (Event x a)) -> Event x (IntMap a) mergeIntCheap d = Event $ \sub -> do initialParents <- readBehaviorUntracked $ dynamicCurrent d accum <- liftIO $ FastMutableIntMap.newEmpty @@ -2115,7 +2130,7 @@ clearEventEnv (EventEnv toAssignRef holdInitRef dynInitRef mergeUpdateRef mergeI -- | Run an event action outside of a frame runFrame :: forall x a. HasSpiderTimeline x => EventM x a -> SpiderHost x a --TODO: This function also needs to hold the mutex runFrame a = SpiderHost $ do - let env = _spiderTimeline_eventEnv (spiderTimeline :: SpiderTimelineEnv x) + let env = _spiderTimeline_eventEnv $ unSTE (spiderTimeline :: SpiderTimelineEnv x) let go = do result <- a 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 +2341,7 @@ instance HasSpiderTimeline x => Monad (Reflex.Class.Dynamic (SpiderTimeline x)) fail _ = error "Dynamic does not support 'fail'" {-# INLINABLE newJoinDyn #-} -newJoinDyn :: HasSpiderTimeline x => Reflex.Spider.Internal.Dynamic x (Identity (Reflex.Spider.Internal.Dynamic x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a) +newJoinDyn :: HasSpiderTimeline x => DynamicS x (Identity (DynamicS x (Identity a))) -> Reflex.Spider.Internal.Dyn x (Identity a) newJoinDyn d = let readV0 = readBehaviorTracked . dynamicCurrent =<< readBehaviorTracked (dynamicCurrent d) eOuter = Reflex.Spider.Internal.push (fmap (Just . Identity) . readBehaviorUntracked . dynamicCurrent . runIdentity) $ dynamicUpdated d @@ -2476,7 +2491,7 @@ unsafeNewSpiderTimelineEnv = do #ifdef DEBUG depthRef <- newIORef 0 #endif - return $ SpiderTimelineEnv + return $ STE $ SpiderTimelineEnv { _spiderTimeline_lock = lock , _spiderTimeline_eventEnv = env #ifdef DEBUG @@ -2492,13 +2507,13 @@ data LocalSpiderTimeline (x :: Type) s instance Reifies s (SpiderTimelineEnv x) => HasSpiderTimeline (LocalSpiderTimeline x s) where - spiderTimeline = localSpiderTimeline (Proxy :: Proxy s) $ reflect (Proxy :: Proxy s) + spiderTimeline = localSpiderTimeline Proxy $ reflect (Proxy :: Proxy s) localSpiderTimeline - :: Proxy s + :: proxy s -> SpiderTimelineEnv x -> SpiderTimelineEnv (LocalSpiderTimeline x s) -localSpiderTimeline _ = unsafeCoerce +localSpiderTimeline _ = coerce -- | Pass a new timeline to the given function. withSpiderTimeline :: (forall x. HasSpiderTimeline x => SpiderTimelineEnv x -> IO r) -> IO r @@ -2516,8 +2531,8 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-} newtype Behavior (SpiderTimeline x) a = SpiderBehavior { unSpiderBehavior :: Behavior x a } newtype Event (SpiderTimeline x) a = SpiderEvent { unSpiderEvent :: Event x a } - newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: Dynamic x (Identity a) } -- deriving (Functor, Applicative, Monad) - newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: Dynamic x p } + newtype Dynamic (SpiderTimeline x) a = SpiderDynamic { unSpiderDynamic :: DynamicS x (Identity a) } -- deriving (Functor, Applicative, Monad) + newtype Incremental (SpiderTimeline x) p = SpiderIncremental { unSpiderIncremental :: DynamicS x p } type PullM (SpiderTimeline x) = SpiderPullM x type PushM (SpiderTimeline x) = SpiderPushM x {-# INLINABLE never #-} @@ -2546,7 +2561,7 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where {-# INLINABLE current #-} current = SpiderBehavior . dynamicCurrent . unSpiderDynamic {-# INLINABLE updated #-} - updated = coerce $ SpiderEvent . dynamicUpdated . unSpiderDynamic + updated = SpiderEvent #. dynamicUpdated .# fmap coerce . unSpiderDynamic {-# INLINABLE unsafeBuildDynamic #-} unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v' {-# INLINABLE unsafeBuildIncremental #-} @@ -2565,9 +2580,10 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where return $ Identity <$> apply p c --TODO: Avoid the redundant 'apply' eventCoercion Coercion = Coercion behaviorCoercion Coercion = Coercion - dynamicCoercion = unsafeCoerce --TODO: How can we avoid this unsafeCoerce? This is safe only because we know how Identity works as a Patch instance + dynamicCoercion Coercion = Coercion + incrementalCoercion Coercion Coercion = Coercion {-# INLINABLE mergeIntIncremental #-} - mergeIntIncremental = SpiderEvent . mergeInt . (unsafeCoerce :: Dynamic x (PatchIntMap (R.Event (SpiderTimeline x) a)) -> Dynamic x (PatchIntMap (Event x a))) . unSpiderIncremental + mergeIntIncremental = SpiderEvent . mergeInt . coerce {-# INLINABLE fanInt #-} fanInt e = R.EventSelectorInt $ SpiderEvent . selectInt (fanInt (unSpiderEvent e)) From e424bedc2d56052d073bd994c732049fd966307c Mon Sep 17 00:00:00 2001 From: Oliver Batchelor Date: Tue, 6 Aug 2019 01:29:29 +1200 Subject: [PATCH 2/2] A couple of missed bits, compile in ghc 8.0 --- src/Control/Monad/ReaderIO.hs | 5 +++++ src/Reflex/Spider/Internal.hs | 18 +++++++++++------- test/Reflex/Bench/Focused.hs | 12 ++++++++++++ 3 files changed, 28 insertions(+), 7 deletions(-) diff --git a/src/Control/Monad/ReaderIO.hs b/src/Control/Monad/ReaderIO.hs index 59964780..fb5f60c7 100644 --- a/src/Control/Monad/ReaderIO.hs +++ b/src/Control/Monad/ReaderIO.hs @@ -1,6 +1,7 @@ {-# language RoleAnnotations #-} {-# language MultiParamTypeClasses #-} {-# language FlexibleInstances #-} +{-# language CPP #-} module Control.Monad.ReaderIO ( ReaderIO (..) @@ -8,7 +9,9 @@ module Control.Monad.ReaderIO where import Control.Monad.Fix +#if MIN_VERSION_base(4,10,0) import Control.Applicative +#endif import Control.Monad import Control.Monad.Reader.Class import Control.Monad.IO.Class @@ -31,8 +34,10 @@ instance Applicative (ReaderIO e) where {-# INLINE pure #-} (<*>) = ap {-# INLINE (<*>) #-} +#if MIN_VERSION_base(4,10,0) liftA2 = liftM2 {-# INLINE liftA2 #-} +#endif (*>) = (>>) {-# INLINE (*>) #-} diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index 931ac679..6bef73d3 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -19,6 +19,7 @@ {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE InstanceSigs #-} #ifdef USE_REFLEX_OPTIMIZER @@ -71,7 +72,6 @@ import Reflex.FastWeak import System.IO.Unsafe import System.Mem.Weak import Unsafe.Coerce -import Data.Profunctor.Unsafe #ifdef DEBUG_CYCLES import Control.Monad.State hiding (forM, forM_, mapM, mapM_, sequence) @@ -719,7 +719,11 @@ data Dynamic x target p = Dynamic { dynamicCurrent :: !(Behavior x target) , dynamicUpdated :: Event x p -- This must be lazy; see the comment on holdEvent --TODO: Would this let us eliminate `Dyn`? } - deriving (Functor) + +deriving instance (HasSpiderTimeline x) => Functor (Dynamic x target) + + + dynamicHold :: Hold x p -> DynamicS x p dynamicHold !h = Dynamic @@ -1716,20 +1720,20 @@ subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceS {-# INLINE mergeG #-} mergeG :: forall k q x v. (HasSpiderTimeline x, GCompare k) => (forall a. q a -> Event x (v a)) - -> Dynamic x (PatchDMap k q) -> Event x (DMap k v) + -> DynamicS x (PatchDMap k q) -> Event x (DMap k v) mergeG nt d = cacheEvent (mergeCheap nt d) {-# INLINE mergeWithMove #-} mergeWithMove :: forall k v q x. (HasSpiderTimeline x, GCompare k) => (forall a. q a -> Event x (v a)) - -> Dynamic x (PatchDMapWithMove k q) -> Event x (DMap k v) + -> DynamicS x (PatchDMapWithMove k q) -> Event x (DMap k v) mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d) {-# INLINE [1] mergeCheap #-} mergeCheap :: forall k x q v. (HasSpiderTimeline x, GCompare k) => (forall a. q a -> Event x (v a)) - -> Dynamic x (PatchDMap k q) + -> DynamicS x (PatchDMap k q) -> Event x (DMap k v) mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy where @@ -1769,7 +1773,7 @@ mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy {-# INLINE [1] mergeCheapWithMove #-} mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k) => (forall a. q a -> Event x (v a)) - -> Dynamic x (PatchDMapWithMove k q) + -> DynamicS x (PatchDMapWithMove k q) -> Event x (DMap k v) mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy where @@ -1917,7 +1921,7 @@ updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) {-# INLINE mergeGCheap' #-} mergeGCheap' :: forall k v x p s q. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k q) - => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> Dynamic x p -> Event x (DMap k v) + => MergeInitFunc k v q x s -> MergeUpdateFunc k v x p s -> MergeDestroyFunc k s -> DynamicS x p -> Event x (DMap k v) mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do initialParents <- readBehaviorUntracked $ dynamicCurrent d accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized" diff --git a/test/Reflex/Bench/Focused.hs b/test/Reflex/Bench/Focused.hs index 621ab5a5..cdfd5dd0 100644 --- a/test/Reflex/Bench/Focused.hs +++ b/test/Reflex/Bench/Focused.hs @@ -130,6 +130,16 @@ mapDynChain = iterM (return . fmap (+1)) joinDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word) joinDynChain = iterM (\d -> return $ join $ fmap (const d) d) +holdDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word) +holdDynChain = iterM (\d -> sample (current d) >>= flip holdDyn (updated d)) + +buildDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word) +buildDynChain = iterM (\d -> do + let b = fmap (+1) (current d) + e = fmap (*2) (updated d) + buildDynamic (sample b) e) + + combineDynChain :: (Reflex t, MonadHold t m) => Word -> Dynamic t Word -> m (Dynamic t Word) combineDynChain = iterM (\d -> return $ zipDynWith (+) d d) @@ -308,6 +318,8 @@ dynamics :: Word -> [(String, TestCase)] dynamics n = [ testE "mapDynChain" $ fmap updated $ mapDynChain n =<< d , testE "joinDynChain" $ fmap updated $ joinDynChain n =<< d + , testE "holdDynChain" $ fmap updated $ holdDynChain n =<< d + , testE "buildDynChain" $ fmap updated $ buildDynChain n =<< d , testE "combineDynChain" $ fmap updated $ combineDynChain n =<< d , testE "dense mergeTree" $ fmap (updated . mergeTreeDyn 8) dense , testE "sparse mergeTree" $ fmap (updated . mergeTreeDyn 8) sparse