@@ -1,13 +1,13 @@
1−{-# LANGUAGE CPP #-}
1+{-# LANGUAGE DeriveTraversable #-}
22{-# LANGUAGE FlexibleContexts #-}
33{-# LANGUAGE FlexibleInstances #-}
44{-# LANGUAGE LambdaCase #-}
55{-# LANGUAGE MultiParamTypeClasses #-}
66{-# LANGUAGE PatternGuards #-}
77{-# LANGUAGE ScopedTypeVariables #-}
8−{-# LANGUAGE StandaloneDeriving #-}
8+{-# LANGUAGE TemplateHaskell #-}
9+{-# LANGUAGE TypeApplications #-}
910{-# LANGUAGE TypeFamilies #-}
10−{-# LANGUAGE UndecidableInstances #-}
1111
1212-- | 'Patch'es on 'Map' that can insert, delete, and move values from one key to
1313-- another
@@ -16,6 +16,7 @@ module Data.Patch.MapWithMove where
1616import Data.Patch.Class
1717
1818import Control.Arrow
19+import Control.Lens hiding (from, to)
1920import Control.Monad.Trans.State
2021import Data.Foldable
2122import Data.Function
@@ -23,97 +24,89 @@ import Data.List
2324import Data.Map (Map)
2425import qualified Data.Map as Map
2526import Data.Maybe
26−--import Data.Proxy
27−#if !MIN_VERSION_base(4,9,0)
2827import Data.Semigroup (Semigroup (..), (<>))
29−#endif
30−import Data.Monoid.DecidablyEmpty
3128import qualified Data.Set as Set
32−import Data.These (These (..))
29+import Data.These (These(..))
3330import Data.Tuple
3431
3532-- | Patch a Map with additions, deletions, and moves. Invariant: If key @k1@
3633-- is coming from @From_Move k2@, then key @k2@ should be going to @Just k1@,
3734-- and vice versa. There should never be any unpaired From/To keys.
38−newtype PatchMapWithMove k p = PatchMapWithMove
35+newtype PatchMapWithMove k v = PatchMapWithMove
3936 { -- | Extract the internal representation of the 'PatchMapWithMove'
40− unPatchMapWithMove :: Map k (NodeInfo k p)
37+ unPatchMapWithMove :: Map k (NodeInfo k v)
4138 }
42−deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (PatchMapWithMove k p)
43−deriving instance (Ord k, Read k, Read p, Read (PatchTarget p)) => Read (PatchMapWithMove k p)
44−deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (PatchMapWithMove k p)
45−deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (PatchMapWithMove k p)
39+ deriving ( Show, Read, Eq, Ord
40+ , Functor, Foldable, Traversable
41+ )
4642
4743-- | Holds the information about each key: where its new value should come from,
4844-- and where its old value should go to
49−data NodeInfo k p = NodeInfo
50− { _nodeInfo_from :: !(From k p)
45+data NodeInfo k v = NodeInfo
46+ { _nodeInfo_from :: !(From k v)
5147 -- ^ Where do we get the new value for this key?
5248 , _nodeInfo_to :: !(To k)
5349 -- ^ If the old value is being kept (i.e. moved rather than deleted or
5450 -- replaced), where is it going?
5551 }
56−deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (NodeInfo k p)
57−deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (NodeInfo k p)
58−deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (NodeInfo k p)
59−deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (NodeInfo k p)
52+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
6053
6154-- | Describe how a key's new value should be produced
62−data From k p
63− = From_Insert (PatchTarget p) -- ^ Insert the given value here
55+data From k v
56+ = From_Insert v -- ^ Insert the given value here
6457 | From_Delete -- ^ Delete the existing value, if any, from here
65− | From_Move !k !p -- ^ Move the value here from the given key, and apply the given patch
66−
67−deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (From k p)
68−deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (From k p)
69−deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (From k p)
70−deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (From k p)
58+ | From_Move !k -- ^ Move the value here from the given key
59+ deriving (Show, Read, Eq, Ord, Functor, Foldable, Traversable)
7160
7261-- | Describe where a key's old value will go. If this is 'Just', that means
7362-- the key's old value will be moved to the given other key; if it is 'Nothing',
7463-- that means it will be deleted.
7564type To = Maybe
7665
66+makeWrapped ''PatchMapWithMove
67+
68+instance FunctorWithIndex k (PatchMapWithMove k)
69+instance FoldableWithIndex k (PatchMapWithMove k)
70+instance TraversableWithIndex k (PatchMapWithMove k) where
71+ itraverse = itraversed . Indexed
72+ itraversed = _Wrapped .> itraversed <. traversed
73+
7774-- | Create a 'PatchMapWithMove', validating it
78−patchMapWithMove
79− :: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithMove k p)
75+patchMapWithMove :: Ord k => Map k (NodeInfo k v) -> Maybe (PatchMapWithMove k v)
8076patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
8177 where valid = forwardLinks == backwardLinks
8278 forwardLinks = Map.mapMaybe _nodeInfo_to m
83− backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, p) ->
84− case _nodeInfo_from p of
85− From_Move from _ -> Just (from, to)
79+ backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, v) ->
80+ case _nodeInfo_from v of
81+ From_Move from -> Just (from, to)
8682 _ -> Nothing
8783
8884-- | Create a 'PatchMapWithMove' that inserts everything in the given 'Map'
89−patchMapWithMoveInsertAll
90− :: Map k (PatchTarget p) -> PatchMapWithMove k p
85+patchMapWithMoveInsertAll :: Map k v -> PatchMapWithMove k v
9186patchMapWithMoveInsertAll m = PatchMapWithMove $ flip fmap m $ \v -> NodeInfo
9287 { _nodeInfo_from = From_Insert v
9388 , _nodeInfo_to = Nothing
9489 }
9590
96−-- | Make a @'PatchMapWithMove' k p@ which has the effect of inserting or replacing a value @v@ at the given key @k@, like 'Map.insert'.
97−insertMapKey
98− :: k -> PatchTarget p -> PatchMapWithMove k p
91+-- | Make a @'PatchMapWithMove' k v@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'.
92+insertMapKey :: k -> v -> PatchMapWithMove k v
9993insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing
10094
101−-- |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:
95+-- |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:
10296--
10397-- @
10498-- 'Map.delete' src (maybe map ('Map.insert' dst) (Map.lookup src map))
10599-- @
106−moveMapKey
107− :: (DecidablyEmpty p, Patch p) => Ord k => k -> k -> PatchMapWithMove k p
100+moveMapKey :: Ord k => k -> k -> PatchMapWithMove k v
108101moveMapKey src dst
109102 | src == dst = mempty
110103 | otherwise =
111104 PatchMapWithMove $ Map.fromList
112− [ (dst, NodeInfo (From_Move src mempty) Nothing)
105+ [ (dst, NodeInfo (From_Move src) Nothing)
113106 , (src, NodeInfo From_Delete (Just dst))
114107 ]
115108
116−-- |Make a @'PatchMapWithMove' k p@ which has the effect of swapping two keys in the mapping, equivalent to:
109+-- |Make a @'PatchMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
117110--
118111-- @
119112-- let aMay = Map.lookup a map
@@ -122,67 +115,53 @@ moveMapKey src dst
122115-- . maybe id (Map.insert b) (aMay `mplus` bMay)
123116-- . Map.delete a . Map.delete b $ map
124117-- @
125−swapMapKey
126− :: (DecidablyEmpty p, Patch p)
127− => Ord k => k -> k -> PatchMapWithMove k p
118+swapMapKey :: Ord k => k -> k -> PatchMapWithMove k v
128119swapMapKey src dst
129120 | src == dst = mempty
130121 | otherwise =
131122 PatchMapWithMove $ Map.fromList
132− [ (dst, NodeInfo (From_Move src mempty) (Just src))
133− , (src, NodeInfo (From_Move dst mempty) (Just dst))
123+ [ (dst, NodeInfo (From_Move src) (Just src))
124+ , (src, NodeInfo (From_Move dst) (Just dst))
134125 ]
135126
136−-- | Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in
137−-- the mapping, equivalent to 'Map.delete'.
138−deleteMapKey
139− :: k -> PatchMapWithMove k v
127+-- |Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'.
128+deleteMapKey :: k -> PatchMapWithMove k v
140129deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete Nothing
141130
142131-- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants.
143132--
144133-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchMapWithMove' are preserved; they will not be checked.
145−unsafePatchMapWithMove
146− :: Map k (NodeInfo k p) -> PatchMapWithMove k p
134+unsafePatchMapWithMove :: Map k (NodeInfo k v) -> PatchMapWithMove k v
147135unsafePatchMapWithMove = PatchMapWithMove
148136
149137-- | Apply the insertions, deletions, and moves to a given 'Map'
150−instance (Ord k, Patch p) => Patch (PatchMapWithMove k p) where
151− type PatchTarget (PatchMapWithMove k p) = Map k (PatchTarget p)
152− -- TODO: return Nothing sometimes
153− -- Note: the strict application here is critical to ensuring that incremental
154− -- merges don't hold onto all their prerequisite events forever; can we make
155− -- this more robust?
156− apply (PatchMapWithMove m) old = Just $! insertions `Map.union` (old `Map.difference` deletions)
157− where insertions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
138+instance Ord k => Patch (PatchMapWithMove k v) where
139+ type PatchTarget (PatchMapWithMove k v) = Map k v
140+ 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?
141+ where insertions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of
158142 From_Insert v -> Just v
159− From_Move k p -> applyAlways p <$> Map.lookup k old
143+ From_Move k -> Map.lookup k old
160144 From_Delete -> Nothing
161− deletions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
145+ deletions = flip Map.mapMaybeWithKey p $ \_ ni -> case _nodeInfo_from ni of
162146 From_Delete -> Just ()
163147 _ -> Nothing
164148
165−-- | Returns all the new elements that will be added to the 'Map'
166−patchMapWithMoveNewElements
167− :: PatchMapWithMove k p -> [PatchTarget p]
149+-- | Returns all the new elements that will be added to the 'Map'.
150+patchMapWithMoveNewElements :: PatchMapWithMove k v -> [v]
168151patchMapWithMoveNewElements = Map.elems . patchMapWithMoveNewElementsMap
169152
170153-- | Return a @'Map' k v@ with all the inserts/updates from the given @'PatchMapWithMove' k v@.
171−patchMapWithMoveNewElementsMap
172− :: PatchMapWithMove k p -> Map k (PatchTarget p)
154+patchMapWithMoveNewElementsMap :: PatchMapWithMove k v -> Map k v
173155patchMapWithMoveNewElementsMap (PatchMapWithMove p) = Map.mapMaybe f p
174156 where f ni = case _nodeInfo_from ni of
175157 From_Insert v -> Just v
176− From_Move _ _ -> Nothing
158+ From_Move _ -> Nothing
177159 From_Delete -> Nothing
178160
179161-- | Create a 'PatchMapWithMove' that, if applied to the given 'Map', will sort
180162-- its values using the given ordering function. The set keys of the 'Map' is
181163-- not changed.
182−patchThatSortsMapWith
183− :: (Ord k, Monoid p)
184− => (PatchTarget p -> PatchTarget p -> Ordering)
185− -> Map k (PatchTarget p) -> PatchMapWithMove k p
164+patchThatSortsMapWith :: Ord k => (v -> v -> Ordering) -> Map k v -> PatchMapWithMove k v
186165patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipWith g unsorted sorted
187166 where unsorted = Map.toList m
188167 sorted = sortBy (cmp `on` snd) unsorted
@@ -190,25 +169,20 @@ patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipW
190169 Just (from, to)
191170 reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
192171 g (to, _) (from, _) = if to == from then Nothing else
193− let Just movingTo = Map.lookup from reverseMapping
194− in Just (to, NodeInfo (From_Move from mempty) $ Just movingTo)
172+ let Just movingTo = Map.lookup to reverseMapping
173+ in Just (to, NodeInfo (From_Move from) $ Just movingTo)
195174
196175-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
197176-- will produce a 'Map' with the same values as the second 'Map' but with the
198177-- values sorted with the given ordering function.
199−patchThatChangesAndSortsMapWith
200− :: forall k p. (Ord k, Ord (PatchTarget p), Monoid p)
201− => (PatchTarget p -> PatchTarget p -> Ordering)
202− -> Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithMove k p
178+patchThatChangesAndSortsMapWith :: forall k v. (Ord k, Ord v) => (v -> v -> Ordering) -> Map k v -> Map k v -> PatchMapWithMove k v
203179patchThatChangesAndSortsMapWith cmp oldByIndex newByIndexUnsorted = patchThatChangesMap oldByIndex newByIndex
204180 where newList = Map.toList newByIndexUnsorted
205181 newByIndex = Map.fromList $ zip (fst <$> newList) $ sortBy cmp $ snd <$> newList
206182
207183-- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
208184-- will produce the second 'Map'.
209−patchThatChangesMap
210− :: (Ord k, Ord (PatchTarget p), Monoid p)
211− => Map k (PatchTarget p) -> Map k (PatchTarget p) -> PatchMapWithMove k p
185+patchThatChangesMap :: (Ord k, Ord v) => Map k v -> Map k v -> PatchMapWithMove k v
212186patchThatChangesMap oldByIndex newByIndex = patch
213187 where oldByValue = Map.fromListWith Set.union $ swap . first Set.singleton <$> Map.toList oldByIndex
214188 (insertsAndMoves, unusedValuesByValue) = flip runState oldByValue $ do
@@ -223,15 +197,15 @@ patchThatChangesMap oldByIndex newByIndex = patch
223197 if k `Set.member` fromKs
224198 then do
225199 putRemainingKeys $ Set.delete k fromKs
226− return $ NodeInfo (From_Move k mempty) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
200+ return $ NodeInfo (From_Move k) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
227201 else do
228202 (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
229203 putRemainingKeys remainingKeys
230− return $ NodeInfo (From_Move fromK mempty) $ Just undefined
204+ return $ NodeInfo (From_Move fromK) $ Just undefined
231205 Map.traverseWithKey f newByIndex
232206 unusedOldKeys = fold unusedValuesByValue
233207 pointlessMove k = \case
234− From_Move k' _ | k == k' -> True
208+ From_Move k' | k == k' -> True
235209 _ -> False
236210 keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
237211 then Just undefined
@@ -239,19 +213,16 @@ patchThatChangesMap oldByIndex newByIndex = patch
239213 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
240214
241215-- | Change the 'From' value of a 'NodeInfo'
242−nodeInfoMapFrom
243− :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
216+nodeInfoMapFrom :: (From k v -> From k v) -> NodeInfo k v -> NodeInfo k v
244217nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
245218
246219-- | Change the 'From' value of a 'NodeInfo', using a 'Functor' (or
247220-- 'Applicative', 'Monad', etc.) action to get the new value
248−nodeInfoMapMFrom
249− :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
221+nodeInfoMapMFrom :: Functor f => (From k v -> f (From k v)) -> NodeInfo k v -> f (NodeInfo k v)
250222nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
251223
252224-- | Set the 'To' field of a 'NodeInfo'
253−nodeInfoSetTo
254− :: To k -> NodeInfo k v -> NodeInfo k v
225+nodeInfoSetTo :: To k -> NodeInfo k v -> NodeInfo k v
255226nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
256227
257228-- |Helper data structure used for composing patches using the monoid instance.
@@ -260,24 +231,20 @@ data Fixup k v
260231 | Fixup_Update (These (From k v) (To k))
261232
262233-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
263−instance ( Ord k
264− , Monoid p
265− , DecidablyEmpty p
266− , Patch p
267− ) => Semigroup (PatchMapWithMove k p) where
234+instance Ord k => Semigroup (PatchMapWithMove k v) where
268235 PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m
269236 where
270237 connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb
271− h :: (k, (Maybe k, From k p)) -> [(k, Fixup k p)]
238+ h :: (k, (Maybe k, From k v)) -> [(k, Fixup k v)]
272239 h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of
273− (Just toAfter, From_Move fromBefore p)
274− | fromBefore == toAfter && isNull p
240+ (Just toAfter, From_Move fromBefore)
241+ | fromBefore == toAfter
275242 -> [(toAfter, Fixup_Delete)]
276243 | otherwise
277244 -> [ (toAfter, Fixup_Update (This editBefore))
278245 , (fromBefore, Fixup_Update (That mToAfter))
279246 ]
280− (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
247+ (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
281248 (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]
282249 (Nothing, _) -> []
283250 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
@@ -295,13 +262,7 @@ instance ( Ord k
295262 applyFixup _ ni = \case
296263 Fixup_Delete -> Nothing
297264 Fixup_Update u -> Just $ NodeInfo
298− { _nodeInfo_from = case _nodeInfo_from ni of
299− f@(From_Move _ p') -> case getHere u of -- The `from` fixup comes from the "old" patch
300− Nothing -> f -- If there's no `from` fixup, just use the "new" `from`
301− Just (From_Insert v) -> From_Insert $ applyAlways p' v
302− Just From_Delete -> From_Delete
303− Just (From_Move oldKey p) -> From_Move oldKey $ p' <> p
304− _ -> error "PatchMapWithMove: fixup for non-move From"
265+ { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
305266 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
306267 }
307268 m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups
@@ -317,12 +278,7 @@ instance ( Ord k
317278 That b -> Just b
318279
319280--TODO: Figure out how to implement this in terms of PatchDMapWithMove rather than duplicating it here
320−-- | Compose patches having the same effect as applying the patches in turn:
321−-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
322−instance ( Ord k
323− , Monoid p
324− , DecidablyEmpty p
325− , Patch p
326− ) => Monoid (PatchMapWithMove k p) where
281+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
282+instance Ord k => Monoid (PatchMapWithMove k v) where
327283 mempty = PatchMapWithMove mempty
328284 mappend = (<>)