Merge pull request #1337 from github/separate-diff-annotation-parameters

Separate diff annotation parameters

semantic-diff.cabal

@@ -76,7 +76,6 @@ library
                      , Semantic.Util
                      , SemanticCmdLine
                      , SES
-                     , SES.Myers
                      , SplitDiff
                      , Syntax
                      , Term
@@ -171,7 +170,7 @@ test-suite test
                      , SemanticCmdLineSpec
                      , InterpreterSpec
                      , PatchOutputSpec
-                     , SES.Myers.Spec
+                     , SES.Spec
                      , SourceSpec
                      , SpecHelpers
                      , TermSpec

src/Algorithm.hs

@@ -4,7 +4,6 @@ module Algorithm where
 import Control.Applicative (liftA2)
 import Control.Monad (guard, join)
 import Control.Monad.Free.Freer
-import Data.Function (on)
 import Data.Functor.Classes
 import Data.List.NonEmpty (NonEmpty(..))
 import Data.Maybe
@@ -18,17 +17,17 @@ import Term
 -- | A single step in a diffing algorithm, parameterized by the types of terms, diffs, and the result of the applicable algorithm.
 data AlgorithmF term diff result where
   -- | Diff two terms with the choice of algorithm left to the interpreter’s discretion.
-  Diff :: term -> term -> AlgorithmF term diff diff
+  Diff :: term ann1 -> term ann2 -> AlgorithmF term (diff ann1 ann2) (diff ann1 ann2)
   -- | Diff two terms recursively in O(n) time, resulting in a single diff node.
-  Linear :: term -> term -> AlgorithmF term diff diff
+  Linear :: term ann1 -> term ann2 -> AlgorithmF term (diff ann1 ann2) (diff ann1 ann2)
   -- | Diff two lists of terms by each element’s similarity in O(n³ log n), resulting in a list of diffs.
-  RWS :: [term] -> [term] -> AlgorithmF term diff [diff]
+  RWS :: [term ann1] -> [term ann2] -> AlgorithmF term (diff ann1 ann2) [diff ann1 ann2]
   -- | Delete a term..
-  Delete :: term -> AlgorithmF term diff diff
+  Delete :: term ann1 -> AlgorithmF term (diff ann1 ann2) (diff ann1 ann2)
   -- | Insert a term.
-  Insert :: term -> AlgorithmF term diff diff
+  Insert :: term ann2 -> AlgorithmF term (diff ann1 ann2) (diff ann1 ann2)
   -- | Replace one term with another.
-  Replace :: term -> term -> AlgorithmF term diff diff
+  Replace :: term ann1 -> term ann2 -> AlgorithmF term (diff ann1 ann2) (diff ann1 ann2)
 
 -- | The free applicative for 'AlgorithmF'. This enables us to construct diff values using <$> and <*> notation.
 type Algorithm term diff = Freer (AlgorithmF term diff)
@@ -37,15 +36,15 @@ type Algorithm term diff = Freer (AlgorithmF term diff)
 -- DSL
 
 -- | Diff two terms without specifying the algorithm to be used.
-diff :: term -> term -> Algorithm term diff diff
+diff :: term ann1 -> term ann2 -> Algorithm term (diff ann1 ann2) (diff ann1 ann2)
 diff = (liftF .) . Algorithm.Diff
 
 -- | Diff a These of terms without specifying the algorithm to be used.
-diffThese :: These term term -> Algorithm term diff diff
+diffThese :: These (term ann1) (term ann2) -> Algorithm term (diff ann1 ann2) (diff ann1 ann2)
 diffThese = these byDeleting byInserting diff
 
 -- | Diff a pair of optional terms without specifying the algorithm to be used.
-diffMaybe :: Maybe term -> Maybe term -> Algorithm term diff (Maybe diff)
+diffMaybe :: Maybe (term ann1) -> Maybe (term ann2) -> Algorithm term (diff ann1 ann2) (Maybe (diff ann1 ann2))
 diffMaybe a b = case (a, b) of
   (Just a, Just b) -> Just <$> diff a b
   (Just a, _) -> Just <$> byDeleting a
@@ -53,53 +52,61 @@ diffMaybe a b = case (a, b) of
   _ -> pure Nothing
 
 -- | Diff two terms linearly.
-linearly :: term -> term -> Algorithm term diff diff
+linearly :: term ann1 -> term ann2 -> Algorithm term (diff ann1 ann2) (diff ann1 ann2)
 linearly a b = liftF (Linear a b)
 
 -- | Diff two terms using RWS.
-byRWS :: [term] -> [term] -> Algorithm term diff [diff]
+byRWS :: [term ann1] -> [term ann2] -> Algorithm term (diff ann1 ann2) [diff ann1 ann2]
 byRWS a b = liftF (RWS a b)
 
 -- | Delete a term.
-byDeleting :: term -> Algorithm term diff diff
+byDeleting :: term ann1 -> Algorithm term (diff ann1 ann2) (diff ann1 ann2)
 byDeleting = liftF . Delete
 
 -- | Insert a term.
-byInserting :: term -> Algorithm term diff diff
+byInserting :: term ann2 -> Algorithm term (diff ann1 ann2) (diff ann1 ann2)
 byInserting = liftF . Insert
 
 -- | Replace one term with another.
-byReplacing :: term -> term -> Algorithm term diff diff
+byReplacing :: term ann1 -> term ann2 -> Algorithm term (diff ann1 ann2) (diff ann1 ann2)
 byReplacing = (liftF .) . Replace
 
 
-instance Show term => Show1 (AlgorithmF term diff) where
+instance (Show1 term, Show ann1, Show ann2) => Show1 (AlgorithmF term (diff ann1 ann2)) where
   liftShowsPrec _ _ d algorithm = case algorithm of
-    Algorithm.Diff t1 t2 -> showsBinaryWith showsPrec showsPrec "Diff" d t1 t2
-    Linear t1 t2 -> showsBinaryWith showsPrec showsPrec "Linear" d t1 t2
-    RWS as bs -> showsBinaryWith showsPrec showsPrec "RWS" d as bs
-    Delete t1 -> showsUnaryWith showsPrec "Delete" d t1
-    Insert t2 -> showsUnaryWith showsPrec "Insert" d t2
-    Replace t1 t2 -> showsBinaryWith showsPrec showsPrec "Replace" d t1 t2
+    Algorithm.Diff t1 t2 -> showsBinaryWith showsTerm showsTerm "Diff" d t1 t2
+    Linear t1 t2 -> showsBinaryWith showsTerm showsTerm "Linear" d t1 t2
+    RWS as bs -> showsBinaryWith (liftShowsPrec showsTerm (liftShowList showsPrec showList)) (liftShowsPrec showsTerm (liftShowList showsPrec showList)) "RWS" d as bs
+    Delete t1 -> showsUnaryWith showsTerm "Delete" d t1
+    Insert t2 -> showsUnaryWith showsTerm "Insert" d t2
+    Replace t1 t2 -> showsBinaryWith showsTerm showsTerm "Replace" d t1 t2
+    where showsTerm :: (Show1 term, Show ann) => Int -> term ann -> ShowS
+          showsTerm = liftShowsPrec showsPrec showList
 
 
 -- | Diff two terms based on their generic Diffable instances. If the terms are not diffable
 -- (represented by a Nothing diff returned from algorithmFor) replace one term with another.
-algorithmForTerms :: (Functor f, Diffable f) => Term f a -> Term f a -> Algorithm (Term f a) (Diff f a) (Diff f a)
+algorithmForTerms :: (Functor syntax, Diffable syntax)
+                  => Term syntax ann1
+                  -> Term syntax ann2
+                  -> Algorithm (Term syntax) (Diff syntax ann1 ann2) (Diff syntax ann1 ann2)
 algorithmForTerms t1 t2 = fromMaybe (byReplacing t1 t2) (algorithmForComparableTerms t1 t2)
 
-algorithmForComparableTerms :: (Functor f, Diffable f) => Term f a -> Term f a -> Maybe (Algorithm (Term f a) (Diff f a) (Diff f a))
+algorithmForComparableTerms :: (Functor syntax, Diffable syntax)
+                            => Term syntax ann1
+                            -> Term syntax ann2
+                            -> Maybe (Algorithm (Term syntax) (Diff syntax ann1 ann2) (Diff syntax ann1 ann2))
 algorithmForComparableTerms (Term (In ann1 f1)) (Term (In ann2 f2)) = fmap (merge (ann1, ann2)) <$> algorithmFor f1 f2
 
 
 -- | A type class for determining what algorithm to use for diffing two terms.
 class Diffable f where
