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