From d4840d7e2b2059842b424c63b25116de0122684e Mon Sep 17 00:00:00 2001
From: Oliver Batchelor <saulzar@gmail.com>
Date: Sun, 5 Aug 2018 22:16:52 +1200
Subject: [PATCH] Add buildIncremental

Add mapIncremental (Monadic, not unsafe)

Add some basic tests for mapIncremental
---
 src/Reflex/Class.hs             | 18 ++++++++++++---
 src/Reflex/PerformEvent/Base.hs |  2 ++
 src/Reflex/Profiled.hs          |  1 +
 src/Reflex/Pure.hs              |  3 +++
 src/Reflex/Spider/Internal.hs   | 21 +++++++++++++++++
 test/Reflex/Plan/Pure.hs        |  2 ++
 test/Reflex/Test/Micro.hs       | 41 +++++++++++++++++++++++++++++++++
 7 files changed, 85 insertions(+), 3 deletions(-)

diff --git a/src/Reflex/Class.hs b/src/Reflex/Class.hs
index c4bae6f4..55d50905 100644
--- a/src/Reflex/Class.hs
+++ b/src/Reflex/Class.hs
@@ -38,6 +38,7 @@ module Reflex.Class
   , EventSelector (..)
   , EventSelectorInt (..)
     -- ** 'Incremental'-related types
+  , mapIncremental
     -- * Convenience functions
   , constDyn
   , pushAlways
@@ -339,11 +340,18 @@ class MonadSample t m => MonadHold t m where
   holdIncremental :: Patch p => PatchTarget p -> Event t p -> m (Incremental t p)
   default holdIncremental :: (Patch p, m ~ f m', MonadTrans f, MonadHold t m') => PatchTarget p -> Event t p -> m (Incremental t p)
   holdIncremental v0 = lift . holdIncremental v0
+
+  buildIncremental :: Patch p => PushM t (PatchTarget p) -> Event t p -> m (Incremental t p)
+  default buildIncremental :: (m ~ f m', MonadTrans f, MonadHold t m', Patch p) => PushM t (PatchTarget p) -> Event t p -> m (Incremental t p)
+  buildIncremental getV0 = lift . buildIncremental getV0
+
+  -- | Create a 'Dynamic' from a 'PushM' (which allows sampling from Behaviors
+  -- and holding 'Events') and an 'Event'
   buildDynamic :: PushM t a -> Event t a -> m (Dynamic t a)
-  {-
-  default buildDynamic :: (m ~ f m', MonadTrans f, MonadHold t m') => PullM t a -> Event t a -> m (Dynamic t a)
+
+  default buildDynamic :: (m ~ f m', MonadTrans f, MonadHold t m') => PushM t a -> Event t a -> m (Dynamic t a)
   buildDynamic getV0 = lift . buildDynamic getV0
-  -}
+
   -- | Create a new 'Event' that only occurs only once, on the first occurrence of
   -- the supplied 'Event'.
   headE :: Event t a -> m (Event t a)
