PatchDMapWithMove: add insertDMapKey, swapDMapKey, fix PatchDMapWithMove validation, and add doc comments

Author: Ross MacLeod

src/Reflex/Patch/DMapWithMove.hs

@@ -10,6 +10,9 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
+
+-- |Module containing @'PatchDMapWithMove' k v@ and associated functions, which represents a 'Patch' to a @'DMap' k v@ which can insert, update, delete, and
+-- move values between keys.
 module Reflex.Patch.DMapWithMove where
 
 import Reflex.Patch.Class
@@ -23,6 +26,7 @@ import Data.Functor.Constant
 import Data.Functor.Misc
 import Data.Functor.Product
 import Data.GADT.Compare (GEq (..))
+import Data.GADT.Show (GShow, gshow)
 import qualified Data.Map as Map
 import Data.Maybe
 import Data.Semigroup (Semigroup (..), (<>))
@@ -36,15 +40,25 @@ import Data.GADT.Show (GShow (..))
 import Data.Typeable (Proxy (..))
 #endif
 
--- | Like 'PatchMapWithMove', but for 'DMap'.
+-- | 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
+-- destinations.
+--
+-- Invariants:
+--
+--     * A key should not move to itself.
+--     * A move should always be represented with both the destination key (as a 'From_Move') and the source key (as a @'ComposeMaybe' ('Just' destination)@)
 newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
 #ifdef EXPERIMENTAL_DEPENDENT_SUM_INSTANCES
   deriving (Show)
 #endif
 
+-- |Structure which represents what changes apply to a particular key. @_nodeInfo_from@ specifies what happens to this key, and in particular what other key
+-- the current key is moving from, while @_nodeInfo_to@ specifies what key the current key is moving to if involved in a move.
 data NodeInfo k v a = NodeInfo
   { _nodeInfo_from :: !(From k v a)
+  -- ^Change applying to the current key, be it an insert, move, or delete.
   , _nodeInfo_to :: !(To k a)
+  -- ^Where this key is moving to, if involved in a move. Should only be @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.
   }
   deriving (Show)
 
