git.iko.soy/patch
on 1150ac9 help sign in
patch/src/Reflex/Patch/DMapWithMove.hs
367 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 Reflex.Patch.DMapWithMove where
18import Reflex.Patch.Class
19import Reflex.Patch.MapWithMove (PatchMapWithMove (..))
20import qualified Reflex.Patch.MapWithMove as MapWithMove
22import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
23import qualified Data.Dependent.Map as DMap
24import Data.Dependent.Sum (EqTag (..))
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)
34import qualified Data.Some as 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-- |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
107instance EqTag 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-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
114instance GCompare k => Semigroup (PatchDMapWithMove k v) where
115 (<>) = mappend
117-- |Helper data structure used for composing patches using the monoid instance.
118data Fixup k v a
119 = Fixup_Delete
120 | Fixup_Update (These (From k v a) (To k a))
122-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
123instance GCompare k => Monoid (PatchDMapWithMove k v) where
124 mempty = PatchDMapWithMove mempty
125 PatchDMapWithMove ma `mappend` 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
160-- |Project the @a@ from a @'These' a b@, identical to @preview '_Here'@ but without using preview
161getHere :: These a b -> Maybe a
162getHere = \case
163 This a -> Just a
164 These a _ -> Just a
165 That _ -> Nothing
167-- |Project the @b@ from a @'These' a b@, identical to @preview '_There'@ but without using preview
168getThere :: These a b -> Maybe b
169getThere = \case
170 This _ -> Nothing
171 These _ b -> Just b
172 That b -> Just b
174{-
175mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
176PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
177 where
178 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
179 removeRedundantDst toKey (From_Move fromKey) | isJust (toKey `geq` fromKey) = Nothing
180 removeRedundantDst _ a = Just a
181 f :: forall a. k a -> From k v a -> Maybe (From k v a)
182 f toKey _ = removeRedundantDst toKey $ case getDstAction toKey dstAfter of
183 From_Move fromKey -> getDstAction fromKey dstBefore
184 nonMove -> nonMove
185 dst = DMap.mapMaybeWithKey f $ DMap.union dstAfter dstBefore
186 getSrcAction k m = fromMaybe (ComposeMaybe $ Just k) $ DMap.lookup k m
187 removeRedundantSrc fromKey (ComposeMaybe (Just toKey)) | isJust (fromKey `geq` toKey) = Nothing
188 removeRedundantSrc _ a = Just a
189 g :: forall a. k a -> ComposeMaybe k a -> Maybe (ComposeMaybe k a)
190 g fromKey _ = removeRedundantSrc fromKey $ case getSrcAction fromKey srcBefore of
191 ComposeMaybe Nothing -> ComposeMaybe Nothing
192 ComposeMaybe (Just toKeyBefore) -> getSrcAction toKeyBefore srcAfter
193 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
194-}
196-- |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'.
197insertDMapKey :: k a -> v a -> PatchDMapWithMove k v
198insertDMapKey k v =
199 PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing)
201-- |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:
202--
203-- @
204-- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap))
205-- @
206moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
207moveDMapKey src dst = case src `geq` dst of
208 Nothing -> PatchDMapWithMove $ DMap.fromList
209 [ dst :=> NodeInfo (From_Move src) (ComposeMaybe Nothing)
210 , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst)
211 ]
212 Just _ -> mempty
214-- |Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
215--
216-- @
217-- let aMay = DMap.lookup a dmap
218-- bMay = DMap.lookup b dmap
219-- in maybe id (DMap.insert a) (bMay `mplus` aMay)
220-- . maybe id (DMap.insert b) (aMay `mplus` bMay)
221-- . DMap.delete a . DMap.delete b $ dmap
222-- @
223swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
224swapDMapKey src dst = case src `geq` dst of
225 Nothing -> PatchDMapWithMove $ DMap.fromList
226 [ dst :=> NodeInfo (From_Move src) (ComposeMaybe $ Just src)
227 , src :=> NodeInfo (From_Move dst) (ComposeMaybe $ Just dst)
228 ]
229 Just _ -> mempty
231-- |Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'DMap.delete'.
232deleteDMapKey :: k a -> PatchDMapWithMove k v
233deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete $ ComposeMaybe Nothing
235{-
236k1, k2 :: Const2 Int () ()
237k1 = Const2 1
238k2 = Const2 2
239p1, p2 :: PatchDMapWithMove (Const2 Int ()) Identity
240p1 = moveDMapKey k1 k2
241p2 = moveDMapKey k2 k1
242p12 = p1 <> p2
243p21 = p2 <> p1
244p12Slow = p1 `mappendPatchDMapWithMoveSlow` p2
245p21Slow = p2 `mappendPatchDMapWithMoveSlow` p1
247testPatchDMapWithMove = do
248 print p1
249 print p2
250 print $ p12 == deleteDMapKey k1
251 print $ p21 == deleteDMapKey k2
252 print $ p12Slow == deleteDMapKey k1
253 print $ p21Slow == deleteDMapKey k2
255dst (PatchDMapWithMove x _) = x
256src (PatchDMapWithMove _ x) = x
257-}
259-- |Extract the 'DMap' representing the patch changes from the 'PatchDMapWithMove'.
260unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)
261unPatchDMapWithMove (PatchDMapWithMove p) = p
263-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove', without checking any invariants.
264--
265-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchDMapWithMove' are preserved; they will not be checked.
266unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v
267unsafePatchDMapWithMove = PatchDMapWithMove
269-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while checking invariants. If the invariants are satisfied, @Right p@ is returned
270-- otherwise @Left errors@.
271patchDMapWithMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)
272patchDMapWithMove dm =
273 case validationErrorsForPatchDMapWithMove dm of
274 [] -> Right $ unsafePatchDMapWithMove dm
275 errs -> Left errs
277-- |Map a natural transform @v -> v'@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.
278mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'
279mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $
280 DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
281 where g :: forall a. From k v a -> From k v' a
282 g = \case
283 From_Insert v -> From_Insert $ f v
284 From_Delete -> From_Delete
285 From_Move k -> From_Move k
287-- |Traverse an effectful function @forall a. v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.
288traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
289traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
291-- |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')@.
292traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
293traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p
294 where g :: forall a. k a -> From k v a -> m (From k v' a)
295 g k = \case
296 From_Insert v -> From_Insert <$> f k v
297 From_Delete -> pure From_Delete
298 From_Move fromKey -> pure $ From_Move fromKey
300-- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over a @'NodeInfo' k v a@.
301nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a
302nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
304-- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'NodeInfo' k v a@.
305nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)
306nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
308-- |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
309-- values.
310weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'
311weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
312 where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) v'
313 g ni = MapWithMove.NodeInfo
314 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
315 From_Insert v -> MapWithMove.From_Insert $ f v
316 From_Delete -> MapWithMove.From_Delete
317 From_Move k -> MapWithMove.From_Move $ Some.This k
318 , MapWithMove._nodeInfo_to = Some.This <$> getComposeMaybe (_nodeInfo_to ni)
319 }
321-- |"Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k v'@. Weaken is in scare quotes because the 'Const2' has already disabled any
322-- dependency in the typing and all points are already @a@, hence the function to map each value to @v'@ is not higher rank.
323patchDMapWithMoveToPatchMapWithMoveWith :: forall k v v' a. (v a -> v') -> PatchDMapWithMove (Const2 k a) v -> PatchMapWithMove k v'
324patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
325 where g :: NodeInfo (Const2 k a) v a -> MapWithMove.NodeInfo k v'
326 g ni = MapWithMove.NodeInfo
327 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
328 From_Insert v -> MapWithMove.From_Insert $ f v
329 From_Delete -> MapWithMove.From_Delete
330 From_Move (Const2 k) -> MapWithMove.From_Move k
331 , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)
332 }
334-- |"Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove ('Const2' k a)@; that is, turn a non-dependently-typed patch into a dependently typed
335-- one but which always has a constant key type represented by 'Const2'. Apply the given function to each @v@ to produce a @v' a@.
336-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
337const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) v'
338const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
339 where g :: (k, MapWithMove.NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')
340 g (k, ni) = Const2 k :=> NodeInfo
341 { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of
342 MapWithMove.From_Insert v -> From_Insert $ f v
343 MapWithMove.From_Delete -> From_Delete
344 MapWithMove.From_Move fromKey -> From_Move $ Const2 fromKey
345 , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni
346 }
348instance GCompare k => Patch (PatchDMapWithMove k v) where
349 type PatchTarget (PatchDMapWithMove k v) = DMap k v
350 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?
351 where insertions = DMap.mapMaybeWithKey insertFunc p
352 insertFunc :: forall a. k a -> NodeInfo k v a -> Maybe (v a)
353 insertFunc _ ni = case _nodeInfo_from ni of
354 From_Insert v -> Just v
355 From_Move k -> DMap.lookup k old
356 From_Delete -> Nothing
357 deletions = DMap.mapMaybeWithKey deleteFunc p
358 deleteFunc :: forall a. k a -> NodeInfo k v a -> Maybe (Constant () a)
359 deleteFunc _ ni = case _nodeInfo_from ni of
360 From_Delete -> Just $ Constant ()
361 _ -> Nothing
363-- | Get the values that will be deleted or moved if the given patch is applied
364-- to the given 'DMap'.
365getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))
366getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
367 where f _ v ni = Pair v $ _nodeInfo_to ni