git.iko.soy/patch
on develop help sign in
patch/src/Data/Patch/DMapWithMove.hs
371 lines 20 kB history raw
1{-# LANGUAGE CPP #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE FlexibleInstances #-}
4{-# LANGUAGE GADTs #-}
5{-# LANGUAGE LambdaCase #-}
6{-# LANGUAGE MultiParamTypeClasses #-}
7{-# LANGUAGE PatternGuards #-}
8{-# LANGUAGE PolyKinds #-}
9{-# LANGUAGE Rank2Types #-}
10{-# LANGUAGE ScopedTypeVariables #-}
11{-# LANGUAGE TypeFamilies #-}
12{-# LANGUAGE UndecidableInstances #-}
14-- |Module containing @'PatchDMapWithMove' k v@ and associated functions, which represents a 'Patch' to a @'DMap' k v@ which can insert, update, delete, and
15-- move values between keys.
16module Data.Patch.DMapWithMove where
18import Data.Patch.Class
19import Data.Patch.MapWithMove (PatchMapWithMove (..))
20import qualified Data.Patch.MapWithMove as MapWithMove
22import Data.Constraint.Extras
23import Data.Dependent.Map (DMap)
24import Data.Dependent.Sum (DSum (..))
25import qualified Data.Dependent.Map as DMap
26import Data.Functor.Constant
27import Data.Functor.Misc
28import Data.Functor.Product
29import Data.GADT.Compare (GEq (..), GCompare (..))
30import Data.GADT.Show (GShow, gshow)
31import qualified Data.Map as Map
32import Data.Maybe
33import Data.Monoid.DecidablyEmpty
34#if !MIN_VERSION_base(4,11,0)
35import Data.Semigroup (Semigroup (..))
36#endif
37import Data.Some (Some, mkSome)
38import Data.These
40-- | Like 'PatchMapWithMove', but for 'DMap'. Each key carries a 'NodeInfo' which describes how it will be changed by the patch and connects move sources and
41-- destinations.
42--
43-- Invariants:
44--
45-- * A key should not move to itself.
46-- * A move should always be represented with both the destination key (as a 'From_Move') and the source key (as a @'ComposeMaybe' ('Just' destination)@)
47newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
49-- It won't let me derive for some reason
50instance GCompare k => DecidablyEmpty (PatchDMapWithMove k v) where
51 isEmpty (PatchDMapWithMove m) = DMap.null m
53-- |Structure which represents what changes apply to a particular key. @_nodeInfo_from@ specifies what happens to this key, and in particular what other key
54-- the current key is moving from, while @_nodeInfo_to@ specifies what key the current key is moving to if involved in a move.
55data NodeInfo k v a = NodeInfo
56 { _nodeInfo_from :: !(From k v a)
57 -- ^Change applying to the current key, be it an insert, move, or delete.
58 , _nodeInfo_to :: !(To k a)
59 -- ^Where this key is moving to, if involved in a move. Should only be @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.
60 }
61 deriving (Show)
63-- |Structure describing a particular change to a key, be it inserting a new key (@From_Insert@), updating an existing key (@From_Insert@ again), deleting a
64-- key (@From_Delete@), or moving a key (@From_Move@).
65data From (k :: a -> *) (v :: a -> *) :: a -> * where
66 -- |Insert a new or update an existing key with the given value @v a@
67 From_Insert :: v a -> From k v a
68 -- |Delete the existing key
69 From_Delete :: From k v a
70 -- |Move the value from the given key @k a@ to this key. The source key should also have an entry in the patch giving the current key as @_nodeInfo_to@,
71 -- usually but not necessarily with @From_Delete@.
72 From_Move :: !(k a) -> From k v a
73 deriving (Show, Read, Eq, Ord)
75-- |Type alias for the "to" part of a 'NodeInfo'. @'ComposeMaybe' ('Just' k)@ means the key is moving to another key, @ComposeMaybe Nothing@ for any other
76-- operation.
77type To = ComposeMaybe
79-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
80validPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Bool
81validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
83-- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.
84validationErrorsForPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> [String]
85validationErrorsForPatchDMapWithMove m =
86 noSelfMoves <> movesBalanced
87 where
88 noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
89 selfMove (dst :=> NodeInfo (From_Move src) _) | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"
90 selfMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
91 selfMove _ = Nothing
92 movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
93 unbalancedMove (dst :=> NodeInfo (From_Move src) _) =
94 case DMap.lookup src m of
95 Nothing -> Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key is not in the patch"
96 Just (NodeInfo _ (ComposeMaybe (Just dst'))) ->
97 if isNothing (dst' `geq` dst)
98 then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead"
99 else Nothing
100 _ ->
101 Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key has no move to key"
102 unbalancedMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) =
103 case DMap.lookup dst m of
104 Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"
105 Just (NodeInfo (From_Move src') _) ->
106 if isNothing (src' `geq` src)
107 then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead"
108 else Nothing
110 _ ->
111 Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
112 unbalancedMove _ = Nothing
114-- |Test whether two @'PatchDMapWithMove' k v@ contain the same patch operations.
115instance (GEq k, Has' Eq k (NodeInfo k v)) => Eq (PatchDMapWithMove k v) where
116 PatchDMapWithMove a == PatchDMapWithMove b = a == b
118-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
119data Pair1 f g a = Pair1 (f a) (g a)
121-- |Helper data structure used for composing patches using the monoid instance.
122data Fixup k v a
123 = Fixup_Delete
124 | Fixup_Update (These (From k v a) (To k a))
126-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
127instance GCompare k => Semigroup (PatchDMapWithMove k v) where
128 PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
129 where
130 connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb
131 h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]
132 h (_ :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case (mToAfter, editBefore) of
133 (Just toAfter, From_Move fromBefore)
134 | isJust $ fromBefore `geq` toAfter
135 -> [toAfter :=> Fixup_Delete]
136 | otherwise
137 -> [ toAfter :=> Fixup_Update (This editBefore)
138 , fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))
139 ]
140 (Nothing, From_Move fromBefore) -> [fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map
141 (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)]
142 (Nothing, _) -> []
143 mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
144 mergeFixups _ (Fixup_Update a) (Fixup_Update b)
145 | This x <- a, That y <- b
146 = Fixup_Update $ These x y
147 | That y <- a, This x <- b
148 = Fixup_Update $ These x y
149 mergeFixups _ _ _ = error "PatchDMapWithMove: incompatible fixups"
150 fixups = DMap.fromListWithKey mergeFixups $ concatMap h connections
151 combineNodeInfos _ nia nib = NodeInfo
152 { _nodeInfo_from = _nodeInfo_from nia
153 , _nodeInfo_to = _nodeInfo_to nib
154 }
155 applyFixup _ ni = \case
156 Fixup_Delete -> Nothing
157 Fixup_Update u -> Just $ NodeInfo
158 { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
159 , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
160 }
161 m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups
162 getHere :: These a b -> Maybe a
163 getHere = \case
164 This a -> Just a
165 These a _ -> Just a
166 That _ -> Nothing
167 getThere :: These a b -> Maybe b
168 getThere = \case
169 This _ -> Nothing
170 These _ b -> Just b
171 That b -> Just b
173-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
174instance GCompare k => Monoid (PatchDMapWithMove k v) where
175 mempty = PatchDMapWithMove mempty
176 mappend = (<>)
178{-
179mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
180PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
181 where
182 getDstAction k m = fromMaybe (From_Move k) $ DMap.lookup k m -- Any key that isn't present is treated as that key moving to itself
183 removeRedundantDst toKey (From_Move fromKey) | isJust (toKey `geq` fromKey) = Nothing
184 removeRedundantDst _ a = Just a
185 f :: forall a. k a -> From k v a -> Maybe (From k v a)
186 f toKey _ = removeRedundantDst toKey $ case getDstAction toKey dstAfter of
187 From_Move fromKey -> getDstAction fromKey dstBefore
188 nonMove -> nonMove
189 dst = DMap.mapMaybeWithKey f $ DMap.union dstAfter dstBefore
190 getSrcAction k m = fromMaybe (ComposeMaybe $ Just k) $ DMap.lookup k m
191 removeRedundantSrc fromKey (ComposeMaybe (Just toKey)) | isJust (fromKey `geq` toKey) = Nothing
192 removeRedundantSrc _ a = Just a
193 g :: forall a. k a -> ComposeMaybe k a -> Maybe (ComposeMaybe k a)
194 g fromKey _ = removeRedundantSrc fromKey $ case getSrcAction fromKey srcBefore of
195 ComposeMaybe Nothing -> ComposeMaybe Nothing
196 ComposeMaybe (Just toKeyBefore) -> getSrcAction toKeyBefore srcAfter
197 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
198-}
200-- |Make a @'PatchDMapWithMove' k v@ which has the effect of inserting or updating a value @v a@ to the given key @k a@, like 'DMap.insert'.
201insertDMapKey :: k a -> v a -> PatchDMapWithMove k v
202insertDMapKey k v =
203 PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing)
205-- |Make a @'PatchDMapWithMove' k v@ which has the effect of moving the value from the first key @k a@ to the second key @k a@, equivalent to:
206--
207-- @
208-- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap))
209-- @
210moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
211moveDMapKey src dst = case src `geq` dst of
212 Nothing -> PatchDMapWithMove $ DMap.fromList
213 [ dst :=> NodeInfo (From_Move src) (ComposeMaybe Nothing)
214 , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst)
215 ]
216 Just _ -> mempty
218-- |Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
219--
220-- @
221-- let aMay = DMap.lookup a dmap
222-- bMay = DMap.lookup b dmap
223-- in maybe id (DMap.insert a) (bMay <> aMay)
224-- . maybe id (DMap.insert b) (aMay <> bMay)
225-- . DMap.delete a . DMap.delete b $ dmap
226-- @
227swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
228swapDMapKey src dst = case src `geq` dst of
229 Nothing -> PatchDMapWithMove $ DMap.fromList
230 [ dst :=> NodeInfo (From_Move src) (ComposeMaybe $ Just src)
231 , src :=> NodeInfo (From_Move dst) (ComposeMaybe $ Just dst)
232 ]
233 Just _ -> mempty
235-- |Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'DMap.delete'.
236deleteDMapKey :: k a -> PatchDMapWithMove k v
237deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete $ ComposeMaybe Nothing
239{-
240k1, k2 :: Const2 Int () ()
241k1 = Const2 1
242k2 = Const2 2
243p1, p2 :: PatchDMapWithMove (Const2 Int ()) Identity
244p1 = moveDMapKey k1 k2
245p2 = moveDMapKey k2 k1
246p12 = p1 <> p2
247p21 = p2 <> p1
248p12Slow = p1 `mappendPatchDMapWithMoveSlow` p2
249p21Slow = p2 `mappendPatchDMapWithMoveSlow` p1
251testPatchDMapWithMove = do
252 print p1
253 print p2
254 print $ p12 == deleteDMapKey k1
255 print $ p21 == deleteDMapKey k2
256 print $ p12Slow == deleteDMapKey k1
257 print $ p21Slow == deleteDMapKey k2
259dst (PatchDMapWithMove x _) = x
260src (PatchDMapWithMove _ x) = x
261-}
263-- |Extract the 'DMap' representing the patch changes from the 'PatchDMapWithMove'.
264unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)
265unPatchDMapWithMove (PatchDMapWithMove p) = p
267-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove', without checking any invariants.
268--
269-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchDMapWithMove' are preserved; they will not be checked.
270unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v
271unsafePatchDMapWithMove = PatchDMapWithMove
273-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while checking invariants. If the invariants are satisfied, @Right p@ is returned
274-- otherwise @Left errors@.
275patchDMapWithMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)
276patchDMapWithMove dm =
277 case validationErrorsForPatchDMapWithMove dm of
278 [] -> Right $ unsafePatchDMapWithMove dm
279 errs -> Left errs
281-- |Map a natural transform @v -> v'@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.
282mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'
283mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $
284 DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
285 where g :: forall a. From k v a -> From k v' a
286 g = \case
287 From_Insert v -> From_Insert $ f v
288 From_Delete -> From_Delete
289 From_Move k -> From_Move k
291-- |Traverse an effectful function @forall a. v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.
292traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
293traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
295-- |Map an effectful function @forall a. k a -> v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.
296traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
297traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p
298 where g :: forall a. k a -> From k v a -> m (From k v' a)
299 g k = \case
300 From_Insert v -> From_Insert <$> f k v
301 From_Delete -> pure From_Delete
302 From_Move fromKey -> pure $ From_Move fromKey
304-- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over a @'NodeInfo' k v a@.
305nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a
306nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
308-- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'NodeInfo' k v a@.
309nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)
310nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
312-- |Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys from @k a@ to @'Some' k@ and applying a given weakening function @v a -> v'@ to
313-- values.
314weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'
315weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
316 where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) v'
317 g ni = MapWithMove.NodeInfo
318 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
319 From_Insert v -> MapWithMove.From_Insert $ f v
320 From_Delete -> MapWithMove.From_Delete
321 From_Move k -> MapWithMove.From_Move $ mkSome k
322 , MapWithMove._nodeInfo_to = mkSome <$> getComposeMaybe (_nodeInfo_to ni)
323 }
325-- |"Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k v'@. Weaken is in scare quotes because the 'Const2' has already disabled any
326-- dependency in the typing and all points are already @a@, hence the function to map each value to @v'@ is not higher rank.
327patchDMapWithMoveToPatchMapWithMoveWith :: forall k v v' a. (v a -> v') -> PatchDMapWithMove (Const2 k a) v -> PatchMapWithMove k v'
328patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
329 where g :: NodeInfo (Const2 k a) v a -> MapWithMove.NodeInfo k v'
330 g ni = MapWithMove.NodeInfo
331 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
332 From_Insert v -> MapWithMove.From_Insert $ f v
333 From_Delete -> MapWithMove.From_Delete
334 From_Move (Const2 k) -> MapWithMove.From_Move k
335 , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)
336 }
338-- |"Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove ('Const2' k a)@; that is, turn a non-dependently-typed patch into a dependently typed
339-- one but which always has a constant key type represented by 'Const2'. Apply the given function to each @v@ to produce a @v' a@.
340-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
341const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) v'
342const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
343 where g :: (k, MapWithMove.NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')
344 g (k, ni) = Const2 k :=> NodeInfo
345 { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of
346 MapWithMove.From_Insert v -> From_Insert $ f v
347 MapWithMove.From_Delete -> From_Delete
348 MapWithMove.From_Move fromKey -> From_Move $ Const2 fromKey
349 , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni
350 }
352-- | Apply the insertions, deletions, and moves to a given 'DMap'.
353instance GCompare k => Patch (PatchDMapWithMove k v) where
354 type PatchTarget (PatchDMapWithMove k v) = DMap k v
355 apply (PatchDMapWithMove p) old = Just $! insertions `DMap.union` (old `DMap.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?
356 where insertions = DMap.mapMaybeWithKey insertFunc p
357 insertFunc :: forall a. k a -> NodeInfo k v a -> Maybe (v a)
358 insertFunc _ ni = case _nodeInfo_from ni of
359 From_Insert v -> Just v
360 From_Move k -> DMap.lookup k old
361 From_Delete -> Nothing
362 deletions = DMap.mapMaybeWithKey deleteFunc p
363 deleteFunc :: forall a. k a -> NodeInfo k v a -> Maybe (Constant () a)
364 deleteFunc _ ni = case _nodeInfo_from ni of
365 From_Delete -> Just $ Constant ()
366 _ -> Nothing
368-- | Get the values that will be replaced, deleted, or moved if the given patch is applied to the given 'DMap'.
369getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))
370getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
371 where f _ v ni = Pair v $ _nodeInfo_to ni