@@ -56,36 +70,73 @@ instance {-# INCOHERENT #-} (GEq k, EqTag k v) => EqTag k (From k v) where
   eqTagToEq k _ r = eqTagToEq k (Proxy :: Proxy v) (geqToEq k r)
 #endif
 
+-- |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
+-- key (@From_Delete@), or moving a key (@From_Move@).
 data From (k :: a -> *) (v :: a -> *) :: a -> * where
   From_Insert :: v a -> From k v a
+  -- ^Insert a new or update an existing key with the given value @v a@
   From_Delete :: From k v a
+  -- ^Delete the existing key
   From_Move :: !(k a) -> From k v a
+  -- ^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@,
+  -- usually but not necessarily with @From_Delete@.
   deriving (Show, Read, Eq, Ord)
 
+-- |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
+-- operation.
 type To = ComposeMaybe
 
-validPatchDMapWithMove :: forall k v. (GCompare k, EqTag k (ComposeMaybe k)) => PatchDMapWithMove k v -> Bool
-validPatchDMapWithMove (PatchDMapWithMove m) = src == srcFromDst
+-- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
+validPatchDMapWithMove :: forall k v. (GCompare k, GEq k, GShow k) => DMap k (NodeInfo k v) -> Bool
+validPatchDMapWithMove = not . null . validPatchDMapWithMove'
+
+-- |Test whether a 'PatchDMapWithMove' satisfies its invariants and give reasons why it doesn't.
+validPatchDMapWithMove' :: forall k v. (GCompare k, GEq k, GShow k) => DMap k (NodeInfo k v) -> [String]
+validPatchDMapWithMove' m =
+  noSelfMoves `mappend` movesBalanced
   where
-    src = DMap.map _nodeInfo_to m
-    dst = DMap.map _nodeInfo_from m
-    srcFromDst :: DMap k (ComposeMaybe k)
-    srcFromDst = DMap.fromList $ flip fmap (DMap.toList dst) $ \(to :=> edit) -> case edit of
-      From_Move from -> from :=> ComposeMaybe (Just to)
-      _ -> to :=> ComposeMaybe Nothing
+    noSelfMoves = catMaybes . map selfMove . DMap.toAscList $ m
+    selfMove (dst :=> NodeInfo (From_Move src) _)           | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"
+    selfMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
+    selfMove _ = Nothing
+    movesBalanced = catMaybes . map unbalancedMove . DMap.toAscList $ m
+    unbalancedMove (dst :=> NodeInfo (From_Move src) _) =
+      case DMap.lookup src m of
+        Nothing -> Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key is not in the patch"
+        Just (NodeInfo _ (ComposeMaybe (Just dst'))) ->
+          if isNothing (dst' `geq` dst)
+            then Just $ "unbalanced move at destination key " <> gshow dst <> " from " <> gshow src <> " is going to " <> gshow dst' <> " instead"
+            else Nothing
+        _ ->
+          Just $ "unbalanced move at destination key " <> gshow dst <> " supposedly from " <> gshow src <> " but source key has no move to key"
+    unbalancedMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) =
+      case DMap.lookup dst m of
+        Nothing -> Just $ " unbalancved move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"
+        Just (NodeInfo (From_Move src') _) ->
+          if isNothing (src' `geq` src)
+            then Just $ "unbalanced move at source key " <> gshow src <> " to " <> gshow dst <> " is coming from " <> gshow src' <> " instead"
+            else Nothing
+
+        _ ->
+          Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
+    unbalancedMove _ = Nothing
 
 instance EqTag k (NodeInfo k v) => Eq (PatchDMapWithMove k v) where
   PatchDMapWithMove a == PatchDMapWithMove b = a == b
 
+-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
 data Pair1 f g a = Pair1 (f a) (g a)
 
+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
 instance GCompare k => Semigroup (PatchDMapWithMove k v) where
   (<>) = mappend
 
+-- |Helper data structure used for composing patches using the monoid instance.
 data Fixup k v a
    = Fixup_Delete
    | Fixup_Update (These (From k v a) (To k a))
 
+-- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
 instance GCompare k => Monoid (PatchDMapWithMove k v) where
   mempty = PatchDMapWithMove mempty
   PatchDMapWithMove ma `mappend` PatchDMapWithMove mb = PatchDMapWithMove m
@@ -123,12 +174,14 @@ instance GCompare k => Monoid (PatchDMapWithMove k v) where
           }
       m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups
 
+-- |Project the @a@ from a @'These' a b@, identical to @preview '_Here'@ but without using preview
 getHere :: These a b -> Maybe a
 getHere = \case
   This a -> Just a
   These a _ -> Just a
   That _ -> Nothing
 
+-- |Project the @b@ from a @'These' a b@, identical to @preview '_There'@ but without using preview
 getThere :: These a b -> Maybe b
 getThere = \case
   This _ -> Nothing
@@ -157,6 +210,16 @@ PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWith
     src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
 -}
 
+-- |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'.
+insertDMapKey :: k a -> v a -> PatchDMapWithMove k v
+insertDMapKey k v =
+  PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing)
+
+-- |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:
+--
+-- @
+--     'DMap.delete' src (maybe dmap ('DMap.insert' dst) (DMap.lookup src dmap))
+-- @
 moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
 moveDMapKey src dst = case src `geq` dst of
   Nothing -> PatchDMapWithMove $ DMap.fromList
@@ -165,6 +228,24 @@ moveDMapKey src dst = case src `geq` dst of
     ]
   Just _ -> mempty
 
+-- |Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
+--
+-- @
+--     let aMay = DMap.lookup a dmap
+--         bMay = DMap.lookup b dmap
+--     in maybe id (DMap.insert a) (bMay `mplus` aMay)
+--      . maybe id (DMap.insert b) (aMay `mplus` bMay)
+--      . DMap.delete a . DMap.delete b $ dmap
+-- @
+swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
+swapDMapKey src dst = case src `geq` dst of
+  Nothing -> PatchDMapWithMove $ DMap.fromList
+    [ dst :=> NodeInfo (From_Move src) (ComposeMaybe $ Just src)
+    , src :=> NodeInfo (From_Move dst) (ComposeMaybe $ Just dst)
+    ]
+  Just _ -> mempty
+
+-- |Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'DMap.delete'.
 deleteDMapKey :: k a -> PatchDMapWithMove k v
 deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete $ ComposeMaybe Nothing
 
@@ -192,14 +273,25 @@ dst (PatchDMapWithMove x _) = x
 src (PatchDMapWithMove _ x) = x
 -}
 
+-- |Extract the 'DMap' representing the patch changes from the 'PatchDMapWithMove'.
 unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)
 unPatchDMapWithMove (PatchDMapWithMove p) = p
 
--- | Warning: when using this function, you must ensure that the invariants of
--- 'PatchDMapWithMove' are preserved; they will not be checked.
+-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove', without checking any invariants.
+--
+-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchDMapWithMove' are preserved; they will not be checked.
 unsafePatchDMapWithMove :: DMap k (NodeInfo k v) -> PatchDMapWithMove k v
 unsafePatchDMapWithMove = PatchDMapWithMove
 
+-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while checking invariants. If the invariants are satisfied, @Right p@ is returned
+-- otherwise @Left errors@.
+patchDMapWithMove :: (GCompare k, GEq k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)
+patchDMapWithMove dm =
+  case validPatchDMapWithMove' dm of
+    [] -> Right $ unsafePatchDMapWithMove dm
+    errs -> Left errs
+
+-- |Map a natural transform @v -> v'@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.
 mapPatchDMapWithMove :: forall k v v'. (forall a. v a -> v' a) -> PatchDMapWithMove k v -> PatchDMapWithMove k v'
 mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $
   DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
