@@ -1,5 +1,4 @@
11{-# LANGUAGE CPP #-}
2−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
32{-# LANGUAGE FlexibleContexts #-}
43{-# LANGUAGE FlexibleInstances #-}
54{-# LANGUAGE LambdaCase #-}
@@ -13,57 +12,26 @@
1312
1413-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
1514-- another
16−module Data.Patch.MapWithPatchingMove
17− ( PatchMapWithPatchingMove (..)
18− , patchMapWithPatchingMove
19− , patchMapWithPatchingMoveInsertAll
20− , insertMapKey
21− , moveMapKey
22− , swapMapKey
23− , deleteMapKey
24− , unsafePatchMapWithPatchingMove
25− , patchMapWithPatchingMoveNewElements
26− , patchMapWithPatchingMoveNewElementsMap
27− , patchThatSortsMapWith
28− , patchThatChangesAndSortsMapWith
29− , patchThatChangesMap
30−
31− -- * Node Info
32− , NodeInfo (..)
33− , bitraverseNodeInfo
34− , nodeInfoMapFrom
35− , nodeInfoMapMFrom
36− , nodeInfoSetTo
37−
38− -- * From
39− , From(..)
40− , bitraverseFrom
41−
42− -- * To
43− , To
44−
45− -- TODO internals module
46− , Fixup (..)
47− ) where
15+module Data.Patch.MapWithPatchingMove where
4816
4917import Data.Patch.Class
5018
51−import Control.Lens hiding (from, to)
19+import Control.Arrow
5220import Control.Lens.TH (makeWrapped)
53−import Data.Align (align)
54−import Data.Foldable (toList)
21+import Control.Monad.Trans.State
22+import Data.Foldable
5523import Data.Function
5624import Data.List
5725import Data.Map (Map)
5826import qualified Data.Map as Map
5927import Data.Maybe
60−#if !MIN_VERSION_base(4,11,0)
28+#if !MIN_VERSION_base(4,10,0)
6129import Data.Semigroup (Semigroup (..))
6230#endif
6331import Data.Monoid.DecidablyEmpty
64−import Data.Set (Set)
6532import qualified Data.Set as Set
6633import Data.These (These (..))
34+import Data.Tuple
6735
6836-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
6937-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
@@ -78,13 +46,56 @@ deriving instance (Ord k, Read k, Read p, Read (PatchTarget p)) => Read (PatchMa
7846deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (PatchMapWithPatchingMove k p)
7947deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (PatchMapWithPatchingMove k p)
8048
81−deriving instance ( Ord k
82−#if !MIN_VERSION_base(4,11,0)
83− , Semigroup p
84−#endif
85− , DecidablyEmpty p
86− , Patch p
87− ) => DecidablyEmpty (PatchMapWithPatchingMove k p)
49+-- | Holds the information about each key: where its new value should come from,
50+-- and where its old value should go to
51+data NodeInfo k p = NodeInfo
52+ { _nodeInfo_from :: !(From k p)
53+ -- ^ Where do we get the new value for this key?
54+ , _nodeInfo_to :: !(To k)
55+ -- ^ If the old value is being kept (i.e. moved rather than deleted or
56+ -- replaced), where is it going?
57+ }
58+deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (NodeInfo k p)
59+deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (NodeInfo k p)
60+deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (NodeInfo k p)
61+deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (NodeInfo k p)
62+
63+bitraverseNodeInfo
64+ :: Applicative f
65+ => (k0 -> f k1)
66+ -> (p0 -> f p1)
67+ -> (PatchTarget p0 -> f (PatchTarget p1))
68+ -> NodeInfo k0 p0 -> f (NodeInfo k1 p1)
69+bitraverseNodeInfo fk fp fpt (NodeInfo from to) = NodeInfo
70+ <$> bitraverseFrom fk fp fpt from
71+ <*> traverse fk to
72+
73+-- | Describe how a key's new value should be produced
74+data From k p
75+ = From_Insert (PatchTarget p) -- ^ Insert the given value here
76+ | From_Delete -- ^ Delete the existing value, if any, from here
77+ | From_Move !k !p -- ^ Move the value here from the given key, and apply the given patch
78+
79+bitraverseFrom
80+ :: Applicative f
81+ => (k0 -> f k1)
82+ -> (p0 -> f p1)
83+ -> (PatchTarget p0 -> f (PatchTarget p1))
84+ -> From k0 p0 -> f (From k1 p1)
85+bitraverseFrom fk fp fpt = \case
86+ From_Insert pt -> From_Insert <$> fpt pt
87+ From_Delete -> pure From_Delete
88+ From_Move k p -> From_Move <$> fk k <*> fp p
89+
90+deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (From k p)
91+deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (From k p)
92+deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (From k p)
93+deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (From k p)
94+
95+-- | Describe where a key's old value will go. If this is 'Just', that means
96+-- the key's old value will be moved to the given other key; if it is 'Nothing',
97+-- that means it will be deleted.
98+type To = Maybe
8899
89100-- | Create a 'PatchMapWithPatchingMove', validating it
90101patchMapWithPatchingMove
@@ -116,13 +127,7 @@ insertMapKey k v = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo (From_I
116127-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
117128-- @
118129moveMapKey
119− :: ( DecidablyEmpty p
120−#if !MIN_VERSION_base(4,11,0)
121− , Semigroup p
122−#endif
123− , Patch p
124− )
125− => Ord k => k -> k -> PatchMapWithPatchingMove k p
130+ :: (DecidablyEmpty p, Patch p) => Ord k => k -> k -> PatchMapWithPatchingMove k p
126131moveMapKey src dst
127132 | src == dst = mempty
128133 | otherwise =
@@ -136,17 +141,12 @@ moveMapKey src dst
136141-- @
137142-- let aMay = Map.lookup a map
138143-- bMay = Map.lookup b map
139−-- in maybe id (Map.insert a) (bMay <> aMay)
140−-- . maybe id (Map.insert b) (aMay <> bMay)
144+-- in maybe id (Map.insert a) (bMay `mplus` aMay)
145+-- . maybe id (Map.insert b) (aMay `mplus` bMay)
141146-- . Map.delete a . Map.delete b $ map
142147-- @
143148swapMapKey
144− :: ( DecidablyEmpty p
145−#if !MIN_VERSION_base(4,11,0)
146− , Semigroup p
147−#endif
148− , Patch p
149− )
149+ :: (DecidablyEmpty p, Patch p)
150150 => Ord k => k -> k -> PatchMapWithPatchingMove k p
151151swapMapKey src dst
152152 | src == dst = mempty
@@ -229,70 +229,37 @@ patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatCha
229229
230230-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
231231-- will produce the second 'Map'.
232−-- Note: this will never produce a patch on a value.
233232patchThatChangesMap
234− :: forall k p
235− . (Ord k, Ord (PatchTarget p), Monoid p)
233+ :: (Ord k, Ord (PatchTarget p), Monoid p)
236234 => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
237235patchThatChangesMap oldByIndex newByIndex = patch
238− where invert :: Map k (PatchTarget p) -> Map (PatchTarget p) (Set k)
239− invert = Map.fromListWith (<>) . fmap (\(k, v) -> (v, Set.singleton k)) . Map.toList
240− -- In the places where we use unionDistinct, a non-distinct key indicates a bug in this function
241− unionDistinct :: forall k' v'. Ord k' => Map k' v' -> Map k' v' -> Map k' v'
242− unionDistinct = Map.unionWith (error "patchThatChangesMap: non-distinct keys")
243− unionPairDistinct :: (Map k (From k v), Map k (To k)) -> (Map k (From k v), Map k (To k)) -> (Map k (From k v), Map k (To k))
244− unionPairDistinct (oldFroms, oldTos) (newFroms, newTos) = (unionDistinct oldFroms newFroms, unionDistinct oldTos newTos)
245− -- Generate patch info for a single value
246− -- Keys that are found in both the old and new sets will not be patched
247− -- Keys that are found in only the old set will be moved to a new position if any are available; otherwise they will be deleted
248− -- Keys that are found in only the new set will be populated by moving an old key if any are available; otherwise they will be inserted
249− patchSingleValue :: PatchTarget p -> Set k -> Set k -> (Map k (From k p), Map k (To k))
250− patchSingleValue v oldKeys newKeys = foldl' unionPairDistinct mempty $ align (toList $ oldKeys `Set.difference` newKeys) (toList $ newKeys `Set.difference` oldKeys) <&> \case
251− This oldK -> (mempty, Map.singleton oldK Nothing) -- There's nowhere for this value to go, so we know we are deleting it
252− That newK -> (Map.singleton newK $ From_Insert v, mempty) -- There's nowhere fo this value to come from, so we know we are inserting it
253− These oldK newK -> (Map.singleton newK $ From_Move oldK mempty, Map.singleton oldK $ Just newK)
254− -- Run patchSingleValue on a These. Missing old or new sets are considered empty
255− patchSingleValueThese :: PatchTarget p -> These (Set k) (Set k) -> (Map k (From k p), Map k (To k))
256− patchSingleValueThese v = \case
257− This oldKeys -> patchSingleValue v oldKeys mempty
258− That newKeys -> patchSingleValue v mempty newKeys
259− These oldKeys newKeys -> patchSingleValue v oldKeys newKeys
260− -- Generate froms and tos for all values, then merge them together
261− (froms, tos) = foldl' unionPairDistinct mempty $ Map.mapWithKey patchSingleValueThese $ align (invert oldByIndex) (invert newByIndex)
262− patch = unsafePatchMapWithPatchingMove $ align froms tos <&> \case
263− This from -> NodeInfo from Nothing -- Since we don't have a 'to' record for this key, that must mean it isn't being moved anywhere, so it should be deleted.
264− That to -> NodeInfo From_Delete to -- Since we don't have a 'from' record for this key, it must be getting deleted
265− These from to -> NodeInfo from to
266−
267−--
268−-- NodeInfo
269−--
270−
271−-- | Holds the information about each key: where its new value should come from,
272−-- and where its old value should go to
273−data NodeInfo k p = NodeInfo
274− { _nodeInfo_from :: !(From k p)
275− -- ^ Where do we get the new value for this key?
276− , _nodeInfo_to :: !(To k)
277− -- ^ If the old value is being kept (i.e. moved rather than deleted or
278− -- replaced), where is it going?
279− }
280−deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (NodeInfo k p)
281−deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (NodeInfo k p)
282−deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (NodeInfo k p)
283−deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (NodeInfo k p)
284−
285−-- | Traverse the 'NodeInfo' over the key, patch, and patch target. Because of
286−-- the type families here, this doesn't it any bi- or tri-traversal class.
287−bitraverseNodeInfo
288− :: Applicative f
289− => (k0 -> f k1)
290− -> (p0 -> f p1)
291− -> (PatchTarget p0 -> f (PatchTarget p1))
292− -> NodeInfo k0 p0 -> f (NodeInfo k1 p1)
293−bitraverseNodeInfo fk fp fpt (NodeInfo from to) = NodeInfo
294− <$> bitraverseFrom fk fp fpt from
295− <*> traverse fk to
236+ where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
237+ (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
238+ let f k v = do
239+ remainingValues <- get
240+ let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
241+ then Map.delete v remainingValues
242+ else Map.insert v remainingKeys remainingValues
243+ case Map.lookup v remainingValues of
244+ Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
245+ Just fromKs ->
246+ if k `Set.member` fromKs
247+ then do
248+ putRemainingKeys $ Set.delete k fromKs
249+ return $ NodeInfo (From_Move k mempty) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
250+ else do
251+ (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
252+ putRemainingKeys remainingKeys
253+ return $ NodeInfo (From_Move fromK mempty) $ Just undefined
254+ Map.traverseWithKey f newByIndex
255+ unusedOldKeys = fold unusedValuesByValue
256+ pointlessMove k = \case
257+ From_Move k' _ | k == k' -> True
258+ _ -> False
259+ keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
260+ then Just undefined
261+ else Nothing
262+ patch = unsafePatchMapWithPatchingMove $ Map.filterWithKey (\k -> not . pointlessMove k . _nodeInfo_from) $ Map.mergeWithKey (\k a _ -> Just $ nodeInfoSetTo (keyWasMoved k) a) (Map.mapWithKey $ \k -> nodeInfoSetTo $ keyWasMoved k) (Map.mapWithKey $ \k _ -> NodeInfo From_Delete $ keyWasMoved k) insertsAndMoves oldByIndex
296263
297264-- | Change the 'From' value of a 'NodeInfo'
298265nodeInfoMapFrom
@@ -310,58 +277,14 @@ nodeInfoSetTo
310277 :: To k -> NodeInfo k v -> NodeInfo k v
311278nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
312279
313−--
314−-- From
315−--
316−
317−-- | Describe how a key's new value should be produced
318−data From k p
319− = From_Insert (PatchTarget p) -- ^ Insert the given value here
320− | From_Delete -- ^ Delete the existing value, if any, from here
321− | From_Move !k !p -- ^ Move the value here from the given key, and apply the given patch
322−
323−deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (From k p)
324−deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (From k p)
325−deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (From k p)
326−deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (From k p)
327−
328−-- | Traverse the 'From' over the key, patch, and patch target. Because of
329−-- the type families here, this doesn't it any bi- or tri-traversal class.
330−bitraverseFrom
331− :: Applicative f
332− => (k0 -> f k1)
333− -> (p0 -> f p1)
334− -> (PatchTarget p0 -> f (PatchTarget p1))
335− -> From k0 p0 -> f (From k1 p1)
336−bitraverseFrom fk fp fpt = \case
337− From_Insert pt -> From_Insert <$> fpt pt
338− From_Delete -> pure From_Delete
339− From_Move k p -> From_Move <$> fk k <*> fp p
340−
341−--
342−-- To
343−--
344−
345−-- | Describe where a key's old value will go. If this is 'Just', that means
346−-- the key's old value will be moved to the given other key; if it is 'Nothing',
347−-- that means it will be deleted.
348−type To = Maybe
349−
350−--
351−-- Fixup
352−--
353−
354−-- | Helper data structure used for composing patches using the monoid instance.
280+-- |Helper data structure used for composing patches using the monoid instance.
355281data Fixup k v
356282 = Fixup_Delete
357283 | Fixup_Update (These (From k v) (To k))
358284
359−-- | Compose patches having the same effect as applying the patches in turn:
360−-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
285+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
361286instance ( Ord k
362−#if !MIN_VERSION_base(4,11,0)
363− , Semigroup p
364−#endif
287+ , Monoid p
365288 , DecidablyEmpty p
366289 , Patch p
367290 ) => Semigroup (PatchMapWithPatchingMove k p) where
@@ -420,9 +343,7 @@ instance ( Ord k
420343-- | Compose patches having the same effect as applying the patches in turn:
421344-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
422345instance ( Ord k
423−#if !MIN_VERSION_base(4,11,0)
424− , Semigroup p
425−#endif
346+ , Monoid p
426347 , DecidablyEmpty p
427348 , Patch p
428349 ) => Monoid (PatchMapWithPatchingMove k p) where