@@ -2,97 +2,150 @@
2{-# LANGUAGE DeriveTraversable #-}
2{-# LANGUAGE DeriveTraversable #-}
3{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE PatternGuards #-}
8{-# LANGUAGE PatternGuards #-}
9+{-# LANGUAGE PatternSynonyms #-}
8{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE StandaloneDeriving #-}
9{-# LANGUAGE TemplateHaskell #-}
12{-# LANGUAGE TemplateHaskell #-}
10{-# LANGUAGE TypeApplications #-}
13{-# LANGUAGE TypeApplications #-}
11{-# LANGUAGE TypeFamilies #-}
14{-# LANGUAGE TypeFamilies #-}
15+{-# LANGUAGE ViewPatterns #-}
13-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
17-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
15−module Data.Patch.MapWithMove where
19+module Data.Patch.MapWithMove
26+ , patchMapWithMoveInsertAll
31+ , unsafePatchMapWithMove
32+ , patchMapWithMoveNewElements
33+ , patchMapWithMoveNewElementsMap
34+ , patchThatSortsMapWith
35+ , patchThatChangesAndSortsMapWith
36+ , patchThatChangesMap
64+import Data.Kind (Type)
17import Data.Patch.Class
65import Data.Patch.Class
66+import Data.Patch.MapWithPatchingMove (PatchMapWithPatchingMove(..), To)
67+import qualified Data.Patch.MapWithPatchingMove as PM -- already a transparent synonym
19−import Control.Lens hiding (from, to)
69+import Control.Lens
20−import Data.Align (align)
23import Data.List
70import Data.List
24import Data.Map (Map)
71import Data.Map (Map)
25import qualified Data.Map as Map
72import qualified Data.Map as Map
26−import Data.Maybe
73+import Data.Proxy
27#if !MIN_VERSION_base(4,11,0)
74#if !MIN_VERSION_base(4,11,0)
28import Data.Semigroup (Semigroup (..))
75import Data.Semigroup (Semigroup (..))
30−import Data.Set (Set)
77+import Data.Traversable (foldMapDefault)
31−import qualified Data.Set as Set
32−import Data.These (These(..))
34-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
79-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
35-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
80-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
36-- and vice versa. There should never be any unpaired From/To keys.
81-- and vice versa. There should never be any unpaired From/To keys.
37−newtype PatchMapWithMove k v = PatchMapWithMove
82+newtype PatchMapWithMove k (v :: Type) = PatchMapWithMove'
38− { -- | Extract the internal representation of the 'PatchMapWithMove'
83+ { -- | Extract the underlying 'PatchMapWithPatchingMove k (Proxy v)'
39− unPatchMapWithMove :: Map k (NodeInfo k v)
84+ unPatchMapWithMove' :: PatchMapWithPatchingMove k (Proxy v)
41 deriving ( Show, Read, Eq, Ord
86 deriving ( Show, Read, Eq, Ord
42− , Functor, Foldable, Traversable
87+-- Haddock cannot handle documentation here before GHC 8.6
89+#if __GLASGOW_HASKELL__ >= 806
90+ -- | Compose patches having the same effect as applying the
91+ -- patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p .
45−-- | Holds the information about each key: where its new value should come from,
98+pattern Coerce :: Coercible a b => a -> b
46−-- and where its old value should go to
99+pattern Coerce x <- (coerce -> x)
47−data NodeInfo k v = NodeInfo
100+ where Coerce x = coerce x
48− { _nodeInfo_from :: !(From k v)
49− -- ^ Where do we get the new value for this key?
50− , _nodeInfo_to :: !(To k)
51− -- ^ If the old value is being kept (i.e. moved rather than deleted or
52− -- replaced), where is it going?
54− deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
56−-- | Describe how a key's new value should be produced
102+{-# COMPLETE PatchMapWithMove #-}
57−data From k v
103+pattern PatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
58− = From_Insert v -- ^ Insert the given value here
104+-- | Extract the representation of the 'PatchMapWithMove' as a map of
59− | From_Delete -- ^ Delete the existing value, if any, from here
105+-- 'NodeInfo'.
60− | From_Move !k -- ^ Move the value here from the given key
106+unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)
61− deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
107+pattern PatchMapWithMove { unPatchMapWithMove } = PatchMapWithMove' (PatchMapWithPatchingMove (Coerce unPatchMapWithMove))
63−-- | Describe where a key's old value will go. If this is 'Just', that means
109+_PatchMapWithMove
64−-- the key's old value will be moved to the given other key; if it is 'Nothing',
110+ :: Iso
65−-- that means it will be deleted.
111+ (PatchMapWithMove k0 v0)
66−type To = Maybe
112+ (PatchMapWithMove k1 v1)
113+ (Map k0 (NodeInfo k0 v0))
114+ (Map k1 (NodeInfo k1 v1))
115+_PatchMapWithMove = iso unPatchMapWithMove PatchMapWithMove
117+instance Functor (PatchMapWithMove k) where
118+ fmap f = runIdentity . traverse (Identity . f)
120+instance Foldable (PatchMapWithMove k) where
121+ foldMap = foldMapDefault
68−makeWrapped ''PatchMapWithMove
123+instance Traversable (PatchMapWithMove k) where
70instance FunctorWithIndex k (PatchMapWithMove k)
129instance FunctorWithIndex k (PatchMapWithMove k)
71instance FoldableWithIndex k (PatchMapWithMove k)
130instance FoldableWithIndex k (PatchMapWithMove k)
72instance TraversableWithIndex k (PatchMapWithMove k) where
131instance TraversableWithIndex k (PatchMapWithMove k) where
73 itraverse = itraversed . Indexed
132 itraverse = itraversed . Indexed
74− itraversed = _Wrapped .> itraversed <. traversed
133+ itraversed =
134+ _PatchMapWithMove .>
76-- | Create a 'PatchMapWithMove', validating it
138-- | Create a 'PatchMapWithMove', validating it
77patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
139patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
78−patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
140+patchMapWithMove = fmap PatchMapWithMove' . PM.patchMapWithPatchingMove . coerce
79− where valid = forwardLinks == backwardLinks
80− forwardLinks = Map.mapMaybe _nodeInfo_to m
81− backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, v) ->
82− case _nodeInfo_from v of
83− From_Move from -> Just (from, to)
86-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'
142-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'
87patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v
143patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v
88−patchMapWithMoveInsertAll m = PatchMapWithMove $ flip fmap m $ \v -> NodeInfo
144+patchMapWithMoveInsertAll = PatchMapWithMove' . PM.patchMapWithPatchingMoveInsertAll
89− { _nodeInfo_from = From_Insert v
90− , _nodeInfo_to = Nothing
93-- | Make a @'PatchMapWithMove' k v@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'.
146-- | Make a @'PatchMapWithMove' k v@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'.
94insertMapKey :: k -> v -> PatchMapWithMove k v
147insertMapKey :: k -> v -> PatchMapWithMove k v
95−insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing
148+insertMapKey k v = PatchMapWithMove' $ PM.insertMapKey k v
97-- |Make a @'PatchMapWithMove' k v@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to:
150-- |Make a @'PatchMapWithMove' k v@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to:
@@ -100,188 +153,160 @@ insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v)
100-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
153-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
102moveMapKey :: Ord k => k -> k -> PatchMapWithMove k v
155moveMapKey :: Ord k => k -> k -> PatchMapWithMove k v
103−moveMapKey src dst
156+moveMapKey src dst = PatchMapWithMove' $ PM.moveMapKey src dst
104− | src == dst = mempty
106− PatchMapWithMove $ Map.fromList
107− [ (dst, NodeInfo (From_Move src) Nothing)
108− , (src, NodeInfo From_Delete (Just dst))
111-- |Make a @'PatchMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
158-- |Make a @'PatchMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
114-- let aMay = Map.lookup a map
161-- let aMay = Map.lookup a map
115-- bMay = Map.lookup b map
162-- bMay = Map.lookup b map
116−-- in maybe id (Map.insert a) (bMay `mplus` aMay)
163+-- in maybe id (Map.insert a) (bMay <> aMay)
117−-- . maybe id (Map.insert b) (aMay `mplus` bMay)
164+-- . maybe id (Map.insert b) (aMay <> bMay)
118-- . Map.delete a . Map.delete b $ map
165-- . Map.delete a . Map.delete b $ map
120swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v
167swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v
121−swapMapKey src dst
168+swapMapKey src dst = PatchMapWithMove' $ PM.swapMapKey src dst
122− | src == dst = mempty
124− PatchMapWithMove $ Map.fromList
125− [ (dst, NodeInfo (From_Move src) (Just src))
126− , (src, NodeInfo (From_Move dst) (Just dst))
129-- |Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'.
170-- |Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'.
130deleteMapKey :: k -> PatchMapWithMove k v
171deleteMapKey :: k -> PatchMapWithMove k v
131−deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete Nothing
172+deleteMapKey = PatchMapWithMove' . PM.deleteMapKey
133-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants.
174-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants.
135-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked.
176-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked.
136unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
177unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
137−unsafePatchMapWithMove = PatchMapWithMove
178+unsafePatchMapWithMove = coerce PM.unsafePatchMapWithPatchingMove
139-- | Apply the insertions, deletions, and moves to a given 'Map'
180-- | Apply the insertions, deletions, and moves to a given 'Map'
140instance Ord k => Patch (PatchMapWithMove k v) where
181instance Ord k => Patch (PatchMapWithMove k v) where
141 type PatchTarget (PatchMapWithMove k v) = Map k v
182 type PatchTarget (PatchMapWithMove k v) = Map k v
142− apply (PatchMapWithMove p) old = Just $! insertions `Map.union` (old `Map.difference` deletions) --TODO: return Nothing sometimes --Note: the strict application here is critical to ensuring that incremental merges don't hold onto all their prerequisite events forever; can we make this more robust?
183+ apply (PatchMapWithMove' p) = apply p
143− where insertions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of
144− From_Insert v -> Just v
145− From_Move k -> Map.lookup k old
146− From_Delete -> Nothing
147− deletions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of
148− From_Delete -> Just ()
151-- | Returns all the new elements that will be added to the 'Map'.
185-- | Returns all the new elements that will be added to the 'Map'.
152patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
186patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
153−patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap
187+patchMapWithMoveNewElements = PM.patchMapWithPatchingMoveNewElements . unPatchMapWithMove'
155-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@.
189-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@.
156patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v
190patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v
157−patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p
191+patchMapWithMoveNewElementsMap = PM.patchMapWithPatchingMoveNewElementsMap . unPatchMapWithMove'
158− where f ni = case _nodeInfo_from ni of
159− From_Insert v -> Just v
160− From_Move _ -> Nothing
161− From_Delete -> Nothing
163-- | Create a 'PatchMapWithMove' that, if applied to the given 'Map', will sort
193-- | Create a 'PatchMapWithMove' that, if applied to the given 'Map', will sort
164-- its values using the given ordering function. The set keys of the 'Map' is
194-- its values using the given ordering function. The set keys of the 'Map' is
165-- not changed.
195-- not changed.
166patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v
196patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v
167−patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
197+patchThatSortsMapWith cmp = PatchMapWithMove' . PM.patchThatSortsMapWith cmp
168− where unsorted = Map.toList m
169− sorted = sortBy (cmp `on` snd) unsorted
170− f (to, _) (from, _) = if to == from then Nothing else
172− reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
173− g (to, _) (from, _) = if to == from then Nothing else
174− let Just movingTo = Map.lookup to reverseMapping
175− in Just (to, NodeInfo (From_Move from) $ Just movingTo)
177-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
199-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
178-- will produce a 'Map' with the same values as the second 'Map' but with the
200-- will produce a 'Map' with the same values as the second 'Map' but with the
179-- values sorted with the given ordering function.
201-- values sorted with the given ordering function.
180−patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
202+patchThatChangesAndSortsMapWith :: (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
181patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
203patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
182 where newList = Map.toList newByIndexUnsorted
204 where newList = Map.toList newByIndexUnsorted
183 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
205 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
185-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
207-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
186-- will produce the second 'Map'.
208-- will produce the second 'Map'.
187−patchThatChangesMap :: forall k v. (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v
209+patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v
188−patchThatChangesMap oldByIndex newByIndex = patch
210+patchThatChangesMap oldByIndex newByIndex = PatchMapWithMove' $
189− where invert :: Map k v -> Map v (Set k)
211+ PM.patchThatChangesMap oldByIndex newByIndex
190− invert = Map.fromListWith (<>) . fmap (\(k, v) -> (v, Set.singleton k)) . Map.toList
212+
191− -- In the places where we use unionDistinct, a non-distinct key indicates a bug in this function
213+--
192− unionDistinct :: forall k' v'. Ord k' => Map k' v' -> Map k' v' -> Map k' v'
214+-- NodeInfo
193− unionDistinct = Map.unionWith (error "patchThatChangesMap: non-distinct keys")
215+--
194− 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))
216+
195− unionPairDistinct (oldFroms, oldTos) (newFroms, newTos) = (unionDistinct oldFroms newFroms, unionDistinct oldTos newTos)
217+-- | Holds the information about each key: where its new value should come from,
196− -- Generate patch info for a single value
218+-- and where its old value should go to
197− -- Keys that are found in both the old and new sets will not be patched
219+newtype NodeInfo k (v :: Type) = NodeInfo' { unNodeInfo' :: PM.NodeInfo k (Proxy v) }
198− -- 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
220+
199− -- 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
221+deriving instance (Show k, Show p) => Show (NodeInfo k p)
200− patchSingleValue :: v -> Set k -> Set k -> (Map k (From k v), Map k (To k))
222+deriving instance (Read k, Read p) => Read (NodeInfo k p)
201− patchSingleValue v oldKeys newKeys = foldl' unionPairDistinct mempty $ align (toList $ oldKeys `Set.difference` newKeys) (toList $ newKeys `Set.difference` oldKeys) <&> \case
223+deriving instance (Eq k, Eq p) => Eq (NodeInfo k p)
202− This oldK -> (mempty, Map.singleton oldK Nothing) -- There's nowhere for this value to go, so we know we are deleting it
224+deriving instance (Ord k, Ord p) => Ord (NodeInfo k p)
203− 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
225+
204− These oldK newK -> (Map.singleton newK $ From_Move oldK, Map.singleton oldK $ Just newK)
226+{-# COMPLETE NodeInfo #-}
205− -- Run patchSingleValue on a These. Missing old or new sets are considered empty
227+pattern NodeInfo :: To k -> From k v -> NodeInfo k v
206− patchSingleValueThese :: v -> These (Set k) (Set k) -> (Map k (From k v), Map k (To k))
228+_nodeInfo_to :: NodeInfo k v -> To k
207− patchSingleValueThese v = \case
229+_nodeInfo_from :: NodeInfo k v -> From k v
208− This oldKeys -> patchSingleValue v oldKeys mempty
230+pattern NodeInfo { _nodeInfo_to, _nodeInfo_from } = NodeInfo'
209− That newKeys -> patchSingleValue v mempty newKeys
231+ PM.NodeInfo
210− These oldKeys newKeys -> patchSingleValue v oldKeys newKeys
232+ { PM._nodeInfo_to = _nodeInfo_to
211− -- Generate froms and tos for all values, then merge them together
233+ , PM._nodeInfo_from = Coerce _nodeInfo_from
212− (froms, tos) = foldl' unionPairDistinct mempty $ Map.mapWithKey patchSingleValueThese $ align (invert oldByIndex) (invert newByIndex)
234+ }
213− patch = unsafePatchMapWithMove $ align froms tos <&> \case
235+
214− 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.
236+_NodeInfo
215− That to -> NodeInfo From_Delete to -- Since we don't have a 'from' record for this key, it must be getting deleted
237+ :: Iso
216− These from to -> NodeInfo from to
238+ (NodeInfo k0 v0)
240+ (PM.NodeInfo k0 (Proxy v0))
241+ (PM.NodeInfo k1 (Proxy v1))
242+_NodeInfo = iso unNodeInfo' NodeInfo'
244+instance Functor (NodeInfo k) where
245+ fmap f = runIdentity . traverse (Identity . f)
247+instance Foldable (NodeInfo k) where
248+ foldMap = foldMapDefault
250+instance Traversable (NodeInfo k) where
251+ traverse = bitraverseNodeInfo pure
257+ -> NodeInfo k0 v0 -> f (NodeInfo k1 v1)
258+bitraverseNodeInfo fk fv = fmap NodeInfo'
259+ . PM.bitraverseNodeInfo fk (\ ~Proxy -> pure Proxy) fv
218-- | Change the 'From' value of a 'NodeInfo'
262-- | Change the 'From' value of a 'NodeInfo'
219nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
263nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
220−nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
264+nodeInfoMapFrom f = coerce $ PM.nodeInfoMapFrom (unFrom' . f . From')
222-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
266-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
223-- 'Applicative', 'Monad', etc.) action to get the new value
267-- 'Applicative', 'Monad', etc.) action to get the new value
270+ => (From k v -> f (From k v))
224−nodeInfoMapMFrom :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
271+ -> NodeInfo k v -> f (NodeInfo k v)
225−nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
272+nodeInfoMapMFrom f = fmap NodeInfo'
273+ . PM.nodeInfoMapMFrom (fmap unFrom' . f . From')
227-- | Set the 'To' field of a 'NodeInfo'
276-- | Set the 'To' field of a 'NodeInfo'
228nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
277nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
229−nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
278+nodeInfoSetTo = coerce . PM.nodeInfoSetTo
231−-- |Helper data structure used for composing patches using the monoid instance.
280+--
232−data Fixup k v
281+-- From
233− = Fixup_Delete
282+--
234− | Fixup_Update (These (From k v) (To k))
283+
235−
284+-- | Describe how a key's new value should be produced
236−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
285+newtype From k (v :: Type) = From' { unFrom' :: PM.From k (Proxy v) }
237−instance Ord k => Semigroup (PatchMapWithMove k v) where
286+
238− PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m
287+{-# COMPLETE From_Insert, From_Delete, From_Move #-}
240− connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb
289+-- | Insert the given value here
241− h :: (k, (Maybe k, From k v)) -> [(k, Fixup k v)]
290+pattern From_Insert :: v -> From k v
242− h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of
291+pattern From_Insert v = From' (PM.From_Insert v)
243− (Just toAfter, From_Move fromBefore)
292+
244− | fromBefore == toAfter
293+-- | Delete the existing value, if any, from here
245− -> [(toAfter, Fixup_Delete)]
294+pattern From_Delete :: From k v
246− | otherwise
295+pattern From_Delete = From' PM.From_Delete
247− -> [ (toAfter, Fixup_Update (This editBefore))
296+
248− , (fromBefore, Fixup_Update (That mToAfter))
297+-- | Move the value here from the given key
249− ]
298+pattern From_Move :: k -> From k v
250− (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
299+pattern From_Move k = From' (PM.From_Move k Proxy)
251− (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]
300+
252− (Nothing, _) -> []
301+bitraverseFrom
253− mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
302+ :: Applicative f
254− mergeFixups _ (Fixup_Update a) (Fixup_Update b)
303+ => (k0 -> f k1)
255− | This x <- a, That y <- b
304+ -> (v0 -> f v1)
256− = Fixup_Update $ These x y
305+ -> From k0 v0 -> f (From k1 v1)
257− | That y <- a, This x <- b
306+bitraverseFrom fk fv = fmap From'
258− = Fixup_Update $ These x y
307+ . PM.bitraverseFrom fk (\ ~Proxy -> pure Proxy) fv
259− mergeFixups _ _ _ = error "PatchMapWithMove: incompatible fixups"
308+ . coerce
260− fixups = Map.fromListWithKey mergeFixups $ concatMap h connections
309+
261− combineNodeInfos _ nia nib = NodeInfo
310+makeWrapped ''PatchMapWithMove
262− { _nodeInfo_from = _nodeInfo_from nia
311+makeWrapped ''NodeInfo
263− , _nodeInfo_to = _nodeInfo_to nib
312+makeWrapped ''From
265− applyFixup _ ni = \case
266− Fixup_Delete -> Nothing
267− Fixup_Update u -> Just $ NodeInfo
268− { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
269− , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
271− m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups
272− getHere :: These a b -> Maybe a
277− getThere :: These a b -> Maybe b
283−--TODO: Figure out how to implement this in terms of PatchDMapWithMove rather than duplicating it here
284−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
285−instance Ord k => Monoid (PatchMapWithMove k v) where
286− mempty = PatchMapWithMove mempty