From d66d5e9ee657d72a709edf6c98407a2f7b7347f3 Mon Sep 17 00:00:00 2001
From: Dan Bornside <dan.bornside@obsidian.systems>
Date: Wed, 18 Sep 2019 17:56:18 -0400
Subject: [PATCH 01/27] add a couple of types for working with patches

---
 reflex.cabal                      |   2 +
 src/Reflex/Patch/DMapWithReset.hs | 120 ++++++++++++++++++++++++++++++
 src/Reflex/Patch/Patchable.hs     |  44 +++++++++++
 3 files changed, 166 insertions(+)
 create mode 100644 src/Reflex/Patch/DMapWithReset.hs
 create mode 100644 src/Reflex/Patch/Patchable.hs

diff --git a/reflex.cabal b/reflex.cabal
index a0984333..c85ed247 100644
--- a/reflex.cabal
+++ b/reflex.cabal
@@ -115,9 +115,11 @@ library
     Reflex.Patch.Class,
     Reflex.Patch.DMap,
     Reflex.Patch.DMapWithMove,
+    Reflex.Patch.DMapWithReset,
     Reflex.Patch.IntMap,
     Reflex.Patch.Map,
     Reflex.Patch.MapWithMove,
+    Reflex.Patch.Patchable,
     Reflex.PerformEvent.Base,
     Reflex.PerformEvent.Class,
     Reflex.PostBuild.Base,
