@@ -0,0 +1,378 @@
1+{-# LANGUAGE CPP #-}
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 #-}
13+
14+-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
15+-- another
16+module Data.Patch.MapWithPatchingMove where
17+
18+import Data.Patch.Class
19+
20+import Control.Arrow
21+import Control.Lens.TH (makeWrapped)
22+import Control.Monad.Trans.State
23+import Data.Foldable
24+import Data.Function
25+import Data.List
26+import Data.Map (Map)
27+import qualified Data.Map as Map
28+import Data.Maybe
29+#if !MIN_VERSION_base(4,11,0)
30+import Data.Semigroup (Semigroup (..))
31+#endif
32+import Data.Monoid.DecidablyEmpty
33+import qualified Data.Set as Set
34+import Data.These (These (..))
35+import Data.Tuple
36+
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)
43+ }
44+
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)
49+
50+deriving instance ( Ord k
51+#if !MIN_VERSION_base(4,11,0)
52+ , Semigroup p
53+#endif
54+ , DecidablyEmpty p
55+ , Patch p
56+ ) => DecidablyEmpty (PatchMapWithPatchingMove k p)
57+
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?
66+ }
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)
71+
72+bitraverseNodeInfo
73+ :: Applicative f
74+ => (k0 -> f k1)
75+ -> (p0 -> f p1)
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
80+ <*> traverse fk to
81+
82+-- | Describe how a key's new value should be produced
83+data From k p
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
87+
88+bitraverseFrom
89+ :: Applicative f
90+ => (k0 -> f k1)
91+ -> (p0 -> f p1)
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
98+
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)
103+
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.
107+type To = Maybe
108+
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)
118+ _ -> Nothing
119+
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
126+ }
127+
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'.
129+insertMapKey
130+ :: k -> PatchTarget p -> PatchMapWithPatchingMove k p
131+insertMapKey k v = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing
132+
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:
134+--
135+-- @
136+-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
137+-- @
138+moveMapKey
139+ :: ( DecidablyEmpty p
140+#if !MIN_VERSION_base(4,11,0)
141+ , Semigroup p
142+#endif
143+ , Patch p
144+ )
145+ => Ord k => k -> k -> PatchMapWithPatchingMove k p
146+moveMapKey src dst
147+ | src == dst = mempty
148+ | otherwise =
149+ PatchMapWithPatchingMove $ Map.fromList
150+ [ (dst, NodeInfo (From_Move src mempty) Nothing)
151+ , (src, NodeInfo From_Delete (Just dst))
152+ ]
153+
154+-- |Make a @'PatchMapWithPatchingMove' k p@ which has the effect of swapping two keys in the mapping, equivalent to:
155+--
156+-- @
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
162+-- @
163+swapMapKey
164+ :: ( DecidablyEmpty p
165+#if !MIN_VERSION_base(4,11,0)
166+ , Semigroup p
167+#endif
168+ , Patch p
169+ )
170+ => Ord k => k -> k -> PatchMapWithPatchingMove k p
171+swapMapKey src dst
172+ | src == dst = mempty
173+ | otherwise =
174+ PatchMapWithPatchingMove $ Map.fromList
175+ [ (dst, NodeInfo (From_Move src mempty) (Just src))
176+ , (src, NodeInfo (From_Move dst mempty) (Just dst))
177+ ]
178+
179+-- | Make a @'PatchMapWithPatchingMove' k v@ which has the effect of deleting a key in
180+-- the mapping, equivalent to 'Map.delete'.
181+deleteMapKey
182+ :: k -> PatchMapWithPatchingMove k v
183+deleteMapKey k = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo From_Delete Nothing
184+
185+-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithPatchingMove' k v@, without checking any invariants.
186+--
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
191+
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 ()
206+ _ -> Nothing
207+
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
212+
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
221+
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
224+-- not changed.
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
233+ Just (from, to)
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)
238+
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
249+
250+-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
251+-- will produce the second 'Map'.
252+patchThatChangesMap
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
258+ let f k v = 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
265+ Just fromKs ->
266+ if k `Set.member` fromKs
267+ then do
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
270+ else do
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
278+ _ -> False
279+ keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
280+ then Just undefined
281+ else Nothing
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
283+
284+-- | Change the 'From' value of a 'NodeInfo'
285+nodeInfoMapFrom
286+ :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
287+nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
288+
289+-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
290+-- 'Applicative', 'Monad', etc.) action to get the new value
291+nodeInfoMapMFrom
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
294+
295+-- | Set the 'To' field of a 'NodeInfo'
296+nodeInfoSetTo
297+ :: To k -> NodeInfo k v -> NodeInfo k v
298+nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
299+
300+-- | Helper data structure used for composing patches using the monoid instance.
301+data Fixup k v
302+ = Fixup_Delete
303+ | Fixup_Update (These (From k v) (To k))
304+
305+-- | Compose patches having the same effect as applying the patches in turn:
306+-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
307+instance ( Ord k
308+#if !MIN_VERSION_base(4,11,0)
309+ , Semigroup p
310+#endif
311+ , DecidablyEmpty p
312+ , Patch p
313+ ) => Semigroup (PatchMapWithPatchingMove k p) where
314+ PatchMapWithPatchingMove ma <> PatchMapWithPatchingMove mb = PatchMapWithPatchingMove m
315+ where
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)]
322+ | otherwise
323+ -> [ (toAfter, Fixup_Update (This editBefore))
324+ , (fromBefore, Fixup_Update (That mToAfter))
325+ ]
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))]
328+ (Nothing, _) -> []
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
340+ }
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
352+ }
353+ m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups
354+ getHere :: These a b -> Maybe a
355+ getHere = \case
356+ This a -> Just a
357+ These a _ -> Just a
358+ That _ -> Nothing
359+ getThere :: These a b -> Maybe b
360+ getThere = \case
361+ This _ -> Nothing
362+ These _ b -> Just b
363+ That b -> Just b
364+
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@
368+instance ( Ord k
369+#if !MIN_VERSION_base(4,11,0)
370+ , Semigroup p
371+#endif
372+ , DecidablyEmpty p
373+ , Patch p
374+ ) => Monoid (PatchMapWithPatchingMove k p) where
375+ mempty = PatchMapWithPatchingMove mempty
376+ mappend = (<>)
377+
378+makeWrapped ''PatchMapWithPatchingMove