WIP: Combination of #1 and #2

ChangeLog.md

@@ -1,5 +1,11 @@
 # Revision history for patch
 
+## Unreleased
+
+* `PatchMapWithMove` supports moves with a patch.
+
+* `PatchDMapWithMove` supports moves with a patch.
+
 ## 0.0.7.0 - 2022-06-23
 
 * Use `commutative-semigroups` for `Commutative`, making `Additive` a

patch.cabal

@@ -48,12 +48,15 @@ library
   if impl(ghc < 8.6) -- really, if base < 8.12
     build-depends: base-orphans >= 0.8 && < 0.9
 
-  exposed-modules: Data.Functor.Misc
+  exposed-modules: Control.Category.DecidablyEmpty
+                 , Data.Functor.Misc
                  , Data.Monoid.DecidablyEmpty
                  , Data.Patch
                  , Data.Patch.Class
                  , Data.Patch.DMap
                  , Data.Patch.DMapWithMove
+                 , Data.Patch.DMapWithPatchingMove
+                 , Data.Patch.DMapWithPatchingMove.By
                  , Data.Patch.IntMap
                  , Data.Patch.Map
                  , Data.Patch.MapWithMove
@@ -66,6 +69,7 @@ library
 
   if flag(split-these)
     build-depends: these >= 1 && <1.2
+                 , these-lens >= 1 && <1.1
                  , semialign >=1 && <1.3
                  , monoidal-containers >= 0.6 && < 0.7
   else

src/Control/Category/DecidablyEmpty.hs

