@@ -1,4 +1,5 @@
11{-# LANGUAGE CPP #-}
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
23{-# LANGUAGE FlexibleContexts #-}
34{-# LANGUAGE FlexibleInstances #-}
45{-# LANGUAGE LambdaCase #-}
@@ -12,26 +13,57 @@
1213
1314-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
1415-- another
15−module Data.Patch.MapWithPatchingMove where
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
1648
1749import Data.Patch.Class
1850
19−import Control.Arrow
51+import Control.Lens hiding (from, to)
2052import Control.Lens.TH (makeWrapped)
21−import Control.Monad.Trans.State
22−import Data.Foldable
53+import Data.Align (align)
54+import Data.Foldable (toList)
2355import Data.Function
2456import Data.List
2557import Data.Map (Map)
2658import qualified Data.Map as Map
2759import Data.Maybe
28−#if !MIN_VERSION_base(4,10,0)
60+#if !MIN_VERSION_base(4,11,0)
2961import Data.Semigroup (Semigroup (..))
3062#endif
3163import Data.Monoid.DecidablyEmpty
64+import Data.Set (Set)
3265import qualified Data.Set as Set
3366import Data.These (These (..))
34−import Data.Tuple
3567
3668-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
3769-- 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
4678deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (PatchMapWithPatchingMove k p)
4779deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (PatchMapWithPatchingMove k p)
4880
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
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)
9988
10089-- | Create a 'PatchMapWithPatchingMove', validating it
10190patchMapWithPatchingMove
@@ -127,7 +116,13 @@ insertMapKey k v = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo (From_I
127116-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
128117-- @
129118moveMapKey
130− :: (DecidablyEmpty p, Patch p) => Ord k => k -> k -> PatchMapWithPatchingMove k p
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
131126moveMapKey src dst
132127 | src == dst = mempty
133128 | otherwise =
@@ -141,12 +136,17 @@ moveMapKey src dst
141136-- @
142137-- let aMay = Map.lookup a map
143138-- bMay = Map.lookup b map
144−-- in maybe id (Map.insert a) (bMay `mplus` aMay)
145−-- . maybe id (Map.insert b) (aMay `mplus` bMay)
139+-- in maybe id (Map.insert a) (bMay <> aMay)
140+-- . maybe id (Map.insert b) (aMay <> bMay)
146141-- . Map.delete a . Map.delete b $ map
147142-- @
148143swapMapKey
149− :: (DecidablyEmpty p, Patch p)
144+ :: ( DecidablyEmpty p
145+#if !MIN_VERSION_base(4,11,0)
146+ , Semigroup p
147+#endif
148+ , Patch p
149+ )
150150 => Ord k => k -> k -> PatchMapWithPatchingMove k p
151151swapMapKey src dst
152152 | src == dst = mempty
@@ -229,37 +229,70 @@ 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.
232233patchThatChangesMap
233− :: (Ord k, Ord (PatchTarget p), Monoid p)
234+ :: forall k p
235+ . (Ord k, Ord (PatchTarget p), Monoid p)
234236 => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
235237patchThatChangesMap oldByIndex newByIndex = patch
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
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
263296
264297-- | Change the 'From' value of a 'NodeInfo'
265298nodeInfoMapFrom
@@ -277,14 +310,58 @@ nodeInfoSetTo
277310 :: To k -> NodeInfo k v -> NodeInfo k v
278311nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
279312
280−-- |Helper data structure used for composing patches using the monoid instance.
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.
281355data Fixup k v
282356 = Fixup_Delete
283357 | Fixup_Update (These (From k v) (To k))
284358
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@
286361instance ( Ord k
287− , Monoid p
362+#if !MIN_VERSION_base(4,11,0)
363+ , Semigroup p
364+#endif
288365 , DecidablyEmpty p
289366 , Patch p
290367 ) => Semigroup (PatchMapWithPatchingMove k p) where
@@ -343,7 +420,9 @@ instance ( Ord k
343420-- | Compose patches having the same effect as applying the patches in turn:
344421-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
345422instance ( Ord k
346− , Monoid p
423+#if !MIN_VERSION_base(4,11,0)
424+ , Semigroup p
425+#endif
347426 , DecidablyEmpty p
348427 , Patch p
349428 ) => Monoid (PatchMapWithPatchingMove k p) where