@@ -21,10 +21,11 @@ import Data.Map (Map)
2121import qualified Data.Map as Map
2222import Data.Maybe
2323#if !MIN_VERSION_base(4,9,0)
24−import Data.Semigroup
24+import Data.Semigroup (Semigroup (..), (<>))
2525#endif
26+import Data.Monoid.DecidablyEmpty
2627import qualified Data.Set as Set
27−import Data.These
28+import Data.These (These (..))
2829import Data.Tuple
2930
3031-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
@@ -49,8 +50,25 @@ deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (NodeInfo k p)
4950deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (NodeInfo k p)
5051deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (NodeInfo k p)
5152
53+-- | Describe how a key's new value should be produced
54+data From k p
55+ = From_Insert (PatchTarget p) -- ^ Insert the given value here
56+ | From_Delete -- ^ Delete the existing value, if any, from here
57+ | From_Move !k !p -- ^ Move the value here from the given key, and apply the given patch
58+
59+deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (From k p)
60+deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (From k p)
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)
63+
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
68+
5269-- | Create a 'PatchMapWithMove', validating it
53−patchMapWithMove :: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithMove k p)
70+patchMapWithMove
71+ :: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithMove k p)
5472patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
5573 where valid = forwardLinks == backwardLinks
5674 forwardLinks = Map.mapMaybe _nodeInfo_to m
@@ -60,36 +78,68 @@ patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
6078 _ -> Nothing
6179
6280-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'
63−patchMapWithMoveInsertAll :: Map k (PatchTarget p) -> PatchMapWithMove k p
81+patchMapWithMoveInsertAll
82+ :: Map k (PatchTarget p) -> PatchMapWithMove k p
6483patchMapWithMoveInsertAll m = PatchMapWithMove $ flip fmap m $ \v -> NodeInfo
6584 { _nodeInfo_from = From_Insert v
6685 , _nodeInfo_to = Nothing
6786 }
6887
6988-- | Extract the internal representation of the 'PatchMapWithMove'
70−unPatchMapWithMove :: PatchMapWithMove k p -> Map k (NodeInfo k p)
89+unPatchMapWithMove
90+ :: PatchMapWithMove k p -> Map k (NodeInfo k p)
7191unPatchMapWithMove (PatchMapWithMove p) = p
7292
73−-- | Warning: when using this function, you must ensure that the invariants of
74−-- 'PatchMapWithMove' are preserved; they will not be checked.
75−unsafePatchMapWithMove :: Map k (NodeInfo k p) -> PatchMapWithMove k p
76−unsafePatchMapWithMove = PatchMapWithMove
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'.
94+insertMapKey
95+ :: k -> PatchTarget p -> PatchMapWithMove k p
96+insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing
7797
78−-- | Describe how a key's new value should be produced
79−data From k p
80− = From_Insert (PatchTarget p) -- ^ Insert the given value here
81− | From_Delete -- ^ Delete the existing value, if any, from here
82− | From_Move !k !p -- ^ Move the value here from the given key, and apply the given patch
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:
99+--
100+-- @
101+-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
102+-- @
103+moveMapKey
104+ :: (DecidablyEmpty p, Patch p) => Ord k => k -> k -> PatchMapWithMove k p
105+moveMapKey src dst
106+ | src == dst = mempty
107+ | otherwise =
108+ PatchMapWithMove $ Map.fromList
109+ [ (dst, NodeInfo (From_Move src mempty) Nothing)
110+ , (src, NodeInfo From_Delete (Just dst))
111+ ]
83112
84−deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (From k p)
85−deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (From k p)
86−deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (From k p)
87−deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (From k p)
113+-- |Make a @'PatchMapWithMove' k p@ which has the effect of swapping two keys in the mapping, equivalent to:
114+--
115+-- @
116+-- let aMay = Map.lookup a map
117+-- bMay = Map.lookup b map
118+-- in maybe id (Map.insert a) (bMay `mplus` aMay)
119+-- . maybe id (Map.insert b) (aMay `mplus` bMay)
120+-- . Map.delete a . Map.delete b $ map
121+-- @
122+swapMapKey
123+ :: (DecidablyEmpty p, Patch p) => Ord k => k -> k -> PatchMapWithMove k p
124+swapMapKey src dst
125+ | src == dst = mempty
126+ | otherwise =
127+ PatchMapWithMove $ Map.fromList
128+ [ (dst, NodeInfo (From_Move src mempty) (Just src))
129+ , (src, NodeInfo (From_Move dst mempty) (Just dst))
130+ ]
88131
89−-- | Describe where a key's old value will go. If this is 'Just', that means
90−-- the key's old value will be moved to the given other key; if it is 'Nothing',
91−-- that means it will be deleted.
92−type To = Maybe
132+-- |Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'.
133+deleteMapKey
134+ :: k -> PatchMapWithMove k v
135+deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete Nothing
136+
137+-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants.
138+--
139+-- __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
142+unsafePatchMapWithMove = PatchMapWithMove
93143
94144-- | Apply the insertions, deletions, and moves to a given 'Map'
95145instance (Ord k, Patch p) => Patch (PatchMapWithMove k p) where
@@ -104,10 +154,13 @@ instance (Ord k, Patch p) => Patch (PatchMapWithMove k p) where
104154 _ -> Nothing
105155
106156-- | Returns all the new elements that will be added to the 'Map'
107−patchMapWithMoveNewElements :: PatchMapWithMove k p -> [PatchTarget p]
157+patchMapWithMoveNewElements
158+ :: PatchMapWithMove k p -> [PatchTarget p]
108159patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap
109160
110−patchMapWithMoveNewElementsMap :: PatchMapWithMove k p -> Map k (PatchTarget p)
161+-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@.
162+patchMapWithMoveNewElementsMap
163+ :: PatchMapWithMove k p -> Map k (PatchTarget p)
111164patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p
112165 where f ni = case _nodeInfo_from ni of
113166 From_Insert v -> Just v
@@ -117,7 +170,10 @@ patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p
117170-- | Create a 'PatchMapWithMove' that, if applied to the given 'Map', will sort
118171-- its values using the given ordering function. The set keys of the 'Map' is
119172-- not changed.
120−patchThatSortsMapWith :: (Ord k, Monoid p) => (PatchTarget p -> PatchTarget p -> Ordering) -> Map k (PatchTarget p) -> PatchMapWithMove k p
173+patchThatSortsMapWith
174+ :: (Ord k, Monoid p)
175+ => (PatchTarget p -> PatchTarget p -> Ordering)
176+ -> Map k (PatchTarget p) -> PatchMapWithMove k p
121177patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
122178 where unsorted = Map.toList m
123179 sorted = sortBy (cmp `on` snd) unsorted
@@ -131,14 +187,19 @@ patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipW
131187-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
132188-- will produce a 'Map' with the same values as the second 'Map' but with the
133189-- values sorted with the given ordering function.
134−patchThatChangesAndSortsMapWith :: forall k p. (Ord k, Ord (PatchTarget p), Monoid p) => (PatchTarget p -> PatchTarget p -> Ordering) -> Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithMove k p
190+patchThatChangesAndSortsMapWith
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
135194patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
136195 where newList = Map.toList newByIndexUnsorted
137196 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
138197
139198-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
140199-- will produce the second 'Map'.
141−patchThatChangesMap :: (Ord k, Ord (PatchTarget p), Monoid p) => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithMove k p
200+patchThatChangesMap
201+ :: (Ord k, Ord (PatchTarget p), Monoid p)
202+ => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithMove k p
142203patchThatChangesMap oldByIndex newByIndex = patch
143204 where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
144205 (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
@@ -169,16 +230,19 @@ patchThatChangesMap oldByIndex newByIndex = patch
169230 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
170231
171232-- | Change the 'From' value of a 'NodeInfo'
172−nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
233+nodeInfoMapFrom
234+ :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
173235nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
174236
175237-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
176238-- 'Applicative', 'Monad', etc.) action to get the new value
177−nodeInfoMapMFrom :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
239+nodeInfoMapMFrom
240+ :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
178241nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
179242
180243-- | Set the 'To' field of a 'NodeInfo'
181−nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
244+nodeInfoSetTo
245+ :: To k -> NodeInfo k v -> NodeInfo k v
182246nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
183247
184248-- |Helper data structure used for composing patches using the monoid instance.
@@ -187,14 +251,18 @@ data Fixup k v
187251 | Fixup_Update (These (From k v) (To k))
188252
189253-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
190−instance (Ord k, Monoid p, Eq p, Patch p) => Semigroup (PatchMapWithMove k p) where
254+instance ( Ord k
255+ , Monoid p
256+ , DecidablyEmpty p
257+ , Patch p
258+ ) => Semigroup (PatchMapWithMove k p) where
191259 PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m
192260 where
193261 connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb
194262 h :: (k, (Maybe k, From k p)) -> [(k, Fixup k p)]
195263 h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of
196264 (Just toAfter, From_Move fromBefore p)
197− | fromBefore == toAfter && p == mempty
265+ | fromBefore == toAfter && isNull p
198266 -> [(toAfter, Fixup_Delete)]
199267 | otherwise
200268 -> [ (toAfter, Fixup_Update (This editBefore))
@@ -241,6 +309,10 @@ instance (Ord k, Monoid p, Eq p, Patch p) => Semigroup (PatchMapWithMove k p) wh
241309
242310--TODO: Figure out how to implement this in terms of PatchDMapWithMove rather than duplicating it here
243311-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
244−instance (Ord k, Monoid p, Eq p, Patch p) => Monoid (PatchMapWithMove k p) where
312+instance ( Ord k
313+ , Monoid p
314+ , DecidablyEmpty p
315+ , Patch p
316+ ) => Monoid (PatchMapWithMove k p) where
245317 mempty = PatchMapWithMove mempty
246318 mappend = (<>)