@@ -1,82 +1,151 @@
1−{-# LANGUAGE DeriveFoldable #-}
2−{-# LANGUAGE DeriveFunctor #-}
1+{-# LANGUAGE CPP #-}
32{-# LANGUAGE DeriveTraversable #-}
43{-# LANGUAGE FlexibleContexts #-}
4+{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
56{-# LANGUAGE LambdaCase #-}
7+{-# LANGUAGE MultiParamTypeClasses #-}
68{-# LANGUAGE PatternGuards #-}
9+{-# LANGUAGE PatternSynonyms #-}
710{-# LANGUAGE ScopedTypeVariables #-}
11+{-# LANGUAGE StandaloneDeriving #-}
12+{-# LANGUAGE TemplateHaskell #-}
13+{-# LANGUAGE TypeApplications #-}
814{-# LANGUAGE TypeFamilies #-}
15+{-# LANGUAGE ViewPatterns #-}
16+
917-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
1018-- another
11−module Data.Patch.MapWithMove where
19+module Data.Patch.MapWithMove
20+ ( PatchMapWithMove
21+ ( PatchMapWithMove
22+ , unPatchMapWithMove
23+ , ..
24+ )
25+ , patchMapWithMove
26+ , patchMapWithMoveInsertAll
27+ , insertMapKey
28+ , moveMapKey
29+ , swapMapKey
30+ , deleteMapKey
31+ , unsafePatchMapWithMove
32+ , patchMapWithMoveNewElements
33+ , patchMapWithMoveNewElementsMap
34+ , patchThatSortsMapWith
35+ , patchThatChangesAndSortsMapWith
36+ , patchThatChangesMap
37+
38+ -- * Node Info
39+ , NodeInfo
40+ ( NodeInfo
41+ , _nodeInfo_to
42+ , _nodeInfo_from
43+ , ..
44+ )
45+ , bitraverseNodeInfo
46+ , nodeInfoMapFrom
47+ , nodeInfoMapMFrom
48+ , nodeInfoSetTo
49+
50+ -- * From
51+ , From
52+ ( From_Insert
53+ , From_Delete
54+ , From_Move
55+ , ..
56+ )
57+ , bitraverseFrom
1258
59+ -- * To
60+ , To
61+ ) where
62+
63+import Data.Coerce
64+import Data.Kind (Type)
1365import Data.Patch.Class
66+import Data.Patch.MapWithPatchingMove (PatchMapWithPatchingMove(..), To)
67+import qualified Data.Patch.MapWithPatchingMove as PM -- already a transparent synonym
1468
15−import Control.Arrow
16−import Control.Monad.Trans.State
17−import Data.Foldable
18−import Data.Function
69+import Control.Lens
1970import Data.List
2071import Data.Map (Map)
2172import qualified Data.Map as Map
22−import Data.Maybe
23−import Data.Semigroup (Semigroup (..), (<>))
24−import qualified Data.Set as Set
25−import Data.These (These(..))
26−import Data.Tuple
73+import Data.Proxy
74+#if !MIN_VERSION_base(4,11,0)
75+import Data.Semigroup (Semigroup (..))
76+#endif
77+import Data.Traversable (foldMapDefault)
2778
2879-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
2980-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
3081-- and vice versa. There should never be any unpaired From/To keys.
31−newtype PatchMapWithMove k v = PatchMapWithMove (Map k (NodeInfo k v)) deriving (Show, Eq, Ord, Functor, Foldable, Traversable)
32−
33−-- | Holds the information about each key: where its new value should come from,
34−-- and where its old value should go to
35−data NodeInfo k v = NodeInfo
36− { _nodeInfo_from :: !(From k v)
37− -- ^ Where do we get the new value for this key?
38− , _nodeInfo_to :: !(To k)
39− -- ^ If the old value is being kept (i.e. moved rather than deleted or
40− -- replaced), where is it going?
82+newtype PatchMapWithMove k (v :: Type) = PatchMapWithMove'
83+ { -- | Extract the underlying 'PatchMapWithPatchingMove k (Proxy v)'
84+ unPatchMapWithMove' :: PatchMapWithPatchingMove k (Proxy v)
4185 }
42− deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
86+ deriving ( Show, Read, Eq, Ord
87+-- Haddock cannot handle documentation here before GHC 8.6
88+ ,
89+#if __GLASGOW_HASKELL__ >= 806
90+ -- | Compose patches having the same effect as applying the
91+ -- patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p .
92+ -- 'applyAlways' q@
93+#endif
94+ Semigroup
95+ , Monoid
96+ )
4397
44−-- | Describe how a key's new value should be produced
45−data From k v
46− = From_Insert v -- ^ Insert the given value here
47− | From_Delete -- ^ Delete the existing value, if any, from here
48− | From_Move !k -- ^ Move the value here from the given key
49− deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
98+pattern Coerce :: Coercible a b => a -> b
99+pattern Coerce x <- (coerce -> x)
100+ where Coerce x = coerce x
101+
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
105+-- 'NodeInfo'.
106+unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)
107+pattern PatchMapWithMove { unPatchMapWithMove } = PatchMapWithMove' (PatchMapWithPatchingMove (Coerce unPatchMapWithMove))
108+
109+_PatchMapWithMove
110+ :: Iso
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
50116
51−-- | Describe where a key's old value will go. If this is 'Just', that means
52−-- the key's old value will be moved to the given other key; if it is 'Nothing',
53−-- that means it will be deleted.
54−type To = Maybe
117+instance Functor (PatchMapWithMove k) where
118+ fmap f = runIdentity . traverse (Identity . f)
119+
120+instance Foldable (PatchMapWithMove k) where
121+ foldMap = foldMapDefault
122+
123+instance Traversable (PatchMapWithMove k) where
124+ traverse =
125+ _PatchMapWithMove .
126+ traverse .
127+ traverse
128+
129+instance FunctorWithIndex k (PatchMapWithMove k)
130+instance FoldableWithIndex k (PatchMapWithMove k)
131+instance TraversableWithIndex k (PatchMapWithMove k) where
132+ itraverse = itraversed . Indexed
133+ itraversed =
134+ _PatchMapWithMove .>
135+ itraversed <.
136+ traverse
55137
56138-- | Create a 'PatchMapWithMove', validating it
57139patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
58−patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
59− where valid = forwardLinks == backwardLinks
60− forwardLinks = Map.mapMaybe _nodeInfo_to m
61− backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, v) ->
62− case _nodeInfo_from v of
63− From_Move from -> Just (from, to)
64− _ -> Nothing
140+patchMapWithMove = fmap PatchMapWithMove' . PM.patchMapWithPatchingMove . coerce
65141
66142-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'
67143patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v
68−patchMapWithMoveInsertAll m = PatchMapWithMove $ flip fmap m $ \v -> NodeInfo
69− { _nodeInfo_from = From_Insert v
70− , _nodeInfo_to = Nothing
71− }
72−
73−-- | Extract the internal representation of the 'PatchMapWithMove'
74−unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)
75−unPatchMapWithMove (PatchMapWithMove p) = p
144+patchMapWithMoveInsertAll = PatchMapWithMove' . PM.patchMapWithPatchingMoveInsertAll
76145
77146-- | Make a @'PatchMapWithMove' k v@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'.
78147insertMapKey :: k -> v -> PatchMapWithMove k v
79−insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing
148+insertMapKey k v = PatchMapWithMove' $ PM.insertMapKey k v
80149
81150-- |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:
82151--
@@ -84,84 +153,53 @@ insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v)
84153-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
85154-- @
86155moveMapKey :: Ord k => k -> k -> PatchMapWithMove k v
87−moveMapKey src dst
88− | src == dst = mempty
89− | otherwise =
90− PatchMapWithMove $ Map.fromList
91− [ (dst, NodeInfo (From_Move src) Nothing)
92− , (src, NodeInfo From_Delete (Just dst))
93− ]
156+moveMapKey src dst = PatchMapWithMove' $ PM.moveMapKey src dst
94157
95158-- |Make a @'PatchMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
96159--
97160-- @
98161-- let aMay = Map.lookup a map
99162-- bMay = Map.lookup b map
100−-- in maybe id (Map.insert a) (bMay `mplus` aMay)
101−-- . maybe id (Map.insert b) (aMay `mplus` bMay)
163+-- in maybe id (Map.insert a) (bMay <> aMay)
164+-- . maybe id (Map.insert b) (aMay <> bMay)
102165-- . Map.delete a . Map.delete b $ map
103166-- @
104167swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v
105−swapMapKey src dst
106− | src == dst = mempty
107− | otherwise =
108− PatchMapWithMove $ Map.fromList
109− [ (dst, NodeInfo (From_Move src) (Just src))
110− , (src, NodeInfo (From_Move dst) (Just dst))
111− ]
168+swapMapKey src dst = PatchMapWithMove' $ PM.swapMapKey src dst
112169
113170-- |Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'.
114171deleteMapKey :: k -> PatchMapWithMove k v
115−deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete Nothing
172+deleteMapKey = PatchMapWithMove' . PM.deleteMapKey
116173
117174-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants.
118175--
119176-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked.
120177unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
121−unsafePatchMapWithMove = PatchMapWithMove
178+unsafePatchMapWithMove = coerce PM.unsafePatchMapWithPatchingMove
122179
123180-- | Apply the insertions, deletions, and moves to a given 'Map'
124181instance Ord k => Patch (PatchMapWithMove k v) where
125182 type PatchTarget (PatchMapWithMove k v) = Map k v
126− 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?
127− where insertions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of
128− From_Insert v -> Just v
129− From_Move k -> Map.lookup k old
130− From_Delete -> Nothing
131− deletions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of
132− From_Delete -> Just ()
133− _ -> Nothing
183+ apply (PatchMapWithMove' p) = apply p
134184
135185-- | Returns all the new elements that will be added to the 'Map'.
136186patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
137−patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap
187+patchMapWithMoveNewElements = PM.patchMapWithPatchingMoveNewElements . unPatchMapWithMove'
138188
139189-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@.
140190patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v
141−patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p
142− where f ni = case _nodeInfo_from ni of
143− From_Insert v -> Just v
144− From_Move _ -> Nothing
145− From_Delete -> Nothing
191+patchMapWithMoveNewElementsMap = PM.patchMapWithPatchingMoveNewElementsMap . unPatchMapWithMove'
146192
147193-- | Create a 'PatchMapWithMove' that, if applied to the given 'Map', will sort
148194-- its values using the given ordering function. The set keys of the 'Map' is
149195-- not changed.
150196patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v
151−patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
152− where unsorted = Map.toList m
153− sorted = sortBy (cmp `on` snd) unsorted
154− f (to, _) (from, _) = if to == from then Nothing else
155− Just (from, to)
156− reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
157− g (to, _) (from, _) = if to == from then Nothing else
158− let Just movingTo = Map.lookup to reverseMapping
159− in Just (to, NodeInfo (From_Move from) $ Just movingTo)
197+patchThatSortsMapWith cmp = PatchMapWithMove' . PM.patchThatSortsMapWith cmp
160198
161199-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
162200-- will produce a 'Map' with the same values as the second 'Map' but with the
163201-- values sorted with the given ordering function.
164−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
165203patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
166204 where newList = Map.toList newByIndexUnsorted
167205 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
@@ -169,102 +207,106 @@ patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatCha
169207-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
170208-- will produce the second 'Map'.
171209patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v
172−patchThatChangesMap oldByIndex newByIndex = patch
173− where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
174− (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
175− let f k v = do
176− remainingValues <- get
177− let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
178− then Map.delete v remainingValues
179− else Map.insert v remainingKeys remainingValues
180− case Map.lookup v remainingValues of
181− Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
182− Just fromKs ->
183− if k `Set.member` fromKs
184− then do
185− putRemainingKeys $ Set.delete k fromKs
186− return $ NodeInfo (From_Move k) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
187− else do
188− (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
189− putRemainingKeys remainingKeys
190− return $ NodeInfo (From_Move fromK) $ Just undefined
191− Map.traverseWithKey f newByIndex
192− unusedOldKeys = fold unusedValuesByValue
193− pointlessMove k = \case
194− From_Move k' | k == k' -> True
195− _ -> False
196− keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
197− then Just undefined
198− else Nothing
199− 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
210+patchThatChangesMap oldByIndex newByIndex = PatchMapWithMove' $
211+ PM.patchThatChangesMap oldByIndex newByIndex
212+
213+--
214+-- NodeInfo
215+--
216+
217+-- | Holds the information about each key: where its new value should come from,
218+-- and where its old value should go to
219+newtype NodeInfo k (v :: Type) = NodeInfo' { unNodeInfo' :: PM.NodeInfo k (Proxy v) }
220+
221+deriving instance (Show k, Show p) => Show (NodeInfo k p)
222+deriving instance (Read k, Read p) => Read (NodeInfo k p)
223+deriving instance (Eq k, Eq p) => Eq (NodeInfo k p)
224+deriving instance (Ord k, Ord p) => Ord (NodeInfo k p)
225+
226+{-# COMPLETE NodeInfo #-}
227+pattern NodeInfo :: To k -> From k v -> NodeInfo k v
228+_nodeInfo_to :: NodeInfo k v -> To k
229+_nodeInfo_from :: NodeInfo k v -> From k v
230+pattern NodeInfo { _nodeInfo_to, _nodeInfo_from } = NodeInfo'
231+ PM.NodeInfo
232+ { PM._nodeInfo_to = _nodeInfo_to
233+ , PM._nodeInfo_from = Coerce _nodeInfo_from
234+ }
235+
236+_NodeInfo
237+ :: Iso
238+ (NodeInfo k0 v0)
239+ (NodeInfo k1 v1)
240+ (PM.NodeInfo k0 (Proxy v0))
241+ (PM.NodeInfo k1 (Proxy v1))
242+_NodeInfo = iso unNodeInfo' NodeInfo'
243+
244+instance Functor (NodeInfo k) where
245+ fmap f = runIdentity . traverse (Identity . f)
246+
247+instance Foldable (NodeInfo k) where
248+ foldMap = foldMapDefault
249+
250+instance Traversable (NodeInfo k) where
251+ traverse = bitraverseNodeInfo pure
252+
253+bitraverseNodeInfo
254+ :: Applicative f
255+ => (k0 -> f k1)
256+ -> (v0 -> f v1)
257+ -> NodeInfo k0 v0 -> f (NodeInfo k1 v1)
258+bitraverseNodeInfo fk fv = fmap NodeInfo'
259+ . PM.bitraverseNodeInfo fk (\ ~Proxy -> pure Proxy) fv
260+ . coerce
200261
201262-- | Change the 'From' value of a 'NodeInfo'
202263nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
203−nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
264+nodeInfoMapFrom f = coerce $ PM.nodeInfoMapFrom (unFrom' . f . From')
204265
205266-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
206267-- 'Applicative', 'Monad', etc.) action to get the new value
207−nodeInfoMapMFrom :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
208−nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
268+nodeInfoMapMFrom
269+ :: Functor f
270+ => (From k v -> f (From k v))
271+ -> NodeInfo k v -> f (NodeInfo k v)
272+nodeInfoMapMFrom f = fmap NodeInfo'
273+ . PM.nodeInfoMapMFrom (fmap unFrom' . f . From')
274+ . coerce
209275
210276-- | Set the 'To' field of a 'NodeInfo'
211277nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
212−nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
213−
214−-- |Helper data structure used for composing patches using the monoid instance.
215−data Fixup k v
216− = Fixup_Delete
217− | Fixup_Update (These (From k v) (To k))
218−
219−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
220−instance Ord k => Semigroup (PatchMapWithMove k v) where
221− PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m
222− where
223− connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb
224− h :: (k, (Maybe k, From k v)) -> [(k, Fixup k v)]
225− h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of
226− (Just toAfter, From_Move fromBefore)
227− | fromBefore == toAfter
228− -> [(toAfter, Fixup_Delete)]
229− | otherwise
230− -> [ (toAfter, Fixup_Update (This editBefore))
231− , (fromBefore, Fixup_Update (That mToAfter))
232− ]
233− (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
234− (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]
235− (Nothing, _) -> []
236− mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
237− mergeFixups _ (Fixup_Update a) (Fixup_Update b)
238− | This x <- a, That y <- b
239− = Fixup_Update $ These x y
240− | That y <- a, This x <- b
241− = Fixup_Update $ These x y
242− mergeFixups _ _ _ = error "PatchMapWithMove: incompatible fixups"
243− fixups = Map.fromListWithKey mergeFixups $ concatMap h connections
244− combineNodeInfos _ nia nib = NodeInfo
245− { _nodeInfo_from = _nodeInfo_from nia
246− , _nodeInfo_to = _nodeInfo_to nib
247− }
248− applyFixup _ ni = \case
249− Fixup_Delete -> Nothing
250− Fixup_Update u -> Just $ NodeInfo
251− { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
252− , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
253− }
254− m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups
255− getHere :: These a b -> Maybe a
256− getHere = \case
257− This a -> Just a
258− These a _ -> Just a
259− That _ -> Nothing
260− getThere :: These a b -> Maybe b
261− getThere = \case
262− This _ -> Nothing
263− These _ b -> Just b
264− That b -> Just b
265−
266−--TODO: Figure out how to implement this in terms of PatchDMapWithMove rather than duplicating it here
267−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
268−instance Ord k => Monoid (PatchMapWithMove k v) where
269− mempty = PatchMapWithMove mempty
270− mappend = (<>)
278+nodeInfoSetTo = coerce . PM.nodeInfoSetTo
279+
280+--
281+-- From
282+--
283+
284+-- | Describe how a key's new value should be produced
285+newtype From k (v :: Type) = From' { unFrom' :: PM.From k (Proxy v) }
286+
287+{-# COMPLETE From_Insert, From_Delete, From_Move #-}
288+
289+-- | Insert the given value here
290+pattern From_Insert :: v -> From k v
291+pattern From_Insert v = From' (PM.From_Insert v)
292+
293+-- | Delete the existing value, if any, from here
294+pattern From_Delete :: From k v
295+pattern From_Delete = From' PM.From_Delete
296+
297+-- | Move the value here from the given key
298+pattern From_Move :: k -> From k v
299+pattern From_Move k = From' (PM.From_Move k Proxy)
300+
301+bitraverseFrom
302+ :: Applicative f
303+ => (k0 -> f k1)
304+ -> (v0 -> f v1)
305+ -> From k0 v0 -> f (From k1 v1)
306+bitraverseFrom fk fv = fmap From'
307+ . PM.bitraverseFrom fk (\ ~Proxy -> pure Proxy) fv
308+ . coerce
309+
310+makeWrapped ''PatchMapWithMove
311+makeWrapped ''NodeInfo
312+makeWrapped ''From