@@ -0,0 +1,9 @@
+{-# LANGUAGE TypeOperators #-}
+-- TODO upstream somwhere else?
+module Control.Category.DecidablyEmpty where
+
+import Control.Category
+import Data.Type.Equality
+
+class Category c => DecidablyEmpty c where
+  isId :: c a b -> Maybe (a :~: b)

src/Data/Functor/Misc.hs

@@ -1,6 +1,6 @@
 {-# LANGUAGE CPP #-}
 {-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE DeriveFunctor #-}
+{-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
@@ -21,6 +21,7 @@ are relevant to the use of 'Functor'-based datastructures like
 module Data.Functor.Misc
   ( -- * Const2
     Const2 (..)
+  , First2 (..)
   , unConst2
   , dmapToMap
   , dmapToIntMap
@@ -52,6 +53,7 @@ import qualified Data.IntMap as IntMap
 import Data.Kind (Type)
 import Data.Map (Map)
 import qualified Data.Map as Map
+import qualified Data.Semigroupoid as Cat
 import Data.Some (Some, mkSome)
 import Data.These
 import Data.Type.Equality ((:~:)(Refl))
@@ -68,15 +70,15 @@ data Const2 :: Type -> x -> x -> Type where
   Const2 :: k -> Const2 k v v
   deriving (Typeable)
 
--- | Extract the value from a Const2
-unConst2 :: Const2 k v v' -> k
-unConst2 (Const2 k) = k
-
 deriving instance Eq k => Eq (Const2 k v v')
 deriving instance Ord k => Ord (Const2 k v v')
 deriving instance Show k => Show (Const2 k v v')
 deriving instance Read k => Read (Const2 k v v)
 
+-- | Extract the value from a Const2
+unConst2 :: Const2 k v v' -> k
+unConst2 (Const2 k) = k
+
 instance Show k => GShow (Const2 k v) where
   gshowsPrec n x@(Const2 _) = showsPrec n x
 
@@ -92,6 +94,14 @@ instance Ord k => GCompare (Const2 k v) where
     EQ -> GEQ
     GT -> GGT
 
+newtype First2 (t :: k -> Type) (a :: k) (b :: k) = First2 (t b)
+  deriving ( Show, Read, Eq, Ord
+           , Functor, Foldable, Traversable
+           )
+
+instance Cat.Semigroupoid (First2 x) where
+  First2 x `o` ~(First2 _) = First2 x
+
 -- | Convert a 'DMap' to a regular 'Map'
 dmapToMap :: DMap (Const2 k v) Identity -> Map k v
 dmapToMap = Map.fromDistinctAscList . map (\(Const2 k :=> Identity v) -> (k, v)) . DMap.toAscList

src/Data/Patch.hs

@@ -33,6 +33,12 @@ import Data.Patch.DMapWithMove as X
   , traversePatchDMapWithMoveWithKey, unPatchDMapWithMove
   , unsafePatchDMapWithMove, weakenPatchDMapWithMoveWith
   )
+import Data.Patch.DMapWithPatchingMove as X
+  ( PatchDMapWithPatchingMove, const2PatchDMapWithPatchingMoveWith, mapPatchDMapWithPatchingMove
+  , patchDMapWithPatchingMoveToPatchMapWithPatchingMoveWith
+  , traversePatchDMapWithPatchingMoveWithKey, unPatchDMapWithPatchingMove
+  , unsafePatchDMapWithPatchingMove, weakenPatchDMapWithPatchingMoveWith
+  )
 import Data.Patch.IntMap as X hiding (getDeletions)
 import Data.Patch.Map as X
 import Data.Patch.MapWithMove as X
@@ -50,17 +56,19 @@ class (Semigroup q, Monoid q) => Group q where
 -- | The elements of an 'Commutative' 'Semigroup' can be considered as patches of their own type.
 newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }
 
-instance Commutative p => Patch (AdditivePatch p) where
+instance Commutative p => PatchHet (AdditivePatch p) where
+  type PatchSource (AdditivePatch p) = p
   type PatchTarget (AdditivePatch p) = p
+instance Commutative p => Patch (AdditivePatch p) where
   apply (AdditivePatch p) q = Just $ p <> q
 
 instance (Ord k, Group q) => Group (MonoidalMap k q) where
   negateG = fmap negateG
 
 -- | Trivial group.
 instance Group () where
-  negateG _ = ()
-  _ ~~ _ = ()
+  negateG ~() = ()
+  ~() ~~ ~() = ()
 
 -- | Product group.  A Pair of groups gives rise to a group
 instance (Group a, Group b) => Group (a, b) where
@@ -81,8 +89,8 @@ instance (Group (f a), Group (g a)) => Group ((f :*: g) a) where
 
 -- | Trivial group, Functor style
 instance Group (Proxy x) where
-  negateG _ = Proxy
-  _ ~~ _ = Proxy
+  negateG ~Proxy = Proxy
+  ~Proxy ~~ ~Proxy = Proxy
 
 -- | Const lifts groups into a functor.
 deriving instance Group a => Group (Const a x)

src/Data/Patch/Class.hs

@@ -1,6 +1,15 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE StandaloneDeriving #-}
 
 {-|
 Description: The module provides the 'Patch' class.
@@ -9,20 +18,49 @@ This is a class for types which represent changes made to other types
 -}
 module Data.Patch.Class where
 
+import qualified Data.Semigroupoid as Cat
+import qualified Control.Category as Cat
 import Data.Functor.Identity
+import Data.Functor.Misc
 import Data.Kind (Type)
 import Data.Maybe
 #if !MIN_VERSION_base(4,11,0)
 import Data.Semigroup (Semigroup(..))
 #endif
 import Data.Proxy
+import Data.Typeable
+
+class PatchHet p where
+  type PatchSource p :: Type
+  type PatchTarget p :: Type
+  -- | Apply the patch @p a@ to the value @a@.  If no change is needed, return
+  -- 'Nothing'.
+  applyHet
+    :: p
+    -> PatchSource p
+    -> Either (PatchSource p :~: PatchTarget p) (PatchTarget p)
+  default applyHet
+    :: Patch p
+    => p
+    -> PatchSource p
+    -> Either (PatchSource p :~: PatchTarget p) (PatchTarget p)
+  applyHet p a = case apply p a of
+    Nothing -> Left Refl
+    Just a' -> Right a'
+
+-- | Apply a 'PatchHet'; if it does nothing, return the original value
+applyAlwaysHet :: PatchHet p => p -> PatchSource p -> PatchTarget p
+applyAlwaysHet p t = case applyHet p t of
+  Left Refl -> t
+  Right t' -> t'
 
 -- | A 'Patch' type represents a kind of change made to a datastructure.
 --
 -- If an instance of 'Patch' is also an instance of 'Semigroup', it should obey
 -- the law that @applyAlways (f <> g) == applyAlways f . applyAlways g@.
-class Patch p where
-  type PatchTarget p :: Type
+class ( PatchHet p
+      , PatchSource p ~ PatchTarget p
+      ) => Patch p where
   -- | Apply the patch @p a@ to the value @a@.  If no change is needed, return
   -- 'Nothing'.
   apply :: p -> PatchTarget p -> Maybe (PatchTarget p)
@@ -32,19 +70,123 @@ applyAlways :: Patch p => p -> PatchTarget p -> PatchTarget p
 applyAlways p t = fromMaybe t $ apply p t
 
 -- | 'Identity' can be used as a 'Patch' that always fully replaces the value
-instance Patch (Identity a) where
+instance PatchHet (Identity a) where
+  type PatchSource (Identity a) = a
   type PatchTarget (Identity a) = a
+instance Patch (Identity a) where
   apply (Identity a) _ = Just a
 
 -- | 'Proxy' can be used as a 'Patch' that does nothing.
-instance forall (a :: Type). Patch (Proxy a) where
+instance forall (a :: Type). PatchHet (Proxy a) where
+  type PatchSource (Proxy a) = a
   type PatchTarget (Proxy a) = a
+instance forall (a :: Type). Patch (Proxy a) where
   apply ~Proxy _ = Nothing
 
 -- | Like '(.)', but composes functions that return patches rather than
 -- functions that return new values.  The Semigroup instance for patches must
 -- apply patches right-to-left, like '(.)'.
-composePatchFunctions :: (Patch p, Semigroup p) => (PatchTarget p -> p) -> (PatchTarget p -> p) -> PatchTarget p -> p
+composePatchFunctions
+  :: (Patch p, Semigroup p)
+  => (PatchTarget p -> p)
+  -> (PatchTarget p -> p)
+  -> PatchTarget p -> p
 composePatchFunctions g f a =
   let fp = f a
   in g (applyAlways fp a) <> fp
+
+
+class PatchHet2Base (p :: k -> k -> Type) where
+  type PatchSource1 p :: k -> Type
+  type PatchTarget1 p :: k -> Type
+
+class ( PatchHet2Base p
+      , PatchHet (p from to)
+      , PatchSource1 p from ~ PatchSource (p from to)
+      , PatchTarget1 p to ~ PatchTarget (p from to)
+      ) => PatchHet2Locally (p :: k -> k -> Type) from to where
+instance ( PatchHet2Base p
+         , PatchHet (p from to)
+         , PatchSource1 p from ~ PatchSource (p from to)
+         , PatchTarget1 p to ~ PatchTarget (p from to)
+         ) => PatchHet2Locally (p :: k -> k -> Type) from to where
+
+applyHet2Locally
+  :: PatchHet2Locally p from to
+  => p from to
+  -> PatchSource1 p from
+  -> Either (PatchSource1 p from :~: PatchTarget1 p to) (PatchTarget1 p to)
+applyHet2Locally = applyHet
+
+applyAlwaysHet2Locally
+  :: PatchHet2Locally p from to
+  => p from to
+  -> PatchSource1 p from
+  -> PatchTarget1 p to
+applyAlwaysHet2Locally = applyAlwaysHet
+
+-- TODO once we can use quantified constraints, perhaps combine PatchHet2Base and
+-- PatchHet2Locally, or at least get rid of this.
+class PatchHet2Base p => PatchHet2 (p :: k -> k -> Type) where
+  applyHet2
+    :: p from to
+    -> PatchSource1 p from
+    -> Either (PatchSource1 p from :~: PatchTarget1 p to) (PatchTarget1 p to)
+
+applyAlwaysHet2
+  :: PatchHet2 p
+  => p from to
+  -> PatchSource1 p from
+  -> PatchTarget1 p to
+applyAlwaysHet2 p t = case applyHet2 p t of
+  Left Refl -> t
+  Right t' -> t'
+
+-- | Connect the classes without quanitified constraints
+newtype ProjectLocal p from to = ProjectLocal { unProjectLocal :: p from to }
+  deriving newtype Cat.Semigroupoid
+
+instance PatchHet2 p => PatchHet (ProjectLocal p from to) where
+  type PatchSource (ProjectLocal p from to) = PatchSource1 p from
+  type PatchTarget (ProjectLocal p from to) = PatchTarget1 p to
+  applyHet (ProjectLocal p) = applyHet2 p
+
+instance PatchHet2 p => PatchHet2Base (ProjectLocal p) where
+  type PatchSource1 (ProjectLocal p) = PatchSource1 p
+  type PatchTarget1 (ProjectLocal p) = PatchTarget1 p
+
+class ( PatchHet2Base p
+      , PatchSource1 p ~ PatchTarget1 p
+      ) => Patch2 p
+instance ( PatchHet2Base p
+         , PatchSource1 p ~ PatchTarget1 p
+         ) => Patch2 p
+
+-- | 'First2' can be used as a 'Patch' that always fully replaces the value
+instance PatchHet (First2 (t :: k -> Type) (from :: k) (to :: k)) where
+  type PatchSource (First2 t from to) = t from
+  type PatchTarget (First2 t from to) = t to
+  applyHet (First2 val) _ = Right val
+
+data IndexedEq :: (k -> Type) -> k -> k -> Type where
+  IndexedRefl :: IndexedEq k x x
+  deriving (Typeable)
+
+deriving instance Eq (IndexedEq k x y)
+deriving instance Ord (IndexedEq k x y)
+deriving instance Show (IndexedEq k x y)
+deriving instance Read (IndexedEq k x x)
+
+instance Cat.Category (IndexedEq x) where
+  id = IndexedRefl
+  IndexedRefl . IndexedRefl = IndexedRefl
+
+-- | 'IndexedEq' can be used as a 'Patch' that always does nothing
+instance PatchHet (IndexedEq (t :: k -> Type) (a :: k) (b :: k)) where
+  type PatchSource (IndexedEq t a b) = t a
+  type PatchTarget (IndexedEq t a b) = t b
+  applyHet IndexedRefl _ = Left Refl
+
+instance PatchHet2Base (IndexedEq (t :: k -> Type) :: k -> k -> Type) where
+  type PatchSource1 (IndexedEq t) = t
+  type PatchTarget1 (IndexedEq t) = t

src/Data/Patch/DMap.hs

@@ -47,8 +47,10 @@ instance GCompare k => DecidablyEmpty (PatchDMap k v) where
   isEmpty (PatchDMap m) = DMap.null m
 
 -- | Apply the insertions or deletions to a given 'DMap'.
-instance GCompare k => Patch (PatchDMap k v) where
+instance GCompare k => PatchHet (PatchDMap k v) where
+  type PatchSource (PatchDMap k v) = DMap k v
   type PatchTarget (PatchDMap k v) = DMap k v
+instance GCompare k => Patch (PatchDMap k v) where
   apply (PatchDMap diff) 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?
     where insertions = DMap.mapMaybeWithKey (const $ getComposeMaybe) diff
           deletions = DMap.mapMaybeWithKey (const $ nothingToJust . getComposeMaybe) diff

src/Data/Patch/DMapWithMove.hs

@@ -356,8 +356,11 @@ const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fr
           }
 
 -- | Apply the insertions, deletions, and moves to a given 'DMap'.
-instance GCompare k => Patch (PatchDMapWithMove k v) where
+instance GCompare k => PatchHet (PatchDMapWithMove k v) where
+  type PatchSource (PatchDMapWithMove k v) = DMap k v
   type PatchTarget (PatchDMapWithMove k v) = DMap k v
+
+instance GCompare k => Patch (PatchDMapWithMove k v) where
   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?
     where insertions = DMap.mapMaybeWithKey insertFunc p
           insertFunc :: forall a. k a -> NodeInfo k v a -> Maybe (v a)