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
16module Data.Patch.MapWithPatchingMove
17 ( PatchMapWithPatchingMove (..)
18 , patchMapWithPatchingMove
19 , patchMapWithPatchingMoveInsertAll
24 , unsafePatchMapWithPatchingMove
25 , patchMapWithPatchingMoveNewElements
26 , patchMapWithPatchingMoveNewElementsMap
27 , patchThatSortsMapWith
28 , patchThatChangesAndSortsMapWith
45 -- TODO internals module
49import Data.Patch.Class
51import Control.Lens hiding (from, to)
52import Control.Lens.TH (makeWrapped)
53import Data.Align (align)
54import Data.Foldable (toList)
58import qualified Data.Map as Map
60#if !MIN_VERSION_base(4,11,0)
61import Data.Semigroup (Semigroup (..))
63import Data.Monoid.DecidablyEmpty
65import qualified Data.Set as Set
66import Data.These (These (..))
68-- | 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@,
70-- and vice versa. There should never be any unpaired From/To keys.
71newtype PatchMapWithPatchingMove k p = PatchMapWithPatchingMove
72 { -- | Extract the internal representation of the 'PatchMapWithPatchingMove'
73 unPatchMapWithPatchingMove :: Map k (NodeInfo k p)
76deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (PatchMapWithPatchingMove k p)
77deriving instance (Ord k, Read k, Read p, Read (PatchTarget p)) => Read (PatchMapWithPatchingMove k p)
78deriving 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)
81deriving instance ( Ord k
82#if !MIN_VERSION_base(4,11,0)
87 ) => DecidablyEmpty (PatchMapWithPatchingMove k p)
89-- | Create a 'PatchMapWithPatchingMove', validating it
90patchMapWithPatchingMove
91 :: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithPatchingMove k p)
92patchMapWithPatchingMove m = if valid then Just $ PatchMapWithPatchingMove m else Nothing
93 where valid = forwardLinks == backwardLinks
94 forwardLinks = Map.mapMaybe _nodeInfo_to m
95 backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, p) ->
96 case _nodeInfo_from p of
97 From_Move from _ -> Just (from, to)
100-- | Create a 'PatchMapWithPatchingMove' that inserts everything in the given 'Map'
101patchMapWithPatchingMoveInsertAll
102 :: Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
103patchMapWithPatchingMoveInsertAll m = PatchMapWithPatchingMove $ flip fmap m $ \v -> NodeInfo
104 { _nodeInfo_from = From_Insert v
105 , _nodeInfo_to = Nothing
108-- | Make a @'PatchMapWithPatchingMove' k p@ which has the effect of inserting or replacing a value @v@ at the given key @k@, like 'Map.insert'.
110 :: k -> PatchTarget p -> PatchMapWithPatchingMove k p
111insertMapKey k v = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing
113-- |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:
116-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
119 :: ( DecidablyEmpty p
120#if !MIN_VERSION_base(4,11,0)
125 => Ord k => k -> k -> PatchMapWithPatchingMove k p
127 | src == dst = mempty
129 PatchMapWithPatchingMove $ Map.fromList
130 [ (dst, NodeInfo (From_Move src mempty) Nothing)
131 , (src, NodeInfo From_Delete (Just dst))
134-- |Make a @'PatchMapWithPatchingMove' k p@ which has the effect of swapping two keys in the mapping, equivalent to:
137-- let aMay = Map.lookup a map
138-- bMay = Map.lookup b map
139-- in maybe id (Map.insert a) (bMay <> aMay)
140-- . maybe id (Map.insert b) (aMay <> bMay)
141-- . Map.delete a . Map.delete b $ map
144 :: ( DecidablyEmpty p
145#if !MIN_VERSION_base(4,11,0)
150 => Ord k => k -> k -> PatchMapWithPatchingMove k p
152 | src == dst = mempty
154 PatchMapWithPatchingMove $ Map.fromList
155 [ (dst, NodeInfo (From_Move src mempty) (Just src))
156 , (src, NodeInfo (From_Move dst mempty) (Just dst))
159-- | Make a @'PatchMapWithPatchingMove' k v@ which has the effect of deleting a key in
160-- the mapping, equivalent to 'Map.delete'.
162 :: k -> PatchMapWithPatchingMove k v
163deleteMapKey k = PatchMapWithPatchingMove . Map.singleton k $ NodeInfo From_Delete Nothing
165-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithPatchingMove' k v@, without checking any invariants.
167-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithPatchingMove' are preserved; they will not be checked.
168unsafePatchMapWithPatchingMove
169 :: Map k (NodeInfo k p) -> PatchMapWithPatchingMove k p
170unsafePatchMapWithPatchingMove = PatchMapWithPatchingMove
172-- | Apply the insertions, deletions, and moves to a given 'Map'
173instance (Ord k, Patch p) => Patch (PatchMapWithPatchingMove k p) where
174 type PatchTarget (PatchMapWithPatchingMove k p) = Map k (PatchTarget p)
175 -- TODO: return Nothing sometimes
176 -- Note: the strict application here is critical to ensuring that incremental
177 -- merges don't hold onto all their prerequisite events forever; can we make
179 apply (PatchMapWithPatchingMove m) old = Just $! insertions `Map.union` (old `Map.difference` deletions)
180 where insertions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
181 From_Insert v -> Just v
182 From_Move k p -> applyAlways p <$> Map.lookup k old
183 From_Delete -> Nothing
184 deletions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
185 From_Delete -> Just ()
188-- | Returns all the new elements that will be added to the 'Map'
189patchMapWithPatchingMoveNewElements
190 :: PatchMapWithPatchingMove k p -> [PatchTarget p]
191patchMapWithPatchingMoveNewElements = Map.elems . patchMapWithPatchingMoveNewElementsMap
193-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithPatchingMove' k v@.
194patchMapWithPatchingMoveNewElementsMap
195 :: PatchMapWithPatchingMove k p -> Map k (PatchTarget p)
196patchMapWithPatchingMoveNewElementsMap (PatchMapWithPatchingMove p) = Map.mapMaybe f p
197 where f ni = case _nodeInfo_from ni of
198 From_Insert v -> Just v
199 From_Move _ _ -> Nothing
200 From_Delete -> Nothing
202-- | Create a 'PatchMapWithPatchingMove' that, if applied to the given 'Map', will sort
203-- its values using the given ordering function. The set keys of the 'Map' is
207 => (PatchTarget p -> PatchTarget p -> Ordering)
208 -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
209patchThatSortsMapWith cmp m = PatchMapWithPatchingMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
210 where unsorted = Map.toList m
211 sorted = sortBy (cmp `on` snd) unsorted
212 f (to, _) (from, _) = if to == from then Nothing else
214 reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
215 g (to, _) (from, _) = if to == from then Nothing else
216 let Just movingTo = Map.lookup from reverseMapping
217 in Just (to, NodeInfo (From_Move from mempty) $ Just movingTo)
219-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
220-- will produce a 'Map' with the same values as the second 'Map' but with the
221-- values sorted with the given ordering function.
222patchThatChangesAndSortsMapWith
223 :: forall k p. (Ord k, Ord (PatchTarget p), Monoid p)
224 => (PatchTarget p -> PatchTarget p -> Ordering)
225 -> Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
226patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
227 where newList = Map.toList newByIndexUnsorted
228 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
230-- | Create a 'PatchMapWithPatchingMove' that, if applied to the first 'Map' provided,
231-- will produce the second 'Map'.
232-- Note: this will never produce a patch on a value.
235 . (Ord k, Ord (PatchTarget p), Monoid p)
236 => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithPatchingMove k p
237patchThatChangesMap 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
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
271-- | Holds the information about each key: where its new value should come from,
272-- and where its old value should go to
273data 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?
280deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (NodeInfo k p)
281deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (NodeInfo k p)
282deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (NodeInfo k p)
283deriving 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)
293bitraverseNodeInfo fk fp fpt (NodeInfo from to) = NodeInfo
294 <$> bitraverseFrom fk fp fpt from
297-- | Change the 'From' value of a 'NodeInfo'
299 :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
300nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
302-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
303-- 'Applicative', 'Monad', etc.) action to get the new value
305 :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
306nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
308-- | Set the 'To' field of a 'NodeInfo'
310 :: To k -> NodeInfo k v -> NodeInfo k v
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
323deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (From k p)
324deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (From k p)
325deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (From k p)
326deriving 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)
336bitraverseFrom 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.
357 | Fixup_Update (These (From k v) (To k))
359-- | Compose patches having the same effect as applying the patches in turn:
360-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
362#if !MIN_VERSION_base(4,11,0)
367 ) => Semigroup (PatchMapWithPatchingMove k p) where
368 PatchMapWithPatchingMove ma <> PatchMapWithPatchingMove mb = PatchMapWithPatchingMove m
370 connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb
371 h :: (k, (Maybe k, From k p)) -> [(k, Fixup k p)]
372 h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of
373 (Just toAfter, From_Move fromBefore p)
374 | fromBefore == toAfter && isEmpty p
375 -> [(toAfter, Fixup_Delete)]
377 -> [ (toAfter, Fixup_Update (This editBefore))
378 , (fromBefore, Fixup_Update (That mToAfter))
380 (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
381 (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]
383 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
384 mergeFixups _ (Fixup_Update a) (Fixup_Update b)
385 | This x <- a, That y <- b
386 = Fixup_Update $ These x y
387 | That y <- a, This x <- b
388 = Fixup_Update $ These x y
389 mergeFixups _ _ _ = error "PatchMapWithPatchingMove: incompatible fixups"
390 fixups = Map.fromListWithKey mergeFixups $ concatMap h connections
391 combineNodeInfos _ nia nib = NodeInfo
392 { _nodeInfo_from = _nodeInfo_from nia
393 , _nodeInfo_to = _nodeInfo_to nib
395 applyFixup _ ni = \case
396 Fixup_Delete -> Nothing
397 Fixup_Update u -> Just $ NodeInfo
398 { _nodeInfo_from = case _nodeInfo_from ni of
399 f@(From_Move _ p') -> case getHere u of -- The `from` fixup comes from the "old" patch
400 Nothing -> f -- If there's no `from` fixup, just use the "new" `from`
401 Just (From_Insert v) -> From_Insert $ applyAlways p' v
402 Just From_Delete -> From_Delete
403 Just (From_Move oldKey p) -> From_Move oldKey $ p' <> p
404 _ -> error "PatchMapWithPatchingMove: fixup for non-move From"
405 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
407 m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups
408 getHere :: These a b -> Maybe a
413 getThere :: These a b -> Maybe b
419--TODO: Figure out how to implement this in terms of PatchDMapWithPatchingMove rather than duplicating it here
420-- | Compose patches having the same effect as applying the patches in turn:
421-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
423#if !MIN_VERSION_base(4,11,0)
428 ) => Monoid (PatchMapWithPatchingMove k p) where
429 mempty = PatchMapWithPatchingMove mempty
432makeWrapped ''PatchMapWithPatchingMove
keysesc to close
- j k
- move down, up
- enter
- open
- esc
- back, or up a level
- 1 2 3 4
- readme, files, commits, refs
- /
- filter
- y
- copy the clone command
- c
- compare the chosen commit with another (or shift-click both)
- ?
- show or hide this list