@@ -1,318 +1,312 @@
1{-# LANGUAGE CPP #-}
1{-# LANGUAGE CPP #-}
2+{-# LANGUAGE DeriveTraversable #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
3{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE PatternGuards #-}
8{-# LANGUAGE PatternGuards #-}
9+{-# LANGUAGE PatternSynonyms #-}
5{-# LANGUAGE ScopedTypeVariables #-}
10{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE StandaloneDeriving #-}
11{-# LANGUAGE StandaloneDeriving #-}
12+{-# LANGUAGE TemplateHaskell #-}
13+{-# LANGUAGE TypeApplications #-}
7{-# LANGUAGE TypeFamilies #-}
14{-# LANGUAGE TypeFamilies #-}
8−{-# LANGUAGE UndecidableInstances #-}
15+{-# LANGUAGE ViewPatterns #-}
9-- | '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
11−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)
13import 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
15−import Control.Arrow
69+import Control.Lens
16−import Control.Monad.Trans.State
19import Data.List
70import Data.List
20import Data.Map (Map)
71import Data.Map (Map)
21import qualified Data.Map as Map
72import qualified Data.Map as Map
22−import Data.Maybe
73+import Data.Proxy
23−#if !MIN_VERSION_base(4,9,0)
74+#if !MIN_VERSION_base(4,11,0)
24−import Data.Semigroup (Semigroup (..), (<>))
75+import Data.Semigroup (Semigroup (..))
26−import Data.Monoid.DecidablyEmpty
77+import Data.Traversable (foldMapDefault)
27−import qualified Data.Set as Set
28−import Data.These (These (..))
31-- | 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@
32-- 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@,
33-- 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.
34−newtype PatchMapWithMove k p = PatchMapWithMove (Map k (NodeInfo k p))
82+newtype PatchMapWithMove k (v :: Type) = PatchMapWithMove'
35−deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (PatchMapWithMove k p)
83+ { -- | Extract the underlying 'PatchMapWithPatchingMove k (Proxy v)'
36−deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (PatchMapWithMove k p)
84+ unPatchMapWithMove' :: PatchMapWithPatchingMove k (Proxy v)
37−deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (PatchMapWithMove k p)
39−-- | Holds the information about each key: where its new value should come from,
40−-- and where its old value should go to
41−data NodeInfo k p = NodeInfo
42− { _nodeInfo_from :: !(From k p)
43− -- ^ Where do we get the new value for this key?
44− , _nodeInfo_to :: !(To k)
45− -- ^ If the old value is being kept (i.e. moved rather than deleted or
46− -- replaced), where is it going?
48−deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (NodeInfo k p)
86+ deriving ( Show, Read, Eq, Ord
49−deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (NodeInfo k p)
87+-- Haddock cannot handle documentation here before GHC 8.6
50−deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (NodeInfo k p)
88+ ,
51−deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (NodeInfo k p)
89+#if __GLASGOW_HASKELL__ >= 806
90+ -- | Compose patches having the same effect as applying the
91+ -- patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p .
53−-- | Describe how a key's new value should be produced
98+pattern Coerce :: Coercible a b => a -> b
54−data From k p
99+pattern Coerce x <- (coerce -> x)
55− = From_Insert (PatchTarget p) -- ^ Insert the given value here
100+ where Coerce x = coerce x
56− | From_Delete -- ^ Delete the existing value, if any, from here
101+
57− | From_Move !k !p -- ^ Move the value here from the given key, and apply the given patch
102+{-# COMPLETE PatchMapWithMove #-}
103+pattern PatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
104+-- | Extract the representation of the 'PatchMapWithMove' as a map of
106+unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)
107+pattern PatchMapWithMove { unPatchMapWithMove } = PatchMapWithMove' (PatchMapWithPatchingMove (Coerce unPatchMapWithMove))
111+ (PatchMapWithMove k0 v0)
112+ (PatchMapWithMove k1 v1)
113+ (Map k0 (NodeInfo k0 v0))
114+ (Map k1 (NodeInfo k1 v1))
115+_PatchMapWithMove = iso unPatchMapWithMove PatchMapWithMove
59−deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (From k p)
117+instance Functor (PatchMapWithMove k) where
60−deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (From k p)
118+ fmap f = runIdentity . traverse (Identity . f)
61−deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (From k p)
62−deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (From k p)
64−-- | Describe where a key's old value will go. If this is 'Just', that means
120+instance Foldable (PatchMapWithMove k) where
65−-- the key's old value will be moved to the given other key; if it is 'Nothing',
121+ foldMap = foldMapDefault
66−-- that means it will be deleted.
122+
67−type To = Maybe
123+instance Traversable (PatchMapWithMove k) where
129+instance FunctorWithIndex k (PatchMapWithMove k)
130+instance FoldableWithIndex k (PatchMapWithMove k)
131+instance TraversableWithIndex k (PatchMapWithMove k) where
132+ itraverse = itraversed . Indexed
134+ _PatchMapWithMove .>
69-- | Create a 'PatchMapWithMove', validating it
138-- | Create a 'PatchMapWithMove', validating it
71− :: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithMove k p)
139+patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
72−patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
140+patchMapWithMove = fmap PatchMapWithMove' . PM.patchMapWithPatchingMove . coerce
73− where valid = forwardLinks == backwardLinks
74− forwardLinks = Map.mapMaybe _nodeInfo_to m
75− backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, p) ->
76− case _nodeInfo_from p of
77− From_Move from _ -> Just (from, to)
80-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'
142-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'
81−patchMapWithMoveInsertAll
143+patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v
82− :: Map k (PatchTarget p) -> PatchMapWithMove k p
83−patchMapWithMoveInsertAll m = PatchMapWithMove $ flip fmap m $ \v -> NodeInfo
144+patchMapWithMoveInsertAll = PatchMapWithMove' . PM.patchMapWithPatchingMoveInsertAll
84− { _nodeInfo_from = From_Insert v
85− , _nodeInfo_to = Nothing
88−-- | Extract the internal representation of the 'PatchMapWithMove'
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'.
89−unPatchMapWithMove
147+insertMapKey :: k -> v -> PatchMapWithMove k v
90− :: PatchMapWithMove k p -> Map k (NodeInfo k p)
148+insertMapKey k v = PatchMapWithMove' $ PM.insertMapKey k v
91−unPatchMapWithMove (PatchMapWithMove p) = p
93−-- | Make a @'PatchMapWithMove' k p@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'.
95− :: k -> PatchTarget p -> PatchMapWithMove k p
96−insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing
98−-- |Make a @'PatchMapWithMove' k p@ 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:
101-- '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))
104− :: (DecidablyEmpty p, Patch p) => Ord k => k -> k -> PatchMapWithMove k p
155+moveMapKey :: Ord k => k -> k -> PatchMapWithMove k v
105−moveMapKey src dst
156+moveMapKey src dst = PatchMapWithMove' $ PM.moveMapKey src dst
106− | src == dst = mempty
157+
108− PatchMapWithMove $ Map.fromList
109− [ (dst, NodeInfo (From_Move src mempty) Nothing)
110− , (src, NodeInfo From_Delete (Just dst))
113−-- |Make a @'PatchMapWithMove' k p@ 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:
116-- let aMay = Map.lookup a map
161-- let aMay = Map.lookup a map
117-- bMay = Map.lookup b map
162-- bMay = Map.lookup b map
118−-- in maybe id (Map.insert a) (bMay `mplus` aMay)
163+-- in maybe id (Map.insert a) (bMay <> aMay)
119−-- . maybe id (Map.insert b) (aMay `mplus` bMay)
164+-- . maybe id (Map.insert b) (aMay <> bMay)
120-- . Map.delete a . Map.delete b $ map
165-- . Map.delete a . Map.delete b $ map
123− :: (DecidablyEmpty p, Patch p) => Ord k => k -> k -> PatchMapWithMove k p
167+swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v
124−swapMapKey src dst
168+swapMapKey src dst = PatchMapWithMove' $ PM.swapMapKey src dst
125− | src == dst = mempty
127− PatchMapWithMove $ Map.fromList
128− [ (dst, NodeInfo (From_Move src mempty) (Just src))
129− , (src, NodeInfo (From_Move dst mempty) (Just dst))
132-- |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'.
134− :: k -> PatchMapWithMove k v
171+deleteMapKey :: k -> PatchMapWithMove k v
135−deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete Nothing
172+deleteMapKey = PatchMapWithMove' . PM.deleteMapKey
137-- | 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.
139-- __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.
140−unsafePatchMapWithMove
141− :: Map k (NodeInfo k p) -> PatchMapWithMove k p
177+unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
142−unsafePatchMapWithMove = PatchMapWithMove
178+unsafePatchMapWithMove = coerce PM.unsafePatchMapWithPatchingMove
144-- | Apply the insertions, deletions, and moves to a given 'Map'
180-- | Apply the insertions, deletions, and moves to a given 'Map'
145−instance (Ord k, Patch p) => Patch (PatchMapWithMove k p) where
181+instance Ord k => Patch (PatchMapWithMove k v) where
146− type PatchTarget (PatchMapWithMove k p) = Map k (PatchTarget p)
182+ type PatchTarget (PatchMapWithMove k v) = Map k v
147− apply (PatchMapWithMove m) 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
148− where insertions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
184+
149− From_Insert v -> Just v
150− From_Move k p -> applyAlways p <$> Map.lookup k old
151− From_Delete -> Nothing
152− deletions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
153− From_Delete -> Just ()
156−-- | 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'.
157−patchMapWithMoveNewElements
186+patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
158− :: PatchMapWithMove k p -> [PatchTarget p]
187+patchMapWithMoveNewElements = PM.patchMapWithPatchingMoveNewElements . unPatchMapWithMove'
159−patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap
161-- | 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@.
162−patchMapWithMoveNewElementsMap
190+patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v
163− :: PatchMapWithMove k p -> Map k (PatchTarget p)
164−patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p
191+patchMapWithMoveNewElementsMap = PM.patchMapWithPatchingMoveNewElementsMap . unPatchMapWithMove'
165− where f ni = case _nodeInfo_from ni of
166− From_Insert v -> Just v
167− From_Move _ _ -> Nothing
168− From_Delete -> Nothing
170-- | 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
171-- 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
172-- not changed.
195-- not changed.
173−patchThatSortsMapWith
196+patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v
174− :: (Ord k, Monoid p)
175− => (PatchTarget p -> PatchTarget p -> Ordering)
176− -> Map k (PatchTarget p) -> PatchMapWithMove k p
177−patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
197+patchThatSortsMapWith cmp = PatchMapWithMove' . PM.patchThatSortsMapWith cmp
178− where unsorted = Map.toList m
179− sorted = sortBy (cmp `on` snd) unsorted
180− f (to, _) (from, _) = if to == from then Nothing else
182− reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
183− g (to, _) (from, _) = if to == from then Nothing else
184− let Just movingTo = Map.lookup from reverseMapping
185− in Just (to, NodeInfo (From_Move from mempty) $ Just movingTo)
187-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
199-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
188-- 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
189-- values sorted with the given ordering function.
201-- values sorted with the given ordering function.
190−patchThatChangesAndSortsMapWith
202+patchThatChangesAndSortsMapWith :: (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
191− :: forall k p. (Ord k, Ord (PatchTarget p), Monoid p)
192− => (PatchTarget p -> PatchTarget p -> Ordering)
193− -> Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithMove k p
194patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
203patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
195 where newList = Map.toList newByIndexUnsorted
204 where newList = Map.toList newByIndexUnsorted
196 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
205 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
198-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
207-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
199-- will produce the second 'Map'.
208-- will produce the second 'Map'.
200−patchThatChangesMap
209+patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v
201− :: (Ord k, Ord (PatchTarget p), Monoid p)
202− => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithMove k p
203−patchThatChangesMap oldByIndex newByIndex = patch
210+patchThatChangesMap oldByIndex newByIndex = PatchMapWithMove' $
204− where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
211+ PM.patchThatChangesMap oldByIndex newByIndex
205− (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
212+
206− let f k v = do
213+--
207− remainingValues <- get
214+-- NodeInfo
208− let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
215+--
209− then Map.delete v remainingValues
216+
210− else Map.insert v remainingKeys remainingValues
217+-- | Holds the information about each key: where its new value should come from,
211− case Map.lookup v remainingValues of
218+-- and where its old value should go to
212− Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
219+newtype NodeInfo k (v :: Type) = NodeInfo' { unNodeInfo' :: PM.NodeInfo k (Proxy v) }
214− if k `Set.member` fromKs
221+deriving instance (Show k, Show p) => Show (NodeInfo k p)
215− then do
222+deriving instance (Read k, Read p) => Read (NodeInfo k p)
216− putRemainingKeys $ Set.delete k fromKs
223+deriving instance (Eq k, Eq p) => Eq (NodeInfo k p)
217− return $ NodeInfo (From_Move k mempty) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
224+deriving instance (Ord k, Ord p) => Ord (NodeInfo k p)
219− (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
226+{-# COMPLETE NodeInfo #-}
220− putRemainingKeys remainingKeys
227+pattern NodeInfo :: To k -> From k v -> NodeInfo k v
221− return $ NodeInfo (From_Move fromK mempty) $ Just undefined
228+_nodeInfo_to :: NodeInfo k v -> To k
222− Map.traverseWithKey f newByIndex
229+_nodeInfo_from :: NodeInfo k v -> From k v
223− unusedOldKeys = fold unusedValuesByValue
230+pattern NodeInfo { _nodeInfo_to, _nodeInfo_from } = NodeInfo'
224− pointlessMove k = \case
231+ PM.NodeInfo
225− From_Move k' _ | k == k' -> True
232+ { PM._nodeInfo_to = _nodeInfo_to
226− _ -> False
233+ , PM._nodeInfo_from = Coerce _nodeInfo_from
227− keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
234+ }
228− then Just undefined
235+
229− else Nothing
236+_NodeInfo
230− patch = unsafePatchMapWithMove $ 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
237+ :: Iso
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
232-- | Change the 'From' value of a 'NodeInfo'
262-- | Change the 'From' value of a 'NodeInfo'
234− :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
263+nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
235−nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
264+nodeInfoMapFrom f = coerce $ PM.nodeInfoMapFrom (unFrom' . f . From')
237-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
266-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
238-- 'Applicative', 'Monad', etc.) action to get the new value
267-- 'Applicative', 'Monad', etc.) action to get the new value
239nodeInfoMapMFrom
268nodeInfoMapMFrom
270+ => (From k v -> f (From k v))
240− :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
271+ -> NodeInfo k v -> f (NodeInfo k v)
241−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')
243-- | Set the 'To' field of a 'NodeInfo'
276-- | Set the 'To' field of a 'NodeInfo'
245− :: To k -> NodeInfo k v -> NodeInfo k v
277+nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
246−nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
278+nodeInfoSetTo = coerce . PM.nodeInfoSetTo
248−-- |Helper data structure used for composing patches using the monoid instance.
280+--
249−data Fixup k v
281+-- From
250− = Fixup_Delete
282+--
251− | Fixup_Update (These (From k v) (To k))
283+
252−
284+-- | Describe how a key's new value should be produced
253−-- |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) }
255− , Monoid p
287+{-# COMPLETE From_Insert, From_Delete, From_Move #-}
256− , DecidablyEmpty p
288+
257− , Patch p
289+-- | Insert the given value here
258− ) => Semigroup (PatchMapWithMove k p) where
290+pattern From_Insert :: v -> From k v
259− PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m
291+pattern From_Insert v = From' (PM.From_Insert v)
261− connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb
293+-- | Delete the existing value, if any, from here
262− h :: (k, (Maybe k, From k p)) -> [(k, Fixup k p)]
294+pattern From_Delete :: From k v
263− h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of
295+pattern From_Delete = From' PM.From_Delete
264− (Just toAfter, From_Move fromBefore p)
296+
265− | fromBefore == toAfter && isNull p
297+-- | Move the value here from the given key
266− -> [(toAfter, Fixup_Delete)]
298+pattern From_Move :: k -> From k v
267− | otherwise
299+pattern From_Move k = From' (PM.From_Move k Proxy)
268− -> [ (toAfter, Fixup_Update (This editBefore))
300+
269− , (fromBefore, Fixup_Update (That mToAfter))
301+bitraverseFrom
270− ]
302+ :: Applicative f
271− (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
303+ => (k0 -> f k1)
272− (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]
304+ -> (v0 -> f v1)
273− (Nothing, _) -> []
305+ -> From k0 v0 -> f (From k1 v1)
274− mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
306+bitraverseFrom fk fv = fmap From'
275− mergeFixups _ (Fixup_Update a) (Fixup_Update b)
307+ . PM.bitraverseFrom fk (\ ~Proxy -> pure Proxy) fv
276− | This x <- a, That y <- b
308+ . coerce
277− = Fixup_Update $ These x y
309+
278− | That y <- a, This x <- b
279− = Fixup_Update $ These x y
280− mergeFixups _ _ _ = error "PatchMapWithMove: incompatible fixups"
281− fixups = Map.fromListWithKey mergeFixups $ concatMap h connections
282− combineNodeInfos _ nia nib = NodeInfo
283− { _nodeInfo_from = _nodeInfo_from nia
284− , _nodeInfo_to = _nodeInfo_to nib
286− applyFixup _ ni = \case
287− Fixup_Delete -> Nothing
288− Fixup_Update u -> Just $ NodeInfo
289− { _nodeInfo_from = case _nodeInfo_from ni of
290− f@(From_Move _ p') -> case getHere u of -- The `from` fixup comes from the "old" patch
291− Nothing -> f -- If there's no `from` fixup, just use the "new" `from`
292− Just (From_Insert v) -> From_Insert $ applyAlways p' v
293− Just From_Delete -> From_Delete
294− Just (From_Move oldKey p) -> From_Move oldKey $ p' <> p
295− _ -> error "PatchMapWithMove: fixup for non-move From"
296− , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
298− m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups
299− getHere :: These a b -> Maybe a
304− getThere :: These a b -> Maybe b
310−--TODO: Figure out how to implement this in terms of PatchDMapWithMove rather than duplicating it here
311−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
316− ) => Monoid (PatchMapWithMove k p) where
317− mempty = PatchMapWithMove mempty
310+makeWrapped ''PatchMapWithMove
318− mappend = (<>)
311+makeWrapped ''NodeInfo