From e1bc6f0428195121bd3cf774d34c63edbd820fac Mon Sep 17 00:00:00 2001 From: John Ericson Date: Fri, 27 Jul 2018 15:19:08 -0400 Subject: [PATCH 1/2] Wrap signatures of methods of `Adjustable` --- src/Reflex/Adjustable/Class.hs | 25 +++++++++++++++++++++---- 1 file changed, 21 insertions(+), 4 deletions(-) diff --git a/src/Reflex/Adjustable/Class.hs b/src/Reflex/Adjustable/Class.hs index 57a1bcbd..cd355139 100644 --- a/src/Reflex/Adjustable/Class.hs +++ b/src/Reflex/Adjustable/Class.hs @@ -39,10 +39,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 From 0352d5de52c6e54d78d9e0b8d76fa531513dd524 Mon Sep 17 00:00:00 2001 From: John Ericson Date: Wed, 18 Jul 2018 01:24:12 -0400 Subject: [PATCH 2/2] Add `traverseFactorableSumWithAdjust` and `networkHoldFactorableSum` they avoid the samples of `factorDyn` by embracing the `widgetHold` pattern. I am 100% cargo culting names here. --- src/Reflex/Adjustable/Class.hs | 75 +++++++++++++++++++++++++++++++++- src/Reflex/Network.hs | 36 ++++++++++++++++ 2 files changed, 110 insertions(+), 1 deletion(-) diff --git a/src/Reflex/Adjustable/Class.hs b/src/Reflex/Adjustable/Class.hs index cd355139..bb41ffff 100644 --- a/src/Reflex/Adjustable/Class.hs +++ b/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 (..)) @@ -86,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 -------------------------------------------------------------------------------- diff --git a/src/Reflex/Network.hs b/src/Reflex/Network.hs index 6d3b774e..a9e2bdd4 100644 --- a/src/Reflex/Network.hs +++ b/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)