@@ -738,6 +746,10 @@ mergeList es = mergeWithFoldCheap' id es
 unsafeMapIncremental :: (Reflex t, Patch p, Patch p') => (PatchTarget p -> PatchTarget p') -> (p -> p') -> Incremental t p -> Incremental t p'
 unsafeMapIncremental f g a = unsafeBuildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a
 
+
+mapIncremental :: (Reflex t, Patch p, Patch p', MonadHold t m) => (PatchTarget p -> PatchTarget p') -> (p -> p') -> Incremental t p -> m (Incremental t p')
+mapIncremental f g a = buildIncremental (fmap f $ sample $ currentIncremental a) $ g <$> updatedIncremental a
+
 -- | Create a new 'Event' combining the map of 'Event's into an 'Event' that
 -- occurs if at least one of them occurs and has a map of values of all 'Event's
 -- occurring at that time.
diff --git a/src/Reflex/PerformEvent/Base.hs b/src/Reflex/PerformEvent/Base.hs
index b0d24883..472529bf 100644
--- a/src/Reflex/PerformEvent/Base.hs
+++ b/src/Reflex/PerformEvent/Base.hs
@@ -162,6 +162,8 @@ instance (ReflexHost t, MonadHold t m) => MonadHold t (PerformEventT t m) where
   holdIncremental v0 v' = lift $ holdIncremental v0 v'
   {-# INLINABLE buildDynamic #-}
   buildDynamic getV0 v' = lift $ buildDynamic getV0 v'
+  {-# INLINABLE buildIncremental #-}
+  buildIncremental getV0 v' = lift $ buildIncremental getV0 v'
   {-# INLINABLE headE #-}
   headE = lift . headE
 
diff --git a/src/Reflex/Profiled.hs b/src/Reflex/Profiled.hs
index 56d5ba1c..ddf78b4f 100644
--- a/src/Reflex/Profiled.hs
+++ b/src/Reflex/Profiled.hs
@@ -157,6 +157,7 @@ instance MonadHold t m => MonadHold (ProfiledTimeline t) (ProfiledM m) where
   holdDyn v0 (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> holdDyn v0 v'
   holdIncremental v0 (Event_Profiled v') = ProfiledM $ Incremental_Profiled <$> holdIncremental v0 v'
   buildDynamic (ProfiledM v0) (Event_Profiled v') = ProfiledM $ Dynamic_Profiled <$> buildDynamic v0 v'
+  buildIncremental (ProfiledM v0) (Event_Profiled v') = ProfiledM $ Incremental_Profiled <$> buildIncremental v0 v'
   headE (Event_Profiled e) = ProfiledM $ Event_Profiled <$> headE e
 
 instance MonadSample t m => MonadSample (ProfiledTimeline t) (ProfiledM m) where
diff --git a/src/Reflex/Pure.hs b/src/Reflex/Pure.hs
index 05bff9f3..2bc8d4fd 100644
--- a/src/Reflex/Pure.hs
+++ b/src/Reflex/Pure.hs
@@ -204,3 +204,6 @@ instance (Enum t, HasTrie t, Ord t) => MonadHold (Pure t) ((->) t) where
                    Just x -> fromMaybe lastValue $ apply x lastValue
 
   headE = slowHeadE
+
+  buildIncremental :: Patch p => (t -> PatchTarget p) -> Event (Pure t) p -> t -> Incremental (Pure t) p
+  buildIncremental initialValue e initialTime = holdIncremental (initialValue initialTime) e initialTime
diff --git a/src/Reflex/Spider/Internal.hs b/src/Reflex/Spider/Internal.hs
index 7ba27228..990c385e 100644
--- a/src/Reflex/Spider/Internal.hs
+++ b/src/Reflex/Spider/Internal.hs
@@ -1167,6 +1167,8 @@ buildDynamic readV0 v' = do
   defer $ SomeDynInit d
   return d
 
+
+
 unsafeBuildDynamic :: BehaviorM x (PatchTarget p) -> Event x p -> Dyn x p
 unsafeBuildDynamic readV0 v' = Dyn $ unsafeNewIORef x $ UnsafeDyn x
   where x = (readV0, v')
@@ -2261,6 +2263,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Event
   holdIncremental = holdIncrementalSpiderEventM
   {-# INLINABLE buildDynamic #-}
   buildDynamic = buildDynamicSpiderEventM
+  {-# INLINABLE buildIncremental #-}
+  buildIncremental = buildIncrementalSpiderEventM
   {-# INLINABLE headE #-}
   headE = R.slowHeadE
 --  headE (SpiderEvent e) = SpiderEvent <$> Reflex.Spider.Internal.headE e
@@ -2282,6 +2286,10 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide
   holdIncremental v0 (SpiderEvent e) = SpiderPushM $ SpiderIncremental . dynamicHold <$> Reflex.Spider.Internal.hold v0 e
   {-# INLINABLE buildDynamic #-}
   buildDynamic getV0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce e
+
+  {-# INLINABLE buildIncremental #-}
+  buildIncremental getV0 (SpiderEvent e) = SpiderPushM $ fmap (SpiderIncremental . dynamicDyn) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) (coerce e)
+
   {-# INLINABLE headE #-}
   headE = R.slowHeadE
 --  headE (SpiderEvent e) = SpiderPushM $ SpiderEvent <$> Reflex.Spider.Internal.headE e
@@ -2331,6 +2339,10 @@ holdIncrementalSpiderEventM v0 e = fmap (SpiderIncremental . dynamicHold) $ Refl
 buildDynamicSpiderEventM :: HasSpiderTimeline x => SpiderPushM x a -> Reflex.Class.Event (SpiderTimeline x) a -> EventM x (Reflex.Class.Dynamic (SpiderTimeline x) a)
 buildDynamicSpiderEventM getV0 e = fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e
 
+buildIncrementalSpiderEventM :: (HasSpiderTimeline x, Patch p) => SpiderPushM x (PatchTarget p) -> Reflex.Class.Event (SpiderTimeline x) p -> EventM x (Reflex.Class.Incremental (SpiderTimeline x) p)
+buildIncrementalSpiderEventM getV0 e = fmap (SpiderIncremental . dynamicDyn) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e
+
+
 instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (SpiderHost x) where
   {-# INLINABLE hold #-}
   hold v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.hold v0 e
@@ -2340,6 +2352,10 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide
   holdIncremental v0 e = runFrame . runSpiderHostFrame $ Reflex.Class.holdIncremental v0 e
   {-# INLINABLE buildDynamic #-}
   buildDynamic getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildDynamic getV0 e
+
+  {-# INLINABLE buildIncremental #-}
+  buildIncremental getV0 e = runFrame . runSpiderHostFrame $ Reflex.Class.buildIncremental getV0 e
+
   {-# INLINABLE headE #-}
   headE e = runFrame . runSpiderHostFrame $ Reflex.Class.headE e
 
@@ -2355,6 +2371,8 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Spide
   holdIncremental v0 e = SpiderHostFrame $ fmap (SpiderIncremental . dynamicHold) $ Reflex.Spider.Internal.hold v0 $ unSpiderEvent e
   {-# INLINABLE buildDynamic #-}
   buildDynamic getV0 e = SpiderHostFrame $ fmap (SpiderDynamic . dynamicDynIdentity) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e
+  {-# INLINABLE buildIncremental #-}
+  buildIncremental getV0 e = SpiderHostFrame $ fmap (SpiderIncremental . dynamicDyn) $ Reflex.Spider.Internal.buildDynamic (coerce getV0) $ coerce $ unSpiderEvent e
   {-# INLINABLE headE #-}
   headE = R.slowHeadE
 --  headE (SpiderEvent e) = SpiderHostFrame $ SpiderEvent <$> Reflex.Spider.Internal.headE e
@@ -2376,6 +2394,9 @@ instance HasSpiderTimeline x => Reflex.Class.MonadHold (SpiderTimeline x) (Refle
   holdIncremental v0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.holdIncremental v0 e
   {-# INLINABLE buildDynamic #-}
   buildDynamic getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildDynamic getV0 e
+  {-# INLINABLE buildIncremental #-}
+  buildIncremental getV0 e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.buildIncremental getV0 e
+
   {-# INLINABLE headE #-}
   headE e = Reflex.Spider.Internal.ReadPhase $ Reflex.Class.headE e
 
diff --git a/test/Reflex/Plan/Pure.hs b/test/Reflex/Plan/Pure.hs
index a595b811..d38c9c33 100644
--- a/test/Reflex/Plan/Pure.hs
+++ b/test/Reflex/Plan/Pure.hs
@@ -39,7 +39,9 @@ instance MonadHold (Pure Int) PurePlan where
   hold initial  = liftPlan . hold initial
   holdDyn initial = liftPlan . holdDyn initial
   holdIncremental initial = liftPlan . holdIncremental initial
+
   buildDynamic getInitial = liftPlan . buildDynamic getInitial
+  buildIncremental getInitial = liftPlan . buildIncremental getInitial
   headE = liftPlan . headE
 
 instance MonadSample (Pure Int) PurePlan where
diff --git a/test/Reflex/Test/Micro.hs b/test/Reflex/Test/Micro.hs
index 50aa55a4..b80e9225 100644
--- a/test/Reflex/Test/Micro.hs
+++ b/test/Reflex/Test/Micro.hs
@@ -42,6 +42,7 @@ scanInnerDyns d = do
 
 
 
+
 {-# ANN testCases "HLint: ignore Functor law" #-}
 testCases :: [(String, TestCase)]
 testCases =
@@ -282,6 +283,31 @@ testCases =
       d' <- pushDyn scanInnerDyns d >>= scanInnerDyns
       return $ current d'
 
+  , testB "holdIncremental" $ do
+    inc <- makeIncremental
+    return (currentIncremental inc)
+
+  , testB "unsafeMapIncremental" $ do
+    inc <- makeIncremental
+    let f = Map.mapKeys (+1)
+        g (PatchMap m) = PatchMap (Map.mapKeys (+1) m)
+
+    let inc' = unsafeMapIncremental f g inc
+    return (currentIncremental inc')
+
+  , testB "mapIncremental" $ do
+
+    -- Not be safe with 'unsafeBuildIncremental' due to key changes
+    let f = Map.mapKeys (+1)
+        g (PatchMap m) = PatchMap (Map.mapKeys (+2) m)
+
+    rec  -- Backwards order, test laziness
+      inc'' <- mapIncremental f g inc'
+      inc'  <- mapIncremental f g inc
+      inc   <- makeIncremental
+
+    return $ currentIncremental inc''
+
   , testE "fan-1" $ do
       e <- fmap toMap <$> events1
       let es = select (fanMap e) . Const2 <$> values
@@ -331,6 +357,7 @@ testCases =
     events2 = plan [(1, "e"), (3, "d"), (4, "c"), (6, "b"), (7, "a")]
     events3 = liftA2 mappend events1 events2
 
+
     eithers ::  TestPlan t m => m (Event t (Either String String))
     eithers = plan [(1, Left "e"), (3, Left "d"), (4, Right "c"), (6, Right "b"), (7, Left "a")]
 
@@ -344,3 +371,17 @@ testCases =
 
     deep e = leftmost [e, e]
     leftmost2 e1 e2 = leftmost [e1, e2]
+
+
+    makeIncremental :: forall t m. TestPlan t m => m (Incremental t (PatchMap Int String))
+    makeIncremental = do
+      e1  <- events1
+      e2  <- events2
+
+      e <- zipListWithEvent (,) [(0::Int)..] (leftmost [e1, e2])
+      let f (k, v) = Map.fromList $ if odd k
+            then [(k, Just v)]
+            else [(k, Nothing)]
+
+      holdIncremental (Map.fromList [((1 :: Int), "g"), (2, "b"), (5, "b")])
+        (PatchMap . f <$> e)