@@ -10,6 +10,9 @@
1010{-# LANGUAGE ScopedTypeVariables #-}
1111{-# LANGUAGE TypeFamilies #-}
1212{-# 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.
1316module Reflex.Patch.DMapWithMove where
1417
1518import Reflex.Patch.Class
@@ -23,6 +26,7 @@ import Data.Functor.Constant
2326import Data.Functor.Misc
2427import Data.Functor.Product
2528import Data.GADT.Compare (GEq (..))
29+import Data.GADT.Show (GShow, gshow)
2630import qualified Data.Map as Map
2731import Data.Maybe
2832import Data.Semigroup (Semigroup (..), (<>))
@@ -36,15 +40,25 @@ import Data.GADT.Show (GShow (..))
3640import Data.Typeable (Proxy (..))
3741#endif
3842
39−-- | Like 'PatchMapWithMove', but for 'DMap'.
43+-- | 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
44+-- destinations.
45+--
46+-- Invariants:
47+--
48+-- * A key should not move to itself.
49+-- * A move should always be represented with both the destination key (as a 'From_Move') and the source key (as a @'ComposeMaybe' ('Just' destination)@)
4050newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
4151#ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
4252 deriving (Show)
4353#endif
4454
55+-- |Structure which represents what changes apply to a particular key. @_nodeInfo_from@ specifies what happens to this key, and in particular what other key
56+-- the current key is moving from, while @_nodeInfo_to@ specifies what key the current key is moving to if involved in a move.
4557data NodeInfo k v a = NodeInfo
4658 { _nodeInfo_from :: !(From k v a)
59+ -- ^Change applying to the current key, be it an insert, move, or delete.
4760 , _nodeInfo_to :: !(To k a)
61+ -- ^Where this key is moving to, if involved in a move. Should only be @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.
4862 }
4963 deriving (Show)
5064
@@ -56,36 +70,73 @@ instance {-# INCOHERENT #-} (GEq k, EqTag k v) => EqTag k (From k v) where
5670 eqTagToEq k _ r = eqTagToEq k (Proxy :: Proxy v) (geqToEq k r)
5771#endif
5872
73+-- |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
74+-- key (@From_Delete@), or moving a key (@From_Move@).
5975data From (k :: a -> *) (v :: a -> *) :: a -> * where
6076 From_Insert :: v a -> From k v a
77+ -- ^Insert a new or update an existing key with the given value @v a@
6178 From_Delete :: From k v a
79+ -- ^Delete the existing key
6280 From_Move :: !(k a) -> From k v a
81+ -- ^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@,
82+ -- usually but not necessarily with @From_Delete@.
6383 deriving (Show, Read, Eq, Ord)
6484
85+-- |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
86+-- operation.
6587type To = ComposeMaybe
6688
67−validPatchDMapWithMove :: forall k v. (GCompare k, EqTag k (ComposeMaybe k)) => PatchDMapWithMove k v -> Bool
68−validPatchDMapWithMove (PatchDMapWithMove m) = src == srcFromDst
89+-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
90+validPatchDMapWithMove :: forall k v. (GCompare k, GEq k, GShow k) => DMap k (NodeInfo k v) -> Bool
91+validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
92+
93+-- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.
94+validationErrorsForPatchDMapWithMove :: forall k v. (GCompare k, GEq k, GShow k) => DMap k (NodeInfo k v) -> [String]
95+validationErrorsForPatchDMapWithMove m =
96+ noSelfMoves `mappend` movesBalanced
6997 where
70− src = DMap.map _nodeInfo_to m
71− dst = DMap.map _nodeInfo_from m
72− srcFromDst :: DMap k (ComposeMaybe k)
73− srcFromDst = DMap.fromList $ flip fmap (DMap.toList dst) $ \(to :=> edit) -> case edit of
74− From_Move from -> from :=> ComposeMaybe (Just to)
75− _ -> to :=> ComposeMaybe Nothing
98+ noSelfMoves = catMaybes . map selfMove . DMap.toAscList $ m
99+ selfMove (dst :=> NodeInfo (From_Move src) _) | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"
100+ selfMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
101+ selfMove _ = Nothing
102+ movesBalanced = catMaybes . map unbalancedMove . DMap.toAscList $ m
103+ unbalancedMove (dst :=> NodeInfo (From_Move src) _) =
104+ case DMap.lookup src m of
105+ Nothing -> Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key is not in the patch"
106+ Just (NodeInfo _ (ComposeMaybe (Just dst'))) ->
107+ if isNothing (dst' `geq` dst)
108+ then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead"
109+ else Nothing
110+ _ ->
111+ Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key has no move to key"
112+ unbalancedMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) =
113+ case DMap.lookup dst m of
114+ Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"
115+ Just (NodeInfo (From_Move src') _) ->
116+ if isNothing (src' `geq` src)
117+ then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead"
118+ else Nothing
119+
120+ _ ->
121+ Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
122+ unbalancedMove _ = Nothing
76123
77124instance EqTag k (NodeInfo k v) => Eq (PatchDMapWithMove k v) where
78125 PatchDMapWithMove a == PatchDMapWithMove b = a == b
79126
127+-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
80128data Pair1 f g a = Pair1 (f a) (g a)
81129
130+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
82131instance GCompare k => Semigroup (PatchDMapWithMove k v) where
83132 (<>) = mappend
84133
134+-- |Helper data structure used for composing patches using the monoid instance.
85135data Fixup k v a
86136 = Fixup_Delete
87137 | Fixup_Update (These (From k v a) (To k a))
88138
139+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
89140instance GCompare k => Monoid (PatchDMapWithMove k v) where
90141 mempty = PatchDMapWithMove mempty
91142 PatchDMapWithMove ma `mappend` PatchDMapWithMove mb = PatchDMapWithMove m
@@ -123,12 +174,14 @@ instance GCompare k => Monoid (PatchDMapWithMove k v) where
123174 }
124175 m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups
125176
177+-- |Project the @a@ from a @'These' a b@, identical to @preview '_Here'@ but without using preview
126178getHere :: These a b -> Maybe a
127179getHere = \case
128180 This a -> Just a
129181 These a _ -> Just a
130182 That _ -> Nothing
131183
184+-- |Project the @b@ from a @'These' a b@, identical to @preview '_There'@ but without using preview
132185getThere :: These a b -> Maybe b
133186getThere = \case
134187 This _ -> Nothing
@@ -157,6 +210,16 @@ PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWith
157210 src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
158211-}
159212
213+-- |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'.
214+insertDMapKey :: k a -> v a -> PatchDMapWithMove k v
215+insertDMapKey k v =
216+ PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing)
217+
218+-- |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:
219+--
220+-- @
221+-- 'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap))
222+-- @
160223moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
161224moveDMapKey src dst = case src `geq` dst of
162225 Nothing -> PatchDMapWithMove $ DMap.fromList
@@ -165,6 +228,24 @@ moveDMapKey src dst = case src `geq` dst of
165228 ]
166229 Just _ -> mempty
167230
231+-- |Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
232+--
233+-- @
234+-- let aMay = DMap.lookup a dmap
235+-- bMay = DMap.lookup b dmap
236+-- in maybe id (DMap.insert a) (bMay `mplus` aMay)
237+-- . maybe id (DMap.insert b) (aMay `mplus` bMay)
238+-- . DMap.delete a . DMap.delete b $ dmap
239+-- @
240+swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
241+swapDMapKey src dst = case src `geq` dst of
242+ Nothing -> PatchDMapWithMove $ DMap.fromList
243+ [ dst :=> NodeInfo (From_Move src) (ComposeMaybe $ Just src)
244+ , src :=> NodeInfo (From_Move dst) (ComposeMaybe $ Just dst)
245+ ]
246+ Just _ -> mempty
247+
248+-- |Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'DMap.delete'.
168249deleteDMapKey :: k a -> PatchDMapWithMove k v
169250deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete $ ComposeMaybe Nothing
170251
@@ -192,14 +273,25 @@ dst (PatchDMapWithMove x _) = x
192273src (PatchDMapWithMove _ x) = x
193274-}
194275
276+-- |Extract the 'DMap' representing the patch changes from the 'PatchDMapWithMove'.
195277unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)
196278unPatchDMapWithMove (PatchDMapWithMove p) = p
197279
198−-- | Warning: when using this function, you must ensure that the invariants of
199−-- 'PatchDMapWithMove' are preserved; they will not be checked.
280+-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove', without checking any invariants.
281+--
282+-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchDMapWithMove' are preserved; they will not be checked.
200283unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v
201284unsafePatchDMapWithMove = PatchDMapWithMove
202285
286+-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while checking invariants. If the invariants are satisfied, @Right p@ is returned
287+-- otherwise @Left errors@.
288+patchDMapWithMove :: (GCompare k, GEq k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)
289+patchDMapWithMove dm =
290+ case validationErrorsForPatchDMapWithMove dm of
291+ [] -> Right $ unsafePatchDMapWithMove dm
292+ errs -> Left errs
293+
294+-- |Map a natural transform @v -> v'@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.
203295mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'
204296mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $
205297 DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
@@ -209,9 +301,11 @@ mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $
209301 From_Delete -> From_Delete
210302 From_Move k -> From_Move k
211303
304+-- |Traverse an effectful function @forall a. v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.
212305traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
213306traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
214307
308+-- |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')@.
215309traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
216310traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p
217311 where g :: forall a. k a -> From k v a -> m (From k v' a)
@@ -220,12 +314,16 @@ traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$>
220314 From_Delete -> pure From_Delete
221315 From_Move fromKey -> pure $ From_Move fromKey
222316
317+-- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over a @'NodeInfo' k v a@.
223318nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a
224319nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
225320
321+-- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'NodeInfo' k v a@.
226322nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)
227323nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
228324
325+-- |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
326+-- values.
229327weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'
230328weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
231329 where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) v'
@@ -237,9 +335,11 @@ weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenD
237335 , MapWithMove._nodeInfo_to = Some.This <$> getComposeMaybe (_nodeInfo_to ni)
238336 }
239337
240−patchDMapWithMoveToPatchMapWithMoveWith :: forall k f v v'. (f v -> v') -> PatchDMapWithMove (Const2 k v) f -> PatchMapWithMove k v'
338+-- |"Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k v'@. Weaken is in scare quotes because the 'Const2' has already disabled any
339+-- dependency in the typing and all points are already @a@, hence the function to map each value to @v'@ is not higher rank.
340+patchDMapWithMoveToPatchMapWithMoveWith :: forall k v v' a. (v a -> v') -> PatchDMapWithMove (Const2 k a) v -> PatchMapWithMove k v'
241341patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
242− where g :: NodeInfo (Const2 k v) f v -> MapWithMove.NodeInfo k v'
342+ where g :: NodeInfo (Const2 k a) v a -> MapWithMove.NodeInfo k v'
243343 g ni = MapWithMove.NodeInfo
244344 { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
245345 From_Insert v -> MapWithMove.From_Insert $ f v
@@ -248,9 +348,12 @@ patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMo
248348 , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)
249349 }
250350
251−const2PatchDMapWithMoveWith :: forall k v f a. (v -> f a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) f
351+-- |"Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove ('Const2' k a)@; that is, turn a non-dependently-typed patch into a dependently typed
352+-- one but which always has a constant key type represented by 'Const2'. Apply the given function to each @v@ to produce a @v' a@.
353+-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
354+const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) v'
252355const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
253− where g :: (k, MapWithMove.NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) f)
356+ where g :: (k, MapWithMove.NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')
254357 g (k, ni) = Const2 k :=> NodeInfo
255358 { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of
256359 MapWithMove.From_Insert v -> From_Insert $ f v