@@ -0,0 +1,378 @@
2+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3+{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE LambdaCase #-}
6+{-# LANGUAGE MultiParamTypeClasses #-}
7+{-# LANGUAGE PatternGuards #-}
8+{-# LANGUAGE ScopedTypeVariables #-}
9+{-# LANGUAGE StandaloneDeriving #-}
10+{-# LANGUAGE TemplateHaskell #-}
11+{-# LANGUAGE TypeFamilies #-}
12+{-# LANGUAGE UndecidableInstances #-}
14+-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
16+module Data.Patch.MapWithPatchingMove where
18+import Data.Patch.Class
21+import Control.Lens.TH (makeWrapped)
22+import Control.Monad.Trans.State
27+import qualified Data.Map as Map
29+#if !MIN_VERSION_base(4,11,0)
30+import Data.Semigroup (Semigroup (..))
32+import Data.Monoid.DecidablyEmpty
33+import qualified Data.Set as Set
34+import Data.These (These (..))
37+-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
38+-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
39+-- and vice versa. There should never be any unpaired From/To keys.
40+newtype PatchMapWithPatchingMove k p = PatchMapWithPatchingMove
41+ { -- | Extract the internal representation of the 'PatchMapWithPatchingMove'
42+ unPatchMapWithPatchingMove :: Map k (NodeInfo k p)
45+deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (PatchMapWithPatchingMove k p)
46+deriving instance (Ord k, Read k, Read p, Read (PatchTarget p)) => Read (PatchMapWithPatchingMove k p)
47+deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (PatchMapWithPatchingMove k p)
48+deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (PatchMapWithPatchingMove k p)
50+deriving instance ( Ord k
51+#if !MIN_VERSION_base(4,11,0)
56+ ) => DecidablyEmpty (PatchMapWithPatchingMove k p)
58+-- | Holds the information about each key: where its new value should come from,
59+-- and where its old value should go to
60+data NodeInfo k p = NodeInfo
61+ { _nodeInfo_from :: !(From k p)
62+ -- ^ Where do we get the new value for this key?
63+ , _nodeInfo_to :: !(To k)
64+ -- ^ If the old value is being kept (i.e. moved rather than deleted or
65+ -- replaced), where is it going?
67+deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (NodeInfo k p)
68+deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (NodeInfo k p)
69+deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (NodeInfo k p)
70+deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (NodeInfo k p)
76+ -> (PatchTarget p0 -> f (PatchTarget p1))
77+ -> NodeInfo k0 p0 -> f (NodeInfo k1 p1)
78+bitraverseNodeInfo fk fp fpt (NodeInfo from to) = NodeInfo
79+ <$> bitraverseFrom fk fp fpt from
82+-- | Describe how a key's new value should be produced
84+ = From_Insert (PatchTarget p) -- ^ Insert the given value here
85+ | From_Delete -- ^ Delete the existing value, if any, from here
86+ | From_Move !k !p -- ^ Move the value here from the given key, and apply the given patch
92+ -> (PatchTarget p0 -> f (PatchTarget p1))
93+ -> From k0 p0 -> f (From k1 p1)
94+bitraverseFrom fk fp fpt = \case
95+ From_Insert pt -> From_Insert <$> fpt pt
96+ From_Delete -> pure From_Delete
97+ From_Move k p -> From_Move <$> fk k <*> fp p
99+deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (From k p)
100+deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (From k p)
101+deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (From k p)
102+deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (From k p)
104+-- | Describe where a key's old value will go. If this is 'Just', that means
105+-- the key's old value will be moved to the given other key; if it is 'Nothing',
106+-- that means it will be deleted.
109+-- | Create a 'PatchMapWithPatchingMove', validating it
110+patchMapWithPatchingMove
111+ :: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithPatchingMove k p)
112+patchMapWithPatchingMove m = if valid then Just $ PatchMapWithPatchingMove m else Nothing
113+ where valid = forwardLinks == backwardLinks
114+ forwardLinks = Map.mapMaybe _nodeInfo_to m
115+ backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, p) ->
116+ case _nodeInfo_from p of
117+ From_Move from _ -> Just (from, to)
120+-- | Create a 'PatchMapWithPatchingMove' that inserts everything in the given 'Map'
121+patchMapWithPatchingMoveInsertAll
122+ :: Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
123+patchMapWithPatchingMoveInsertAll m = PatchMapWithPatchingMove $ flip fmap m $ \v -> NodeInfo
124+ { _nodeInfo_from = From_Insert v
125+ , _nodeInfo_to = Nothing
128+-- | Make a @'PatchMapWithPatchingMove' k p@ which has the effect of inserting or replacing a value @v@ at the given key @k@, like 'Map.insert'.
130+ :: k -> PatchTarget p -> PatchMapWithPatchingMove k p
131+insertMapKey k v = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing
133+-- |Make a @'PatchMapWithPatchingMove' k p@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to:
136+-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
139+ :: ( DecidablyEmpty p
140+#if !MIN_VERSION_base(4,11,0)
145+ => Ord k => k -> k -> PatchMapWithPatchingMove k p
147+ | src == dst = mempty
149+ PatchMapWithPatchingMove $ Map.fromList
150+ [ (dst, NodeInfo (From_Move src mempty) Nothing)
151+ , (src, NodeInfo From_Delete (Just dst))
154+-- |Make a @'PatchMapWithPatchingMove' k p@ which has the effect of swapping two keys in the mapping, equivalent to:
157+-- let aMay = Map.lookup a map
158+-- bMay = Map.lookup b map
159+-- in maybe id (Map.insert a) (bMay `mplus` aMay)
160+-- . maybe id (Map.insert b) (aMay `mplus` bMay)
161+-- . Map.delete a . Map.delete b $ map
164+ :: ( DecidablyEmpty p
165+#if !MIN_VERSION_base(4,11,0)
170+ => Ord k => k -> k -> PatchMapWithPatchingMove k p
172+ | src == dst = mempty
174+ PatchMapWithPatchingMove $ Map.fromList
175+ [ (dst, NodeInfo (From_Move src mempty) (Just src))
176+ , (src, NodeInfo (From_Move dst mempty) (Just dst))
179+-- | Make a @'PatchMapWithPatchingMove' k v@ which has the effect of deleting a key in
180+-- the mapping, equivalent to 'Map.delete'.
182+ :: k -> PatchMapWithPatchingMove k v
183+deleteMapKey k = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo From_Delete Nothing
185+-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithPatchingMove' k v@, without checking any invariants.
187+-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithPatchingMove' are preserved; they will not be checked.
188+unsafePatchMapWithPatchingMove
189+ :: Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
190+unsafePatchMapWithPatchingMove = PatchMapWithPatchingMove
192+-- | Apply the insertions, deletions, and moves to a given 'Map'
193+instance (Ord k, Patch p) => Patch (PatchMapWithPatchingMove k p) where
194+ type PatchTarget (PatchMapWithPatchingMove k p) = Map k (PatchTarget p)
195+ -- TODO: return Nothing sometimes
196+ -- Note: the strict application here is critical to ensuring that incremental
197+ -- merges don't hold onto all their prerequisite events forever; can we make
198+ -- this more robust?
199+ apply (PatchMapWithPatchingMove m) old = Just $! insertions `Map.union` (old `Map.difference` deletions)
200+ where insertions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
201+ From_Insert v -> Just v
202+ From_Move k p -> applyAlways p <$> Map.lookup k old
203+ From_Delete -> Nothing
204+ deletions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
205+ From_Delete -> Just ()
208+-- | Returns all the new elements that will be added to the 'Map'
209+patchMapWithPatchingMoveNewElements
210+ :: PatchMapWithPatchingMove k p -> [PatchTarget p]
211+patchMapWithPatchingMoveNewElements = Map.elems . patchMapWithPatchingMoveNewElementsMap
213+-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithPatchingMove' k v@.
214+patchMapWithPatchingMoveNewElementsMap
215+ :: PatchMapWithPatchingMove k p -> Map k (PatchTarget p)
216+patchMapWithPatchingMoveNewElementsMap (PatchMapWithPatchingMove p) = Map.mapMaybe f p
217+ where f ni = case _nodeInfo_from ni of
218+ From_Insert v -> Just v
219+ From_Move _ _ -> Nothing
220+ From_Delete -> Nothing
222+-- | Create a 'PatchMapWithPatchingMove' that, if applied to the given 'Map', will sort
223+-- its values using the given ordering function. The set keys of the 'Map' is
225+patchThatSortsMapWith
226+ :: (Ord k, Monoid p)
227+ => (PatchTarget p -> PatchTarget p -> Ordering)
228+ -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
229+patchThatSortsMapWith cmp m = PatchMapWithPatchingMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
230+ where unsorted = Map.toList m
231+ sorted = sortBy (cmp `on` snd) unsorted
232+ f (to, _) (from, _) = if to == from then Nothing else
234+ reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
235+ g (to, _) (from, _) = if to == from then Nothing else
236+ let Just movingTo = Map.lookup from reverseMapping
237+ in Just (to, NodeInfo (From_Move from mempty) $ Just movingTo)
239+-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
240+-- will produce a 'Map' with the same values as the second 'Map' but with the
241+-- values sorted with the given ordering function.
242+patchThatChangesAndSortsMapWith
243+ :: forall k p. (Ord k, Ord (PatchTarget p), Monoid p)
244+ => (PatchTarget p -> PatchTarget p -> Ordering)
245+ -> Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
246+patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
247+ where newList = Map.toList newByIndexUnsorted
248+ newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
250+-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
251+-- will produce the second 'Map'.
253+ :: (Ord k, Ord (PatchTarget p), Monoid p)
254+ => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
255+patchThatChangesMap oldByIndex newByIndex = patch
256+ where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
257+ (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
259+ remainingValues <- get
260+ let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
261+ then Map.delete v remainingValues
262+ else Map.insert v remainingKeys remainingValues
263+ case Map.lookup v remainingValues of
264+ Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
266+ if k `Set.member` fromKs
268+ putRemainingKeys $ Set.delete k fromKs
269+ return $ NodeInfo (From_Move k mempty) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
271+ (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
272+ putRemainingKeys remainingKeys
273+ return $ NodeInfo (From_Move fromK mempty) $ Just undefined
274+ Map.traverseWithKey f newByIndex
275+ unusedOldKeys = fold unusedValuesByValue
276+ pointlessMove k = \case
277+ From_Move k' _ | k == k' -> True
279+ keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
282+ 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
284+-- | Change the 'From' value of a 'NodeInfo'
286+ :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
287+nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
289+-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
290+-- 'Applicative', 'Monad', etc.) action to get the new value
292+ :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
293+nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
295+-- | Set the 'To' field of a 'NodeInfo'
297+ :: To k -> NodeInfo k v -> NodeInfo k v
298+nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
300+-- | Helper data structure used for composing patches using the monoid instance.
303+ | Fixup_Update (These (From k v) (To k))
305+-- | Compose patches having the same effect as applying the patches in turn:
306+-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
308+#if !MIN_VERSION_base(4,11,0)
313+ ) => Semigroup (PatchMapWithPatchingMove k p) where
314+ PatchMapWithPatchingMove ma <> PatchMapWithPatchingMove mb = PatchMapWithPatchingMove m
316+ connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb
317+ h :: (k, (Maybe k, From k p)) -> [(k, Fixup k p)]
318+ h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of
319+ (Just toAfter, From_Move fromBefore p)
320+ | fromBefore == toAfter && isEmpty p
321+ -> [(toAfter, Fixup_Delete)]
323+ -> [ (toAfter, Fixup_Update (This editBefore))
324+ , (fromBefore, Fixup_Update (That mToAfter))
326+ (Nothing, From_Move fromBefore _) -> [(fromBefore, Fixup_Update (That mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map
327+ (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]
329+ mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
330+ mergeFixups _ (Fixup_Update a) (Fixup_Update b)
331+ | This x <- a, That y <- b
332+ = Fixup_Update $ These x y
333+ | That y <- a, This x <- b
334+ = Fixup_Update $ These x y
335+ mergeFixups _ _ _ = error "PatchMapWithPatchingMove: incompatible fixups"
336+ fixups = Map.fromListWithKey mergeFixups $ concatMap h connections
337+ combineNodeInfos _ nia nib = NodeInfo
338+ { _nodeInfo_from = _nodeInfo_from nia
339+ , _nodeInfo_to = _nodeInfo_to nib
341+ applyFixup _ ni = \case
342+ Fixup_Delete -> Nothing
343+ Fixup_Update u -> Just $ NodeInfo
344+ { _nodeInfo_from = case _nodeInfo_from ni of
345+ f@(From_Move _ p') -> case getHere u of -- The `from` fixup comes from the "old" patch
346+ Nothing -> f -- If there's no `from` fixup, just use the "new" `from`
347+ Just (From_Insert v) -> From_Insert $ applyAlways p' v
348+ Just From_Delete -> From_Delete
349+ Just (From_Move oldKey p) -> From_Move oldKey $ p' <> p
350+ _ -> error "PatchMapWithPatchingMove: fixup for non-move From"
351+ , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
353+ m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups
354+ getHere :: These a b -> Maybe a
359+ getThere :: These a b -> Maybe b
365+--TODO: Figure out how to implement this in terms of PatchDMapWithPatchingMove rather than duplicating it here
366+-- | Compose patches having the same effect as applying the patches in turn:
367+-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
369+#if !MIN_VERSION_base(4,11,0)
374+ ) => Monoid (PatchMapWithPatchingMove k p) where
375+ mempty = PatchMapWithPatchingMove mempty
378+makeWrapped ''PatchMapWithPatchingMove