Add traverseFactorableSumWithAdjust and networkHoldFactorableSum

src/Reflex/Adjustable/Class.hs

@@ -3,7 +3,8 @@
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FunctionalDependencies #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE RecursiveDo #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
@@ -17,10 +18,12 @@ module Reflex.Adjustable.Class
   , sequenceDMapWithAdjust
   , sequenceDMapWithAdjustWithMove
   , mapMapWithAdjustWithMove
+  , traverseFactorableSumWithAdjust
   -- * Deprecated aliases
   , MonadAdjust
   ) where
 
+import Control.Lens (Prism', (^?), review)
 import Control.Monad.Identity
 import Control.Monad.Reader
 import Data.Dependent.Map (DMap, GCompare (..))
@@ -39,10 +42,27 @@ import Reflex.Class
 -- other side-effects) cannot be undone, so it is up to the instance implementer
 -- to determine what the best meaning for this class is in such cases.
 class (Reflex t, Monad m) => Adjustable t m | m -> t where
-  runWithReplace :: m a -> Event t (m b) -> m (a, Event t b)
-  traverseIntMapWithKeyWithAdjust :: (IntMap.Key -> v -> m v') -> IntMap v -> Event t (PatchIntMap v) -> m (IntMap v', Event t (PatchIntMap v'))
-  traverseDMapWithKeyWithAdjust :: GCompare k => (forall a. k a -> v a -> m (v' a)) -> DMap k v -> Event t (PatchDMap k v) -> m (DMap k v', Event t (PatchDMap k v'))
-  traverseDMapWithKeyWithAdjustWithMove :: GCompare k => (forall a. k a -> v a -> m (v' a)) -> DMap k v -> Event t (PatchDMapWithMove k v) -> m (DMap k v', Event t (PatchDMapWithMove k v'))
+  runWithReplace
+    :: m a
+    -> Event t (m b)
+    -> m (a, Event t b)
+  traverseIntMapWithKeyWithAdjust
+    :: (IntMap.Key -> v -> m v')
+    -> IntMap v
+    -> Event t (PatchIntMap v)
+    -> m (IntMap v', Event t (PatchIntMap v'))
+  traverseDMapWithKeyWithAdjust
+    :: GCompare k
+    => (forall a. k a -> v a -> m (v' a))
+    -> DMap k v
+    -> Event t (PatchDMap k v)
+    -> m (DMap k v', Event t (PatchDMap k v'))
+  traverseDMapWithKeyWithAdjustWithMove
+    :: GCompare k
+    => (forall a. k a -> v a -> m (v' a))
+    -> DMap k v
+    -> Event t (PatchDMapWithMove k v)
+    -> m (DMap k v', Event t (PatchDMapWithMove k v'))
 
 instance Adjustable t m => Adjustable t (ReaderT r m) where
   runWithReplace a0 a' = do
@@ -69,6 +89,76 @@ mapMapWithAdjustWithMove f m0 m' = do
   (out0 :: DMap (Const2 k v) (Constant v'), out') <- traverseDMapWithKeyWithAdjustWithMove (\(Const2 k) (Identity v) -> Constant <$> f k v) (mapToDMap m0) (const2PatchDMapWithMoveWith Identity <$> m')
   return (dmapToMapWith (\(Constant v') -> v') out0, patchDMapWithMoveToPatchMapWithMoveWith (\(Constant v') -> v') <$> out')
 
+
+-- | 'Adjustable' helper for sum types.
+--
+-- It's often the case that some adjustable computation fed with sum types only
+-- needs incremental adjustments when the variant stays the same but data within
+-- changes, and only need be done from scatch when the the variant changes. This
+-- function is a specialization of 'runWithReplace' but with more parameters
+-- prepended to help provide that incrementalism.
+--
+-- The singleton ['sing'], eliminator, and 'Prism'' family together connect the
+-- sum type ['sum'] with its variants. The singleton must be total in that there
+-- must be a singleon singleton assigned to each variant. The 'Prism'' family
+-- must be "honest" in that the prism indexed by the singleton for each variant
+-- must actually match that variant. Together this is formalized as:
+--
+--   forall s :: sum. exists tp (i :: sing tp) (v :: tp).
+--     s ^? (prismForVariant i) = Just v
+--
+-- (Note this technically allows the same singleton to be assigned to multiple
+-- variants, but that is needlessly confusing and you shouldn't do that.)
+--
+-- Given this ability to "factor" the sum, 'traverseFactorableSumWithAdjust'
+-- splits the update event "runs" of updates of the same variant, and then feeds
+-- the first and rest firing(s) of each run into the adjustable action
+-- constructor for the variant of that run. If 'f' is suitably incremental, the
+-- whole computation is too as the from-scratch reapplications of 'f' only
+-- happen at run boundaries.
+--
+-- The "out functor" might reasonably be instantiated with 'Dynamic t a', or
+-- something like '\a -> (a, Event t a)' (like the return type of
+-- 'runWithReplace'). The latter is a more general return type, which is why
+-- 'runWithReplace' hard-codes it, but for 'traverseFactorableSumWithAdjust'
+-- that puts a more difficult obligation on the constructor, so neither
+-- instantiation is more general than the other. That is why this is made a
+-- parameter.
+traverseFactorableSumWithAdjust
+  :: forall sum sing t m outFunctor
+  .  (Reflex t, MonadHold t m, MonadFix m, Adjustable t m, Functor outFunctor)
+  => (forall a. sum -> (forall tp. sing tp -> tp -> a) -> a)
+  -- ^ eliminator for the sum type using the 'sing' singleton to constrain the
+  -- 'tp' parameter over valid variant types
+  -> (forall tp. sing tp -> Prism' sum tp)
+  -- ^ family of ''Prism''s per variant
+  -> (forall tp. sing tp -> tp -> Event t tp -> m (outFunctor tp))
+  -- ^ family of constructors of adjustable actions, one constructor per variant
+  -> sum
+  -- ^ initial value to be held
+  -> Event t sum
+  -- ^ updates to be held
+  -> m (outFunctor sum, Event t (outFunctor sum))
+traverseFactorableSumWithAdjust withVariant prismForVariant f iv ev = do
+    (initM :: m (outFunctor sum), rest :: Event t sum) <- f' iv ev
+    rec
+      let eBoth = pushAlways (flip f' rest) e'
+          l = fst <$> eBoth
+          r = snd <$> eBoth
+      e' <- switchHold rest r
+    runWithReplace initM l
+  where
+    f' :: forall m'. (MonadHold t m', MonadFix m')
+       => sum
+       -> Event t sum
+       -> m' (m (outFunctor sum), Event t sum)
+    f' iv' ev' = withVariant iv' $ \(ot :: sing tp) (i :: tp) -> do
+      (sames :: Event t tp, rest :: Event t sum)
+        <- takeDropWhileJustE (^? prismForVariant ot) ev'
+      let firstRun = (fmap . fmap) (review (prismForVariant ot)) $
+            f ot i sames
+      pure (firstRun, rest)
+
 --------------------------------------------------------------------------------
 -- Deprecated functions
 --------------------------------------------------------------------------------

src/Reflex/Network.hs

@@ -1,14 +1,24 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+
 #ifdef USE_REFLEX_OPTIMIZER
 {-# OPTIONS_GHC -fplugin=Reflex.Optimizer #-}
 #endif
+
 module Reflex.Network
   ( networkView
   , networkHold
+  , networkHoldFactorableSum
   , untilReady
   ) where
 
+import Control.Lens (Prism')
+import Control.Monad (join)
+import Control.Monad.Fix (MonadFix)
+
 import Reflex.Class
 import Reflex.Adjustable.Class
 import Reflex.NotReady.Class
@@ -31,6 +41,32 @@ networkHold child0 newChild = do
   (result0, newResult) <- runWithReplace child0 newChild
   holdDyn result0 newResult
 
+-- | 'runFactorableSumWithReplace' specialized to 'Dynamic', and then held and
+-- joined down to one 'Dynamic'. This is to 'runFactorableSumWithReplace', as
+-- 'networkHold' is to 'runWithReplace'.
+--
+-- N.B. A similar outcome could be achieved with some combination of 'factorDyn'
+-- and 'networkHold', but this way avoids the initial 'sample' in 'factorDyn'
+-- which is a bit too easy to use improperly and get diverging cycles.
+networkHoldFactorableSum
+  :: forall sum sing t m
+  .  (Reflex t, MonadHold t m, MonadFix m, Adjustable t m)
+  => (forall a. sum -> (forall tp. sing tp -> tp -> a) -> a)
+  -- ^ eliminator for the sum type using the 'sing' singleton to constrain the
+  -- 'tp' parameter over valid variant types
+  -> (forall tp. sing tp -> Prism' sum tp)
+  -- ^ family of ''Prism''s per variant
+  -> (forall tp. sing tp -> tp -> Event t tp -> m (Dynamic t tp))
+  -- ^ family of constructors of adjustable actions, one constructor per variant
+  -> sum
+  -- ^ initial value to be held
+  -> Event t sum
+  -- ^ updates to be held
+  -> m (Dynamic t sum)
+networkHoldFactorableSum wV pFV f iv ev = do
+  (result0, newResult) <- traverseFactorableSumWithAdjust wV pFV f iv ev
+  Control.Monad.join <$> holdDyn result0 newResult
+
 -- | Render a placeholder network to be shown while another network is not yet
 -- done building
 untilReady :: (Adjustable t m, PostBuild t m) => m a -> m b -> m (a, Event t b)