diff --git a/src/Reflex/Patch/DMapWithReset.hs b/src/Reflex/Patch/DMapWithReset.hs
new file mode 100644
index 00000000..b8bb7f31
--- /dev/null
+++ b/src/Reflex/Patch/DMapWithReset.hs
@@ -0,0 +1,120 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+{-# OPTIONS_GHC -Wall #-}
+
+-- | 'Patch'es on 'DMap' that consist only of insertions (or overwrites) and deletions.
+module Reflex.Patch.DMapWithReset where
+
+import Reflex.Patch.Class
+
+import Data.Dependent.Map (DMap, GCompare (..))
+import qualified Data.Dependent.Map as DMap
+import Data.Semigroup (Semigroup (..))
+import Data.Constraint.Extras
+
+-- | A set of changes to a 'DMap'.  Any element may be inserted/updated or deleted.
+-- Insertions are represented as @'ComposeMaybe' (Just value)@,
+-- while deletions are represented as @'ComposeMaybe' Nothing@.
+newtype PatchDMapWithReset k p = PatchDMapWithReset { unPatchDMapWithReset :: DMap k (By p) }
+
+-- | Holds the information about each key: where its new value should come from,
+-- and where its old value should go to
+data By p a
+  = By_Insert (PatchTarget (p a)) -- ^ Insert the given value here
+  | By_Delete -- ^ Delete the existing value, if any, from here
+  | By_Patch (p a) -- ^ Patch the value here with the given patch
+
+instance (Semigroup (p a), Patch (p a)) => Semigroup (By p a) where
+  x@(By_Insert _) <> _ = x
+  By_Delete <> _ = By_Delete
+  By_Patch x <> By_Insert y = By_Insert (applyAlways x y)
+  By_Patch x <> By_Patch y = By_Patch (x <> y)
+  By_Patch _ <> By_Delete = By_Delete
+
+instance (Monoid (p a), Patch (p a)) => Monoid (By p a) where
+  mappend = (<>)
+  mempty = By_Patch mempty
+
+instance
+    ( GCompare k
+    , Has' Semigroup k p
+    , Has' Patch k p
+    )
+    => Semigroup (PatchDMapWithReset k p) where
+  PatchDMapWithReset xs <> PatchDMapWithReset ys = PatchDMapWithReset $ DMap.unionWithKey
+    (\k -> has' @Patch @p k
+         $ has' @Semigroup @p k
+         $ (<>)) xs ys
+
+instance
+    ( GCompare k
+    , Has' Semigroup k p
+    , Has' Patch k p
+    )
+    => Monoid (PatchDMapWithReset k p) where
+  mappend = (<>)
+  mempty = PatchDMapWithReset DMap.empty
+
+class (Patch (p a), PatchTarget (p a) ~ Patches1LocallyTarget p a) => Patches1Locally p a where
+  type Patches1LocallyTarget p :: k -> *
+
+data These1 f g x
+  = This1 (f x)
+  | That1 (g x)
+  | These1 (f x) (g x)
+
+mergeWithKey
+  :: forall k v1 v2 v.
+  (GCompare k)
+  => (forall x. k x -> v1 x -> Maybe (v x))
+  -> (forall x. k x -> v2 x -> Maybe (v x))
+  -> (forall x. k x -> v1 x -> v2 x -> Maybe (v x))
+  -> DMap k v1 -> DMap k v2 -> DMap k v
+mergeWithKey f g fg = \xs ys -> DMap.mapMaybeWithKey onlyThat $ DMap.unionWithKey doIt (DMap.map This1 xs) (DMap.map That1 ys)
+  where
+    doIt _ (This1 xs) (That1 ys) = These1 xs ys
+    doIt _ _ _ = error "mergeWithKey misalligned keys"
+
+    onlyThat :: forall x. k x -> These1 v1 v2 x -> Maybe (v x)
+    onlyThat k = \case
+      This1 xs -> f k xs
+      That1 ys -> g k ys
+      These1 xs ys -> fg k xs ys
+{-# INLINE mergeWithKey #-}
+
+-- | Apply the insertions or deletions to a given 'DMap'.
+instance (GCompare k, Has (Patches1Locally p) k) => Patch (PatchDMapWithReset k p) where
+
+  type PatchTarget (PatchDMapWithReset k p) = DMap k (Patches1LocallyTarget p)
+
+  apply = go
+    where
+      go :: PatchDMapWithReset k p -> DMap k (Patches1LocallyTarget p) -> Maybe (DMap k (Patches1LocallyTarget p))
+      go (PatchDMapWithReset diff) old = Just $! mergeWithKey (\_ -> Just) inserts updates old diff
+        where
+          updates :: forall x. k x -> Patches1LocallyTarget p x -> By p x -> Maybe (Patches1LocallyTarget p x)
+          updates k ys = has @(Patches1Locally p) k $ \case
+            By_Insert x -> Just x
+            By_Delete -> Nothing
+            By_Patch x -> Just $ applyAlways x ys
+
+          inserts :: forall x. k x -> By p x -> Maybe (Patches1LocallyTarget p x)
+          inserts k = has @(Patches1Locally p) k $ \case
+            By_Insert x -> Just x
+            By_Delete -> Nothing
+            By_Patch _ -> Nothing
+
+deriving instance (Patch (p a), Eq (p a), Eq (PatchTarget (p a))) => Eq (By p a)
+deriving instance (Patch (p a), Show (p a), Show (PatchTarget (p a))) => Show (By p a)
+deriving instance (Eq (DMap k (By p))) => Eq (PatchDMapWithReset k p)
+deriving instance (Show (DMap k (By p))) => Show (PatchDMapWithReset k p)
diff --git a/src/Reflex/Patch/Patchable.hs b/src/Reflex/Patch/Patchable.hs
new file mode 100644
index 00000000..2c529abe
--- /dev/null
+++ b/src/Reflex/Patch/Patchable.hs
@@ -0,0 +1,44 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+
+-- The derived instances are undecidable in the case of a pathlogical instance like
+-- instance Patch x where
+--   type PatchTarget x = Patchable x
+{-# LANGUAGE UndecidableInstances #-}
+
+module Reflex.Patch.Patchable where
+
+-- import Data.Aeson
+import GHC.Generics
+import Reflex.Patch
+
+-- | Like SemiMap/PartialMap but for anything patchable
+data Patchable p
+  = Patchable_Patch p
+  | Patchable_Complete (PatchTarget p)
+  deriving (Generic)
+
+completePatchable :: Patchable p -> Maybe (PatchTarget p)
+completePatchable = \case
+  Patchable_Complete t -> Just t
+  Patchable_Patch _ -> Nothing
+
+deriving instance (Eq p, Eq (PatchTarget p)) => Eq (Patchable p)
+deriving instance (Ord p, Ord (PatchTarget p)) => Ord (Patchable p)
+deriving instance (Show p, Show (PatchTarget p)) => Show (Patchable p)
+deriving instance (Read p, Read (PatchTarget p)) => Read (Patchable p)
+-- instance (ToJSON p, ToJSON (PatchTarget p)) => ToJSON (Patchable p)
+-- instance (FromJSON p, FromJSON (PatchTarget p)) => FromJSON (Patchable p)
+
+instance (Monoid p, Patch p) => Monoid (Patchable p) where
+  mempty = Patchable_Patch mempty
+  mappend = (<>)
+
+instance (Semigroup p, Patch p) => Semigroup (Patchable p) where
+  (<>) = curry $ \case
+    (Patchable_Patch a, Patchable_Patch b) -> Patchable_Patch $ a <> b
+    (Patchable_Patch a, Patchable_Complete b) -> Patchable_Complete $ applyAlways a b
+    (Patchable_Complete a, _) -> Patchable_Complete a

From 732cb147ca0c8df0957bae94d8611829a760daad Mon Sep 17 00:00:00 2001
From: Dan Bornside <dan.bornside@obsidian.systems>
Date: Wed, 25 Sep 2019 17:58:46 -0400
Subject: [PATCH 02/27] Update src/Reflex/Patch/Patchable.hs

Co-Authored-By: Alexandre Esteves <2335822+alexfmpe@users.noreply.github.com>
---
 src/Reflex/Patch/Patchable.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Reflex/Patch/Patchable.hs b/src/Reflex/Patch/Patchable.hs
index 2c529abe..e699b0e8 100644
--- a/src/Reflex/Patch/Patchable.hs
+++ b/src/Reflex/Patch/Patchable.hs
@@ -4,7 +4,7 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 
--- The derived instances are undecidable in the case of a pathlogical instance like
+-- The derived instances are undecidable in the case of a pathological instance like
 -- instance Patch x where
 --   type PatchTarget x = Patchable x
 {-# LANGUAGE UndecidableInstances #-}

From 0ec95ff25d5e91e1bd17431d6ceed2c4d50de51a Mon Sep 17 00:00:00 2001
From: John Ericson <John.Ericson@Obsidian.Systems>
Date: Wed, 8 Jan 2020 18:41:17 -0500
Subject: [PATCH 03/27] Add change log entry

---
 ChangeLog.md | 6 ++++++
 1 file changed, 6 insertions(+)

diff --git a/ChangeLog.md b/ChangeLog.md
index a863cded..6abaa6b1 100644
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -1,5 +1,11 @@
 # Revision history for patch
 
+## Unreleased
+
+* Add `PatchDMapWithReset`
+
+* Add `Patchable`
+
 ## 0.0.0.1
 
 * Remove unneeded dependencies

From cf7b8fb7237e01a9eec43c0c7bca81134ee702c6 Mon Sep 17 00:00:00 2001
From: John Ericson <git@JohnEricson.me>
Date: Sat, 11 Jan 2020 01:33:06 -0500
Subject: [PATCH 04/27] Get rid of entirely-_ pattern in Group instances

Do this without changing strictness using ~.
---
 src/Data/Patch.hs | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/src/Data/Patch.hs b/src/Data/Patch.hs
index 7579a456..951b248c 100644
--- a/src/Data/Patch.hs
+++ b/src/Data/Patch.hs
@@ -62,8 +62,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 +88,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.

From 7fd18c03fa4187344394b284bb89537bc15815b5 Mon Sep 17 00:00:00 2001
From: John Ericson <git@JohnEricson.me>
Date: Sat, 11 Jan 2020 01:58:54 -0500
Subject: [PATCH 05/27] Add notion of heterogenous patch

---
 src/Data/Patch.hs              |  4 ++-
 src/Data/Patch/Class.hs        | 46 ++++++++++++++++++++++++++++++----
 src/Data/Patch/DMap.hs         |  4 ++-
 src/Data/Patch/DMapWithMove.hs |  4 ++-
 src/Data/Patch/IntMap.hs       |  4 ++-
 src/Data/Patch/Map.hs          |  4 ++-
 src/Data/Patch/MapWithMove.hs  | 10 ++++++--
 7 files changed, 64 insertions(+), 12 deletions(-)

diff --git a/src/Data/Patch.hs b/src/Data/Patch.hs
index 951b248c..1179c1b0 100644
--- a/src/Data/Patch.hs
+++ b/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
diff --git a/src/Data/Patch/Class.hs b/src/Data/Patch/Class.hs
index 27db038c..0fd2aeb9 100644
--- a/src/Data/Patch/Class.hs
+++ b/src/Data/Patch/Class.hs
@@ -1,4 +1,6 @@
+{-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
 -- | The interface for types which represent changes made to other types
 module Data.Patch.Class where
 
@@ -6,13 +8,39 @@ import Data.Functor.Identity
 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 +50,27 @@ 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
+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
diff --git a/src/Data/Patch/DMap.hs b/src/Data/Patch/DMap.hs
index 32c36079..97828611 100644
--- a/src/Data/Patch/DMap.hs
+++ b/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
diff --git a/src/Data/Patch/DMapWithMove.hs b/src/Data/Patch/DMapWithMove.hs
index 05813ae1..5e251878 100644
--- a/src/Data/Patch/DMapWithMove.hs
+++ b/src/Data/Patch/DMapWithMove.hs
@@ -343,8 +343,10 @@ 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)
diff --git a/src/Data/Patch/IntMap.hs b/src/Data/Patch/IntMap.hs
index 8d70fd3b..3c28c7cc 100644
--- a/src/Data/Patch/IntMap.hs
+++ b/src/Data/Patch/IntMap.hs
@@ -19,8 +19,10 @@ import Data.Patch.Class
 newtype PatchIntMap a = PatchIntMap (IntMap (Maybe a)) deriving (Functor, Foldable, Traversable, Monoid)
 
 -- | Apply the insertions or deletions to a given 'IntMap'.
-instance Patch (PatchIntMap a) where
+instance PatchHet (PatchIntMap a) where
+  type PatchSource (PatchIntMap a) = IntMap a
   type PatchTarget (PatchIntMap a) = IntMap a
+instance Patch (PatchIntMap a) where
   apply (PatchIntMap p) v = if IntMap.null p then Nothing else Just $
     let removes = IntMap.filter isNothing p
         adds = IntMap.mapMaybe id p
diff --git a/src/Data/Patch/Map.hs b/src/Data/Patch/Map.hs
index 8524031e..b107b05e 100644
--- a/src/Data/Patch/Map.hs
+++ b/src/Data/Patch/Map.hs
@@ -18,8 +18,10 @@ newtype PatchMap k v = PatchMap { unPatchMap :: Map k (Maybe v) }
   deriving (Show, Read, Eq, Ord)
 
 -- | Apply the insertions or deletions to a given 'Map'.
-instance Ord k => Patch (PatchMap k v) where
+instance Ord k => PatchHet (PatchMap k v) where
+  type PatchSource (PatchMap k v) = Map k v
   type PatchTarget (PatchMap k v) = Map k v
+instance Ord k => Patch (PatchMap k v) where
   {-# INLINABLE apply #-}
   apply (PatchMap p) old = Just $! insertions `Map.union` (old `Map.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 = Map.mapMaybeWithKey (const id) p
diff --git a/src/Data/Patch/MapWithMove.hs b/src/Data/Patch/MapWithMove.hs
index 894c5f90..5f680bd2 100644
--- a/src/Data/Patch/MapWithMove.hs
+++ b/src/Data/Patch/MapWithMove.hs
@@ -142,9 +142,15 @@ unsafePatchMapWithMove
 unsafePatchMapWithMove = PatchMapWithMove
 
 -- | Apply the insertions, deletions, and moves to a given 'Map'
-instance (Ord k, Patch p) => Patch (PatchMapWithMove k p) where
+instance (Ord k, Patch p) => PatchHet (PatchMapWithMove k p) where
+  type PatchSource (PatchMapWithMove k p) = Map k (PatchSource p)
   type PatchTarget (PatchMapWithMove k p) = Map k (PatchTarget p)
-  apply (PatchMapWithMove m) old = Just $! insertions `Map.union` (old `Map.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?
+instance (Ord k, Patch p) => Patch (PatchMapWithMove k p) where
+  -- 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?
+  apply (PatchMapWithMove m) old = Just $! insertions `Map.union` (old `Map.difference` deletions)
     where insertions = flip Map.mapMaybeWithKey m $ \_ ni -> case _nodeInfo_from ni of
             From_Insert v -> Just v
             From_Move k p -> applyAlways p <$> Map.lookup k old

From aa7311b1f2f2992bff08e1aa1f4c76869f7912ba Mon Sep 17 00:00:00 2001
From: John Ericson <git@JohnEricson.me>
Date: Sat, 11 Jan 2020 03:45:34 -0500
Subject: [PATCH 06/27] WIP: Patch in PatchDMapWithMove's From_Move

This makes it match the new PatchMapWithMove, and obviates
PatchDMapWithReset.
---
 src/Data/Patch/Class.hs        |  48 ++++++-
 src/Data/Patch/DMapWithMove.hs | 239 +++++++++++++++++++++++++--------
 src/Data/Patch/MapWithMove.hs  |   1 -
 3 files changed, 230 insertions(+), 58 deletions(-)

diff --git a/src/Data/Patch/Class.hs b/src/Data/Patch/Class.hs
index 0fd2aeb9..93e1eb33 100644
--- a/src/Data/Patch/Class.hs
+++ b/src/Data/Patch/Class.hs
@@ -1,4 +1,8 @@
 {-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 -- | The interface for types which represent changes made to other types
@@ -56,11 +60,11 @@ instance PatchHet (Identity a) where
 instance Patch (Identity a) where
   apply (Identity a) _ = Just a
 
--- | 'Identity' can be used as a 'Patch' that always fully replaces the value
-instance PatchHet (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
+instance Patch (Proxy (a :: *)) where
   apply ~Proxy _ = Nothing
 
 -- | Like '(.)', but composes functions that return patches rather than
@@ -74,3 +78,41 @@ composePatchFunctions
 composePatchFunctions g f a =
   let fp = f a
   in g (applyAlways fp a) <> fp
+
+class (forall x y
+       . ( PatchHet (p x y)
+         , PatchSource1 p x ~ PatchSource (p x y)
+         , PatchTarget1 p y ~ PatchTarget (p x y)
+         )
+      ) => PatchHet2 (p :: k -> k -> *) where
+  type PatchSource1 p :: k -> *
+  type PatchTarget1 p :: k -> *
+
+class ( PatchHet2 p
+      , PatchSource1 p ~ PatchTarget1 p
+      ) => Patch2 p
+instance ( PatchHet2 p
+         , PatchSource1 p ~ PatchTarget1 p
+         ) => Patch2 p
+
+newtype Replace2 (t :: k -> *) (a :: k) (b :: k) = Replace2 (t b)
+  deriving ( Show, Read, Eq, Ord
+           , Functor, Foldable, Traversable
+           )
+
+data Proxy2 t a b = Proxy2
+  deriving ( Show, Read, Eq, Ord
+           , Functor, Foldable, Traversable
+           )
+
+-- | 'Replace2' can be used as a 'Patch' that always fully replaces the value
+instance PatchHet (Replace2 (t :: k -> *) (a :: k) (b :: k)) where
+  type PatchSource (Replace2 t a b) = t a
+  type PatchTarget (Replace2 t a b) = t b
+  applyHet (Replace2 val) _ = Right val
+
+-- | 'Proxy2' can be used as a 'Patch' that always fully replaces the value
+instance PatchHet (Proxy2 (t :: k -> *) (a :: k) (a :: k)) where
+  type PatchSource (Proxy2 t a a) = t a
+  type PatchTarget (Proxy2 t a a) = t a
+  applyHet ~Proxy2 _ = Left Refl
diff --git a/src/Data/Patch/DMapWithMove.hs b/src/Data/Patch/DMapWithMove.hs
index 5e251878..d8fc6d6e 100644
--- a/src/Data/Patch/DMapWithMove.hs
+++ b/src/Data/Patch/DMapWithMove.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
@@ -8,8 +9,11 @@
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
 
 -- |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.
@@ -20,19 +24,34 @@ import Data.Patch.MapWithMove (PatchMapWithMove (..))
 import qualified Data.Patch.MapWithMove as MapWithMove
 
 import Data.Constraint.Extras
+import Data.Constraint.Compose
 import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
 import qualified Data.Dependent.Map as DMap
 import Data.Functor.Constant
 import Data.Functor.Misc
 import Data.Functor.Product
-import Data.GADT.Compare (GEq (..))
-import Data.GADT.Show (GShow, gshow)
+import Data.GADT.Compare (GEq (..), GCompare)
+import Data.GADT.Show (GRead, GShow, gshow)
 import qualified Data.Map as Map
 import Data.Maybe
+import Data.Monoid.DecidablyEmpty
 import Data.Semigroup (Semigroup (..), (<>))
 import Data.Some (Some(Some))
 import Data.Proxy
 import Data.These
+import Data.Type.Equality ((:~:) (..))
+import Data.Kind (Constraint)
+
+
+-- | Composition for constraints.
+class p (f a a) => DupC (p :: k2 -> Constraint) (f :: k1 -> k1 -> k2) (a :: k1)
+instance p (f a a) => DupC p f a
+
+type ConstraintsForZip f (c :: k -> Constraint) (g :: k' -> k' -> k) =
+  ConstraintsFor f (DupC c g)
+
+type HasZip (c :: k -> Constraint) f (g :: k' -> k' -> k) =
+  (ArgDict (DupC c g) f, ConstraintsForZip f c g)
 
 -- | 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.
@@ -43,47 +62,119 @@ import Data.These
 --     * 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))
 
+deriving instance ( GShow k
+                  , HasZip Show k p
+                  , Has' Show k (PatchTarget1 p)
+                  ) => Show (PatchDMapWithMove k p)
+deriving instance ( GRead k
+                  , HasZip Read k p
+                  , Has' Read k (PatchTarget1 p)
+                  ) => Read (PatchDMapWithMove k p)
+deriving instance ( GEq k
+                  , HasZip Eq k p
+                  , Has' Eq k (PatchTarget1 p)
+                  ) => Eq (PatchDMapWithMove k p)
+deriving instance ( GCompare k
+                  , HasZip Ord k p
+                  , Has' Ord k (PatchTarget1 p)
+                  ) => Ord (PatchDMapWithMove k p)
+
 -- |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)
+data NodeInfo k p a = NodeInfo
+  { _nodeInfo_from :: !(From k p 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)
+
+deriving instance ( Show (k a)
+                  , Show (p a a)
+                  , Show (PatchTarget1 p a)
+                  ) => Show (NodeInfo k p a)
+deriving instance ( Read (k a)
+                  , Read (p a a)
+                  , Read (PatchTarget1 p a)
+                  ) => Read (NodeInfo k p a)
+deriving instance ( Eq (k a)
+                  , Eq (p a a)
+                  , Eq (PatchTarget1 p a)
+                  ) => Eq (NodeInfo k p a)
+deriving instance ( Ord (k a)
+                  , Ord (p a a)
+                  , Ord (PatchTarget1 p a)
+                  ) => Ord (NodeInfo k p a)
 
 -- |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
-  -- |Insert a new or update an existing key with the given value @v a@
-  From_Insert :: v a -> From k v a
+data From (k :: a -> *) (p :: a -> a -> *) :: a -> * where
+  -- |Insert a new or update an existing key with the given value @PatchTarget1 p a@
+  From_Insert :: PatchTarget1 p a -> From k p a
   -- |Delete the existing key
-  From_Delete :: From k v a
+  From_Delete :: From k p 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@.
-  From_Move :: !(k a) -> From k v a
-  deriving (Show, Read, Eq, Ord)
+  From_Move :: !(k a0) -> p a0 a1 -> From k p a1
+
+deriving instance ( Show (k a)
+                  , Show (p a a)
+                  , Show (PatchTarget1 p a)
+                  ) => Show (From k p a)
+deriving instance ( Read (k a)
+                  , Read (p a a)
+                  , Read (PatchTarget1 p a)
+                  ) => Read (From k p a)
+
+instance ( GEq k
+         , HasZip Eq k p
+         , Eq (PatchTarget1 p a)
+         ) => Eq (From k p a) where
+  From_Insert p0 == From_Insert p1 = p0 == p1
+  From_Delete == From_Delete = True
+  From_Move k0 p0 == From_Move k1 p1 = case geq k0 k1 of
+    Nothing -> False
+    Just Refl -> has @(DupC Eq p) k0 $ p0 == p1
+
+instance ( GCompare k
+         , HasZip Ord k p
+         , Ord (PatchTarget1 p a)
+         ) => Ord (From k p a) where
+  From_Insert p0 `compare` From_Insert p1 = p0 `compare` p1
+  From_Delete `compare` From_Delete = EQ
+  From_Move k0 p0 `compare` From_Move k1 p1 = case gcompare k0 k1 of
+    DMap.GGT -> GT
+    DMap.GEQ -> has @(DupC Ord p) k0 $ p0 `compare` p1
+    DMap.GLT -> LT
 
 -- |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
 
 -- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
-validPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Bool
+validPatchDMapWithMove
+  :: forall k v
+  .  (GCompare k, GShow k)
+  => DMap k (NodeInfo k v)
+  -> Bool
 validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
 
 -- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.
-validationErrorsForPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> [String]
+validationErrorsForPatchDMapWithMove
+  :: forall k v
+  .  (GCompare k, GShow k)
+  => DMap k (NodeInfo k v)
+  -> [String]
 validationErrorsForPatchDMapWithMove m =
   noSelfMoves <> movesBalanced
   where
     noSelfMoves = mapMaybe 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 (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 = mapMaybe unbalancedMove . DMap.toAscList $ m
-    unbalancedMove (dst :=> NodeInfo (From_Move src) _) =
+    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'))) ->
@@ -95,7 +186,7 @@ validationErrorsForPatchDMapWithMove m =
     unbalancedMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) =
       case DMap.lookup dst m of
         Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"
-        Just (NodeInfo (From_Move src') _) ->
+        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
@@ -104,10 +195,6 @@ validationErrorsForPatchDMapWithMove m =
           Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
     unbalancedMove _ = Nothing
 
--- |Test whether two @'PatchDMapWithMove' k v@ contain the same patch operations.
-instance (GEq k, Has' Eq 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)
 
@@ -117,20 +204,25 @@ data Fixup k v a
    | 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 => Semigroup (PatchDMapWithMove k v) where
+instance ( GCompare k
+         -- , DecidablyEmpty p
+         , PatchHet2 p
+         ) => Semigroup (PatchDMapWithMove k p) where
   PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
     where
       connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb
       h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]
       h (_ :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case (mToAfter, editBefore) of
-        (Just toAfter, From_Move fromBefore)
-          | isJust $ fromBefore `geq` toAfter
+        (Just toAfter, From_Move fromBefore p)
+          | case fromBefore `geq` toAfter of
+              Nothing -> False
+              Just Refl -> isNull p
             -> [toAfter :=> Fixup_Delete]
           | otherwise
             -> [ toAfter :=> Fixup_Update (This editBefore)
                , fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))
                ]
-        (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
+        (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
         (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)]
         (Nothing, _) -> []
       mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
@@ -148,7 +240,13 @@ instance GCompare k => Semigroup (PatchDMapWithMove k v) where
       applyFixup _ ni = \case
         Fixup_Delete -> Nothing
         Fixup_Update u -> Just $ NodeInfo
-          { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
+          { _nodeInfo_from = case _nodeInfo_from ni of
+              f@(From_Move _ p') -> case getHere u of -- The `from` fixup comes from the "old" patch
+                Nothing -> f -- If there's no `from` fixup, just use the "new" `from`
+                Just (From_Insert v) -> From_Insert $ applyAlways p' v
+                Just From_Delete -> From_Delete
+                Just (From_Move oldKey p) -> From_Move oldKey $ p' <> p
+              _ -> error "DPatchMapWithMove: fixup for non-move From"
           , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
           }
       m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups
@@ -169,7 +267,7 @@ instance GCompare k => Monoid (PatchDMapWithMove k v) where
   mappend = (<>)
 
 {-
-mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
+mappendPatchDMapWithMoveSlow :: forall k v.  (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
 PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
   where
     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
@@ -190,8 +288,8 @@ 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
+-- |Make a @'PatchDMapWithMove' k v@ which has the effect of inserting or updating a value @PatchTarget1 p a@ to the given key @k a@, like 'DMap.insert'.
+insertDMapKey :: k a -> PatchTarget1 p a -> PatchDMapWithMove k p
 insertDMapKey k v =
   PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing)
 
@@ -272,41 +370,67 @@ patchDMapWithMove 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
+  :: forall k p p'
+  .  (forall a. PatchTarget1 p a -> PatchTarget1 p' a)
+  -> PatchDMapWithMove k p
+  -> PatchDMapWithMove k p'
 mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $
   DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
-  where g :: forall a. From k v a -> From k v' a
+  where g :: forall a. From k PatchTarget1 p a -> From k PatchTarget1 p' a
         g = \case
           From_Insert v -> From_Insert $ f v
           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')
+-- |Traverse an effectful function @forall a. PatchTarget1 p a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.
+traversePatchDMapWithMove
+  :: forall m k p p'
+  . Applicative m
+  => (forall a. PatchTarget1 p a -> m (PatchTarget1 p' a))
+  -> PatchDMapWithMove k p
+  -> m (PatchDMapWithMove k p')
 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)
+-- |Map an effectful function @forall a. k a -> PatchTarget1 p a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.
+traversePatchDMapWithMoveWithKey
+  :: forall m k p p'
+  . Applicative m
+  => (forall a. k a -> PatchTarget1 p a -> m (PatchTarget1 p' a))
+  -> PatchDMapWithMove k p
+  -> m (PatchDMapWithMove k p')
+traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) =
+  PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p
+  where g :: forall a. k a -> From k PatchTarget1 p a -> m (From k PatchTarget1 p' a)
         g k = \case
           From_Insert v -> From_Insert <$> f k v
           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
+-- |Map a function which transforms @'From' k PatchTarget1 p a@ into a @'From' k PatchTarget1 p' a@ over a @'NodeInfo' k PatchTarget1 p a@.
+nodeInfoMapFrom
+  :: (From k p a -> From k p' a)
+  -> NodeInfo k p a
+  -> NodeInfo k p' 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)
+-- |Map an effectful function which transforms @'From' k PatchTarget1 p a@ into a @f ('From' k PatchTarget1 p' a)@ over a @'NodeInfo' k PatchTarget1 p a@.
+nodeInfoMapFromM
+  :: Functor f
+  => (From k p a -> f (From k p' a))
+  -> NodeInfo k p a
+  -> f (NodeInfo k p' 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
+-- |Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys from @k a@ to @'Some' k@ and applying a given weakening function @PatchTarget1 p a -> v'@ to
 -- values.
-weakenPatchDMapWithMoveWith :: forall k v v'. (forall a. v a -> v') -> PatchDMapWithMove k v -> PatchMapWithMove (Some k) (Proxy v')
+weakenPatchDMapWithMoveWith
+  :: forall k p v'
+  .  (forall a. PatchTarget1 p a -> v')
+  -> PatchDMapWithMove k p
+  -> PatchMapWithMove (Some k) (Proxy v')
 weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
-  where g :: forall a. NodeInfo k v a -> MapWithMove.NodeInfo (Some k) (Proxy v')
+  where g :: forall a. NodeInfo k PatchTarget1 p a -> MapWithMove.NodeInfo (Some k) (Proxy v')
         g ni = MapWithMove.NodeInfo
           { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
               From_Insert v -> MapWithMove.From_Insert $ f v
@@ -317,9 +441,12 @@ weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenD
 
 -- |"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 (Proxy v')
+patchDMapWithMoveToPatchMapWithMoveWith
+  :: forall k p v' a. (PatchTarget1 p a -> v')
+  -> PatchDMapWithMove (Const2 k a) p
+  -> PatchMapWithMove k (Proxy v')
 patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
-  where g :: NodeInfo (Const2 k a) v a -> MapWithMove.NodeInfo k (Proxy v')
+  where g :: NodeInfo (Const2 k a) PatchTarget1 p a -> MapWithMove.NodeInfo k (Proxy v')
         g ni = MapWithMove.NodeInfo
           { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
               From_Insert v -> MapWithMove.From_Insert $ f v
@@ -329,9 +456,13 @@ patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMo
           }
 
 -- |"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@.
+-- one but which always has a constant key type represented by 'Const2'. Apply the given function to each @v@ to produce a @PatchTarget1 p' a@.
 -- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
-const2PatchDMapWithMoveWith :: forall k v v' a. (v -> v' a) -> PatchMapWithMove k (Proxy v) -> PatchDMapWithMove (Const2 k a) v'
+const2PatchDMapWithMoveWith
+  :: forall k v p' a
+  .  (v -> PatchTarget1 p' a)
+  -> PatchMapWithMove k (Proxy v)
+  -> PatchDMapWithMove (Const2 k a) p'
 const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
   where g :: (k, MapWithMove.NodeInfo k (Proxy v)) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')
         g (k, ni) = Const2 k :=> NodeInfo
@@ -343,19 +474,19 @@ const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fr
           }
 
 -- | Apply the insertions, deletions, and moves to a given 'DMap'.
-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
+instance GCompare k => PatchHet (PatchDMapWithMove k p) where
+  type PatchSource (PatchDMapWithMove k p) = DMap k (PatchSource1 p)
+  type PatchTarget (PatchDMapWithMove k p) = DMap k (PatchTarget1 p)
+instance GCompare k => Patch (PatchDMapWithMove k p) 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)
+          insertFunc :: forall a. k a -> NodeInfo k p a -> Maybe (PatchTarget1 p a)
           insertFunc _ ni = case _nodeInfo_from ni of
             From_Insert v -> Just v
             From_Move k -> DMap.lookup k old
             From_Delete -> Nothing
           deletions = DMap.mapMaybeWithKey deleteFunc p
-          deleteFunc :: forall a. k a -> NodeInfo k v a -> Maybe (Constant () a)
+          deleteFunc :: forall a. k a -> NodeInfo k p a -> Maybe (Constant () a)
           deleteFunc _ ni = case _nodeInfo_from ni of
             From_Delete -> Just $ Constant ()
             _ -> Nothing
diff --git a/src/Data/Patch/MapWithMove.hs b/src/Data/Patch/MapWithMove.hs
index 5f680bd2..a54abb8d 100644
--- a/src/Data/Patch/MapWithMove.hs
+++ b/src/Data/Patch/MapWithMove.hs
@@ -258,7 +258,6 @@ data Fixup k v
 
 -- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
 instance ( Ord k
-         , Monoid p
          , DecidablyEmpty p
          , Patch p
          ) => Semigroup (PatchMapWithMove k p) where

From d72221c4c76887d8a32ef8830280a6dcee9f2220 Mon Sep 17 00:00:00 2001
From: John Ericson <git@JohnEricson.me>
Date: Sat, 11 Jan 2020 04:11:25 -0500
Subject: [PATCH 07/27] Try making the "to" field at a potentially different
 index

This isn't good enough. I think there is a bug in that we don't store
enough information in the two field: we need both inner patches with the
join so we can combine them together. In the non-dependent case, nothing
stops us from making this misake, but in the dependent case we would
need to use a `Category` instance on the inner move patches. We plainly
aren't combining two inner patches in the double move case, and the
types let us know.
---
 src/Data/Patch/DMapWithMove.hs | 19 ++++++++++++-------
 1 file changed, 12 insertions(+), 7 deletions(-)

diff --git a/src/Data/Patch/DMapWithMove.hs b/src/Data/Patch/DMapWithMove.hs
index d8fc6d6e..ec2202cc 100644
--- a/src/Data/Patch/DMapWithMove.hs
+++ b/src/Data/Patch/DMapWithMove.hs
@@ -84,7 +84,7 @@ deriving instance ( GCompare k
 data NodeInfo k p a = NodeInfo
   { _nodeInfo_from :: !(From k p a)
   -- ^Change applying to the current key, be it an insert, move, or delete.
-  , _nodeInfo_to :: !(To k a)
+  , _nodeInfo_to :: !(Some (To k))
   -- ^Where this key is moving to, if involved in a move. Should only be @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.
   }
 
@@ -170,20 +170,20 @@ validationErrorsForPatchDMapWithMove m =
     noSelfMoves = mapMaybe 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)))
+    selfMove (src :=> NodeInfo _ (Some (ComposeMaybe (Just dst))))
       | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
     selfMove _ = Nothing
     movesBalanced = mapMaybe 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'))) ->
+        Just (NodeInfo _ (Some (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))) =
+    unbalancedMove (src :=> NodeInfo _ (Some (ComposeMaybe (Just dst)))) =
       case DMap.lookup dst m of
         Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"
         Just (NodeInfo (From_Move src' _) _) ->
@@ -198,6 +198,8 @@ validationErrorsForPatchDMapWithMove m =
 -- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
 data Pair1 f g a = Pair1 (f a) (g a)
 
+data PairHalf a f b = PairHalf a (f b)
+
 -- |Helper data structure used for composing patches using the monoid instance.
 data Fixup k v a
    = Fixup_Delete
@@ -210,9 +212,12 @@ instance ( GCompare k
          ) => Semigroup (PatchDMapWithMove k p) where
   PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
     where
-      connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb
-      h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]
-      h (_ :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case (mToAfter, editBefore) of
+      connections = DMap.toList $ DMap.intersectionWithKey
+        (\_ a b -> PairHalf (_nodeInfo_to a) (_nodeInfo_from b))
+        ma
+        mb
+      h :: DSum k (PairHalf (Some (ComposeMaybe k)) (From k v)) -> [DSum k (Fixup k v)]
+      h (between :=> PairHalf (Some (ComposeMaybe mToAfter)) editBefore) = case (mToAfter, editBefore) of
         (Just toAfter, From_Move fromBefore p)
           | case fromBefore `geq` toAfter of
               Nothing -> False

From f78dd1617e9303e68e18ace415ce786ad05edba5 Mon Sep 17 00:00:00 2001
From: John Ericson <git@JohnEricson.me>
Date: Sat, 11 Jan 2020 15:03:40 -0500
Subject: [PATCH 08/27] WIP Generalize DMap patching

---
 patch.cabal                     |   1 +
 src/Data/Patch/Class.hs         |  76 +++++++--
 src/Data/Patch/DMapWithMove.hs  | 294 +++++++++++++++++++++++---------
 src/Data/Patch/DMapWithReset.hs |   4 +-
 4 files changed, 284 insertions(+), 91 deletions(-)

diff --git a/patch.cabal b/patch.cabal
index 3189880d..4e40a199 100644
--- a/patch.cabal
+++ b/patch.cabal
@@ -54,6 +54,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
diff --git a/src/Data/Patch/Class.hs b/src/Data/Patch/Class.hs
index 93e1eb33..80e4aee5 100644
--- a/src/Data/Patch/Class.hs
+++ b/src/Data/Patch/Class.hs
@@ -1,8 +1,8 @@
 {-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE QuantifiedConstraints #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TypeOperators #-}
 -- | The interface for types which represent changes made to other types
@@ -79,19 +79,69 @@ composePatchFunctions g f a =
   let fp = f a
   in g (applyAlways fp a) <> fp
 
-class (forall x y
-       . ( PatchHet (p x y)
-         , PatchSource1 p x ~ PatchSource (p x y)
-         , PatchTarget1 p y ~ PatchTarget (p x y)
-         )
-      ) => PatchHet2 (p :: k -> k -> *) where
+
+class PatchHet2Base (p :: k -> k -> *) where
   type PatchSource1 p :: k -> *
   type PatchTarget1 p :: k -> *
 
-class ( PatchHet2 p
+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 }
+
+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) src = applyHet2 p src
+
+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 ( PatchHet2 p
+instance ( PatchHet2Base p
          , PatchSource1 p ~ PatchTarget1 p
          ) => Patch2 p
 
@@ -106,12 +156,12 @@ data Proxy2 t a b = Proxy2
            )
 
 -- | 'Replace2' can be used as a 'Patch' that always fully replaces the value
-instance PatchHet (Replace2 (t :: k -> *) (a :: k) (b :: k)) where
-  type PatchSource (Replace2 t a b) = t a
-  type PatchTarget (Replace2 t a b) = t b
+instance PatchHet (Replace2 (t :: k -> *) (from :: k) (to :: k)) where
+  type PatchSource (Replace2 t from to) = t from
+  type PatchTarget (Replace2 t from to) = t to
   applyHet (Replace2 val) _ = Right val
 
--- | 'Proxy2' can be used as a 'Patch' that always fully replaces the value
+-- | 'Proxy2' can be used as a 'Patch' that always does nothing
 instance PatchHet (Proxy2 (t :: k -> *) (a :: k) (a :: k)) where
   type PatchSource (Proxy2 t a a) = t a
   type PatchTarget (Proxy2 t a a) = t a
diff --git a/src/Data/Patch/DMapWithMove.hs b/src/Data/Patch/DMapWithMove.hs
index ec2202cc..d3a6c7dc 100644
--- a/src/Data/Patch/DMapWithMove.hs
+++ b/src/Data/Patch/DMapWithMove.hs
@@ -3,6 +3,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
+{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE PatternGuards #-}
@@ -19,10 +20,7 @@
 -- move values between keys.
 module Data.Patch.DMapWithMove where
 
-import Data.Patch.Class
-import Data.Patch.MapWithMove (PatchMapWithMove (..))
-import qualified Data.Patch.MapWithMove as MapWithMove
-
+import qualified Control.Category as Cat
 import Data.Constraint.Extras
 import Data.Constraint.Compose
 import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
@@ -36,12 +34,16 @@ import qualified Data.Map as Map
 import Data.Maybe
 import Data.Monoid.DecidablyEmpty
 import Data.Semigroup (Semigroup (..), (<>))
+import Data.Semigroupoid as Cat
 import Data.Some (Some(Some))
 import Data.Proxy
 import Data.These
 import Data.Type.Equality ((:~:) (..))
 import Data.Kind (Constraint)
 
+import Data.Patch.Class
+import Data.Patch.MapWithMove (PatchMapWithMove (..))
+import qualified Data.Patch.MapWithMove as MapWithMove
 
 -- | Composition for constraints.
 class p (f a a) => DupC (p :: k2 -> Constraint) (f :: k1 -> k1 -> k2) (a :: k1)
@@ -53,13 +55,17 @@ type ConstraintsForZip f (c :: k -> Constraint) (g :: k' -> k' -> k) =
 type HasZip (c :: k -> Constraint) f (g :: k' -> k' -> k) =
   (ArgDict (DupC c g) f, ConstraintsForZip f c g)
 
--- | 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.
+-- | 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)@)
+--  * 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))
 
 deriving instance ( GShow k
@@ -79,13 +85,16 @@ deriving instance ( GCompare k
                   , Has' Ord k (PatchTarget1 p)
                   ) => Ord (PatchDMapWithMove k p)
 
--- |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.
+-- | 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 p a = NodeInfo
   { _nodeInfo_from :: !(From k p a)
-  -- ^Change applying to the current key, be it an insert, move, or delete.
-  , _nodeInfo_to :: !(Some (To k))
-  -- ^Where this key is moving to, if involved in a move. Should only be @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.
+  -- ^ Change applying to the current key, be it an insert, move, or delete.
+  , _nodeInfo_to :: !(To k p 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 instance ( Show (k a)
@@ -105,16 +114,92 @@ deriving instance ( Ord (k a)
                   , Ord (PatchTarget1 p a)
                   ) => Ord (NodeInfo k p a)
 
--- |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@).
+-- | Structure describing a particular change to a key, be it inserting a new
+-- key (@By_Insert@), updating an existing key (@By_Insert@ again), deleting
+-- a key (@By_Delete@), or moving a key (@By_Move@).
+--
+-- This type isn't used directly as the from field patch, but is instead wrapped
+-- in an existential. However, it is nice to be able to reason about this in
+-- isolation as it is itself a @Semigroupoid@ when the underlying patch is.
+data By (k :: a -> *) (p :: a -> a -> *) :: a -> a -> * where
+  -- | Insert a new or update an existing key with the given value @PatchTarget1
+  -- p a@
+  By_Insert :: PatchTarget1 p to -> By k p from to
+  -- | Delete the existing key
+  By_Delete :: By k p from to
+  -- | 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 @By_Delete@.
+  By_Move :: !(k from) -> p from to -> By k p from to
+
+deriving instance ( Show (k to)
+                  , Show (p from to)
+                  , Show (PatchTarget1 p to)
+                  ) => Show (By k p from to)
+deriving instance ( Read (k to)
+                  , Read (p from to)
+                  , Read (PatchTarget1 p to)
+                  ) => Read (By k p from to)
+deriving instance ( Eq (k to)
+                  , Eq (p from to)
+                  , Eq (PatchTarget1 p to)
+                  ) => Eq (By k p from to)
+deriving instance ( Ord (k to)
+                  , Ord (p from to)
+                  , Ord (PatchTarget1 p to)
+                  ) => Ord (By k p from to)
+
+mapByPatch
+  :: PatchTarget1 p0 ~ PatchTarget1 p1
+  => ((p0 from to) -> (p1 from to))
+  -> By k p0 from to
+  -> By k p1 from to
+mapByPatch f = \case
+  By_Insert v -> By_Insert v
+  By_Delete -> By_Delete
+  By_Move k p -> By_Move k $ f p
+
+-- | Compose patches having the same effect as applying the patches in turn:
+-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
+instance ( PatchSource1 p ~ PatchTarget1 p
+         , Cat.Semigroupoid p
+         , PatchHet2 p
+         ) => Cat.Semigroupoid (By k p) where
+  o p0 p1 = mapByPatch unProjectLocal $
+    oLocal (mapByPatch ProjectLocal p0) (mapByPatch ProjectLocal p1)
+
+oLocal
+  :: ( PatchSource1 p ~ PatchTarget1 p
+     , PatchHet2Locally p between after
+     )
+  => By k p between after
+  -> By k p before between
+  -> By k p before after
+By_Insert new `oLocal` _ = By_Insert new
+By_Delete `oLocal` _ = By_Delete
+By_Move _ x `oLocal` By_Insert y = By_Insert $ applyAlwaysHet2 x y
+By_Move _ x `oLocal` By_Move src y = By_Move src $ x `o` y
+By_Move _ _ `oLocal` By_Delete = By_Delete
+
+newtype Flip p to from = Flip (p from to)
+
+-- | 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@).
+--
+-- This type isn't used directly as the from field patch, but is instead wrapped
+-- in an existential. However, it is nice to be able to reason about this in
+-- isolation as it is itself a @Semigroupoid@ when the underlying patch is.
 data From (k :: a -> *) (p :: a -> a -> *) :: a -> * where
-  -- |Insert a new or update an existing key with the given value @PatchTarget1 p a@
-  From_Insert :: PatchTarget1 p a -> From k p a
-  -- |Delete the existing key
-  From_Delete :: From k p 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@.
-  From_Move :: !(k a0) -> p a0 a1 -> From k p a1
+  -- | Insert a new or update an existing key with the given value @PatchTarget1
+  -- p a@
+  From_Insert :: PatchTarget1 p to -> From k p to
+  -- | Delete the existing key
+  From_Delete :: From k p to
+  -- | 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@.
+  From_Move :: !(DSum k (Flip p to)) -> From k p to
 
 deriving instance ( Show (k a)
                   , Show (p a a)
@@ -125,30 +210,67 @@ deriving instance ( Read (k a)
                   , Read (PatchTarget1 p a)
                   ) => Read (From k p a)
 
+deriving instance ( GEq k
+                  , HasZip Eq k p
+                  , Eq (PatchTarget1 p a)
+                  ) => Eq (From k p a)
+
+deriving instance ( GCompare k
+                  , HasZip Ord k p
+                  , Ord (PatchTarget1 p a)
+                  ) => Ord (From k p a)
+
+-- | The "to" part of a 'NodeInfo'. Rather than be built out of @From@ like @From@
+-- is, we store just the information necessary to compose a @To@ and @From@ like
+-- @oLocal@ composes two @From@s.
+data To (k :: a -> *) (p :: a -> a -> *) :: a -> * where
+  -- | Delete or leave in place
+  To_NonMove :: To k p a0
+  -- | Move the value from the given key @k a@ to this key. The target key
+  -- should also have an entry in the patch giving the current key in
+  -- @_nodeInfo_from@, usually but not necessarily with @To_Delete@.
+  To_Move :: !(k a1) -> p a0 a1 -> To k p a0
+
+deriving instance ( Show (k a)
+                  , Show (p a a)
+                  , Show (PatchTarget1 p a)
+                  ) => Show (To k p a)
+deriving instance ( Read (k a)
+                  , Read (p a a)
+                  , Read (PatchTarget1 p a)
+                  ) => Read (To k p a)
+
 instance ( GEq k
          , HasZip Eq k p
          , Eq (PatchTarget1 p a)
-         ) => Eq (From k p a) where
-  From_Insert p0 == From_Insert p1 = p0 == p1
-  From_Delete == From_Delete = True
-  From_Move k0 p0 == From_Move k1 p1 = case geq k0 k1 of
+         ) => Eq (To k p a) where
+  To_NonMove == To_NonMove = True
+  To_Move k0 p0 == To_Move k1 p1 = case geq k0 k1 of
     Nothing -> False
     Just Refl -> has @(DupC Eq p) k0 $ p0 == p1
 
 instance ( GCompare k
          , HasZip Ord k p
          , Ord (PatchTarget1 p a)
-         ) => Ord (From k p a) where
-  From_Insert p0 `compare` From_Insert p1 = p0 `compare` p1
-  From_Delete `compare` From_Delete = EQ
-  From_Move k0 p0 `compare` From_Move k1 p1 = case gcompare k0 k1 of
+         ) => Ord (To k p a) where
+  To_NonMove `compare` To_NonMove = EQ
+  To_Move k0 p0 `compare` To_Move k1 p1 = case gcompare k0 k1 of
     DMap.GGT -> GT
     DMap.GEQ -> has @(DupC Ord p) k0 $ p0 `compare` p1
     DMap.GLT -> LT
 
--- |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
+--oToFrom
+--  :: ( PatchSource1 p ~ PatchTarget1 p
+--     , PatchHet2 p
+--     )
+--  => To k p between
+--  -> From k p between
+--  -> DSum k (From k p)
+--From_Insert new `oToFrom` _ = From_Insert new
+--From_Delete `oToFrom` _ = From_Delete
+--From_Move _ x `oToFrom` From_Insert y = From_Insert $ applyAlwaysHet2 x y
+--From_Move _ x `oToFrom` From_Move src y = From_Move src $ x `o` y
+--From_Move _ _ `oToFrom` From_Delete = From_Delete
 
 -- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
 validPatchDMapWithMove
@@ -168,25 +290,25 @@ validationErrorsForPatchDMapWithMove m =
   noSelfMoves <> movesBalanced
   where
     noSelfMoves = mapMaybe selfMove . DMap.toAscList $ m
-    selfMove (dst :=> NodeInfo (From_Move src _) _)
+    selfMove (dst :=> NodeInfo (From_Move (src :=> _)) _)
       | Just _ <- dst `geq` src = Just $ "self move of key " <> gshow src <> " at destination side"
-    selfMove (src :=> NodeInfo _ (Some (ComposeMaybe (Just dst))))
+    selfMove (src :=> NodeInfo _ (To_Move dst _))
       | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
     selfMove _ = Nothing
     movesBalanced = mapMaybe unbalancedMove . DMap.toAscList $ m
-    unbalancedMove (dst :=> NodeInfo (From_Move src _) _) =
+    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 _ (Some (ComposeMaybe (Just dst')))) ->
+        Just (NodeInfo _ (To_Move 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 _ (Some (ComposeMaybe (Just dst)))) =
+    unbalancedMove (src :=> NodeInfo _ (To_Move dst _)) =
       case DMap.lookup dst m of
         Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"
-        Just (NodeInfo (From_Move src' _) _) ->
+        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
@@ -198,36 +320,38 @@ validationErrorsForPatchDMapWithMove m =
 -- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
 data Pair1 f g a = Pair1 (f a) (g a)
 
-data PairHalf a f b = PairHalf a (f b)
-
 -- |Helper data structure used for composing patches using the monoid instance.
-data Fixup k v a
+data Fixup k p a
    = Fixup_Delete
-   | Fixup_Update (These (From k v a) (To k a))
+   | Fixup_Update (These (From k p a) (To k p a))
 
--- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
+-- | Compose patches having the same effect as applying the patches in turn:
+-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
 instance ( GCompare k
+         , Cat.Semigroupoid p
          -- , DecidablyEmpty p
          , PatchHet2 p
          ) => Semigroup (PatchDMapWithMove k p) where
   PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
     where
+      connections :: [DSum k (Pair1 (To k p) (From k p))]
       connections = DMap.toList $ DMap.intersectionWithKey
-        (\_ a b -> PairHalf (_nodeInfo_to a) (_nodeInfo_from b))
+        (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b))
         ma
         mb
-      h :: DSum k (PairHalf (Some (ComposeMaybe k)) (From k v)) -> [DSum k (Fixup k v)]
-      h (between :=> PairHalf (Some (ComposeMaybe mToAfter)) editBefore) = case (mToAfter, editBefore) of
-        (Just toAfter, From_Move fromBefore p)
-          | case fromBefore `geq` toAfter of
-              Nothing -> False
-              Just Refl -> isNull p
-            -> [toAfter :=> Fixup_Delete]
-          | otherwise
-            -> [ toAfter :=> Fixup_Update (This editBefore)
-               , fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))
-               ]
-        (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
+      h :: DSum k (Pair1 k (From k v)) -> [DSum k (Fixup k v)]
+      h (between :=> Pair1 editAfter editBefore) = case (editAfter, editBefore) of
+        (To_Move toAfter p1, From_Move (fromBefore :=> p0)) -> case toAfter `geq` fromBefore of
+          Just Refl | isNull p0 ->
+            [ toAfter :=> Fixup_Delete ]
+          _ ->
+            [ toAfter :=> Fixup_Update (This editBefore)
+            , fromBefore :=> Fixup_Update (That editAfter)
+            ]
+        (To_NonMove, From_Move (fromBefore :=> _)) ->
+          -- The item is destroyed in the second patch, so indicate that it is
+          -- destroyed in the source map
+          [fromBefore :=> Fixup_Update (That (ComposeMaybe editAfter))]
         (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)]
         (Nothing, _) -> []
       mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
@@ -246,11 +370,11 @@ instance ( GCompare k
         Fixup_Delete -> Nothing
         Fixup_Update u -> Just $ NodeInfo
           { _nodeInfo_from = case _nodeInfo_from ni of
-              f@(From_Move _ p') -> case getHere u of -- The `from` fixup comes from the "old" patch
+              f@(From_Move (_ :=> p')) -> case _here u of -- The `from` fixup comes from the "old" patch
                 Nothing -> f -- If there's no `from` fixup, just use the "new" `from`
                 Just (From_Insert v) -> From_Insert $ applyAlways p' v
                 Just From_Delete -> From_Delete
-                Just (From_Move oldKey p) -> From_Move oldKey $ p' <> p
+                Just (From_Move (oldKey :=> p)) -> From_Move $ oldKey :=> (p' <> p)
               _ -> error "DPatchMapWithMove: fixup for non-move From"
           , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
           }
@@ -306,7 +430,7 @@ insertDMapKey k v =
 moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
 moveDMapKey src dst = case src `geq` dst of
   Nothing -> PatchDMapWithMove $ DMap.fromList
-    [ dst :=> NodeInfo (From_Move src) (ComposeMaybe Nothing)
+    [ dst :=> NodeInfo (From_Move (src :=> Cat.id)) (ComposeMaybe Nothing)
     , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst)
     ]
   Just _ -> mempty
@@ -323,8 +447,8 @@ moveDMapKey src dst = case src `geq` dst of
 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)
+    [ dst :=> NodeInfo (From_Move (src :=> Cat.id)) (ComposeMaybe $ Just src)
+    , src :=> NodeInfo (From_Move (dst :=> Cat.id)) (ComposeMaybe $ Just dst)
     ]
   Just _ -> mempty
 
@@ -378,17 +502,20 @@ patchDMapWithMove dm =
 mapPatchDMapWithMove
   :: forall k p p'
   .  (forall a. PatchTarget1 p a -> PatchTarget1 p' a)
+  -> (forall from to. p from to -> p' from to)
   -> PatchDMapWithMove k p
   -> PatchDMapWithMove k p'
-mapPatchDMapWithMove f (PatchDMapWithMove p) = PatchDMapWithMove $
+mapPatchDMapWithMove f g (PatchDMapWithMove p) = PatchDMapWithMove $
   DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
   where g :: forall a. From k PatchTarget1 p a -> From k PatchTarget1 p' a
         g = \case
           From_Insert v -> From_Insert $ f v
           From_Delete -> From_Delete
-          From_Move k -> From_Move k
+          From_Move k p -> From_Move k $ g p
 
--- |Traverse an effectful function @forall a. PatchTarget1 p a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.
+-- | Traverse an effectful function @forall a. PatchTarget1 p a -> m (v ' a)@
+-- over the given patch, transforming @'PatchDMapWithMove' k v@ into @m
+-- ('PatchDMapWithMove' k v')@.
 traversePatchDMapWithMove
   :: forall m k p p'
   . Applicative m
@@ -397,7 +524,9 @@ traversePatchDMapWithMove
   -> m (PatchDMapWithMove k p')
 traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
 
--- |Map an effectful function @forall a. k a -> PatchTarget1 p a -> m (v ' a)@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @m ('PatchDMapWithMove' k v')@.
+-- | Map an effectful function @forall a. k a -> PatchTarget1 p a -> m (v ' a)@
+-- over the given patch, transforming @'PatchDMapWithMove' k v@ into @m
+-- ('PatchDMapWithMove' k v')@.
 traversePatchDMapWithMoveWithKey
   :: forall m k p p'
   . Applicative m
@@ -412,14 +541,16 @@ traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) =
           From_Delete -> pure From_Delete
           From_Move fromKey -> pure $ From_Move fromKey
 
--- |Map a function which transforms @'From' k PatchTarget1 p a@ into a @'From' k PatchTarget1 p' a@ over a @'NodeInfo' k PatchTarget1 p a@.
+-- | Map a function which transforms @'From k PatchTarget1 p a@ into a @'From k
+-- PatchTarget1 p' a@ over a @'NodeInfo' k PatchTarget1 p a@.
 nodeInfoMapFrom
   :: (From k p a -> From k p' a)
   -> NodeInfo k p a
   -> NodeInfo k p' a
 nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
 
--- |Map an effectful function which transforms @'From' k PatchTarget1 p a@ into a @f ('From' k PatchTarget1 p' a)@ over a @'NodeInfo' k PatchTarget1 p a@.
+-- | Map an effectful function which transforms @'From k PatchTarget1 p a@ into
+-- a @f ('From k PatchTarget1 p' a)@ over a @'NodeInfo' k PatchTarget1 p a@.
 nodeInfoMapFromM
   :: Functor f
   => (From k p a -> f (From k p' a))
@@ -427,8 +558,9 @@ nodeInfoMapFromM
   -> f (NodeInfo k p' 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 @PatchTarget1 p a -> v'@ to
--- values.
+-- | Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys
+-- from @k a@ to @'Some' k@ and applying a given weakening function
+-- @PatchTarget1 p a -> v'@ to values.
 weakenPatchDMapWithMoveWith
   :: forall k p v'
   .  (forall a. PatchTarget1 p a -> v')
@@ -444,8 +576,10 @@ weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenD
           , MapWithMove._nodeInfo_to = Some <$> getComposeMaybe (_nodeInfo_to ni)
           }
 
--- |"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.
+-- | "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 p v' a. (PatchTarget1 p a -> v')
   -> PatchDMapWithMove (Const2 k a) p
@@ -460,9 +594,11 @@ patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMo
           , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)
           }
 
--- |"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 @PatchTarget1 p' a@.
--- Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
+-- | "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 @PatchTarget1 p'
+-- a@. Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
 const2PatchDMapWithMoveWith
   :: forall k v p' a
   .  (v -> PatchTarget1 p' a)
@@ -483,7 +619,10 @@ instance GCompare k => PatchHet (PatchDMapWithMove k p) where
   type PatchSource (PatchDMapWithMove k p) = DMap k (PatchSource1 p)
   type PatchTarget (PatchDMapWithMove k p) = DMap k (PatchTarget1 p)
 instance GCompare k => Patch (PatchDMapWithMove k p) 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?
+  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 p a -> Maybe (PatchTarget1 p a)
           insertFunc _ ni = case _nodeInfo_from ni of
@@ -496,7 +635,8 @@ instance GCompare k => Patch (PatchDMapWithMove k p) where
             From_Delete -> Just $ Constant ()
             _ -> Nothing
 
--- | Get the values that will be replaced, deleted, or moved if the given patch is applied to the given 'DMap'.
+-- | Get the values that will be replaced, deleted, or moved if the given patch
+-- is applied to the given 'DMap'.
 getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))
 getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
   where f _ v ni = Pair v $ _nodeInfo_to ni
diff --git a/src/Data/Patch/DMapWithReset.hs b/src/Data/Patch/DMapWithReset.hs
index 9dd3b659..46db98c0 100644
--- a/src/Data/Patch/DMapWithReset.hs
+++ b/src/Data/Patch/DMapWithReset.hs
@@ -93,10 +93,12 @@ mergeWithKey f g fg = \xs ys -> DMap.mapMaybeWithKey onlyThat $ DMap.unionWithKe
 {-# INLINE mergeWithKey #-}
 
 -- | Apply the insertions or deletions to a given 'DMap'.
-instance (GCompare k, Has (Patches1Locally p) k) => Patch (PatchDMapWithReset k p) where
+instance (GCompare k, Has (Patches1Locally p) k) => PatchHet (PatchDMapWithReset k p) where
 
+  type PatchSource (PatchDMapWithReset k p) = DMap k (Patches1LocallyTarget p)
   type PatchTarget (PatchDMapWithReset k p) = DMap k (Patches1LocallyTarget p)
 
+instance (GCompare k, Has (Patches1Locally p) k) => Patch (PatchDMapWithReset k p) where
   apply = go
     where
       go :: PatchDMapWithReset k p -> DMap k (Patches1LocallyTarget p) -> Maybe (DMap k (Patches1LocallyTarget p))

From 69a7ab8020bf03eb730f1cdbbc4f354907b1aaa3 Mon Sep 17 00:00:00 2001
From: John Ericson <git@JohnEricson.me>
Date: Sat, 11 Jan 2020 16:29:59 -0500
Subject: [PATCH 09/27] Over the hill

---
 src/Data/Patch/DMapWithMove.hs | 93 ++++++++++++++++------------------
 1 file changed, 45 insertions(+), 48 deletions(-)

diff --git a/src/Data/Patch/DMapWithMove.hs b/src/Data/Patch/DMapWithMove.hs
index d3a6c7dc..e57d9642 100644
--- a/src/Data/Patch/DMapWithMove.hs
+++ b/src/Data/Patch/DMapWithMove.hs
@@ -225,11 +225,11 @@ deriving instance ( GCompare k
 -- @oLocal@ composes two @From@s.
 data To (k :: a -> *) (p :: a -> a -> *) :: a -> * where
   -- | Delete or leave in place
-  To_NonMove :: To k p a0
+  To_NonMove :: To k p from
   -- | Move the value from the given key @k a@ to this key. The target key
   -- should also have an entry in the patch giving the current key in
   -- @_nodeInfo_from@, usually but not necessarily with @To_Delete@.
-  To_Move :: !(k a1) -> p a0 a1 -> To k p a0
+  To_Move :: !(DSum k (p from)) -> To k p from
 
 deriving instance ( Show (k a)
                   , Show (p a a)
@@ -240,24 +240,15 @@ deriving instance ( Read (k a)
                   , Read (PatchTarget1 p a)
                   ) => Read (To k p a)
 
-instance ( GEq k
-         , HasZip Eq k p
-         , Eq (PatchTarget1 p a)
-         ) => Eq (To k p a) where
-  To_NonMove == To_NonMove = True
-  To_Move k0 p0 == To_Move k1 p1 = case geq k0 k1 of
-    Nothing -> False
-    Just Refl -> has @(DupC Eq p) k0 $ p0 == p1
+deriving instance ( GEq k
+                  , HasZip Eq k p
+                  , Eq (PatchTarget1 p a)
+                  ) => Eq (To k p a)
 
-instance ( GCompare k
-         , HasZip Ord k p
-         , Ord (PatchTarget1 p a)
-         ) => Ord (To k p a) where
-  To_NonMove `compare` To_NonMove = EQ
-  To_Move k0 p0 `compare` To_Move k1 p1 = case gcompare k0 k1 of
-    DMap.GGT -> GT
-    DMap.GEQ -> has @(DupC Ord p) k0 $ p0 `compare` p1
-    DMap.GLT -> LT
+deriving instance ( GCompare k
+                  , HasZip Ord k p
+                  , Ord (PatchTarget1 p a)
+                  ) => Ord (To k p a)
 
 --oToFrom
 --  :: ( PatchSource1 p ~ PatchTarget1 p
@@ -292,20 +283,20 @@ validationErrorsForPatchDMapWithMove m =
     noSelfMoves = mapMaybe 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 _ (To_Move dst _))
+    selfMove (src :=> NodeInfo _ (To_Move (dst :=> _)))
       | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
     selfMove _ = Nothing
     movesBalanced = mapMaybe 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 _ (To_Move dst' _)) ->
+        Just (NodeInfo _ (To_Move (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 _ (To_Move dst _)) =
+    unbalancedMove (src :=> NodeInfo _ (To_Move (dst :=> _))) =
       case DMap.lookup dst m of
         Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"
         Just (NodeInfo (From_Move (src' :=> _)) _) ->
@@ -331,6 +322,7 @@ instance ( GCompare k
          , Cat.Semigroupoid p
          -- , DecidablyEmpty p
          , PatchHet2 p
+         , PatchSource1 p ~ PatchTarget1 p
          ) => Semigroup (PatchDMapWithMove k p) where
   PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
     where
@@ -339,21 +331,26 @@ instance ( GCompare k
         (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b))
         ma
         mb
-      h :: DSum k (Pair1 k (From k v)) -> [DSum k (Fixup k v)]
-      h (between :=> Pair1 editAfter editBefore) = case (editAfter, editBefore) of
-        (To_Move toAfter p1, From_Move (fromBefore :=> p0)) -> case toAfter `geq` fromBefore of
-          Just Refl | isNull p0 ->
-            [ toAfter :=> Fixup_Delete ]
-          _ ->
-            [ toAfter :=> Fixup_Update (This editBefore)
-            , fromBefore :=> Fixup_Update (That editAfter)
-            ]
+      h :: DSum k (Pair1 (To k p) (From k p)) -> [DSum k (Fixup k p)]
+      h ((between :: k between) :=> Pair1 editAfter editBefore) = case (editAfter, editBefore) of
+        (To_Move ((toAfter :: k after) :=> p1), From_Move ((fromBefore :: k before) :=> Flip p0)) ->
+          case toAfter `geq` fromBefore of
+            Just Refl | isNull p0 ->
+              [ toAfter :=> Fixup_Delete ]
+            _ ->
+              [ toAfter :=> Fixup_Update (This $ From_Move $ fromBefore :=> (Flip $ p1 `o` p0))
+              , fromBefore :=> Fixup_Update (That $ To_Move $ toAfter :=> (p1 `o` p0))
+              ]
         (To_NonMove, From_Move (fromBefore :=> _)) ->
           -- The item is destroyed in the second patch, so indicate that it is
           -- destroyed in the source map
-          [fromBefore :=> Fixup_Update (That (ComposeMaybe editAfter))]
-        (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)]
-        (Nothing, _) -> []
+          [fromBefore :=> Fixup_Update (That To_NonMove)]
+        (To_Move (toAfter :=> p), From_Insert val) ->
+          [toAfter :=> Fixup_Update (This $ From_Insert $ applyAlwaysHet2 p val)]
+        (To_Move (toAfter :=> p), From_Delete) ->
+          [toAfter :=> Fixup_Update (This From_Delete)]
+        (To_NonMove, _) ->
+          []
       mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
       mergeFixups _ (Fixup_Update a) (Fixup_Update b)
         | This x <- a, That y <- b
@@ -369,13 +366,7 @@ instance ( GCompare k
       applyFixup _ ni = \case
         Fixup_Delete -> Nothing
         Fixup_Update u -> Just $ NodeInfo
-          { _nodeInfo_from = case _nodeInfo_from ni of
-              f@(From_Move (_ :=> p')) -> case _here u of -- The `from` fixup comes from the "old" patch
-                Nothing -> f -- If there's no `from` fixup, just use the "new" `from`
-                Just (From_Insert v) -> From_Insert $ applyAlways p' v
-                Just From_Delete -> From_Delete
-                Just (From_Move (oldKey :=> p)) -> From_Move $ oldKey :=> (p' <> p)
-              _ -> error "DPatchMapWithMove: fixup for non-move From"
+          { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
           , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
           }
       m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups
@@ -390,8 +381,14 @@ instance ( GCompare k
         These _ b -> Just b
         That b -> Just b
 
--- |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
+-- | Compose patches having the same effect as applying the patches in turn:
+-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
+instance ( GCompare k
+         , Cat.Semigroupoid p
+         -- , DecidablyEmpty p
+         , PatchHet2 p
+         , PatchSource1 p ~ PatchTarget1 p
+         ) => Monoid (PatchDMapWithMove k p) where
   mempty = PatchDMapWithMove mempty
   mappend = (<>)
 
@@ -420,18 +417,18 @@ PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWith
 -- |Make a @'PatchDMapWithMove' k v@ which has the effect of inserting or updating a value @PatchTarget1 p a@ to the given key @k a@, like 'DMap.insert'.
 insertDMapKey :: k a -> PatchTarget1 p a -> PatchDMapWithMove k p
 insertDMapKey k v =
-  PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) (ComposeMaybe Nothing)
+  PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) To_NonMove
 
 -- |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 :: GCompare k => k a -> k a -> PatchDMapWithMove k (Proxy2 v)
 moveDMapKey src dst = case src `geq` dst of
   Nothing -> PatchDMapWithMove $ DMap.fromList
-    [ dst :=> NodeInfo (From_Move (src :=> Cat.id)) (ComposeMaybe Nothing)
-    , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst)
+    [ dst :=> NodeInfo (From_Move (src :=> Cat.id)) To_NonMove
+    , src :=> NodeInfo From_Delete (To_Move $ dst :=> Proxy2)
     ]
   Just _ -> mempty
 
@@ -448,7 +445,7 @@ 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 :=> Cat.id)) (ComposeMaybe $ Just src)
-    , src :=> NodeInfo (From_Move (dst :=> Cat.id)) (ComposeMaybe $ Just dst)
+    , src :=> NodeInfo (From_Move (dst :=> Cat.id)) (To_Move $ dst :=> Proxy2)
     ]
   Just _ -> mempty
 

From 3f037af800e0f74cf70badd4255e3c2cd6913da5 Mon Sep 17 00:00:00 2001
From: John Ericson <git@JohnEricson.me>
Date: Sat, 11 Jan 2020 19:23:48 -0500
Subject: [PATCH 10/27] Get everything type checking again

---
 src/Data/Functor/Misc.hs       |  33 ++-
 src/Data/Patch/Class.hs        |  41 ++--
 src/Data/Patch/DMapWithMove.hs | 415 ++++++++++++++++-----------------
 src/Data/Patch/MapWithMove.hs  | 103 ++++----
 4 files changed, 307 insertions(+), 285 deletions(-)

diff --git a/src/Data/Functor/Misc.hs b/src/Data/Functor/Misc.hs
index a09d4a9e..f57cc766 100644
--- a/src/Data/Functor/Misc.hs
+++ 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
diff --git a/src/Data/Patch/Class.hs b/src/Data/Patch/Class.hs
index 80e4aee5..af848d78 100644
--- a/src/Data/Patch/Class.hs
+++ b/src/Data/Patch/Class.hs
@@ -1,5 +1,7 @@
 {-# LANGUAGE DefaultSignatures #-}
 {-# LANGUAGE DeriveTraversable #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE PolyKinds #-}
@@ -8,7 +10,9 @@
 -- | 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
@@ -128,6 +132,7 @@ applyAlwaysHet2 p t = case applyHet2 p t of
 
 -- | 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
@@ -145,24 +150,18 @@ instance ( PatchHet2Base p
          , PatchSource1 p ~ PatchTarget1 p
          ) => Patch2 p
 
-newtype Replace2 (t :: k -> *) (a :: k) (b :: k) = Replace2 (t b)
-  deriving ( Show, Read, Eq, Ord
-           , Functor, Foldable, Traversable
-           )
-
-data Proxy2 t a b = Proxy2
-  deriving ( Show, Read, Eq, Ord
-           , Functor, Foldable, Traversable
-           )
-
--- | 'Replace2' can be used as a 'Patch' that always fully replaces the value
-instance PatchHet (Replace2 (t :: k -> *) (from :: k) (to :: k)) where
-  type PatchSource (Replace2 t from to) = t from
-  type PatchTarget (Replace2 t from to) = t to
-  applyHet (Replace2 val) _ = Right val
-
--- | 'Proxy2' can be used as a 'Patch' that always does nothing
-instance PatchHet (Proxy2 (t :: k -> *) (a :: k) (a :: k)) where
-  type PatchSource (Proxy2 t a a) = t a
-  type PatchTarget (Proxy2 t a a) = t a
-  applyHet ~Proxy2 _ = Left Refl
+-- | '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
diff --git a/src/Data/Patch/DMapWithMove.hs b/src/Data/Patch/DMapWithMove.hs
index e57d9642..1a0927cf 100644
--- a/src/Data/Patch/DMapWithMove.hs
+++ b/src/Data/Patch/DMapWithMove.hs
@@ -21,40 +21,36 @@
 module Data.Patch.DMapWithMove where
 
 import qualified Control.Category as Cat
-import Data.Constraint.Extras
-import Data.Constraint.Compose
-import Data.Dependent.Map (DMap, DSum (..), GCompare (..))
+--import qualified Control.Category.DecidablyEmpty as Cat
+import Data.Constraint.Extras (Has')
+import Data.Dependent.Map (DMap)
+import Data.Dependent.Sum (DSum (..))
 import qualified Data.Dependent.Map as DMap
-import Data.Functor.Constant
+import Data.Functor.Constant (Constant (..))
 import Data.Functor.Misc
-import Data.Functor.Product
-import Data.GADT.Compare (GEq (..), GCompare)
+  ( Const2 (..), Proxy3 (..)
+  , weakenDMapWith
+  , dmapToMapWith
+  )
+import Data.Functor.Product (Product (..))
+import Data.GADT.Compare (GEq (..), GCompare (..))
 import Data.GADT.Show (GRead, GShow, gshow)
 import qualified Data.Map as Map
 import Data.Maybe
-import Data.Monoid.DecidablyEmpty
 import Data.Semigroup (Semigroup (..), (<>))
 import Data.Semigroupoid as Cat
 import Data.Some (Some(Some))
-import Data.Proxy
-import Data.These
-import Data.Type.Equality ((:~:) (..))
-import Data.Kind (Constraint)
+import Data.Proxy (Proxy (..))
+import Data.These (These (..))
 
 import Data.Patch.Class
+  ( Patch (..), PatchHet (..)
+  , PatchHet2 (..), PatchSource1, PatchTarget1
+  , applyAlwaysHet2
+  )
 import Data.Patch.MapWithMove (PatchMapWithMove (..))
 import qualified Data.Patch.MapWithMove as MapWithMove
 
--- | Composition for constraints.
-class p (f a a) => DupC (p :: k2 -> Constraint) (f :: k1 -> k1 -> k2) (a :: k1)
-instance p (f a a) => DupC p f a
-
-type ConstraintsForZip f (c :: k -> Constraint) (g :: k' -> k' -> k) =
-  ConstraintsFor f (DupC c g)
-
-type HasZip (c :: k -> Constraint) f (g :: k' -> k' -> k) =
-  (ArgDict (DupC c g) f, ConstraintsForZip f c g)
-
 -- | 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.
@@ -68,22 +64,22 @@ type HasZip (c :: k -> Constraint) f (g :: k' -> k' -> k) =
 --    destination)@)
 newtype PatchDMapWithMove k v = PatchDMapWithMove (DMap k (NodeInfo k v))
 
-deriving instance ( GShow k
-                  , HasZip Show k p
-                  , Has' Show k (PatchTarget1 p)
-                  ) => Show (PatchDMapWithMove k p)
-deriving instance ( GRead k
-                  , HasZip Read k p
-                  , Has' Read k (PatchTarget1 p)
-                  ) => Read (PatchDMapWithMove k p)
-deriving instance ( GEq k
-                  , HasZip Eq k p
-                  , Has' Eq k (PatchTarget1 p)
-                  ) => Eq (PatchDMapWithMove k p)
-deriving instance ( GCompare k
-                  , HasZip Ord k p
-                  , Has' Ord k (PatchTarget1 p)
-                  ) => Ord (PatchDMapWithMove k p)
+--deriving instance ( GShow k
+--                  , HasZip Show k p
+--                  , Has' Show k (PatchTarget1 p)
+--                  ) => Show (PatchDMapWithMove k p)
+--deriving instance ( GRead k
+--                  , HasZip Read k p
+--                  , Has' Read k (PatchTarget1 p)
+--                  ) => Read (PatchDMapWithMove k p)
+--deriving instance ( GEq k
+--                  , HasZip Eq k p
+--                  , Has' Eq k (PatchTarget1 p)
+--                  ) => Eq (PatchDMapWithMove k p)
+--deriving instance ( GCompare k
+--                  , HasZip Ord k p
+--                  , Has' Ord k (PatchTarget1 p)
+--                  ) => Ord (PatchDMapWithMove k p)
 
 -- | Structure which represents what changes apply to a particular key.
 -- @_nodeInfo_from@ specifies what happens to this key, and in particular what
@@ -97,91 +93,22 @@ data NodeInfo k p a = NodeInfo
   -- @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.
   }
 
-deriving instance ( Show (k a)
-                  , Show (p a a)
-                  , Show (PatchTarget1 p a)
-                  ) => Show (NodeInfo k p a)
-deriving instance ( Read (k a)
-                  , Read (p a a)
-                  , Read (PatchTarget1 p a)
-                  ) => Read (NodeInfo k p a)
-deriving instance ( Eq (k a)
-                  , Eq (p a a)
-                  , Eq (PatchTarget1 p a)
-                  ) => Eq (NodeInfo k p a)
-deriving instance ( Ord (k a)
-                  , Ord (p a a)
-                  , Ord (PatchTarget1 p a)
-                  ) => Ord (NodeInfo k p a)
-
--- | Structure describing a particular change to a key, be it inserting a new
--- key (@By_Insert@), updating an existing key (@By_Insert@ again), deleting
--- a key (@By_Delete@), or moving a key (@By_Move@).
---
--- This type isn't used directly as the from field patch, but is instead wrapped
--- in an existential. However, it is nice to be able to reason about this in
--- isolation as it is itself a @Semigroupoid@ when the underlying patch is.
-data By (k :: a -> *) (p :: a -> a -> *) :: a -> a -> * where
-  -- | Insert a new or update an existing key with the given value @PatchTarget1
-  -- p a@
-  By_Insert :: PatchTarget1 p to -> By k p from to
-  -- | Delete the existing key
-  By_Delete :: By k p from to
-  -- | 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 @By_Delete@.
-  By_Move :: !(k from) -> p from to -> By k p from to
-
-deriving instance ( Show (k to)
-                  , Show (p from to)
-                  , Show (PatchTarget1 p to)
-                  ) => Show (By k p from to)
-deriving instance ( Read (k to)
-                  , Read (p from to)
-                  , Read (PatchTarget1 p to)
-                  ) => Read (By k p from to)
-deriving instance ( Eq (k to)
-                  , Eq (p from to)
-                  , Eq (PatchTarget1 p to)
-                  ) => Eq (By k p from to)
-deriving instance ( Ord (k to)
-                  , Ord (p from to)
-                  , Ord (PatchTarget1 p to)
-                  ) => Ord (By k p from to)
-
-mapByPatch
-  :: PatchTarget1 p0 ~ PatchTarget1 p1
-  => ((p0 from to) -> (p1 from to))
-  -> By k p0 from to
-  -> By k p1 from to
-mapByPatch f = \case
-  By_Insert v -> By_Insert v
-  By_Delete -> By_Delete
-  By_Move k p -> By_Move k $ f p
-
--- | Compose patches having the same effect as applying the patches in turn:
--- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
-instance ( PatchSource1 p ~ PatchTarget1 p
-         , Cat.Semigroupoid p
-         , PatchHet2 p
-         ) => Cat.Semigroupoid (By k p) where
-  o p0 p1 = mapByPatch unProjectLocal $
-    oLocal (mapByPatch ProjectLocal p0) (mapByPatch ProjectLocal p1)
-
-oLocal
-  :: ( PatchSource1 p ~ PatchTarget1 p
-     , PatchHet2Locally p between after
-     )
-  => By k p between after
-  -> By k p before between
-  -> By k p before after
-By_Insert new `oLocal` _ = By_Insert new
-By_Delete `oLocal` _ = By_Delete
-By_Move _ x `oLocal` By_Insert y = By_Insert $ applyAlwaysHet2 x y
-By_Move _ x `oLocal` By_Move src y = By_Move src $ x `o` y
-By_Move _ _ `oLocal` By_Delete = By_Delete
-
-newtype Flip p to from = Flip (p from to)
+--deriving instance ( Show (k a)
+--                  , Show (p a a)
+--                  , Show (PatchTarget1 p a)
+--                  ) => Show (NodeInfo k p a)
+--deriving instance ( Read (k a)
+--                  , Read (p a a)
+--                  , Read (PatchTarget1 p a)
+--                  ) => Read (NodeInfo k p a)
+--deriving instance ( Eq (k a)
+--                  , Eq (p a a)
+--                  , Eq (PatchTarget1 p a)
+--                  ) => Eq (NodeInfo k p a)
+--deriving instance ( Ord (k a)
+--                  , Ord (p a a)
+--                  , Ord (PatchTarget1 p a)
+--                  ) => Ord (NodeInfo k p a)
 
 -- | Structure describing a particular change to a key, be it inserting a new
 -- key (@From_Insert@), updating an existing key (@From_Insert@ again), deleting
@@ -201,25 +128,30 @@ data From (k :: a -> *) (p :: a -> a -> *) :: a -> * where
   -- @_nodeInfo_to@, usually but not necessarily with @From_Delete@.
   From_Move :: !(DSum k (Flip p to)) -> From k p to
 
-deriving instance ( Show (k a)
-                  , Show (p a a)
+deriving instance ( Show (k a), GShow k
+                  , Has' Show k (Flip p a)
                   , Show (PatchTarget1 p a)
                   ) => Show (From k p a)
-deriving instance ( Read (k a)
-                  , Read (p a a)
+deriving instance ( Read (k a), GRead k
+                  , Has' Read k (Flip p a)
                   , Read (PatchTarget1 p a)
                   ) => Read (From k p a)
-
 deriving instance ( GEq k
-                  , HasZip Eq k p
+                  , Has' Eq k (Flip p a)
                   , Eq (PatchTarget1 p a)
                   ) => Eq (From k p a)
-
 deriving instance ( GCompare k
-                  , HasZip Ord k p
+                  , Has' Eq k (Flip p a) -- superclass bug
+                  , Has' Ord k (Flip p a)
                   , Ord (PatchTarget1 p a)
                   ) => Ord (From k p a)
 
+newtype Flip p to from = Flip (p from to)
+
+instance Cat.Category p => Cat.Category (Flip (p :: k -> k -> *)) where
+  id = Flip Cat.id
+  Flip y . Flip x = Flip $ x Cat.. y
+
 -- | The "to" part of a 'NodeInfo'. Rather than be built out of @From@ like @From@
 -- is, we store just the information necessary to compose a @To@ and @From@ like
 -- @oLocal@ composes two @From@s.
@@ -231,38 +163,24 @@ data To (k :: a -> *) (p :: a -> a -> *) :: a -> * where
   -- @_nodeInfo_from@, usually but not necessarily with @To_Delete@.
   To_Move :: !(DSum k (p from)) -> To k p from
 
-deriving instance ( Show (k a)
-                  , Show (p a a)
+deriving instance ( Show (k a), GShow k
+                  , Has' Show k (p a)
                   , Show (PatchTarget1 p a)
                   ) => Show (To k p a)
-deriving instance ( Read (k a)
-                  , Read (p a a)
+deriving instance ( Read (k a), GRead k
+                  , Has' Read k (p a)
                   , Read (PatchTarget1 p a)
                   ) => Read (To k p a)
-
 deriving instance ( GEq k
-                  , HasZip Eq k p
+                  , Has' Eq k (p a)
                   , Eq (PatchTarget1 p a)
                   ) => Eq (To k p a)
-
 deriving instance ( GCompare k
-                  , HasZip Ord k p
+                  , Has' Eq k (p a) -- superclass bug
+                  , Has' Ord k (p a)
                   , Ord (PatchTarget1 p a)
                   ) => Ord (To k p a)
 
---oToFrom
---  :: ( PatchSource1 p ~ PatchTarget1 p
---     , PatchHet2 p
---     )
---  => To k p between
---  -> From k p between
---  -> DSum k (From k p)
---From_Insert new `oToFrom` _ = From_Insert new
---From_Delete `oToFrom` _ = From_Delete
---From_Move _ x `oToFrom` From_Insert y = From_Insert $ applyAlwaysHet2 x y
---From_Move _ x `oToFrom` From_Move src y = From_Move src $ x `o` y
---From_Move _ _ `oToFrom` From_Delete = From_Delete
-
 -- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
 validPatchDMapWithMove
   :: forall k v
@@ -320,7 +238,7 @@ data Fixup k p a
 -- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
 instance ( GCompare k
          , Cat.Semigroupoid p
-         -- , DecidablyEmpty p
+         -- , Cat.DecidablyEmpty p
          , PatchHet2 p
          , PatchSource1 p ~ PatchTarget1 p
          ) => Semigroup (PatchDMapWithMove k p) where
@@ -332,12 +250,12 @@ instance ( GCompare k
         ma
         mb
       h :: DSum k (Pair1 (To k p) (From k p)) -> [DSum k (Fixup k p)]
-      h ((between :: k between) :=> Pair1 editAfter editBefore) = case (editAfter, editBefore) of
+      h ((_ :: k between) :=> Pair1 editAfter editBefore) = case (editAfter, editBefore) of
         (To_Move ((toAfter :: k after) :=> p1), From_Move ((fromBefore :: k before) :=> Flip p0)) ->
-          case toAfter `geq` fromBefore of
-            Just Refl | isNull p0 ->
-              [ toAfter :=> Fixup_Delete ]
-            _ ->
+          --case toAfter `geq` fromBefore of
+          --  Just Refl | Just Refl <- Cat.isId p0 ->
+          --    [ toAfter :=> Fixup_Delete ]
+          --  _ ->
               [ toAfter :=> Fixup_Update (This $ From_Move $ fromBefore :=> (Flip $ p1 `o` p0))
               , fromBefore :=> Fixup_Update (That $ To_Move $ toAfter :=> (p1 `o` p0))
               ]
@@ -347,7 +265,7 @@ instance ( GCompare k
           [fromBefore :=> Fixup_Update (That To_NonMove)]
         (To_Move (toAfter :=> p), From_Insert val) ->
           [toAfter :=> Fixup_Update (This $ From_Insert $ applyAlwaysHet2 p val)]
-        (To_Move (toAfter :=> p), From_Delete) ->
+        (To_Move (toAfter :=> _), From_Delete) ->
           [toAfter :=> Fixup_Update (This From_Delete)]
         (To_NonMove, _) ->
           []
@@ -414,25 +332,31 @@ 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 @PatchTarget1 p a@ to the given key @k a@, like 'DMap.insert'.
+-- | Make a @'PatchDMapWithMove' k v@ which has the effect of inserting or
+-- updating a value @PatchTarget1 p a@ to the given key @k a@, like
+-- 'DMap.insert'.
 insertDMapKey :: k a -> PatchTarget1 p a -> PatchDMapWithMove k p
 insertDMapKey k v =
   PatchDMapWithMove . DMap.singleton k $ NodeInfo (From_Insert v) To_NonMove
 
--- |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:
+-- | 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 (Proxy2 v)
+moveDMapKey
+  :: GCompare k
+  => k a -> k a -> PatchDMapWithMove k (Proxy3 v)
 moveDMapKey src dst = case src `geq` dst of
   Nothing -> PatchDMapWithMove $ DMap.fromList
-    [ dst :=> NodeInfo (From_Move (src :=> Cat.id)) To_NonMove
-    , src :=> NodeInfo From_Delete (To_Move $ dst :=> Proxy2)
+    [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) To_NonMove
+    , src :=> NodeInfo From_Delete (To_Move $ dst :=> Proxy3)
     ]
-  Just _ -> mempty
+  Just _ -> PatchDMapWithMove DMap.empty
 
--- |Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
+-- | Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys
+-- in the mapping, equivalent to:
 --
 -- @
 --     let aMay = DMap.lookup a dmap
@@ -441,17 +365,18 @@ moveDMapKey src dst = case src `geq` dst of
 --      . 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 :: GCompare k => k a -> k a -> PatchDMapWithMove k (Proxy3 v)
 swapDMapKey src dst = case src `geq` dst of
   Nothing -> PatchDMapWithMove $ DMap.fromList
-    [ dst :=> NodeInfo (From_Move (src :=> Cat.id)) (ComposeMaybe $ Just src)
-    , src :=> NodeInfo (From_Move (dst :=> Cat.id)) (To_Move $ dst :=> Proxy2)
+    [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) (To_Move $ src :=> Proxy3)
+    , src :=> NodeInfo (From_Move (dst :=> Flip Proxy3)) (To_Move $ dst :=> Proxy3)
     ]
-  Just _ -> mempty
+  Just _ -> PatchDMapWithMove DMap.empty
 
--- |Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'DMap.delete'.
+-- | 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
+deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete To_NonMove
 
 {-
 k1, k2 :: Const2 Int () ()
@@ -477,17 +402,20 @@ dst (PatchDMapWithMove x _) = x
 src (PatchDMapWithMove _ x) = x
 -}
 
--- |Extract the 'DMap' representing the patch changes from the 'PatchDMapWithMove'.
+-- | Extract the 'DMap' representing the patch changes from the
+-- 'PatchDMapWithMove'.
 unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)
 unPatchDMapWithMove (PatchDMapWithMove p) = p
 
--- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove', without checking any invariants.
+-- | 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
+-- | 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, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)
 patchDMapWithMove dm =
@@ -495,20 +423,28 @@ patchDMapWithMove dm =
     [] -> Right $ unsafePatchDMapWithMove dm
     errs -> Left errs
 
--- |Map a natural transform @v -> v'@ over the given patch, transforming @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.
+-- | Map a natural transform @v -> v'@ over the given patch, transforming
+-- @'PatchDMapWithMove' k v@ into @'PatchDMapWithMove' k v'@.
 mapPatchDMapWithMove
   :: forall k p p'
   .  (forall a. PatchTarget1 p a -> PatchTarget1 p' a)
   -> (forall from to. p from to -> p' from to)
   -> PatchDMapWithMove k p
   -> PatchDMapWithMove k p'
-mapPatchDMapWithMove f g (PatchDMapWithMove p) = PatchDMapWithMove $
-  DMap.map (\ni -> ni { _nodeInfo_from = g $ _nodeInfo_from ni }) p
-  where g :: forall a. From k PatchTarget1 p a -> From k PatchTarget1 p' a
-        g = \case
+mapPatchDMapWithMove f g (PatchDMapWithMove m) =
+  PatchDMapWithMove $ DMap.map (\ni -> NodeInfo
+    { _nodeInfo_from = h $ _nodeInfo_from ni
+    , _nodeInfo_to = j $ _nodeInfo_to ni
+    }) m
+  where h :: forall a. From k p a -> From k p' a
+        h = \case
           From_Insert v -> From_Insert $ f v
           From_Delete -> From_Delete
-          From_Move k p -> From_Move k $ g p
+          From_Move (k :=> (Flip p)) -> From_Move $ k :=> Flip (g p)
+        j :: forall a. To k p a -> To k p' a
+        j = \case
+          To_NonMove -> To_NonMove
+          To_Move (k :=> p) -> To_Move $ k :=> g p
 
 -- | Traverse an effectful function @forall a. PatchTarget1 p a -> m (v ' a)@
 -- over the given patch, transforming @'PatchDMapWithMove' k v@ into @m
@@ -517,9 +453,12 @@ traversePatchDMapWithMove
   :: forall m k p p'
   . Applicative m
   => (forall a. PatchTarget1 p a -> m (PatchTarget1 p' a))
+  -> (forall from to. p from to -> m (p' from to))
   -> PatchDMapWithMove k p
   -> m (PatchDMapWithMove k p')
-traversePatchDMapWithMove f = traversePatchDMapWithMoveWithKey $ const f
+traversePatchDMapWithMove f g = traversePatchDMapWithMoveWithKey
+  (\_ -> f)
+  (\_ _ -> g)
 
 -- | Map an effectful function @forall a. k a -> PatchTarget1 p a -> m (v ' a)@
 -- over the given patch, transforming @'PatchDMapWithMove' k v@ into @m
@@ -528,49 +467,67 @@ traversePatchDMapWithMoveWithKey
   :: forall m k p p'
   . Applicative m
   => (forall a. k a -> PatchTarget1 p a -> m (PatchTarget1 p' a))
+  -> (forall from to. k from -> k to -> p from to -> m (p' from to))
   -> PatchDMapWithMove k p
   -> m (PatchDMapWithMove k p')
-traversePatchDMapWithMoveWithKey f (PatchDMapWithMove p) =
-  PatchDMapWithMove <$> DMap.traverseWithKey (nodeInfoMapFromM . g) p
-  where g :: forall a. k a -> From k PatchTarget1 p a -> m (From k PatchTarget1 p' a)
-        g k = \case
+traversePatchDMapWithMoveWithKey f g (PatchDMapWithMove m) =
+  fmap PatchDMapWithMove $ DMap.traverseWithKey (\k  ni -> NodeInfo
+    <$> (h k $ _nodeInfo_from ni)
+    <*> (j k $ _nodeInfo_to ni)) m
+  where h :: forall a. k a -> From k p a -> m (From k p' a)
+        h k = \case
           From_Insert v -> From_Insert <$> f k v
           From_Delete -> pure From_Delete
-          From_Move fromKey -> pure $ From_Move fromKey
+          From_Move (fromKey :=> Flip p) -> From_Move . (fromKey :=>) . Flip <$> g fromKey k p
+        j :: forall a. k a -> To k p a -> m (To k p' a)
+        j k = \case
+          To_NonMove -> pure To_NonMove
+          To_Move (toKey :=> p) -> To_Move . (toKey :=>) <$> g k toKey p
 
 -- | Map a function which transforms @'From k PatchTarget1 p a@ into a @'From k
 -- PatchTarget1 p' a@ over a @'NodeInfo' k PatchTarget1 p a@.
 nodeInfoMapFrom
   :: (From k p a -> From k p' a)
+  -> (To k p a -> To k p' a)
   -> NodeInfo k p a
   -> NodeInfo k p' a
-nodeInfoMapFrom f ni = ni { _nodeInfo_from = f $ _nodeInfo_from ni }
+nodeInfoMapFrom f g ni = NodeInfo
+  { _nodeInfo_from = f $ _nodeInfo_from ni
+  , _nodeInfo_to = g $ _nodeInfo_to ni
+  }
 
 -- | Map an effectful function which transforms @'From k PatchTarget1 p a@ into
 -- a @f ('From k PatchTarget1 p' a)@ over a @'NodeInfo' k PatchTarget1 p a@.
 nodeInfoMapFromM
-  :: Functor f
+  :: Applicative f
   => (From k p a -> f (From k p' a))
+  -> (To k p a -> f (To k p' a))
   -> NodeInfo k p a
   -> f (NodeInfo k p' a)
-nodeInfoMapFromM f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _nodeInfo_from ni
+nodeInfoMapFromM f g ni = NodeInfo
+  <$> (f $ _nodeInfo_from ni)
+  <*> (g $ _nodeInfo_to ni)
 
 -- | Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys
 -- from @k a@ to @'Some' k@ and applying a given weakening function
 -- @PatchTarget1 p a -> v'@ to values.
 weakenPatchDMapWithMoveWith
-  :: forall k p v'
-  .  (forall a. PatchTarget1 p a -> v')
+  :: forall k p p'
+  .  (forall a. PatchTarget1 p a -> PatchTarget p')
+  -> (forall from to. p from to -> p')
   -> PatchDMapWithMove k p
-  -> PatchMapWithMove (Some k) (Proxy v')
-weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenDMapWith g p
-  where g :: forall a. NodeInfo k PatchTarget1 p a -> MapWithMove.NodeInfo (Some k) (Proxy v')
-        g ni = MapWithMove.NodeInfo
+  -> PatchMapWithMove (Some k) p'
+weakenPatchDMapWithMoveWith f g (PatchDMapWithMove m) =
+  PatchMapWithMove $ weakenDMapWith h m
+  where h :: forall a. NodeInfo k p a -> MapWithMove.NodeInfo (Some k) p'
+        h ni = MapWithMove.NodeInfo
           { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
               From_Insert v -> MapWithMove.From_Insert $ f v
               From_Delete -> MapWithMove.From_Delete
-              From_Move k -> MapWithMove.From_Move (Some k) Proxy
-          , MapWithMove._nodeInfo_to = Some <$> getComposeMaybe (_nodeInfo_to ni)
+              From_Move (k :=> Flip p) -> MapWithMove.From_Move (Some k) $ g p
+          , MapWithMove._nodeInfo_to = case _nodeInfo_to ni of
+              To_NonMove -> MapWithMove.To_NonMove
+              To_Move (k :=> p) -> MapWithMove.To_Move (Some k) $ g p
           }
 
 -- | "Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithMove' k
@@ -578,17 +535,22 @@ weakenPatchDMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ weakenD
 -- 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 p v' a. (PatchTarget1 p a -> v')
+  :: forall k p p' a
+  . (PatchTarget1 p a -> PatchTarget p')
+  -> (p a a -> p')
   -> PatchDMapWithMove (Const2 k a) p
-  -> PatchMapWithMove k (Proxy v')
-patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMove $ dmapToMapWith g p
-  where g :: NodeInfo (Const2 k a) PatchTarget1 p a -> MapWithMove.NodeInfo k (Proxy v')
-        g ni = MapWithMove.NodeInfo
+  -> PatchMapWithMove k p'
+patchDMapWithMoveToPatchMapWithMoveWith f g (PatchDMapWithMove m) =
+  PatchMapWithMove $ dmapToMapWith h m
+  where h :: NodeInfo (Const2 k a) p a -> MapWithMove.NodeInfo k p'
+        h ni = MapWithMove.NodeInfo
           { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
               From_Insert v -> MapWithMove.From_Insert $ f v
               From_Delete -> MapWithMove.From_Delete
-              From_Move (Const2 k) -> MapWithMove.From_Move k Proxy
-          , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)
+              From_Move (Const2 k :=> Flip p) -> MapWithMove.From_Move k $ g p
+          , MapWithMove._nodeInfo_to = case _nodeInfo_to ni of
+              To_NonMove -> MapWithMove.To_NonMove
+              To_Move (Const2 k :=> p) -> MapWithMove.To_Move k $ g p
           }
 
 -- | "Strengthen" a @'PatchMapWithMove' k v@ into a @'PatchDMapWithMove
@@ -597,36 +559,47 @@ patchDMapWithMoveToPatchMapWithMoveWith f (PatchDMapWithMove p) = PatchMapWithMo
 -- 'Const2'. Apply the given function to each @v@ to produce a @PatchTarget1 p'
 -- a@. Completemented by 'patchDMapWithMoveToPatchMapWithMoveWith'
 const2PatchDMapWithMoveWith
-  :: forall k v p' a
-  .  (v -> PatchTarget1 p' a)
+  :: forall k v v' a
+  .  (v -> v' a)
   -> PatchMapWithMove k (Proxy v)
-  -> PatchDMapWithMove (Const2 k a) p'
-const2PatchDMapWithMoveWith f (PatchMapWithMove p) = PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
-  where g :: (k, MapWithMove.NodeInfo k (Proxy v)) -> DSum (Const2 k a) (NodeInfo (Const2 k a) v')
+  -> PatchDMapWithMove (Const2 k a) (Proxy3 v')
+const2PatchDMapWithMoveWith f (PatchMapWithMove p) =
+  PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
+  where g :: (k, MapWithMove.NodeInfo k (Proxy v))
+          -> DSum (Const2 k a) (NodeInfo (Const2 k a) (Proxy3 v'))
         g (k, ni) = Const2 k :=> NodeInfo
           { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of
               MapWithMove.From_Insert v -> From_Insert $ f v
               MapWithMove.From_Delete -> From_Delete
-              MapWithMove.From_Move fromKey Proxy -> From_Move $ Const2 fromKey
-          , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni
+              MapWithMove.From_Move fromKey Proxy -> From_Move $ Const2 fromKey :=> Flip Proxy3
+          , _nodeInfo_to = case MapWithMove._nodeInfo_to ni of
+              MapWithMove.To_NonMove -> To_NonMove
+              MapWithMove.To_Move toKey Proxy -> To_Move $ Const2 toKey :=> Proxy3
           }
 
 -- | Apply the insertions, deletions, and moves to a given 'DMap'.
-instance GCompare k => PatchHet (PatchDMapWithMove k p) where
+instance ( GCompare k
+         , PatchHet2 p
+         , PatchSource1 p ~ PatchTarget1 p
+         ) => PatchHet (PatchDMapWithMove k p) where
   type PatchSource (PatchDMapWithMove k p) = DMap k (PatchSource1 p)
   type PatchTarget (PatchDMapWithMove k p) = DMap k (PatchTarget1 p)
-instance GCompare k => Patch (PatchDMapWithMove k p) where
-  apply (PatchDMapWithMove p) old = Just $! insertions `DMap.union` (old `DMap.difference` deletions)
+
+instance ( GCompare k
+         , PatchHet2 p
+         , PatchSource1 p ~ PatchTarget1 p
+         ) => Patch (PatchDMapWithMove k p) where
+  apply (PatchDMapWithMove m) 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
+    where insertions = DMap.mapMaybeWithKey insertFunc m
           insertFunc :: forall a. k a -> NodeInfo k p a -> Maybe (PatchTarget1 p a)
           insertFunc _ ni = case _nodeInfo_from ni of
             From_Insert v -> Just v
-            From_Move k -> DMap.lookup k old
+            From_Move (k :=> Flip p) -> applyAlwaysHet2 p <$> DMap.lookup k old
             From_Delete -> Nothing
-          deletions = DMap.mapMaybeWithKey deleteFunc p
+          deletions = DMap.mapMaybeWithKey deleteFunc m
           deleteFunc :: forall a. k a -> NodeInfo k p a -> Maybe (Constant () a)
           deleteFunc _ ni = case _nodeInfo_from ni of
             From_Delete -> Just $ Constant ()
@@ -634,6 +607,12 @@ instance GCompare k => Patch (PatchDMapWithMove k p) where
 
 -- | Get the values that will be replaced, deleted, or moved if the given patch
 -- is applied to the given 'DMap'.
-getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))
+getDeletionsAndMoves
+  :: ( GCompare k
+     , PatchSource1 p ~ PatchTarget1 p
+     )
+  => PatchDMapWithMove k p
+  -> DMap k (PatchSource1 p)
+  -> DMap k (Product (PatchTarget1 p) (To k p))
 getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
   where f _ v ni = Pair v $ _nodeInfo_to ni
diff --git a/src/Data/Patch/MapWithMove.hs b/src/Data/Patch/MapWithMove.hs
index a54abb8d..a63105c9 100644
--- a/src/Data/Patch/MapWithMove.hs
+++ b/src/Data/Patch/MapWithMove.hs
@@ -41,7 +41,7 @@ deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (PatchMapWithMove k
 data NodeInfo k p = NodeInfo
   { _nodeInfo_from :: !(From k p)
     -- ^ Where do we get the new value for this key?
-  , _nodeInfo_to :: !(To k)
+  , _nodeInfo_to :: !(To k p)
     -- ^ If the old value is being kept (i.e. moved rather than deleted or
     -- replaced), where is it going?
   }
@@ -64,14 +64,23 @@ deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (From k p)
 -- | Describe where a key's old value will go.  If this is 'Just', that means
 -- the key's old value will be moved to the given other key; if it is 'Nothing',
 -- that means it will be deleted.
-type To = Maybe
+data To k p
+  = To_NonMove
+  | To_Move !k !p
+
+deriving instance (Show k, Show p, Show (PatchTarget p)) => Show (To k p)
+deriving instance (Read k, Read p, Read (PatchTarget p)) => Read (To k p)
+deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (To k p)
+deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (To k p)
 
 -- | Create a 'PatchMapWithMove', validating it
 patchMapWithMove
   :: Ord k => Map k (NodeInfo k p) -> Maybe (PatchMapWithMove k p)
 patchMapWithMove m = if valid then Just $ PatchMapWithMove m else Nothing
   where valid = forwardLinks == backwardLinks
-        forwardLinks = Map.mapMaybe _nodeInfo_to m
+        forwardLinks = flip Map.mapMaybe m $ \x -> case _nodeInfo_to x of
+          To_NonMove -> Nothing
+          To_Move to _ -> Just to
         backwardLinks = Map.fromList $ catMaybes $ flip fmap (Map.toList m) $ \(to, p) ->
           case _nodeInfo_from p of
             From_Move from _ -> Just (from, to)
@@ -82,7 +91,7 @@ patchMapWithMoveInsertAll
   :: Map k (PatchTarget p) -> PatchMapWithMove k p
 patchMapWithMoveInsertAll m = PatchMapWithMove $ flip fmap m $ \v -> NodeInfo
   { _nodeInfo_from = From_Insert v
-  , _nodeInfo_to = Nothing
+  , _nodeInfo_to = To_NonMove
   }
 
 -- | Extract the internal representation of the 'PatchMapWithMove'
@@ -93,7 +102,7 @@ unPatchMapWithMove (PatchMapWithMove p) = p
 -- | Make a @'PatchMapWithMove' k p@ which has the effect of inserting or updating a value @v@ to the given key @k@, like 'Map.insert'.
 insertMapKey
   :: k -> PatchTarget p -> PatchMapWithMove k p
-insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) Nothing
+insertMapKey k v = PatchMapWithMove . Map.singleton k $ NodeInfo (From_Insert v) To_NonMove
 
 -- |Make a @'PatchMapWithMove' k p@ which has the effect of moving the value from the first key @k@ to the second key @k@, equivalent to:
 --
@@ -106,8 +115,8 @@ moveMapKey src dst
   | src == dst = mempty
   | otherwise =
       PatchMapWithMove $ Map.fromList
-        [ (dst, NodeInfo (From_Move src mempty) Nothing)
-        , (src, NodeInfo From_Delete (Just dst))
+        [ (dst, NodeInfo (From_Move src mempty) To_NonMove)
+        , (src, NodeInfo From_Delete (To_Move dst mempty))
         ]
 
 -- |Make a @'PatchMapWithMove' k p@ which has the effect of swapping two keys in the mapping, equivalent to:
@@ -120,19 +129,21 @@ moveMapKey src dst
 --      . Map.delete a . Map.delete b $ map
 -- @
 swapMapKey
-  :: (DecidablyEmpty p, Patch p) => Ord k => k -> k -> PatchMapWithMove k p
+  :: (DecidablyEmpty p, Patch p)
+  => Ord k => k -> k -> PatchMapWithMove k p
 swapMapKey src dst
   | src == dst = mempty
   | otherwise =
     PatchMapWithMove $ Map.fromList
-      [ (dst, NodeInfo (From_Move src mempty) (Just src))
-      , (src, NodeInfo (From_Move dst mempty) (Just dst))
+      [ (dst, NodeInfo (From_Move src mempty) (To_Move dst mempty))
+      , (src, NodeInfo (From_Move dst mempty) (To_Move dst mempty))
       ]
 
--- |Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in the mapping, equivalent to 'Map.delete'.
+-- | Make a @'PatchMapWithMove' k v@ which has the effect of deleting a key in
+-- the mapping, equivalent to 'Map.delete'.
 deleteMapKey
   :: k -> PatchMapWithMove k v
-deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete Nothing
+deleteMapKey k = PatchMapWithMove . Map.singleton k $ NodeInfo From_Delete To_NonMove
 
 -- | Wrap a @'Map' k (NodeInfo k v)@ representing patch changes into a @'PatchMapWithMove' k v@, without checking any invariants.
 --
@@ -145,6 +156,7 @@ unsafePatchMapWithMove = PatchMapWithMove
 instance (Ord k, Patch p) => PatchHet (PatchMapWithMove k p) where
   type PatchSource (PatchMapWithMove k p) = Map k (PatchSource p)
   type PatchTarget (PatchMapWithMove k p) = Map k (PatchTarget p)
+
 instance (Ord k, Patch p) => Patch (PatchMapWithMove k p) where
   -- TODO: return Nothing sometimes
   -- Note: the strict application here is critical to ensuring that incremental
@@ -188,7 +200,7 @@ patchThatSortsMapWith cmp m = PatchMapWithMove $ Map.fromList $ catMaybes $ zipW
         reverseMapping = Map.fromList $ catMaybes $ zipWith f unsorted sorted
         g (to, _) (from, _) = if to == from then Nothing else
           let Just movingTo = Map.lookup from reverseMapping
-          in Just (to, NodeInfo (From_Move from mempty) $ Just movingTo)
+          in Just (to, NodeInfo (From_Move from mempty) $ To_Move movingTo mempty)
 
 -- | Create a 'PatchMapWithMove' that, if applied to the first 'Map' provided,
 -- will produce a 'Map' with the same values as the second 'Map' but with the
@@ -215,25 +227,32 @@ patchThatChangesMap oldByIndex newByIndex = patch
                       then Map.delete v remainingValues
                       else Map.insert v remainingKeys remainingValues
                 case Map.lookup v remainingValues of
-                  Nothing -> return $ NodeInfo (From_Insert v) $ Just undefined -- There's no existing value we can take
+                  Nothing -> return $ NodeInfo (From_Insert v) $ To_Move undefined undefined -- There's no existing value we can take
                   Just fromKs ->
                     if k `Set.member` fromKs
                     then do
                       putRemainingKeys $ Set.delete k fromKs
-                      return $ NodeInfo (From_Move k mempty) $ Just undefined -- There's an existing value, and it's here, so no patch necessary
+                      return $ NodeInfo (From_Move k mempty) $ To_Move undefined undefined -- There's an existing value, and it's here, so no patch necessary
                     else do
                       (fromK, remainingKeys) <- return . fromJust $ Set.minView fromKs -- There's an existing value, but it's not here; move it here
                       putRemainingKeys remainingKeys
-                      return $ NodeInfo (From_Move fromK mempty) $ Just undefined
+                      return $ NodeInfo (From_Move fromK mempty) $ To_Move undefined undefined
           Map.traverseWithKey f newByIndex
         unusedOldKeys = fold unusedValuesByValue
         pointlessMove k = \case
           From_Move k' _ | k == k' -> True
           _ -> False
         keyWasMoved k = if k `Map.member` oldByIndex && not (k `Set.member` unusedOldKeys)
-          then Just undefined
-          else Nothing
-        patch = unsafePatchMapWithMove $ Map.filterWithKey (\k -> not . pointlessMove k . _nodeInfo_from) $ Map.mergeWithKey (\k a _ -> Just $ nodeInfoSetTo (keyWasMoved k) a) (Map.mapWithKey $ \k -> nodeInfoSetTo $ keyWasMoved k) (Map.mapWithKey $ \k _ -> NodeInfo From_Delete $ keyWasMoved k) insertsAndMoves oldByIndex
+          then To_Move undefined undefined
+          else To_NonMove
+        patch = unsafePatchMapWithMove $ Map.filterWithKey
+          (\k -> not . pointlessMove k . _nodeInfo_from)
+          $ Map.mergeWithKey
+            (\k a _ -> Just $ nodeInfoSetTo (keyWasMoved k) a)
+            (Map.mapWithKey $ \k -> nodeInfoSetTo $ keyWasMoved k)
+            (Map.mapWithKey $ \k _ -> NodeInfo From_Delete $ keyWasMoved k)
+            insertsAndMoves
+            oldByIndex
 
 -- | Change the 'From' value of a 'NodeInfo'
 nodeInfoMapFrom
@@ -248,15 +267,16 @@ nodeInfoMapMFrom f ni = fmap (\result -> ni { _nodeInfo_from = result }) $ f $ _
 
 -- | Set the 'To' field of a 'NodeInfo'
 nodeInfoSetTo
-  :: To k -> NodeInfo k v -> NodeInfo k v
+  :: To k p -> NodeInfo k p -> NodeInfo k p
 nodeInfoSetTo to ni = ni { _nodeInfo_to = to }
 
--- |Helper data structure used for composing patches using the monoid instance.
-data Fixup k v
+-- | Helper data structure used for composing patches using the monoid instance.
+data Fixup k p
    = Fixup_Delete
-   | Fixup_Update (These (From k v) (To k))
+   | Fixup_Update (These (From k p) (To k p))
 
--- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
+-- | Compose patches having the same effect as applying the patches in turn:
+-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
 instance ( Ord k
          , DecidablyEmpty p
          , Patch p
@@ -264,18 +284,24 @@ instance ( Ord k
   PatchMapWithMove ma <> PatchMapWithMove mb = PatchMapWithMove m
     where
       connections = Map.toList $ Map.intersectionWithKey (\_ a b -> (_nodeInfo_to a, _nodeInfo_from b)) ma mb
-      h :: (k, (Maybe k, From k p)) -> [(k, Fixup k p)]
-      h (_, (mToAfter, editBefore)) = case (mToAfter, editBefore) of
-        (Just toAfter, From_Move fromBefore p)
-          | fromBefore == toAfter && isNull p
+      h :: (k, (To k p, From k p)) -> [(k, Fixup k p)]
+      h (_, (editAfter, editBefore)) = case (editAfter, editBefore) of
+        (To_Move toAfter p1, From_Move fromBefore p0)
+          | fromBefore == toAfter && isNull p0
             -> [(toAfter, Fixup_Delete)]
           | otherwise
-            -> [ (toAfter, Fixup_Update (This editBefore))
-               , (fromBefore, Fixup_Update (That mToAfter))
+            -> [ (toAfter, Fixup_Update (This $ From_Move fromBefore $ p1 <> p0))
+               , (fromBefore, Fixup_Update (That $ To_Move toAfter $ p1 <> p0))
                ]
-        (Nothing, From_Move fromBefore _) -> [(fromBefore, Fixup_Update (That mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map
-        (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]
-        (Nothing, _) -> []
+        (To_NonMove, From_Move fromBefore _) ->
+           -- The item is destroyed in the second patch, so indicate that it is
+           -- destroyed in the source map
+          [(fromBefore, Fixup_Update (That editAfter))]
+        (To_Move toAfter p, From_Insert val) ->
+          [(toAfter, Fixup_Update $ This $ From_Insert $ applyAlways p val)]
+        (To_Move toAfter _, From_Delete) ->
+          [(toAfter, Fixup_Update $ This From_Delete)]
+        (To_NonMove, _) -> []
       mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
       mergeFixups _ (Fixup_Update a) (Fixup_Update b)
         | This x <- a, That y <- b
@@ -291,13 +317,7 @@ instance ( Ord k
       applyFixup _ ni = \case
         Fixup_Delete -> Nothing
         Fixup_Update u -> Just $ NodeInfo
-          { _nodeInfo_from = case _nodeInfo_from ni of
-              f@(From_Move _ p') -> case getHere u of -- The `from` fixup comes from the "old" patch
-                Nothing -> f -- If there's no `from` fixup, just use the "new" `from`
-                Just (From_Insert v) -> From_Insert $ applyAlways p' v
-                Just From_Delete -> From_Delete
-                Just (From_Move oldKey p) -> From_Move oldKey $ p' <> p
-              _ -> error "PatchMapWithMove: fixup for non-move From"
+          { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
           , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
           }
       m = Map.differenceWithKey applyFixup (Map.unionWithKey combineNodeInfos ma mb) fixups
@@ -313,7 +333,8 @@ instance ( Ord k
         That b -> Just b
 
 --TODO: Figure out how to implement this in terms of PatchDMapWithMove rather than duplicating it here
--- |Compose patches having the same effect as applying the patches in turn: @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
+-- | Compose patches having the same effect as applying the patches in turn:
+-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
 instance ( Ord k
          , Monoid p
          , DecidablyEmpty p

From 6b8b77b34720a412971f7d3765ffa9aff3dac32b Mon Sep 17 00:00:00 2001
From: John Ericson <git@JohnEricson.me>
Date: Sat, 11 Jan 2020 19:24:10 -0500
Subject: [PATCH 11/27] Export Data.Patch.DMapWithMove.By

---
 patch.cabal                       |  1 +
 src/Data/Patch/DMapWithMove/By.hs | 91 +++++++++++++++++++++++++++++++
 2 files changed, 92 insertions(+)
 create mode 100644 src/Data/Patch/DMapWithMove/By.hs

diff --git a/patch.cabal b/patch.cabal
index 4e40a199..1d6b95e5 100644
--- a/patch.cabal
+++ b/patch.cabal
@@ -44,6 +44,7 @@ library
                  , Data.Patch.Class
                  , Data.Patch.DMap
                  , Data.Patch.DMapWithMove
+                 , Data.Patch.DMapWithMove.By
                  , Data.Patch.DMapWithReset
                  , Data.Patch.IntMap
                  , Data.Patch.Map
diff --git a/src/Data/Patch/DMapWithMove/By.hs b/src/Data/Patch/DMapWithMove/By.hs
new file mode 100644
index 00000000..2879ee6a
--- /dev/null
+++ b/src/Data/Patch/DMapWithMove/By.hs
@@ -0,0 +1,91 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
+
+module Data.Patch.DMapWithMove.By where
+
+import Data.Semigroupoid as Cat
+
+import Data.Patch.Class
+
+-- | Structure describing a particular change to a key, be it inserting a new
+-- key (@By_Insert@), updating an existing key (@By_Insert@ again), deleting
+-- a key (@By_Delete@), or moving a key (@By_Move@).
+--
+-- This type isn't used directly as the from field patch, but is instead wrapped
+-- in an existential. However, it is nice to be able to reason about this in
+-- isolation as it is itself a @Semigroupoid@ when the underlying patch is.
+data By (k :: a -> *) (p :: a -> a -> *) :: a -> a -> * where
+  -- | Insert a new or update an existing key with the given value @PatchTarget1
+  -- p a@
+  By_Insert :: PatchTarget1 p to -> By k p from to
+  -- | Delete the existing key
+  By_Delete :: By k p from to
+  -- | 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 @By_Delete@.
+  By_Move :: !(k from) -> p from to -> By k p from to
+
+deriving instance ( Show (k from), Show (k to)
+                  , Show (p from to)
+                  , Show (PatchTarget1 p to)
+                  ) => Show (By k p from to)
+deriving instance ( Read (k from), Read (k to)
+                  , Read (p from to)
+                  , Read (PatchTarget1 p to)
+                  ) => Read (By k p from to)
+deriving instance ( Eq (k from), Eq (k to)
+                  , Eq (p from to)
+                  , Eq (PatchTarget1 p to)
+                  ) => Eq (By k p from to)
+deriving instance ( Ord (k from), Ord (k to)
+                  , Ord (p from to)
+                  , Ord (PatchTarget1 p to)
+                  ) => Ord (By k p from to)
+
+mapByPatch
+  :: PatchTarget1 p0 ~ PatchTarget1 p1
+  => ((p0 from to) -> (p1 from to))
+  -> By k p0 from to
+  -> By k p1 from to
+mapByPatch f = \case
+  By_Insert v -> By_Insert v
+  By_Delete -> By_Delete
+  By_Move k p -> By_Move k $ f p
+
+-- | Compose patches having the same effect as applying the patches in turn:
+-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
+instance ( PatchSource1 p ~ PatchTarget1 p
+         , Cat.Semigroupoid p
+         , PatchHet2 p
+         ) => Cat.Semigroupoid (By k p) where
+  o p0 p1 = mapByPatch unProjectLocal $
+    oLocal (mapByPatch ProjectLocal p0) (mapByPatch ProjectLocal p1)
+
+oLocal
+  :: ( PatchSource1 p ~ PatchTarget1 p
+     , PatchHet2Locally p between after
+     , Cat.Semigroupoid p
+     )
+  => By k p between after
+  -> By k p before between
+  -> By k p before after
+By_Insert new `oLocal` _ = By_Insert new
+By_Delete `oLocal` _ = By_Delete
+By_Move _ x `oLocal` By_Insert y = By_Insert $ applyAlwaysHet2Locally x y
+By_Move _ x `oLocal` By_Move src y = By_Move src $ x `o` y
+By_Move _ _ `oLocal` By_Delete = By_Delete

From ab5bd5dd458813b5fbf3cecdb3311ac3a0384477 Mon Sep 17 00:00:00 2001
From: John Ericson <git@JohnEricson.me>
Date: Sat, 11 Jan 2020 19:24:54 -0500
Subject: [PATCH 12/27] Remove PatchDMapWithReset now that it has been
 accounted for

---
 patch.cabal                     |   1 -
 src/Data/Patch/DMapWithReset.hs | 122 --------------------------------
 2 files changed, 123 deletions(-)
 delete mode 100644 src/Data/Patch/DMapWithReset.hs

diff --git a/patch.cabal b/patch.cabal
index 1d6b95e5..82776e19 100644
--- a/patch.cabal
+++ b/patch.cabal
@@ -45,7 +45,6 @@ library
                  , Data.Patch.DMap
                  , Data.Patch.DMapWithMove
                  , Data.Patch.DMapWithMove.By
-                 , Data.Patch.DMapWithReset
                  , Data.Patch.IntMap
                  , Data.Patch.Map
                  , Data.Patch.MapWithMove
diff --git a/src/Data/Patch/DMapWithReset.hs b/src/Data/Patch/DMapWithReset.hs
deleted file mode 100644
index 46db98c0..00000000
--- a/src/Data/Patch/DMapWithReset.hs
+++ /dev/null
@@ -1,122 +0,0 @@
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PolyKinds #-}
-{-# LANGUAGE Rank2Types #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE UndecidableInstances #-}
-
-{-# OPTIONS_GHC -Wall #-}
-
--- | 'Patch'es on 'DMap' that consist only of insertions (or overwrites) and deletions.
-module Data.Patch.DMapWithReset where
-
-import Data.Patch.Class
-
-import Data.Dependent.Map (DMap, GCompare (..))
-import qualified Data.Dependent.Map as DMap
-import Data.Semigroup (Semigroup (..))
-import Data.Constraint.Extras
-
--- | A set of changes to a 'DMap'.  Any element may be inserted/updated or deleted.
--- Insertions are represented as @'ComposeMaybe' (Just value)@,
--- while deletions are represented as @'ComposeMaybe' Nothing@.
-newtype PatchDMapWithReset k p = PatchDMapWithReset { unPatchDMapWithReset :: DMap k (By p) }
-
--- | Holds the information about each key: where its new value should come from,
--- and where its old value should go to
-data By p a
-  = By_Insert (PatchTarget (p a)) -- ^ Insert the given value here
-  | By_Delete -- ^ Delete the existing value, if any, from here
-  | By_Patch (p a) -- ^ Patch the value here with the given patch
-
-instance (Semigroup (p a), Patch (p a)) => Semigroup (By p a) where
-  x@(By_Insert _) <> _ = x
-  By_Delete <> _ = By_Delete
-  By_Patch x <> By_Insert y = By_Insert (applyAlways x y)
-  By_Patch x <> By_Patch y = By_Patch (x <> y)
-  By_Patch _ <> By_Delete = By_Delete
-
-instance (Monoid (p a), Patch (p a)) => Monoid (By p a) where
-  mappend = (<>)
-  mempty = By_Patch mempty
-
-instance
-    ( GCompare k
-    , Has' Semigroup k p
-    , Has' Patch k p
-    )
-    => Semigroup (PatchDMapWithReset k p) where
-  PatchDMapWithReset xs <> PatchDMapWithReset ys = PatchDMapWithReset $ DMap.unionWithKey
-    (\k -> has' @Patch @p k
-         $ has' @Semigroup @p k
-         $ (<>)) xs ys
-
-instance
-    ( GCompare k
-    , Has' Semigroup k p
-    , Has' Patch k p
-    )
-    => Monoid (PatchDMapWithReset k p) where
-  mappend = (<>)
-  mempty = PatchDMapWithReset DMap.empty
-
-class (Patch (p a), PatchTarget (p a) ~ Patches1LocallyTarget p a) => Patches1Locally p a where
-  type Patches1LocallyTarget p :: k -> *
-
-data These1 f g x
-  = This1 (f x)
-  | That1 (g x)
-  | These1 (f x) (g x)
-
-mergeWithKey
-  :: forall k v1 v2 v.
-  (GCompare k)
-  => (forall x. k x -> v1 x -> Maybe (v x))
-  -> (forall x. k x -> v2 x -> Maybe (v x))
-  -> (forall x. k x -> v1 x -> v2 x -> Maybe (v x))
-  -> DMap k v1 -> DMap k v2 -> DMap k v
-mergeWithKey f g fg = \xs ys -> DMap.mapMaybeWithKey onlyThat $ DMap.unionWithKey doIt (DMap.map This1 xs) (DMap.map That1 ys)
-  where
-    doIt _ (This1 xs) (That1 ys) = These1 xs ys
-    doIt _ _ _ = error "mergeWithKey misalligned keys"
-
-    onlyThat :: forall x. k x -> These1 v1 v2 x -> Maybe (v x)
-    onlyThat k = \case
-      This1 xs -> f k xs
-      That1 ys -> g k ys
-      These1 xs ys -> fg k xs ys
-{-# INLINE mergeWithKey #-}
-
--- | Apply the insertions or deletions to a given 'DMap'.
-instance (GCompare k, Has (Patches1Locally p) k) => PatchHet (PatchDMapWithReset k p) where
-
-  type PatchSource (PatchDMapWithReset k p) = DMap k (Patches1LocallyTarget p)
-  type PatchTarget (PatchDMapWithReset k p) = DMap k (Patches1LocallyTarget p)
-
-instance (GCompare k, Has (Patches1Locally p) k) => Patch (PatchDMapWithReset k p) where
-  apply = go
-    where
-      go :: PatchDMapWithReset k p -> DMap k (Patches1LocallyTarget p) -> Maybe (DMap k (Patches1LocallyTarget p))
-      go (PatchDMapWithReset diff) old = Just $! mergeWithKey (\_ -> Just) inserts updates old diff
-        where
-          updates :: forall x. k x -> Patches1LocallyTarget p x -> By p x -> Maybe (Patches1LocallyTarget p x)
-          updates k ys = has @(Patches1Locally p) k $ \case
-            By_Insert x -> Just x
-            By_Delete -> Nothing
-            By_Patch x -> Just $ applyAlways x ys
-
-          inserts :: forall x. k x -> By p x -> Maybe (Patches1LocallyTarget p x)
-          inserts k = has @(Patches1Locally p) k $ \case
-            By_Insert x -> Just x
-            By_Delete -> Nothing
-            By_Patch _ -> Nothing
-
-deriving instance (Patch (p a), Eq (p a), Eq (PatchTarget (p a))) => Eq (By p a)
-deriving instance (Patch (p a), Show (p a), Show (PatchTarget (p a))) => Show (By p a)
-deriving instance (Eq (DMap k (By p))) => Eq (PatchDMapWithReset k p)
-deriving instance (Show (DMap k (By p))) => Show (PatchDMapWithReset k p)

From c99f2d2c5426df68a02ac2dbc8755afa35dd907e Mon Sep 17 00:00:00 2001
From: John Ericson <git@JohnEricson.me>
Date: Sat, 11 Jan 2020 19:26:50 -0500
Subject: [PATCH 13/27] Add decidably empty things

---
 patch.cabal                            | 4 +++-
 src/Control/Category/DecidablyEmpty.hs | 9 +++++++++
 2 files changed, 12 insertions(+), 1 deletion(-)
 create mode 100644 src/Control/Category/DecidablyEmpty.hs

diff --git a/patch.cabal b/patch.cabal
index 82776e19..93451e44 100644
--- a/patch.cabal
+++ b/patch.cabal
@@ -39,7 +39,9 @@ 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
diff --git a/src/Control/Category/DecidablyEmpty.hs b/src/Control/Category/DecidablyEmpty.hs
new file mode 100644
index 00000000..ddcd600d
--- /dev/null
+++ b/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)

From 98634c9cc7813ba2c2e8f070e0c31cb85b04aef4 Mon Sep 17 00:00:00 2001
From: John Ericson <git@JohnEricson.me>
Date: Sat, 11 Jan 2020 19:54:24 -0500
Subject: [PATCH 14/27] Appease hlint

---
 src/Data/Patch/Class.hs           |  3 +--
 src/Data/Patch/DMapWithMove.hs    | 13 ++++++-------
 src/Data/Patch/DMapWithMove/By.hs |  4 +---
 3 files changed, 8 insertions(+), 12 deletions(-)

diff --git a/src/Data/Patch/Class.hs b/src/Data/Patch/Class.hs
index af848d78..049ea1d9 100644
--- a/src/Data/Patch/Class.hs
+++ b/src/Data/Patch/Class.hs
@@ -1,5 +1,4 @@
 {-# LANGUAGE DefaultSignatures #-}
-{-# LANGUAGE DeriveTraversable #-}
 {-# LANGUAGE DerivingStrategies #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -137,7 +136,7 @@ newtype ProjectLocal p from to = ProjectLocal { unProjectLocal :: p from to }
 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) src = applyHet2 p src
+  applyHet (ProjectLocal p) = applyHet2 p
 
 instance PatchHet2 p => PatchHet2Base (ProjectLocal p) where
   type PatchSource1 (ProjectLocal p) = PatchSource1 p
diff --git a/src/Data/Patch/DMapWithMove.hs b/src/Data/Patch/DMapWithMove.hs
index 1a0927cf..e19b96de 100644
--- a/src/Data/Patch/DMapWithMove.hs
+++ b/src/Data/Patch/DMapWithMove.hs
@@ -11,7 +11,6 @@
 {-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE UndecidableSuperClasses #-}
@@ -440,7 +439,7 @@ mapPatchDMapWithMove f g (PatchDMapWithMove m) =
         h = \case
           From_Insert v -> From_Insert $ f v
           From_Delete -> From_Delete
-          From_Move (k :=> (Flip p)) -> From_Move $ k :=> Flip (g p)
+          From_Move (k :=> Flip p) -> From_Move $ k :=> Flip (g p)
         j :: forall a. To k p a -> To k p' a
         j = \case
           To_NonMove -> To_NonMove
@@ -471,9 +470,9 @@ traversePatchDMapWithMoveWithKey
   -> PatchDMapWithMove k p
   -> m (PatchDMapWithMove k p')
 traversePatchDMapWithMoveWithKey f g (PatchDMapWithMove m) =
-  fmap PatchDMapWithMove $ DMap.traverseWithKey (\k  ni -> NodeInfo
-    <$> (h k $ _nodeInfo_from ni)
-    <*> (j k $ _nodeInfo_to ni)) m
+  PatchDMapWithMove <$> DMap.traverseWithKey (\k ni -> NodeInfo
+    <$> h k (_nodeInfo_from ni)
+    <*> j k (_nodeInfo_to ni)) m
   where h :: forall a. k a -> From k p a -> m (From k p' a)
         h k = \case
           From_Insert v -> From_Insert <$> f k v
@@ -505,8 +504,8 @@ nodeInfoMapFromM
   -> NodeInfo k p a
   -> f (NodeInfo k p' a)
 nodeInfoMapFromM f g ni = NodeInfo
-  <$> (f $ _nodeInfo_from ni)
-  <*> (g $ _nodeInfo_to ni)
+  <$> f (_nodeInfo_from ni)
+  <*> g (_nodeInfo_to ni)
 
 -- | Weaken a 'PatchDMapWithMove' to a 'PatchMapWithMove' by weakening the keys
 -- from @k a@ to @'Some' k@ and applying a given weakening function
diff --git a/src/Data/Patch/DMapWithMove/By.hs b/src/Data/Patch/DMapWithMove/By.hs
index 2879ee6a..8938f209 100644
--- a/src/Data/Patch/DMapWithMove/By.hs
+++ b/src/Data/Patch/DMapWithMove/By.hs
@@ -6,12 +6,10 @@
 {-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE PatternGuards #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeApplications #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE UndecidableSuperClasses #-}
@@ -59,7 +57,7 @@ deriving instance ( Ord (k from), Ord (k to)
 
 mapByPatch
   :: PatchTarget1 p0 ~ PatchTarget1 p1
-  => ((p0 from to) -> (p1 from to))
+  => (p0 from to -> p1 from to)
   -> By k p0 from to
   -> By k p1 from to
 mapByPatch f = \case

From 5a135774beee6facd6738cf60ec3ef802ddaa380 Mon Sep 17 00:00:00 2001
From: John Ericson <git@JohnEricson.me>
Date: Sat, 11 Jan 2020 20:46:18 -0500
Subject: [PATCH 15/27] Remove Patchable

I'm not sure it is a good idea in general, so I am putting in another
library instead.
---
 patch.cabal                 |  1 -
 src/Data/Patch/Patchable.hs | 45 -------------------------------------
 2 files changed, 46 deletions(-)
 delete mode 100644 src/Data/Patch/Patchable.hs

diff --git a/patch.cabal b/patch.cabal
index 93451e44..9f504d6c 100644
--- a/patch.cabal
+++ b/patch.cabal
@@ -50,7 +50,6 @@ library
                  , Data.Patch.IntMap
                  , Data.Patch.Map
                  , Data.Patch.MapWithMove
-                 , Data.Patch.Patchable
 
   ghc-options: -Wall -fwarn-redundant-constraints -fwarn-tabs
 
diff --git a/src/Data/Patch/Patchable.hs b/src/Data/Patch/Patchable.hs
deleted file mode 100644
index 3add5141..00000000
--- a/src/Data/Patch/Patchable.hs
+++ /dev/null
@@ -1,45 +0,0 @@
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeFamilies #-}
-
--- The derived instances are undecidable in the case of a pathological instance like
--- instance Patch x where
---   type PatchTarget x = Patchable x
-{-# LANGUAGE UndecidableInstances #-}
-
-module Data.Patch.Patchable where
-
--- import Data.Aeson
-import GHC.Generics
-
-import Data.Patch
-
--- | Like SemiMap/PartialMap but for anything patchable
-data Patchable p
-  = Patchable_Patch p
-  | Patchable_Complete (PatchTarget p)
-  deriving (Generic)
-
-completePatchable :: Patchable p -> Maybe (PatchTarget p)
-completePatchable = \case
-  Patchable_Complete t -> Just t
-  Patchable_Patch _ -> Nothing
-
-deriving instance (Eq p, Eq (PatchTarget p)) => Eq (Patchable p)
-deriving instance (Ord p, Ord (PatchTarget p)) => Ord (Patchable p)
-deriving instance (Show p, Show (PatchTarget p)) => Show (Patchable p)
-deriving instance (Read p, Read (PatchTarget p)) => Read (Patchable p)
--- instance (ToJSON p, ToJSON (PatchTarget p)) => ToJSON (Patchable p)
--- instance (FromJSON p, FromJSON (PatchTarget p)) => FromJSON (Patchable p)
-
-instance (Monoid p, Patch p) => Monoid (Patchable p) where
-  mempty = Patchable_Patch mempty
-  mappend = (<>)
-
-instance (Semigroup p, Patch p) => Semigroup (Patchable p) where
-  (<>) = curry $ \case
-    (Patchable_Patch a, Patchable_Patch b) -> Patchable_Patch $ a <> b
-    (Patchable_Patch a, Patchable_Complete b) -> Patchable_Complete $ applyAlways a b
-    (Patchable_Complete a, _) -> Patchable_Complete a

From 08f13f25369b4c35a8ae5db8f57f8322d9e9be23 Mon Sep 17 00:00:00 2001
From: John Ericson <John.Ericson@Obsidian.Systems>
Date: Sat, 11 Jan 2020 20:53:38 -0500
Subject: [PATCH 16/27] Update ChangeLog.md

---
 ChangeLog.md | 4 +---
 1 file changed, 1 insertion(+), 3 deletions(-)

diff --git a/ChangeLog.md b/ChangeLog.md
index f14f8501..9666c65b 100644
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -4,9 +4,7 @@
 
 * `PatchMapWithMove` supports moves with a patch.
 
-* Add `PatchDMapWithReset`
-
-* Add `Patchable`
+* `PatchDMapWithMove` supports moves with a patch.
 
 ## 0.0.1.0
 

From c3cac44ff6068fd00075ccdea21425a4e10f482b Mon Sep 17 00:00:00 2001
From: John Ericson <John.Ericson@Obsidian.Systems>
Date: Tue, 21 Jan 2020 12:01:18 -0500
Subject: [PATCH 17/27] WIP make old in terms of new

---
 src/Data/Patch/MapWithMove.hs | 15 +++++++++++++++
 1 file changed, 15 insertions(+)

diff --git a/src/Data/Patch/MapWithMove.hs b/src/Data/Patch/MapWithMove.hs
index 2547e5c6..0f9b69a4 100644
--- a/src/Data/Patch/MapWithMove.hs
+++ b/src/Data/Patch/MapWithMove.hs
@@ -27,6 +27,7 @@ import Data.List
 import Data.Map (Map)
 import qualified Data.Map as Map
 import Data.Maybe
+--import Data.Proxy
 #if !MIN_VERSION_base(4,9,0)
 import Data.Semigroup (Semigroup (..), (<>))
 #endif
@@ -47,6 +48,13 @@ deriving instance (Ord k, Read k, Read p, Read (PatchTarget p)) => Read (PatchMa
 deriving instance (Eq k, Eq p, Eq (PatchTarget p)) => Eq (PatchMapWithMove k p)
 deriving instance (Ord k, Ord p, Ord (PatchTarget p)) => Ord (PatchMapWithMove k p)
 
+-- -- | Skips the patch so it's 'Functor' and friends
+-- newtype PatchMapWithMove' k v = PatchMapWithMove' { unPatchMapWithMove' :: PatchMapWithMove k (Proxy v) }
+--
+-- deriving instance Functor (PatchMapWithMove' k)
+-- deriving instance Foldable (PatchMapWithMove' k)
+-- deriving instance Traversable (PatchMapWithMove' k)
+
 -- | Holds the information about each key: where its new value should come from,
 -- and where its old value should go to
 data NodeInfo k p = NodeInfo
@@ -83,6 +91,13 @@ data To k p
            )
 
 makeWrapped ''PatchMapWithMove
+--makeWrapped ''PatchMapWithMove'
+
+-- instance FunctorWithIndex k (PatchMapWithMove k)
+-- instance FoldableWithIndex k (PatchMapWithMove k)
+-- instance TraversableWithIndex k (PatchMapWithMove k) where
+--   itraverse = itraversed . Indexed
+--   itraversed = _Wrapped .> itraversed <. traversed
 
 -- | Create a 'PatchMapWithMove', validating it
 patchMapWithMove

From ac8f41179cfb1f65a592f374217be63b5fa67bb4 Mon Sep 17 00:00:00 2001
From: John Ericson <John.Ericson@Obsidian.Systems>
Date: Thu, 22 Apr 2021 22:28:34 -0400
Subject: [PATCH 18/27] Restore the old `DMapWithMove`,

New one is called `DMapWithPatchingMove`
---
 patch.cabal                                   |   3 +-
 src/Data/Patch.hs                             |   8 +-
 src/Data/Patch/DMapWithMove.hs                | 583 +++++-----------
 src/Data/Patch/DMapWithPatchingMove.hs        | 629 ++++++++++++++++++
 .../By.hs                                     |   2 +-
 5 files changed, 803 insertions(+), 422 deletions(-)
 create mode 100644 src/Data/Patch/DMapWithPatchingMove.hs
 rename src/Data/Patch/{DMapWithMove => DMapWithPatchingMove}/By.hs (98%)

diff --git a/patch.cabal b/patch.cabal
index 72611bc0..84a59c5b 100644
--- a/patch.cabal
+++ b/patch.cabal
@@ -50,7 +50,8 @@ library
                  , Data.Patch.Class
                  , Data.Patch.DMap
                  , Data.Patch.DMapWithMove
-                 , Data.Patch.DMapWithMove.By
+                 , Data.Patch.DMapWithPatchingMove
+                 , Data.Patch.DMapWithPatchingMove.By
                  , Data.Patch.IntMap
                  , Data.Patch.Map
                  , Data.Patch.MapWithMove
diff --git a/src/Data/Patch.hs b/src/Data/Patch.hs
index da4e3539..4caf2fa3 100644
--- a/src/Data/Patch.hs
+++ b/src/Data/Patch.hs
@@ -27,10 +27,16 @@ import Data.Patch.Class as X
 import Data.Patch.DMap as X hiding (getDeletions)
 import Data.Patch.DMapWithMove as X
   ( PatchDMapWithMove, const2PatchDMapWithMoveWith, mapPatchDMapWithMove
-  , patchDMapWithMoveToPatchMapWithPatchingMoveWith
+  , patchDMapWithMoveToPatchMapWithMoveWith
   , 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
diff --git a/src/Data/Patch/DMapWithMove.hs b/src/Data/Patch/DMapWithMove.hs
index 5d62ec32..672477e5 100644
--- a/src/Data/Patch/DMapWithMove.hs
+++ b/src/Data/Patch/DMapWithMove.hs
@@ -1,234 +1,108 @@
 {-# LANGUAGE CPP #-}
-{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE InstanceSigs #-}
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE PatternGuards #-}
 {-# LANGUAGE PolyKinds #-}
 {-# LANGUAGE Rank2Types #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE UndecidableSuperClasses #-}
 
 -- |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 Data.Patch.DMapWithMove where
 
-import qualified Control.Category as Cat
---import qualified Control.Category.DecidablyEmpty as Cat
+import Data.Patch.Class
+import Data.Patch.MapWithMove (PatchMapWithMove (..))
+import qualified Data.Patch.MapWithMove as MapWithMove
 
-import Data.Constraint.Extras (Has')
+import Data.Constraint.Extras
 import Data.Dependent.Map (DMap)
 import Data.Dependent.Sum (DSum (..))
 import qualified Data.Dependent.Map as DMap
-import Data.Functor.Constant (Constant (..))
+import Data.Functor.Constant
 import Data.Functor.Misc
-  ( Const2 (..), Proxy3 (..)
-  , weakenDMapWith
-  , dmapToMapWith
-  )
-import Data.Functor.Product (Product (..))
+import Data.Functor.Product
 import Data.GADT.Compare (GEq (..), GCompare (..))
-import Data.GADT.Show (GRead, GShow, gshow)
+import Data.GADT.Show (GShow, gshow)
 import qualified Data.Map as Map
 import Data.Maybe
 import Data.Monoid.DecidablyEmpty
-import Data.Semigroupoid as Cat
 #if !MIN_VERSION_base(4,11,0)
-import Data.Semigroup (Semigroup (..), (<>))
+import Data.Semigroup (Semigroup (..))
 #endif
 import Data.Some (Some, mkSome)
-import Data.Proxy (Proxy (..))
-import Data.These (These (..))
+import Data.These
 
-import Data.Patch.Class
-  ( Patch (..), PatchHet (..)
-  , PatchHet2 (..), PatchSource1, PatchTarget1
-  , applyAlwaysHet2
-  )
-import Data.Patch.MapWithPatchingMove (PatchMapWithPatchingMove (..))
-import qualified Data.Patch.MapWithPatchingMove as MapWithPatchingMove
-
--- | Like 'PatchMapWithPatchingMove', but for 'DMap'. Each key carries a 'NodeInfo'
--- which describes how it will be changed by the patch and connects move sources
--- and destinations.
+-- | 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)@)
+--     * 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))
 
---deriving instance ( GShow k
---                  , HasZip Show k p
---                  , Has' Show k (PatchTarget1 p)
---                  ) => Show (PatchDMapWithMove k p)
---deriving instance ( GRead k
---                  , HasZip Read k p
---                  , Has' Read k (PatchTarget1 p)
---                  ) => Read (PatchDMapWithMove k p)
---deriving instance ( GEq k
---                  , HasZip Eq k p
---                  , Has' Eq k (PatchTarget1 p)
---                  ) => Eq (PatchDMapWithMove k p)
---deriving instance ( GCompare k
---                  , HasZip Ord k p
---                  , Has' Ord k (PatchTarget1 p)
---                  ) => Ord (PatchDMapWithMove k p)
-
 -- It won't let me derive for some reason
-instance ( GCompare k
-         , Cat.Semigroupoid v
-         , PatchHet2 v
-         , PatchSource1 v ~ PatchTarget1 v
-         ) => DecidablyEmpty (PatchDMapWithMove k v) where
+instance GCompare k => DecidablyEmpty (PatchDMapWithMove k v) where
   isEmpty (PatchDMapWithMove m) = DMap.null m
 
--- | 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 p a = NodeInfo
-  { _nodeInfo_from :: !(From k p a)
-  -- ^ Change applying to the current key, be it an insert, move, or delete.
-  , _nodeInfo_to :: !(To k p 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'.
+-- |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 instance ( Show (k a)
---                  , Show (p a a)
---                  , Show (PatchTarget1 p a)
---                  ) => Show (NodeInfo k p a)
---deriving instance ( Read (k a)
---                  , Read (p a a)
---                  , Read (PatchTarget1 p a)
---                  ) => Read (NodeInfo k p a)
---deriving instance ( Eq (k a)
---                  , Eq (p a a)
---                  , Eq (PatchTarget1 p a)
---                  ) => Eq (NodeInfo k p a)
---deriving instance ( Ord (k a)
---                  , Ord (p a a)
---                  , Ord (PatchTarget1 p a)
---                  ) => Ord (NodeInfo k p a)
-
--- | 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@).
---
--- This type isn't used directly as the from field patch, but is instead wrapped
--- in an existential. However, it is nice to be able to reason about this in
--- isolation as it is itself a @Semigroupoid@ when the underlying patch is.
-data From (k :: a -> *) (p :: a -> a -> *) :: a -> * where
-  -- | Insert a new or update an existing key with the given value @PatchTarget1
-  -- p a@
-  From_Insert :: PatchTarget1 p to -> From k p to
-  -- | Delete the existing key
-  From_Delete :: From k p to
-  -- | 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@.
-  From_Move :: !(DSum k (Flip p to)) -> From k p to
-
-deriving instance ( Show (k a), GShow k
-                  , Has' Show k (Flip p a)
-                  , Show (PatchTarget1 p a)
-                  ) => Show (From k p a)
-deriving instance ( Read (k a), GRead k
-                  , Has' Read k (Flip p a)
-                  , Read (PatchTarget1 p a)
-                  ) => Read (From k p a)
-deriving instance ( GEq k
-                  , Has' Eq k (Flip p a)
-                  , Eq (PatchTarget1 p a)
-                  ) => Eq (From k p a)
-deriving instance ( GCompare k
-                  , Has' Eq k (Flip p a) -- superclass bug
-                  , Has' Ord k (Flip p a)
-                  , Ord (PatchTarget1 p a)
-                  ) => Ord (From k p a)
-
-newtype Flip p to from = Flip (p from to)
-
-instance Cat.Category p => Cat.Category (Flip (p :: k -> k -> *)) where
-  id = Flip Cat.id
-  Flip y . Flip x = Flip $ x Cat.. y
-
--- | The "to" part of a 'NodeInfo'. Rather than be built out of @From@ like @From@
--- is, we store just the information necessary to compose a @To@ and @From@ like
--- @oLocal@ composes two @From@s.
-data To (k :: a -> *) (p :: a -> a -> *) :: a -> * where
-  -- | Delete or leave in place
-  To_NonMove :: To k p from
-  -- | Move the value from the given key @k a@ to this key. The target key
-  -- should also have an entry in the patch giving the current key in
-  -- @_nodeInfo_from@, usually but not necessarily with @To_Delete@.
-  To_Move :: !(DSum k (p from)) -> To k p from
-
-deriving instance ( Show (k a), GShow k
-                  , Has' Show k (p a)
-                  , Show (PatchTarget1 p a)
-                  ) => Show (To k p a)
-deriving instance ( Read (k a), GRead k
-                  , Has' Read k (p a)
-                  , Read (PatchTarget1 p a)
-                  ) => Read (To k p a)
-deriving instance ( GEq k
-                  , Has' Eq k (p a)
-                  , Eq (PatchTarget1 p a)
-                  ) => Eq (To k p a)
-deriving instance ( GCompare k
-                  , Has' Eq k (p a) -- superclass bug
-                  , Has' Ord k (p a)
-                  , Ord (PatchTarget1 p a)
-                  ) => Ord (To k p a)
+  deriving (Show)
+
+-- |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
+  -- |Insert a new or update an existing key with the given value @v a@
+  From_Insert :: v a -> From k v a
+  -- |Delete the existing key
+  From_Delete :: 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@.
+  From_Move :: !(k a) -> From k v a
+  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
 
 -- |Test whether a 'PatchDMapWithMove' satisfies its invariants.
-validPatchDMapWithMove
-  :: forall k v
-  .  (GCompare k, GShow k)
-  => DMap k (NodeInfo k v)
-  -> Bool
+validPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Bool
 validPatchDMapWithMove = not . null . validationErrorsForPatchDMapWithMove
 
 -- |Enumerate what reasons a 'PatchDMapWithMove' doesn't satisfy its invariants, returning @[]@ if it's valid.
-validationErrorsForPatchDMapWithMove
-  :: forall k v
-  .  (GCompare k, GShow k)
-  => DMap k (NodeInfo k v)
-  -> [String]
+validationErrorsForPatchDMapWithMove :: forall k v. (GCompare k, GShow k) => DMap k (NodeInfo k v) -> [String]
 validationErrorsForPatchDMapWithMove m =
   noSelfMoves <> movesBalanced
   where
     noSelfMoves = mapMaybe 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 _ (To_Move (dst :=> _)))
-      | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
+    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 = mapMaybe unbalancedMove . DMap.toAscList $ m
-    unbalancedMove (dst :=> NodeInfo (From_Move (src :=> _)) _) =
+    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 _ (To_Move (dst' :=> _))) ->
+        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 _ (To_Move (dst :=> _))) =
+    unbalancedMove (src :=> NodeInfo _ (ComposeMaybe (Just dst))) =
       case DMap.lookup dst m of
         Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"
-        Just (NodeInfo (From_Move (src' :=> _)) _) ->
+        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
@@ -237,49 +111,35 @@ validationErrorsForPatchDMapWithMove m =
           Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
     unbalancedMove _ = Nothing
 
+-- |Test whether two @'PatchDMapWithMove' k v@ contain the same patch operations.
+instance (GEq k, Has' Eq 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)
 
 -- |Helper data structure used for composing patches using the monoid instance.
-data Fixup k p a
+data Fixup k v a
    = Fixup_Delete
-   | Fixup_Update (These (From k p a) (To k p a))
-
--- | Compose patches having the same effect as applying the patches in turn:
--- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
-instance ( GCompare k
-         , Cat.Semigroupoid p
-         -- , Cat.DecidablyEmpty p
-         , PatchHet2 p
-         , PatchSource1 p ~ PatchTarget1 p
-         ) => Semigroup (PatchDMapWithMove k p) where
+   | 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 => Semigroup (PatchDMapWithMove k v) where
   PatchDMapWithMove ma <> PatchDMapWithMove mb = PatchDMapWithMove m
     where
-      connections :: [DSum k (Pair1 (To k p) (From k p))]
-      connections = DMap.toList $ DMap.intersectionWithKey
-        (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b))
-        ma
-        mb
-      h :: DSum k (Pair1 (To k p) (From k p)) -> [DSum k (Fixup k p)]
-      h ((_ :: k between) :=> Pair1 editAfter editBefore) = case (editAfter, editBefore) of
-        (To_Move ((toAfter :: k after) :=> p1), From_Move ((fromBefore :: k before) :=> Flip p0)) ->
-          --case toAfter `geq` fromBefore of
-          --  Just Refl | Just Refl <- Cat.isId p0 ->
-          --    [ toAfter :=> Fixup_Delete ]
-          --  _ ->
-              [ toAfter :=> Fixup_Update (This $ From_Move $ fromBefore :=> (Flip $ p1 `o` p0))
-              , fromBefore :=> Fixup_Update (That $ To_Move $ toAfter :=> (p1 `o` p0))
-              ]
-        (To_NonMove, From_Move (fromBefore :=> _)) ->
-          -- The item is destroyed in the second patch, so indicate that it is
-          -- destroyed in the source map
-          [fromBefore :=> Fixup_Update (That To_NonMove)]
-        (To_Move (toAfter :=> p), From_Insert val) ->
-          [toAfter :=> Fixup_Update (This $ From_Insert $ applyAlwaysHet2 p val)]
-        (To_Move (toAfter :=> _), From_Delete) ->
-          [toAfter :=> Fixup_Update (This From_Delete)]
-        (To_NonMove, _) ->
-          []
+      connections = DMap.toList $ DMap.intersectionWithKey (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b)) ma mb
+      h :: DSum k (Pair1 (ComposeMaybe k) (From k v)) -> [DSum k (Fixup k v)]
+      h (_ :=> Pair1 (ComposeMaybe mToAfter) editBefore) = case (mToAfter, editBefore) of
+        (Just toAfter, From_Move fromBefore)
+          | isJust $ fromBefore `geq` toAfter
+            -> [toAfter :=> Fixup_Delete]
+          | otherwise
+            -> [ toAfter :=> Fixup_Update (This editBefore)
+               , fromBefore :=> Fixup_Update (That (ComposeMaybe mToAfter))
+               ]
+        (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
+        (Just toAfter, _) -> [toAfter :=> Fixup_Update (This editBefore)]
+        (Nothing, _) -> []
       mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
       mergeFixups _ (Fixup_Update a) (Fixup_Update b)
         | This x <- a, That y <- b
@@ -310,19 +170,13 @@ instance ( GCompare k
         These _ b -> Just b
         That b -> Just b
 
--- | Compose patches having the same effect as applying the patches in turn:
--- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
-instance ( GCompare k
-         , Cat.Semigroupoid p
-         -- , DecidablyEmpty p
-         , PatchHet2 p
-         , PatchSource1 p ~ PatchTarget1 p
-         ) => Monoid (PatchDMapWithMove k p) where
+-- |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
   mappend = (<>)
 
 {-
-mappendPatchDMapWithMoveSlow :: forall k v.  (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
+mappendPatchDMapWithMoveSlow :: forall k v. (ShowTag k v, GCompare k) => PatchDMapWithMove k v -> PatchDMapWithMove k v -> PatchDMapWithMove k v
 PatchDMapWithMove dstAfter srcAfter `mappendPatchDMapWithMoveSlow` PatchDMapWithMove dstBefore srcBefore = PatchDMapWithMove dst src
   where
     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
@@ -343,31 +197,25 @@ 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 @PatchTarget1 p a@ to the given key @k a@, like
--- 'DMap.insert'.
-insertDMapKey :: k a -> PatchTarget1 p a -> PatchDMapWithMove k p
+-- |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) To_NonMove
+  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:
+-- |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 (Proxy3 v)
+moveDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k v
 moveDMapKey src dst = case src `geq` dst of
   Nothing -> PatchDMapWithMove $ DMap.fromList
-    [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) To_NonMove
-    , src :=> NodeInfo From_Delete (To_Move $ dst :=> Proxy3)
+    [ dst :=> NodeInfo (From_Move src) (ComposeMaybe Nothing)
+    , src :=> NodeInfo From_Delete (ComposeMaybe $ Just dst)
     ]
-  Just _ -> PatchDMapWithMove DMap.empty
+  Just _ -> mempty
 
--- | Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys
--- in the mapping, equivalent to:
+-- |Make a @'PatchDMapWithMove' k v@ which has the effect of swapping two keys in the mapping, equivalent to:
 --
 -- @
 --     let aMay = DMap.lookup a dmap
@@ -376,18 +224,17 @@ moveDMapKey src dst = case src `geq` dst of
 --      . maybe id (DMap.insert b) (aMay <> bMay)
 --      . DMap.delete a . DMap.delete b $ dmap
 -- @
-swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithMove k (Proxy3 v)
+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 :=> Flip Proxy3)) (To_Move $ src :=> Proxy3)
-    , src :=> NodeInfo (From_Move (dst :=> Flip Proxy3)) (To_Move $ dst :=> Proxy3)
+    [ dst :=> NodeInfo (From_Move src) (ComposeMaybe $ Just src)
+    , src :=> NodeInfo (From_Move dst) (ComposeMaybe $ Just dst)
     ]
-  Just _ -> PatchDMapWithMove DMap.empty
+  Just _ -> mempty
 
--- | Make a @'PatchDMapWithMove' k v@ which has the effect of deleting a key in
--- the mapping, equivalent to 'DMap.delete'.
+-- |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 To_NonMove
+deleteDMapKey k = PatchDMapWithMove $ DMap.singleton k $ NodeInfo From_Delete $ ComposeMaybe Nothing
 
 {-
 k1, k2 :: Const2 Int () ()
@@ -413,217 +260,115 @@ dst (PatchDMapWithMove x _) = x
 src (PatchDMapWithMove _ x) = x
 -}
 
--- | Extract the 'DMap' representing the patch changes from the
--- 'PatchDMapWithMove'.
+-- |Extract the 'DMap' representing the patch changes from the 'PatchDMapWithMove'.
 unPatchDMapWithMove :: PatchDMapWithMove k v -> DMap k (NodeInfo k v)
 unPatchDMapWithMove (PatchDMapWithMove p) = p
 
--- | Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove',
--- without checking any invariants.
+-- |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
+-- |Wrap a 'DMap' representing patch changes into a 'PatchDMapWithMove' while checking invariants. If the invariants are satisfied, @Right p@ is returned
 -- otherwise @Left errors@.
-patchDMapWithPatchingMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)
-patchDMapWithPatchingMove dm =
+patchDMapWithMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithMove k v)
+patchDMapWithMove dm =
   case validationErrorsForPatchDMapWithMove 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 p p'
-  .  (forall a. PatchTarget1 p a -> PatchTarget1 p' a)
-  -> (forall from to. p from to -> p' from to)
-  -> PatchDMapWithMove k p
-  -> PatchDMapWithMove k p'
-mapPatchDMapWithMove f g (PatchDMapWithMove m) =
-  PatchDMapWithMove $ DMap.map (\ni -> NodeInfo
-    { _nodeInfo_from = h $ _nodeInfo_from ni
-    , _nodeInfo_to = j $ _nodeInfo_to ni
-    }) m
-  where h :: forall a. From k p a -> From k p' a
-        h = \case
+-- |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
+  where g :: forall a. From k v a -> From k v' a
+        g = \case
           From_Insert v -> From_Insert $ f v
           From_Delete -> From_Delete
-          From_Move (k :=> Flip p) -> From_Move $ k :=> Flip (g p)
-        j :: forall a. To k p a -> To k p' a
-        j = \case
-          To_NonMove -> To_NonMove
-          To_Move (k :=> p) -> To_Move $ k :=> g p
-
--- | Traverse an effectful function @forall a. PatchTarget1 p a -> m (v ' a)@
--- over the given patch, transforming @'PatchDMapWithMove' k v@ into @m
--- ('PatchDMapWithMove' k v')@.
-traversePatchDMapWithMove
-  :: forall m k p p'
-  . Applicative m
-  => (forall a. PatchTarget1 p a -> m (PatchTarget1 p' a))
-  -> (forall from to. p from to -> m (p' from to))
-  -> PatchDMapWithMove k p
-  -> m (PatchDMapWithMove k p')
-traversePatchDMapWithMove f g = traversePatchDMapWithMoveWithKey
-  (\_ -> f)
-  (\_ _ -> g)
-
--- | Map an effectful function @forall a. k a -> PatchTarget1 p a -> m (v ' a)@
--- over the given patch, transforming @'PatchDMapWithMove' k v@ into @m
--- ('PatchDMapWithMove' k v')@.
-traversePatchDMapWithMoveWithKey
-  :: forall m k p p'
-  . Applicative m
-  => (forall a. k a -> PatchTarget1 p a -> m (PatchTarget1 p' a))
-  -> (forall from to. k from -> k to -> p from to -> m (p' from to))
-  -> PatchDMapWithMove k p
-  -> m (PatchDMapWithMove k p')
-traversePatchDMapWithMoveWithKey f g (PatchDMapWithMove m) =
-  PatchDMapWithMove <$> DMap.traverseWithKey (\k ni -> NodeInfo
-    <$> h k (_nodeInfo_from ni)
-    <*> j k (_nodeInfo_to ni)) m
-  where h :: forall a. k a -> From k p a -> m (From k p' a)
-        h k = \case
+          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)
+        g k = \case
           From_Insert v -> From_Insert <$> f k v
           From_Delete -> pure From_Delete
-          From_Move (fromKey :=> Flip p) -> From_Move . (fromKey :=>) . Flip <$> g fromKey k p
-        j :: forall a. k a -> To k p a -> m (To k p' a)
-        j k = \case
-          To_NonMove -> pure To_NonMove
-          To_Move (toKey :=> p) -> To_Move . (toKey :=>) <$> g k toKey p
-
--- | Map a function which transforms @'From k PatchTarget1 p a@ into a @'From k
--- PatchTarget1 p' a@ over a @'NodeInfo' k PatchTarget1 p a@.
-nodeInfoMapFrom
-  :: (From k p a -> From k p' a)
-  -> (To k p a -> To k p' a)
-  -> NodeInfo k p a
-  -> NodeInfo k p' a
-nodeInfoMapFrom f g ni = NodeInfo
-  { _nodeInfo_from = f $ _nodeInfo_from ni
-  , _nodeInfo_to = g $ _nodeInfo_to ni
-  }
-
--- | Map an effectful function which transforms @'From k PatchTarget1 p a@ into
--- a @f ('From k PatchTarget1 p' a)@ over a @'NodeInfo' k PatchTarget1 p a@.
-nodeInfoMapFromM
-  :: Applicative f
-  => (From k p a -> f (From k p' a))
-  -> (To k p a -> f (To k p' a))
-  -> NodeInfo k p a
-  -> f (NodeInfo k p' a)
-nodeInfoMapFromM f g ni = NodeInfo
-  <$> f (_nodeInfo_from ni)
-  <*> g (_nodeInfo_to ni)
-
--- | Weaken a 'PatchDMapWithMove' to a 'PatchMapWithPatchingMove' by weakening the keys
--- from @k a@ to @'Some' k@ and applying a given weakening function
--- @PatchTarget1 p a -> v'@ to values.
-weakenPatchDMapWithMoveWith
-  :: forall k p p'
-  .  (forall a. PatchTarget1 p a -> PatchTarget p')
-  -> (forall from to. p from to -> p')
-  -> PatchDMapWithMove k p
-  -> PatchMapWithPatchingMove (Some k) p'
-weakenPatchDMapWithMoveWith f g (PatchDMapWithMove m) =
-  PatchMapWithPatchingMove $ weakenDMapWith h m
-  where h :: forall a. NodeInfo k p a -> MapWithPatchingMove.NodeInfo (Some k) p'
-        h ni = MapWithPatchingMove.NodeInfo
-          { MapWithPatchingMove._nodeInfo_from = case _nodeInfo_from ni of
-              From_Insert v -> MapWithPatchingMove.From_Insert $ f v
-              From_Delete -> MapWithPatchingMove.From_Delete
-              From_Move (k :=> Flip p) -> MapWithPatchingMove.From_Move (mkSome k) $ g p
-          , MapWithPatchingMove._nodeInfo_to = case _nodeInfo_to ni of
-              To_NonMove -> Nothing
-              To_Move (k :=> _) -> Just (mkSome k)
+          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'
+        g ni = MapWithMove.NodeInfo
+          { MapWithMove._nodeInfo_from = case _nodeInfo_from ni of
+              From_Insert v -> MapWithMove.From_Insert $ f v
+              From_Delete -> MapWithMove.From_Delete
+              From_Move k -> MapWithMove.From_Move $ mkSome k
+          , MapWithMove._nodeInfo_to = mkSome <$> getComposeMaybe (_nodeInfo_to ni)
           }
 
--- | "Weaken" a @'PatchDMapWithMove' (Const2 k a) v@ to a @'PatchMapWithPatchingMove' 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.
-patchDMapWithMoveToPatchMapWithPatchingMoveWith
-  :: forall k p p' a
-  . (PatchTarget1 p a -> PatchTarget p')
-  -> (p a a -> p')
-  -> PatchDMapWithMove (Const2 k a) p
-  -> PatchMapWithPatchingMove k p'
-patchDMapWithMoveToPatchMapWithPatchingMoveWith f g (PatchDMapWithMove m) =
-  PatchMapWithPatchingMove $ dmapToMapWith h m
-  where h :: NodeInfo (Const2 k a) p a -> MapWithPatchingMove.NodeInfo k p'
-        h ni = MapWithPatchingMove.NodeInfo
-          { MapWithPatchingMove._nodeInfo_from = case _nodeInfo_from ni of
-              From_Insert v -> MapWithPatchingMove.From_Insert $ f v
-              From_Delete -> MapWithPatchingMove.From_Delete
-              From_Move (Const2 k :=> Flip p) -> MapWithPatchingMove.From_Move k $ g p
-          , MapWithPatchingMove._nodeInfo_to = case _nodeInfo_to ni of
-              To_NonMove -> Nothing
-              To_Move (Const2 k :=> _) -> Just k
+-- |"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 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
+              From_Delete -> MapWithMove.From_Delete
+              From_Move (Const2 k) -> MapWithMove.From_Move k
+          , MapWithMove._nodeInfo_to = unConst2 <$> getComposeMaybe (_nodeInfo_to ni)
           }
 
--- | "Strengthen" a @'PatchMapWithPatchingMove' 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 @PatchTarget1 p'
--- a@. Completemented by 'patchDMapWithMoveToPatchMapWithPatchingMoveWith'
-const2PatchDMapWithMoveWith
-  :: forall k v v' a
-  .  (v -> v' a)
-  -> PatchMapWithPatchingMove k (Proxy v)
-  -> PatchDMapWithMove (Const2 k a) (Proxy3 v')
-const2PatchDMapWithMoveWith f (PatchMapWithPatchingMove p) =
-  PatchDMapWithMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
-  where g :: (k, MapWithPatchingMove.NodeInfo k (Proxy v))
-          -> DSum (Const2 k a) (NodeInfo (Const2 k a) (Proxy3 v'))
+-- |"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) v')
         g (k, ni) = Const2 k :=> NodeInfo
-          { _nodeInfo_from = case MapWithPatchingMove._nodeInfo_from ni of
-              MapWithPatchingMove.From_Insert v -> From_Insert $ f v
-              MapWithPatchingMove.From_Delete -> From_Delete
-              MapWithPatchingMove.From_Move fromKey Proxy -> From_Move $ Const2 fromKey :=> Flip Proxy3
-          , _nodeInfo_to = case MapWithPatchingMove._nodeInfo_to ni of
-              Nothing -> To_NonMove
-              Just toKey -> To_Move $ Const2 toKey :=> Proxy3
+          { _nodeInfo_from = case MapWithMove._nodeInfo_from ni of
+              MapWithMove.From_Insert v -> From_Insert $ f v
+              MapWithMove.From_Delete -> From_Delete
+              MapWithMove.From_Move fromKey -> From_Move $ Const2 fromKey
+          , _nodeInfo_to = ComposeMaybe $ Const2 <$> MapWithMove._nodeInfo_to ni
           }
 
 -- | Apply the insertions, deletions, and moves to a given 'DMap'.
-instance ( GCompare k
-         , PatchHet2 p
-         , PatchSource1 p ~ PatchTarget1 p
-         ) => PatchHet (PatchDMapWithMove k p) where
-  type PatchSource (PatchDMapWithMove k p) = DMap k (PatchSource1 p)
-  type PatchTarget (PatchDMapWithMove k p) = DMap k (PatchTarget1 p)
-
-instance ( GCompare k
-         , PatchHet2 p
-         , PatchSource1 p ~ PatchTarget1 p
-         ) => Patch (PatchDMapWithMove k p) where
-  apply (PatchDMapWithMove m) 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 m
-          insertFunc :: forall a. k a -> NodeInfo k p a -> Maybe (PatchTarget1 p a)
+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)
           insertFunc _ ni = case _nodeInfo_from ni of
             From_Insert v -> Just v
-            From_Move (k :=> Flip p) -> applyAlwaysHet2 p <$> DMap.lookup k old
+            From_Move k -> DMap.lookup k old
             From_Delete -> Nothing
-          deletions = DMap.mapMaybeWithKey deleteFunc m
-          deleteFunc :: forall a. k a -> NodeInfo k p a -> Maybe (Constant () a)
+          deletions = DMap.mapMaybeWithKey deleteFunc p
+          deleteFunc :: forall a. k a -> NodeInfo k v a -> Maybe (Constant () a)
           deleteFunc _ ni = case _nodeInfo_from ni of
             From_Delete -> Just $ Constant ()
             _ -> Nothing
 
--- | Get the values that will be replaced, deleted, or moved if the given patch
--- is applied to the given 'DMap'.
-getDeletionsAndMoves
-  :: ( GCompare k
-     , PatchSource1 p ~ PatchTarget1 p
-     )
-  => PatchDMapWithMove k p
-  -> DMap k (PatchSource1 p)
-  -> DMap k (Product (PatchTarget1 p) (To k p))
+-- | Get the values that will be replaced, deleted, or moved if the given patch is applied to the given 'DMap'.
+getDeletionsAndMoves :: GCompare k => PatchDMapWithMove k v -> DMap k v' -> DMap k (Product v' (ComposeMaybe k))
 getDeletionsAndMoves (PatchDMapWithMove p) m = DMap.intersectionWithKey f m p
   where f _ v ni = Pair v $ _nodeInfo_to ni
diff --git a/src/Data/Patch/DMapWithPatchingMove.hs b/src/Data/Patch/DMapWithPatchingMove.hs
new file mode 100644
index 00000000..357c8bd5
--- /dev/null
+++ b/src/Data/Patch/DMapWithPatchingMove.hs
@@ -0,0 +1,629 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE ConstraintKinds #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE InstanceSigs #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE UndecidableSuperClasses #-}
+
+-- |Module containing @'PatchDMapWithPatchingMove' 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 Data.Patch.DMapWithPatchingMove where
+
+import qualified Control.Category as Cat
+--import qualified Control.Category.DecidablyEmpty as Cat
+
+import Data.Constraint.Extras (Has')
+import Data.Dependent.Map (DMap)
+import Data.Dependent.Sum (DSum (..))
+import qualified Data.Dependent.Map as DMap
+import Data.Functor.Constant (Constant (..))
+import Data.Functor.Misc
+  ( Const2 (..), Proxy3 (..)
+  , weakenDMapWith
+  , dmapToMapWith
+  )
+import Data.Functor.Product (Product (..))
+import Data.GADT.Compare (GEq (..), GCompare (..))
+import Data.GADT.Show (GRead, GShow, gshow)
+import qualified Data.Map as Map
+import Data.Maybe
+import Data.Monoid.DecidablyEmpty
+import Data.Semigroupoid as Cat
+#if !MIN_VERSION_base(4,11,0)
+import Data.Semigroup (Semigroup (..), (<>))
+#endif
+import Data.Some (Some, mkSome)
+import Data.Proxy (Proxy (..))
+import Data.These (These (..))
+
+import Data.Patch.Class
+  ( Patch (..), PatchHet (..)
+  , PatchHet2 (..), PatchSource1, PatchTarget1
+  , applyAlwaysHet2
+  )
+import Data.Patch.MapWithPatchingMove (PatchMapWithPatchingMove (..))
+import qualified Data.Patch.MapWithPatchingMove as MapWithPatchingMove
+
+-- | Like 'PatchMapWithPatchingMove', 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 PatchDMapWithPatchingMove k v = PatchDMapWithPatchingMove (DMap k (NodeInfo k v))
+
+--deriving instance ( GShow k
+--                  , HasZip Show k p
+--                  , Has' Show k (PatchTarget1 p)
+--                  ) => Show (PatchDMapWithPatchingMove k p)
+--deriving instance ( GRead k
+--                  , HasZip Read k p
+--                  , Has' Read k (PatchTarget1 p)
+--                  ) => Read (PatchDMapWithPatchingMove k p)
+--deriving instance ( GEq k
+--                  , HasZip Eq k p
+--                  , Has' Eq k (PatchTarget1 p)
+--                  ) => Eq (PatchDMapWithPatchingMove k p)
+--deriving instance ( GCompare k
+--                  , HasZip Ord k p
+--                  , Has' Ord k (PatchTarget1 p)
+--                  ) => Ord (PatchDMapWithPatchingMove k p)
+
+-- It won't let me derive for some reason
+instance ( GCompare k
+         , Cat.Semigroupoid v
+         , PatchHet2 v
+         , PatchSource1 v ~ PatchTarget1 v
+         ) => DecidablyEmpty (PatchDMapWithPatchingMove k v) where
+  isEmpty (PatchDMapWithPatchingMove m) = DMap.null m
+
+-- | 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 p a = NodeInfo
+  { _nodeInfo_from :: !(From k p a)
+  -- ^ Change applying to the current key, be it an insert, move, or delete.
+  , _nodeInfo_to :: !(To k p 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 instance ( Show (k a)
+--                  , Show (p a a)
+--                  , Show (PatchTarget1 p a)
+--                  ) => Show (NodeInfo k p a)
+--deriving instance ( Read (k a)
+--                  , Read (p a a)
+--                  , Read (PatchTarget1 p a)
+--                  ) => Read (NodeInfo k p a)
+--deriving instance ( Eq (k a)
+--                  , Eq (p a a)
+--                  , Eq (PatchTarget1 p a)
+--                  ) => Eq (NodeInfo k p a)
+--deriving instance ( Ord (k a)
+--                  , Ord (p a a)
+--                  , Ord (PatchTarget1 p a)
+--                  ) => Ord (NodeInfo k p a)
+
+-- | 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@).
+--
+-- This type isn't used directly as the from field patch, but is instead wrapped
+-- in an existential. However, it is nice to be able to reason about this in
+-- isolation as it is itself a @Semigroupoid@ when the underlying patch is.
+data From (k :: a -> *) (p :: a -> a -> *) :: a -> * where
+  -- | Insert a new or update an existing key with the given value @PatchTarget1
+  -- p a@
+  From_Insert :: PatchTarget1 p to -> From k p to
+  -- | Delete the existing key
+  From_Delete :: From k p to
+  -- | 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@.
+  From_Move :: !(DSum k (Flip p to)) -> From k p to
+
+deriving instance ( Show (k a), GShow k
+                  , Has' Show k (Flip p a)
+                  , Show (PatchTarget1 p a)
+                  ) => Show (From k p a)
+deriving instance ( Read (k a), GRead k
+                  , Has' Read k (Flip p a)
+                  , Read (PatchTarget1 p a)
+                  ) => Read (From k p a)
+deriving instance ( GEq k
+                  , Has' Eq k (Flip p a)
+                  , Eq (PatchTarget1 p a)
+                  ) => Eq (From k p a)
+deriving instance ( GCompare k
+                  , Has' Eq k (Flip p a) -- superclass bug
+                  , Has' Ord k (Flip p a)
+                  , Ord (PatchTarget1 p a)
+                  ) => Ord (From k p a)
+
+newtype Flip p to from = Flip (p from to)
+
+instance Cat.Category p => Cat.Category (Flip (p :: k -> k -> *)) where
+  id = Flip Cat.id
+  Flip y . Flip x = Flip $ x Cat.. y
+
+-- | The "to" part of a 'NodeInfo'. Rather than be built out of @From@ like @From@
+-- is, we store just the information necessary to compose a @To@ and @From@ like
+-- @oLocal@ composes two @From@s.
+data To (k :: a -> *) (p :: a -> a -> *) :: a -> * where
+  -- | Delete or leave in place
+  To_NonMove :: To k p from
+  -- | Move the value from the given key @k a@ to this key. The target key
+  -- should also have an entry in the patch giving the current key in
+  -- @_nodeInfo_from@, usually but not necessarily with @To_Delete@.
+  To_Move :: !(DSum k (p from)) -> To k p from
+
+deriving instance ( Show (k a), GShow k
+                  , Has' Show k (p a)
+                  , Show (PatchTarget1 p a)
+                  ) => Show (To k p a)
+deriving instance ( Read (k a), GRead k
+                  , Has' Read k (p a)
+                  , Read (PatchTarget1 p a)
+                  ) => Read (To k p a)
+deriving instance ( GEq k
+                  , Has' Eq k (p a)
+                  , Eq (PatchTarget1 p a)
+                  ) => Eq (To k p a)
+deriving instance ( GCompare k
+                  , Has' Eq k (p a) -- superclass bug
+                  , Has' Ord k (p a)
+                  , Ord (PatchTarget1 p a)
+                  ) => Ord (To k p a)
+
+-- |Test whether a 'PatchDMapWithPatchingMove' satisfies its invariants.
+validPatchDMapWithPatchingMove
+  :: forall k v
+  .  (GCompare k, GShow k)
+  => DMap k (NodeInfo k v)
+  -> Bool
+validPatchDMapWithPatchingMove = not . null . validationErrorsForPatchDMapWithPatchingMove
+
+-- |Enumerate what reasons a 'PatchDMapWithPatchingMove' doesn't satisfy its invariants, returning @[]@ if it's valid.
+validationErrorsForPatchDMapWithPatchingMove
+  :: forall k v
+  .  (GCompare k, GShow k)
+  => DMap k (NodeInfo k v)
+  -> [String]
+validationErrorsForPatchDMapWithPatchingMove m =
+  noSelfMoves <> movesBalanced
+  where
+    noSelfMoves = mapMaybe 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 _ (To_Move (dst :=> _)))
+      | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
+    selfMove _ = Nothing
+    movesBalanced = mapMaybe 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 _ (To_Move (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 _ (To_Move (dst :=> _))) =
+      case DMap.lookup dst m of
+        Nothing -> Just $ " unbalanced 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
+
+-- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
+data Pair1 f g a = Pair1 (f a) (g a)
+
+-- |Helper data structure used for composing patches using the monoid instance.
+data Fixup k p a
+   = Fixup_Delete
+   | Fixup_Update (These (From k p a) (To k p a))
+
+-- | Compose patches having the same effect as applying the patches in turn:
+-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
+instance ( GCompare k
+         , Cat.Semigroupoid p
+         -- , Cat.DecidablyEmpty p
+         , PatchHet2 p
+         , PatchSource1 p ~ PatchTarget1 p
+         ) => Semigroup (PatchDMapWithPatchingMove k p) where
+  PatchDMapWithPatchingMove ma <> PatchDMapWithPatchingMove mb = PatchDMapWithPatchingMove m
+    where
+      connections :: [DSum k (Pair1 (To k p) (From k p))]
+      connections = DMap.toList $ DMap.intersectionWithKey
+        (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b))
+        ma
+        mb
+      h :: DSum k (Pair1 (To k p) (From k p)) -> [DSum k (Fixup k p)]
+      h ((_ :: k between) :=> Pair1 editAfter editBefore) = case (editAfter, editBefore) of
+        (To_Move ((toAfter :: k after) :=> p1), From_Move ((fromBefore :: k before) :=> Flip p0)) ->
+          --case toAfter `geq` fromBefore of
+          --  Just Refl | Just Refl <- Cat.isId p0 ->
+          --    [ toAfter :=> Fixup_Delete ]
+          --  _ ->
+              [ toAfter :=> Fixup_Update (This $ From_Move $ fromBefore :=> (Flip $ p1 `o` p0))
+              , fromBefore :=> Fixup_Update (That $ To_Move $ toAfter :=> (p1 `o` p0))
+              ]
+        (To_NonMove, From_Move (fromBefore :=> _)) ->
+          -- The item is destroyed in the second patch, so indicate that it is
+          -- destroyed in the source map
+          [fromBefore :=> Fixup_Update (That To_NonMove)]
+        (To_Move (toAfter :=> p), From_Insert val) ->
+          [toAfter :=> Fixup_Update (This $ From_Insert $ applyAlwaysHet2 p val)]
+        (To_Move (toAfter :=> _), From_Delete) ->
+          [toAfter :=> Fixup_Update (This From_Delete)]
+        (To_NonMove, _) ->
+          []
+      mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
+      mergeFixups _ (Fixup_Update a) (Fixup_Update b)
+        | This x <- a, That y <- b
+        = Fixup_Update $ These x y
+        | That y <- a, This x <- b
+        = Fixup_Update $ These x y
+      mergeFixups _ _ _ = error "PatchDMapWithPatchingMove: incompatible fixups"
+      fixups = DMap.fromListWithKey mergeFixups $ concatMap h connections
+      combineNodeInfos _ nia nib = NodeInfo
+        { _nodeInfo_from = _nodeInfo_from nia
+        , _nodeInfo_to = _nodeInfo_to nib
+        }
+      applyFixup _ ni = \case
+        Fixup_Delete -> Nothing
+        Fixup_Update u -> Just $ NodeInfo
+          { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
+          , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
+          }
+      m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups
+      getHere :: These a b -> Maybe a
+      getHere = \case
+        This a -> Just a
+        These a _ -> Just a
+        That _ -> Nothing
+      getThere :: These a b -> Maybe b
+      getThere = \case
+        This _ -> Nothing
+        These _ b -> Just b
+        That b -> Just b
+
+-- | Compose patches having the same effect as applying the patches in turn:
+-- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
+instance ( GCompare k
+         , Cat.Semigroupoid p
+         -- , DecidablyEmpty p
+         , PatchHet2 p
+         , PatchSource1 p ~ PatchTarget1 p
+         ) => Monoid (PatchDMapWithPatchingMove k p) where
+  mempty = PatchDMapWithPatchingMove mempty
+  mappend = (<>)
+
+{-
+mappendPatchDMapWithPatchingMoveSlow :: forall k v.  (ShowTag k v, GCompare k) => PatchDMapWithPatchingMove k v -> PatchDMapWithPatchingMove k v -> PatchDMapWithPatchingMove k v
+PatchDMapWithPatchingMove dstAfter srcAfter `mappendPatchDMapWithPatchingMoveSlow` PatchDMapWithPatchingMove dstBefore srcBefore = PatchDMapWithPatchingMove dst src
+  where
+    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
+    removeRedundantDst toKey (From_Move fromKey) | isJust (toKey `geq` fromKey) = Nothing
+    removeRedundantDst _ a = Just a
+    f :: forall a. k a -> From k v a -> Maybe (From k v a)
+    f toKey _ = removeRedundantDst toKey $ case getDstAction toKey dstAfter of
+      From_Move fromKey -> getDstAction fromKey dstBefore
+      nonMove -> nonMove
+    dst = DMap.mapMaybeWithKey f $ DMap.union dstAfter dstBefore
+    getSrcAction k m = fromMaybe (ComposeMaybe $ Just k) $ DMap.lookup k m
+    removeRedundantSrc fromKey (ComposeMaybe (Just toKey)) | isJust (fromKey `geq` toKey) = Nothing
+    removeRedundantSrc _ a = Just a
+    g :: forall a. k a -> ComposeMaybe k a -> Maybe (ComposeMaybe k a)
+    g fromKey _ = removeRedundantSrc fromKey $ case getSrcAction fromKey srcBefore of
+      ComposeMaybe Nothing -> ComposeMaybe Nothing
+      ComposeMaybe (Just toKeyBefore) -> getSrcAction toKeyBefore srcAfter
+    src = DMap.mapMaybeWithKey g $ DMap.union srcAfter srcBefore
+-}
+
+-- | Make a @'PatchDMapWithPatchingMove' k v@ which has the effect of inserting or
+-- updating a value @PatchTarget1 p a@ to the given key @k a@, like
+-- 'DMap.insert'.
+insertDMapKey :: k a -> PatchTarget1 p a -> PatchDMapWithPatchingMove k p
+insertDMapKey k v =
+  PatchDMapWithPatchingMove . DMap.singleton k $ NodeInfo (From_Insert v) To_NonMove
+
+-- | Make a @'PatchDMapWithPatchingMove' 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 -> PatchDMapWithPatchingMove k (Proxy3 v)
+moveDMapKey src dst = case src `geq` dst of
+  Nothing -> PatchDMapWithPatchingMove $ DMap.fromList
+    [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) To_NonMove
+    , src :=> NodeInfo From_Delete (To_Move $ dst :=> Proxy3)
+    ]
+  Just _ -> PatchDMapWithPatchingMove DMap.empty
+
+-- | Make a @'PatchDMapWithPatchingMove' 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 <> aMay)
+--      . maybe id (DMap.insert b) (aMay <> bMay)
+--      . DMap.delete a . DMap.delete b $ dmap
+-- @
+swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithPatchingMove k (Proxy3 v)
+swapDMapKey src dst = case src `geq` dst of
+  Nothing -> PatchDMapWithPatchingMove $ DMap.fromList
+    [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) (To_Move $ src :=> Proxy3)
+    , src :=> NodeInfo (From_Move (dst :=> Flip Proxy3)) (To_Move $ dst :=> Proxy3)
+    ]
+  Just _ -> PatchDMapWithPatchingMove DMap.empty
+
+-- | Make a @'PatchDMapWithPatchingMove' k v@ which has the effect of deleting a key in
+-- the mapping, equivalent to 'DMap.delete'.
+deleteDMapKey :: k a -> PatchDMapWithPatchingMove k v
+deleteDMapKey k = PatchDMapWithPatchingMove $ DMap.singleton k $ NodeInfo From_Delete To_NonMove
+
+{-
+k1, k2 :: Const2 Int () ()
+k1 = Const2 1
+k2 = Const2 2
+p1, p2 :: PatchDMapWithPatchingMove (Const2 Int ()) Identity
+p1 = moveDMapKey k1 k2
+p2 = moveDMapKey k2 k1
+p12 = p1 <> p2
+p21 = p2 <> p1
+p12Slow = p1 `mappendPatchDMapWithPatchingMoveSlow` p2
+p21Slow = p2 `mappendPatchDMapWithPatchingMoveSlow` p1
+
+testPatchDMapWithPatchingMove = do
+  print p1
+  print p2
+  print $ p12 == deleteDMapKey k1
+  print $ p21 == deleteDMapKey k2
+  print $ p12Slow == deleteDMapKey k1
+  print $ p21Slow == deleteDMapKey k2
+
+dst (PatchDMapWithPatchingMove x _) = x
+src (PatchDMapWithPatchingMove _ x) = x
+-}
+
+-- | Extract the 'DMap' representing the patch changes from the
+-- 'PatchDMapWithPatchingMove'.
+unPatchDMapWithPatchingMove :: PatchDMapWithPatchingMove k v -> DMap k (NodeInfo k v)
+unPatchDMapWithPatchingMove (PatchDMapWithPatchingMove p) = p
+
+-- | Wrap a 'DMap' representing patch changes into a 'PatchDMapWithPatchingMove',
+-- without checking any invariants.
+--
+-- __Warning:__ when using this function, you must ensure that the invariants of 'PatchDMapWithPatchingMove' are preserved; they will not be checked.
+unsafePatchDMapWithPatchingMove :: DMap k (NodeInfo k v) -> PatchDMapWithPatchingMove k v
+unsafePatchDMapWithPatchingMove = PatchDMapWithPatchingMove
+
+-- | Wrap a 'DMap' representing patch changes into a 'PatchDMapWithPatchingMove' while
+-- checking invariants. If the invariants are satisfied, @Right p@ is returned
+-- otherwise @Left errors@.
+patchDMapWithPatchingMove :: (GCompare k, GShow k) => DMap k (NodeInfo k v) -> Either [String] (PatchDMapWithPatchingMove k v)
+patchDMapWithPatchingMove dm =
+  case validationErrorsForPatchDMapWithPatchingMove dm of
+    [] -> Right $ unsafePatchDMapWithPatchingMove dm
+    errs -> Left errs
+
+-- | Map a natural transform @v -> v'@ over the given patch, transforming
+-- @'PatchDMapWithPatchingMove' k v@ into @'PatchDMapWithPatchingMove' k v'@.
+mapPatchDMapWithPatchingMove
+  :: forall k p p'
+  .  (forall a. PatchTarget1 p a -> PatchTarget1 p' a)
+  -> (forall from to. p from to -> p' from to)
+  -> PatchDMapWithPatchingMove k p
+  -> PatchDMapWithPatchingMove k p'
+mapPatchDMapWithPatchingMove f g (PatchDMapWithPatchingMove m) =
+  PatchDMapWithPatchingMove $ DMap.map (\ni -> NodeInfo
+    { _nodeInfo_from = h $ _nodeInfo_from ni
+    , _nodeInfo_to = j $ _nodeInfo_to ni
+    }) m
+  where h :: forall a. From k p a -> From k p' a
+        h = \case
+          From_Insert v -> From_Insert $ f v
+          From_Delete -> From_Delete
+          From_Move (k :=> Flip p) -> From_Move $ k :=> Flip (g p)
+        j :: forall a. To k p a -> To k p' a
+        j = \case
+          To_NonMove -> To_NonMove
+          To_Move (k :=> p) -> To_Move $ k :=> g p
+
+-- | Traverse an effectful function @forall a. PatchTarget1 p a -> m (v ' a)@
+-- over the given patch, transforming @'PatchDMapWithPatchingMove' k v@ into @m
+-- ('PatchDMapWithPatchingMove' k v')@.
+traversePatchDMapWithPatchingMove
+  :: forall m k p p'
+  . Applicative m
+  => (forall a. PatchTarget1 p a -> m (PatchTarget1 p' a))
+  -> (forall from to. p from to -> m (p' from to))
+  -> PatchDMapWithPatchingMove k p
+  -> m (PatchDMapWithPatchingMove k p')
+traversePatchDMapWithPatchingMove f g = traversePatchDMapWithPatchingMoveWithKey
+  (\_ -> f)
+  (\_ _ -> g)
+
+-- | Map an effectful function @forall a. k a -> PatchTarget1 p a -> m (v ' a)@
+-- over the given patch, transforming @'PatchDMapWithPatchingMove' k v@ into @m
+-- ('PatchDMapWithPatchingMove' k v')@.
+traversePatchDMapWithPatchingMoveWithKey
+  :: forall m k p p'
+  . Applicative m
+  => (forall a. k a -> PatchTarget1 p a -> m (PatchTarget1 p' a))
+  -> (forall from to. k from -> k to -> p from to -> m (p' from to))
+  -> PatchDMapWithPatchingMove k p
+  -> m (PatchDMapWithPatchingMove k p')
+traversePatchDMapWithPatchingMoveWithKey f g (PatchDMapWithPatchingMove m) =
+  PatchDMapWithPatchingMove <$> DMap.traverseWithKey (\k ni -> NodeInfo
+    <$> h k (_nodeInfo_from ni)
+    <*> j k (_nodeInfo_to ni)) m
+  where h :: forall a. k a -> From k p a -> m (From k p' a)
+        h k = \case
+          From_Insert v -> From_Insert <$> f k v
+          From_Delete -> pure From_Delete
+          From_Move (fromKey :=> Flip p) -> From_Move . (fromKey :=>) . Flip <$> g fromKey k p
+        j :: forall a. k a -> To k p a -> m (To k p' a)
+        j k = \case
+          To_NonMove -> pure To_NonMove
+          To_Move (toKey :=> p) -> To_Move . (toKey :=>) <$> g k toKey p
+
+-- | Map a function which transforms @'From k PatchTarget1 p a@ into a @'From k
+-- PatchTarget1 p' a@ over a @'NodeInfo' k PatchTarget1 p a@.
+nodeInfoMapFrom
+  :: (From k p a -> From k p' a)
+  -> (To k p a -> To k p' a)
+  -> NodeInfo k p a
+  -> NodeInfo k p' a
+nodeInfoMapFrom f g ni = NodeInfo
+  { _nodeInfo_from = f $ _nodeInfo_from ni
+  , _nodeInfo_to = g $ _nodeInfo_to ni
+  }
+
+-- | Map an effectful function which transforms @'From k PatchTarget1 p a@ into
+-- a @f ('From k PatchTarget1 p' a)@ over a @'NodeInfo' k PatchTarget1 p a@.
+nodeInfoMapFromM
+  :: Applicative f
+  => (From k p a -> f (From k p' a))
+  -> (To k p a -> f (To k p' a))
+  -> NodeInfo k p a
+  -> f (NodeInfo k p' a)
+nodeInfoMapFromM f g ni = NodeInfo
+  <$> f (_nodeInfo_from ni)
+  <*> g (_nodeInfo_to ni)
+
+-- | Weaken a 'PatchDMapWithPatchingMove' to a 'PatchMapWithPatchingMove' by weakening the keys
+-- from @k a@ to @'Some' k@ and applying a given weakening function
+-- @PatchTarget1 p a -> v'@ to values.
+weakenPatchDMapWithPatchingMoveWith
+  :: forall k p p'
+  .  (forall a. PatchTarget1 p a -> PatchTarget p')
+  -> (forall from to. p from to -> p')
+  -> PatchDMapWithPatchingMove k p
+  -> PatchMapWithPatchingMove (Some k) p'
+weakenPatchDMapWithPatchingMoveWith f g (PatchDMapWithPatchingMove m) =
+  PatchMapWithPatchingMove $ weakenDMapWith h m
+  where h :: forall a. NodeInfo k p a -> MapWithPatchingMove.NodeInfo (Some k) p'
+        h ni = MapWithPatchingMove.NodeInfo
+          { MapWithPatchingMove._nodeInfo_from = case _nodeInfo_from ni of
+              From_Insert v -> MapWithPatchingMove.From_Insert $ f v
+              From_Delete -> MapWithPatchingMove.From_Delete
+              From_Move (k :=> Flip p) -> MapWithPatchingMove.From_Move (mkSome k) $ g p
+          , MapWithPatchingMove._nodeInfo_to = case _nodeInfo_to ni of
+              To_NonMove -> Nothing
+              To_Move (k :=> _) -> Just (mkSome k)
+          }
+
+-- | "Weaken" a @'PatchDMapWithPatchingMove' (Const2 k a) v@ to a @'PatchMapWithPatchingMove' 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.
+patchDMapWithPatchingMoveToPatchMapWithPatchingMoveWith
+  :: forall k p p' a
+  . (PatchTarget1 p a -> PatchTarget p')
+  -> (p a a -> p')
+  -> PatchDMapWithPatchingMove (Const2 k a) p
+  -> PatchMapWithPatchingMove k p'
+patchDMapWithPatchingMoveToPatchMapWithPatchingMoveWith f g (PatchDMapWithPatchingMove m) =
+  PatchMapWithPatchingMove $ dmapToMapWith h m
+  where h :: NodeInfo (Const2 k a) p a -> MapWithPatchingMove.NodeInfo k p'
+        h ni = MapWithPatchingMove.NodeInfo
+          { MapWithPatchingMove._nodeInfo_from = case _nodeInfo_from ni of
+              From_Insert v -> MapWithPatchingMove.From_Insert $ f v
+              From_Delete -> MapWithPatchingMove.From_Delete
+              From_Move (Const2 k :=> Flip p) -> MapWithPatchingMove.From_Move k $ g p
+          , MapWithPatchingMove._nodeInfo_to = case _nodeInfo_to ni of
+              To_NonMove -> Nothing
+              To_Move (Const2 k :=> _) -> Just k
+          }
+
+-- | "Strengthen" a @'PatchMapWithPatchingMove' k v@ into a @'PatchDMapWithPatchingMove
+-- ('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 @PatchTarget1 p'
+-- a@. Completemented by 'patchDMapWithPatchingMoveToPatchMapWithPatchingMoveWith'
+const2PatchDMapWithPatchingMoveWith
+  :: forall k v v' a
+  .  (v -> v' a)
+  -> PatchMapWithPatchingMove k (Proxy v)
+  -> PatchDMapWithPatchingMove (Const2 k a) (Proxy3 v')
+const2PatchDMapWithPatchingMoveWith f (PatchMapWithPatchingMove p) =
+  PatchDMapWithPatchingMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
+  where g :: (k, MapWithPatchingMove.NodeInfo k (Proxy v))
+          -> DSum (Const2 k a) (NodeInfo (Const2 k a) (Proxy3 v'))
+        g (k, ni) = Const2 k :=> NodeInfo
+          { _nodeInfo_from = case MapWithPatchingMove._nodeInfo_from ni of
+              MapWithPatchingMove.From_Insert v -> From_Insert $ f v
+              MapWithPatchingMove.From_Delete -> From_Delete
+              MapWithPatchingMove.From_Move fromKey Proxy -> From_Move $ Const2 fromKey :=> Flip Proxy3
+          , _nodeInfo_to = case MapWithPatchingMove._nodeInfo_to ni of
+              Nothing -> To_NonMove
+              Just toKey -> To_Move $ Const2 toKey :=> Proxy3
+          }
+
+-- | Apply the insertions, deletions, and moves to a given 'DMap'.
+instance ( GCompare k
+         , PatchHet2 p
+         , PatchSource1 p ~ PatchTarget1 p
+         ) => PatchHet (PatchDMapWithPatchingMove k p) where
+  type PatchSource (PatchDMapWithPatchingMove k p) = DMap k (PatchSource1 p)
+  type PatchTarget (PatchDMapWithPatchingMove k p) = DMap k (PatchTarget1 p)
+
+instance ( GCompare k
+         , PatchHet2 p
+         , PatchSource1 p ~ PatchTarget1 p
+         ) => Patch (PatchDMapWithPatchingMove k p) where
+  apply (PatchDMapWithPatchingMove m) 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 m
+          insertFunc :: forall a. k a -> NodeInfo k p a -> Maybe (PatchTarget1 p a)
+          insertFunc _ ni = case _nodeInfo_from ni of
+            From_Insert v -> Just v
+            From_Move (k :=> Flip p) -> applyAlwaysHet2 p <$> DMap.lookup k old
+            From_Delete -> Nothing
+          deletions = DMap.mapMaybeWithKey deleteFunc m
+          deleteFunc :: forall a. k a -> NodeInfo k p a -> Maybe (Constant () a)
+          deleteFunc _ ni = case _nodeInfo_from ni of
+            From_Delete -> Just $ Constant ()
+            _ -> Nothing
+
+-- | Get the values that will be replaced, deleted, or moved if the given patch
+-- is applied to the given 'DMap'.
+getDeletionsAndMoves
+  :: ( GCompare k
+     , PatchSource1 p ~ PatchTarget1 p
+     )
+  => PatchDMapWithPatchingMove k p
+  -> DMap k (PatchSource1 p)
+  -> DMap k (Product (PatchTarget1 p) (To k p))
+getDeletionsAndMoves (PatchDMapWithPatchingMove p) m = DMap.intersectionWithKey f m p
+  where f _ v ni = Pair v $ _nodeInfo_to ni
diff --git a/src/Data/Patch/DMapWithMove/By.hs b/src/Data/Patch/DMapWithPatchingMove/By.hs
similarity index 98%
rename from src/Data/Patch/DMapWithMove/By.hs
rename to src/Data/Patch/DMapWithPatchingMove/By.hs
index 8938f209..0970c357 100644
--- a/src/Data/Patch/DMapWithMove/By.hs
+++ b/src/Data/Patch/DMapWithPatchingMove/By.hs
@@ -14,7 +14,7 @@
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE UndecidableSuperClasses #-}
 
-module Data.Patch.DMapWithMove.By where
+module Data.Patch.DMapWithPatchingMove.By where
 
 import Data.Semigroupoid as Cat
 

From 48711bca322380a3d7e02e73dd6e751c9d3610bf Mon Sep 17 00:00:00 2001
From: John Ericson <John.Ericson@Obsidian.Systems>
Date: Fri, 23 Apr 2021 12:58:33 -0400
Subject: [PATCH 19/27] DMapWithPatchingnMove: Restore old algo

This is the one that doesn't store patches on the "to" side.
---
 src/Data/Patch/DMapWithPatchingMove.hs | 75 +++++++++++++++-----------
 1 file changed, 45 insertions(+), 30 deletions(-)

diff --git a/src/Data/Patch/DMapWithPatchingMove.hs b/src/Data/Patch/DMapWithPatchingMove.hs
index 357c8bd5..c5f266b6 100644
--- a/src/Data/Patch/DMapWithPatchingMove.hs
+++ b/src/Data/Patch/DMapWithPatchingMove.hs
@@ -42,9 +42,10 @@ import Data.Semigroupoid as Cat
 #if !MIN_VERSION_base(4,11,0)
 import Data.Semigroup (Semigroup (..), (<>))
 #endif
-import Data.Some (Some, mkSome)
+import Data.Some (Some (Some), mkSome)
 import Data.Proxy (Proxy (..))
 import Data.These (These (..))
+import Data.Type.Equality ((:~:)(..))
 
 import Data.Patch.Class
   ( Patch (..), PatchHet (..)
@@ -172,7 +173,7 @@ data To (k :: a -> *) (p :: a -> a -> *) :: a -> * where
   -- | Move the value from the given key @k a@ to this key. The target key
   -- should also have an entry in the patch giving the current key in
   -- @_nodeInfo_from@, usually but not necessarily with @To_Delete@.
-  To_Move :: !(DSum k (p from)) -> To k p from
+  To_Move :: !(Some k) -> To k p from
 
 deriving instance ( Show (k a), GShow k
                   , Has' Show k (p a)
@@ -212,20 +213,20 @@ validationErrorsForPatchDMapWithPatchingMove m =
     noSelfMoves = mapMaybe 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 _ (To_Move (dst :=> _)))
+    selfMove (src :=> NodeInfo _ (To_Move (Some dst)))
       | Just _ <- src `geq` dst = Just $ "self move of key " <> gshow dst <> " at source side"
     selfMove _ = Nothing
     movesBalanced = mapMaybe 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 _ (To_Move (dst' :=> _))) ->
+        Just (NodeInfo _ (To_Move (Some 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 _ (To_Move (dst :=> _))) =
+    unbalancedMove (src :=> NodeInfo _ (To_Move (Some dst))) =
       case DMap.lookup dst m of
         Nothing -> Just $ " unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not in the patch"
         Just (NodeInfo (From_Move (src' :=> _)) _) ->
@@ -243,16 +244,18 @@ data Pair1 f g a = Pair1 (f a) (g a)
 -- |Helper data structure used for composing patches using the monoid instance.
 data Fixup k p a
    = Fixup_Delete
-   | Fixup_Update (These (From k p a) (To k p a))
+   | Fixup_Update (These (DSum k (From k p)) (To k p a))
 
 -- | Compose patches having the same effect as applying the patches in turn:
 -- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
-instance ( GCompare k
-         , Cat.Semigroupoid p
-         -- , Cat.DecidablyEmpty p
-         , PatchHet2 p
-         , PatchSource1 p ~ PatchTarget1 p
-         ) => Semigroup (PatchDMapWithPatchingMove k p) where
+instance forall k p
+         . ( GCompare k
+           , Cat.Semigroupoid p
+           -- , Cat.DecidablyEmpty p
+           , PatchHet2 p
+           , PatchSource1 p ~ PatchTarget1 p
+           )
+         => Semigroup (PatchDMapWithPatchingMove k p) where
   PatchDMapWithPatchingMove ma <> PatchDMapWithPatchingMove mb = PatchDMapWithPatchingMove m
     where
       connections :: [DSum k (Pair1 (To k p) (From k p))]
@@ -261,23 +264,25 @@ instance ( GCompare k
         ma
         mb
       h :: DSum k (Pair1 (To k p) (From k p)) -> [DSum k (Fixup k p)]
-      h ((_ :: k between) :=> Pair1 editAfter editBefore) = case (editAfter, editBefore) of
-        (To_Move ((toAfter :: k after) :=> p1), From_Move ((fromBefore :: k before) :=> Flip p0)) ->
+      h ((between :: k between) :=> Pair1 editAfter editBefore) = case (editAfter, editBefore) of
+        (To_Move (Some (toAfter :: k after)), From_Move ((fromBefore :: k before) :=> Flip p) :: From k p between) ->
           --case toAfter `geq` fromBefore of
           --  Just Refl | Just Refl <- Cat.isId p0 ->
           --    [ toAfter :=> Fixup_Delete ]
           --  _ ->
-              [ toAfter :=> Fixup_Update (This $ From_Move $ fromBefore :=> (Flip $ p1 `o` p0))
-              , fromBefore :=> Fixup_Update (That $ To_Move $ toAfter :=> (p1 `o` p0))
+              [ toAfter :=> Fixup_Update (This $ between :=> From_Move (fromBefore :=> Flip p))
+              , fromBefore :=> Fixup_Update (That $ To_Move $ Some toAfter)
               ]
         (To_NonMove, From_Move (fromBefore :=> _)) ->
           -- The item is destroyed in the second patch, so indicate that it is
           -- destroyed in the source map
           [fromBefore :=> Fixup_Update (That To_NonMove)]
-        (To_Move (toAfter :=> p), From_Insert val) ->
-          [toAfter :=> Fixup_Update (This $ From_Insert $ applyAlwaysHet2 p val)]
-        (To_Move (toAfter :=> _), From_Delete) ->
-          [toAfter :=> Fixup_Update (This From_Delete)]
+        --(To_Move (Some toAfter), From_Insert val) ->
+        --  [toAfter :=> Fixup_Update (This $ From_Insert $ applyAlwaysHet2 p val)]
+        --(To_Move (Some toAfter), From_Delete) ->
+        --  [toAfter :=> Fixup_Update (This From_Delete)]
+        (To_Move (Some toAfter), _) ->
+          [toAfter :=> Fixup_Update (This $ between :=> editBefore)]
         (To_NonMove, _) ->
           []
       mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
@@ -292,10 +297,20 @@ instance ( GCompare k
         { _nodeInfo_from = _nodeInfo_from nia
         , _nodeInfo_to = _nodeInfo_to nib
         }
+      applyFixup :: k a -> NodeInfo k p a -> Fixup k p a -> Maybe (NodeInfo k p a)
       applyFixup _ ni = \case
         Fixup_Delete -> Nothing
         Fixup_Update u -> Just $ NodeInfo
-          { _nodeInfo_from = fromMaybe (_nodeInfo_from ni) $ getHere u
+          { _nodeInfo_from = case _nodeInfo_from ni of
+              f@(From_Move ((between0 :: k between0) :=> Flip (p' :: p between0 a))) -> case getHere u of -- The `from` fixup comes from the "old" patch
+                Nothing -> f -- If there's no `from` fixup, just use the "new" `from`
+                Just ((between1 :: k between1) :=> frm) -> case geq between0 between1 of
+                  Nothing -> error "fixup joined-on key did not match"
+                  Just Refl -> case frm of
+                    From_Insert v -> From_Insert $ applyAlwaysHet2 p' v
+                    From_Delete -> From_Delete
+                    From_Move (oldKey :=> Flip (p :: p oldKey between1)) -> From_Move $ oldKey :=> Flip (p' `o` p :: p oldKey a)
+              _ -> error "PatchMapWithPatchingMove: fixup for non-move From"
           , _nodeInfo_to = fromMaybe (_nodeInfo_to ni) $ getThere u
           }
       m = DMap.differenceWithKey applyFixup (DMap.unionWithKey combineNodeInfos ma mb) fixups
@@ -362,7 +377,7 @@ moveDMapKey
 moveDMapKey src dst = case src `geq` dst of
   Nothing -> PatchDMapWithPatchingMove $ DMap.fromList
     [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) To_NonMove
-    , src :=> NodeInfo From_Delete (To_Move $ dst :=> Proxy3)
+    , src :=> NodeInfo From_Delete (To_Move $ Some dst)
     ]
   Just _ -> PatchDMapWithPatchingMove DMap.empty
 
@@ -379,8 +394,8 @@ moveDMapKey src dst = case src `geq` dst of
 swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithPatchingMove k (Proxy3 v)
 swapDMapKey src dst = case src `geq` dst of
   Nothing -> PatchDMapWithPatchingMove $ DMap.fromList
-    [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) (To_Move $ src :=> Proxy3)
-    , src :=> NodeInfo (From_Move (dst :=> Flip Proxy3)) (To_Move $ dst :=> Proxy3)
+    [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) (To_Move $ Some src)
+    , src :=> NodeInfo (From_Move (dst :=> Flip Proxy3)) (To_Move $ Some dst)
     ]
   Just _ -> PatchDMapWithPatchingMove DMap.empty
 
@@ -455,7 +470,7 @@ mapPatchDMapWithPatchingMove f g (PatchDMapWithPatchingMove m) =
         j :: forall a. To k p a -> To k p' a
         j = \case
           To_NonMove -> To_NonMove
-          To_Move (k :=> p) -> To_Move $ k :=> g p
+          To_Move (Some k) -> To_Move $ Some k
 
 -- | Traverse an effectful function @forall a. PatchTarget1 p a -> m (v ' a)@
 -- over the given patch, transforming @'PatchDMapWithPatchingMove' k v@ into @m
@@ -491,9 +506,9 @@ traversePatchDMapWithPatchingMoveWithKey f g (PatchDMapWithPatchingMove m) =
           From_Delete -> pure From_Delete
           From_Move (fromKey :=> Flip p) -> From_Move . (fromKey :=>) . Flip <$> g fromKey k p
         j :: forall a. k a -> To k p a -> m (To k p' a)
-        j k = \case
+        j _ = \case
           To_NonMove -> pure To_NonMove
-          To_Move (toKey :=> p) -> To_Move . (toKey :=>) <$> g k toKey p
+          To_Move (Some toKey) -> pure $ To_Move $ Some toKey
 
 -- | Map a function which transforms @'From k PatchTarget1 p a@ into a @'From k
 -- PatchTarget1 p' a@ over a @'NodeInfo' k PatchTarget1 p a@.
@@ -538,7 +553,7 @@ weakenPatchDMapWithPatchingMoveWith f g (PatchDMapWithPatchingMove m) =
               From_Move (k :=> Flip p) -> MapWithPatchingMove.From_Move (mkSome k) $ g p
           , MapWithPatchingMove._nodeInfo_to = case _nodeInfo_to ni of
               To_NonMove -> Nothing
-              To_Move (k :=> _) -> Just (mkSome k)
+              To_Move (Some k) -> Just (mkSome k)
           }
 
 -- | "Weaken" a @'PatchDMapWithPatchingMove' (Const2 k a) v@ to a @'PatchMapWithPatchingMove' k
@@ -561,7 +576,7 @@ patchDMapWithPatchingMoveToPatchMapWithPatchingMoveWith f g (PatchDMapWithPatchi
               From_Move (Const2 k :=> Flip p) -> MapWithPatchingMove.From_Move k $ g p
           , MapWithPatchingMove._nodeInfo_to = case _nodeInfo_to ni of
               To_NonMove -> Nothing
-              To_Move (Const2 k :=> _) -> Just k
+              To_Move (Some (Const2 k)) -> Just k
           }
 
 -- | "Strengthen" a @'PatchMapWithPatchingMove' k v@ into a @'PatchDMapWithPatchingMove
@@ -585,7 +600,7 @@ const2PatchDMapWithPatchingMoveWith f (PatchMapWithPatchingMove p) =
               MapWithPatchingMove.From_Move fromKey Proxy -> From_Move $ Const2 fromKey :=> Flip Proxy3
           , _nodeInfo_to = case MapWithPatchingMove._nodeInfo_to ni of
               Nothing -> To_NonMove
-              Just toKey -> To_Move $ Const2 toKey :=> Proxy3
+              Just toKey -> To_Move $ Some (Const2 toKey)
           }
 
 -- | Apply the insertions, deletions, and moves to a given 'DMap'.

From 8e3015afccbc0f15564d9f6ffaf1762360e73c75 Mon Sep 17 00:00:00 2001
From: John Ericson <John.Ericson@Obsidian.Systems>
Date: Fri, 23 Apr 2021 13:08:53 -0400
Subject: [PATCH 20/27] Simplify type of "To"

Now that it doesn't contain patches, it doesn't need so many params.
---
 src/Data/Patch/DMapWithPatchingMove.hs | 66 +++++++++-----------------
 1 file changed, 23 insertions(+), 43 deletions(-)

diff --git a/src/Data/Patch/DMapWithPatchingMove.hs b/src/Data/Patch/DMapWithPatchingMove.hs
index c5f266b6..cc860cfd 100644
--- a/src/Data/Patch/DMapWithPatchingMove.hs
+++ b/src/Data/Patch/DMapWithPatchingMove.hs
@@ -32,6 +32,7 @@ import Data.Functor.Misc
   , weakenDMapWith
   , dmapToMapWith
   )
+import Data.Functor.Const (Const (..))
 import Data.Functor.Product (Product (..))
 import Data.GADT.Compare (GEq (..), GCompare (..))
 import Data.GADT.Show (GRead, GShow, gshow)
@@ -100,7 +101,7 @@ instance ( GCompare k
 data NodeInfo k p a = NodeInfo
   { _nodeInfo_from :: !(From k p a)
   -- ^ Change applying to the current key, be it an insert, move, or delete.
-  , _nodeInfo_to :: !(To k p a)
+  , _nodeInfo_to :: !(To k)
   -- ^ Where this key is moving to, if involved in a move. Should only be
   -- @ComposeMaybe (Just k)@ when there is a corresponding 'From_Move'.
   }
@@ -167,31 +168,18 @@ instance Cat.Category p => Cat.Category (Flip (p :: k -> k -> *)) where
 -- | The "to" part of a 'NodeInfo'. Rather than be built out of @From@ like @From@
 -- is, we store just the information necessary to compose a @To@ and @From@ like
 -- @oLocal@ composes two @From@s.
-data To (k :: a -> *) (p :: a -> a -> *) :: a -> * where
+data To (k :: a -> *) where
   -- | Delete or leave in place
-  To_NonMove :: To k p from
+  To_NonMove :: To k
   -- | Move the value from the given key @k a@ to this key. The target key
   -- should also have an entry in the patch giving the current key in
   -- @_nodeInfo_from@, usually but not necessarily with @To_Delete@.
-  To_Move :: !(Some k) -> To k p from
+  To_Move :: !(Some k) -> To k
 
-deriving instance ( Show (k a), GShow k
-                  , Has' Show k (p a)
-                  , Show (PatchTarget1 p a)
-                  ) => Show (To k p a)
-deriving instance ( Read (k a), GRead k
-                  , Has' Read k (p a)
-                  , Read (PatchTarget1 p a)
-                  ) => Read (To k p a)
-deriving instance ( GEq k
-                  , Has' Eq k (p a)
-                  , Eq (PatchTarget1 p a)
-                  ) => Eq (To k p a)
-deriving instance ( GCompare k
-                  , Has' Eq k (p a) -- superclass bug
-                  , Has' Ord k (p a)
-                  , Ord (PatchTarget1 p a)
-                  ) => Ord (To k p a)
+deriving instance GShow k => Show (To k)
+deriving instance GRead k => Read (To k)
+deriving instance GEq k => Eq (To k)
+deriving instance GCompare k => Ord (To k)
 
 -- |Test whether a 'PatchDMapWithPatchingMove' satisfies its invariants.
 validPatchDMapWithPatchingMove
@@ -238,13 +226,13 @@ validationErrorsForPatchDMapWithPatchingMove m =
           Just $ "unbalanced move at source key " <> gshow src <> " supposedly going to " <> gshow dst <> " but destination key is not moving"
     unbalancedMove _ = Nothing
 
--- |Higher kinded 2-tuple, identical to @Data.Functor.Product@ from base ≥ 4.9
-data Pair1 f g a = Pair1 (f a) (g a)
 
--- |Helper data structure used for composing patches using the monoid instance.
+data ToFrom k p a = ToFrom (To k) (From k p a)
+
+-- | Helper data structure used for composing patches using the monoid instance.
 data Fixup k p a
    = Fixup_Delete
-   | Fixup_Update (These (DSum k (From k p)) (To k p a))
+   | Fixup_Update (These (DSum k (From k p)) (To k))
 
 -- | Compose patches having the same effect as applying the patches in turn:
 -- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
@@ -258,13 +246,13 @@ instance forall k p
          => Semigroup (PatchDMapWithPatchingMove k p) where
   PatchDMapWithPatchingMove ma <> PatchDMapWithPatchingMove mb = PatchDMapWithPatchingMove m
     where
-      connections :: [DSum k (Pair1 (To k p) (From k p))]
+      connections :: [DSum k (ToFrom k p)]
       connections = DMap.toList $ DMap.intersectionWithKey
-        (\_ a b -> Pair1 (_nodeInfo_to a) (_nodeInfo_from b))
+        (\_ a b -> ToFrom (_nodeInfo_to a) (_nodeInfo_from b))
         ma
         mb
-      h :: DSum k (Pair1 (To k p) (From k p)) -> [DSum k (Fixup k p)]
-      h ((between :: k between) :=> Pair1 editAfter editBefore) = case (editAfter, editBefore) of
+      h :: DSum k (ToFrom k p) -> [DSum k (Fixup k p)]
+      h ((between :: k between) :=> ToFrom editAfter editBefore) = case (editAfter, editBefore) of
         (To_Move (Some (toAfter :: k after)), From_Move ((fromBefore :: k before) :=> Flip p) :: From k p between) ->
           --case toAfter `geq` fromBefore of
           --  Just Refl | Just Refl <- Cat.isId p0 ->
@@ -460,17 +448,13 @@ mapPatchDMapWithPatchingMove
 mapPatchDMapWithPatchingMove f g (PatchDMapWithPatchingMove m) =
   PatchDMapWithPatchingMove $ DMap.map (\ni -> NodeInfo
     { _nodeInfo_from = h $ _nodeInfo_from ni
-    , _nodeInfo_to = j $ _nodeInfo_to ni
+    , _nodeInfo_to = _nodeInfo_to ni
     }) m
   where h :: forall a. From k p a -> From k p' a
         h = \case
           From_Insert v -> From_Insert $ f v
           From_Delete -> From_Delete
           From_Move (k :=> Flip p) -> From_Move $ k :=> Flip (g p)
-        j :: forall a. To k p a -> To k p' a
-        j = \case
-          To_NonMove -> To_NonMove
-          To_Move (Some k) -> To_Move $ Some k
 
 -- | Traverse an effectful function @forall a. PatchTarget1 p a -> m (v ' a)@
 -- over the given patch, transforming @'PatchDMapWithPatchingMove' k v@ into @m
@@ -499,22 +483,18 @@ traversePatchDMapWithPatchingMoveWithKey
 traversePatchDMapWithPatchingMoveWithKey f g (PatchDMapWithPatchingMove m) =
   PatchDMapWithPatchingMove <$> DMap.traverseWithKey (\k ni -> NodeInfo
     <$> h k (_nodeInfo_from ni)
-    <*> j k (_nodeInfo_to ni)) m
+    <*> pure (_nodeInfo_to ni)) m
   where h :: forall a. k a -> From k p a -> m (From k p' a)
         h k = \case
           From_Insert v -> From_Insert <$> f k v
           From_Delete -> pure From_Delete
           From_Move (fromKey :=> Flip p) -> From_Move . (fromKey :=>) . Flip <$> g fromKey k p
-        j :: forall a. k a -> To k p a -> m (To k p' a)
-        j _ = \case
-          To_NonMove -> pure To_NonMove
-          To_Move (Some toKey) -> pure $ To_Move $ Some toKey
 
 -- | Map a function which transforms @'From k PatchTarget1 p a@ into a @'From k
 -- PatchTarget1 p' a@ over a @'NodeInfo' k PatchTarget1 p a@.
 nodeInfoMapFrom
   :: (From k p a -> From k p' a)
-  -> (To k p a -> To k p' a)
+  -> (To k -> To k)
   -> NodeInfo k p a
   -> NodeInfo k p' a
 nodeInfoMapFrom f g ni = NodeInfo
@@ -527,7 +507,7 @@ nodeInfoMapFrom f g ni = NodeInfo
 nodeInfoMapFromM
   :: Applicative f
   => (From k p a -> f (From k p' a))
-  -> (To k p a -> f (To k p' a))
+  -> (To k -> f (To k))
   -> NodeInfo k p a
   -> f (NodeInfo k p' a)
 nodeInfoMapFromM f g ni = NodeInfo
@@ -639,6 +619,6 @@ getDeletionsAndMoves
      )
   => PatchDMapWithPatchingMove k p
   -> DMap k (PatchSource1 p)
-  -> DMap k (Product (PatchTarget1 p) (To k p))
+  -> DMap k (Product (PatchTarget1 p) (Const (To k)))
 getDeletionsAndMoves (PatchDMapWithPatchingMove p) m = DMap.intersectionWithKey f m p
-  where f _ v ni = Pair v $ _nodeInfo_to ni
+  where f _ v ni = Pair v $ Const $ _nodeInfo_to ni

From 4da27a8007f25d0e7dcd5974cee86a8ece127d69 Mon Sep 17 00:00:00 2001
From: John Ericson <John.Ericson@Obsidian.Systems>
Date: Fri, 23 Apr 2021 13:13:25 -0400
Subject: [PATCH 21/27] Simplify type of fixup

---
 src/Data/Patch/DMapWithPatchingMove.hs | 24 ++++++++++++------------
 1 file changed, 12 insertions(+), 12 deletions(-)

diff --git a/src/Data/Patch/DMapWithPatchingMove.hs b/src/Data/Patch/DMapWithPatchingMove.hs
index cc860cfd..98c91a7d 100644
--- a/src/Data/Patch/DMapWithPatchingMove.hs
+++ b/src/Data/Patch/DMapWithPatchingMove.hs
@@ -230,7 +230,7 @@ validationErrorsForPatchDMapWithPatchingMove m =
 data ToFrom k p a = ToFrom (To k) (From k p a)
 
 -- | Helper data structure used for composing patches using the monoid instance.
-data Fixup k p a
+data Fixup k p
    = Fixup_Delete
    | Fixup_Update (These (DSum k (From k p)) (To k))
 
@@ -251,42 +251,42 @@ instance forall k p
         (\_ a b -> ToFrom (_nodeInfo_to a) (_nodeInfo_from b))
         ma
         mb
-      h :: DSum k (ToFrom k p) -> [DSum k (Fixup k p)]
+      h :: DSum k (ToFrom k p) -> [DSum k (Const (Fixup k p))]
       h ((between :: k between) :=> ToFrom editAfter editBefore) = case (editAfter, editBefore) of
         (To_Move (Some (toAfter :: k after)), From_Move ((fromBefore :: k before) :=> Flip p) :: From k p between) ->
           --case toAfter `geq` fromBefore of
           --  Just Refl | Just Refl <- Cat.isId p0 ->
           --    [ toAfter :=> Fixup_Delete ]
           --  _ ->
-              [ toAfter :=> Fixup_Update (This $ between :=> From_Move (fromBefore :=> Flip p))
-              , fromBefore :=> Fixup_Update (That $ To_Move $ Some toAfter)
+              [ toAfter :=> Const (Fixup_Update $ This $ between :=> From_Move (fromBefore :=> Flip p))
+              , fromBefore :=> Const (Fixup_Update $ That $ To_Move $ Some toAfter)
               ]
         (To_NonMove, From_Move (fromBefore :=> _)) ->
           -- The item is destroyed in the second patch, so indicate that it is
           -- destroyed in the source map
-          [fromBefore :=> Fixup_Update (That To_NonMove)]
+          [fromBefore :=> Const ( Fixup_Update $ That To_NonMove)]
         --(To_Move (Some toAfter), From_Insert val) ->
         --  [toAfter :=> Fixup_Update (This $ From_Insert $ applyAlwaysHet2 p val)]
         --(To_Move (Some toAfter), From_Delete) ->
         --  [toAfter :=> Fixup_Update (This From_Delete)]
         (To_Move (Some toAfter), _) ->
-          [toAfter :=> Fixup_Update (This $ between :=> editBefore)]
+          [toAfter :=> Const (Fixup_Update $ This $ between :=> editBefore)]
         (To_NonMove, _) ->
           []
-      mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete
-      mergeFixups _ (Fixup_Update a) (Fixup_Update b)
+      mergeFixups _ (Const Fixup_Delete) (Const Fixup_Delete) = Const $ Fixup_Delete
+      mergeFixups _ (Const (Fixup_Update a)) (Const (Fixup_Update b))
         | This x <- a, That y <- b
-        = Fixup_Update $ These x y
+        = Const $ Fixup_Update $ These x y
         | That y <- a, This x <- b
-        = Fixup_Update $ These x y
+        = Const $ Fixup_Update $ These x y
       mergeFixups _ _ _ = error "PatchDMapWithPatchingMove: incompatible fixups"
       fixups = DMap.fromListWithKey mergeFixups $ concatMap h connections
       combineNodeInfos _ nia nib = NodeInfo
         { _nodeInfo_from = _nodeInfo_from nia
         , _nodeInfo_to = _nodeInfo_to nib
         }
-      applyFixup :: k a -> NodeInfo k p a -> Fixup k p a -> Maybe (NodeInfo k p a)
-      applyFixup _ ni = \case
+      applyFixup :: k a -> NodeInfo k p a -> Const (Fixup k p) a -> Maybe (NodeInfo k p a)
+      applyFixup _ ni (Const fixup) = case fixup of
         Fixup_Delete -> Nothing
         Fixup_Update u -> Just $ NodeInfo
           { _nodeInfo_from = case _nodeInfo_from ni of

From 76f010efa546c44b686274edaeb3236bb96686a2 Mon Sep 17 00:00:00 2001
From: John Ericson <John.Ericson@Obsidian.Systems>
Date: Fri, 23 Apr 2021 13:17:01 -0400
Subject: [PATCH 22/27] Delete old code and format a bit

---
 src/Data/Patch/DMapWithPatchingMove.hs | 4 ----
 src/Data/Patch/MapWithPatchingMove.hs  | 5 ++++-
 2 files changed, 4 insertions(+), 5 deletions(-)

diff --git a/src/Data/Patch/DMapWithPatchingMove.hs b/src/Data/Patch/DMapWithPatchingMove.hs
index 98c91a7d..df0810fb 100644
--- a/src/Data/Patch/DMapWithPatchingMove.hs
+++ b/src/Data/Patch/DMapWithPatchingMove.hs
@@ -265,10 +265,6 @@ instance forall k p
           -- The item is destroyed in the second patch, so indicate that it is
           -- destroyed in the source map
           [fromBefore :=> Const ( Fixup_Update $ That To_NonMove)]
-        --(To_Move (Some toAfter), From_Insert val) ->
-        --  [toAfter :=> Fixup_Update (This $ From_Insert $ applyAlwaysHet2 p val)]
-        --(To_Move (Some toAfter), From_Delete) ->
-        --  [toAfter :=> Fixup_Update (This From_Delete)]
         (To_Move (Some toAfter), _) ->
           [toAfter :=> Const (Fixup_Update $ This $ between :=> editBefore)]
         (To_NonMove, _) ->
diff --git a/src/Data/Patch/MapWithPatchingMove.hs b/src/Data/Patch/MapWithPatchingMove.hs
index 30c0efd1..fd238f6d 100644
--- a/src/Data/Patch/MapWithPatchingMove.hs
+++ b/src/Data/Patch/MapWithPatchingMove.hs
@@ -379,7 +379,10 @@ instance ( Ord k
             -> [ (toAfter, Fixup_Update (This editBefore))
                , (fromBefore, Fixup_Update (That mToAfter))
                ]
-        (Nothing, From_Move fromBefore _) -> [(fromBefore, Fixup_Update (That mToAfter))] -- The item is destroyed in the second patch, so indicate that it is destroyed in the source map
+        (Nothing, From_Move fromBefore _) ->
+           -- The item is destroyed in the second patch, so indicate that it is
+           -- destroyed in the source map
+           [(fromBefore, Fixup_Update (That mToAfter))]
         (Just toAfter, _) -> [(toAfter, Fixup_Update (This editBefore))]
         (Nothing, _) -> []
       mergeFixups _ Fixup_Delete Fixup_Delete = Fixup_Delete

From efb8a9ba454190efe84f203c188180b9511591f0 Mon Sep 17 00:00:00 2001
From: John Ericson <John.Ericson@Obsidian.Systems>
Date: Fri, 23 Apr 2021 13:21:45 -0400
Subject: [PATCH 23/27] Put back Cat.DecidablyEmpty

---
 src/Data/Patch/DMapWithPatchingMove.hs | 15 ++++++++-------
 1 file changed, 8 insertions(+), 7 deletions(-)

diff --git a/src/Data/Patch/DMapWithPatchingMove.hs b/src/Data/Patch/DMapWithPatchingMove.hs
index df0810fb..33afb1df 100644
--- a/src/Data/Patch/DMapWithPatchingMove.hs
+++ b/src/Data/Patch/DMapWithPatchingMove.hs
@@ -20,7 +20,7 @@
 module Data.Patch.DMapWithPatchingMove where
 
 import qualified Control.Category as Cat
---import qualified Control.Category.DecidablyEmpty as Cat
+import qualified Control.Category.DecidablyEmpty as Cat
 
 import Data.Constraint.Extras (Has')
 import Data.Dependent.Map (DMap)
@@ -88,6 +88,7 @@ newtype PatchDMapWithPatchingMove k v = PatchDMapWithPatchingMove (DMap k (NodeI
 
 -- It won't let me derive for some reason
 instance ( GCompare k
+         , Cat.DecidablyEmpty v
          , Cat.Semigroupoid v
          , PatchHet2 v
          , PatchSource1 v ~ PatchTarget1 v
@@ -239,7 +240,7 @@ data Fixup k p
 instance forall k p
          . ( GCompare k
            , Cat.Semigroupoid p
-           -- , Cat.DecidablyEmpty p
+           , Cat.DecidablyEmpty p
            , PatchHet2 p
            , PatchSource1 p ~ PatchTarget1 p
            )
@@ -254,10 +255,10 @@ instance forall k p
       h :: DSum k (ToFrom k p) -> [DSum k (Const (Fixup k p))]
       h ((between :: k between) :=> ToFrom editAfter editBefore) = case (editAfter, editBefore) of
         (To_Move (Some (toAfter :: k after)), From_Move ((fromBefore :: k before) :=> Flip p) :: From k p between) ->
-          --case toAfter `geq` fromBefore of
-          --  Just Refl | Just Refl <- Cat.isId p0 ->
-          --    [ toAfter :=> Fixup_Delete ]
-          --  _ ->
+          case toAfter `geq` fromBefore of
+            Just Refl | Just Refl <- Cat.isId p ->
+              [ toAfter :=> Const Fixup_Delete ]
+            _ ->
               [ toAfter :=> Const (Fixup_Update $ This $ between :=> From_Move (fromBefore :=> Flip p))
               , fromBefore :=> Const (Fixup_Update $ That $ To_Move $ Some toAfter)
               ]
@@ -313,7 +314,7 @@ instance forall k p
 -- @'applyAlways' (p <> q) == 'applyAlways' p . 'applyAlways' q@
 instance ( GCompare k
          , Cat.Semigroupoid p
-         -- , DecidablyEmpty p
+         , Cat.DecidablyEmpty p
          , PatchHet2 p
          , PatchSource1 p ~ PatchTarget1 p
          ) => Monoid (PatchDMapWithPatchingMove k p) where

From 62bd0fc0046b57438ceb70968c274aedef11aa33 Mon Sep 17 00:00:00 2001
From: John Ericson <John.Ericson@Obsidian.Systems>
Date: Fri, 23 Apr 2021 13:23:59 -0400
Subject: [PATCH 24/27] Remove redundant geq

---
 src/Data/Patch/DMapWithPatchingMove.hs | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/src/Data/Patch/DMapWithPatchingMove.hs b/src/Data/Patch/DMapWithPatchingMove.hs
index 33afb1df..609f7f5a 100644
--- a/src/Data/Patch/DMapWithPatchingMove.hs
+++ b/src/Data/Patch/DMapWithPatchingMove.hs
@@ -255,10 +255,10 @@ instance forall k p
       h :: DSum k (ToFrom k p) -> [DSum k (Const (Fixup k p))]
       h ((between :: k between) :=> ToFrom editAfter editBefore) = case (editAfter, editBefore) of
         (To_Move (Some (toAfter :: k after)), From_Move ((fromBefore :: k before) :=> Flip p) :: From k p between) ->
-          case toAfter `geq` fromBefore of
-            Just Refl | Just Refl <- Cat.isId p ->
+          case Cat.isId p of
+            Just Refl ->
               [ toAfter :=> Const Fixup_Delete ]
-            _ ->
+            Nothing ->
               [ toAfter :=> Const (Fixup_Update $ This $ between :=> From_Move (fromBefore :=> Flip p))
               , fromBefore :=> Const (Fixup_Update $ That $ To_Move $ Some toAfter)
               ]

From 055f256a762d9dbe4e20505a99db8413a36d92b9 Mon Sep 17 00:00:00 2001
From: John Ericson <John.Ericson@Obsidian.Systems>
Date: Fri, 23 Apr 2021 13:29:10 -0400
Subject: [PATCH 25/27] Simplify

Expanded some thing fighting the type checker, can put back now.
---
 src/Data/Patch/DMapWithPatchingMove.hs | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/src/Data/Patch/DMapWithPatchingMove.hs b/src/Data/Patch/DMapWithPatchingMove.hs
index 609f7f5a..cfa782a5 100644
--- a/src/Data/Patch/DMapWithPatchingMove.hs
+++ b/src/Data/Patch/DMapWithPatchingMove.hs
@@ -259,13 +259,13 @@ instance forall k p
             Just Refl ->
               [ toAfter :=> Const Fixup_Delete ]
             Nothing ->
-              [ toAfter :=> Const (Fixup_Update $ This $ between :=> From_Move (fromBefore :=> Flip p))
-              , fromBefore :=> Const (Fixup_Update $ That $ To_Move $ Some toAfter)
+              [ toAfter :=> Const (Fixup_Update $ This $ between :=> editBefore)
+              , fromBefore :=> Const (Fixup_Update $ That editAfter)
               ]
         (To_NonMove, From_Move (fromBefore :=> _)) ->
           -- The item is destroyed in the second patch, so indicate that it is
           -- destroyed in the source map
-          [fromBefore :=> Const ( Fixup_Update $ That To_NonMove)]
+          [fromBefore :=> Const (Fixup_Update $ That To_NonMove)]
         (To_Move (Some toAfter), _) ->
           [toAfter :=> Const (Fixup_Update $ This $ between :=> editBefore)]
         (To_NonMove, _) ->

From 76033e994b91f6a69cf894df733419f25422d57b Mon Sep 17 00:00:00 2001
From: John Ericson <John.Ericson@Obsidian.Systems>
Date: Fri, 23 Apr 2021 13:32:03 -0400
Subject: [PATCH 26/27] Improve error

---
 src/Data/Patch/DMapWithPatchingMove.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/src/Data/Patch/DMapWithPatchingMove.hs b/src/Data/Patch/DMapWithPatchingMove.hs
index cfa782a5..0938006b 100644
--- a/src/Data/Patch/DMapWithPatchingMove.hs
+++ b/src/Data/Patch/DMapWithPatchingMove.hs
@@ -290,7 +290,7 @@ instance forall k p
               f@(From_Move ((between0 :: k between0) :=> Flip (p' :: p between0 a))) -> case getHere u of -- The `from` fixup comes from the "old" patch
                 Nothing -> f -- If there's no `from` fixup, just use the "new" `from`
                 Just ((between1 :: k between1) :=> frm) -> case geq between0 between1 of
-                  Nothing -> error "fixup joined-on key did not match"
+                  Nothing -> error "PatchMapWithPatchingMove: fixup joined-on key did not match"
                   Just Refl -> case frm of
                     From_Insert v -> From_Insert $ applyAlwaysHet2 p' v
                     From_Delete -> From_Delete

From 873bad6348e90cb8ea33e448caca976f73387c17 Mon Sep 17 00:00:00 2001
From: John Ericson <John.Ericson@Obsidian.Systems>
Date: Fri, 23 Apr 2021 14:22:47 -0400
Subject: [PATCH 27/27] Replace Proxy3 with something more appropriate

---
 src/Data/Functor/Misc.hs               | 13 ----------
 src/Data/Patch/Class.hs                | 34 +++++++++++++++++++-------
 src/Data/Patch/DMapWithPatchingMove.hs | 19 +++++++-------
 3 files changed, 35 insertions(+), 31 deletions(-)

diff --git a/src/Data/Functor/Misc.hs b/src/Data/Functor/Misc.hs
index d85fe822..50ef7403 100644
--- a/src/Data/Functor/Misc.hs
+++ b/src/Data/Functor/Misc.hs
@@ -21,7 +21,6 @@ are relevant to the use of 'Functor'-based datastructures like
 module Data.Functor.Misc
   ( -- * Const2
     Const2 (..)
-  , Proxy3 (..)
   , First2 (..)
   , unConst2
   , dmapToMap
@@ -43,7 +42,6 @@ module Data.Functor.Misc
   , ComposeMaybe (..)
   ) where
 
-import qualified Control.Category as Cat
 import Data.Dependent.Map (DMap)
 import qualified Data.Dependent.Map as DMap
 import Data.Dependent.Sum
@@ -96,17 +94,6 @@ instance Ord k => GCompare (Const2 k v) where
     EQ -> GEQ
     GT -> GGT
 
-data Proxy3 :: x -> y -> z -> Type 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 -> Type) (a :: k) (b :: k) = First2 (t b)
   deriving ( Show, Read, Eq, Ord
            , Functor, Foldable, Traversable
diff --git a/src/Data/Patch/Class.hs b/src/Data/Patch/Class.hs
index 5921c93d..491cf4ee 100644
--- a/src/Data/Patch/Class.hs
+++ b/src/Data/Patch/Class.hs
@@ -3,11 +3,13 @@
 {-# 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.
@@ -17,6 +19,7 @@ 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)
@@ -25,7 +28,7 @@ import Data.Maybe
 import Data.Semigroup (Semigroup(..))
 #endif
 import Data.Proxy
-import Data.Type.Equality ((:~:) (..))
+import Data.Typeable
 
 class PatchHet p where
   type PatchSource p :: Type
@@ -165,12 +168,25 @@ instance PatchHet (First2 (t :: k -> Type) (from :: k) (to :: k)) where
   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 -> Type) (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
+data IndexedEq :: (k -> Type) -> k -> k -> Type where
+  IndexedRefl :: IndexedEq k x x
+  deriving (Typeable)
 
-instance PatchHet2Base (Proxy3 (t :: k -> Type) :: k -> k -> Type) where
-  type PatchSource1 (Proxy3 t) = t
-  type PatchTarget1 (Proxy3 t) = t
+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
diff --git a/src/Data/Patch/DMapWithPatchingMove.hs b/src/Data/Patch/DMapWithPatchingMove.hs
index 40cc7e8d..13324294 100644
--- a/src/Data/Patch/DMapWithPatchingMove.hs
+++ b/src/Data/Patch/DMapWithPatchingMove.hs
@@ -28,7 +28,7 @@ import Data.Dependent.Sum (DSum (..))
 import qualified Data.Dependent.Map as DMap
 import Data.Functor.Constant (Constant (..))
 import Data.Functor.Misc
-  ( Const2 (..), Proxy3 (..)
+  ( Const2 (..)
   , weakenDMapWith
   , dmapToMapWith
   )
@@ -53,6 +53,7 @@ import Data.Patch.Class
   ( Patch (..), PatchHet (..)
   , PatchHet2 (..), PatchSource1, PatchTarget1
   , applyAlwaysHet2
+  , IndexedEq (..)
   )
 import Data.Patch.MapWithPatchingMove (PatchMapWithPatchingMove (..))
 import qualified Data.Patch.MapWithPatchingMove as MapWithPatchingMove
@@ -359,10 +360,10 @@ insertDMapKey k v =
 -- @
 moveDMapKey
   :: GCompare k
-  => k a -> k a -> PatchDMapWithPatchingMove k (Proxy3 v)
+  => k a -> k a -> PatchDMapWithPatchingMove k (IndexedEq v)
 moveDMapKey src dst = case src `geq` dst of
   Nothing -> PatchDMapWithPatchingMove $ DMap.fromList
-    [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) To_NonMove
+    [ dst :=> NodeInfo (From_Move (src :=> Flip IndexedRefl)) To_NonMove
     , src :=> NodeInfo From_Delete (To_Move $ Some dst)
     ]
   Just _ -> PatchDMapWithPatchingMove DMap.empty
@@ -377,11 +378,11 @@ moveDMapKey src dst = case src `geq` dst of
 --      . maybe id (DMap.insert b) (aMay <> bMay)
 --      . DMap.delete a . DMap.delete b $ dmap
 -- @
-swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithPatchingMove k (Proxy3 v)
+swapDMapKey :: GCompare k => k a -> k a -> PatchDMapWithPatchingMove k (IndexedEq v)
 swapDMapKey src dst = case src `geq` dst of
   Nothing -> PatchDMapWithPatchingMove $ DMap.fromList
-    [ dst :=> NodeInfo (From_Move (src :=> Flip Proxy3)) (To_Move $ Some src)
-    , src :=> NodeInfo (From_Move (dst :=> Flip Proxy3)) (To_Move $ Some dst)
+    [ dst :=> NodeInfo (From_Move (src :=> Flip IndexedRefl)) (To_Move $ Some src)
+    , src :=> NodeInfo (From_Move (dst :=> Flip IndexedRefl)) (To_Move $ Some dst)
     ]
   Just _ -> PatchDMapWithPatchingMove DMap.empty
 
@@ -566,16 +567,16 @@ const2PatchDMapWithPatchingMoveWith
   :: forall k v v' a
   .  (v -> v' a)
   -> PatchMapWithPatchingMove k (Proxy v)
-  -> PatchDMapWithPatchingMove (Const2 k a) (Proxy3 v')
+  -> PatchDMapWithPatchingMove (Const2 k a) (IndexedEq v')
 const2PatchDMapWithPatchingMoveWith f (PatchMapWithPatchingMove p) =
   PatchDMapWithPatchingMove $ DMap.fromDistinctAscList $ g <$> Map.toAscList p
   where g :: (k, MapWithPatchingMove.NodeInfo k (Proxy v))
-          -> DSum (Const2 k a) (NodeInfo (Const2 k a) (Proxy3 v'))
+          -> DSum (Const2 k a) (NodeInfo (Const2 k a) (IndexedEq v'))
         g (k, ni) = Const2 k :=> NodeInfo
           { _nodeInfo_from = case MapWithPatchingMove._nodeInfo_from ni of
               MapWithPatchingMove.From_Insert v -> From_Insert $ f v
               MapWithPatchingMove.From_Delete -> From_Delete
-              MapWithPatchingMove.From_Move fromKey Proxy -> From_Move $ Const2 fromKey :=> Flip Proxy3
+              MapWithPatchingMove.From_Move fromKey Proxy -> From_Move $ Const2 fromKey :=> Flip IndexedRefl
           , _nodeInfo_to = case MapWithPatchingMove._nodeInfo_to ni of
               Nothing -> To_NonMove
               Just toKey -> To_Move $ Some (Const2 toKey)