-  algorithmFor :: f term -> f term -> Maybe (Algorithm term diff (f diff))
-  default algorithmFor :: (Generic1 f, Diffable' (Rep1 f)) => f term -> f term -> Maybe (Algorithm term diff (f diff))
+  algorithmFor :: f (term ann1) -> f (term ann2) -> Maybe (Algorithm term (diff ann1 ann2) (f (diff ann1 ann2)))
+  default algorithmFor :: (Generic1 f, GDiffable (Rep1 f)) => f (term ann1) -> f (term ann2) -> Maybe (Algorithm term (diff ann1 ann2) (f (diff ann1 ann2)))
   algorithmFor = genericAlgorithmFor
 
-genericAlgorithmFor :: (Generic1 f, Diffable' (Rep1 f)) => f term -> f term -> Maybe (Algorithm term diff (f diff))
-genericAlgorithmFor a b = fmap to1 <$> algorithmFor' (from1 a) (from1 b)
+genericAlgorithmFor :: (Generic1 f, GDiffable (Rep1 f)) => f (term ann1) -> f (term ann2) -> Maybe (Algorithm term (diff ann1 ann2) (f (diff ann1 ann2)))
+genericAlgorithmFor a b = fmap to1 <$> galgorithmFor (from1 a) (from1 b)
 
 
 -- | Diff a Union of Syntax terms. Left is the "rest" of the Syntax terms in the Union,
@@ -114,46 +121,46 @@ instance Diffable [] where
   algorithmFor a b = Just (byRWS a b)
 
 -- | A generic type class for diffing two terms defined by the Generic1 interface.
-class Diffable' f where
-  algorithmFor' :: f term -> f term -> Maybe (Algorithm term diff (f diff))
+class GDiffable f where
+  galgorithmFor :: f (term ann1) -> f (term ann2) -> Maybe (Algorithm term (diff ann1 ann2) (f (diff ann1 ann2)))
 
 -- | Diff two constructors (M1 is the Generic1 newtype for meta-information (possibly related to type constructors, record selectors, and data types))
-instance Diffable' f => Diffable' (M1 i c f) where
-  algorithmFor' (M1 a) (M1 b) = fmap M1 <$> algorithmFor' a b
+instance GDiffable f => GDiffable (M1 i c f) where
+  galgorithmFor (M1 a) (M1 b) = fmap M1 <$> galgorithmFor a b
 
 -- | Diff the fields of a product type.
 -- i.e. data Foo a b = Foo a b (the 'Foo a b' is captured by 'a :*: b').
-instance (Diffable' f, Diffable' g) => Diffable' (f :*: g) where
-  algorithmFor' (a1 :*: b1) (a2 :*: b2) = liftA2 (:*:) <$> algorithmFor' a1 a2 <*> algorithmFor' b1 b2
+instance (GDiffable f, GDiffable g) => GDiffable (f :*: g) where
+  galgorithmFor (a1 :*: b1) (a2 :*: b2) = liftA2 (:*:) <$> galgorithmFor a1 a2 <*> galgorithmFor b1 b2
 
 -- | Diff the constructors of a sum type.
 -- i.e. data Foo a = Foo a | Bar a (the 'Foo a' is captured by L1 and 'Bar a' is R1).
-instance (Diffable' f, Diffable' g) => Diffable' (f :+: g) where
-  algorithmFor' (L1 a) (L1 b) = fmap L1 <$> algorithmFor' a b
-  algorithmFor' (R1 a) (R1 b) = fmap R1 <$> algorithmFor' a b
-  algorithmFor' _ _ = Nothing
+instance (GDiffable f, GDiffable g) => GDiffable (f :+: g) where
+  galgorithmFor (L1 a) (L1 b) = fmap L1 <$> galgorithmFor a b
+  galgorithmFor (R1 a) (R1 b) = fmap R1 <$> galgorithmFor a b
+  galgorithmFor _ _ = Nothing
 
 -- | Diff two parameters (Par1 is the Generic1 newtype representing a type parameter).
 -- i.e. data Foo a = Foo a (the 'a' is captured by Par1).
-instance Diffable' Par1 where
-  algorithmFor' (Par1 a) (Par1 b) = Just (Par1 <$> linearly a b)
+instance GDiffable Par1 where
+  galgorithmFor (Par1 a) (Par1 b) = Just (Par1 <$> linearly a b)
 
 -- | Diff two constant parameters (K1 is the Generic1 newtype representing type parameter constants).
 -- i.e. data Foo = Foo Int (the 'Int' is a constant parameter).
-instance Eq c => Diffable' (K1 i c) where
-  algorithmFor' (K1 a) (K1 b) = guard (a == b) *> Just (pure (K1 a))
+instance Eq c => GDiffable (K1 i c) where
+  galgorithmFor (K1 a) (K1 b) = guard (a == b) *> Just (pure (K1 a))
 
 -- | Diff two terms whose constructors contain 0 type parameters.
 -- i.e. data Foo = Foo.
-instance Diffable' U1 where
-  algorithmFor' _ _ = Just (pure U1)
+instance GDiffable U1 where
+  galgorithmFor _ _ = Just (pure U1)
 
 -- | Diff two lists of parameters.
-instance Diffable' (Rec1 []) where
-  algorithmFor' a b = fmap Rec1 <$> Just ((byRWS `on` unRec1) a b)
+instance GDiffable (Rec1 []) where
+  galgorithmFor a b = Just (Rec1 <$> byRWS (unRec1 a) (unRec1 b))
 
 -- | Diff two non-empty lists of parameters.
-instance Diffable' (Rec1 NonEmpty) where
-  algorithmFor' (Rec1 (a:|as)) (Rec1 (b:|bs)) = Just $ do
+instance GDiffable (Rec1 NonEmpty) where
+  galgorithmFor (Rec1 (a:|as)) (Rec1 (b:|bs)) = Just $ do
     d:ds <- byRWS (a:as) (b:bs)
     pure (Rec1 (d :| ds))

src/Alignment.hs

@@ -46,13 +46,13 @@ hasChanges :: (Foldable f, Functor f) => SplitDiff f annotation -> Bool
 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 :: (HasField fields Range, Traversable f) => Both Source -> Diff f (Record fields) (Record fields) -> [Join These (SplitDiff [] (Record fields))]
 alignDiff sources = cata $ \ diff -> case diff of
   Patch patch                    -> alignPatch sources patch
   Merge (In (ann1, ann2) syntax) -> alignSyntax (runBothWith ((Join .) . These)) wrap getRange sources (In (both ann1 ann2) syntax)
 
 -- | Align the contents of a patch into a list of lines on the corresponding side(s) of the diff.
-alignPatch :: forall fields f. (Traversable f, HasField fields Range) => Both Source -> Patch (TermF f (Record fields) [Join These (SplitDiff [] (Record fields))]) -> [Join These (SplitDiff [] (Record fields))]
+alignPatch :: forall fields f. (Traversable f, HasField fields Range) => Both Source -> Patch (TermF f (Record fields) [Join These (SplitDiff [] (Record fields))]) (TermF f (Record fields) [Join These (SplitDiff [] (Record fields))]) -> [Join These (SplitDiff [] (Record fields))]
 alignPatch sources patch = case patch of
   Delete term -> fmap (pure . SplitDelete) <$> alignSyntax' this (fst sources) term
   Insert term -> fmap (pure . SplitInsert) <$> alignSyntax' that (snd sources) term

src/Data/Syntax.hs

@@ -159,21 +159,21 @@ instance Eq1 Context where liftEq = genericLiftEq
 instance Show1 Context where liftShowsPrec = genericLiftShowsPrec
 
 algorithmDeletingContext :: (Apply Diffable fs, Apply Functor fs, Context :< fs)
-                         => TermF Context a (Term (Union fs) a)
-                         -> Term (Union fs) a
-                         -> Maybe (Algorithm (Term (Union fs) a) (Diff (Union fs) a) (TermF Context a (Diff (Union fs) a)))
+                         => TermF Context ann1 (Term (Union fs) ann1)
+                         -> Term (Union fs) ann2
+                         -> Maybe (Algorithm (Term (Union fs)) (Diff (Union fs) ann1 ann2) (TermF Context ann1 (Diff (Union fs) ann1 ann2)))
 algorithmDeletingContext (In a1 (Context n1 s1)) s2 = fmap (In a1 . Context (deleting <$> n1)) <$> algorithmForComparableTerms s1 s2
 
 algorithmInsertingContext :: (Apply Diffable fs, Apply Functor fs, Context :< fs)
-                          => Term (Union fs) a
-                          -> TermF Context a (Term (Union fs) a)
-                          -> Maybe (Algorithm (Term (Union fs) a) (Diff (Union fs) a) (TermF Context a (Diff (Union fs) a)))
+                          => Term (Union fs) ann1
+                          -> TermF Context ann2 (Term (Union fs) ann2)
+                          -> Maybe (Algorithm (Term (Union fs)) (Diff (Union fs) ann1 ann2) (TermF Context ann2 (Diff (Union fs) ann1 ann2)))
 algorithmInsertingContext s1 (In a2 (Context n2 s2)) = fmap (In a2 . Context (inserting <$> n2)) <$> algorithmForComparableTerms s1 s2
 
 algorithmForContextUnions :: (Apply Diffable fs, Apply Functor fs, Context :< fs)
-                          => Term (Union fs) a
-                          -> Term (Union fs) a
-                          -> Maybe (Algorithm (Term (Union fs) a) (Diff (Union fs) a) (Diff (Union fs) a))
+                          => Term (Union fs) ann1
+                          -> Term (Union fs) ann2
+                          -> Maybe (Algorithm (Term (Union fs)) (Diff (Union fs) ann1 ann2) (Diff (Union fs) ann1 ann2))
 algorithmForContextUnions t1 t2
   | Just algo <- algorithmForComparableTerms t1 t2 = Just algo
   | Just c1@(In _ Context{}) <- prjTermF (unTerm t1) = fmap (deleteF . hoistTermF inj) <$> algorithmDeletingContext c1 t2

src/Diff.hs

@@ -12,176 +12,204 @@ import Data.JSON.Fields
 import Data.Mergeable
 import Data.Record
 import Patch
-import Syntax
 import Term
 import Text.Show
 
 -- | A recursive structure indicating the changed & unchanged portions of a labelled tree.
-newtype Diff syntax ann = Diff { unDiff :: DiffF syntax ann (Diff syntax ann) }
+newtype Diff syntax ann1 ann2 = Diff { unDiff :: DiffF syntax ann1 ann2 (Diff syntax ann1 ann2) }
 
 -- | A single entry within a recursive 'Diff'.
-data DiffF syntax ann recur
+data DiffF syntax ann1 ann2 recur
   -- | A changed node, represented as 'Insert'ed, 'Delete'd, or 'Replace'd 'TermF's, consisting of syntax labelled with an annotation.
-  = Patch (Patch (TermF syntax       ann  recur))
+  = Patch (Patch (TermF syntax  ann1        recur)
+                 (TermF syntax        ann2  recur))
   -- | An unchanged node, consisting of syntax labelled with both the original annotations.
-  | Merge        (TermF syntax (ann, ann) recur)
-  deriving (Foldable, Functor, Traversable)
+  | Merge        (TermF syntax (ann1, ann2) recur)
 
 -- | Constructs a 'Diff' replacing one 'Term' with another recursively.
-replacing :: Functor syntax => Term syntax ann -> Term syntax ann -> Diff syntax ann
+replacing :: Functor syntax => Term syntax ann1 -> Term syntax ann2 -> Diff syntax ann1 ann2
 replacing (Term (In a1 r1)) (Term (In a2 r2)) = Diff (Patch (Replace (In a1 (deleting <$> r1)) (In a2 (inserting <$> r2))))
 
 -- | Constructs a 'Diff' inserting a 'Term' recursively.
-inserting :: Functor syntax => Term syntax ann -> Diff syntax ann
+inserting :: Functor syntax => Term syntax ann2 -> Diff syntax ann1 ann2
 inserting = cata insertF
 
 -- | Constructs a 'Diff' inserting a single 'TermF' populated by further 'Diff's.
-insertF :: TermF syntax ann (Diff syntax ann) -> Diff syntax ann
+insertF :: TermF syntax ann2 (Diff syntax ann1 ann2) -> Diff syntax ann1 ann2
 insertF = Diff . Patch . Insert
 
 -- | Constructs a 'Diff' deleting a 'Term' recursively.
-deleting :: Functor syntax => Term syntax ann -> Diff syntax ann
+deleting :: Functor syntax => Term syntax ann1 -> Diff syntax ann1 ann2
 deleting = cata deleteF
 
 -- | Constructs a 'Diff' deleting a single 'TermF' populated by further 'Diff's.
-deleteF :: TermF syntax ann (Diff syntax ann) -> Diff syntax ann
+deleteF :: TermF syntax ann1 (Diff syntax ann1 ann2) -> Diff syntax ann1 ann2
 deleteF = Diff . Patch . Delete
 
 -- | Constructs a 'Diff' merging two annotations for a single syntax functor populated by further 'Diff's.
-merge :: (ann, ann) -> syntax (Diff syntax ann) -> Diff syntax ann
+merge :: (ann1, ann2) -> syntax (Diff syntax ann1 ann2) -> Diff syntax ann1 ann2
 merge = (Diff .) . (Merge .) . In
 
 
-type SyntaxDiff fields = Diff Syntax (Record fields)
-
-
-diffSum :: (Foldable syntax, Functor syntax) => (forall a. Patch a -> Int) -> Diff syntax ann -> Int
+diffSum :: (Foldable syntax, Functor syntax) => (forall a b. Patch a b -> Int) -> Diff syntax ann1 ann2 -> Int
 diffSum patchCost = cata $ \ diff -> case diff of
   Patch patch -> patchCost patch + sum (sum <$> patch)
   Merge merge -> sum merge
 
 -- | The sum of the node count of the diff’s patches.
-diffCost :: (Foldable syntax, Functor syntax) => Diff syntax ann -> Int
+diffCost :: (Foldable syntax, Functor syntax) => Diff syntax ann1 ann2 -> Int
 diffCost = diffSum (const 1)
 
 
-diffPatch :: Diff syntax ann -> Maybe (Patch (TermF syntax ann (Diff syntax ann)))
+diffPatch :: Diff syntax ann1 ann2 -> Maybe (Patch (TermF syntax ann1 (Diff syntax ann1 ann2)) (TermF syntax ann2 (Diff syntax ann1 ann2)))
 diffPatch diff = case unDiff diff of
   Patch patch -> Just patch
   _ -> Nothing
 
-diffPatches :: (Foldable syntax, Functor syntax) => Diff syntax ann -> [Patch (TermF syntax ann (Diff syntax ann))]
+diffPatches :: (Foldable syntax, Functor syntax) => Diff syntax ann1 ann2 -> [Patch (TermF syntax ann1 (Diff syntax ann1 ann2)) (TermF syntax ann2 (Diff syntax ann1 ann2))]
 diffPatches = para $ \ diff -> case diff of
-  Patch patch -> fmap (fmap fst) patch : foldMap (foldMap (toList . diffPatch . fst)) patch
-  Merge merge ->                                  foldMap (toList . diffPatch . fst)  merge
+  Patch patch -> bimap (fmap fst) (fmap fst) patch : bifoldMap (foldMap (toList . diffPatch . fst)) (foldMap (toList . diffPatch . fst)) patch
+  Merge merge ->                                                foldMap (toList . diffPatch . fst)  merge
 
 
 -- | 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) => (DiffF syntax ann (Maybe (Term syntax ann)) -> Maybe (Term syntax ann)) -> Diff syntax ann -> Maybe (Term syntax ann)
+mergeMaybe :: (Mergeable syntax, Traversable syntax) => (DiffF syntax ann1 ann2 (Maybe (Term syntax combined)) -> Maybe (Term syntax combined)) -> Diff syntax ann1 ann2 -> Maybe (Term syntax combined)
 mergeMaybe = cata
 
 -- | Recover the before state of a diff.
-beforeTerm :: (Mergeable syntax, Traversable syntax) => Diff syntax ann -> Maybe (Term syntax ann)
+beforeTerm :: (Mergeable syntax, Traversable syntax) => Diff syntax ann1 ann2 -> Maybe (Term syntax ann1)
 beforeTerm = mergeMaybe $ \ diff -> case diff of
   Patch patch -> before patch >>= \ (In a l) -> termIn a <$> sequenceAlt l
   Merge  (In (a, _) l) -> termIn a <$> sequenceAlt l
 
 -- | Recover the after state of a diff.
-afterTerm :: (Mergeable syntax, Traversable syntax) => Diff syntax ann -> Maybe (Term syntax ann)
+afterTerm :: (Mergeable syntax, Traversable syntax) => Diff syntax ann1 ann2 -> Maybe (Term syntax ann2)
 afterTerm = mergeMaybe $ \ diff -> case diff of
   Patch patch -> after patch >>= \ (In b r) -> termIn b <$> sequenceAlt r
   Merge  (In (_, b) r) -> termIn b <$> sequenceAlt r
 
 
 -- | Strips the head annotation off a diff annotated with non-empty records.
-stripDiff :: Functor f
-          => Diff f (Record (h ': t))
-          -> Diff f (Record t)
-stripDiff = fmap rtail
+stripDiff :: Functor syntax
+          => Diff syntax (Record (h1 ': t1)) (Record (h2 ': t2))
+          -> Diff syntax (Record        t1)  (Record        t2)
+stripDiff = bimap rtail rtail
 
 
-type instance Base (Diff syntax ann) = DiffF syntax ann
+type instance Base (Diff syntax ann1 ann2) = DiffF syntax ann1 ann2
 
-instance Functor syntax => Recursive   (Diff syntax ann) where project = unDiff
-instance Functor syntax => Corecursive (Diff syntax ann) where embed = Diff
+instance Functor syntax => Recursive   (Diff syntax ann1 ann2) where project = unDiff
+instance Functor syntax => Corecursive (Diff syntax ann1 ann2) where embed = Diff
 
 
-instance Eq1 f => Eq1 (Diff f) where
-  liftEq eqA = go where go (Diff d1) (Diff d2) = liftEq2 eqA go d1 d2
+instance Eq1 syntax => Eq2 (Diff syntax) where
+  liftEq2 eq1 eq2 = go where go (Diff d1) (Diff d2) = liftEq3 eq1 eq2 go d1 d2
 
-instance (Eq1 f, Eq a) => Eq (Diff f a) where
-  (==) = eq1
+instance (Eq1 syntax, Eq ann1, Eq ann2) => Eq (Diff syntax ann1 ann2) where
+  (==) = eq2
 
-instance Eq1 f => Eq2 (DiffF f) where
-  liftEq2 eqA eqB d1 d2 = case (d1, d2) of
-    (Patch p1, Patch p2) -> liftEq (liftEq2 eqA eqB) p1 p2
-    (Merge t1, Merge t2) -> liftEq2 (liftEq2 eqA eqA) eqB t1 t2
+instance Eq1 syntax => Eq3 (DiffF syntax) where
+  liftEq3 eq1 eq2 eqRecur d1 d2 = case (d1, d2) of
+    (Patch p1, Patch p2) -> liftEq2 (liftEq2 eq1 eqRecur) (liftEq2 eq2 eqRecur) p1 p2
+    (Merge t1, Merge t2) -> liftEq2 (liftEq2 eq1 eq2) eqRecur t1 t2
     _ -> False
 
-instance (Eq1 f, Eq a) => Eq1 (DiffF f a) where
-  liftEq = liftEq2 (==)
+instance (Eq1 syntax, Eq ann1, Eq ann2) => Eq1 (DiffF syntax ann1 ann2) where
+  liftEq = liftEq3 (==) (==)
 
-instance (Eq1 f, Eq a, Eq b) => Eq (DiffF f a b) where
-  (==) = eq1
+instance (Eq1 syntax, Eq ann1, Eq ann2, Eq recur) => Eq (DiffF syntax ann1 ann2 recur) where
+  (==) = eq3
 
 
-instance Show1 f => Show1 (Diff f) where
-  liftShowsPrec sp sl = go where go d = showsUnaryWith (liftShowsPrec2 sp sl go (showListWith (go 0))) "Diff" d . unDiff
+instance Show1 syntax => Show2 (Diff syntax) where
+  liftShowsPrec2 sp1 sl1 sp2 sl2 = go where go d = showsUnaryWith (liftShowsPrec3 sp1 sl1 sp2 sl2 go (showListWith (go 0))) "Diff" d . unDiff
 
-instance (Show1 f, Show a) => Show (Diff f a) where
-  showsPrec = showsPrec1
+instance (Show1 syntax, Show ann1, Show ann2) => Show (Diff syntax ann1 ann2) where
+  showsPrec = showsPrec2
 
-instance Show1 f => Show2 (DiffF f) where
-  liftShowsPrec2 spA slA spB slB d diff = case diff of
-    Patch patch -> showsUnaryWith (liftShowsPrec (liftShowsPrec2 spA slA spB slB) (liftShowList2 spA slA spB slB)) "Patch" d patch
-    Merge term  -> showsUnaryWith (liftShowsPrec2 spBoth slBoth spB slB) "Merge" d term
-    where spBoth = liftShowsPrec2 spA slA spA slA
-          slBoth = liftShowList2 spA slA spA slA
+instance Show1 syntax => Show3 (DiffF syntax) where
+  liftShowsPrec3 sp1 sl1 sp2 sl2 spRecur slRecur d diff = case diff of
+    Patch patch -> showsUnaryWith (liftShowsPrec2 (liftShowsPrec2 sp1 sl1 spRecur slRecur) (liftShowList2 sp1 sl1 spRecur slRecur) (liftShowsPrec2 sp2 sl2 spRecur slRecur) (liftShowList2 sp2 sl2 spRecur slRecur)) "Patch" d patch
+    Merge term  -> showsUnaryWith (liftShowsPrec2 spBoth slBoth spRecur slRecur) "Merge" d term
+    where spBoth = liftShowsPrec2 sp1 sl1 sp2 sl2
+          slBoth = liftShowList2 sp1 sl1 sp2 sl2
 
-instance (Show1 f, Show a) => Show1 (DiffF f a) where
-  liftShowsPrec = liftShowsPrec2 showsPrec showList
+instance (Show1 syntax, Show ann1, Show ann2) => Show1 (DiffF syntax ann1 ann2) where
+  liftShowsPrec = liftShowsPrec3 showsPrec showList showsPrec showList
 
-instance (Show1 f, Show a, Show b) => Show (DiffF f a b) where
-  showsPrec = showsPrec1
+instance (Show1 syntax, Show ann1, Show ann2, Show recur) => Show (DiffF syntax ann1 ann2 recur) where
+  showsPrec = showsPrec3
 
 
-instance Functor f => Functor (Diff f) where
-  fmap f = go where go = Diff . bimap f go . unDiff
+instance Functor syntax => Bifunctor (Diff syntax) where
+  bimap f g = go where go = Diff . trimap f g go . unDiff
 
-instance Foldable f => Foldable (Diff f) where
-  foldMap f = go where go = bifoldMap f go . unDiff
+instance Foldable syntax => Bifoldable (Diff syntax) where
+  bifoldMap f g = go where go = trifoldMap f g go . unDiff
 
-instance Traversable f => Traversable (Diff f) where
-  traverse f = go where go = fmap Diff . bitraverse f go . unDiff
+instance Traversable syntax => Bitraversable (Diff syntax) where
+  bitraverse f g = go where go = fmap Diff . tritraverse f g go . unDiff
 
 
-instance Functor syntax => Bifunctor (DiffF syntax) where
-  bimap f g (Patch patch) = Patch (bimap f g <$> patch)
-  bimap f g (Merge term)  = Merge (bimap (bimap f f) g term)
+instance Functor syntax => Functor (DiffF syntax ann1 ann2) where
+  fmap = trimap id id
 
-instance Foldable f => Bifoldable (DiffF f) where
-  bifoldMap f g (Patch patch) = foldMap (bifoldMap f g) patch
-  bifoldMap f g (Merge term)  = bifoldMap (bifoldMap f f) g term
+instance Functor syntax => Trifunctor (DiffF syntax) where
+  trimap f g h (Patch patch) = Patch (bimap (bimap f h) (bimap g h) patch)
+  trimap f g h (Merge term)  = Merge (bimap (bimap f g) h term)
 
-instance Traversable f => Bitraversable (DiffF f) where
-  bitraverse f g (Patch patch) = Patch <$> traverse (bitraverse f g) patch
-  bitraverse f g (Merge term)  = Merge <$> bitraverse (bitraverse f f) g term
+instance Foldable syntax => Foldable (DiffF syntax ann1 ann2) where
+  foldMap = trifoldMap (const mempty) (const mempty)
+
+instance Foldable syntax => Trifoldable (DiffF syntax) where
+  trifoldMap f g h (Patch patch) = bifoldMap (bifoldMap f h) (bifoldMap g h) patch
+  trifoldMap f g h (Merge term)  = bifoldMap (bifoldMap f g) h term
+
+instance Traversable syntax => Traversable (DiffF syntax ann1 ann2) where
+  traverse = tritraverse pure pure
+
+instance Traversable syntax => Tritraversable (DiffF syntax) where
+  tritraverse f g h (Patch patch) = Patch <$> bitraverse (bitraverse f h) (bitraverse g h) patch
+  tritraverse f g h (Merge term)  = Merge <$> bitraverse (bitraverse f g) h term
 
 
-instance (ToJSONFields a, ToJSONFields1 f) => ToJSON (Diff f a) where
+instance (ToJSONFields1 syntax, ToJSONFields ann1, ToJSONFields ann2) => ToJSON (Diff syntax ann1 ann2) where
   toJSON = object . toJSONFields
   toEncoding = pairs . mconcat . toJSONFields
 
-instance (ToJSONFields a, ToJSONFields1 f) => ToJSONFields (Diff f a) where
+instance (ToJSONFields1 syntax, ToJSONFields ann1, ToJSONFields ann2) => ToJSONFields (Diff syntax ann1 ann2) where
   toJSONFields = toJSONFields . unDiff
 
-instance (ToJSONFields a, ToJSONFields1 f) => ToJSONFields1 (DiffF f a) where
+instance (ToJSONFields1 syntax, ToJSONFields ann1, ToJSONFields ann2) => ToJSONFields1 (DiffF syntax ann1 ann2) where
   toJSONFields1 (Patch patch) = [ "patch" .= JSONFields patch ]
   toJSONFields1 (Merge term)  = [ "merge" .= JSONFields term ]
 
-instance (ToJSONFields1 f, ToJSONFields a, ToJSON b) => ToJSONFields (DiffF f a b) where
+instance (ToJSONFields1 syntax, ToJSONFields ann1, ToJSONFields ann2, ToJSON recur) => ToJSONFields (DiffF syntax ann1 ann2 recur) where
   toJSONFields = toJSONFields1
 
-instance (ToJSON b, ToJSONFields a, ToJSONFields1 f) => ToJSON (DiffF f a b) where
+instance (ToJSONFields1 syntax, ToJSONFields ann1, ToJSONFields ann2, ToJSON recur) => ToJSON (DiffF syntax ann1 ann2 recur) where
   toJSON = object . toJSONFields
   toEncoding = pairs . mconcat . toJSONFields
+
+
+class Eq3 f where
+  liftEq3 :: (a1 -> a2 -> Bool) -> (b1 -> b2 -> Bool) -> (c1 -> c2 -> Bool) -> f a1 b1 c1 -> f a2 b2 c2 -> Bool
+
+eq3 :: (Eq3 f, Eq a, Eq b, Eq c) => f a b c -> f a b c -> Bool
+eq3 = liftEq3 (==) (==) (==)
+
+
+class Show3 f where
+  liftShowsPrec3 :: (Int -> a -> ShowS) -> ([a] -> ShowS) -> (Int -> b -> ShowS) -> ([b] -> ShowS) -> (Int -> c -> ShowS) -> ([c] -> ShowS) -> Int -> f a b c -> ShowS
+
+showsPrec3 :: (Show3 f, Show a, Show b, Show c) => Int -> f a b c -> ShowS
+showsPrec3 = liftShowsPrec3 showsPrec showList showsPrec showList showsPrec showList
+
+class Trifunctor f where
+  trimap :: (a -> a') -> (b -> b') -> (c -> c') -> f a b c -> f a' b' c'
+
+class Trifoldable f where
+  trifoldMap :: Monoid m => (a -> m) -> (b -> m) -> (c -> m) -> f a b c -> m
+
+class Tritraversable f where
+  tritraverse :: Applicative g => (a -> g a') -> (b -> g b') -> (c -> g c') -> f a b c -> g (f a' b' c')

src/Interpreter.hs

@@ -9,14 +9,11 @@ module Interpreter
 import Algorithm
 import Control.Monad.Free.Freer
 import Data.Align.Generic
-import Data.Functor.Both
-import Data.Functor.Foldable (cata)
 import Data.Functor.Classes (Eq1)
 import Data.Hashable (Hashable)
 import Data.Maybe (isJust)
 import Data.Record
 import Data.Text (Text)
-import Data.These
 import Diff
 import Info hiding (Return)
 import RWS
@@ -25,33 +22,38 @@ import Term
 
 
 -- | Diff two terms recursively, given functions characterizing the diffing.
-diffTerms :: HasField fields Category
-          => Both (SyntaxTerm fields) -- ^ A pair of terms representing the old and new state, respectively.
-          -> SyntaxDiff fields
-diffTerms = decoratingWith getLabel (diffTermsWith algorithmWithTerms comparableByCategory)
+diffTerms :: (HasField fields1 Category, HasField fields2 Category)
+          => Term Syntax (Record fields1) -- ^ A term representing the old state.
+          -> Term Syntax (Record fields2) -- ^ A term representing the new state.
+          -> Diff Syntax (Record fields1) (Record fields2)
+diffTerms = decoratingWith getLabel getLabel (diffTermsWith algorithmWithTerms comparableByCategory)
 
 -- | Diff two terms by decorating with feature vectors computed using the supplied labelling algebra, and stripping the feature vectors from the resulting diff.
-decoratingWith :: (Hashable label, Traversable f)
-               => (forall a. TermF f (Record fields) a -> label)
-               -> (Both (Term f (Record (FeatureVector ': fields))) -> Diff f (Record (FeatureVector ': fields)))
-               -> Both (Term f (Record fields))
-               -> Diff f (Record fields)
-decoratingWith getLabel differ = stripDiff . differ . fmap (defaultFeatureVectorDecorator getLabel)
+decoratingWith :: (Hashable label, Traversable syntax)
+               => (forall a. TermF syntax (Record fields1) a -> label)
+               -> (forall a. TermF syntax (Record fields2) a -> label)
+               -> (Term syntax (Record (FeatureVector ': fields1)) -> Term syntax (Record (FeatureVector ': fields2)) -> Diff syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2)))
+               -> Term syntax (Record fields1)
+               -> Term syntax (Record fields2)
+               -> Diff syntax (Record fields1) (Record fields2)
+decoratingWith getLabel1 getLabel2 differ t1 t2 = stripDiff (differ (defaultFeatureVectorDecorator getLabel1 t1) (defaultFeatureVectorDecorator getLabel2 t2))
 
 -- | Diff a pair of terms recurisvely, using the supplied continuation and 'ComparabilityRelation'.
-diffTermsWith :: forall f fields . (Traversable f, GAlign f, Eq1 f, HasField fields FeatureVector)
-              => (Term f (Record fields) -> Term f (Record fields) -> Algorithm (Term f (Record fields)) (Diff f (Record fields)) (Diff f (Record fields))) -- ^ A function producing syntax-directed continuations of the algorithm.
-              -> ComparabilityRelation f fields -- ^ A relation on terms used to determine comparability and equality.
-              -> Both (Term f (Record fields)) -- ^ A pair of terms.
-              -> Diff f (Record fields) -- ^ The resulting diff.
-diffTermsWith refine comparable (Join (a, b)) = runFreer decompose (diff a b)
-  where decompose :: AlgorithmF (Term f (Record fields)) (Diff f (Record fields)) result -> Algorithm (Term f (Record fields)) (Diff f (Record fields)) result
+diffTermsWith :: forall syntax fields1 fields2
+              .  (Eq1 syntax, GAlign syntax, Traversable syntax)
+              => (Term syntax (Record (FeatureVector ': fields1)) -> Term syntax (Record (FeatureVector ': fields2)) -> Algorithm (Term syntax) (Diff syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2))) (Diff syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2)))) -- ^ A function producing syntax-directed continuations of the algorithm.
+              -> ComparabilityRelation syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2)) -- ^ A relation on terms used to determine comparability and equality.
+              -> Term syntax (Record (FeatureVector ': fields1)) -- ^ A term representing the old state.
+              -> Term syntax (Record (FeatureVector ': fields2)) -- ^ A term representing the new state.
+              -> Diff syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2)) -- ^ The resulting diff.
+diffTermsWith refine comparable t1 t2 = runFreer decompose (diff t1 t2)
+  where decompose :: AlgorithmF (Term syntax) (Diff syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2))) result -> Algorithm (Term syntax) (Diff syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2))) result
         decompose step = case step of
           Algorithm.Diff t1 t2 -> refine t1 t2
           Linear t1 t2 -> case galignWith diffThese (unwrap t1) (unwrap t2) of
             Just result -> merge (extract t1, extract t2) <$> sequenceA result
             _ -> byReplacing t1 t2
