@@ -1,168 +1,18 @@
11-- | This module defines the 'Patch' class, which is used by Reflex to manage
22-- changes to 'Reflex.Class.Incremental' values.
3−{-# LANGUAGE CPP #-}
4−{-# LANGUAGE DeriveFoldable #-}
5−{-# LANGUAGE DeriveFunctor #-}
6−{-# LANGUAGE DeriveTraversable #-}
7−{-# LANGUAGE FlexibleContexts #-}
8−{-# LANGUAGE GADTs #-}
9−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10−{-# LANGUAGE LambdaCase #-}
11−{-# LANGUAGE PolyKinds #-}
12−{-# LANGUAGE Rank2Types #-}
13−{-# LANGUAGE ScopedTypeVariables #-}
14−{-# LANGUAGE StandaloneDeriving #-}
153{-# LANGUAGE TypeFamilies #-}
164module Reflex.Patch
17− ( Patch (..)
18− , PatchDMap (..)
19− , mapPatchDMap
20− , traversePatchDMap
21− , traversePatchDMapWithKey
22− , weakenPatchDMapWith
23− , patchDMapToPatchMapWith
24− , const2PatchDMapWith
25− , ComposeMaybe (..)
26− , PatchMap (..)
27− , patchMapNewElements
28− , Group (..)
29− , Additive
30− , AdditivePatch (..)
31− , PatchMapWithMove
32− , unPatchMapWithMove
33− , unsafePatchMapWithMove
34− , patchMapWithMoveNewElements
35− , MapEdit (..)
36− , mapEditMoved
37− , mapEditSetMoved
38− , PatchDMapWithMove
39− , unPatchDMapWithMove
40− , unsafePatchDMapWithMove
41− , patchThatSortsMapWith
42− , patchThatChangesAndSortsMapWith
43− , mapPatchDMapWithMove
44− , traversePatchDMapWithMove
45− , traversePatchDMapWithMoveWithKey
46− , weakenPatchDMapWithMoveWith
47− , patchDMapWithMoveToPatchMapWithMoveWith
48− , const2PatchDMapWithMoveWith
49− , DMapEdit (..)
50− , dmapEditMoved
51− -- * Test functions
52− , validPatchMapWithMove
53− , knownValidPatchMapWithMove
54− , knownInvalidPatchMapWithMove
5+ ( module Reflex.Patch
6+ , module X
557 ) where
568
57−import Control.Arrow
58−import Control.Monad.Identity
59−import Control.Monad.State
60−import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
61−import qualified Data.Dependent.Map as DMap
62−import Data.Foldable
63−import Data.Function
64−import Data.Functor.Constant
65−import Data.Functor.Misc
66−import Data.List
67−import Data.Map (Map)
68−import qualified Data.Map as Map
69−import Data.Maybe
70−import Data.Semigroup (Semigroup (..), stimesIdempotentMonoid, (<>))
71−import qualified Data.Set as Set
72−import Data.Some (Some)
73−import qualified Data.Some as Some
74−import Data.Tuple
9+import Reflex.Patch.Class as X
10+import Reflex.Patch.DMap as X
11+import Reflex.Patch.DMapWithMove as X (PatchDMapWithMove, const2PatchDMapWithMoveWith, patchDMapWithMoveToPatchMapWithMoveWith, mapPatchDMapWithMove, weakenPatchDMapWithMoveWith, traversePatchDMapWithMoveWithKey, unsafePatchDMapWithMove, unPatchDMapWithMove)
12+import Reflex.Patch.Map as X
13+import Reflex.Patch.MapWithMove as X (PatchMapWithMove, patchMapWithMoveNewElements, unsafePatchMapWithMove, unPatchMapWithMove)
7514
76−-- | A 'Patch' type represents a kind of change made to a datastructure.
77−class Patch p where
78− type PatchTarget p :: *
79− -- | Apply the patch @p a@ to the value @a@. If no change is needed, return
80− -- 'Nothing'.
81− apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
82−
83−-- | We can't use @Compose Maybe@ instead of 'ComposeMaybe', because that would
84−-- make the 'f' parameter have a nominal type role. We need f to be
85−-- representational so that we can use safe 'coerce'.
86−newtype ComposeMaybe f a = ComposeMaybe { getComposeMaybe :: Maybe (f a) }
87−
88−deriving instance Functor f => Functor (ComposeMaybe f)
89−
90−instance Patch (Identity a) where
91− type PatchTarget (Identity a) = a
92− apply (Identity a) _ = Just a
93−
94−-- | A set of changes to a 'DMap'. Any element may be inserted/updated or
95−-- deleted.
96−newtype PatchDMap k v = PatchDMap (DMap k (ComposeMaybe v))
97−
98−deriving instance GCompare k => Semigroup (PatchDMap k v)
99−
100−deriving instance GCompare k => Monoid (PatchDMap k v)
101−
102−instance GCompare k => Patch (PatchDMap k v) where
103− type PatchTarget (PatchDMap k v) = DMap k v
104− apply (PatchDMap diff) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
105− where insertions = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff
106− deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getComposeMaybe) diff
107− nothingToJust = \case
108− Nothing -> Just $ Constant ()
109− Just _ -> Nothing
110−
111−mapPatchDMap :: (forall a. v a -> v' a) -> PatchDMap k v -> PatchDMap k v'
112−mapPatchDMap f (PatchDMap p) = PatchDMap $ DMap.map (ComposeMaybe . fmap f . getComposeMaybe) p
113−
114−traversePatchDMap :: Applicative m => (forall a. v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')
115−traversePatchDMap f = traversePatchDMapWithKey $ const f
116−
117−traversePatchDMapWithKey :: Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMap k v -> m (PatchDMap k v')
118−traversePatchDMapWithKey f (PatchDMap p) = PatchDMap <$> DMap.traverseWithKey (\k (ComposeMaybe v) -> ComposeMaybe <$> traverse (f k) v) p
119−
120−weakenPatchDMapWith :: (forall a. v a -> v') -> PatchDMap k v -> PatchMap (Some k) v'
121−weakenPatchDMapWith f (PatchDMap p) = PatchMap $ weakenDMapWith (fmap f . getComposeMaybe) p
122−
123−patchDMapToPatchMapWith :: (f v -> v') -> PatchDMap (Const2 k v) f -> PatchMap k v'
124−patchDMapToPatchMapWith f (PatchDMap p) = PatchMap $ dmapToMapWith (fmap f . getComposeMaybe) p
125−
126−const2PatchDMapWith :: forall k v f a. (v -> f a) -> PatchMap k v -> PatchDMap (Const2 k a) f
127−const2PatchDMapWith f (PatchMap p) = PatchDMap $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
128− where g :: (k, Maybe v) -> DSum (Const2 k a) (ComposeMaybe f)
129− g (k, e) = Const2 k :=> ComposeMaybe (f <$> e)
130−
131−-- | A set of changes to a 'Map'. Any element may be inserted/updated or
132−-- deleted.
133−newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }
134−
135−instance Ord k => Patch (PatchMap k v) where
136− type PatchTarget (PatchMap k v) = Map k v
137− apply (PatchMap p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
138− where insertions = Map.mapMaybeWithKey (const id) p
139− deletions = Map.mapMaybeWithKey (const nothingToJust) p
140− nothingToJust = \case
141− Nothing -> Just ()
142− Just _ -> Nothing
143−
144−instance Ord k => Semigroup (PatchMap k v) where
145− PatchMap a <> PatchMap b = PatchMap $ a `mappend` b --TODO: Add a semigroup instance for Map
146− -- PatchMap is idempotent, so stimes n is id for every n
147−#if MIN_VERSION_semigroups(0,17,0)
148− stimes = stimesIdempotentMonoid
149−#else
150− times1p n x = case compare n 0 of
151− LT -> error "stimesIdempotentMonoid: negative multiplier"
152− EQ -> mempty
153− GT -> x
154−#endif
155−
156−instance Ord k => Monoid (PatchMap k v) where
157− mempty = PatchMap mempty
158− mappend = (<>)
159−
160−instance Functor (PatchMap k) where
161− fmap f = PatchMap . fmap (fmap f) . unPatchMap
162−
163−-- | Returns all the new elements that will be added to the 'Map'
164−patchMapNewElements :: PatchMap k v -> [v]
165−patchMapNewElements (PatchMap p) = catMaybes $ Map.elems p
15+import Data.Semigroup (Semigroup (..), (<>))
16616
16717---- Patches based on commutative groups
16818
@@ -181,207 +31,3 @@ newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }
18131instance Additive p => Patch (AdditivePatch p) where
18232 type PatchTarget (AdditivePatch p) = p
18333 apply (AdditivePatch p) q = Just $ p <> q
184−
185−data MapEdit k v
186− = MapEdit_Insert Bool v -- ^ Insert the given value here
187− | MapEdit_Delete Bool -- ^ Delete the existing value, if any, from here
188− | MapEdit_Move Bool k -- ^ Move the value here from the given key
189− deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
190−
191−mapEditMoved :: MapEdit k v -> Bool
192−mapEditMoved = \case
193− MapEdit_Insert moved _ -> moved
194− MapEdit_Delete moved -> moved
195− MapEdit_Move moved _ -> moved
196−
197−mapEditSetMoved :: Bool -> MapEdit k v -> MapEdit k v
198−mapEditSetMoved moved = \case
199− MapEdit_Insert _ v -> MapEdit_Insert moved v
200− MapEdit_Delete _ -> MapEdit_Delete moved
201− MapEdit_Move _ k -> MapEdit_Move moved k
202−
203−-- | Patch a DMap with additions, deletions, and moves.
204−-- Invariants:
205−-- * The same source key may not be moved to two destination keys.
206−-- * Any key that is the source of a Move must also be edited
207−-- (otherwise, the Move would duplicate it)
208−newtype PatchMapWithMove k v = PatchMapWithMove (Map k (MapEdit k v)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
209−
210−unPatchMapWithMove :: PatchMapWithMove k v -> Map k (MapEdit k v)
211−unPatchMapWithMove (PatchMapWithMove p) = p
212−
213−-- | Warning: when using this function, you must ensure that the invariants of
214−-- 'PatchMapWithMove' are preserved; they will not be checked.
215−unsafePatchMapWithMove :: Map k (MapEdit k v) -> PatchMapWithMove k v
216−unsafePatchMapWithMove = PatchMapWithMove
217−
218−instance Ord k => Patch (PatchMapWithMove k v) where
219− type PatchTarget (PatchMapWithMove k v) = Map k v
220− apply (PatchMapWithMove p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
221− where insertions = flip Map.mapMaybeWithKey p $ const $ \case
222− MapEdit_Insert _ v -> Just v
223− MapEdit_Move _ k -> Map.lookup k old
224− MapEdit_Delete _ -> Nothing
225− deletions = flip Map.mapMaybeWithKey p $ const $ \case
226− MapEdit_Delete _ -> Just ()
227− _ -> Nothing
228−
229−-- | Returns all the new elements that will be added to the 'Map'
230−patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
231−patchMapWithMoveNewElements (PatchMapWithMove p) = catMaybes $ flip fmap (Map.elems p) $ \case
232− MapEdit_Insert _ v -> Just v
233− MapEdit_Move _ _ -> Nothing
234− MapEdit_Delete _ -> Nothing
235−
236−validPatchMapWithMove :: Ord k => PatchMapWithMove k v -> Bool
237−validPatchMapWithMove (PatchMapWithMove p) =
238− let moveSources = catMaybes $ flip fmap (Map.elems p) $ \case
239− MapEdit_Move _ k -> Just k
240− _ -> Nothing
241− in and
242− [ -- All Moves must have unique source keys - a single source key can't be moved to two destinations
243− all (==1) $ Map.fromListWith (+) $ fmap (\k -> (k, 1 :: Integer )) moveSources
244− , -- All Move source keys must also be patched - since the value's being moved elsewhere, the original must either be Deleted or replaced (with Insert or Move)
245− all (isJust . flip Map.lookup p) moveSources
246− ]
247−
248−knownValidPatchMapWithMove :: [PatchMapWithMove Int Int]
249−knownValidPatchMapWithMove =
250− [ PatchMapWithMove mempty
251− , PatchMapWithMove $ Map.fromList
252− [ (1, MapEdit_Move True 2)
253− , (2, MapEdit_Move True 1)
254− ]
255− ]
256−
257−knownInvalidPatchMapWithMove :: [PatchMapWithMove Int Int]
258−knownInvalidPatchMapWithMove =
259− [ -- Invalid because we move 2 to 1, but don't specify what to do with 2
260− PatchMapWithMove $ Map.singleton 1 $ MapEdit_Move False 2
261− , -- Invalid because we have multiple moves from 3
262− PatchMapWithMove $ Map.fromList
263− [ (1, MapEdit_Move False 3)
264− , (2, MapEdit_Move False 3)
265− , (3, MapEdit_Delete True)
266− ]
267− ]
268−
269−patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v
270−patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g l $ sortBy (cmp `on` snd) l
271− where l = Map.toList m
272− g (to, _) (from, _) = if to == from
273− then Nothing
274− else Just (to, MapEdit_Move True from)
275−
276−patchThatChangesAndSortsMapWith :: (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
277−patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patch
278− where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
279− newList = Map.toList newByIndexUnsorted
280− newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
281− (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
282− let f k v = do
283− remainingValues <- get
284− let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
285− then Map.delete v remainingValues
286− else Map.insert v remainingKeys remainingValues
287− case Map.lookup v remainingValues of
288− Nothing -> return $ MapEdit_Insert True v -- There's no existing value we can take
289− Just fromKs ->
290− if k `Set.member` fromKs
291− then do
292− putRemainingKeys $ Set.delete k fromKs
293− return $ MapEdit_Move True k -- There's an existing value, and it's here, so no patch necessary
294− else do
295− Just (fromK, remainingKeys) <- return $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
296− putRemainingKeys remainingKeys
297− return $ MapEdit_Move True fromK
298− Map.traverseWithKey f newByIndex
299− unusedOldKeys = fold unusedValuesByValue
300− pointlessMove k = \case
301− MapEdit_Move _ k' | k == k' -> True
302− _ -> False
303− keyWasMoved k = k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
304− patch = unsafePatchMapWithMove $ Map.filterWithKey (\k v -> not $ pointlessMove k v) $ Map.mergeWithKey (\k a _ -> Just $ mapEditSetMoved (keyWasMoved k) a) (Map.mapWithKey $ \k -> mapEditSetMoved $ keyWasMoved k) (Map.mapWithKey $ \k _ -> MapEdit_Delete $ keyWasMoved k) insertsAndMoves oldByIndex
305−
306−data DMapEdit (k :: a -> *) (v :: a -> *) :: a -> * where
307− -- | Insert the given value here
308− DMapEdit_Insert :: Bool -> v a -> DMapEdit k v a
309− -- | Delete the existing value, if any, from here
310− DMapEdit_Delete :: Bool -> DMapEdit k v a
311− -- | Move the value here from the given key
312− DMapEdit_Move :: Bool -> k a -> DMapEdit k v a
313−
314−dmapEditMoved :: DMapEdit k v a -> Bool
315−dmapEditMoved = \case
316− DMapEdit_Insert moved _ -> moved
317− DMapEdit_Delete moved -> moved
318− DMapEdit_Move moved _ -> moved
319−
320−-- | Like 'PatchMapWithMove', but for 'DMap'.
321−newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (DMapEdit k v))
322−
323−unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (DMapEdit k v)
324−unPatchDMapWithMove (PatchDMapWithMove p) = p
325−
326−-- | Warning: when using this function, you must ensure that the invariants of
327−-- 'PatchDMapWithMove' are preserved; they will not be checked.
328−unsafePatchDMapWithMove :: DMap k (DMapEdit k v) -> PatchDMapWithMove k v
329−unsafePatchDMapWithMove = PatchDMapWithMove
330−
331−mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'
332−mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $ DMap.map g p
333− where g :: forall a. DMapEdit k v a -> DMapEdit k v' a
334− g = \case
335− DMapEdit_Insert moved v -> DMapEdit_Insert moved $ f v
336− DMapEdit_Delete moved -> DMapEdit_Delete moved
337− DMapEdit_Move moved k -> DMapEdit_Move moved k
338−
339−traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
340−traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
341−
342−traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
343−traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey g p
344− where g :: forall a. k a -> DMapEdit k v a -> m (DMapEdit k v' a)
345− g k = \case
346− DMapEdit_Insert moved v -> DMapEdit_Insert moved <$> f k v
347− DMapEdit_Delete moved -> pure $ DMapEdit_Delete moved
348− DMapEdit_Move moved fromKey -> pure $ DMapEdit_Move moved fromKey
349−
350−weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'
351−weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
352− where g :: forall a. DMapEdit k v a -> MapEdit (Some k) v'
353− g = \case
354− DMapEdit_Insert moved v -> MapEdit_Insert moved $ f v
355− DMapEdit_Delete moved -> MapEdit_Delete moved
356− DMapEdit_Move moved k -> MapEdit_Move moved $ Some.This k
357−
358−patchDMapWithMoveToPatchMapWithMoveWith :: forall k f v v'. (f v -> v') -> PatchDMapWithMove (Const2 k v) f -> PatchMapWithMove k v'
359−patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
360− where g :: DMapEdit (Const2 k v) f v -> MapEdit k v'
361− g = \case
362− DMapEdit_Insert moved v -> MapEdit_Insert moved $ f v
363− DMapEdit_Delete moved -> MapEdit_Delete moved
364− DMapEdit_Move moved (Const2 k) -> MapEdit_Move moved k
365−
366−const2PatchDMapWithMoveWith :: forall k v f a. (v -> f a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) f
367−const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
368− where g :: (k, MapEdit k v) -> DSum (Const2 k a) (DMapEdit (Const2 k a) f)
369− g (k, e) = Const2 k :=> case e of
370− MapEdit_Insert moved v -> DMapEdit_Insert moved $ f v
371− MapEdit_Delete moved -> DMapEdit_Delete moved
372− MapEdit_Move moved fromKey -> DMapEdit_Move moved $ Const2 fromKey
373−
374−instance GCompare k => Patch (PatchDMapWithMove k v) where
375− type PatchTarget (PatchDMapWithMove k v) = DMap k v
376− apply (PatchDMapWithMove p) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
377− where insertions = DMap.mapMaybeWithKey insertFunc p
378− insertFunc :: forall a. k a -> DMapEdit k v a -> Maybe (v a)
379− insertFunc _ = \case
380− DMapEdit_Insert _ v -> Just v
381− DMapEdit_Move _ k -> DMap.lookup k old
382− DMapEdit_Delete _ -> Nothing
383− deletions = DMap.mapMaybeWithKey deleteFunc p
384− deleteFunc :: forall a. k a -> DMapEdit k v a -> Maybe (Constant () a)
385− deleteFunc _ = \case
386− DMapEdit_Delete _ -> Just $ Constant ()
387− _ -> Nothing