Revert "Generalize fan following DMap (#318)"

This reverts commit 13e76bb.

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  

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 }

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

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

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,15 +2557,15 @@ 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
     => (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 #-}
   switch = SpiderEvent . switch . (coerce :: Behavior x (R.Event (SpiderTimeline x) a) -> Behavior x (Event x a)) . unSpiderBehavior
   {-# INLINABLE coincidence #-}

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