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