01cef41 · reflex · git.iko.soy

git.iko.soy/reflex

Implement traverseIntMapWithKeyWithAdjust for DynamicWriter

commit01cef41fbd5f1f83627af3d4678a8aa54ff193b6 authorRyan Trinkle <ryan.trinkle@gmail.com> dateWed 3 Jan 2018, 19:10 (9 years ago) parentef344d9

11 files changed+114−28

compare with develop

unifiedsplit

reflex.cabal+1 src/Data/FastMutableIntMap.hs+4−24 src/Data/Functor/Misc.hs+13 src/Reflex/Class.hs+5 src/Reflex/DynamicWriter.hs+32 src/Reflex/EventWriter.hs−1 src/Reflex/Patch.hs+2−1 src/Reflex/Patch/DMap.hs+7 src/Reflex/Patch/IntMap.hs+50 src/Reflex/PerformEvent/Base.hs−1 src/Reflex/Requester/Base.hs−1

reflex.cabal+1

@@ -98,6 +98,7 @@ library

9898 Reflex.Patch.Class,

9999 Reflex.Patch.DMap,

100100 Reflex.Patch.DMapWithMove,

101+ Reflex.Patch.IntMap,

101102 Reflex.Patch.Map,

102103 Reflex.Patch.MapWithMove,

103104 Reflex.TriggerEvent.Base,

src/Data/FastMutableIntMap.hs+4−24

@@ -26,14 +26,15 @@ module Data.FastMutableIntMap

2626--TODO: Fast copy to FastIntMap

2727--TODO: Fast patch type

2828

29−import Prelude hiding (lookup)

29+import Control.Monad.IO.Class

30+import Data.Foldable (traverse_)

3031import Data.IORef

3132import Data.IntMap.Strict (IntMap)

3233import qualified Data.IntMap.Strict as IntMap

3334import Data.Maybe

35+import Prelude hiding (lookup)

3436import Reflex.Patch.Class

35−import Data.Foldable (traverse_)

36−import Control.Monad.IO.Class

37+import Reflex.Patch.IntMap

3738

3839newtype FastMutableIntMap a = FastMutableIntMap (IORef (IntMap a))

3940

@@ -77,24 +78,3 @@ applyPatch (FastMutableIntMap r) p@(PatchIntMap m) = do

7778 v <- readIORef r

7879 writeIORef r $! applyAlways p v

7980 return $ IntMap.intersection v m

80−

81−newtype PatchIntMap a = PatchIntMap (IntMap (Maybe a)) deriving (Functor, Foldable, Traversable, Monoid)

82−

83−instance Patch (PatchIntMap a) where

84− type PatchTarget (PatchIntMap a) = IntMap a

85− apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $

86− let removes = IntMap.filter isNothing p

87− adds = IntMap.mapMaybe id p

88− in IntMap.union adds $ v `IntMap.difference` removes

89−

90−traverseIntMapPatchWithKey :: Applicative t => (Int -> a -> t b) -> PatchIntMap a -> t (PatchIntMap b)

91−traverseIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap <$> IntMap.traverseWithKey (\k mv -> traverse (f k) mv) m

92−

93−patchIntMapNewElements :: PatchIntMap a -> [a]

94−patchIntMapNewElements (PatchIntMap m) = catMaybes $ IntMap.elems m

95−

96−patchIntMapNewElementsMap :: PatchIntMap a -> IntMap a

97−patchIntMapNewElementsMap (PatchIntMap m) = IntMap.mapMaybe id m

98−

99−getDeletions :: PatchIntMap v -> IntMap v' -> IntMap v'

100−getDeletions (PatchIntMap m) v = IntMap.intersection v m

src/Data/Functor/Misc.hs+13

@@ -23,6 +23,7 @@ module Data.Functor.Misc

2323 Const2 (..)

2424 , unConst2

2525 , dmapToMap

26+ , dmapToIntMap

2627 , dmapToMapWith

2728 , mapToDMap

