Merge pull request #320 from treeowl/canhazmerge

Generalize merge(s) to allow non Identity functors in DMap.

Author: oliver-batchelor

ChangeLog.md

@@ -1,7 +1,17 @@
 # Revision history for reflex
 
+## Unreleased
+
+* 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  
+  These produce `DMap`s  whose values needn't be `Identity`.
 * Stop using the now-deprecated `*Tag` classes (e.g., `ShowTag`).
 * Fix `holdDyn` so that it is lazy in its event argument.
 

reflex.cabal

@@ -49,6 +49,7 @@ library
     data-default >= 0.5 && < 0.8,
     dependent-map >= 0.3 && < 0.4,
     exception-transformers == 0.4.*,
+    profunctors,
     lens >= 4.7 && < 5,
     monad-control >= 1.0.1 && < 1.1,
     monoidal-containers == 0.4.*,

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
@@ -84,6 +88,7 @@ module Reflex.Class
   , gate
     -- ** Combining 'Dynamic's
   , distributeDMapOverDynPure
+  , distributeDMapOverDynPureG
   , distributeListOverDyn
   , distributeListOverDynWith
   , zipDyn
@@ -255,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
@@ -277,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'
@@ -1079,12 +1091,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
@@ -1557,6 +1578,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

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,17 +135,19 @@ 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)
   current (Dynamic_Profiled d) = coerce $ current d
   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

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