WIP: Combination of #1 and #2

ChangeLog.md

@@ -4,6 +4,8 @@
 
 * `PatchMapWithMove` supports moves with a patch.
 
+* `PatchDMapWithMove` supports moves with a patch.
+
 ## 0.0.1.0
 
 * Support older GHCs with `split-these` flag.

patch.cabal

@@ -39,11 +39,14 @@ library
                , transformers >= 0.5.6.0 && < 0.6
                , witherable >= 0.3 && < 0.3.2
 
-  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.DMapWithMove.By
                  , Data.Patch.IntMap
                  , Data.Patch.Map
                  , Data.Patch.MapWithMove
@@ -52,6 +55,7 @@ library
 
   if flag(split-these)
     build-depends: these >= 1 && <1.1
+                 , these-lens >= 1 && <1.1
                  , semialign >=1 && <1.2
                  , 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 #-}
@@ -17,6 +17,8 @@
 module Data.Functor.Misc
   ( -- * Const2
     Const2 (..)
+  , Proxy3 (..)
+  , First2 (..)
   , unConst2
   , dmapToMap
   , dmapToIntMap
@@ -37,6 +39,7 @@ module Data.Functor.Misc
   , ComposeMaybe (..)
   ) where
 
+import qualified Control.Category as Cat
 import Control.Applicative ((<$>))
 import Data.Dependent.Map (DMap)
 import qualified Data.Dependent.Map as DMap
@@ -48,6 +51,7 @@ import Data.IntMap (IntMap)
 import qualified Data.IntMap as IntMap
 import Data.Map (Map)
 import qualified Data.Map as Map
+import qualified Data.Semigroupoid as Cat
 import Data.Some (Some(Some))
 import Data.These
 import Data.Type.Equality ((:~:)(Refl))
@@ -63,15 +67,15 @@ data Const2 :: * -> x -> x -> * 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
 
@@ -87,6 +91,25 @@ instance Ord k => GCompare (Const2 k v) where
     EQ -> GEQ
     GT -> GGT
 
+data Proxy3 :: x -> y -> z -> * where
+  Proxy3 :: Proxy3 vx vy vz
+  deriving ( Show, Read, Eq, Ord
+           , Functor, Foldable, Traversable
+           , Typeable
+           )
+
+instance Cat.Category (Proxy3 x) where
+  id = Proxy3
+  ~Proxy3 . ~Proxy3 = Proxy3
+
+newtype First2 (t :: k -> *) (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

@@ -51,8 +51,10 @@ class Semigroup q => Additive q where
 -- | The elements of an 'Additive' 'Semigroup' can be considered as patches of their own type.
 newtype AdditivePatch p = AdditivePatch { unAdditivePatch :: p }
 
-instance Additive p => Patch (AdditivePatch p) where
+instance Additive p => PatchHet (AdditivePatch p) where
+  type PatchSource (AdditivePatch p) = p
   type PatchTarget (AdditivePatch p) = p
+instance Additive p => Patch (AdditivePatch p) where
   apply (AdditivePatch p) q = Just $ p <> q
 
 instance (Ord k, Group q) => Group (MonoidalMap k q) where
@@ -62,8 +64,8 @@ instance (Ord k, Additive q) => Additive (MonoidalMap k q)
 
 -- | Trivial group.
 instance Group () where
-  negateG _ = ()
-  _ ~~ _ = ()
+  negateG ~() = ()
+  ~() ~~ ~() = ()
 instance Additive ()
 
 -- | Product group.  A Pair of groups gives rise to a group
@@ -88,8 +90,8 @@ instance (Additive (f a), Additive (g a)) => Additive ((f :*: g) a)
 
 -- | Trivial group, Functor style
 instance Group (Proxy x) where
-  negateG _ = Proxy
-  _ ~~ _ = Proxy
+  negateG ~Proxy = Proxy
+  ~Proxy ~~ ~Proxy = Proxy
 instance Additive (Proxy x)
 
 -- | Const lifts groups into a functor.

src/Data/Patch/Class.hs

@@ -1,18 +1,53 @@
+{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 -- | The interface for types which represent changes made to other types
 module Data.Patch.Class where
 
+import qualified Data.Semigroupoid as Cat
 import Data.Functor.Identity
+import Data.Functor.Misc
 import Data.Maybe
 import Data.Semigroup (Semigroup(..))
 import Data.Proxy
+import Data.Type.Equality ((:~:) (..))
+
+class PatchHet p where
+  type PatchSource p :: *
+  type PatchTarget p :: *
+  -- | 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 :: *
+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)
@@ -22,19 +57,110 @@ 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
 
--- | 'Identity' can be used as a 'Patch' that always fully replaces the value
-instance Patch (Proxy a) where
+-- | 'Proxy' can be used as a 'Patch' that always fully replaces the value
+instance PatchHet (Proxy (a :: *)) where
+  type PatchSource (Proxy a) = a
   type PatchTarget (Proxy a) = a
+instance 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 -> *) where
+  type PatchSource1 p :: k -> *
+  type PatchTarget1 p :: k -> *
+
+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 -> *) 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 -> *) 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 -> *) 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 -> *) (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
+
+-- | 'Proxy3' can be used as a 'Patch' that always does nothing
+instance PatchHet (Proxy3 (t :: k -> *) (a :: k) (a :: k)) where
+  type PatchSource (Proxy3 t a a) = t a
+  type PatchTarget (Proxy3 t a a) = t a
+  applyHet ~Proxy3 _ = Left Refl
+
+instance PatchHet2Base (Proxy3 (t :: k -> *) :: k -> k -> *) where
+  type PatchSource1 (Proxy3 t) = t
+  type PatchTarget1 (Proxy3 t) = t

src/Data/Patch/DMap.hs

@@ -31,8 +31,10 @@ deriving instance GCompare k => Semigroup (PatchDMap k v)
 deriving instance GCompare k => Monoid (PatchDMap k v)
 
 -- | 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