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