@@ -2,364 +2,314 @@
22{-# LANGUAGE DeriveTraversable #-}
33{-# LANGUAGE FlexibleContexts #-}
44{-# LANGUAGE FlexibleInstances #-}
5+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
56{-# LANGUAGE LambdaCase #-}
67{-# LANGUAGE MultiParamTypeClasses #-}
78{-# LANGUAGE PatternGuards #-}
9+{-# LANGUAGE PatternSynonyms #-}
810{-# LANGUAGE ScopedTypeVariables #-}
911{-# LANGUAGE StandaloneDeriving #-}
1012{-# LANGUAGE TemplateHaskell #-}
1113{-# LANGUAGE TypeApplications #-}
1214{-# LANGUAGE TypeFamilies #-}
13−{-# LANGUAGE UndecidableInstances #-}
15+{-# LANGUAGE ViewPatterns #-}
1416
1517-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
1618-- another
17−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
1837
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
58+
59+ -- * To
60+ , To
61+ ) where
62+
63+import Data.Coerce
64+import Data.Kind (Type)
1965import Data.Patch.Class
66+import Data.Patch.MapWithPatchingMove (PatchMapWithPatchingMove(..), To)
67+import qualified Data.Patch.MapWithPatchingMove as PM -- already a transparent synonym
2068
21−import Control.Arrow
22−import Control.Lens hiding (from, to)
23−import Control.Monad.Trans.State
24−import Data.Foldable
25−import Data.Function
69+import Control.Lens
2670import Data.List
2771import Data.Map (Map)
2872import qualified Data.Map as Map
29−import Data.Maybe
30−--import Data.Proxy
31−#if !MIN_VERSION_base(4,9,0)
32−import Data.Semigroup (Semigroup (..), (<>))
73+import Data.Proxy
74+#if !MIN_VERSION_base(4,11,0)
75+import Data.Semigroup (Semigroup (..))
3376#endif
34−import Data.Monoid.DecidablyEmpty
35−import qualified Data.Set as Set
36−import Data.These (These (..))
37−import Data.Tuple
77+import Data.Traversable (foldMapDefault)
3878
3979-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
4080-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
4181-- and vice versa. There should never be any unpaired From/To keys.
42−newtype PatchMapWithMove k p = PatchMapWithMove
43− { -- | Extract the internal representation of the 'PatchMapWithMove'
44− unPatchMapWithMove :: Map k (NodeInfo k p)
82+newtype PatchMapWithMove k (v :: Type) = PatchMapWithMove'
83+ { -- | Extract the underlying 'PatchMapWithPatchingMove k (Proxy v)'
84+ unPatchMapWithMove' :: PatchMapWithPatchingMove k (Proxy v)
4585 }
46−deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (PatchMapWithMove k p)
47−deriving instance (Ord k, Read k, Read p, Read (PatchTarget p)) => Read (PatchMapWithMove k p)
48−deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (PatchMapWithMove k p)
49−deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (PatchMapWithMove k p)
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+ )
5097
51−-- -- | Skips the patch so it's 'Functor' and friends
52−-- newtype PatchMapWithMove' k v = PatchMapWithMove' { unPatchMapWithMove' :: PatchMapWithMove k (Proxy v) }
53−--
54−-- deriving instance Functor (PatchMapWithMove' k)
55−-- deriving instance Foldable (PatchMapWithMove' k)
56−-- deriving instance Traversable (PatchMapWithMove' k)
98+pattern Coerce :: Coercible a b => a -> b
99+pattern Coerce x <- (coerce -> x)
100+ where Coerce x = coerce x
57101
58−-- | Holds the information about each key: where its new value should come from,
59−-- and where its old value should go to
60−data NodeInfo k p = NodeInfo
61− { _nodeInfo_from :: !(From k p)
62− -- ^ Where do we get the new value for this key?
63− , _nodeInfo_to :: !(To k p)
64− -- ^ If the old value is being kept (i.e. moved rather than deleted or
65− -- replaced), where is it going?
66− }
67−deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (NodeInfo k p)
68−deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (NodeInfo k p)
69−deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (NodeInfo k p)
70−deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (NodeInfo k p)
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))
71108
72−-- | Describe how a key's new value should be produced
73−data From k p
74− = From_Insert (PatchTarget p) -- ^ Insert the given value here
75− | From_Delete -- ^ Delete the existing value, if any, from here
76− | From_Move !k !p -- ^ Move the value here from the given key, and apply the given patch
77−
78−deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (From k p)
79−deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (From k p)
80−deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (From k p)
81−deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (From k p)
82−
83−-- | Describe where a key's old value will go. If this is 'Just', that means
84−-- the key's old value will be moved to the given other key; if it is 'Nothing',
85−-- that means it will be deleted.
86−data To k p
87− = To_NonMove
88− | To_Move !k !p
89− deriving ( Show, Read, Eq, Ord
90− , Functor, Foldable, Traversable
91− )
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
92116
93−makeWrapped ''PatchMapWithMove
94−--makeWrapped ''PatchMapWithMove'
117+instance Functor (PatchMapWithMove k) where
118+ fmap f = runIdentity . traverse (Identity . f)
119+
120+instance Foldable (PatchMapWithMove k) where
121+ foldMap = foldMapDefault
95122
96−-- instance FunctorWithIndex k (PatchMapWithMove k)
97−-- instance FoldableWithIndex k (PatchMapWithMove k)
98−-- instance TraversableWithIndex k (PatchMapWithMove k) where
99−-- itraverse = itraversed . Indexed
100−-- itraversed = _Wrapped .> itraversed <. traversed
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
101137
102138-- | Create a 'PatchMapWithMove', validating it
103−patchMapWithMove
104− :: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithMove k p)
105−patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
106− where valid = forwardLinks == backwardLinks
107− forwardLinks = flip Map.mapMaybe m $ \x -> case _nodeInfo_to x of
108− To_NonMove -> Nothing
109− To_Move to _ -> Just to
110− backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, p) ->
111− case _nodeInfo_from p of
112− From_Move from _ -> Just (from, to)
113− _ -> Nothing
139+patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
140+patchMapWithMove = fmap coerce . PM.patchMapWithPatchingMove . coerce
114141
115142-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'
116−patchMapWithMoveInsertAll
117− :: Map k (PatchTarget p) -> PatchMapWithMove k p
118−patchMapWithMoveInsertAll m = PatchMapWithMove $ flip fmap m $ \v -> NodeInfo
119− { _nodeInfo_from = From_Insert v
120− , _nodeInfo_to = To_NonMove
121− }
143+patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v
144+patchMapWithMoveInsertAll = PatchMapWithMove' . PM.patchMapWithPatchingMoveInsertAll
122145
123−-- | Make a @'PatchMapWithMove' k p@ which has the effect of inserting or replacing a value @v@ at the given key @k@, like 'Map.insert'.
124−insertMapKey
125− :: k -> PatchTarget p -> PatchMapWithMove k p
126−insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) To_NonMove
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'.
147+insertMapKey :: k -> v -> PatchMapWithMove k v
148+insertMapKey k v = PatchMapWithMove' $ PM.insertMapKey k v
127149
128−-- |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:
129151--
130152-- @
131153-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
132154-- @
133−moveMapKey
134− :: (DecidablyEmpty p, Patch p) => Ord k => k -> k -> PatchMapWithMove k p
135−moveMapKey src dst
136− | src == dst = mempty
137− | otherwise =
138− PatchMapWithMove $ Map.fromList
139− [ (dst, NodeInfo (From_Move src mempty) To_NonMove)
140− , (src, NodeInfo From_Delete (To_Move dst mempty))
141− ]
142−
143−-- |Make a @'PatchMapWithMove' k p@ which has the effect of swapping two keys in the mapping, equivalent to:
155+moveMapKey :: Ord k => k -> k -> PatchMapWithMove k v
156+moveMapKey src dst = PatchMapWithMove' $ PM.moveMapKey src dst
157+
158+-- |Make a @'PatchMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
144159--
145160-- @
146161-- let aMay = Map.lookup a map
147162-- bMay = Map.lookup b map
148−-- in maybe id (Map.insert a) (bMay `mplus` aMay)
149−-- . 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)
150165-- . Map.delete a . Map.delete b $ map
151166-- @
152−swapMapKey
153− :: (DecidablyEmpty p, Patch p)
154− => Ord k => k -> k -> PatchMapWithMove k p
155−swapMapKey src dst
156− | src == dst = mempty
157− | otherwise =
158− PatchMapWithMove $ Map.fromList
159− [ (dst, NodeInfo (From_Move src mempty) (To_Move dst mempty))
160− , (src, NodeInfo (From_Move dst mempty) (To_Move dst mempty))
161− ]
162−
163−-- | Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in
164−-- the mapping, equivalent to 'Map.delete'.
165−deleteMapKey
166− :: k -> PatchMapWithMove k v
167−deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete To_NonMove
167+swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v
168+swapMapKey src dst = PatchMapWithMove' $ PM.swapMapKey src dst
169+
170+-- |Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'.
171+deleteMapKey :: k -> PatchMapWithMove k v
172+deleteMapKey = PatchMapWithMove' . PM.deleteMapKey
168173
169174-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants.
170175--
171176-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked.
172−unsafePatchMapWithMove
173− :: Map k (NodeInfo k p) -> PatchMapWithMove k p
174−unsafePatchMapWithMove = PatchMapWithMove
177+unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
178+unsafePatchMapWithMove = PatchMapWithMove' . PM.unsafePatchMapWithPatchingMove . coerce
175179
176180-- | Apply the insertions, deletions, and moves to a given 'Map'
177−instance (Ord k, Patch p) => PatchHet (PatchMapWithMove k p) where
178− type PatchSource (PatchMapWithMove k p) = Map k (PatchSource p)
179− type PatchTarget (PatchMapWithMove k p) = Map k (PatchTarget p)
180−
181−instance (Ord k, Patch p) => Patch (PatchMapWithMove k p) where
182− -- TODO: return Nothing sometimes
183− -- Note: the strict application here is critical to ensuring that incremental
184− -- merges don't hold onto all their prerequisite events forever; can we make
185− -- this more robust?
186− apply (PatchMapWithMove m) old = Just $! insertions `Map.union` (old `Map.difference` deletions)
187− where insertions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
188− From_Insert v -> Just v
189− From_Move k p -> applyAlways p <$> Map.lookup k old
190− From_Delete -> Nothing
191− deletions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
192− From_Delete -> Just ()
193− _ -> Nothing
194−
195−-- | Returns all the new elements that will be added to the 'Map'
196−patchMapWithMoveNewElements
197− :: PatchMapWithMove k p -> [PatchTarget p]
198−patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap
181+instance Ord k => PatchHet (PatchMapWithMove k v) where
182+ type PatchSource (PatchMapWithMove k v) = Map k v
183+ type PatchTarget (PatchMapWithMove k v) = Map k v
184+
185+instance Ord k => Patch (PatchMapWithMove k v) where
186+ apply (PatchMapWithMove' p) = apply p
187+
188+-- | Returns all the new elements that will be added to the 'Map'.
189+patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
190+patchMapWithMoveNewElements = PM.patchMapWithPatchingMoveNewElements . unPatchMapWithMove'
199191
200192-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@.
201−patchMapWithMoveNewElementsMap
202− :: PatchMapWithMove k p -> Map k (PatchTarget p)
203−patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p
204− where f ni = case _nodeInfo_from ni of
205− From_Insert v -> Just v
206− From_Move _ _ -> Nothing
207− From_Delete -> Nothing
193+patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v
194+patchMapWithMoveNewElementsMap = PM.patchMapWithPatchingMoveNewElementsMap . unPatchMapWithMove'
208195
209196-- | Create a 'PatchMapWithMove' that, if applied to the given 'Map', will sort
210197-- its values using the given ordering function. The set keys of the 'Map' is
211198-- not changed.
212−patchThatSortsMapWith
213− :: (Ord k, Monoid p)
214− => (PatchTarget p -> PatchTarget p -> Ordering)
215− -> Map k (PatchTarget p) -> PatchMapWithMove k p
216−patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
217− where unsorted = Map.toList m
218− sorted = sortBy (cmp `on` snd) unsorted
219− f (to, _) (from, _) = if to == from then Nothing else
220− Just (from, to)
221− reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
222− g (to, _) (from, _) = if to == from then Nothing else
223− let Just movingTo = Map.lookup from reverseMapping
224− in Just (to, NodeInfo (From_Move from mempty) $ To_Move movingTo mempty)
199+patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v
200+patchThatSortsMapWith cmp = PatchMapWithMove' . PM.patchThatSortsMapWith cmp
225201
226202-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
227203-- will produce a 'Map' with the same values as the second 'Map' but with the
228204-- values sorted with the given ordering function.
229−patchThatChangesAndSortsMapWith
230− :: forall k p. (Ord k, Ord (PatchTarget p), Monoid p)
231− => (PatchTarget p -> PatchTarget p -> Ordering)
232− -> Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithMove k p
205+patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
233206patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
234207 where newList = Map.toList newByIndexUnsorted
235208 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
236209
237210-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
238211-- will produce the second 'Map'.
239−patchThatChangesMap
240− :: (Ord k, Ord (PatchTarget p), Monoid p)
241− => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithMove k p
242−patchThatChangesMap oldByIndex newByIndex = patch
243− where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
244− (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
245− let f k v = do
246− remainingValues <- get
247− let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
248− then Map.delete v remainingValues
249− else Map.insert v remainingKeys remainingValues
250− case Map.lookup v remainingValues of
251− Nothing -> return $ NodeInfo (From_Insert v) $ To_Move undefined undefined -- There's no existing value we can take
252− Just fromKs ->
253− if k `Set.member` fromKs
254− then do
255− putRemainingKeys $ Set.delete k fromKs
256− return $ NodeInfo (From_Move k mempty) $ To_Move undefined undefined -- There's an existing value, and it's here, so no patch necessary
257− else do
258− (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
259− putRemainingKeys remainingKeys
260− return $ NodeInfo (From_Move fromK mempty) $ To_Move undefined undefined
261− Map.traverseWithKey f newByIndex
262− unusedOldKeys = fold unusedValuesByValue
263− pointlessMove k = \case
264− From_Move k' _ | k == k' -> True
265− _ -> False
266− keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
267− then To_Move undefined undefined
268− else To_NonMove
269− patch = unsafePatchMapWithMove $ Map.filterWithKey
270− (\k -> not . pointlessMove k . _nodeInfo_from)
271− $ Map.mergeWithKey
272− (\k a _ -> Just $ nodeInfoSetTo (keyWasMoved k) a)
273− (Map.mapWithKey $ \k -> nodeInfoSetTo $ keyWasMoved k)
274− (Map.mapWithKey $ \k _ -> NodeInfo From_Delete $ keyWasMoved k)
275− insertsAndMoves
276− oldByIndex
212+patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v
213+patchThatChangesMap oldByIndex newByIndex = PatchMapWithMove' $
214+ PM.patchThatChangesMap oldByIndex newByIndex
215+
216+--
217+-- NodeInfo
218+--
219+
220+-- | Holds the information about each key: where its new value should come from,
221+-- and where its old value should go to
222+newtype NodeInfo k (v :: Type) = NodeInfo' { unNodeInfo' :: PM.NodeInfo k (Proxy v) }
223+
224+deriving instance (Show k, Show p) => Show (NodeInfo k p)
225+deriving instance (Read k, Read p) => Read (NodeInfo k p)
226+deriving instance (Eq k, Eq p) => Eq (NodeInfo k p)
227+deriving instance (Ord k, Ord p) => Ord (NodeInfo k p)
228+
229+{-# COMPLETE NodeInfo #-}
230+pattern NodeInfo :: To k -> From k v -> NodeInfo k v
231+_nodeInfo_to :: NodeInfo k v -> To k
232+_nodeInfo_from :: NodeInfo k v -> From k v
233+pattern NodeInfo { _nodeInfo_to, _nodeInfo_from } = NodeInfo'
234+ PM.NodeInfo
235+ { PM._nodeInfo_to = _nodeInfo_to
236+ , PM._nodeInfo_from = Coerce _nodeInfo_from
237+ }
238+
239+_NodeInfo
240+ :: Iso
241+ (NodeInfo k0 v0)
242+ (NodeInfo k1 v1)
243+ (PM.NodeInfo k0 (Proxy v0))
244+ (PM.NodeInfo k1 (Proxy v1))
245+_NodeInfo = iso unNodeInfo' NodeInfo'
246+
247+instance Functor (NodeInfo k) where
248+ fmap f = runIdentity . traverse (Identity . f)
249+
250+instance Foldable (NodeInfo k) where
251+ foldMap = foldMapDefault
252+
253+instance Traversable (NodeInfo k) where
254+ traverse = bitraverseNodeInfo pure
255+
256+bitraverseNodeInfo
257+ :: Applicative f
258+ => (k0 -> f k1)
259+ -> (v0 -> f v1)
260+ -> NodeInfo k0 v0 -> f (NodeInfo k1 v1)
261+bitraverseNodeInfo fk fv = fmap coerce
262+ . PM.bitraverseNodeInfo fk (\ ~Proxy -> pure Proxy) fv
263+ . coerce
277264
278265-- | Change the 'From' value of a 'NodeInfo'
279−nodeInfoMapFrom
280− :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
281−nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
266+nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
267+nodeInfoMapFrom f = coerce . PM.nodeInfoMapFrom (unFrom' . f . From') . coerce
282268
283269-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
284270-- 'Applicative', 'Monad', etc.) action to get the new value
285271nodeInfoMapMFrom
286− :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
287−nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
272+ :: Functor f
273+ => (From k v -> f (From k v))
274+ -> NodeInfo k v -> f (NodeInfo k v)
275+nodeInfoMapMFrom f = fmap coerce
276+ . PM.nodeInfoMapMFrom (fmap unFrom' . f . From')
277+ . coerce
288278
289279-- | Set the 'To' field of a 'NodeInfo'
290−nodeInfoSetTo
291− :: To k p -> NodeInfo k p -> NodeInfo k p
292−nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
293−
294−-- | Helper data structure used for composing patches using the monoid instance.
295−data Fixup k p
296− = Fixup_Delete
297− | Fixup_Update (These (From k p) (To k p))
298−
299−-- | Compose patches having the same effect as applying the patches in turn:
300−-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
301−instance ( Ord k
302− , DecidablyEmpty p
303− , Patch p
304− ) => Semigroup (PatchMapWithMove k p) where
305− PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m
306− where
307− connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb
308− h :: (k, (To k p, From k p)) -> [(k, Fixup k p)]
309− h (_, (editAfter, editBefore)) = case (editAfter, editBefore) of
310− (To_Move toAfter p1, From_Move fromBefore p0)
311− | fromBefore == toAfter && isNull p0
312− -> [(toAfter, Fixup_Delete)]
313− | otherwise
314− -> [ (toAfter, Fixup_Update (This $ From_Move fromBefore $ p1 <> p0))
315− , (fromBefore, Fixup_Update (That $ To_Move toAfter $ p1 <> p0))
316− ]
317− (To_NonMove, From_Move fromBefore _) ->
318− -- The item is destroyed in the second patch, so indicate that it is
319− -- destroyed in the source map
320− [(fromBefore, Fixup_Update (That editAfter))]
321− (To_Move toAfter p, From_Insert val) ->
322− [(toAfter, Fixup_Update $ This $ From_Insert $ applyAlways p val)]
323− (To_Move toAfter _, From_Delete) ->
324− [(toAfter, Fixup_Update $ This From_Delete)]
325− (To_NonMove, _) -> []
326− mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
327− mergeFixups _ (Fixup_Update a) (Fixup_Update b)
328− | This x <- a, That y <- b
329− = Fixup_Update $ These x y
330− | That y <- a, This x <- b
331− = Fixup_Update $ These x y
332− mergeFixups _ _ _ = error "PatchMapWithMove: incompatible fixups"
333− fixups = Map.fromListWithKey mergeFixups $ concatMap h connections
334− combineNodeInfos _ nia nib = NodeInfo
335− { _nodeInfo_from = _nodeInfo_from nia
336− , _nodeInfo_to = _nodeInfo_to nib
337− }
338− applyFixup _ ni = \case
339− Fixup_Delete -> Nothing
340− Fixup_Update u -> Just $ NodeInfo
341− { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
342− , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
343− }
344− m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups
345− getHere :: These a b -> Maybe a
346− getHere = \case
347− This a -> Just a
348− These a _ -> Just a
349− That _ -> Nothing
350− getThere :: These a b -> Maybe b
351− getThere = \case
352− This _ -> Nothing
353− These _ b -> Just b
354− That b -> Just b
355−
356−--TODO: Figure out how to implement this in terms of PatchDMapWithMove rather than duplicating it here
357−-- | Compose patches having the same effect as applying the patches in turn:
358−-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
359−instance ( Ord k
360− , Monoid p
361− , DecidablyEmpty p
362− , Patch p
363− ) => Monoid (PatchMapWithMove k p) where
364− mempty = PatchMapWithMove mempty
365− mappend = (<>)
280+nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
281+nodeInfoSetTo = coerce . PM.nodeInfoSetTo
282+
283+--
284+-- From
285+--
286+
287+-- | Describe how a key's new value should be produced
288+newtype From k (v :: Type) = From' { unFrom' :: PM.From k (Proxy v) }
289+
290+{-# COMPLETE From_Insert, From_Delete, From_Move #-}
291+
292+-- | Insert the given value here
293+pattern From_Insert :: v -> From k v
294+pattern From_Insert v = From' (PM.From_Insert v)
295+
296+-- | Delete the existing value, if any, from here
297+pattern From_Delete :: From k v
298+pattern From_Delete = From' PM.From_Delete
299+
300+-- | Move the value here from the given key
301+pattern From_Move :: k -> From k v
302+pattern From_Move k = From' (PM.From_Move k Proxy)
303+
304+bitraverseFrom
305+ :: Applicative f
306+ => (k0 -> f k1)
307+ -> (v0 -> f v1)
308+ -> From k0 v0 -> f (From k1 v1)
309+bitraverseFrom fk fv = fmap coerce
310+ . PM.bitraverseFrom fk (\ ~Proxy -> pure Proxy) fv
311+ . coerce
312+
313+makeWrapped ''PatchMapWithMove
314+makeWrapped ''NodeInfo
315+makeWrapped ''From