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