@@ -209,9 +301,11 @@ mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $
           From_Delete -> From_Delete
           From_Move k -> From_Move k
 
+-- |Traverse an effectful function @forall a. v a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.
 traversePatchDMapWithMove :: forall m k v v'. Applicative m => (forall a. v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
 traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
 
+-- |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')@.
 traversePatchDMapWithMoveWithKey :: forall m k v v'. Applicative m => (forall a. k a -> v a -> m (v' a)) -> PatchDMapWithMove k v -> m (PatchDMapWithMove k v')
 traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p
   where g :: forall a. k a -> From k v a -> m (From k v' a)
@@ -220,12 +314,16 @@ traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) = PatchDMapWithMove <$>
           From_Delete -> pure From_Delete
           From_Move fromKey -> pure $ From_Move fromKey
 
+-- |Map a function which transforms @'From' k v a@ into a @'From' k v' a@ over a @'NodeInfo' k v a@.
 nodeInfoMapFrom :: (From k v a -> From k v' a) -> NodeInfo k v a -> NodeInfo k v' a
 nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
 
+-- |Map an effectful function which transforms @'From' k v a@ into a @f ('From' k v' a)@ over a @'NodeInfo' k v a@.
 nodeInfoMapFromM :: Functor f => (From k v a -> f (From k v' a)) -> NodeInfo k v a -> f (NodeInfo k v' a)
 nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
 
+-- |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
+-- values.
 weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) v'
 weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
   where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) v'
@@ -237,9 +335,11 @@ weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenD
           , MapWithMove._nodeInfo_to = Some.This <$> getComposeMaybe (_nodeInfo_to ni)
           }
 
-patchDMapWithMoveToPatchMapWithMoveWith :: forall k f v v'. (f v -> v') -> PatchDMapWithMove (Const2 k v) f -> PatchMapWithMove k v'
+-- |"Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k v'@. Weaken is in scare quotes because the 'Const2' has already disabled any
+-- dependency in the typing and all points are already @a@, hence the function to map each value to @v'@ is not higher rank.
+patchDMapWithMoveToPatchMapWithMoveWith :: forall k v v' a. (v a -> v') -> PatchDMapWithMove (Const2 k a) v -> PatchMapWithMove k v'
 patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
-  where g :: NodeInfo (Const2 k v) f v -> MapWithMove.NodeInfo k v'
+  where g :: NodeInfo (Const2 k a) v a -> MapWithMove.NodeInfo k v'
         g ni = MapWithMove.NodeInfo
           { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
               From_Insert v -> MapWithMove.From_Insert $ f v
@@ -248,9 +348,12 @@ patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMo
           , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)
           }
 
-const2PatchDMapWithMoveWith :: forall k v f a. (v -> f a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) f
+-- |"Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove ('Const2' k a)@; that is, turn a non-dependently-typed patch into a dependently typed
+-- one but which always has a constant key type represented by 'Const2'. Apply the given function to each @v@ to produce a @v' a@.
+-- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
+const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k v -> PatchDMapWithMove (Const2 k a) v'
 const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
-  where g :: (k, MapWithMove.NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) f)
+  where g :: (k, MapWithMove.NodeInfo k v) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')
         g (k, ni) = Const2 k :=> NodeInfo
           { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of
               MapWithMove.From_Insert v -> From_Insert $ f v