2829 , weakenDMapWith

@@ -30,6 +31,7 @@ module Data.Functor.Misc

3031 , WrapArg (..)

3132 -- * Convenience functions for DMap

3233 , mapWithFunctorToDMap

34+ , intMapWithFunctorToDMap

3335 , mapKeyValuePairsMonotonic

3436 , combineDMapsWithKey

3537 , EitherTag (..)

@@ -53,6 +55,8 @@ import qualified Data.Dependent.Map as DMap

5355import Data.Dependent.Sum

5456import Data.GADT.Compare

5557import Data.GADT.Show

58+import Data.IntMap (IntMap)

59+import qualified Data.IntMap as IntMap

5660import Data.Map (Map)

5761import qualified Data.Map as Map

5862import Data.Some (Some)

@@ -127,6 +131,10 @@ instance {-# INCOHERENT #-} Eq k => EqTag (Const2 k v) (Const2 k v) where

127131dmapToMap :: DMap (Const2 k v) Identity -> Map k v

128132dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList

129133

134+-- | Convert a 'DMap' to an 'IntMap'

135+dmapToIntMap :: DMap (Const2 IntMap.Key v) Identity -> IntMap v

136+dmapToIntMap = IntMap.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList

137+

130138-- | Convert a 'DMap' to a regular 'Map', applying the given function to remove

131139-- the wrapping 'Functor'

132140dmapToMapWith :: (f v -> v') -> DMap (Const2 k v) f -> Map k v'

@@ -141,6 +149,11 @@ mapToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> Identity v)

141149mapWithFunctorToDMap :: Map k (f v) -> DMap (Const2 k v) f

142150mapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . Map.toAscList

143151

152+-- | Convert a regular 'IntMap', where the values are already wrapped in a

153+-- functor, to a 'DMap'

154+intMapWithFunctorToDMap :: IntMap (f v) -> DMap (Const2 IntMap.Key v) f

155+intMapWithFunctorToDMap = DMap.fromDistinctAscList . map (\(k, v) -> Const2 k :=> v) . IntMap.toAscList

156+

144157-- | Convert a 'DMap' to a regular 'Map' by forgetting the types associated with

145158-- the keys, using a function to remove the wrapping 'Functor'

146159weakenDMapWith :: (forall a. v a -> v') -> DMap k v -> Map (Some k) v'

src/Reflex/Class.hs+5

@@ -48,6 +48,7 @@ module Reflex.Class

4848 , mergeMap

4949 , mergeMapIncremental

5050 , mergeMapIncrementalWithMove

51+ , mergeIntMapIncremental

5152 , mergeList

5253 , mergeWith

5354 , difference

@@ -792,6 +793,10 @@ mergeMap = fmap dmapToMap . merge . mapWithFunctorToDMap

792793mergeMapIncremental :: (Reflex t, Ord k) => Incremental t (PatchMap k (Event t a)) -> Event t (Map k a)

793794mergeMapIncremental = fmap dmapToMap . mergeIncremental . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWith id)

794795

796+-- | Create a merge whose parents can change over time

797+mergeIntMapIncremental :: Reflex t => Incremental t (PatchIntMap (Event t a)) -> Event t (IntMap a)

798+mergeIntMapIncremental = fmap dmapToIntMap . mergeIncremental . unsafeMapIncremental intMapWithFunctorToDMap (const2IntPatchDMapWith id)

799+

795800-- | Experimental: Create a merge whose parents can change over time; changing the key of an Event is more efficient than with mergeIncremental

796801mergeMapIncrementalWithMove :: (Reflex t, Ord k) => Incremental t (PatchMapWithMove k (Event t a)) -> Event t (Map k a)

797802mergeMapIncrementalWithMove = fmap dmapToMap . mergeIncrementalWithMove . unsafeMapIncremental mapWithFunctorToDMap (const2PatchDMapWithMoveWith id)

src/Reflex/DynamicWriter.hs+32

@@ -30,7 +30,10 @@ import Control.Monad.State.Strict

3030import Data.Align

3131import Data.Dependent.Map (DMap)

3232import qualified Data.Dependent.Map as DMap

33+import Data.FastMutableIntMap

3334import Data.Functor.Misc

35+import Data.IntMap (IntMap)

36+import qualified Data.IntMap as IntMap

3437import Data.Map (Map)

3538import qualified Data.Map as Map

3639import Data.Semigroup

@@ -55,6 +58,11 @@ mergeDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< samp

5558 where changedValues = fmap (PatchMap . fmap Just) $ mergeMapIncremental $ mapIncrementalMapValues updated a

5659 addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchMap m) -> PatchMap <$> mapM (mapM (sample . current)) m

