From 8d8ceecd548f3d4f6e0b8db00a57659511d241a5 Mon Sep 17 00:00:00 2001 From: David Feuer Date: Mon, 8 Jul 2019 00:02:55 -0400 Subject: [PATCH 1/2] Generalize merge --- ChangeLog.md | 4 ++ reflex.cabal | 1 + src/Reflex/Class.hs | 34 ++++++++- src/Reflex/Profiled.hs | 14 ++-- src/Reflex/Pure.hs | 26 ++++--- src/Reflex/Spider/Internal.hs | 131 ++++++++++++++++++++-------------- test/GC.hs | 3 +- 7 files changed, 141 insertions(+), 72 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index 18f064bd..2293af98 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -3,6 +3,10 @@ ## Unreleased * Fix `holdDyn` so that it is lazy in its event argument +* Generalize `merge` to `mergeG`, `mergeIncremental` to + `mergeIncrementalG`, and `mergeIncrementalWithMove` + to `mergeIncrementalWithMoveG`. These produce `DMap`s + whose values needn't be `Identity`. ## 0.6.1.0 diff --git a/reflex.cabal b/reflex.cabal index 2f0cff20..b42674cc 100644 --- a/reflex.cabal +++ b/reflex.cabal @@ -48,6 +48,7 @@ library data-default >= 0.5 && < 0.8, dependent-map >= 0.2.4 && < 0.3, exception-transformers == 0.4.*, + profunctors, lens >= 4.7 && < 5, monad-control >= 1.0.1 && < 1.1, monoidal-containers == 0.4.*, diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 59e087c3..08f4bc2a 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -17,6 +17,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE Trustworthy #-} #ifdef USE_REFLEX_OPTIMIZER {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} #endif @@ -46,6 +47,9 @@ module Reflex.Class , pushAlways -- ** Combining 'Event's , leftmost + , merge + , mergeIncremental + , mergeIncrementalWithMove , mergeMap , mergeIntMap , mergeMapIncremental @@ -256,7 +260,9 @@ class ( MonadHold t (PushM t) -- | Merge a collection of events; the resulting 'Event' will only occur if at -- least one input event is occurring, and will contain all of the input keys -- that are occurring simultaneously - merge :: GCompare k => DMap k (Event t) -> Event t (DMap k Identity) --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty + mergeG :: GCompare k => (forall a. q a -> Event t (v a)) + -> DMap k q -> Event t (DMap k v) + --TODO: Generalize to get rid of DMap use --TODO: Provide a type-level guarantee that the result is not empty -- | Efficiently fan-out an event to many destinations. You should save the -- result in a @let@-binding, and then repeatedly 'select' on the result to -- create child events @@ -278,9 +284,14 @@ class ( MonadHold t (PushM t) -- that value. unsafeBuildIncremental :: Patch p => PullM t (PatchTarget p) -> Event t p -> Incremental t p -- | Create a merge whose parents can change over time - mergeIncremental :: GCompare k => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity) + mergeIncrementalG :: GCompare k + => (forall a. q a -> Event t (v a)) + -> Incremental t (PatchDMap k q) + -> Event t (DMap k v) -- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental - mergeIncrementalWithMove :: GCompare k => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity) + mergeIncrementalWithMoveG :: GCompare k + => (forall a. q a -> Event t (v a)) + -> Incremental t (PatchDMapWithMove k q) -> Event t (DMap k v) -- | Extract the 'Behavior' component of an 'Incremental' currentIncremental :: Patch p => Incremental t p -> Behavior t (PatchTarget p) -- | Extract the 'Event' component of an 'Incremental' @@ -1558,6 +1569,23 @@ fmapCheap f = pushCheap $ return . Just . f tagCheap :: Reflex t => Behavior t b -> Event t a -> Event t b tagCheap b = pushAlwaysCheap $ \_ -> sample b +-- | Merge a collection of events; the resulting 'Event' will only occur if at +-- least one input event is occurring, and will contain all of the input keys +-- that are occurring simultaneously +merge :: (Reflex t, GCompare k) => DMap k (Event t) -> Event t (DMap k Identity) +merge = mergeG coerceEvent +{-# INLINE merge #-} + +-- | Create a merge whose parents can change over time +mergeIncremental :: (Reflex t, GCompare k) + => Incremental t (PatchDMap k (Event t)) -> Event t (DMap k Identity) +mergeIncremental = mergeIncrementalG coerceEvent + +-- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental +mergeIncrementalWithMove :: (Reflex t, GCompare k) + => Incremental t (PatchDMapWithMove k (Event t)) -> Event t (DMap k Identity) +mergeIncrementalWithMove = mergeIncrementalWithMoveG coerceEvent + -- | A "cheap" version of 'mergeWithCheap'. See the performance note on 'pushCheap'. {-# INLINE mergeWithCheap #-} mergeWithCheap :: Reflex t => (a -> a -> a) -> [Event t a] -> Event t a diff --git a/src/Reflex/Profiled.hs b/src/Reflex/Profiled.hs index c0322da2..b311a8b5 100644 --- a/src/Reflex/Profiled.hs +++ b/src/Reflex/Profiled.hs @@ -8,6 +8,8 @@ {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} -- | -- Module: -- Reflex.Profiled @@ -16,7 +18,6 @@ -- profiling/cost-center information. module Reflex.Profiled where -import Control.Lens hiding (children) import Control.Monad import Control.Monad.Exception import Control.Monad.Fix @@ -33,6 +34,7 @@ import Data.Map (Map) import qualified Data.Map.Strict as Map import Data.Monoid ((<>)) import Data.Ord +import Data.Profunctor.Unsafe ((#.)) import qualified Data.Semigroup as S import Data.Type.Coercion import Foreign.Ptr @@ -133,8 +135,10 @@ instance Reflex t => Reflex (ProfiledTimeline t) where push f (Event_Profiled e) = coerce $ push (coerce f) $ profileEvent e -- Profile before rather than after; this way fanout won't count against us pushCheap f (Event_Profiled e) = coerce $ pushCheap (coerce f) $ profileEvent e pull = Behavior_Profiled . pull . coerce - merge :: forall k. GCompare k => DMap k (Event (ProfiledTimeline t)) -> Event (ProfiledTimeline t) (DMap k Identity) - merge = Event_Profiled . merge . (unsafeCoerce :: DMap k (Event (ProfiledTimeline t)) -> DMap k (Event t)) + mergeG :: forall (k :: z -> *) q v. GCompare k + => (forall a. q a -> Event (ProfiledTimeline t) (v a)) + -> DMap k q -> Event (ProfiledTimeline t) (DMap k v) + mergeG nt = Event_Profiled #. mergeG (coerce nt) fan (Event_Profiled e) = EventSelector $ coerce $ select (fan $ profileEvent e) switch (Behavior_Profiled b) = coerce $ profileEvent $ switch (coerceBehavior b) coincidence (Event_Profiled e) = coerce $ profileEvent $ coincidence (coerceEvent e) @@ -142,8 +146,8 @@ instance Reflex t => Reflex (ProfiledTimeline t) where updated (Dynamic_Profiled d) = coerce $ profileEvent $ updated d unsafeBuildDynamic (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildDynamic a0 a' unsafeBuildIncremental (ProfiledM a0) (Event_Profiled a') = coerce $ unsafeBuildIncremental a0 a' - mergeIncremental = Event_Profiled . mergeIncremental . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMap k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMap k (Event t))) - mergeIncrementalWithMove = Event_Profiled . mergeIncrementalWithMove . (unsafeCoerce :: Incremental (ProfiledTimeline t) (PatchDMapWithMove k (Event (ProfiledTimeline t))) -> Incremental t (PatchDMapWithMove k (Event t))) + mergeIncrementalG nt = (Event_Profiled . coerce) #. mergeIncrementalG nt + mergeIncrementalWithMoveG nt = (Event_Profiled . coerce) #. mergeIncrementalWithMoveG nt currentIncremental (Incremental_Profiled i) = coerce $ currentIncremental i updatedIncremental (Incremental_Profiled i) = coerce $ profileEvent $ updatedIncremental i incrementalToDynamic (Incremental_Profiled i) = coerce $ incrementalToDynamic i diff --git a/src/Reflex/Pure.hs b/src/Reflex/Pure.hs index 43d38608..cbf89b0c 100644 --- a/src/Reflex/Pure.hs +++ b/src/Reflex/Pure.hs @@ -5,6 +5,8 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE PolyKinds #-} #ifdef USE_REFLEX_OPTIMIZER {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} #endif @@ -43,10 +45,11 @@ import Data.MemoTrie import Data.Monoid import Data.Type.Coercion import Reflex.Class +import Data.Kind (Type) -- | A completely pure-functional 'Reflex' timeline, identifying moments in time -- with the type @/t/@. -data Pure t +data Pure (t :: Type) -- | The 'Enum' instance of @/t/@ must be dense: for all @/x :: t/@, there must not exist -- any @/y :: t/@ such that @/'pred' x < y < x/@. The 'HasTrie' instance will be used @@ -79,11 +82,12 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where -- [UNUSED_CONSTRAINT]: The following type signature for merge will produce a -- warning because the GCompare instance is not used; however, removing the -- GCompare instance produces a different warning, due to that constraint - -- being present in the original class definition + -- being present in the original class definition. - --merge :: GCompare k => DMap k (Event (Pure t)) -> Event (Pure t) (DMap k Identity) - merge events = Event $ memo $ \t -> - let currentOccurrences = DMap.mapMaybeWithKey (\_ (Event a) -> Identity <$> a t) events + --mergeG :: GCompare k => (forall a. q a -> Event (Pure t) (v a)) + -- -> DMap k q -> Event (Pure t) (DMap k v) + mergeG nt events = Event $ memo $ \t -> + let currentOccurrences = DMap.mapMaybeWithKey (\_ q -> case nt q of Event a -> a t) events in if DMap.null currentOccurrences then Nothing else Just currentOccurrences @@ -112,8 +116,8 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where --a) -> Incremental (Pure t) p a unsafeBuildIncremental readV0 p = Incremental $ \t -> (readV0 t, unEvent p t) - mergeIncremental = mergeIncrementalImpl - mergeIncrementalWithMove = mergeIncrementalImpl + mergeIncrementalG = mergeIncrementalImpl + mergeIncrementalWithMoveG = mergeIncrementalImpl currentIncremental i = Behavior $ \t -> fst $ unIncremental i t @@ -133,9 +137,11 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where mergeIntIncremental = mergeIntIncrementalImpl -mergeIncrementalImpl :: (PatchTarget p ~ DMap k (Event (Pure t)), GCompare k) => Incremental (Pure t) p -> Event (Pure t) (DMap k Identity) -mergeIncrementalImpl i = Event $ \t -> - let results = DMap.mapMaybeWithKey (\_ (Event e) -> Identity <$> e t) $ fst $ unIncremental i t +mergeIncrementalImpl :: (PatchTarget p ~ DMap k q, GCompare k) + => (forall a. q a -> Event (Pure t) (v a)) + -> Incremental (Pure t) p -> Event (Pure t) (DMap k v) +mergeIncrementalImpl nt i = Event $ \t -> + let results = DMap.mapMaybeWithKey (\_ q -> case nt q of Event e -> e t) $ fst $ unIncremental i t in if DMap.null results then Nothing else Just results diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index fbad7574..d9eb6473 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -17,9 +17,12 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE InstanceSigs #-} #ifdef USE_REFLEX_OPTIMIZER {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} #endif +{-# OPTIONS_GHC -Wunused-binds #-} -- | This module is the implementation of the 'Spider' 'Reflex' engine. It uses -- a graph traversal algorithm to propagate 'Event's and 'Behavior's. module Reflex.Spider.Internal (module Reflex.Spider.Internal) where @@ -49,6 +52,7 @@ import Data.GADT.Compare import Data.IntMap.Strict (IntMap) import qualified Data.IntMap.Strict as IntMap import Data.IORef +import Data.Kind (Type) import Data.Maybe hiding (mapMaybe) import Data.Monoid ((<>)) import Data.Proxy @@ -77,6 +81,7 @@ import Data.Reflection import Data.Some (Some) import qualified Data.Some as Some import Data.Type.Coercion +import Data.Profunctor.Unsafe ((#.), (.#)) import Data.WeakBag (WeakBag, WeakBagTicket, _weakBag_children) import qualified Data.WeakBag as WeakBag import qualified Reflex.Class @@ -1136,13 +1141,14 @@ instance HasSpiderTimeline x => Align (Event x) where #if MIN_VERSION_these(0, 8, 0) instance HasSpiderTimeline x => Semialign (Event x) where #endif - align ea eb = mapMaybe dmapToThese $ merge $ dynamicConst $ DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb] + align ea eb = mapMaybe dmapToThese $ mergeG coerce $ dynamicConst $ + DMap.fromDistinctAscList [LeftTag :=> ea, RightTag :=> eb] data DynType x p = UnsafeDyn !(BehaviorM x (PatchTarget p), Event x p) | BuildDyn !(EventM x (PatchTarget p), Event x p) | HoldDyn !(Hold x p) -newtype Dyn x p = Dyn { unDyn :: IORef (DynType 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 f d = dynamicDynIdentity $ unsafeBuildDynamic (fmap f $ readBehaviorTracked $ dynamicCurrent d) (Identity . f . runIdentity <$> dynamicUpdated d) @@ -1688,26 +1694,34 @@ cleanupCoincidenceSubscribed subscribed = do subscribeCoincidenceSubscribed :: CoincidenceSubscribed x a -> Subscriber x a -> IO WeakBagTicket subscribeCoincidenceSubscribed subscribed sub = WeakBag.insert sub (coincidenceSubscribedSubscribers subscribed) (coincidenceSubscribedWeakSelf subscribed) cleanupCoincidenceSubscribed -{-# INLINE merge #-} -merge :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity) -merge d = cacheEvent (mergeCheap d) +{-# 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) +mergeG nt d = cacheEvent (mergeCheap nt d) {-# INLINE mergeWithMove #-} -mergeWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity) -mergeWithMove d = cacheEvent (mergeCheapWithMove d) +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) +mergeWithMove nt d = cacheEvent (mergeCheapWithMove nt d) {-# INLINE [1] mergeCheap #-} -mergeCheap :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMap k (Event x)) -> Event x (DMap k Identity) -mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy +mergeCheap + :: forall k x q v. (HasSpiderTimeline x, GCompare k) + => (forall a. q a -> Event x (v a)) + -> Dynamic x (PatchDMap k q) + -> Event x (DMap k v) +mergeCheap nt = mergeGCheap' getInitialSubscribers updateMe destroy where - updateMe :: MergeUpdateFunc k x (PatchDMap k (Event x)) (MergeSubscribedParent x) + updateMe :: MergeUpdateFunc k v x (PatchDMap k q) (MergeSubscribedParent x) updateMe subscriber heightBagRef oldParents (PatchDMap p) = do let f (subscriptionsToKill, ps) (k :=> ComposeMaybe me) = do (mOldSubd, newPs) <- case me of Nothing -> return $ DMap.updateLookupWithKey (\_ _ -> Nothing) k ps Just e -> do let s = subscriber $ return k - subscription@(EventSubscription _ subd) <- subscribe e s + subscription@(EventSubscription _ subd) <- subscribe (nt e) s newParentHeight <- liftIO $ getEventSubscribedHeight subd let newParent = MergeSubscribedParent subscription liftIO $ modifyIORef' heightBagRef $ heightBagAdd newParentHeight @@ -1717,28 +1731,33 @@ mergeCheap = mergeCheap' getInitialSubscribers updateMe destroy liftIO $ modifyIORef heightBagRef $ heightBagRemove oldHeight return (maybeToList (unMergeSubscribedParent <$> mOldSubd) ++ subscriptionsToKill, newPs) foldM f ([], oldParents) $ DMap.toList p - getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParent x) + + getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParent x) getInitialSubscribers initialParents subscriber = do subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do let s = subscriber $ return k - (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s + (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s height <- liftIO $ getEventSubscribedHeight parentSubd - return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParent subscription) + return (fmap (\x -> k :=> x) parentOcc, height, k :=> MergeSubscribedParent subscription) return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers ) + destroy :: MergeDestroyFunc k (MergeSubscribedParent x) destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParent sub) -> unsubscribe sub {-# INLINE [1] mergeCheapWithMove #-} -mergeCheapWithMove :: forall k x. (HasSpiderTimeline x, GCompare k) => Dynamic x (PatchDMapWithMove k (Event x)) -> Event x (DMap k Identity) -mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy +mergeCheapWithMove :: forall k x v q. (HasSpiderTimeline x, GCompare k) + => (forall a. q a -> Event x (v a)) + -> Dynamic x (PatchDMapWithMove k q) + -> Event x (DMap k v) +mergeCheapWithMove nt = mergeGCheap' getInitialSubscribers updateMe destroy where - updateMe :: MergeUpdateFunc k x (PatchDMapWithMove k (Event x)) (MergeSubscribedParentWithMove x k) + updateMe :: MergeUpdateFunc k v x (PatchDMapWithMove k q) (MergeSubscribedParentWithMove x k) updateMe subscriber heightBagRef oldParents p = do -- Prepare new parents for insertion - let subscribeParent :: forall a. k a -> Event x a -> EventM x (MergeSubscribedParentWithMove x k a) + let subscribeParent :: forall a. k a -> Event x (v a) -> EventM x (MergeSubscribedParentWithMove x k a) subscribeParent k e = do keyRef <- liftIO $ newIORef k let s = subscriber $ liftIO $ readIORef keyRef @@ -1747,9 +1766,9 @@ mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy newParentHeight <- getEventSubscribedHeight subd modifyIORef' heightBagRef $ heightBagAdd newParentHeight return $ MergeSubscribedParentWithMove subscription keyRef - p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey subscribeParent p + p' <- PatchDMapWithMove.traversePatchDMapWithMoveWithKey (\k q -> subscribeParent k (nt q)) p -- Collect old parents for deletion and update the keys of moved parents - let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k (Event x) a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a + let moveOrDelete :: forall a. k a -> PatchDMapWithMove.NodeInfo k q a -> MergeSubscribedParentWithMove x k a -> Constant (EventM x (Maybe (EventSubscription x))) a moveOrDelete _ ni parent = Constant $ case getComposeMaybe $ PatchDMapWithMove._nodeInfo_to ni of Nothing -> do oldHeight <- liftIO $ getEventSubscribedHeight $ _eventSubscription_subscribed $ _mergeSubscribedParentWithMove_subscription parent @@ -1760,46 +1779,47 @@ mergeCheapWithMove = mergeCheap' getInitialSubscribers updateMe destroy return Nothing toDelete <- fmap catMaybes $ mapM (\(_ :=> v) -> getConstant v) $ DMap.toList $ DMap.intersectionWithKey moveOrDelete (unPatchDMapWithMove p) oldParents return (toDelete, applyAlways p' oldParents) - getInitialSubscribers :: MergeInitFunc k x (MergeSubscribedParentWithMove x k) + getInitialSubscribers :: MergeInitFunc k v q x (MergeSubscribedParentWithMove x k) getInitialSubscribers initialParents subscriber = do subscribers <- forM (DMap.toList initialParents) $ \(k :=> e) -> do keyRef <- liftIO $ newIORef k let s = subscriber $ liftIO $ readIORef keyRef - (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead e s + (subscription@(EventSubscription _ parentSubd), parentOcc) <- subscribeAndRead (nt e) s height <- liftIO $ getEventSubscribedHeight parentSubd - return (fmap (\x -> k :=> Identity x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef) + return (fmap (\x -> k :=> x) parentOcc, height, k :=> MergeSubscribedParentWithMove subscription keyRef) return ( DMap.fromDistinctAscList $ mapMaybe (\(x, _, _) -> x) subscribers , fmap (\(_, h, _) -> h) subscribers --TODO: Assert that there's no invalidHeight in here , DMap.fromDistinctAscList $ map (\(_, _, x) -> x) subscribers ) + destroy :: MergeDestroyFunc k (MergeSubscribedParentWithMove x k) destroy s = forM_ (DMap.toList s) $ \(_ :=> MergeSubscribedParentWithMove sub _) -> unsubscribe sub -type MergeUpdateFunc k x p s - = (forall a. EventM x (k a) -> Subscriber x a) +type MergeUpdateFunc k v x p s + = (forall a. EventM x (k a) -> Subscriber x (v a)) -> IORef HeightBag -> DMap k s -> p -> EventM x ([EventSubscription x], DMap k s) -type MergeInitFunc k x s - = DMap k (Event x) - -> (forall a. EventM x (k a) -> Subscriber x a) - -> EventM x (DMap k Identity, [Height], DMap k s) +type MergeInitFunc k v q x s + = DMap k q + -> (forall a. EventM x (k a) -> Subscriber x (v a)) + -> EventM x (DMap k v, [Height], DMap k s) type MergeDestroyFunc k s = DMap k s -> IO () -data Merge x k s = Merge +data Merge x k v s = Merge { _merge_parentsRef :: {-# UNPACK #-} !(IORef (DMap k s)) , _merge_heightBagRef :: {-# UNPACK #-} !(IORef HeightBag) , _merge_heightRef :: {-# UNPACK #-} !(IORef Height) - , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k Identity)) - , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k Identity)) + , _merge_sub :: {-# UNPACK #-} !(Subscriber x (DMap k v)) + , _merge_accumRef :: {-# UNPACK #-} !(IORef (DMap k v)) } -invalidateMergeHeight :: Merge x k s -> IO () +invalidateMergeHeight :: Merge x k v s -> IO () invalidateMergeHeight m = invalidateMergeHeight' (_merge_heightRef m) (_merge_sub m) invalidateMergeHeight' :: IORef Height -> Subscriber x a -> IO () @@ -1809,8 +1829,7 @@ invalidateMergeHeight' heightRef sub = do writeIORef heightRef $! invalidHeight subscriberInvalidateHeight sub oldHeight - -revalidateMergeHeight :: Merge x k s -> IO () +revalidateMergeHeight :: Merge x k v s -> IO () revalidateMergeHeight m = do currentHeight <- readIORef $ _merge_heightRef m when (currentHeight == invalidHeight) $ do -- revalidateMergeHeight may be called multiple times; perhaps the's a way to finesse it to avoid this check @@ -1826,19 +1845,19 @@ revalidateMergeHeight m = do subscriberRecalculateHeight (_merge_sub m) height GT -> error $ "revalidateMergeHeight: more heights (" <> show (heightBagSize heights) <> ") than parents (" <> show (DMap.size parents) <> ") for Merge" -scheduleMergeSelf :: HasSpiderTimeline x => Merge x k s -> Height -> EventM x () +scheduleMergeSelf :: HasSpiderTimeline x => Merge x k v s -> Height -> EventM x () scheduleMergeSelf m height = scheduleMerge' height (_merge_heightRef m) $ do vals <- liftIO $ readIORef $ _merge_accumRef m liftIO $ writeIORef (_merge_accumRef m) $! DMap.empty -- Once we're done with this, we can clear it immediately, because if there's a cacheEvent in front of us, it'll handle subsequent subscribers, and if not, we won't get subsequent subscribers --TODO: Assert that m is not empty subscriberPropagate (_merge_sub m) vals -mergeSubscriber :: forall x k s a. (HasSpiderTimeline x, GCompare k) => Merge x k s -> EventM x (k a) -> Subscriber x a +mergeSubscriber :: forall x k v s a. (HasSpiderTimeline x, GCompare k) => Merge x k v s -> EventM x (k a) -> Subscriber x (v a) mergeSubscriber m getKey = Subscriber { subscriberPropagate = \a -> do oldM <- liftIO $ readIORef $ _merge_accumRef m k <- getKey - let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k (Identity a) oldM + let newM = DMap.insertWith (error $ "Same key fired multiple times for Merge") k a oldM tracePropagate (Proxy :: Proxy x) $ " DMap.size oldM = " <> show (DMap.size oldM) <> "; DMap.size newM = " <> show (DMap.size newM) liftIO $ writeIORef (_merge_accumRef m) $! newM when (DMap.null oldM) $ do -- Only schedule the firing once @@ -1869,7 +1888,7 @@ mergeSubscriber m getKey = Subscriber } --TODO: Be able to run as much of this as possible promptly -updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k s -> MergeUpdateFunc k x p s -> p -> SomeMergeUpdate x +updateMerge :: (HasSpiderTimeline x, GCompare k) => Merge x k v s -> MergeUpdateFunc k v x p s -> p -> SomeMergeUpdate x updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) (revalidateMergeHeight m) where updateMe = do oldParents <- liftIO $ readIORef $ _merge_parentsRef m @@ -1877,9 +1896,10 @@ updateMerge m updateFunc p = SomeMergeUpdate updateMe (invalidateMergeHeight m) liftIO $ writeIORef (_merge_parentsRef m) $! newParents return subscriptionsToKill -{-# INLINE mergeCheap' #-} -mergeCheap' :: forall k x p s. (HasSpiderTimeline x, GCompare k, PatchTarget p ~ DMap k (Event x)) => MergeInitFunc k x s -> MergeUpdateFunc k x p s -> MergeDestroyFunc k s -> Dynamic x p -> Event x (DMap k Identity) -mergeCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do +{-# 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) +mergeGCheap' getInitialSubscribers updateFunc destroy d = Event $ \sub -> do initialParents <- readBehaviorUntracked $ dynamicCurrent d accumRef <- liftIO $ newIORef $ error "merge: accumRef not yet initialized" heightRef <- liftIO $ newIORef $ error "merge: heightRef not yet initialized" @@ -2462,7 +2482,7 @@ unsafeNewSpiderTimelineEnv = do newSpiderTimeline :: IO (Some SpiderTimelineEnv) newSpiderTimeline = withSpiderTimeline (pure . Some.This) -data LocalSpiderTimeline x s +data LocalSpiderTimeline (x :: Type) s instance Reifies s (SpiderTimelineEnv x) => HasSpiderTimeline (LocalSpiderTimeline x s) where @@ -2480,11 +2500,11 @@ withSpiderTimeline k = do env <- unsafeNewSpiderTimelineEnv reify env $ \s -> k $ localSpiderTimeline s env -newtype SpiderPullM x a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix) +newtype SpiderPullM (x :: Type) a = SpiderPullM (BehaviorM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix) type ComputeM = EventM -newtype SpiderPushM x a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix) +newtype SpiderPushM (x :: Type) a = SpiderPushM (ComputeM x a) deriving (Functor, Applicative, Monad, MonadIO, MonadFix) instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where {-# SPECIALIZE instance R.Reflex (SpiderTimeline Global) #-} @@ -2504,8 +2524,13 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent {-# INLINABLE pull #-} pull = SpiderBehavior . pull . coerce - {-# INLINABLE merge #-} - merge = SpiderEvent . merge . dynamicConst . (coerce :: DMap k (R.Event (SpiderTimeline x)) -> DMap k (Event x)) + {-# INLINABLE mergeG #-} + mergeG + :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k + => (forall a. q a -> R.Event (SpiderTimeline x) (v a)) + -> DMap k q + -> R.Event (SpiderTimeline x) (DMap k v) + mergeG nt = SpiderEvent . mergeG (unSpiderEvent #. nt) . dynamicConst {-# INLINABLE fan #-} fan e = R.EventSelector $ SpiderEvent . select (fan (unSpiderEvent e)) {-# INLINABLE switch #-} @@ -2520,10 +2545,10 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where unsafeBuildDynamic readV0 v' = SpiderDynamic $ dynamicDynIdentity $ unsafeBuildDynamic (coerce readV0) $ coerce $ unSpiderEvent v' {-# INLINABLE unsafeBuildIncremental #-} unsafeBuildIncremental readV0 dv = SpiderIncremental $ dynamicDyn $ unsafeBuildDynamic (coerce readV0) $ unSpiderEvent dv - {-# INLINABLE mergeIncremental #-} - mergeIncremental = SpiderEvent . merge . (unsafeCoerce :: Dynamic x (PatchDMap k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMap k (Event x))) . unSpiderIncremental - {-# INLINABLE mergeIncrementalWithMove #-} - mergeIncrementalWithMove = SpiderEvent . mergeWithMove . (unsafeCoerce :: Dynamic x (PatchDMapWithMove k (R.Event (SpiderTimeline x))) -> Dynamic x (PatchDMapWithMove k (Event x))) . unSpiderIncremental + {-# INLINABLE mergeIncrementalG #-} + mergeIncrementalG nt = SpiderEvent #. mergeG (coerce #. nt) .# unSpiderIncremental + {-# INLINABLE mergeIncrementalWithMoveG #-} + mergeIncrementalWithMoveG nt = SpiderEvent #. mergeWithMove (coerce #. nt) .# unSpiderIncremental {-# INLINABLE currentIncremental #-} currentIncremental = SpiderBehavior . dynamicCurrent . unSpiderIncremental {-# INLINABLE updatedIncremental #-} @@ -2561,7 +2586,7 @@ instance MonadAtomicRef (EventM x) where atomicModifyRef r f = liftIO $ atomicModifyRef r f -- | The monad for actions that manipulate a Spider timeline identified by @x@ -newtype SpiderHost x a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException) +newtype SpiderHost (x :: Type) a = SpiderHost { unSpiderHost :: IO a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException) instance Monad (SpiderHost x) where {-# INLINABLE (>>=) #-} @@ -2583,7 +2608,7 @@ runSpiderHost (SpiderHost a) = a runSpiderHostForTimeline :: SpiderHost x a -> SpiderTimelineEnv x -> IO a runSpiderHostForTimeline (SpiderHost a) _ = a -newtype SpiderHostFrame x a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } +newtype SpiderHostFrame (x :: Type) a = SpiderHostFrame { runSpiderHostFrame :: EventM x a } deriving (Functor, Applicative, MonadFix, MonadIO, MonadException, MonadAsyncException) instance Monad (SpiderHostFrame x) where diff --git a/test/GC.hs b/test/GC.hs index cc0c343f..85be7bde 100644 --- a/test/GC.hs +++ b/test/GC.hs @@ -27,6 +27,7 @@ import qualified Reflex.Spider.Internal as S import System.Exit import System.Mem +import Data.Coerce main :: IO () main = do @@ -46,7 +47,7 @@ hostPerf ref = S.runSpiderHost $ do eventToPerform <- Host.runHostFrame $ do (reqMap :: S.Event S.Global (DMap (Const2 Int (DMap Tell (S.SpiderHostFrame S.Global))) Identity)) <- S.SpiderHostFrame - $ fmap ( S.merge + $ fmap ( S.mergeG coerce . S.dynamicHold) $ S.hold DMap.empty -- Construct a new heap object for the subscriber, invalidating any weak references to the subscriber if they are not retained From 5feea4250ea637e6c1514f0600036156e3b022b9 Mon Sep 17 00:00:00 2001 From: David Feuer Date: Sat, 13 Jul 2019 15:54:42 -0400 Subject: [PATCH 2/2] Distribute more generally --- src/Reflex/Class.hs | 18 ++++++++++++++---- 1 file changed, 14 insertions(+), 4 deletions(-) diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 08f4bc2a..33927985 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -88,6 +88,7 @@ module Reflex.Class , gate -- ** Combining 'Dynamic's , distributeDMapOverDynPure + , distributeDMapOverDynPureG , distributeListOverDyn , distributeListOverDynWith , zipDyn @@ -1091,12 +1092,21 @@ instance (Reflex t, Monoid a) => Monoid (Dynamic t a) where -- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same -- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators. distributeDMapOverDynPure :: forall t k. (Reflex t, GCompare k) => DMap k (Dynamic t) -> Dynamic t (DMap k Identity) -distributeDMapOverDynPure dm = case DMap.toList dm of +distributeDMapOverDynPure = distributeDMapOverDynPureG coerceDynamic + +-- | This function converts a 'DMap' whose elements are 'Dynamic's into a +-- 'Dynamic' 'DMap'. Its implementation is more efficient than doing the same +-- through the use of multiple uses of 'zipDynWith' or 'Applicative' operators. +distributeDMapOverDynPureG + :: forall t k q v. (Reflex t, GCompare k) + => (forall a. q a -> Dynamic t (v a)) + -> DMap k q -> Dynamic t (DMap k v) +distributeDMapOverDynPureG nt dm = case DMap.toList dm of [] -> constDyn DMap.empty - [k :=> v] -> fmap (DMap.singleton k . Identity) v + [k :=> v] -> DMap.singleton k <$> nt v _ -> - let getInitial = DMap.traverseWithKey (\_ -> fmap Identity . sample . current) dm - edmPre = merge $ DMap.map updated dm + let getInitial = DMap.traverseWithKey (\_ -> sample . current . nt) dm + edmPre = mergeG getCompose $ DMap.map (Compose . updated . nt) dm result = unsafeBuildDynamic getInitial $ flip pushAlways edmPre $ \news -> do olds <- sample $ current result return $ DMap.unionWithKey (\_ _ new -> new) olds news