Skip to content

Commit c2d5c14

Browse files
author
Ross MacLeod
committed
add missing functions to Reflex.Patch.MapWithMove that Reflex.Patch.DMapWithMove has
specifically: Semigroup instance Monoid instance insertMapKey deleteMapKey moveMapKey swapMapKey
1 parent 1b36922 commit c2d5c14

File tree

1 file changed

+121
-15
lines changed

1 file changed

+121
-15
lines changed

‎src/Reflex/Patch/MapWithMove.hs

Lines changed: 121 additions & 15 deletions
Original file line numberDiff line numberDiff line change
@@ -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
1920
import Data.Map (Map)
2021
import qualified Data.Map as Map
2122
import Data.Maybe
23+
import Data.Semigroup (Semigroup (..), (<>))
2224
import qualified Data.Set as Set
25+
import Data.These
2326
import 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
42118
patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
43119
patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
@@ -52,22 +128,51 @@ patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
52128
unPatchMapWithMove :: PatchMapWithMove k v -> Map k (NodeInfo k v)
53129
unPatchMapWithMove (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'
73178
instance 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'.
85190
patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
86191
patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap
87192

193+
-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@.
88194
patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v
89195
patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p
90196
where f ni = case _nodeInfo_from ni of

0 commit comments

Comments
 (0)