@@ -1,5 +1,4 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2−{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
3{-# LANGUAGE FlexibleInstances #-}
5{-# LANGUAGE LambdaCase #-}
4{-# LANGUAGE LambdaCase #-}
@@ -13,57 +12,26 @@
14-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
13-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
16−module Data.Patch.MapWithPatchingMove
15+module Data.Patch.MapWithPatchingMove where
17− ( PatchMapWithPatchingMove (..)
18− , patchMapWithPatchingMove
19− , patchMapWithPatchingMoveInsertAll
24− , unsafePatchMapWithPatchingMove
25− , patchMapWithPatchingMoveNewElements
26− , patchMapWithPatchingMoveNewElementsMap
27− , patchThatSortsMapWith
28− , patchThatChangesAndSortsMapWith
29− , patchThatChangesMap
45− -- TODO internals module
49import Data.Patch.Class
17import Data.Patch.Class
51−import Control.Lens hiding (from, to)
19+import Control.Arrow
52import Control.Lens.TH (makeWrapped)
20import Control.Lens.TH (makeWrapped)
53−import Data.Align (align)
21+import Control.Monad.Trans.State
54−import Data.Foldable (toList)
22+import Data.Foldable
55import Data.Function
23import Data.Function
56import Data.List
24import Data.List
57import Data.Map (Map)
25import Data.Map (Map)
58import qualified Data.Map as Map
26import qualified Data.Map as Map
59import Data.Maybe
27import Data.Maybe
60−#if !MIN_VERSION_base(4,11,0)
28+#if !MIN_VERSION_base(4,10,0)
61import Data.Semigroup (Semigroup (..))
29import Data.Semigroup (Semigroup (..))
63import Data.Monoid.DecidablyEmpty
31import Data.Monoid.DecidablyEmpty
65import qualified Data.Set as Set
32import qualified Data.Set as Set
66import Data.These (These (..))
33import Data.These (These (..))
68-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
36-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
69-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
37-- 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
78deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (PatchMapWithPatchingMove k p)
46deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (PatchMapWithPatchingMove k p)
79deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (PatchMapWithPatchingMove k p)
47deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (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?
81−deriving instance ( Ord k
58+deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (NodeInfo k p)
82−#if !MIN_VERSION_base(4,11,0)
59+deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (NodeInfo k p)
83− , Semigroup p
60+deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (NodeInfo k p)
84−#endif
61+deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (NodeInfo k p)
85− , DecidablyEmpty p
62+
86− , Patch p
63+bitraverseNodeInfo
87− ) => DecidablyEmpty (PatchMapWithPatchingMove k p)
64+ :: Applicative f
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
73+-- | Describe how a key's new value should be produced
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
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
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)
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.
89-- | Create a 'PatchMapWithPatchingMove', validating it
100-- | Create a 'PatchMapWithPatchingMove', validating it
90patchMapWithPatchingMove
101patchMapWithPatchingMove
@@ -116,13 +127,7 @@ insertMapKey k v = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo (From_I
116-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
127-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
118moveMapKey
129moveMapKey
119− :: ( DecidablyEmpty p
120−#if !MIN_VERSION_base(4,11,0)
125− => Ord k => k -> k -> PatchMapWithPatchingMove k p
130+ :: (DecidablyEmpty p, Patch p) => Ord k => k -> k -> PatchMapWithPatchingMove k p
126moveMapKey src dst
131moveMapKey src dst
127 | src == dst = mempty
132 | src == dst = mempty
128 | otherwise =
133 | otherwise =
@@ -136,17 +141,12 @@ moveMapKey src dst
137-- let aMay = Map.lookup a map
142-- let aMay = Map.lookup a map
138-- bMay = Map.lookup b map
143-- bMay = Map.lookup b map
139−-- in maybe id (Map.insert a) (bMay <> aMay)
144+-- in maybe id (Map.insert a) (bMay `mplus` aMay)
140−-- . maybe id (Map.insert b) (aMay <> bMay)
145+-- . maybe id (Map.insert b) (aMay `mplus` bMay)
141-- . Map.delete a . Map.delete b $ map
146-- . Map.delete a . Map.delete b $ map
143swapMapKey
148swapMapKey
144− :: ( DecidablyEmpty p
149+ :: (DecidablyEmpty p, Patch p)
145−#if !MIN_VERSION_base(4,11,0)
150 => Ord k => k -> k -> PatchMapWithPatchingMove k p
150 => Ord k => k -> k -> PatchMapWithPatchingMove k p
151swapMapKey src dst
151swapMapKey src dst
152 | src == dst = mempty
152 | src == dst = mempty
@@ -229,70 +229,37 @@ patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatCha
230-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
230-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
231-- will produce the second 'Map'.
231-- will produce the second 'Map'.
232−-- Note: this will never produce a patch on a value.
233patchThatChangesMap
232patchThatChangesMap
235− . (Ord k, Ord (PatchTarget p), Monoid p)
233+ :: (Ord k, Ord (PatchTarget p), Monoid p)
236 => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
234 => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
237patchThatChangesMap oldByIndex newByIndex = patch
235patchThatChangesMap 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
236+ where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
240− -- In the places where we use unionDistinct, a non-distinct key indicates a bug in this function
237+ (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
241− unionDistinct :: forall k' v'. Ord k' => Map k' v' -> Map k' v' -> Map k' v'
238+ let f k v = do
242− unionDistinct = Map.unionWith (error "patchThatChangesMap: non-distinct keys")
239+ remainingValues <- get
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))
240+ let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
244− unionPairDistinct (oldFroms, oldTos) (newFroms, newTos) = (unionDistinct oldFroms newFroms, unionDistinct oldTos newTos)
241+ then Map.delete v remainingValues
245− -- Generate patch info for a single value
242+ else Map.insert v remainingKeys remainingValues
246− -- Keys that are found in both the old and new sets will not be patched
243+ case Map.lookup v remainingValues of
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
244+ Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
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
245+ Just fromKs ->
249− patchSingleValue :: PatchTarget p -> Set k -> Set k -> (Map k (From k p), Map k (To k))
246+ if k `Set.member` fromKs
250− patchSingleValue v oldKeys newKeys = foldl' unionPairDistinct mempty $ align (toList $ oldKeys `Set.difference` newKeys) (toList $ newKeys `Set.difference` oldKeys) <&> \case
247+ then do
251− This oldK -> (mempty, Map.singleton oldK Nothing) -- There's nowhere for this value to go, so we know we are deleting it
248+ putRemainingKeys $ Set.delete k fromKs
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
249+ return $ NodeInfo (From_Move k mempty) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
253− These oldK newK -> (Map.singleton newK $ From_Move oldK mempty, Map.singleton oldK $ Just newK)
250+ else do
254− -- Run patchSingleValue on a These. Missing old or new sets are considered empty
251+ (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
255− patchSingleValueThese :: PatchTarget p -> These (Set k) (Set k) -> (Map k (From k p), Map k (To k))
252+ putRemainingKeys remainingKeys
256− patchSingleValueThese v = \case
253+ return $ NodeInfo (From_Move fromK mempty) $ Just undefined
257− This oldKeys -> patchSingleValue v oldKeys mempty
254+ Map.traverseWithKey f newByIndex
258− That newKeys -> patchSingleValue v mempty newKeys
255+ unusedOldKeys = fold unusedValuesByValue
259− These oldKeys newKeys -> patchSingleValue v oldKeys newKeys
256+ pointlessMove k = \case
260− -- Generate froms and tos for all values, then merge them together
257+ From_Move k' _ | k == k' -> True
261− (froms, tos) = foldl' unionPairDistinct mempty $ Map.mapWithKey patchSingleValueThese $ align (invert oldByIndex) (invert newByIndex)
258+ _ -> False
262− patch = unsafePatchMapWithPatchingMove $ align froms tos <&> \case
259+ keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
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.
260+ then Just undefined
264− That to -> NodeInfo From_Delete to -- Since we don't have a 'from' record for this key, it must be getting deleted
261+ else Nothing
265− These from to -> NodeInfo from to
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
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?
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)
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.
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
297-- | Change the 'From' value of a 'NodeInfo'
264-- | Change the 'From' value of a 'NodeInfo'
298nodeInfoMapFrom
265nodeInfoMapFrom
@@ -310,58 +277,14 @@ nodeInfoSetTo
310 :: To k -> NodeInfo k v -> NodeInfo k v
277 :: To k -> NodeInfo k v -> NodeInfo k v
311nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
278nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
317−-- | Describe how a key's new value should be produced
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
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)
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.
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
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.
354−-- | Helper data structure used for composing patches using the monoid instance.
280+-- |Helper data structure used for composing patches using the monoid instance.
355data Fixup k v
281data Fixup k v
356 = Fixup_Delete
282 = Fixup_Delete
357 | Fixup_Update (These (From k v) (To k))
283 | Fixup_Update (These (From k v) (To k))
359−-- | Compose patches having the same effect as applying the patches in turn:
285+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
360−-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
361instance ( Ord k
286instance ( Ord k
362−#if !MIN_VERSION_base(4,11,0)
287+ , Monoid p
365 , DecidablyEmpty p
288 , DecidablyEmpty p
366 , Patch p
289 , Patch p
367 ) => Semigroup (PatchMapWithPatchingMove k p) where
290 ) => Semigroup (PatchMapWithPatchingMove k p) where
@@ -420,9 +343,7 @@ instance ( Ord k
420-- | Compose patches having the same effect as applying the patches in turn:
343-- | Compose patches having the same effect as applying the patches in turn:
421-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
344-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
422instance ( Ord k
345instance ( Ord k
423−#if !MIN_VERSION_base(4,11,0)
346+ , Monoid p
426 , DecidablyEmpty p
347 , DecidablyEmpty p
427 , Patch p
348 , Patch p
428 ) => Monoid (PatchMapWithPatchingMove k p) where
349 ) => Monoid (PatchMapWithPatchingMove k p) where