Copy holds a TermF.

src/Alignment.hs

@@ -47,7 +47,7 @@ hasChanges = or . (True <$)
 -- | Align a Diff into a list of Join These SplitDiffs representing the (possibly blank) lines on either side.
 alignDiff :: (HasField fields Range, Traversable f) => Both Source -> Diff f (Record fields) -> [Join These (SplitDiff [] (Record fields))]
 alignDiff sources = evalDiff $ \ diff env -> case diff of
-  Copy _ ann r -> alignSyntax (runBothWith ((Join .) . These)) wrap getRange sources (ann :< r)
+  Copy _ body -> alignSyntax (runBothWith ((Join .) . These)) wrap getRange sources body
   Var v -> fromMaybe [] (envLookup v env)
   Patch patch -> alignPatch sources patch
 

src/Diff.hs

@@ -9,7 +9,7 @@ import Data.Bifoldable
 import Data.Bifunctor
 import Data.Bitraversable
 import Data.Foldable (fold)
-import Data.Functor.Both (Both, Join(..), liftShowsPrecBoth)
+import Data.Functor.Both (Both)
 import qualified Data.Functor.Both as Both
 import Data.Functor.Classes
 import Data.Functor.Classes.Pretty.Generic as Pretty
@@ -29,7 +29,7 @@ import Text.Show
 newtype Diff syntax ann = Diff { unDiff :: DiffF syntax ann (Diff syntax ann) }
 
 data DiffF syntax ann recur
-  = Copy [(Metavar, recur)] (Both ann) (syntax recur)
+  = Copy [(Metavar, recur)] (TermF syntax (Both ann) recur)
   | Var Metavar
   | Patch (Patch (TermF syntax ann recur))
   deriving (Foldable, Functor, Traversable)
@@ -37,7 +37,7 @@ data DiffF syntax ann recur
 type SyntaxDiff fields = Diff Syntax (Record fields)
 
 diffFBindings :: DiffF syntax ann recur -> [(Metavar, recur)]
-diffFBindings (Copy bindings _ _) = bindings
+diffFBindings (Copy bindings _) = bindings
 diffFBindings _ = []
 
 
@@ -48,7 +48,7 @@ newtype Metavar = Metavar { unMetavar :: Int }
 
 freeMetavariables :: (Foldable syntax, Functor syntax) => Diff syntax ann -> Set.Set Metavar
 freeMetavariables = cata $ \ diff -> case diff of
-  Copy bindings _ body -> foldMap snd bindings <> foldr Set.delete (fold body) (fst <$> bindings)
+  Copy bindings body -> foldMap snd bindings <> foldr Set.delete (fold body) (fst <$> bindings)
   Var v -> Set.singleton v
   Patch patch -> foldMap fold patch
 
