@@ -3,6 +3,7 @@
33{-# LANGUAGE DeriveTraversable #-}
44{-# LANGUAGE FlexibleContexts #-}
55{-# LANGUAGE LambdaCase #-}
6+{-# LANGUAGE PatternGuards #-}
67{-# LANGUAGE ScopedTypeVariables #-}
78{-# LANGUAGE TypeFamilies #-}
89-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
@@ -19,7 +20,9 @@ import Data.List
1920import Data.Map (Map)
2021import qualified Data.Map as Map
2122import Data.Maybe
23+import Data.Semigroup (Semigroup (..), (<>))
2224import qualified Data.Set as Set
25+import Data.These
2326import Data.Tuple
2427
2528-- | Patch a DMap with additions, deletions, and moves. Invariant: If key @k1@
@@ -38,6 +41,79 @@ data NodeInfo k v = NodeInfo
3841 }
3942 deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
4043
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)
50+
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
55+
56+-- |Helper data structure used for composing patches using the monoid instance.
57+data Fixup k v
58+ = Fixup_Delete
59+ | Fixup_Update (These (From k v) (To k))
60+
61+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
62+instance Ord k => Semigroup (PatchMapWithMove k v) where
63+ (<>) = mappend
64+
65+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
66+instance Ord k => Monoid (PatchMapWithMove k v) where
67+ mempty = PatchMapWithMove mempty
68+ PatchMapWithMove ma `mappend` PatchMapWithMove mb = PatchMapWithMove m
69+ where
70+ connections = Map.toList $ Map.intersectionWith (\ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb
71+ h :: (k, (Maybe k, From k v)) -> [(k, Fixup k v)]
72+ h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of
73+ (Just toAfter, From_Move fromBefore)
74+ | fromBefore == toAfter
75+ -> [(toAfter, Fixup_Delete)]
76+ | otherwise
77+ -> [ (toAfter, Fixup_Update (This editBefore))
78+ , (fromBefore, Fixup_Update (That mToAfter))
79+ ]
80+ (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
81+ (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]
82+ (Nothing, _) -> []
83+ mergeFixups Fixup_Delete Fixup_Delete = Fixup_Delete
84+ mergeFixups (Fixup_Update a) (Fixup_Update b)
85+ | This x <- a, That y <- b
86+ = Fixup_Update $ These x y
87+ | That y <- a, This x <- b
88+ = Fixup_Update $ These x y
89+ mergeFixups _ _ = error "PatchMapWithMove: incompatible fixups"
90+ fixups = Map.fromListWith mergeFixups $ concatMap h connections
91+ combineNodeInfos nia nib = NodeInfo
92+ { _nodeInfo_from = _nodeInfo_from nia
93+ , _nodeInfo_to = _nodeInfo_to nib
94+ }
95+ applyFixup ni = \case
96+ Fixup_Delete -> Nothing
97+ Fixup_Update u -> Just $ NodeInfo
98+ { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
99+ , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
100+ }
101+ m = Map.differenceWith applyFixup (Map.unionWith combineNodeInfos ma mb) fixups
102+
103+-- |Project the @a@ from a @'These' a b@, identical to @preview '_Here'@ but without using preview
104+getHere :: These a b -> Maybe a
105+getHere = \case
106+ This a -> Just a
107+ These a _ -> Just a
108+ That _ -> Nothing
109+
110+-- |Project the @b@ from a @'These' a b@, identical to @preview '_There'@ but without using preview
111+getThere :: These a b -> Maybe b
112+getThere = \case
113+ This _ -> Nothing
114+ These _ b -> Just b
115+ That b -> Just b
116+
41117-- | Create a 'PatchMapWithMove', validating it
42118patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
43119patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
@@ -52,22 +128,51 @@ patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
52128unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)
53129unPatchMapWithMove (PatchMapWithMove p) = p
54130
55−-- | Warning: when using this function, you must ensure that the invariants of
56−-- 'PatchMapWithMove' are preserved; they will not be checked.
57−unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
58−unsafePatchMapWithMove = PatchMapWithMove
131+-- | Make a @'PatchMapWithMove' k v@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'.
132+insertMapKey :: k -> v -> PatchMapWithMove k v
133+insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing
59134
60−-- | Describe how a key's new value should be produced
61−data From k v
62− = From_Insert v -- ^ Insert the given value here
63− | From_Delete -- ^ Delete the existing value, if any, from here
64− | From_Move !k -- ^ Move the value here from the given key
65− deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
135+-- |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:
136+--
137+-- @
138+-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
139+-- @
140+moveMapKey :: Ord k => k -> k -> PatchMapWithMove k v
141+moveMapKey src dst
142+ | src == dst = mempty
143+ | otherwise =
144+ PatchMapWithMove $ Map.fromList
145+ [ (dst, NodeInfo (From_Move src) Nothing)
146+ , (src, NodeInfo From_Delete (Just dst))
147+ ]
66148
67−-- | Describe where a key's old value will go. If this is 'Just', that means
68−-- the key's old value will be moved to the given other key; if it is 'Nothing',
69−-- that means it will be deleted.
70−type To = Maybe
149+-- |Make a @'PatchMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
150+--
151+-- @
152+-- let aMay = Map.lookup a map
153+-- bMay = Map.lookup b map
154+-- in maybe id (Map.insert a) (bMay `mplus` aMay)
155+-- . maybe id (Map.insert b) (aMay `mplus` bMay)
156+-- . Map.delete a . Map.delete b $ map
157+-- @
158+swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v
159+swapMapKey src dst
160+ | src == dst = mempty
161+ | otherwise =
162+ PatchMapWithMove $ Map.fromList
163+ [ (dst, NodeInfo (From_Move src) (Just src))
164+ , (src, NodeInfo (From_Move dst) (Just dst))
165+ ]
166+
167+-- |Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'.
168+deleteMapKey :: k -> PatchMapWithMove k v
169+deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete Nothing
170+
171+-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants.
172+--
173+-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked.
174+unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
175+unsafePatchMapWithMove = PatchMapWithMove
71176
72177-- | Apply the insertions, deletions, and moves to a given 'Map'
73178instance Ord k => Patch (PatchMapWithMove k v) where
@@ -81,10 +186,11 @@ instance Ord k => Patch (PatchMapWithMove k v) where
81186 From_Delete -> Just ()
82187 _ -> Nothing
83188
84−-- | Returns all the new elements that will be added to the 'Map'
189+-- | Returns all the new elements that will be added to the 'Map'.
85190patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
86191patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap
87192
193+-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@.
88194patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v
89195patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p
90196 where f ni = case _nodeInfo_from ni of