-          RWS as bs -> traverse diffThese (rws (editDistanceUpTo defaultM) comparable as bs)
+          RWS as bs -> traverse diffThese (rws comparable as bs)
           Delete a -> pure (deleting a)
           Insert b -> pure (inserting b)
           Replace a b -> pure (replacing a b)
@@ -64,9 +66,9 @@ getLabel (In h t) = (Info.category h, case t of
 
 
 -- | Construct an algorithm to diff a pair of terms.
-algorithmWithTerms :: SyntaxTerm fields
-                   -> SyntaxTerm fields
-                   -> Algorithm (SyntaxTerm fields) (SyntaxDiff fields) (SyntaxDiff fields)
+algorithmWithTerms :: Term Syntax ann1
+                   -> Term Syntax ann2
+                   -> Algorithm (Term Syntax) (Diff Syntax ann1 ann2) (Diff Syntax ann1 ann2)
 algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of
   (Indexed a, Indexed b) ->
     annotate . Indexed <$> byRWS a b
@@ -108,24 +110,9 @@ algorithmWithTerms t1 t2 = case (unwrap t1, unwrap t2) of
 
 
 -- | Test whether two terms are comparable by their Category.
-comparableByCategory :: HasField fields Category => ComparabilityRelation f fields
+comparableByCategory :: (HasField fields1 Category, HasField fields2 Category) => ComparabilityRelation syntax (Record fields1) (Record fields2)
 comparableByCategory (In a _) (In b _) = category a == category b
 
 -- | Test whether two terms are comparable by their constructor.
-comparableByConstructor :: GAlign f => ComparabilityRelation f fields
+comparableByConstructor :: GAlign syntax => ComparabilityRelation syntax ann1 ann2
 comparableByConstructor (In _ a) (In _ b) = isJust (galign a b)
-
-
--- | How many nodes to consider for our constant-time approximation to tree edit distance.
-defaultM :: Integer
-defaultM = 10
-
--- | Return an edit distance as the sum of it's term sizes, given an cutoff and a syntax of terms 'f a'.
--- | Computes a constant-time approximation to the edit distance of a diff. This is done by comparing at most _m_ nodes, & assuming the rest are zero-cost.
-editDistanceUpTo :: (GAlign f, Foldable f, Functor f) => Integer -> These (Term f (Record fields)) (Term f (Record fields)) -> Int
-editDistanceUpTo m = these termSize termSize (\ a b -> diffCost m (approximateDiff a b))
-  where diffCost = flip . cata $ \ diff m -> case diff of
-          _ | m <= 0 -> 0
-          Merge body -> sum (fmap ($ pred m) body)
-          body -> succ (sum (fmap ($ pred m) body))
-        approximateDiff a b = maybe (replacing a b) (merge (extract a, extract b)) (galignWith (these deleting inserting approximateDiff) (unwrap a) (unwrap b))

src/Language.hs

@@ -53,13 +53,13 @@ toTuple child | S.Fixed [key,value] <- unwrap child = [termIn (extract child) (S
 toTuple child | S.Leaf c <- unwrap child = [termIn (extract child) (S.Comment c)]
 toTuple child = pure child
 
-toPublicFieldDefinition :: HasField fields Category => [SyntaxTerm fields] -> Maybe (S.Syntax (SyntaxTerm fields))
+toPublicFieldDefinition :: HasField fields Category => [Term S.Syntax (Record fields)] -> Maybe (S.Syntax (Term S.Syntax (Record fields)))
 toPublicFieldDefinition children = case break (\x -> category (extract x) == Identifier) children of
   (prev, [identifier, assignment]) -> Just $ S.VarAssignment (prev ++ [identifier]) assignment
   (_, [_]) -> Just $ S.VarDecl children
   _ -> Nothing
 
-toInterface :: HasField fields Category => [SyntaxTerm fields] -> Maybe (S.Syntax (SyntaxTerm fields))
+toInterface :: HasField fields Category => [Term S.Syntax (Record fields)] -> Maybe (S.Syntax (Term S.Syntax (Record fields)))
 toInterface (id : rest) = case break (\x -> category (extract x) == Other "object_type") rest of
   (clauses, [body]) -> Just $ S.Interface id clauses (toList (unwrap body))
   _ -> Nothing

src/Language/Go.hs

@@ -5,6 +5,7 @@ import Control.Comonad
 import Control.Comonad.Cofree
 import Data.Foldable (toList)
 import Data.Maybe
+import Data.Record
 import Data.Source
 import Data.Text
 import Info
@@ -14,8 +15,8 @@ import Term
 termAssignment
   :: Source -- ^ The source of the term.
   -> Category -- ^ The category for the term.
-  -> [ SyntaxTerm DefaultFields ] -- ^ The child nodes of the term.
-  -> Maybe (S.Syntax (SyntaxTerm DefaultFields)) -- ^ The resulting term, in Maybe.
+  -> [ Term S.Syntax (Record DefaultFields) ] -- ^ The child nodes of the term.
+  -> Maybe (S.Syntax (Term S.Syntax (Record DefaultFields))) -- ^ The resulting term, in Maybe.
 termAssignment source category children = case (category, children) of
   (Module, [moduleName]) -> Just $ S.Module moduleName []
   (Import, [importName]) -> Just $ S.Import importName []

src/Language/Ruby.hs

@@ -3,6 +3,7 @@ module Language.Ruby where
 
 import Data.Foldable (toList)
 import Data.List (partition)
+import Data.Record
 import Data.Semigroup
 import Data.Source
 import Data.Text (Text)
@@ -14,8 +15,8 @@ import Term
 termAssignment
   :: Source -- ^ The source of the term.
   -> Category -- ^ The category for the term.
-  -> [ SyntaxTerm DefaultFields ] -- ^ The child nodes of the term.
-  -> Maybe (S.Syntax (SyntaxTerm DefaultFields)) -- ^ The resulting term, in Maybe.
+  -> [ Term S.Syntax (Record DefaultFields) ] -- ^ The child nodes of the term.
+  -> Maybe (S.Syntax (Term S.Syntax (Record DefaultFields))) -- ^ The resulting term, in Maybe.
 termAssignment _ category children
   = case (category, children) of
     (ArgumentPair, [ k, v ] ) -> Just $ S.Pair k v

src/Language/TypeScript.hs

@@ -4,6 +4,7 @@ module Language.TypeScript where
 import Control.Comonad (extract)
 import Control.Comonad.Cofree (unwrap)
 import Data.Foldable (toList)
+import Data.Record
 import Data.Source
 import Data.Text (Text)
 import Info
@@ -14,8 +15,8 @@ import Term
 termAssignment
   :: Source -- ^ The source of the term.
   -> Category -- ^ The category for the term.
-  -> [ SyntaxTerm DefaultFields ] -- ^ The child nodes of the term.
-  -> Maybe (S.Syntax (SyntaxTerm DefaultFields)) -- ^ The resulting term, in Maybe.
+  -> [ Term S.Syntax (Record DefaultFields) ] -- ^ The child nodes of the term.
+  -> Maybe (S.Syntax (Term S.Syntax (Record DefaultFields))) -- ^ The resulting term, in Maybe.
 termAssignment _ category children =
   case (category, children) of
     (Assignment, [ identifier, value ]) -> Just $ S.Assignment identifier value

src/Parser.hs

@@ -45,14 +45,14 @@ data Parser term where
                    -> Assignment ast grammar (Term (Union fs) (Record Location)) -- ^ An assignment from AST onto 'Term's.
                    -> Parser (Term (Union fs) (Record Location))                 -- ^ A parser producing 'Term's.
   -- | A tree-sitter parser.
-  TreeSitterParser :: Ptr TS.Language -> Parser (SyntaxTerm DefaultFields)
+  TreeSitterParser :: Ptr TS.Language -> Parser (Term Syntax (Record DefaultFields))
   -- | A parser for 'Markdown' using cmark.
   MarkdownParser :: Parser (Term (TermF [] CMarkGFM.NodeType) (Node Markdown.Grammar))
   -- | A parser which will parse any input 'Source' into a top-level 'Term' whose children are leaves consisting of the 'Source's lines.
-  LineByLineParser :: Parser (SyntaxTerm DefaultFields)
+  LineByLineParser :: Parser (Term Syntax (Record DefaultFields))
 
 -- | Return a 'Language'-specific 'Parser', if one exists, falling back to the 'LineByLineParser'.
-parserForLanguage :: Maybe Language -> Parser (SyntaxTerm DefaultFields)
+parserForLanguage :: Maybe Language -> Parser (Term Syntax (Record DefaultFields))
 parserForLanguage Nothing = LineByLineParser
 parserForLanguage (Just language) = case language of
   Go -> TreeSitterParser tree_sitter_go
@@ -77,6 +77,6 @@ markdownParser = AssignmentParser MarkdownParser Markdown.assignment
 
 
 -- | A fallback parser that treats a file simply as rows of strings.
-lineByLineParser :: Source -> SyntaxTerm DefaultFields
+lineByLineParser :: Source -> Term Syntax (Record DefaultFields)
 lineByLineParser source = termIn (totalRange source :. Program :. totalSpan source :. Nil) (Indexed (zipWith toLine [1..] (sourceLineRanges source)))
   where toLine line range = termIn (range :. Program :. Span (Pos line 1) (Pos line (end range)) :. Nil) (Leaf (toText (slice range source)))

src/Patch.hs

@@ -4,68 +4,79 @@ module Patch
 ( Patch(..)
 , after
 , before
-, unPatch
-, maybeFst
-, maybeSnd
-, mapPatch
+, patch
 ) where
 
 import Data.Aeson
 import Data.Align
-import Data.Functor.Classes.Eq.Generic
-import Data.Functor.Classes.Show.Generic
+import Data.Bifoldable
+import Data.Bifunctor
+import Data.Bitraversable
+import Data.Functor.Classes
 import Data.JSON.Fields
 import Data.These
 import GHC.Generics
 
 -- | An operation to replace, insert, or delete an item.
-data Patch a
-  = Replace a a
-  | Insert a
-  | Delete a
+data Patch a b
+  = Delete a
+  | Insert b
+  | Replace a b
   deriving (Eq, Foldable, Functor, Generic, Generic1, Ord, Show, Traversable)
 
 
 -- | Return the item from the after side of the patch.
-after :: Patch a -> Maybe a
-after = maybeSnd . unPatch
+after :: Patch before after -> Maybe after
+after = patch (const Nothing) Just (\ _ b -> Just b)
 
 -- | Return the item from the before side of the patch.
-before :: Patch a -> Maybe a
-before = maybeFst . unPatch
+before :: Patch before after -> Maybe before
+before = patch Just (const Nothing) (\ a _ -> Just a)
 
 -- | Return both sides of a patch.
-unPatch :: Patch a -> These a a
-unPatch (Replace a b) = These a b
-unPatch (Insert b) = That b
-unPatch (Delete a) = This a
-
-mapPatch :: (a -> b) -> (a -> b) -> Patch a -> Patch b
-mapPatch f _ (Delete  a  ) = Delete  (f a)
-mapPatch _ g (Insert    b) = Insert  (g b)
-mapPatch f g (Replace a b) = Replace (f a) (g b)
-
--- | Return Just the value in This, or the first value in These, if any.
-maybeFst :: These a b -> Maybe a
-maybeFst = these Just (const Nothing) ((Just .) . const)
-
--- | Return Just the value in That, or the second value in These, if any.
-maybeSnd :: These a b -> Maybe b
-maybeSnd = these (const Nothing) Just ((Just .) . flip const)
+patch :: (before -> result) -> (after -> result) -> (before -> after -> result) -> Patch before after -> result
+patch ifDelete _ _ (Delete a) = ifDelete a
+patch _ ifInsert _ (Insert b) = ifInsert b
+patch _ _ ifReplace (Replace a b) = ifReplace a b
 
 
 -- Instances
 
-instance Crosswalk Patch where
-  crosswalk f (Replace a b) = alignWith (these Delete Insert Replace) (f a) (f b)
-  crosswalk f (Insert b) = Insert <$> f b
-  crosswalk f (Delete a) = Delete <$> f a
+instance Bifunctor Patch where
+  bimap f _ (Delete a) = Delete (f a)
+  bimap _ g (Insert b) = Insert (g b)
+  bimap f g (Replace a b) = Replace (f a) (g b)
 
-instance Eq1 Patch where liftEq = genericLiftEq
-instance Show1 Patch where liftShowsPrec = genericLiftShowsPrec
+instance Bifoldable Patch where
+  bifoldMap f _ (Delete a) = f a
+  bifoldMap _ g (Insert b) = g b
+  bifoldMap f g (Replace a b) = f a `mappend` g b
+
+instance Bitraversable Patch where
+  bitraverse f _ (Delete a) = Delete <$> f a
+  bitraverse _ g (Insert b) = Insert <$> g b
+  bitraverse f g (Replace a b) = Replace <$> f a <*> g b
+
+instance Bicrosswalk Patch where
+  bicrosswalk f _ (Delete a) = Delete <$> f a
+  bicrosswalk _ g (Insert b) = Insert <$> g b
+  bicrosswalk f g (Replace a b) = alignWith (these Delete Insert Replace) (f a) (g b)
+
+instance Eq2 Patch where
+  liftEq2 eqBefore eqAfter p1 p2 = case (p1, p2) of
+    (Delete a1, Delete a2) -> eqBefore a1 a2
+    (Insert b1, Insert b2) -> eqAfter b1 b2
+    (Replace a1 b1, Replace a2 b2) -> eqBefore a1 a2 && eqAfter b1 b2
+    _ -> False
+
+instance Show2 Patch where
+  liftShowsPrec2 spBefore _ spAfter _ d p = case p of
+    Delete a -> showsUnaryWith spBefore "Delete" d a
+    Insert b -> showsUnaryWith spAfter "Insert" d b
+    Replace a b -> showsBinaryWith spBefore spAfter "Replace" d a b
 
 
-instance ToJSONFields a => ToJSONFields (Patch a) where
+instance (ToJSONFields a, ToJSONFields b) => ToJSONFields (Patch a b) where
   toJSONFields (Insert a)    = [ "insert" .= object (toJSONFields a) ]
   toJSONFields (Delete a)    = [ "delete" .= object (toJSONFields a) ]
   toJSONFields (Replace a b) = [ "replace" .= [object (toJSONFields a), object (toJSONFields b)] ]

src/RWS.hs

@@ -1,25 +1,25 @@
 {-# LANGUAGE GADTs, DataKinds, RankNTypes, TypeOperators #-}
-module RWS (
-    rws
-  , ComparabilityRelation
-  , FeatureVector
-  , defaultFeatureVectorDecorator
-  , featureVectorDecorator
-  , pqGramDecorator
-  , Gram(..)
-  , defaultD
-  ) where
+module RWS
+( rws
+, ComparabilityRelation
+, FeatureVector(..)
+, defaultFeatureVectorDecorator
+, featureVectorDecorator
+, pqGramDecorator
+, Gram(..)
+, defaultD
+) where
 
 import Control.Applicative (empty)
 import Control.Arrow ((&&&))
 import Control.Monad.State.Strict
+import Data.Align.Generic
 import Data.Foldable
-import Data.Function ((&), on)
+import Data.Function ((&))
 import Data.Functor.Foldable
 import Data.Hashable
 import Data.List (sortOn)
 import Data.Maybe
-import Data.Monoid (First(..))
 import Data.Record
 import Data.Semigroup hiding (First(..))
 import Data.These
@@ -27,9 +27,9 @@ import Data.Traversable
 import Term
 import Data.Array.Unboxed
 import Data.Functor.Classes
+import Diff (DiffF(..), deleting, inserting, merge, replacing)
 import SES
-import qualified Data.Functor.Both as Both
-import Data.KdTree.Static hiding (empty, toList)
+import Data.KdMap.Static hiding (elems, empty)
 import qualified Data.IntMap as IntMap
 
 import Control.Monad.Random
@@ -40,61 +40,64 @@ type Label f fields label = forall b. TermF f (Record fields) b -> label
 -- | A relation on 'Term's, guaranteed constant-time in the size of the 'Term' by parametricity.
 --
 --   This is used both to determine whether two root terms can be compared in O(1), and, recursively, to determine whether two nodes are equal in O(n); thus, comparability is defined s.t. two terms are equal if they are recursively comparable subterm-wise.
-type ComparabilityRelation f fields = forall a b. TermF f (Record fields) a -> TermF f (Record fields) b -> Bool
+type ComparabilityRelation syntax ann1 ann2 = forall a b. TermF syntax ann1 a -> TermF syntax ann2 b -> Bool
 
-type FeatureVector = UArray Int Double
+newtype FeatureVector = FV { unFV :: UArray Int Double }
+  deriving (Eq, Ord, Show)
 
 -- | A term which has not yet been mapped by `rws`, along with its feature vector summary & index.
-data UnmappedTerm f fields = UnmappedTerm {
-    termIndex :: {-# UNPACK #-} !Int -- ^ The index of the term within its root term.
+data UnmappedTerm syntax ann = UnmappedTerm
+  { termIndex :: {-# UNPACK #-} !Int -- ^ The index of the term within its root term.
   , feature   :: {-# UNPACK #-} !FeatureVector -- ^ Feature vector
-  , term      :: Term f (Record fields) -- ^ The unmapped term
-}
+  , term      :: Term syntax ann -- ^ The unmapped term
+  }
 
 -- | Either a `term`, an index of a matched term, or nil.
 data TermOrIndexOrNone term = Term term | Index {-# UNPACK #-} !Int | None
 
-rws :: (HasField fields FeatureVector, Functor f, Eq1 f)
-    => (Diff f fields -> Int)
-    -> ComparabilityRelation f fields
-    -> [Term f (Record fields)]
-    -> [Term f (Record fields)]
-    -> RWSEditScript f fields
-rws _            _          as [] = This <$> as
-rws _            _          [] bs = That <$> bs
-rws _            canCompare [a] [b] = if canCompareTerms canCompare a b then [These a b] else [That b, This a]
-rws editDistance canCompare as bs =
+rws :: (Eq1 syntax, Foldable syntax, Functor syntax, GAlign syntax)
+    => ComparabilityRelation syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2))
+    -> [Term syntax (Record (FeatureVector ': fields1))]
+    -> [Term syntax (Record (FeatureVector ': fields2))]
+    -> RWSEditScript syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2))
+rws _          as [] = This <$> as
+rws _          [] bs = That <$> bs
+rws canCompare [a] [b] = if canCompareTerms canCompare a b then [These a b] else [That b, This a]
+rws canCompare as bs =
   let sesDiffs = ses (equalTerms canCompare) as bs
       (featureAs, featureBs, mappedDiffs, allDiffs) = genFeaturizedTermsAndDiffs sesDiffs
-      (diffs, remaining) = findNearestNeighboursToDiff editDistance canCompare allDiffs featureAs featureBs
+      (diffs, remaining) = findNearestNeighboursToDiff canCompare allDiffs featureAs featureBs
       diffs' = deleteRemaining diffs remaining
       rwsDiffs = insertMapped mappedDiffs diffs'
   in fmap snd rwsDiffs
 
 -- | An IntMap of unmapped terms keyed by their position in a list of terms.
-type UnmappedTerms f fields = IntMap.IntMap (UnmappedTerm f fields)
+type UnmappedTerms syntax ann = IntMap.IntMap (UnmappedTerm syntax ann)
 
-type Diff f fields = These (Term f (Record fields)) (Term f (Record fields))
+type Edit syntax ann1 ann2 = These (Term syntax ann1) (Term syntax ann2)
 
 -- A Diff paired with both its indices
-type MappedDiff f fields = (These Int Int, Diff f fields)
+type MappedDiff syntax ann1 ann2 = (These Int Int, Edit syntax ann1 ann2)
 
-type RWSEditScript f fields = [Diff f fields]
+type RWSEditScript syntax ann1 ann2 = [Edit syntax ann1 ann2]
 
-insertMapped :: Foldable t => t (MappedDiff f fields) -> [MappedDiff f fields] -> [MappedDiff f fields]
+insertMapped :: Foldable t
+             => t (MappedDiff syntax ann1 ann2)
+             -> [MappedDiff syntax ann1 ann2]
+             -> [MappedDiff syntax ann1 ann2]
 insertMapped diffs into = foldl' (flip insertDiff) into diffs
 
-deleteRemaining :: (Traversable t)
-                => [MappedDiff f fields]
-                -> t (UnmappedTerm f fields)
-                -> [MappedDiff f fields]
+deleteRemaining :: Traversable t
+                => [MappedDiff syntax ann1 ann2]
+                -> t (UnmappedTerm syntax ann1)
+                -> [MappedDiff syntax ann1 ann2]
 deleteRemaining diffs unmappedAs =
   foldl' (flip insertDiff) diffs ((This . termIndex &&& This . term) <$> unmappedAs)
 
 -- | Inserts an index and diff pair into a list of indices and diffs.
-insertDiff :: MappedDiff f fields
-           -> [MappedDiff f fields]
-           -> [MappedDiff f fields]
+insertDiff :: MappedDiff syntax ann1 ann2
+           -> [MappedDiff syntax ann1 ann2]
+           -> [MappedDiff syntax ann1 ann2]
 insertDiff inserted [] = [ inserted ]
 insertDiff a@(ij1, _) (b@(ij2, _):rest) = case (ij1, ij2) of
   (These i1 i2, These j1 j2) -> if i1 <= j1 && i2 <= j2 then a : b : rest else b : insertDiff a rest
@@ -117,44 +120,46 @@ insertDiff a@(ij1, _) (b@(ij2, _):rest) = case (ij1, ij2) of
       That j2 -> if i2 <= j2 then (before, each : after) else (each : before, after)
       These _ _ -> (before, after)
 
-findNearestNeighboursToDiff :: (These (Term f (Record fields)) (Term f (Record fields)) -> Int) -- ^ A function computes a constant-time approximation to the edit distance between two terms.
-                           -> ComparabilityRelation f fields -- ^ A relation determining whether two terms can be compared.
-                           -> [TermOrIndexOrNone (UnmappedTerm f fields)]
-                           -> [UnmappedTerm f fields]
-                           -> [UnmappedTerm f fields]
-                           -> ([(These Int Int, These (Term f (Record fields)) (Term f (Record fields)))], UnmappedTerms f fields)
-findNearestNeighboursToDiff editDistance canCompare allDiffs featureAs featureBs = (diffs, remaining)
+findNearestNeighboursToDiff :: (Foldable syntax, Functor syntax, GAlign syntax)
+                            => ComparabilityRelation syntax ann1 ann2 -- ^ A relation determining whether two terms can be compared.
+                            -> [TermOrIndexOrNone (UnmappedTerm syntax ann2)]
+                            -> [UnmappedTerm syntax ann1]
+                            -> [UnmappedTerm syntax ann2]
+                            -> ([MappedDiff syntax ann1 ann2], UnmappedTerms syntax ann1)
+findNearestNeighboursToDiff canCompare allDiffs featureAs featureBs = (diffs, remaining)
   where
     (diffs, (_, remaining, _)) =
-      traverse (findNearestNeighbourToDiff' editDistance canCompare (toKdTree <$> Both.both featureAs featureBs)) allDiffs &
+      traverse (findNearestNeighbourToDiff' canCompare (toKdMap featureAs) (toKdMap featureBs)) allDiffs &
       fmap catMaybes &
       (`runState` (minimumTermIndex featureAs, toMap featureAs, toMap featureBs))
 
-findNearestNeighbourToDiff' :: (Diff f fields -> Int) -- ^ A function computes a constant-time approximation to the edit distance between two terms.
-                           -> ComparabilityRelation f fields -- ^ A relation determining whether two terms can be compared.
-                           -> Both.Both (KdTree Double (UnmappedTerm f fields))
-                           -> TermOrIndexOrNone (UnmappedTerm f fields)
-                           -> State (Int, UnmappedTerms f fields, UnmappedTerms f fields)
-                                    (Maybe (MappedDiff f fields))
-findNearestNeighbourToDiff' editDistance canCompare kdTrees termThing = case termThing of
+findNearestNeighbourToDiff' :: (Foldable syntax, Functor syntax, GAlign syntax)
+                            => ComparabilityRelation syntax ann1 ann2 -- ^ A relation determining whether two terms can be compared.
+                            -> KdMap Double FeatureVector (UnmappedTerm syntax ann1)
+                            -> KdMap Double FeatureVector (UnmappedTerm syntax ann2)
+                            -> TermOrIndexOrNone (UnmappedTerm syntax ann2)
+                            -> State (Int, UnmappedTerms syntax ann1, UnmappedTerms syntax ann2)
+                                     (Maybe (MappedDiff syntax ann1 ann2))
+findNearestNeighbourToDiff' canCompare kdTreeA kdTreeB termThing = case termThing of
   None -> pure Nothing
-  RWS.Term term -> Just <$> findNearestNeighbourTo editDistance canCompare kdTrees term
+  RWS.Term term -> Just <$> findNearestNeighbourTo canCompare kdTreeA kdTreeB term
   Index i -> modify' (\ (_, unA, unB) -> (i, unA, unB)) >> pure Nothing
 
 -- | Construct a diff for a term in B by matching it against the most similar eligible term in A (if any), marking both as ineligible for future matches.
-findNearestNeighbourTo :: (Diff f fields -> Int) -- ^ A function computes a constant-time approximation to the edit distance between two terms.
-                       -> ComparabilityRelation f fields -- ^ A relation determining whether two terms can be compared.
-                       -> Both.Both (KdTree Double (UnmappedTerm f fields))
-                       -> UnmappedTerm f fields
-                       -> State (Int, UnmappedTerms f fields, UnmappedTerms f fields)
-                                (MappedDiff f fields)
-findNearestNeighbourTo editDistance canCompare kdTrees term@(UnmappedTerm j _ b) = do
+findNearestNeighbourTo :: (Foldable syntax, Functor syntax, GAlign syntax)
+                       => ComparabilityRelation syntax ann1 ann2 -- ^ A relation determining whether two terms can be compared.
+                       -> KdMap Double FeatureVector (UnmappedTerm syntax ann1)
+                       -> KdMap Double FeatureVector (UnmappedTerm syntax ann2)
+                       -> UnmappedTerm syntax ann2
+                       -> State (Int, UnmappedTerms syntax ann1, UnmappedTerms syntax ann2)
+                                (MappedDiff syntax ann1 ann2)
+findNearestNeighbourTo canCompare kdTreeA kdTreeB term@(UnmappedTerm j _ b) = do
   (previous, unmappedA, unmappedB) <- get
   fromMaybe (insertion previous unmappedA unmappedB term) $ do
     -- Look up the nearest unmapped term in `unmappedA`.
-    foundA@(UnmappedTerm i _ a) <- nearestUnmapped editDistance canCompare (termsWithinMoveBoundsFrom previous unmappedA) (Both.fst kdTrees) term
+    foundA@(UnmappedTerm i _ a) <- nearestUnmapped canCompare (termsWithinMoveBoundsFrom previous unmappedA) kdTreeA term
     -- Look up the nearest `foundA` in `unmappedB`
-    UnmappedTerm j' _ _ <- nearestUnmapped editDistance canCompare (termsWithinMoveBoundsFrom (pred j) unmappedB) (Both.snd kdTrees) foundA
+    UnmappedTerm j' _ _ <- nearestUnmapped (flip canCompare) (termsWithinMoveBoundsFrom (pred j) unmappedB) kdTreeB foundA
     -- Return Nothing if their indices don't match
     guard (j == j')
     guard (canCompareTerms canCompare a b)
@@ -171,18 +176,23 @@ isInMoveBounds previous i = previous < i && i < previous + defaultMoveBound
 -- RWS can produce false positives in the case of e.g. hash collisions. Therefore, we find the _l_ nearest candidates, filter out any which have already been mapped, and select the minimum of the remaining by (a constant-time approximation of) edit distance.
 --
 -- cf §4.2 of RWS-Diff
-nearestUnmapped
-  :: (Diff f fields -> Int) -- ^ A function computes a constant-time approximation to the edit distance between two terms.
-  -> ComparabilityRelation f fields -- ^ A relation determining whether two terms can be compared.
-  -> UnmappedTerms f fields -- ^ A set of terms eligible for matching against.
-  -> KdTree Double (UnmappedTerm f fields) -- ^ The k-d tree to look up nearest neighbours within.
-  -> UnmappedTerm f fields -- ^ The term to find the nearest neighbour to.
-  -> Maybe (UnmappedTerm f fields) -- ^ The most similar unmapped term, if any.
-nearestUnmapped editDistance canCompare unmapped tree key = getFirst $ foldMap (First . Just) (sortOn (editDistanceIfComparable editDistance canCompare (term key) . term) (toList (IntMap.intersection unmapped (toMap (kNearest tree defaultL key)))))
+nearestUnmapped :: (Foldable syntax, Functor syntax, GAlign syntax)
+                => ComparabilityRelation syntax ann1 ann2 -- ^ A relation determining whether two terms can be compared.
+                -> UnmappedTerms syntax ann1 -- ^ A set of terms eligible for matching against.
+                -> KdMap Double FeatureVector (UnmappedTerm syntax ann1) -- ^ The k-d tree to look up nearest neighbours within.
+                -> UnmappedTerm syntax ann2 -- ^ The term to find the nearest neighbour to.
+                -> Maybe (UnmappedTerm syntax ann1) -- ^ The most similar unmapped term, if any.
+nearestUnmapped canCompare unmapped tree key = listToMaybe (sortOn approximateEditDistance candidates)
+  where candidates = toList (IntMap.intersection unmapped (toMap (fmap snd (kNearest tree defaultL (feature key)))))
+        approximateEditDistance = editDistanceIfComparable (flip canCompare) (term key) . term
 
-editDistanceIfComparable :: Bounded t => (These (Term f (Record fields)) (Term f (Record fields)) -> t) -> ComparabilityRelation f fields -> Term f (Record fields) -> Term f (Record fields) -> t
-editDistanceIfComparable editDistance canCompare a b = if canCompareTerms canCompare a b
-  then editDistance (These a b)
+editDistanceIfComparable :: (Foldable syntax, Functor syntax, GAlign syntax)
+                         => ComparabilityRelation syntax ann1 ann2
+                         -> Term syntax ann1
+                         -> Term syntax ann2
+                         -> Int
+editDistanceIfComparable canCompare a b = if canCompareTerms canCompare a b
+  then editDistanceUpTo defaultM (These a b)
   else maxBound
 
 defaultD, defaultL, defaultP, defaultQ, defaultMoveBound :: Int
@@ -196,46 +206,57 @@ defaultMoveBound = 2
 -- Returns a state (insertion index, old unmapped terms, new unmapped terms), and value of (index, inserted diff),
 -- given a previous index, two sets of umapped terms, and an unmapped term to insert.
 insertion :: Int
-             -> UnmappedTerms f fields
-             -> UnmappedTerms f fields
-             -> UnmappedTerm f fields
-             -> State (Int, UnmappedTerms f fields, UnmappedTerms f fields)
-                      (MappedDiff f fields)
+          -> UnmappedTerms syntax ann1
+          -> UnmappedTerms syntax ann2
+          -> UnmappedTerm syntax ann2
+          -> State (Int, UnmappedTerms syntax ann1, UnmappedTerms syntax ann2)
+                   (MappedDiff syntax ann1 ann2)
 insertion previous unmappedA unmappedB (UnmappedTerm j _ b) = do
   put (previous, unmappedA, IntMap.delete j unmappedB)
   pure (That j, That b)
 
-genFeaturizedTermsAndDiffs :: (Functor f, HasField fields FeatureVector)
-                           => RWSEditScript f fields
-                           -> ([UnmappedTerm f fields], [UnmappedTerm f fields], [MappedDiff f fields], [TermOrIndexOrNone (UnmappedTerm f fields)])
+genFeaturizedTermsAndDiffs :: Functor syntax
+                           => RWSEditScript syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2))
+                           -> ( [UnmappedTerm syntax (Record (FeatureVector ': fields1))]
+                              , [UnmappedTerm syntax (Record (FeatureVector ': fields2))]
+                              , [MappedDiff syntax (Record (FeatureVector ': fields1)) (Record (FeatureVector ': fields2))]
+                              , [TermOrIndexOrNone (UnmappedTerm syntax (Record (FeatureVector ': fields2)))]
+                              )
 genFeaturizedTermsAndDiffs sesDiffs = let Mapping _ _ a b c d = foldl' combine (Mapping 0 0 [] [] [] []) sesDiffs in (reverse a, reverse b, reverse c, reverse d)
   where combine (Mapping counterA counterB as bs mappedDiffs allDiffs) diff = case diff of
           This term -> Mapping (succ counterA) counterB (featurize counterA term : as) bs mappedDiffs (None : allDiffs)
           That term -> Mapping counterA (succ counterB) as (featurize counterB term : bs) mappedDiffs (RWS.Term (featurize counterB term) : allDiffs)
           These a b -> Mapping (succ counterA) (succ counterB) as bs ((These counterA counterB, These a b) : mappedDiffs) (Index counterA : allDiffs)
 
-data Mapping f fields = Mapping {-# UNPACK #-} !Int {-# UNPACK #-} !Int ![UnmappedTerm f fields] ![UnmappedTerm f fields] ![MappedDiff f fields] ![TermOrIndexOrNone (UnmappedTerm f fields)]
+data Mapping syntax ann1 ann2
+  = Mapping
+    {-# UNPACK #-} !Int
+    {-# UNPACK #-} !Int
+    ![UnmappedTerm syntax ann1]
+    ![UnmappedTerm syntax ann2]
+    ![MappedDiff syntax ann1 ann2]
+    ![TermOrIndexOrNone (UnmappedTerm syntax ann2)]
 
-featurize :: (HasField fields FeatureVector, Functor f) => Int -> Term f (Record fields) -> UnmappedTerm f fields
+featurize :: Functor syntax => Int -> Term syntax (Record (FeatureVector ': fields)) -> UnmappedTerm syntax (Record (FeatureVector ': fields))
 featurize index term = UnmappedTerm index (getField (extract term)) (eraseFeatureVector term)
 
-eraseFeatureVector :: (Functor f, HasField fields FeatureVector) => Term f (Record fields) -> Term f (Record fields)
+eraseFeatureVector :: Functor syntax => Term syntax (Record (FeatureVector ': fields)) -> Term syntax (Record (FeatureVector ': fields))
 eraseFeatureVector (Term.Term (In record functor)) = termIn (setFeatureVector record nullFeatureVector) functor
 
 nullFeatureVector :: FeatureVector
-nullFeatureVector = listArray (0, 0) [0]
+nullFeatureVector = FV $ listArray (0, 0) [0]
 
-setFeatureVector :: HasField fields FeatureVector => Record fields -> FeatureVector -> Record fields
+setFeatureVector :: Record (FeatureVector ': fields) -> FeatureVector -> Record (FeatureVector ': fields)
 setFeatureVector = setField
 
-minimumTermIndex :: [RWS.UnmappedTerm f fields] -> Int
+minimumTermIndex :: [UnmappedTerm syntax ann] -> Int
 minimumTermIndex = pred . maybe 0 getMin . getOption . foldMap (Option . Just . Min . termIndex)
 
-toMap :: [UnmappedTerm f fields] -> IntMap.IntMap (UnmappedTerm f fields)
+toMap :: [UnmappedTerm syntax ann] -> IntMap.IntMap (UnmappedTerm syntax ann)
 toMap = IntMap.fromList . fmap (termIndex &&& id)
 
-toKdTree :: [UnmappedTerm f fields] -> KdTree Double (UnmappedTerm f fields)
-toKdTree = build (elems . feature)
+toKdMap :: [UnmappedTerm syntax ann] -> KdMap Double FeatureVector (UnmappedTerm syntax ann)
+toKdMap = build (elems . unFV) . fmap (feature &&& id)
 
 -- | A `Gram` is a fixed-size view of some portion of a tree, consisting of a `stem` of _p_ labels for parent nodes, and a `base` of _q_ labels of sibling nodes. Collectively, the bag of `Gram`s for each node of a tree (e.g. as computed by `pqGrams`) form a summary of the tree.
 data Gram label = Gram { stem :: [Maybe label], base :: [Maybe label] }
@@ -258,8 +279,8 @@ featureVectorDecorator getLabel p q d
        addSubtermVector :: Functor f => FeatureVector -> Term f (Record (FeatureVector ': fields)) -> FeatureVector
        addSubtermVector v term = addVectors v (rhead (extract term))
 
-       addVectors :: UArray Int Double -> UArray Int Double -> UArray Int Double
-       addVectors as bs = listArray (0, d - 1) (fmap (\ i -> as ! i + bs ! i) [0..(d - 1)])
+       addVectors :: FeatureVector -> FeatureVector -> FeatureVector
+       addVectors (FV as) (FV bs) = FV $ listArray (0, d - 1) (fmap (\ i -> as ! i + bs ! i) [0..(d - 1)])
 
 -- | Annotates a term with the corresponding p,q-gram at each node.
 pqGramDecorator
@@ -290,21 +311,36 @@ pqGramDecorator getLabel p q = cata algebra
 
 -- | Computes a unit vector of the specified dimension from a hash.
 unitVector :: Int -> Int -> FeatureVector
-unitVector d hash = listArray (0, d - 1) ((* invMagnitude) <$> components)
+unitVector d hash = FV $ listArray (0, d - 1) ((* invMagnitude) <$> components)
   where
     invMagnitude = 1 / sqrt (sum (fmap (** 2) components))
     components = evalRand (sequenceA (replicate d (liftRand randomDouble))) (pureMT (fromIntegral hash))
 
 -- | Test the comparability of two root 'Term's in O(1).
-canCompareTerms :: ComparabilityRelation f fields -> Term f (Record fields) -> Term f (Record fields) -> Bool
-canCompareTerms canCompare = canCompare `on` unTerm
+canCompareTerms :: ComparabilityRelation syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> Bool
+canCompareTerms canCompare t1 t2 = canCompare (unTerm t1) (unTerm t2)
 
 -- | Recursively test the equality of two 'Term's in O(n).
-equalTerms :: Eq1 f => ComparabilityRelation f fields -> Term f (Record fields) -> Term f (Record fields) -> Bool
+equalTerms :: Eq1 syntax => ComparabilityRelation syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> Bool
 equalTerms canCompare = go
   where go a b = canCompareTerms canCompare a b && liftEq go (termOut (unTerm a)) (termOut (unTerm b))
 
 
+-- | How many nodes to consider for our constant-time approximation to tree edit distance.
+defaultM :: Integer
+defaultM = 10
+
+-- | Return an edit distance as the sum of it's term sizes, given an cutoff and a syntax of terms 'f a'.
+-- | Computes a constant-time approximation to the edit distance of a diff. This is done by comparing at most _m_ nodes, & assuming the rest are zero-cost.
+editDistanceUpTo :: (GAlign syntax, Foldable syntax, Functor syntax) => Integer -> Edit syntax ann1 ann2 -> Int
+editDistanceUpTo m = these termSize termSize (\ a b -> diffCost m (approximateDiff a b))
+  where diffCost = flip . cata $ \ diff m -> case diff of
+          _ | m <= 0 -> 0
+          Merge body -> sum (fmap ($ pred m) body)
+          body -> succ (sum (fmap ($ pred m) body))
+        approximateDiff a b = maybe (replacing a b) (merge (extract a, extract b)) (galignWith (these deleting inserting approximateDiff) (unwrap a) (unwrap b))
+
+
 -- Instances
 
 instance Hashable label => Hashable (Gram label) where

src/Renderer.hs

@@ -24,9 +24,10 @@ import Data.Foldable (asum)
 import Data.JSON.Fields
 import qualified Data.Map as Map
 import Data.Output
+import Data.Record
 import Data.Syntax.Algebra (RAlgebra)
 import Data.Text (Text)
-import Diff (SyntaxDiff)
+import Diff
 import Info (DefaultFields)
 import Renderer.JSON as R
 import Renderer.Patch as R
@@ -45,8 +46,8 @@ data DiffRenderer output where
   JSONDiffRenderer :: DiffRenderer (Map.Map Text Value)
   -- | Render to a 'ByteString' formatted as nested s-expressions with patches indicated.
   SExpressionDiffRenderer :: DiffRenderer ByteString
-  -- | “Render” by returning the computed 'SyntaxDiff'. This renderer is not surfaced in the command-line interface, and is intended strictly for tests. Further, as it cannot render à la carte terms, it should be regarded as a (very) short-term hack until such time as we have a better idea for TOCSpec.hs.
-  IdentityDiffRenderer :: DiffRenderer (Maybe (SyntaxDiff (Maybe Declaration ': DefaultFields)))
+  -- | “Render” by returning the computed 'Diff'. This renderer is not surfaced in the command-line interface, and is intended strictly for tests. Further, as it cannot render à la carte terms, it should be regarded as a (very) short-term hack until such time as we have a better idea for TOCSpec.hs.
+  IdentityDiffRenderer :: DiffRenderer (Maybe (Diff Syntax (Record (Maybe Declaration ': DefaultFields)) (Record (Maybe Declaration ': DefaultFields))))
 
 deriving instance Eq (DiffRenderer output)
 deriving instance Show (DiffRenderer output)
@@ -59,8 +60,8 @@ data TermRenderer output where
   JSONTermRenderer :: TermRenderer [Value]
   -- | Render to a 'ByteString' formatted as nested s-expressions.
   SExpressionTermRenderer :: TermRenderer ByteString
-  -- | “Render” by returning the computed 'SyntaxTerm'. This renderer is not surfaced in the command-line interface, and is intended strictly for tests. Further, as it cannot render à la carte terms, it should be regarded as a (very) short-term hack until such time as we have a better idea for SemanticSpec.hs.
-  IdentityTermRenderer :: TermRenderer (Maybe (SyntaxTerm DefaultFields))
+  -- | “Render” by returning the computed 'Term'. This renderer is not surfaced in the command-line interface, and is intended strictly for tests. Further, as it cannot render à la carte terms, it should be regarded as a (very) short-term hack until such time as we have a better idea for SemanticSpec.hs.
+  IdentityTermRenderer :: TermRenderer (Maybe (Term Syntax (Record DefaultFields)))
 
 deriving instance Eq (TermRenderer output)
 deriving instance Show (TermRenderer output)

src/Renderer/Patch.hs

@@ -23,7 +23,6 @@ import Data.Semigroup ((<>))
 import Data.Source
 import Data.These
 import Diff
-import Patch
 import Prelude hiding (fst, snd)
 import SplitDiff
 
@@ -32,7 +31,7 @@ truncatePatch :: Both Blob -> ByteString
 truncatePatch blobs = header blobs <> "#timed_out\nTruncating diff: timeout reached.\n"
 
 -- | Render a diff in the traditional patch format.
-renderPatch :: (HasField fields Range, Traversable f) => Both Blob -> Diff f (Record fields) -> File
+renderPatch :: (HasField fields Range, Traversable f) => Both Blob -> Diff f (Record fields) (Record fields) -> File
 renderPatch blobs diff = File $ if not (ByteString.null text) && ByteString.last text /= '\n'
   then text <> "\n\\ No newline at end of file\n"
   else text
@@ -133,7 +132,7 @@ emptyHunk :: Hunk (SplitDiff a annotation)
 emptyHunk = Hunk { offset = mempty, changes = [], trailingContext = [] }
 
 -- | Render a diff as a series of hunks.
-hunks :: (Traversable f, HasField fields Range) => Diff f (Record fields) -> Both Blob -> [Hunk (SplitDiff [] (Record fields))]
+hunks :: (Traversable f, HasField fields Range) => Diff f (Record fields) (Record fields) -> Both Blob -> [Hunk (SplitDiff [] (Record fields))]
 hunks _ blobs | sources <- blobSource <$> blobs
               , sourcesEqual <- runBothWith (==) sources
               , sourcesNull <- runBothWith (&&) (nullSource <$> sources)
@@ -181,3 +180,6 @@ changeIncludingContext leadingContext rows = case changes of
 -- | Whether a row has changes on either side.
 rowHasChanges :: (Foldable f, Functor f) => Join These (SplitDiff f annotation) -> Bool
 rowHasChanges row = or (hasChanges <$> row)
+
+maybeSnd :: These a b -> Maybe b
+maybeSnd = these (const Nothing) Just (\ _ a -> Just a)

src/Renderer/SExpression.hs

@@ -14,14 +14,14 @@ import Prelude hiding (replicate)
 import Term
 
 -- | Returns a ByteString SExpression formatted diff.
-renderSExpressionDiff :: (ConstrainAll Show fields, Foldable f, Functor f) => Diff f (Record fields) -> ByteString
+renderSExpressionDiff :: (ConstrainAll Show fields, Foldable syntax, Functor syntax) => Diff syntax (Record fields) (Record fields) -> ByteString
 renderSExpressionDiff diff = cata printDiffF diff 0 <> "\n"
 
 -- | Returns a ByteString SExpression formatted term.
-renderSExpressionTerm :: (ConstrainAll Show fields, Foldable f, Functor f) => Term f (Record fields) -> ByteString
+renderSExpressionTerm :: (ConstrainAll Show fields, Foldable syntax, Functor syntax) => Term syntax (Record fields) -> ByteString
 renderSExpressionTerm term = cata (\ term n -> nl n <> replicate (2 * n) ' ' <> printTermF term n) term 0 <> "\n"
 
-printDiffF :: (ConstrainAll Show fields, Foldable f, Functor f) => DiffF f (Record fields) (Int -> ByteString) -> Int -> ByteString
+printDiffF :: (ConstrainAll Show fields, Foldable syntax, Functor syntax) => DiffF syntax (Record fields) (Record fields) (Int -> ByteString) -> Int -> ByteString
 printDiffF diff n = case diff of
   Patch (Delete term) -> nl n <> pad (n - 1) <> "{-" <> printTermF term n <> "-}"
   Patch (Insert term) -> nl n <> pad (n - 1) <> "{+" <> printTermF term n <> "+}"
@@ -29,7 +29,7 @@ printDiffF diff n = case diff of
                               <> nl (n + 1) <> pad (n - 1) <> "->" <> printTermF term2 n <> " }"
   Merge (In (_, ann) syntax) -> nl n <> pad n <> "(" <> showAnnotation ann <> foldMap (\ d -> d (n + 1)) syntax <> ")"
 
-printTermF :: (ConstrainAll Show fields, Foldable f, Functor f) => TermF f (Record fields) (Int -> ByteString) -> Int -> ByteString
+printTermF :: (ConstrainAll Show fields, Foldable syntax, Functor syntax) => TermF syntax (Record fields) (Int -> ByteString) -> Int -> ByteString
 printTermF (In annotation syntax) n = "(" <> showAnnotation annotation <> foldMap (\t -> t (n + 1)) syntax <> ")"
 
 nl :: Int -> ByteString

src/Renderer/TOC.hs

@@ -18,7 +18,8 @@ module Renderer.TOC
 ) where
 
 import Data.Aeson
-import Data.Align (crosswalk)
+import Data.Align (bicrosswalk)
+import Data.Bifoldable (bifoldMap)
 import Data.Bifunctor (bimap)
 import Data.Blob
 import Data.ByteString.Lazy (toStrict)
@@ -35,7 +36,6 @@ import Data.Semigroup ((<>), sconcat)
 import Data.Source as Source
 import Data.Text (toLower)
 import qualified Data.Text as T
-import Data.These
 import Data.Union
 import Diff
 import GHC.Generics
@@ -99,7 +99,7 @@ declaration (In annotation _) = annotation <$ (getField annotation :: Maybe Decl
 
 
 -- | Compute 'Declaration's for methods and functions in 'Syntax'.
-syntaxDeclarationAlgebra :: HasField fields Range => Blob -> RAlgebra (SyntaxTermF fields) (SyntaxTerm fields) (Maybe Declaration)
+syntaxDeclarationAlgebra :: HasField fields Range => Blob -> RAlgebra (TermF S.Syntax (Record fields)) (Term S.Syntax (Record fields)) (Maybe Declaration)
 syntaxDeclarationAlgebra Blob{..} (In a r) = case r of
   S.Function (identifier, _) _ _ -> Just $ FunctionDeclaration (getSource identifier)
   S.Method _ (identifier, _) Nothing _ _ -> Just $ MethodDeclaration (getSource identifier)
@@ -146,17 +146,17 @@ data Entry a
 
 -- | Compute a table of contents for a diff characterized by a function mapping relevant nodes onto values in Maybe.
 tableOfContentsBy :: (Foldable f, Functor f)
-                  => (forall b. TermF f annotation b -> Maybe a) -- ^ A function mapping relevant nodes onto values in Maybe.
-                  -> Diff f annotation                           -- ^ The diff to compute the table of contents for.
-                  -> [Entry a]                                   -- ^ A list of entries for relevant changed and unchanged nodes in the diff.
+                  => (forall b. TermF f ann b -> Maybe a) -- ^ A function mapping relevant nodes onto values in Maybe.
+                  -> Diff f ann ann                       -- ^ The diff to compute the table of contents for.
+                  -> [Entry a]                            -- ^ A list of entries for relevant changed and unchanged nodes in the diff.
 tableOfContentsBy selector = fromMaybe [] . cata (\ r -> case r of
-  Patch patch -> (pure . patchEntry <$> crosswalk selector patch) <> foldMap fold patch <> Just []
+  Patch patch -> (pure . patchEntry <$> bicrosswalk selector selector patch) <> bifoldMap fold fold patch <> Just []
   Merge (In (_, ann2) r) -> case (selector (In ann2 r), fold r) of
     (Just a, Nothing) -> Just [Unchanged a]
     (Just a, Just []) -> Just [Changed a]
     (_     , entries) -> entries)
 
-  where patchEntry = these Deleted Inserted (const Replaced) . unPatch
+  where patchEntry = patch Deleted Inserted (const Replaced)
 
 termTableOfContentsBy :: (Foldable f, Functor f)
                       => (forall b. TermF f annotation b -> Maybe a)
@@ -195,7 +195,7 @@ recordSummary record = case getDeclaration record of
   Just declaration -> Just . JSONSummary (toCategoryName declaration) (declarationIdentifier declaration) (sourceSpan record)
   Nothing -> const Nothing
 
-renderToCDiff :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Both Blob -> Diff f (Record fields) -> Summaries
+renderToCDiff :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Both Blob -> Diff f (Record fields) (Record fields) -> Summaries
 renderToCDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . diffTOC
   where toMap [] = mempty
         toMap as = Map.singleton summaryKey (toJSON <$> as)
@@ -210,7 +210,7 @@ renderToCTerm Blob{..} = uncurry Summaries . bimap toMap toMap . List.partition
   where toMap [] = mempty
         toMap as = Map.singleton (T.pack blobPath) (toJSON <$> as)
 
-diffTOC :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Diff f (Record fields) -> [JSONSummary]
+diffTOC :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Diff f (Record fields) (Record fields) -> [JSONSummary]
 diffTOC = mapMaybe entrySummary . dedupe . tableOfContentsBy declaration
 
 termToC :: (HasField fields (Maybe Declaration), HasField fields Span, Foldable f, Functor f) => Term f (Record fields) -> [JSONSummary]

src/SES.hs

@@ -1,10 +1,70 @@
-{-# LANGUAGE Strict #-}
+{-# LANGUAGE BangPatterns, GADTs, ImplicitParams, MultiParamTypeClasses, ScopedTypeVariables #-}
 module SES
-( Comparable
-, Myers.ses
+( EditScript
+, ses
 ) where
 
-import qualified SES.Myers as Myers
+import Data.Array ((!))
+import qualified Data.Array as Array
+import Data.Foldable (find, toList)
+import Data.Ix
+import Data.These
 
--- | Edit constructor for two terms, if comparable. Otherwise returns Nothing.
-type Comparable term = term -> term -> Bool
+-- | An edit script, i.e. a sequence of changes/copies of elements.
+type EditScript a b = [These a b]
+
+data Endpoint a b = Endpoint { x :: {-# UNPACK #-} !Int, _y :: {-# UNPACK #-} !Int, _script :: EditScript a b }
+  deriving (Eq, Show)
+
+
+-- | Compute the shortest edit script using Myers’ algorithm.
+ses :: (Foldable t, Foldable u) => (a -> b -> Bool) -> t a -> u b -> EditScript a b
+ses eq as' bs'
+  | null bs = This <$> toList as
+  | null as = That <$> toList bs
+  | otherwise = reverse (searchUpToD 0 (Array.array (1, 1) [(1, Endpoint 0 (-1) [])]))
+  where (as, bs) = (Array.listArray (0, pred n) (toList as'), Array.listArray (0, pred m) (toList bs'))
+        (!n, !m) = (length as', length bs')
+
+        -- Search an edit graph for the shortest edit script up to a given proposed edit distance, building on the results of previous searches.
+        searchUpToD !d !v =
+          let !endpoints = slideFrom . searchAlongK <$> [ k | k <- [-d, -d + 2 .. d], inRange (-m, n) k ] in
+          case find isComplete endpoints of
+            Just (Endpoint _ _ script) -> script
+            _ -> searchUpToD (succ d) (Array.array (-d, d) ((\ e@(Endpoint x y _) -> (x - y, e)) <$> endpoints))
+          where isComplete (Endpoint x y _) = x >= n && y >= m
+
+                -- Search an edit graph for the shortest edit script along a specific diagonal, moving onto a given diagonal from one of its in-bounds adjacent diagonals (if any).
+                searchAlongK !k
+                  | k == -d = moveDownFrom (v ! succ k)
+                  | k ==  d = moveRightFrom (v ! pred k)
+                  | k == -m = moveDownFrom (v ! succ k)
+                  | k ==  n = moveRightFrom (v ! pred k)
+                  | otherwise =
+                    let left = v ! pred k
+                        up   = v ! succ k in
+                    if x left < x up then
+                      moveDownFrom up
+                    else
+                      moveRightFrom left
+
+        -- | Move downward from a given vertex, inserting the element for the corresponding row.
+        moveDownFrom  (Endpoint x y script) = Endpoint       x (succ y) $ maybe script ((: script) . That) (bs !? y)
+        {-# INLINE moveDownFrom #-}
+
+        -- | Move rightward from a given vertex, deleting the element for the corresponding column.
+        moveRightFrom (Endpoint x y script) = Endpoint (succ x)      y  $ maybe script ((: script) . This) (as !? x)
+        {-# INLINE moveRightFrom #-}
+
+        -- | Slide down any diagonal edges from a given vertex.
+        slideFrom (Endpoint x y script)
+          | Just a <- as !? x
+          , Just b <- bs !? y
+          , a `eq` b  = slideFrom (Endpoint (succ x) (succ y) (These a b : script))
+          | otherwise =            Endpoint       x        y               script
+
+
+(!?) :: Ix i => Array.Array i a -> i -> Maybe a
+(!?) v i | inRange (Array.bounds v) i, !a <- v ! i = Just a
+         | otherwise = Nothing
+{-# INLINE (!?) #-}

src/SES/Myers.hs

@@ -1,70 +0,0 @@
-{-# LANGUAGE BangPatterns, GADTs, ImplicitParams, MultiParamTypeClasses, ScopedTypeVariables #-}
-module SES.Myers
-( EditScript
-, ses
-) where
-
-import Data.Array ((!))
-import qualified Data.Array as Array
-import Data.Foldable (find, toList)
-import Data.Ix
-import Data.These
-
--- | An edit script, i.e. a sequence of changes/copies of elements.
-type EditScript a b = [These a b]
-
-data Endpoint a b = Endpoint { x :: {-# UNPACK #-} !Int, _y :: {-# UNPACK #-} !Int, _script :: EditScript a b }
-  deriving (Eq, Show)
-
-
--- | Compute the shortest edit script using Myers’ algorithm.
-ses :: (Foldable t, Foldable u) => (a -> b -> Bool) -> t a -> u b -> EditScript a b
-ses eq as' bs'
-  | null bs = This <$> toList as
-  | null as = That <$> toList bs
-  | otherwise = reverse (searchUpToD 0 (Array.array (1, 1) [(1, Endpoint 0 (-1) [])]))
-  where (as, bs) = (Array.listArray (0, pred n) (toList as'), Array.listArray (0, pred m) (toList bs'))
-        (!n, !m) = (length as', length bs')
-
-        -- Search an edit graph for the shortest edit script up to a given proposed edit distance, building on the results of previous searches.
-        searchUpToD !d !v =
-          let !endpoints = slideFrom . searchAlongK <$> [ k | k <- [-d, -d + 2 .. d], inRange (-m, n) k ] in
-          case find isComplete endpoints of
-            Just (Endpoint _ _ script) -> script
-            _ -> searchUpToD (succ d) (Array.array (-d, d) ((\ e@(Endpoint x y _) -> (x - y, e)) <$> endpoints))
-          where isComplete (Endpoint x y _) = x >= n && y >= m
-
-                -- Search an edit graph for the shortest edit script along a specific diagonal, moving onto a given diagonal from one of its in-bounds adjacent diagonals (if any).
-                searchAlongK !k
-                  | k == -d = moveDownFrom (v ! succ k)
-                  | k ==  d = moveRightFrom (v ! pred k)
-                  | k == -m = moveDownFrom (v ! succ k)
-                  | k ==  n = moveRightFrom (v ! pred k)
-                  | otherwise =
-                    let left = v ! pred k
-                        up   = v ! succ k in
-                    if x left < x up then
-                      moveDownFrom up
-                    else
-                      moveRightFrom left
-
-        -- | Move downward from a given vertex, inserting the element for the corresponding row.
-        moveDownFrom  (Endpoint x y script) = Endpoint       x (succ y) $ maybe script ((: script) . That) (bs !? y)
-        {-# INLINE moveDownFrom #-}
-
-        -- | Move rightward from a given vertex, deleting the element for the corresponding column.
-        moveRightFrom (Endpoint x y script) = Endpoint (succ x)      y  $ maybe script ((: script) . This) (as !? x)
-        {-# INLINE moveRightFrom #-}
-
-        -- | Slide down any diagonal edges from a given vertex.
-        slideFrom (Endpoint x y script)
-          | Just a <- as !? x
-          , Just b <- bs !? y
-          , a `eq` b  = slideFrom (Endpoint (succ x) (succ y) (These a b : script))
-          | otherwise =            Endpoint       x        y               script
-
-
-(!?) :: Ix i => Array.Array i a -> i -> Maybe a
-(!?) v i | inRange (Array.bounds v) i, !a <- v ! i = Just a
-         | otherwise = Nothing
-{-# INLINE (!?) #-}

src/Semantic.hs

@@ -11,6 +11,7 @@ import Algorithm hiding (diff)
 import Control.Applicative ((<|>))
 import Control.Monad ((<=<))
 import Data.Align.Generic (GAlign)
+import Data.Bifunctor
 import Data.Blob
 import Data.ByteString (ByteString)
 import Data.Functor.Both as Both
@@ -80,26 +81,26 @@ diffBlobPair renderer blobs = case (renderer, effectiveLanguage) of
   (PatchDiffRenderer, Just Language.Markdown) -> run (parse markdownParser) diffRecursively (renderPatch blobs)
   (PatchDiffRenderer, Just Language.Python) -> run (parse pythonParser) diffRecursively (renderPatch blobs)
   (PatchDiffRenderer, _) -> run (parse syntaxParser) diffTerms (renderPatch blobs)
-  (SExpressionDiffRenderer, Just Language.JSON) -> run (decorate constructorLabel <=< parse jsonParser) diffRecursively (renderSExpressionDiff . fmap keepConstructorLabel)
-  (SExpressionDiffRenderer, Just Language.Markdown) -> run (decorate constructorLabel <=< parse markdownParser) diffRecursively (renderSExpressionDiff . fmap keepConstructorLabel)
-  (SExpressionDiffRenderer, Just Language.Python) -> run (decorate constructorLabel <=< parse pythonParser) diffRecursively (renderSExpressionDiff . fmap keepConstructorLabel)
-  (SExpressionDiffRenderer, _) -> run (parse syntaxParser) diffTerms (renderSExpressionDiff . fmap keepCategory)
+  (SExpressionDiffRenderer, Just Language.JSON) -> run (decorate constructorLabel <=< parse jsonParser) diffRecursively (renderSExpressionDiff . bimap keepConstructorLabel keepConstructorLabel)
+  (SExpressionDiffRenderer, Just Language.Markdown) -> run (decorate constructorLabel <=< parse markdownParser) diffRecursively (renderSExpressionDiff . bimap keepConstructorLabel keepConstructorLabel)
+  (SExpressionDiffRenderer, Just Language.Python) -> run (decorate constructorLabel <=< parse pythonParser) diffRecursively (renderSExpressionDiff . bimap keepConstructorLabel keepConstructorLabel)
+  (SExpressionDiffRenderer, _) -> run (parse syntaxParser) diffTerms (renderSExpressionDiff . bimap keepCategory keepCategory)
   (IdentityDiffRenderer, _) -> run (\ blob -> parse syntaxParser blob >>= decorate (syntaxDeclarationAlgebra blob)) diffTerms Just
   where effectiveLanguage = runBothWith (<|>) (blobLanguage <$> blobs)
         syntaxParser = parserForLanguage effectiveLanguage
 
-        run :: Functor f => (Blob -> Task (Term f a)) -> (Both (Term f a) -> Diff f a) -> (Diff f a -> output) -> Task output
-        run parse diff renderer = distributeFor blobs parse >>= diffTermPair blobs diff >>= render renderer
+        run :: Functor syntax => (Blob -> Task (Term syntax ann)) -> (Term syntax ann -> Term syntax ann -> Diff syntax ann ann) -> (Diff syntax ann ann -> output) -> Task output
+        run parse diff renderer = distributeFor blobs parse >>= runBothWith (diffTermPair blobs diff) >>= render renderer
 
-        diffRecursively :: (Eq1 f, GAlign f, Show1 f, Traversable f, Diffable f) => Both (Term f (Record fields)) -> Diff f (Record fields)
-        diffRecursively = decoratingWith constructorNameAndConstantFields (diffTermsWith algorithmForTerms comparableByConstructor)
+        diffRecursively :: (Eq1 syntax, GAlign syntax, Show1 syntax, Traversable syntax, Diffable syntax) => Term syntax (Record fields1) -> Term syntax (Record fields2) -> Diff syntax (Record fields1) (Record fields2)
+        diffRecursively = decoratingWith constructorNameAndConstantFields constructorNameAndConstantFields (diffTermsWith algorithmForTerms comparableByConstructor)
 
 -- | A task to diff a pair of 'Term's, producing insertion/deletion 'Patch'es for non-existent 'Blob's.
-diffTermPair :: Functor f => Both Blob -> Differ f a -> Both (Term f a) -> Task (Diff f a)
-diffTermPair blobs differ terms = case runJoin (blobExists <$> blobs) of
-  (True, False) -> pure (deleting (Both.fst terms))
-  (False, True) -> pure (inserting (Both.snd terms))
-  _ -> time "diff" logInfo $ diff differ terms
+diffTermPair :: Functor syntax => Both Blob -> Differ syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> Task (Diff syntax ann1 ann2)
+diffTermPair blobs differ t1 t2 = case runJoin (blobExists <$> blobs) of
+  (True, False) -> pure (deleting t1)
+  (False, True) -> pure (inserting t2)
+  _ -> time "diff" logInfo $ diff differ t1 t2
   where
     logInfo = let (a, b) = runJoin blobs in
             [ ("before_path", blobPath a)

src/Semantic/Task.hs

@@ -67,7 +67,7 @@ data TaskF output where
   Time :: String -> [(String, String)] -> Task output -> TaskF output
   Parse :: Parser term -> Blob -> TaskF term
   Decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fields)) field -> Term f (Record fields) -> TaskF (Term f (Record (field ': fields)))
-  Diff :: Differ f a -> Both (Term f a) -> TaskF (Diff f a)
+  Diff :: Differ syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> TaskF (Diff syntax ann1 ann2)
   Render :: Renderer input output -> input -> TaskF output
   Distribute :: Traversable t => t (Task output) -> TaskF (t output)
 
@@ -82,7 +82,7 @@ data TaskF output where
 type Task = Freer TaskF
 
 -- | A function to compute the 'Diff' for a pair of 'Term's with arbitrary syntax functor & annotation types.
-type Differ f a = Both (Term f a) -> Diff f a
+type Differ syntax ann1 ann2 = Term syntax ann1 -> Term syntax ann2 -> Diff syntax ann1 ann2
 
 -- | A function to render terms or diffs.
 type Renderer i o = i -> o
@@ -117,8 +117,8 @@ decorate :: Functor f => RAlgebra (TermF f (Record fields)) (Term f (Record fiel
 decorate algebra term = Decorate algebra term `Then` return
 
 -- | A 'Task' which diffs a pair of terms using the supplied 'Differ' function.
-diff :: Differ f a -> Both (Term f a) -> Task (Diff f a)
-diff differ terms = Semantic.Task.Diff differ terms `Then` return
+diff :: Differ syntax ann1 ann2 -> Term syntax ann1 -> Term syntax ann2 -> Task (Diff syntax ann1 ann2)
+diff differ term1 term2 = Semantic.Task.Diff differ term1 term2 `Then` return
 
 -- | A 'Task' which renders some input using the supplied 'Renderer' function.
 render :: Renderer input output -> input -> Task output
@@ -182,7 +182,7 @@ runTaskWithOptions options task = do
                     either (pure . Left) yield res
                   Parse parser blob -> go (runParser options blob parser) >>= either (pure . Left) yield
                   Decorate algebra term -> pure (decoratorWithAlgebra algebra term) >>= yield
-                  Semantic.Task.Diff differ terms -> pure (differ terms) >>= yield
+                  Semantic.Task.Diff differ term1 term2 -> pure (differ term1 term2) >>= yield
                   Render renderer input -> pure (renderer input) >>= yield
                   Distribute tasks -> Async.mapConcurrently go tasks >>= either (pure . Left) yield . sequenceA . withStrategy (parTraversable (parTraversable rseq))
                   LiftIO action -> action >>= yield

src/Term.hs

@@ -3,8 +3,6 @@ module Term
 ( Term(..)
 , termIn
 , TermF(..)
-, SyntaxTerm
-, SyntaxTermF
 , termSize
 , extract
 , unwrap
@@ -24,7 +22,6 @@ import Data.Functor.Foldable
 import Data.JSON.Fields
 import Data.Record
 import Data.Semigroup ((<>))
-import Syntax
 import Text.Show
 
 -- | A Term with an abstract syntax tree and an annotation.
@@ -33,9 +30,6 @@ newtype Term syntax ann = Term { unTerm :: TermF syntax ann (Term syntax ann) }
 data TermF syntax ann recur = In { termAnnotation :: ann, termOut :: syntax recur }
   deriving (Eq, Foldable, Functor, Show, Traversable)
 
--- | A Term with a Syntax leaf and a record of fields.
-type SyntaxTerm fields = Term Syntax (Record fields)
-type SyntaxTermF fields = TermF Syntax (Record fields)
 
 -- | Return the node count of a term.
 termSize :: (Foldable f, Functor f) => Term f annotation -> Int

src/TreeSitter.hs

@@ -35,7 +35,7 @@ import qualified TreeSitter.TypeScript as TS
 import Info
 
 -- | Returns a TreeSitter parser for the given language and TreeSitter grammar.
-treeSitterParser :: Ptr TS.Language -> Blob -> IO (SyntaxTerm DefaultFields)
+treeSitterParser :: Ptr TS.Language -> Blob -> IO (Term S.Syntax (Record DefaultFields))
 treeSitterParser language blob = bracket TS.ts_document_new TS.ts_document_free $ \ document -> do
   TS.ts_document_set_language document language
   unsafeUseAsCStringLen (sourceBytes (blobSource blob)) $ \ (sourceBytes, len) -> do
@@ -71,13 +71,13 @@ anaM g = a where a = pure . embed <=< traverse a <=< g
 
 
 -- | Return a parser for a tree sitter language & document.
-documentToTerm :: Ptr TS.Language -> Ptr TS.Document -> Blob -> IO (SyntaxTerm DefaultFields)
+documentToTerm :: Ptr TS.Language -> Ptr TS.Document -> Blob -> IO (Term S.Syntax (Record DefaultFields))
 documentToTerm language document Blob{..} = do
   root <- alloca (\ rootPtr -> do
     TS.ts_document_root_node_p document rootPtr
     peek rootPtr)
   toTerm root
-  where toTerm :: TS.Node -> IO (SyntaxTerm DefaultFields)
+  where toTerm :: TS.Node -> IO (Term S.Syntax (Record DefaultFields))
         toTerm node@TS.Node{..} = do
           name <- peekCString nodeType
 
@@ -96,7 +96,7 @@ documentToTerm language document Blob{..} = do
         copyNamed = TS.ts_node_copy_named_child_nodes document
         copyAll = TS.ts_node_copy_child_nodes document
 
-isNonEmpty :: HasField fields Category => SyntaxTerm fields -> Bool
+isNonEmpty :: HasField fields Category => Term S.Syntax (Record fields) -> Bool
 isNonEmpty = (/= Empty) . category . extract
 
 nodeRange :: TS.Node -> Range
@@ -106,19 +106,19 @@ nodeSpan :: TS.Node -> Span
 nodeSpan TS.Node{..} = nodeStartPoint `seq` nodeEndPoint `seq` Span (pointPos nodeStartPoint) (pointPos nodeEndPoint)
   where pointPos TS.TSPoint{..} = pointRow `seq` pointColumn `seq` Pos (1 + fromIntegral pointRow) (1 + fromIntegral pointColumn)
 
-assignTerm :: Ptr TS.Language -> Source -> Record DefaultFields -> [ SyntaxTerm DefaultFields ] -> IO [ SyntaxTerm DefaultFields ] -> IO (SyntaxTerm DefaultFields)
+assignTerm :: Ptr TS.Language -> Source -> Record DefaultFields -> [ Term S.Syntax (Record DefaultFields) ] -> IO [ Term S.Syntax (Record DefaultFields) ] -> IO (Term S.Syntax (Record DefaultFields))
 assignTerm language source annotation children allChildren =
   case assignTermByLanguage source (category annotation) children of
     Just a -> pure (termIn annotation a)
     _ -> defaultTermAssignment source annotation children allChildren
-  where assignTermByLanguage :: Source -> Category -> [ SyntaxTerm DefaultFields ] -> Maybe (S.Syntax (SyntaxTerm DefaultFields))
+  where assignTermByLanguage :: Source -> Category -> [ Term S.Syntax (Record DefaultFields) ] -> Maybe (S.Syntax (Term S.Syntax (Record DefaultFields)))
         assignTermByLanguage = case languageForTSLanguage language of
           Just Language.Go -> Go.termAssignment
           Just Ruby -> Ruby.termAssignment
           Just TypeScript -> TS.termAssignment
           _ -> \ _ _ _ -> Nothing
 
-defaultTermAssignment :: Source -> Record DefaultFields -> [ SyntaxTerm DefaultFields ] -> IO [ SyntaxTerm DefaultFields ] -> IO (SyntaxTerm DefaultFields)
+defaultTermAssignment :: Source -> Record DefaultFields -> [ Term S.Syntax (Record DefaultFields) ] -> IO [ Term S.Syntax (Record DefaultFields) ] -> IO (Term S.Syntax (Record DefaultFields))
 defaultTermAssignment source annotation children allChildren
   | category annotation `elem` operatorCategories = Term . In annotation . S.Operator <$> allChildren
   | otherwise = case (category annotation, children) of

test/AlignmentSpec.hs

@@ -258,7 +258,7 @@ instance Listable BranchElement where
 counts :: [Join These (Int, a)] -> Both Int
 counts numbered = fromMaybe 0 . getLast . mconcat . fmap Last <$> Join (unalign (runJoin . fmap fst <$> numbered))
 
-align :: Both Source.Source -> Diff Syntax (Record '[Range]) -> PrettyDiff (SplitDiff [] (Record '[Range]))
+align :: Both Source.Source -> Diff Syntax (Record '[Range]) (Record '[Range]) -> PrettyDiff (SplitDiff [] (Record '[Range]))
 align sources = PrettyDiff sources . fmap (fmap (getRange &&& id)) . alignDiff sources
 
 info :: Int -> Int -> Record '[Range]

test/Data/Functor/Listable.hs

@@ -70,6 +70,13 @@ tiers2 :: (Listable a, Listable b, Listable2 l) => [Tier (l a b)]
 tiers2 = liftTiers2 tiers tiers
 
 
+class Listable3 l where
+  liftTiers3 :: [Tier a] -> [Tier b] -> [Tier c] -> [Tier (l a b c)]
+
+tiers3 :: (Listable3 l, Listable a, Listable b, Listable c) => [Tier (l a b c)]
+tiers3 = liftTiers3 tiers tiers tiers
+
+
 -- | Lifts a unary constructor to a list of tiers, given a list of tiers for its argument.
 --
 --   Commonly used in the definition of 'Listable1' and 'Listable2' instances.
@@ -165,22 +172,19 @@ instance (Listable1 f, Listable a) => Listable (Term f a) where
   tiers = tiers1
 
 
-instance Listable1 f => Listable2 (DiffF f) where
-  liftTiers2 annTiers recurTiers
-    =  liftCons1 (liftTiers (liftTiers2 annTiers recurTiers)) Patch
-    \/ liftCons1 (liftTiers2 (liftTiers2 annTiers annTiers) recurTiers) Merge
+instance (Listable1 syntax) => Listable3 (DiffF syntax) where
+  liftTiers3 ann1Tiers ann2Tiers recurTiers
+    =  liftCons1 (liftTiers2 (liftTiers2 ann1Tiers recurTiers) (liftTiers2 ann2Tiers recurTiers)) Patch
+    \/ liftCons1 (liftTiers2 (liftTiers2 ann1Tiers ann2Tiers) recurTiers) Merge
 
-instance (Listable1 f, Listable a) => Listable1 (DiffF f a) where
-  liftTiers = liftTiers2 tiers
+instance (Listable1 syntax, Listable ann1, Listable ann2, Listable recur) => Listable (DiffF syntax ann1 ann2 recur) where
+  tiers = tiers3
 
-instance (Listable1 f, Listable a, Listable b) => Listable (DiffF f a b) where
-  tiers = tiers1
+instance Listable1 f => Listable2 (Diff f) where
+  liftTiers2 annTiers1 annTiers2 = go where go = liftCons1 (liftTiers3 annTiers1 annTiers2 go) Diff
 
-instance Listable1 f => Listable1 (Diff f) where
-  liftTiers annTiers = go where go = liftCons1 (liftTiers2 annTiers go) Diff
-
-instance (Listable1 f, Listable a) => Listable (Diff f a) where
-  tiers = tiers1
+instance (Listable1 syntax, Listable ann1, Listable ann2) => Listable (Diff syntax ann1 ann2) where
+  tiers = tiers2
 
 
 instance (Listable head, Listable (Record tail)) => Listable (Record (head ': tail)) where
@@ -211,11 +215,11 @@ instance Listable Category.Category where
        \/ cons0 Category.SingletonMethod
 
 
-instance Listable1 Patch where
-  liftTiers t = liftCons1 t Insert \/ liftCons1 t Delete \/ liftCons2 t t Replace
+instance Listable2 Patch where
+  liftTiers2 t1 t2 = liftCons1 t2 Insert \/ liftCons1 t1 Delete \/ liftCons2 t1 t2 Replace
 
-instance Listable a => Listable (Patch a) where
-  tiers = tiers1
+instance (Listable a, Listable b) => Listable (Patch a b) where
+  tiers = tiers2
 
 
 instance Listable1 Syntax where

test/Data/RandomWalkSimilarity/Spec.hs

@@ -20,32 +20,30 @@ spec = parallel $ do
   let positively = succ . abs
   describe "pqGramDecorator" $ do
     prop "produces grams with stems of the specified length" $
-      \ (term, p, q) -> pqGramDecorator (rhead . termAnnotation) (positively p) (positively q) (term :: SyntaxTerm '[Category]) `shouldSatisfy` all ((== positively p) . length . stem . rhead)
+      \ (term, p, q) -> pqGramDecorator (rhead . termAnnotation) (positively p) (positively q) (term :: Term Syntax (Record '[Category])) `shouldSatisfy` all ((== positively p) . length . stem . rhead)
 
     prop "produces grams with bases of the specified width" $
-      \ (term, p, q) -> pqGramDecorator (rhead . termAnnotation) (positively p) (positively q) (term :: SyntaxTerm '[Category]) `shouldSatisfy` all ((== positively q) . length . base . rhead)
+      \ (term, p, q) -> pqGramDecorator (rhead . termAnnotation) (positively p) (positively q) (term :: Term Syntax (Record '[Category])) `shouldSatisfy` all ((== positively q) . length . base . rhead)
 
   describe "featureVectorDecorator" $ do
     prop "produces a vector of the specified dimension" $
-      \ (term, p, q, d) -> featureVectorDecorator (rhead . termAnnotation) (positively p) (positively q) (positively d) (term :: SyntaxTerm '[Category]) `shouldSatisfy` all ((== (0, abs d)) . bounds . rhead)
+      \ (term, p, q, d) -> featureVectorDecorator (rhead . termAnnotation) (positively p) (positively q) (positively d) (term :: Term Syntax (Record '[Category])) `shouldSatisfy` all ((== (0, abs d)) . bounds . unFV . rhead)
 
   describe "rws" $ do
     prop "produces correct diffs" $
-      \ (as, bs) -> let tas = decorate <$> (as :: [SyntaxTerm '[Category]])
-                        tbs = decorate <$> (bs :: [SyntaxTerm '[Category]])
+      \ (as, bs) -> let tas = decorate <$> (as :: [Term Syntax (Record '[Category])])
+                        tbs = decorate <$> (bs :: [Term Syntax (Record '[Category])])
                         root = termIn (Program :. Nil) . Indexed
-                        diff = merge ((Program :. Nil, Program :. Nil)) (Indexed (stripDiff . diffThese <$> rws editDistance canCompare tas tbs)) in
+                        diff = merge ((Program :. Nil, Program :. Nil)) (Indexed (stripDiff . diffThese <$> rws canCompare tas tbs)) in
         (beforeTerm diff, afterTerm diff) `shouldBe` (Just (root (stripTerm <$> tas)), Just (root (stripTerm <$> tbs)))
 
     it "produces unbiased insertions within branches" $
       let (a, b) = (decorate (Term ((StringLiteral :. Nil) `In` Indexed [ Term ((StringLiteral :. Nil) `In` Leaf "a") ])), decorate (Term ((StringLiteral :. Nil) `In` Indexed [ Term ((StringLiteral :. Nil) `In` Leaf "b") ]))) in
-      fmap (bimap stripTerm stripTerm) (rws editDistance canCompare [ b ] [ a, b ]) `shouldBe` fmap (bimap stripTerm stripTerm) [ That a, These b b ]
+      fmap (bimap stripTerm stripTerm) (rws canCompare [ b ] [ a, b ]) `shouldBe` fmap (bimap stripTerm stripTerm) [ That a, These b b ]
 
   where canCompare a b = termAnnotation a == termAnnotation b
 
-        decorate :: SyntaxTerm '[Category] -> SyntaxTerm '[FeatureVector, Category]
+        decorate :: Term Syntax (Record '[Category]) -> Term Syntax (Record '[FeatureVector, Category])
         decorate = defaultFeatureVectorDecorator (category . termAnnotation)
 
         diffThese = these deleting inserting replacing
-
-        editDistance = these (const 1) (const 1) (const (const 0))

test/DiffSpec.hs

@@ -4,10 +4,12 @@ module DiffSpec where
 import Category
 import Data.Functor.Both
 import Data.Functor.Listable ()
+import Data.Record
 import RWS
 import Diff
 import Info
 import Interpreter
+import Syntax
 import Term
 import Test.Hspec
 import Test.Hspec.LeanCheck
@@ -16,19 +18,18 @@ spec :: Spec
 spec = parallel $ do
   let decorate = defaultFeatureVectorDecorator (category . termAnnotation)
   prop "equality is reflexive" $
-    \ a -> let diff = a :: SyntaxDiff '[Category] in
-      diff `shouldBe` diff
+    \ diff -> diff `shouldBe` (diff :: Diff Syntax (Record '[Category]) (Record '[Category]))
 
   prop "equal terms produce identity diffs" $
-    \ a -> let term = decorate (a :: SyntaxTerm '[Category]) in
-      diffCost (diffTerms (pure term)) `shouldBe` 0
+    \ a -> let term = decorate (a :: Term Syntax (Record '[Category])) in
+      diffCost (diffTerms term term) `shouldBe` 0
 
   describe "beforeTerm" $ do
     prop "recovers the before term" $
-      \ a b -> let diff = diffTerms (both a b :: Both (SyntaxTerm '[Category])) in
+      \ a b -> let diff = diffTerms a b :: Diff Syntax (Record '[Category]) (Record '[Category]) in
         beforeTerm diff `shouldBe` Just a
 
   describe "afterTerm" $ do
     prop "recovers the after term" $
-      \ a b -> let diff = diffTerms (both a b :: Both (SyntaxTerm '[Category])) in
+      \ a b -> let diff = diffTerms a b :: Diff Syntax (Record '[Category]) (Record '[Category]) in
         afterTerm diff `shouldBe` Just b

test/InterpreterSpec.hs

@@ -20,18 +20,17 @@ spec = parallel $ do
     it "returns a replacement when comparing two unicode equivalent terms" $
       let termA = Term $ (StringLiteral :. Nil) `In` Leaf "t\776"
           termB = Term $ (StringLiteral :. Nil) `In` Leaf "\7831" in
-          diffTerms (both termA termB) `shouldBe` replacing termA termB
+          diffTerms termA termB `shouldBe` replacing termA termB
 
     prop "produces correct diffs" $
-      \ a b -> let diff = diffTerms (unListableF <$> both a b :: Both (SyntaxTerm '[Category])) in
-                   (beforeTerm diff, afterTerm diff) `shouldBe` (Just (unListableF a), Just (unListableF b))
+      \ a b -> let diff = diffTerms a b :: Diff Syntax (Record '[Category]) (Record '[Category]) in
+                   (beforeTerm diff, afterTerm diff) `shouldBe` (Just a, Just b)
 
     prop "constructs zero-cost diffs of equal terms" $
-      \ a -> let term = (unListableF a :: SyntaxTerm '[Category])
-                 diff = diffTerms (pure term) in
+      \ a -> let diff = diffTerms a a :: Diff Syntax (Record '[Category]) (Record '[Category]) in
                  diffCost diff `shouldBe` 0
 
     it "produces unbiased insertions within branches" $
-      let term s = Term ((StringLiteral :. Nil) `In` Indexed [ Term ((StringLiteral :. Nil) `In` Leaf s) ]) :: SyntaxTerm '[Category]
+      let term s = Term ((StringLiteral :. Nil) `In` Indexed [ Term ((StringLiteral :. Nil) `In` Leaf s) ]) :: Term Syntax (Record '[Category])
           root = termIn (Program :. Nil) . Indexed in
-      diffTerms (both (root [ term "b" ]) (root [ term "a", term "b" ])) `shouldBe` merge ((Program :. Nil, Program :. Nil)) (Indexed [ inserting (term "a"), cata (\ (In a r) -> merge (a, a) r) (term "b") ])
+      diffTerms (root [ term "b" ]) (root [ term "a", term "b" ]) `shouldBe` merge ((Program :. Nil, Program :. Nil)) (Indexed [ inserting (term "a"), cata (\ (In a r) -> merge (a, a) r) (term "b") ])

test/SES/Spec.hs

@@ -1,7 +1,7 @@
-module SES.Myers.Spec where
+module SES.Spec where
 
 import Data.These
-import SES.Myers
+import SES
 import Test.Hspec
 import Test.Hspec.LeanCheck
 

test/SemanticSpec.hs

@@ -31,11 +31,11 @@ spec = parallel $ do
 
   describe "diffTermPair" $ do
     it "produces an Insert when the first blob is missing" $ do
-      result <- runTask (diffTermPair (both (emptyBlob "/foo") (sourceBlob "/foo" Nothing "")) (runBothWith replacing) (pure (termIn () [])))
+      result <- runTask (diffTermPair (both (emptyBlob "/foo") (sourceBlob "/foo" Nothing "")) replacing (termIn () []) (termIn () []))
       result `shouldBe` Diff (Patch (Insert (In () [])))
 
     it "produces a Delete when the second blob is missing" $ do
-      result <- runTask (diffTermPair (both (sourceBlob "/foo" Nothing "") (emptyBlob "/foo")) (runBothWith replacing) (pure (termIn () [])))
+      result <- runTask (diffTermPair (both (sourceBlob "/foo" Nothing "") (emptyBlob "/foo")) replacing (termIn () []) (termIn () []))
       result `shouldBe` Diff (Patch (Delete (In () [])))
 
   where

test/Spec.hs

@@ -8,7 +8,7 @@ import qualified Data.Syntax.Assignment.Spec
 import qualified DiffSpec
 import qualified InterpreterSpec
 import qualified PatchOutputSpec
-import qualified SES.Myers.Spec
+import qualified SES.Spec
 import qualified SourceSpec
 import qualified TermSpec
 import qualified TOCSpec
@@ -28,7 +28,7 @@ main = hspec $ do
     describe "Diff" DiffSpec.spec
     describe "Interpreter" InterpreterSpec.spec
     describe "PatchOutput" PatchOutputSpec.spec
-    describe "SES.Myers" SES.Myers.Spec.spec
+    describe "SES" SES.Spec.spec
     describe "Source" SourceSpec.spec
     describe "Term" TermSpec.spec
     describe "Semantic" SemanticSpec.spec

test/TOCSpec.hs

@@ -4,6 +4,7 @@ module TOCSpec where
 
 import Category as C
 import Data.Aeson
+import Data.Bifunctor
 import Data.Blob
 import Data.ByteString (ByteString)
 import Data.Functor.Both
@@ -39,21 +40,23 @@ spec :: Spec
 spec = parallel $ do
   describe "tableOfContentsBy" $ do
     prop "drops all nodes with the constant Nothing function" $
-      \ diff -> tableOfContentsBy (const Nothing :: a -> Maybe ()) (diff :: Diff Syntax ()) `shouldBe` []
+      \ diff -> tableOfContentsBy (const Nothing :: a -> Maybe ()) (diff :: Diff Syntax () ()) `shouldBe` []
 
     let diffSize = max 1 . length . diffPatches
     let lastValue a = fromMaybe (extract a) (getLast (foldMap (Last . Just) a))
     prop "includes all nodes with a constant Just function" $
-      \ diff -> let diff' = (diff :: Diff Syntax ()) in entryPayload <$> tableOfContentsBy (const (Just ())) diff' `shouldBe` replicate (diffSize diff') ()
+      \ diff -> let diff' = (diff :: Diff Syntax () ()) in entryPayload <$> tableOfContentsBy (const (Just ())) diff' `shouldBe` replicate (diffSize diff') ()
 
     prop "produces an unchanged entry for identity diffs" $
-      \ term -> let term' = (term :: Term Syntax (Record '[Category])) in tableOfContentsBy (Just . termAnnotation) (diffTerms (pure term')) `shouldBe` [Unchanged (lastValue term')]
+      \ term -> tableOfContentsBy (Just . termAnnotation) (diffTerms term term) `shouldBe` [Unchanged (lastValue (term :: Term Syntax (Record '[Category])))]
 
     prop "produces inserted/deleted/replaced entries for relevant nodes within patches" $
-      \ patch -> let patch' = (patch :: Patch (Term Syntax Int)) in tableOfContentsBy (Just . termAnnotation) (these deleting inserting replacing (unPatch patch')) `shouldBe` these (fmap Deleted) (fmap Inserted) (const (fmap Replaced)) (unPatch (foldMap pure <$> patch'))
+      \ p -> tableOfContentsBy (Just . termAnnotation) (patch deleting inserting replacing p)
+      `shouldBe`
+      patch (fmap Deleted) (fmap Inserted) (const (fmap Replaced)) (bimap (foldMap pure) (foldMap pure) (p :: Patch (Term Syntax Int) (Term Syntax Int)))
 
     prop "produces changed entries for relevant nodes containing irrelevant patches" $
-      \ diff -> let diff' = merge (0, 0) (Indexed [1 <$ (diff :: Diff Syntax Int)]) in
+      \ diff -> let diff' = merge (0, 0) (Indexed [bimap (const 1) (const 1) (diff :: Diff Syntax Int Int)]) in
         tableOfContentsBy (\ (n `In` _) -> if n == (0 :: Int) then Just n else Nothing) diff' `shouldBe`
         if null (diffPatches diff') then [Unchanged 0]
                                     else replicate (length (diffPatches diff')) (Changed 0)
@@ -132,7 +135,7 @@ spec = parallel $ do
 
     prop "equal terms produce identity diffs" $
       \a -> let term = defaultFeatureVectorDecorator (Info.category . termAnnotation) (a :: Term') in
-        diffTOC (diffTerms (pure term)) `shouldBe` []
+        diffTOC (diffTerms term term) `shouldBe` []
 
   describe "JSONSummary" $ do
     it "encodes modified summaries to JSON" $ do
@@ -160,8 +163,8 @@ spec = parallel $ do
       toOutput output `shouldBe` ("{\"changes\":{\"test/fixtures/toc/markdown/headings.A.md -> test/fixtures/toc/markdown/headings.B.md\":[{\"span\":{\"start\":[5,1],\"end\":[7,10]},\"category\":\"Heading 2\",\"term\":\"Two\",\"changeType\":\"added\"},{\"span\":{\"start\":[9,1],\"end\":[10,4]},\"category\":\"Heading 1\",\"term\":\"Final\",\"changeType\":\"added\"}]},\"errors\":{}}\n" :: ByteString)
 
 
-type Diff' = SyntaxDiff (Maybe Declaration ': DefaultFields)
-type Term' = SyntaxTerm (Maybe Declaration ': DefaultFields)
+type Diff' = Diff Syntax (Record (Maybe Declaration ': DefaultFields)) (Record (Maybe Declaration ': DefaultFields))
+type Term' = Term Syntax (Record (Maybe Declaration ': DefaultFields))
 
 numTocSummaries :: Diff' -> Int
 numTocSummaries diff = length $ filter isValidSummary (diffTOC diff)

test/TermSpec.hs

@@ -3,6 +3,8 @@ module TermSpec where
 
 import Category
 import Data.Functor.Listable
+import Data.Record
+import Syntax
 import Term
 import Test.Hspec (Spec, describe, parallel)
 import Test.Hspec.Expectations.Pretty
@@ -12,4 +14,4 @@ spec :: Spec
 spec = parallel $ do
   describe "Term" $ do
     prop "equality is reflexive" $
-      \ a -> unListableF a `shouldBe` (unListableF a :: SyntaxTerm '[Category])
+      \ a -> unListableF a `shouldBe` (unListableF a :: Term Syntax (Record '[Category]))