@@ -69,10 +69,10 @@ evalDiff algebra = evalDiffR (\ diff env -> algebra (snd <$> diff) (snd <$> env)
 evalDiffR :: Functor syntax => (DiffF syntax ann (Diff syntax ann, a) -> Env (Diff syntax ann, a) -> a) -> Diff syntax ann -> a
 evalDiffR algebra = flip go mempty
   where go = para $ \ diff env -> case diff of
-          Copy bindings ann syntax ->
+          Copy bindings body ->
             let evaluated = fmap (second ($ env)) <$> bindings
                 extended = foldr (uncurry envExtend) env evaluated
-            in algebra (Copy evaluated ann (second ($ extended) <$> syntax)) env
+            in algebra (Copy evaluated (second ($ extended) <$> body)) env
           _ -> algebra (second ($ env) <$> diff) env
 
 evalDiffRM :: (Functor syntax, Reader (Env (Diff syntax ann, Eff fs a)) :< fs) => (DiffF syntax ann (Diff syntax ann, Eff fs a) -> Eff fs a) -> Diff syntax ann -> Eff fs a
@@ -82,7 +82,7 @@ evalDiffRM algebra = para (\ diff -> local (bindMetavariables diff) (algebra dif
 
 diffSum :: (Foldable syntax, Functor syntax) => (forall a. Patch a -> Int) -> Diff syntax ann -> Int
 diffSum patchCost = evalDiff $ \ diff env -> case diff of
-  Copy _ _ syntax -> sum syntax
+  Copy _ body -> sum body
   Var v -> fromMaybe 0 (envLookup v env)
   Patch p -> patchCost p + sum (sum <$> p)
 
@@ -92,14 +92,14 @@ diffCost = diffSum (const 1)
 
 diffPatches :: (Foldable syntax, Functor syntax) => Diff syntax ann -> [Patch (TermF syntax ann (Diff syntax ann))]
 diffPatches = evalDiffR $ \ diff env -> case diff of
-  Copy _ _ r -> foldMap snd r
+  Copy _ r -> foldMap snd r
   Var v -> maybe [] snd (envLookup v env)
   Patch p -> [fmap (fmap fst) p]
 
 -- | Merge a diff using a function to provide the Term (in Maybe, to simplify recovery of the before/after state) for every Patch.
 mergeMaybe :: (Mergeable syntax, Traversable syntax) => (Patch (Term syntax ann) -> Maybe (Term syntax ann)) -> (Both ann -> ann) -> Diff syntax ann -> Maybe (Term syntax ann)
 mergeMaybe transform extractAnnotation = evalDiff $ \ diff env -> case diff of
-  Copy _ annotations syntax -> Term . (extractAnnotation annotations :<) <$> sequenceAlt syntax
+  Copy _ (annotations :< syntax) -> Term . (extractAnnotation annotations :<) <$> sequenceAlt syntax
   Var v -> join (envLookup v env)
   Patch patch -> traverse sequenceA patch >>= transform . fmap Term
 
@@ -133,7 +133,7 @@ deleting = cata (Diff . Patch . Delete)
 
 
 copy :: Both ann -> syntax (Diff syntax ann) -> Diff syntax ann
-copy = (Diff .) . Copy []
+copy = (Diff .) . (Copy [] .) . (:<)
 
 
 instance Pretty Metavar where
@@ -147,7 +147,7 @@ instance (Apply1 Pretty1 fs, Pretty ann) => Pretty (Diff (Union fs) ann) where
   pretty = liftPretty pretty prettyList
 
 instance Apply1 Pretty1 fs => Pretty2 (DiffF (Union fs)) where
-  liftPretty2 pA plA pB plB (Copy bindings (Join ann) f) = pretty ("let" :: String) <+> align (vsep (prettyKV <$> bindings)) <> line <> pretty ("in" :: String) <+> liftPretty2 pA plA pA plA ann <+> liftPrettyUnion pB plB f
+  liftPretty2 pA plA pB plB (Copy bindings body) = pretty ("let" :: String) <+> align (vsep (prettyKV <$> bindings)) <> line <> pretty ("in" :: String) <+> liftPretty2 (liftPretty pA plA) (list . map (liftPretty pA plA)) pB plB body
     where prettyKV (var, val) = pretty var <+> pretty '=' <+> pB val
   liftPretty2 _ _ _ _ (Var v) = pretty v
   liftPretty2 pA plA pB plB (Patch p) = liftPretty (liftPretty2 pA plA pB plB) (Pretty.list . map (liftPretty2 pA plA pB plB)) p
@@ -165,7 +165,7 @@ instance (Eq1 f, Eq a) => Eq (Diff f a) where
 
 instance Eq1 f => Eq2 (DiffF f) where
   liftEq2 eqA eqB d1 d2 = case (d1, d2) of
-    (Copy v1 (Join (a1, b1)) f1, Copy v2 (Join (a2, b2)) f2) -> liftEq (liftEq eqB) v1 v2 && eqA a1 a2 && eqA b1 b2 && liftEq eqB f1 f2
+    (Copy v1 b1, Copy v2 b2) -> liftEq (liftEq eqB) v1 v2 && liftEq2 (liftEq eqA) eqB b1 b2
     (Var v1, Var v2) -> v1 == v2
     (Patch p1, Patch p2) -> liftEq (liftEq2 eqA eqB) p1 p2
     _ -> False
@@ -185,7 +185,7 @@ instance (Show1 f, Show a) => Show (Diff f a) where
 
 instance Show1 f => Show2 (DiffF f) where
   liftShowsPrec2 spA slA spB slB d diff = case diff of
-    Copy bindings ann r -> showParen (d > 10) $ showString "Copy " . liftShowList spB slB bindings . showChar ' ' . liftShowsPrecBoth spA slA 11 ann . showChar ' ' . liftShowsPrec spB slB 11 r
+    Copy bindings body -> showsBinaryWith (const (liftShowList spB slB)) (liftShowsPrec2 (liftShowsPrec spA slA) (liftShowList spA slA) spB slB) "Copy" d bindings body
     Var v -> showsUnaryWith showsPrec "Var" d v
     Patch patch -> showsUnaryWith (liftShowsPrec (liftShowsPrec2 spA slA spB slB) (liftShowList2 spA slA spB slB)) "Patch" d patch
 
@@ -207,17 +207,17 @@ instance Traversable f => Traversable (Diff f) where
 
 
 instance Functor syntax => Bifunctor (DiffF syntax) where
-  bimap f g (Copy bindings anns r) = Copy (fmap g <$> bindings) (fmap f anns) (fmap g r)
+  bimap f g (Copy bindings body) = Copy (fmap g <$> bindings) (bimap (fmap f) g body)
   bimap _ _ (Var v) = Var v
   bimap f g (Patch patch) = Patch (bimap f g <$> patch)
 
 instance Foldable f => Bifoldable (DiffF f) where
-  bifoldMap f g (Copy vs as r) = foldMap (g . snd) vs `mappend` foldMap f as `mappend` foldMap g r
+  bifoldMap f g (Copy vs body) = foldMap (g . snd) vs `mappend` bifoldMap (foldMap f) g body
   bifoldMap _ _ (Var _) = mempty
   bifoldMap f g (Patch p) = foldMap (bifoldMap f g) p
 
 instance Traversable f => Bitraversable (DiffF f) where
-  bitraverse f g (Copy vs as r) = Copy <$> traverse (traverse g) vs <*> traverse f as <*> traverse g r
+  bitraverse f g (Copy vs body) = Copy <$> traverse (traverse g) vs <*> bitraverse (traverse f) g body
   bitraverse _ _ (Var v) = pure (Var v)
   bitraverse f g (Patch p) = Patch <$> traverse (bitraverse f g) p
 
@@ -230,6 +230,6 @@ instance (ToJSONFields a, ToJSONFields1 f) => ToJSONFields (Diff f a) where
   toJSONFields = toJSONFields . unDiff
 
 instance (ToJSON b, ToJSONFields a, ToJSONFields1 f) => ToJSONFields (DiffF f a b) where
-  toJSONFields (Copy vs a f)     = [ "bindings" .= vs] <> toJSONFields a <> toJSONFields1 f
+  toJSONFields (Copy vs body)    = [ "bindings" .= vs] <> toJSONFields body
   toJSONFields (Var (Metavar v)) = [ "metavar" .= v ]
   toJSONFields (Patch a)         = toJSONFields a

src/Interpreter.hs

@@ -125,7 +125,7 @@ editDistanceUpTo :: (GAlign f, Foldable f, Functor f) => Integer -> These (Term
 editDistanceUpTo m = these termSize termSize (\ a b -> diffCost m (approximateDiff a b))
   where diffCost = flip . evalDiff $ \ diff env m -> case diff of
           _ | m <= 0 -> 0
-          Copy _ _ r -> sum (fmap ($ pred m) r)
+          Copy _ body -> sum (fmap ($ pred m) body)
           Var v -> maybe 0 ($ pred m) (envLookup v env)
           Patch patch -> succ (sum (sum . fmap ($ pred m) <$> patch))
         approximateDiff a b = maybe (replacing a b) (copy (both (extract a) (extract b))) (galignWith (these deleting inserting approximateDiff) (unwrap a) (unwrap b))

src/Renderer/SExpression.hs

@@ -32,7 +32,7 @@ printDiffF diff n = case diff of
     Delete term -> nl n <> pad (n - 1) <> "{-" <> printTermF term n <> "-}"
     Replace a b -> nl n <> pad (n - 1) <> "{ " <> printTermF a n
                 <> nl (n + 1) <> pad (n - 1) <> "->" <> printTermF b n <> " }"
-  Copy vs (Join (_, annotation)) syntax -> nl n <> pad n <> "(" <> showBindings (fmap (\ b -> b n) <$> vs) <> showAnnotation annotation <> foldMap (\ d -> d (n + 1)) syntax <> ")"
+  Copy vs (Join (_, annotation) :< syntax) -> nl n <> pad n <> "(" <> showBindings (fmap (\ b -> b n) <$> vs) <> showAnnotation annotation <> foldMap (\ d -> d (n + 1)) syntax <> ")"
   Var v -> nl n <> pad n <> showMetavar v
 
 printTermF :: (ConstrainAll Show fields, Foldable f, Functor f) => TermF f (Record fields) (Int -> ByteString) -> Int -> ByteString

src/Renderer/TOC.hs

@@ -153,7 +153,7 @@ tableOfContentsBy :: (Foldable f, Functor f)
                   -> [Entry a]                                   -- ^ A list of entries for relevant changed and unchanged nodes in the diff.
 tableOfContentsBy selector = fromMaybe [] . evalDiff diffAlgebra
   where diffAlgebra r env = case r of
-          Copy _ ann r -> case (selector (Both.snd ann :< r), fold r) of
+          Copy _ (ann :< r) -> case (selector (Both.snd ann :< r), fold r) of
             (Just a, Nothing) -> Just [Unchanged a]
             (Just a, Just []) -> Just [Changed a]
             (_     , entries) -> entries