From 04403d3e2a208c5634ee1229aa0cbb89803c2af9 Mon Sep 17 00:00:00 2001 From: Matthew Bauer Date: Fri, 31 Jan 2020 16:26:46 -0500 Subject: [PATCH] Revert "Generalize fan following DMap (#318)" This reverts commit 13e76bb3db6566cdd9e51544ea456eee807ed302. --- ChangeLog.md | 4 --- src/Reflex/Class.hs | 34 +++--------------------- src/Reflex/Profiled.hs | 2 +- src/Reflex/Pure.hs | 6 ++--- src/Reflex/Spider/Internal.hs | 50 +++++++++++++++++------------------ test/GC.hs | 4 +-- 6 files changed, 33 insertions(+), 67 deletions(-) diff --git a/ChangeLog.md b/ChangeLog.md index d802c075..c1a74f5c 100644 --- a/ChangeLog.md +++ b/ChangeLog.md @@ -16,16 +16,12 @@ ## 0.6.2.1 -* Generalize `fan` to `fanG` to take a `DMap` with non-`Identity` - values. - * Generalize merging functions: `merge` to `mergeG`, `mergeIncremental` to `mergeIncrementalG`, `distributeDMapOverDynPure` to `distributeDMapOverDynPureG`, `mergeIncrementalWithMove` to `mergeIncrementalWithMoveG`. - ## 0.6.2.0 * Fix `holdDyn` so that it is lazy in its event argument diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs index 4d81a1b9..35897faf 100644 --- a/src/Reflex/Class.hs +++ b/src/Reflex/Class.hs @@ -41,7 +41,6 @@ module Reflex.Class , MonadHold (..) -- ** 'fan' related types , EventSelector (..) - , EventSelectorG (..) , EventSelectorInt (..) -- * Convenience functions , constDyn @@ -65,7 +64,6 @@ module Reflex.Class , alignEventWithMaybe -- ** Breaking up 'Event's , splitE - , fan , fanEither , fanThese , fanMap @@ -273,16 +271,13 @@ 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 - - --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 'selectG' on the result to + -- result in a @let@-binding, and then repeatedly 'select' on the result to -- create child events - fanG :: GCompare k => Event t (DMap k v) -> EventSelectorG t k v - + fan :: GCompare k => Event t (DMap k Identity) -> EventSelector t k -- | Create an 'Event' that will occur whenever the currently-selected input -- 'Event' occurs switch :: Behavior t (Event t a) -> Event t a @@ -330,18 +325,6 @@ class ( MonadHold t (PushM t) mergeIntIncremental :: Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a) fanInt :: Event t (IntMap a) -> EventSelectorInt t a --- | 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 -fan :: forall t k. (Reflex t, GCompare k) - => Event t (DMap k Identity) -> EventSelector t k - --TODO: Can we help enforce the partial application discipline here? The combinator is worthless without it -fan e = EventSelector (fixup (selectG (fanG e) :: k a -> Event t (Identity a)) :: forall a. k a -> Event t a) - where - fixup :: forall a. (k a -> Event t (Identity a)) -> k a -> Event t a - fixup = case eventCoercion Coercion :: Coercion (Event t (Identity a)) (Event t a) of - Coercion -> coerce - --TODO: Specialize this so that we can take advantage of knowing that there's no changing going on -- | Constructs a single 'Event' out of a map of events. The output event may fire with multiple -- keys simultaneously. @@ -535,17 +518,6 @@ newtype EventSelector t k = EventSelector select :: forall a. k a -> Event t a } -newtype EventSelectorG t k v = EventSelectorG - { -- | Retrieve the 'Event' for the given key. The type of the 'Event' is - -- determined by the type of the key, so this can be used to fan-out - -- 'Event's whose sub-'Event's have different types. - -- - -- Using 'EventSelector's and the 'fan' primitive is far more efficient than - -- (but equivalent to) using 'mapMaybe' to select only the relevant - -- occurrences of an 'Event'. - selectG :: forall a. k a -> Event t (v a) - } - -- | Efficiently select an 'Event' keyed on 'Int'. This is more efficient than manually -- filtering by key. newtype EventSelectorInt t a = EventSelectorInt { selectInt :: Int -> Event t a } diff --git a/src/Reflex/Profiled.hs b/src/Reflex/Profiled.hs index db9aa829..7aafd867 100644 --- a/src/Reflex/Profiled.hs +++ b/src/Reflex/Profiled.hs @@ -136,11 +136,11 @@ 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 - fanG (Event_Profiled e) = EventSelectorG $ coerce $ selectG (fanG $ profileEvent e) 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) current (Dynamic_Profiled d) = coerce $ current d diff --git a/src/Reflex/Pure.hs b/src/Reflex/Pure.hs index cc9188ec..1d12aed9 100644 --- a/src/Reflex/Pure.hs +++ b/src/Reflex/Pure.hs @@ -7,7 +7,6 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE PolyKinds #-} - #ifdef USE_REFLEX_OPTIMIZER {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} #endif @@ -34,6 +33,7 @@ module Reflex.Pure import Control.Monad import Data.Dependent.Map (DMap, GCompare) import qualified Data.Dependent.Map as DMap +import Data.Functor.Identity import Data.IntMap (IntMap) import qualified Data.IntMap as IntMap import Data.Maybe @@ -88,8 +88,8 @@ instance (Enum t, HasTrie t, Ord t) => Reflex (Pure t) where then Nothing else Just currentOccurrences - -- fanG :: GCompare k => Event (Pure t) (DMap k v) -> EventSelectorG (Pure t) k v - fanG e = EventSelectorG $ \k -> Event $ \t -> unEvent e t >>= DMap.lookup k + fan :: GCompare k => Event (Pure t) (DMap k Identity) -> EventSelector (Pure t) k + fan e = EventSelector $ \k -> Event $ \t -> unEvent e t >>= fmap runIdentity . DMap.lookup k switch :: Behavior (Pure t) (Event (Pure t) a) -> Event (Pure t) a switch b = Event $ memo $ \t -> unEvent (unBehavior b t) t diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs index db8f25f0..f7267ea8 100644 --- a/src/Reflex/Spider/Internal.hs +++ b/src/Reflex/Spider/Internal.hs @@ -20,7 +20,6 @@ {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE InstanceSigs #-} - #ifdef USE_REFLEX_OPTIMIZER {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-} #endif @@ -388,7 +387,7 @@ eventRoot !k !r = Event $ wrap eventSubscribedRoot $ liftIO . getRootSubscribed eventNever :: Event x a eventNever = Event $ \_ -> return (EventSubscription (return ()) eventSubscribedNever, Nothing) -eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k v -> Event x (v a) +eventFan :: (GCompare k, HasSpiderTimeline x) => k a -> Fan x k -> Event x a eventFan !k !f = Event $ wrap eventSubscribedFan $ getFanSubscribed k f eventSwitch :: HasSpiderTimeline x => Switch x a -> Event x a @@ -440,14 +439,14 @@ newSubscriberHold h = return $ Subscriber , subscriberRecalculateHeight = \_ -> return () } -newSubscriberFan :: forall x k v. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k v -> IO (Subscriber x (DMap k v)) +newSubscriberFan :: forall x k. (HasSpiderTimeline x, GCompare k) => FanSubscribed x k -> IO (Subscriber x (DMap k Identity)) newSubscriberFan subscribed = return $ Subscriber { subscriberPropagate = \a -> {-# SCC "traverseFan" #-} do subs <- liftIO $ readIORef $ fanSubscribedSubscribers subscribed tracePropagate (Proxy :: Proxy x) $ "SubscriberFan" <> showNodeId subscribed <> ": " ++ show (DMap.size subs) ++ " keys subscribed, " ++ show (DMap.size a) ++ " keys firing" liftIO $ writeIORef (fanSubscribedOccurrence subscribed) $ Just a scheduleClear $ fanSubscribedOccurrence subscribed - let f _ (Pair v subsubs) = do + let f _ (Pair (Identity v) subsubs) = do propagate v $ _fanSubscribedChildren_list subsubs return $ Constant () _ <- DMap.traverseWithKey f $ DMap.intersectionWithKey (\_ -> Pair) a subs --TODO: Would be nice to have DMap.traverse_ @@ -600,7 +599,7 @@ eventSubscribedNever = EventSubscribed #endif } -eventSubscribedFan :: FanSubscribed x k v -> EventSubscribed x +eventSubscribedFan :: FanSubscribed x k -> EventSubscribed x eventSubscribedFan !subscribed = EventSubscribed { eventSubscribedHeightRef = eventSubscribedHeightRef $ _eventSubscription_subscribed $ fanSubscribedParent subscribed , eventSubscribedRetained = toAny subscribed @@ -1018,7 +1017,7 @@ data RootSubscribed x a = forall k. GCompare k => RootSubscribed #endif } -data Root x k +data Root x (k :: * -> *) = Root { rootOccurrence :: !(IORef (DMap k Identity)) -- The currently-firing occurrence of this event , rootSubscribed :: !(IORef (DMap k (RootSubscribed x))) , rootInit :: !(forall a. k a -> RootTrigger x a -> IO (IO ())) @@ -1088,25 +1087,25 @@ heightBagVerify b@(HeightBag s c) = if heightBagVerify = id #endif -data FanSubscribedChildren x k v a = FanSubscribedChildren - { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x (v a))) - , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k v) - , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k v))) +data FanSubscribedChildren (x :: *) k a = FanSubscribedChildren + { _fanSubscribedChildren_list :: !(WeakBag (Subscriber x a)) + , _fanSubscribedChildren_self :: {-# NOUNPACK #-} !(k a, FanSubscribed x k) + , _fanSubscribedChildren_weakSelf :: !(IORef (Weak (k a, FanSubscribed x k))) } -data FanSubscribed x k v - = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k v))) - , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k v))) - , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k v))) -- This DMap should never be empty +data FanSubscribed (x :: *) k + = FanSubscribed { fanSubscribedCachedSubscribed :: !(IORef (Maybe (FanSubscribed x k))) + , fanSubscribedOccurrence :: !(IORef (Maybe (DMap k Identity))) + , fanSubscribedSubscribers :: !(IORef (DMap k (FanSubscribedChildren x k))) -- This DMap should never be empty , fanSubscribedParent :: !(EventSubscription x) #ifdef DEBUG_NODEIDS , fanSubscribedNodeId :: Int #endif } -data Fan x k v - = Fan { fanParent :: !(Event x (DMap k v)) - , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k v))) +data Fan x k + = Fan { fanParent :: !(Event x (DMap k Identity)) + , fanSubscribed :: !(IORef (Maybe (FanSubscribed x k))) } data SwitchSubscribed x a @@ -1560,7 +1559,7 @@ fanInt p = return (EventSubscription (FastWeakBag.remove t) $! EventSubscribed heightRef $! toAny (_fanInt_subscriptionRef self, t), IntMap.lookup k currentOcc) {-# INLINABLE getFanSubscribed #-} -getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k v -> Subscriber x (v a) -> EventM x (WeakBagTicket, FanSubscribed x k v, Maybe (v a)) +getFanSubscribed :: (HasSpiderTimeline x, GCompare k) => k a -> Fan x k -> Subscriber x a -> EventM x (WeakBagTicket, FanSubscribed x k, Maybe a) getFanSubscribed k f sub = do mSubscribed <- liftIO $ readIORef $ fanSubscribed f case mSubscribed of @@ -1594,7 +1593,7 @@ getFanSubscribed k f sub = do liftIO $ writeIORef (fanSubscribed f) $ Just subscribed return (slnForSub, subscribed, coerce $ DMap.lookup k =<< parentOcc) -cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k v) -> IO () +cleanupFanSubscribed :: GCompare k => (k a, FanSubscribed x k) -> IO () cleanupFanSubscribed (k, subscribed) = do subscribers <- readIORef $ fanSubscribedSubscribers subscribed let reducedSubscribers = DMap.delete k subscribers @@ -1606,7 +1605,7 @@ cleanupFanSubscribed (k, subscribed) = do else writeIORef (fanSubscribedSubscribers subscribed) $! reducedSubscribers {-# INLINE subscribeFanSubscribed #-} -subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k v -> Subscriber x (v a) -> IO WeakBagTicket +subscribeFanSubscribed :: GCompare k => k a -> FanSubscribed x k -> Subscriber x a -> IO WeakBagTicket subscribeFanSubscribed k subscribed sub = do subscribers <- readIORef $ fanSubscribedSubscribers subscribed case DMap.lookup k subscribers of @@ -2082,15 +2081,14 @@ mergeIntCheap d = Event $ \sub -> do ) newtype EventSelector x k = EventSelector { select :: forall a. k a -> Event x a } -newtype EventSelectorG x k v = EventSelectorG { selectG :: forall a. k a -> Event x (v a) } -fanG :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k v) -> EventSelectorG x k v -fanG e = +fan :: (HasSpiderTimeline x, GCompare k) => Event x (DMap k Identity) -> EventSelector x k +fan e = let f = Fan { fanParent = e , fanSubscribed = unsafeNewIORef e Nothing } - in EventSelectorG $ \k -> eventFan k f + in EventSelector $ \k -> eventFan k f runHoldInits :: HasSpiderTimeline x => IORef [SomeHoldInit x] -> IORef [SomeDynInit x] -> IORef [SomeMergeInit x] -> EventM x () runHoldInits holdInitRef dynInitRef mergeInitRef = do @@ -2559,8 +2557,6 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where pushCheap f = SpiderEvent . pushCheap (coerce f) . unSpiderEvent {-# INLINABLE pull #-} pull = SpiderBehavior . pull . coerce - {-# INLINABLE fanG #-} - fanG e = R.EventSelectorG $ SpiderEvent . selectG (fanG (unSpiderEvent e)) {-# INLINABLE mergeG #-} mergeG :: forall (k :: k2 -> *) q (v :: k2 -> *). GCompare k @@ -2568,6 +2564,8 @@ instance HasSpiderTimeline x => R.Reflex (SpiderTimeline x) where -> 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 #-} switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior {-# INLINABLE coincidence #-} diff --git a/test/GC.hs b/test/GC.hs index 0fabf7cb..85be7bde 100644 --- a/test/GC.hs +++ b/test/GC.hs @@ -56,8 +56,8 @@ hostPerf ref = S.runSpiderHost $ do { S.subscriberPropagate = S.subscriberPropagate sub } return (s, o)) - $ runIdentity . runIdentity <$> S.selectG - (S.fanG $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response) + $ runIdentity <$> S.select + (S.fan $ S.pushCheap (return . Just . mapKeyValuePairsMonotonic (\(t :=> e) -> WrapArg t :=> Identity e)) response) (WrapArg Request) return $ alignWith (mergeThese (<>)) (flip S.pushCheap eadd $ \_ -> return $ Just $ DMap.singleton Request $ do