@@ -1,363 +0,0 @@
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 #-}
13−
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.
16−module Reflex.Patch.DMapWithMove where
17−
18−import Reflex.Patch.Class
19−import Reflex.Patch.MapWithMove (PatchMapWithMove (..))
20−import qualified Reflex.Patch.MapWithMove as MapWithMove
21−
22−import Data.Constraint.Extras
23−import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
24−import qualified Data.Dependent.Map as DMap
25−import Data.Functor.Constant
26−import Data.Functor.Misc
27−import Data.Functor.Product
28−import Data.GADT.Compare (GEq (..))
29−import Data.GADT.Show (GShow, gshow)
30−import qualified Data.Map as Map
31−import Data.Maybe
32−import Data.Semigroup (Semigroup (..), (<>))
33−import Data.Some (Some(Some))
34−import Data.These
35−
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)@)
43−newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
44−
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.
47−data 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)
54−
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@).
57−data 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)
66−
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.
69−type To = ComposeMaybe
70−
71−-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
72−validPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Bool
73−validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
74−
75−-- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.
76−validationErrorsForPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> [String]
77−validationErrorsForPatchDMapWithMove 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
101−
102− _ ->
103− Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
104− unbalancedMove _ = Nothing
105−
106−-- |Test whether two @'PatchDMapWithMove' k v@ contain the same patch operations.
107−instance (GEq k, Has' Eq k (NodeInfo k v)) => Eq (PatchDMapWithMove k v) where
108− PatchDMapWithMove a == PatchDMapWithMove b = a == b
109−
110−-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
111−data Pair1 f g a = Pair1 (f a) (g a)
112−
113−-- |Helper data structure used for composing patches using the monoid instance.
114−data Fixup k v a
115− = Fixup_Delete
116− | Fixup_Update (These (From k v a) (To k a))
117−
118−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
119−instance 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
164−
165−-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
166−instance GCompare k => Monoid (PatchDMapWithMove k v) where
167− mempty = PatchDMapWithMove mempty
168− mappend = (<>)
169−
170−{-
171−mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
172−PatchDMapWithMove 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−-}
191−
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'.
193−insertDMapKey :: k a -> v a -> PatchDMapWithMove k v
194−insertDMapKey k v =
195− PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing)
196−
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−-- @
202−moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
203−moveDMapKey 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
209−
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−-- @
219−swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
220−swapDMapKey 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
226−
227−-- |Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'DMap.delete'.
228−deleteDMapKey :: k a -> PatchDMapWithMove k v
229−deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete $ ComposeMaybe Nothing
230−
231−{-
232−k1, k2 :: Const2 Int () ()
233−k1 = Const2 1
234−k2 = Const2 2
235−p1, p2 :: PatchDMapWithMove (Const2 Int ()) Identity
236−p1 = moveDMapKey k1 k2
237−p2 = moveDMapKey k2 k1
238−p12 = p1 <> p2
239−p21 = p2 <> p1
240−p12Slow = p1 `mappendPatchDMapWithMoveSlow` p2
241−p21Slow = p2 `mappendPatchDMapWithMoveSlow` p1
242−
243−testPatchDMapWithMove = 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
250−
251−dst (PatchDMapWithMove x _) = x
252−src (PatchDMapWithMove _ x) = x
253−-}
254−
255−-- |Extract the 'DMap' representing the patch changes from the 'PatchDMapWithMove'.
256−unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)
257−unPatchDMapWithMove (PatchDMapWithMove p) = p
258−
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.
262−unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v
263−unsafePatchDMapWithMove = PatchDMapWithMove
264−
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@.
267−patchDMapWithMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)
268−patchDMapWithMove dm =
269− case validationErrorsForPatchDMapWithMove dm of
270− [] -> Right $ unsafePatchDMapWithMove dm
271− errs -> Left errs
272−
273−-- |Map a natural transform @v -> v'@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.
274−mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'
275−mapPatchDMapWithMove 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
282−
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')@.
284−traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
285−traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
286−
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')@.
288−traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
289−traversePatchDMapWithMoveWithKey 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
295−
296−-- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over a @'NodeInfo' k v a@.
297−nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a
298−nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
299−
300−-- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'NodeInfo' k v a@.
301−nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)
302−nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
303−
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.
306−weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'
307−weakenPatchDMapWithMoveWith 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− }
316−
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.
319−patchDMapWithMoveToPatchMapWithMoveWith :: forall k v v' a. (v a -> v') -> PatchDMapWithMove (Const2 k a) v -> PatchMapWithMove k v'
320−patchDMapWithMoveToPatchMapWithMoveWith 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− }
329−
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'
333−const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) v'
334−const2PatchDMapWithMoveWith 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− }
343−
344−-- | Apply the insertions, deletions, and moves to a given 'DMap'.
345−instance 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
359−
360−-- | Get the values that will be replaced, deleted, or moved if the given patch is applied to the given 'DMap'.
361−getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))
362−getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
363− where f _ v ni = Pair v $ _nodeInfo_to ni