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