5760

61+mergeIntMapDynIncremental :: Reflex t => Incremental t (PatchIntMap (Dynamic t v)) -> Incremental t (PatchIntMap v)

62+mergeIntMapDynIncremental a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ addedAndRemovedValues <> changedValues

63+ where changedValues = fmap (PatchIntMap . fmap Just) $ mergeIntMapIncremental $ mapIncrementalMapValues updated a

64+ addedAndRemovedValues = flip pushAlways (updatedIncremental a) $ \(PatchIntMap m) -> PatchIntMap <$> mapM (mapM (sample . current)) m

65+

5866mergeDynIncrementalWithMove :: forall t k v. (Reflex t, Ord k) => Incremental t (PatchMapWithMove k (Dynamic t v)) -> Incremental t (PatchMapWithMove k v)

5967mergeDynIncrementalWithMove a = unsafeBuildIncremental (mapM (sample . current) =<< sample (currentIncremental a)) $ alignWith f addedAndRemovedValues changedValues

6068 where changedValues = mergeMapIncrementalWithMove $ mapIncrementalMapValues updated a

@@ -142,6 +150,7 @@ instance (Adjustable t m, MonadFix m, Monoid w, MonadHold t m, Reflex t) => Adju

142150 (result0, result') <- lift $ runWithReplace (runDynamicWriterT a0) $ runDynamicWriterT <$> a'

143151 tellDyn . join =<< holdDyn (snd result0) (snd <$> result')

144152 return (fst result0, fst <$> result')

153+ traverseIntMapWithKeyWithAdjust = traverseIntMapWithKeyWithAdjustImpl traverseIntMapWithKeyWithAdjust mergeIntMapDynIncremental

145154 traverseDMapWithKeyWithAdjust = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjust mapPatchDMap weakenPatchDMapWith mergeDynIncremental

146155 traverseDMapWithKeyWithAdjustWithMove = traverseDMapWithKeyWithAdjustImpl traverseDMapWithKeyWithAdjustWithMove mapPatchDMapWithMove weakenPatchDMapWithMoveWith mergeDynIncrementalWithMove

147156

@@ -172,6 +181,29 @@ traverseDMapWithKeyWithAdjustImpl base mapPatch weakenPatchWith mergeMyDynIncrem

172181 tellDyn $ fmap (mconcat . Map.elems) $ incrementalToDynamic $ mergeMyDynIncremental i

173182 return (liftedResult0, liftedResult')

174183

184+traverseIntMapWithKeyWithAdjustImpl :: forall t w v' p p' v m. (PatchTarget (p' (Dynamic t w)) ~ IntMap (Dynamic t w), PatchTarget (p' w) ~ IntMap w, Patch (p' w), Patch (p' (Dynamic t w)), MonadFix m, Monoid w, Reflex t, MonadHold t m, Functor p, p ~ p')

185+ => ( (IntMap.Key -> v -> m ((v', Dynamic t w)))

186+ -> IntMap v

187+ -> Event t (p v)

188+ -> m (IntMap (v', Dynamic t w), Event t (p (v', Dynamic t w)))

189+ )

190+ -> (Incremental t (p' (Dynamic t w)) -> Incremental t (p' w))

191+ -> (IntMap.Key -> v -> DynamicWriterT t w m v')

192+ -> IntMap v

193+ -> Event t (p v)

194+ -> DynamicWriterT t w m (IntMap v', Event t (p v'))

195+traverseIntMapWithKeyWithAdjustImpl base mergeMyDynIncremental f (dm0 :: IntMap v) dm' = do

196+ (result0, result') <- lift $ base (\k v -> runDynamicWriterT $ f k v) dm0 dm'

197+ let liftedResult0 = fmap fst result0

198+ liftedResult' = fmap (fmap fst) result'

199+ liftedWritten0 :: IntMap (Dynamic t w)

200+ liftedWritten0 = fmap snd result0

201+ liftedWritten' = fmap (fmap snd) result'

202+ --TODO: We should be able to improve the performance here by incrementally updating the mconcat of the merged Dynamics

203+ i <- holdIncremental liftedWritten0 liftedWritten'

204+ tellDyn $ fmap (mconcat . IntMap.elems) $ incrementalToDynamic $ mergeMyDynIncremental i

205+ return (liftedResult0, liftedResult')

206+

175207-- | Map a function over the output of a 'DynamicWriterT'.

176208withDynamicWriterT :: (Monoid w, Monoid w', Reflex t, MonadHold t m, MonadFix m)

177209 => (w -> w')

src/Reflex/EventWriter.hs−1

@@ -38,7 +38,6 @@ import Control.Monad.Ref

3838import Control.Monad.State.Strict

3939import Data.Dependent.Map (DMap, DSum (..))

4040import qualified Data.Dependent.Map as DMap

41−import Data.FastMutableIntMap

4241import Data.Foldable

4342import Data.Functor.Compose

4443import Data.Functor.Misc

src/Reflex/Patch.hs+2−1

@@ -7,10 +7,11 @@ module Reflex.Patch

77 ) where

99import Reflex.Patch.Class as X

10−import Reflex.Patch.DMap as X

10+import Reflex.Patch.DMap as X hiding (getDeletions)

1111import Reflex.Patch.DMapWithMove as X (PatchDMapWithMove, const2PatchDMapWithMoveWith, patchDMapWithMoveToPatchMapWithMoveWith, mapPatchDMapWithMove, weakenPatchDMapWithMoveWith, traversePatchDMapWithMoveWithKey, unsafePatchDMapWithMove, unPatchDMapWithMove)

1212import Reflex.Patch.Map as X

1313import Reflex.Patch.MapWithMove as X (PatchMapWithMove, patchMapWithMoveNewElementsMap, patchMapWithMoveNewElements, unsafePatchMapWithMove, unPatchMapWithMove)

14+import Reflex.Patch.IntMap as X hiding (getDeletions)

1415

1516import Data.Semigroup (Semigroup (..), (<>))

1617

src/Reflex/Patch/DMap.hs+7

@@ -8,11 +8,13 @@

88module Reflex.Patch.DMap where

1010import Reflex.Patch.Class

11+import Reflex.Patch.IntMap

1112import Reflex.Patch.Map

1213

1314import Data.Dependent.Map (DMap, DSum (..), GCompare (..))

1415import qualified Data.Dependent.Map as DMap

1516import Data.Functor.Constant

17+import qualified Data.IntMap as IntMap

1618import Data.Functor.Misc

1719import qualified Data.Map as Map

1820import Data.Semigroup (Semigroup (..))

@@ -55,6 +57,11 @@ const2PatchDMapWith f (PatchMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$

5557 where g :: (k, Maybe v) -> DSum (Const2 k a) (ComposeMaybe f)

5658 g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)

5759

60+const2IntPatchDMapWith :: forall v f a. (v -> f a) -> PatchIntMap v -> PatchDMap (Const2 IntMap.Key a) f

61+const2IntPatchDMapWith f (PatchIntMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> IntMap.toAscList p

62+ where g :: (IntMap.Key, Maybe v) -> DSum (Const2 IntMap.Key a) (ComposeMaybe f)

63+ g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)

64+

5865-- | Get the values that will be deleted if the given patch is applied to the

5966-- given 'DMap'. Includes values that will be replaced.

6067getDeletions :: GCompare k => PatchDMap k v -> DMap k v' -> DMap k v'

src/Reflex/Patch/IntMap.hsnew file+50

@@ -0,0 +1,50 @@

1+{-# LANGUAGE CPP #-}

2+{-# LANGUAGE DeriveFunctor #-}

3+{-# LANGUAGE DeriveFoldable #-}

4+{-# LANGUAGE DeriveTraversable #-}

5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}

6+{-# LANGUAGE TypeFamilies #-}

7+module Reflex.Patch.IntMap where

9+import Prelude hiding (lookup)

10+import Data.IntMap.Strict (IntMap)

11+import qualified Data.IntMap.Strict as IntMap

12+import Data.Maybe

13+import Data.Semigroup

14+import Reflex.Patch.Class

15+

16+newtype PatchIntMap a = PatchIntMap (IntMap (Maybe a)) deriving (Functor, Foldable, Traversable, Monoid)

17+

18+instance Patch (PatchIntMap a) where

19+ type PatchTarget (PatchIntMap a) = IntMap a

20+ apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $

21+ let removes = IntMap.filter isNothing p

22+ adds = IntMap.mapMaybe id p

23+ in IntMap.union adds $ v `IntMap.difference` removes

24+

25+-- | @a <> b@ will apply the changes of @b@ and then apply the changes of @a@.

26+-- If the same key is modified by both patches, the one on the left will take

27+-- precedence.

28+instance Semigroup (PatchIntMap v) where

29+ PatchIntMap a <> PatchIntMap b = PatchIntMap $ a `mappend` b --TODO: Add a semigroup instance for Map

30+ -- PatchMap is idempotent, so stimes n is id for every n

31+#if MIN_VERSION_semigroups(0,17,0)

32+ stimes = stimesIdempotentMonoid

33+#else

34+ times1p n x = case compare n 0 of

35+ LT -> error "stimesIdempotentMonoid: negative multiplier"

36+ EQ -> mempty

37+ GT -> x

38+#endif

39+

40+traverseIntMapPatchWithKey :: Applicative t => (Int -> a -> t b) -> PatchIntMap a -> t (PatchIntMap b)

41+traverseIntMapPatchWithKey f (PatchIntMap m) = PatchIntMap <$> IntMap.traverseWithKey (\k mv -> traverse (f k) mv) m

42+

43+patchIntMapNewElements :: PatchIntMap a -> [a]

44+patchIntMapNewElements (PatchIntMap m) = catMaybes $ IntMap.elems m

45+

46+patchIntMapNewElementsMap :: PatchIntMap a -> IntMap a

47+patchIntMapNewElementsMap (PatchIntMap m) = IntMap.mapMaybe id m

48+

49+getDeletions :: PatchIntMap v -> IntMap v' -> IntMap v'

50+getDeletions (PatchIntMap m) v = IntMap.intersection v m

src/Reflex/PerformEvent/Base.hs−1

@@ -40,7 +40,6 @@ import Data.Coerce

4040import Data.Dependent.Map (DMap)

4141import qualified Data.Dependent.Map as DMap

4242import Data.Dependent.Sum

43−import Data.FastMutableIntMap

4443import Data.IntMap.Strict (IntMap)

4544import qualified Data.IntMap.Strict as IntMap

4645

src/Reflex/Requester/Base.hs−1

@@ -50,7 +50,6 @@ import Data.Coerce

5050import Data.Dependent.Map (DMap, DSum (..))

5151import qualified Data.Dependent.Map as DMap

5252import qualified Data.Some as Some

53−import Data.FastMutableIntMap

5453import Data.Functor.Compose

5554import Data.Functor.Misc

5655import Data.IntMap.Strict (IntMap)