git.iko.soy/patch
on develop help sign in
add missing functions to Reflex.Patch.MapWithMove that Reflex.Patch.DMapWithMove has
c2d5c14Ross MacLeod
src/Reflex/Patch/MapWithMove.hs+121−15
compare with develop
unifiedsplit
@@ -3,6 +3,7 @@
3{-# LANGUAGE DeriveTraversable #-}
3{-# LANGUAGE DeriveTraversable #-}
4{-# LANGUAGE FlexibleContexts #-}
4{-# LANGUAGE FlexibleContexts #-}
5{-# LANGUAGE LambdaCase #-}
5{-# LANGUAGE LambdaCase #-}
6+{-# LANGUAGE PatternGuards #-}
6{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE ScopedTypeVariables #-}
7{-# LANGUAGE TypeFamilies #-}
8{-# LANGUAGE TypeFamilies #-}
8-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
9-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
@@ -19,7 +20,9 @@ import Data.List
19import Data.Map (Map)
20import Data.Map (Map)
20import qualified Data.Map as Map
21import qualified Data.Map as Map
21import Data.Maybe
22import Data.Maybe
23+import Data.Semigroup (Semigroup (..), (<>))
22import qualified Data.Set as Set
24import qualified Data.Set as Set
25+import Data.These
23import Data.Tuple
26import Data.Tuple
24
27
25-- | Patch a DMap with additions, deletions, and moves. Invariant: If key @k1@
28-- | Patch a DMap with additions, deletions, and moves. Invariant: If key @k1@
@@ -38,6 +41,79 @@ data NodeInfo k v = NodeInfo
38 }
41 }
39 deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
42 deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
40
43
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+
41-- | Create a 'PatchMapWithMove', validating it
117-- | Create a 'PatchMapWithMove', validating it
42patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
118patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
43patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
119patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
@@ -52,22 +128,51 @@ patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
52unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)
128unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)
53unPatchMapWithMove (PatchMapWithMove p) = p
129unPatchMapWithMove (PatchMapWithMove p) = p
54
130
55−-- | Warning: when using this function, you must ensure that the invariants of
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'.
56−-- 'PatchMapWithMove' are preserved; they will not be checked.
132+insertMapKey :: k -> v -> PatchMapWithMove k v
57−unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
133+insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing
58−unsafePatchMapWithMove = PatchMapWithMove
59
134
60−-- | Describe how a key's new value should be produced
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:
61−data From k v
136+--
62− = From_Insert v -- ^ Insert the given value here
137+-- @
63− | From_Delete -- ^ Delete the existing value, if any, from here
138+-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
64− | From_Move !k -- ^ Move the value here from the given key
139+-- @
65− deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
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+ ]
66
148
67−-- | Describe where a key's old value will go. If this is 'Just', that means
149+-- |Make a @'PatchMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
68−-- the key's old value will be moved to the given other key; if it is 'Nothing',
150+--
69−-- that means it will be deleted.
151+-- @
70−type To = Maybe
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
71
176
72-- | Apply the insertions, deletions, and moves to a given 'Map'
177-- | Apply the insertions, deletions, and moves to a given 'Map'
73instance Ord k => Patch (PatchMapWithMove k v) where
178instance Ord k => Patch (PatchMapWithMove k v) where
@@ -81,10 +186,11 @@ instance Ord k => Patch (PatchMapWithMove k v) where
81 From_Delete -> Just ()
186 From_Delete -> Just ()
82 _ -> Nothing
187 _ -> Nothing
83
188
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'.
85patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
190patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
86patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap
191patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap
87
192
193+-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@.
88patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v
194patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v
89patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p
195patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p
90 where f ni = case _nodeInfo_from ni of
196 where f ni = case _nodeInfo_from ni of