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