@@ -2,9 +2,11 @@
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 TemplateHaskell #-}
1012{-# LANGUAGE TypeApplications #-}
@@ -12,88 +14,105 @@
1214
1315-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
1416-- another
15−module Data.Patch.MapWithMove where
17+module Data.Patch.MapWithMove
18+ ( module Data.Patch.MapWithMove
19+ , PatchMapWithMove (PatchMapWithMove)
20+ , NodeInfo
21+ , pattern PM.NodeInfo
22+ , PM._nodeInfo_to
23+ , PM._nodeInfo_from
24+ ) where
1625
1726import Data.Patch.Class
27+import Data.Patch.MapWithPatchingMove
28+ ( PatchMapWithPatchingMove (..)
29+ )
30+import qualified Data.Patch.MapWithPatchingMove as PM
1831
19−import Control.Arrow
2032import Control.Lens hiding (from, to)
21−import Control.Monad.Trans.State
22−import Data.Foldable
23−import Data.Function
2433import Data.List
2534import Data.Map (Map)
2635import qualified Data.Map as Map
27−import Data.Maybe
36+import Data.Proxy
2837#if !MIN_VERSION_base(4,10,0)
29−import Data.Semigroup (Semigroup (..), (<>))
38+import Data.Semigroup (Semigroup (..))
3039#endif
31−import qualified Data.Set as Set
32−import Data.These (These(..))
33−import Data.Tuple
40+import Data.Traversable (foldMapDefault)
3441
3542-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
3643-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
3744-- and vice versa. There should never be any unpaired From/To keys.
38−newtype PatchMapWithMove k v = PatchMapWithMove
39− { -- | Extract the internal representation of the 'PatchMapWithMove'
40− unPatchMapWithMove :: Map k (NodeInfo k v)
45+newtype PatchMapWithMove k v = PatchMapWithMove'
46+ { -- | Extract the underlying 'PatchMapWithPatchingMove k (Proxy v)'
47+ unPatchMapWithMove' :: PatchMapWithPatchingMove k (Proxy v)
4148 }
4249 deriving ( Show, Read, Eq, Ord
43− , Functor, Foldable, Traversable
50+ , Semigroup, Monoid
4451 )
4552
46−-- | Holds the information about each key: where its new value should come from,
47−-- and where its old value should go to
48−data NodeInfo k v = NodeInfo
49− { _nodeInfo_from :: !(From k v)
50− -- ^ Where do we get the new value for this key?
51− , _nodeInfo_to :: !(To k)
52− -- ^ If the old value is being kept (i.e. moved rather than deleted or
53− -- replaced), where is it going?
54− }
55− deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
53+{-# COMPLETE PatchMapWithMove #-}
54+pattern PatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
55+pattern PatchMapWithMove m = PatchMapWithMove' (PatchMapWithPatchingMove m)
5656
57−-- | Describe how a key's new value should be produced
58−data From k v
59− = From_Insert v -- ^ Insert the given value here
60− | From_Delete -- ^ Delete the existing value, if any, from here
61− | From_Move !k -- ^ Move the value here from the given key
62− deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
57+-- | Extract the internal representation of the 'PatchMapWithMove'
58+unPatchMapWithMove :: PatchMapWithMove k v -> Map k (PM.NodeInfo k (Proxy v))
59+unPatchMapWithMove = unPatchMapWithPatchingMove . unPatchMapWithMove'
6360
64−-- | Describe where a key's old value will go. If this is 'Just', that means
65−-- the key's old value will be moved to the given other key; if it is 'Nothing',
66−-- that means it will be deleted.
67−type To = Maybe
61+instance Functor (PatchMapWithMove k) where
62+ fmap f = runIdentity . traverse (Identity . f)
6863
69−makeWrapped ''PatchMapWithMove
64+instance Foldable (PatchMapWithMove k) where
65+ foldMap = foldMapDefault
66+
67+instance Traversable (PatchMapWithMove k) where
68+ traverse =
69+ _Wrapping PatchMapWithMove' .
70+ _Wrapping PatchMapWithPatchingMove .
71+ traverse .
72+ traverseNodeInfo
7073
7174instance FunctorWithIndex k (PatchMapWithMove k)
7275instance FoldableWithIndex k (PatchMapWithMove k)
7376instance TraversableWithIndex k (PatchMapWithMove k) where
7477 itraverse = itraversed . Indexed
75− itraversed = _Wrapped .> itraversed <. traversed
78+ itraversed =
79+ _Wrapping PatchMapWithMove' .>
80+ _Wrapping PatchMapWithPatchingMove .>
81+ itraversed <.
82+ traverseNodeInfo
83+
84+type NodeInfo k v = PM.NodeInfo k (Proxy v)
85+
86+type From k v = PM.From k (Proxy v)
87+
88+{-# COMPLETE From_Insert, From_Delete, From_Move #-}
89+
90+pattern From_Insert :: v -> From k v
91+pattern From_Insert v = PM.From_Insert v
92+
93+pattern From_Delete :: From k v
94+pattern From_Delete = PM.From_Delete
95+
96+pattern From_Move :: k -> From k v
97+pattern From_Move k = PM.From_Move k Proxy
98+
99+type To k = PM.To k
100+
101+traverseNodeInfo
102+ :: Traversal (NodeInfo k a) (NodeInfo k b) a b
103+traverseNodeInfo = PM.bitraverseNodeInfo pure (\(~Proxy) -> pure Proxy)
76104
77105-- | Create a 'PatchMapWithMove', validating it
78106patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
79−patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
80− where valid = forwardLinks == backwardLinks
81− forwardLinks = Map.mapMaybe _nodeInfo_to m
82− backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, v) ->
83− case _nodeInfo_from v of
84− From_Move from -> Just (from, to)
85− _ -> Nothing
107+patchMapWithMove = fmap PatchMapWithMove' . PM.patchMapWithPatchingMove
86108
87109-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'
88110patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v
89−patchMapWithMoveInsertAll m = PatchMapWithMove $ flip fmap m $ \v -> NodeInfo
90− { _nodeInfo_from = From_Insert v
91− , _nodeInfo_to = Nothing
92− }
111+patchMapWithMoveInsertAll = PatchMapWithMove' . PM.patchMapWithPatchingMoveInsertAll
93112
94113-- | Make a @'PatchMapWithMove' k v@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'.
95114insertMapKey :: k -> v -> PatchMapWithMove k v
96−insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing
115+insertMapKey k v = PatchMapWithMove' $ PM.insertMapKey k v
97116
98117-- |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:
99118--
@@ -101,13 +120,7 @@ insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v)
101120-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
102121-- @
103122moveMapKey :: Ord k => k -> k -> PatchMapWithMove k v
104−moveMapKey src dst
105− | src == dst = mempty
106− | otherwise =
107− PatchMapWithMove $ Map.fromList
108− [ (dst, NodeInfo (From_Move src) Nothing)
109− , (src, NodeInfo From_Delete (Just dst))
110− ]
123+moveMapKey src dst = PatchMapWithMove' $ PM.moveMapKey src dst
111124
112125-- |Make a @'PatchMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
113126--
@@ -119,61 +132,36 @@ moveMapKey src dst
119132-- . Map.delete a . Map.delete b $ map
120133-- @
121134swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v
122−swapMapKey src dst
123− | src == dst = mempty
124− | otherwise =
125− PatchMapWithMove $ Map.fromList
126− [ (dst, NodeInfo (From_Move src) (Just src))
127− , (src, NodeInfo (From_Move dst) (Just dst))
128− ]
135+swapMapKey src dst = PatchMapWithMove' $ PM.swapMapKey src dst
129136
130137-- |Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'.
131138deleteMapKey :: k -> PatchMapWithMove k v
132−deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete Nothing
139+deleteMapKey = PatchMapWithMove' . PM.deleteMapKey
133140
134141-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants.
135142--
136143-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked.
137144unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
138−unsafePatchMapWithMove = PatchMapWithMove
145+unsafePatchMapWithMove = PatchMapWithMove' . PM.unsafePatchMapWithPatchingMove
139146
140147-- | Apply the insertions, deletions, and moves to a given 'Map'
141148instance Ord k => Patch (PatchMapWithMove k v) where
142149 type PatchTarget (PatchMapWithMove k v) = Map k v
143− 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?
144− where insertions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of
145− From_Insert v -> Just v
146− From_Move k -> Map.lookup k old
147− From_Delete -> Nothing
148− deletions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of
149− From_Delete -> Just ()
150− _ -> Nothing
150+ apply (PatchMapWithMove' p) old = apply p old
151151
152152-- | Returns all the new elements that will be added to the 'Map'.
153153patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
154−patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap
154+patchMapWithMoveNewElements = PM.patchMapWithPatchingMoveNewElements . unPatchMapWithMove'
155155
156156-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@.
157157patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v
158−patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p
159− where f ni = case _nodeInfo_from ni of
160− From_Insert v -> Just v
161− From_Move _ -> Nothing
162− From_Delete -> Nothing
158+patchMapWithMoveNewElementsMap = PM.patchMapWithPatchingMoveNewElementsMap . unPatchMapWithMove'
163159
164160-- | Create a 'PatchMapWithMove' that, if applied to the given 'Map', will sort
165161-- its values using the given ordering function. The set keys of the 'Map' is
166162-- not changed.
167163patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v
168−patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
169− where unsorted = Map.toList m
170− sorted = sortBy (cmp `on` snd) unsorted
171− f (to, _) (from, _) = if to == from then Nothing else
172− Just (from, to)
173− reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
174− g (to, _) (from, _) = if to == from then Nothing else
175− let Just movingTo = Map.lookup to reverseMapping
176− in Just (to, NodeInfo (From_Move from) $ Just movingTo)
164+patchThatSortsMapWith cmp = PatchMapWithMove' . PM.patchThatSortsMapWith cmp
177165
178166-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
179167-- will produce a 'Map' with the same values as the second 'Map' but with the
@@ -186,102 +174,23 @@ patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatCha
186174-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
187175-- will produce the second 'Map'.
188176patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v
189−patchThatChangesMap oldByIndex newByIndex = patch
190− where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
191− (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
192− let f k v = do
193− remainingValues <- get
194− let putRemainingKeys remainingKeys = put $ if Set.null remainingKeys
195− then Map.delete v remainingValues
196− else Map.insert v remainingKeys remainingValues
197− case Map.lookup v remainingValues of
198− Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
199− Just fromKs ->
200− if k `Set.member` fromKs
201− then do
202− putRemainingKeys $ Set.delete k fromKs
203− return $ NodeInfo (From_Move k) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
204− else do
205− (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
206− putRemainingKeys remainingKeys
207− return $ NodeInfo (From_Move fromK) $ Just undefined
208− Map.traverseWithKey f newByIndex
209− unusedOldKeys = fold unusedValuesByValue
210− pointlessMove k = \case
211− From_Move k' | k == k' -> True
212− _ -> False
213− keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
214− then Just undefined
215− else Nothing
216− 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
177+patchThatChangesMap oldByIndex newByIndex = PatchMapWithMove' $
178+ PM.patchThatChangesMap oldByIndex newByIndex
217179
218180-- | Change the 'From' value of a 'NodeInfo'
219181nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
220−nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
182+nodeInfoMapFrom = PM.nodeInfoMapFrom
221183
222184-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
223185-- 'Applicative', 'Monad', etc.) action to get the new value
224−nodeInfoMapMFrom :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
225−nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
186+nodeInfoMapMFrom
187+ :: Functor f
188+ => (From k v -> f (From k v))
189+ -> NodeInfo k v -> f (NodeInfo k v)
190+nodeInfoMapMFrom = PM.nodeInfoMapMFrom
226191
227192-- | Set the 'To' field of a 'NodeInfo'
228193nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
229−nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
230−
231−-- |Helper data structure used for composing patches using the monoid instance.
232−data Fixup k v
233− = Fixup_Delete
234− | Fixup_Update (These (From k v) (To k))
235−
236−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
237−instance Ord k => Semigroup (PatchMapWithMove k v) where
238− PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m
239− where
240− connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb
241− h :: (k, (Maybe k, From k v)) -> [(k, Fixup k v)]
242− h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of
243− (Just toAfter, From_Move fromBefore)
244− | fromBefore == toAfter
245− -> [(toAfter, Fixup_Delete)]
246− | otherwise
247− -> [ (toAfter, Fixup_Update (This editBefore))
248− , (fromBefore, Fixup_Update (That mToAfter))
249− ]
250− (Nothing, From_Move fromBefore) -> [(fromBefore, Fixup_Update (That mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map
251− (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]
252− (Nothing, _) -> []
253− mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
254− mergeFixups _ (Fixup_Update a) (Fixup_Update b)
255− | This x <- a, That y <- b
256− = Fixup_Update $ These x y
257− | That y <- a, This x <- b
258− = Fixup_Update $ These x y
259− mergeFixups _ _ _ = error "PatchMapWithMove: incompatible fixups"
260− fixups = Map.fromListWithKey mergeFixups $ concatMap h connections
261− combineNodeInfos _ nia nib = NodeInfo
262− { _nodeInfo_from = _nodeInfo_from nia
263− , _nodeInfo_to = _nodeInfo_to nib
264− }
265− applyFixup _ ni = \case
266− Fixup_Delete -> Nothing
267− Fixup_Update u -> Just $ NodeInfo
268− { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
269− , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
270− }
271− m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups
272− getHere :: These a b -> Maybe a
273− getHere = \case
274− This a -> Just a
275− These a _ -> Just a
276− That _ -> Nothing
277− getThere :: These a b -> Maybe b
278− getThere = \case
279− This _ -> Nothing
280− These _ b -> Just b
281− That b -> Just b
282−
283−--TODO: Figure out how to implement this in terms of PatchDMapWithMove rather than duplicating it here
284−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
285−instance Ord k => Monoid (PatchMapWithMove k v) where
286− mempty = PatchMapWithMove mempty
287− mappend = (<>)
194+nodeInfoSetTo = PM.nodeInfoSetTo
195+
196+makeWrapped ''PatchMapWithMove