🔥 the comparability parameter to diffTerms.

src/Diffing.hs

@@ -46,7 +46,7 @@ diffFiles parse render sourceBlobs = do
         (True, False) -> pure $ Insert (snd terms)
         (False, True) -> pure $ Delete (fst terms)
         (_, _) ->
-          runBothWith (diffTerms compareCategoryEq) terms
+          runBothWith diffTerms terms
     areNullOids a b = (hasNullOid a, hasNullOid b)
     hasNullOid blob = oid blob == nullOid || Source.null (source blob)
 

src/Interpreter.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE GADTs, RankNTypes #-}
-module Interpreter (Comparable, diffTerms) where
+module Interpreter (diffTerms) where
 
 import Algorithm
 import Data.Align.Generic
@@ -15,28 +15,24 @@ import Prologue hiding (lookup)
 import Syntax as S
 import Term
 
--- | Returns whether two terms are comparable
-type Comparable f annotation = Term f annotation -> Term f annotation -> Bool
-
 -- | Diff two terms recursively, given functions characterizing the diffing.
 diffTerms :: (Eq leaf, HasField fields Category, HasField fields (Maybe FeatureVector))
-  => Comparable (Syntax leaf) (Record fields) -- ^ A function to determine whether or not two terms should even be compared.
+  => SyntaxTerm leaf fields -- ^ A term representing the old state.
-  -> SyntaxTerm leaf fields -- ^ A term representing the old state.
   -> SyntaxTerm leaf fields -- ^ A term representing the new state.
   -> SyntaxDiff leaf fields
-diffTerms comparable a b = fromMaybe (replacing a b) $ diffComparableTerms comparable a b
+diffTerms a b = fromMaybe (replacing a b) $ diffComparableTerms a b
 
 -- | Diff two terms recursively, given functions characterizing the diffing. If the terms are incomparable, returns 'Nothing'.
 diffComparableTerms :: (Eq leaf, HasField fields Category, HasField fields (Maybe FeatureVector))
-                    => Comparable (Syntax leaf) (Record fields)
+                    => SyntaxTerm leaf fields
-                    -> SyntaxTerm leaf fields
                     -> SyntaxTerm leaf fields
                     -> Maybe (SyntaxDiff leaf fields)
-diffComparableTerms comparable = recur
+diffComparableTerms = recur
   where recur a b
           | (category <$> a) == (category <$> b) = hylo wrap runCofree <$> zipTerms a b
           | comparable a b = runAlgorithm recur (Just <$> algorithmWithTerms a b)
           | otherwise = Nothing
+        comparable = (==) `on` category . extract
 
 -- | Construct an algorithm to diff a pair of terms.
 algorithmWithTerms :: MonadFree (TermF (Syntax leaf) (Both a)) diff

test/Diff/Spec.hs

@@ -24,16 +24,16 @@ spec = parallel $ do
 
   prop "equal terms produce identity diffs" $
     \ a -> let term = decorate (unListableF a :: SyntaxTerm String '[Category]) in
-      diffCost (diffTerms (==) term term) `shouldBe` 0
+      diffCost (diffTerms term term) `shouldBe` 0
 
   describe "beforeTerm" $ do
     prop "recovers the before term" $
-      \ a b -> let diff = stripDiff $ diffTerms (==) (decorate (unListableF a)) (decorate (unListableF b :: SyntaxTerm String '[Category])) in
+      \ a b -> let diff = stripDiff $ diffTerms (decorate (unListableF a)) (decorate (unListableF b :: SyntaxTerm String '[Category])) in
         beforeTerm diff `shouldBe` Just (unListableF a)
 
   describe "afterTerm" $ do
     prop "recovers the after term" $
-      \ a b -> let diff = stripDiff $ diffTerms (==) (decorate (unListableF a)) (decorate (unListableF b :: SyntaxTerm String '[Category])) in
+      \ a b -> let diff = stripDiff $ diffTerms (decorate (unListableF a)) (decorate (unListableF b :: SyntaxTerm String '[Category])) in
         afterTerm diff `shouldBe` Just (unListableF b)
 
 unListableDiff :: Functor f => ListableF (Free (TermF f (ListableF (Join (,)) annotation))) (Patch (ListableF (Term f) annotation)) -> Diff f annotation

test/DiffSummarySpec.hs

@@ -51,7 +51,7 @@ spec = parallel $ do
 
     prop "equal terms produce identity diffs" $
       \ a -> let term = defaultFeatureVectorDecorator (category . headF) (unListableF a :: SyntaxTerm String '[Category, Range, SourceSpan]) in
-        diffSummaries blobs (diffTerms (==) term term) `shouldBe` []
+        diffSummaries blobs (diffTerms term term) `shouldBe` []
 
   describe "DiffInfo" $ do
     prop "patches in summaries match the patches in diffs" $

test/InterpreterSpec.hs

@@ -23,22 +23,21 @@ spec :: Spec
 spec = parallel $ do
   describe "interpret" $ do
     let decorate = defaultFeatureVectorDecorator (category . headF)
-    let compare = (==) `on` category . extract
     it "returns a replacement when comparing two unicode equivalent terms" $
       let termA = cofree $ (StringLiteral :. Nil) :< Leaf ("t\776" :: String)
           termB = cofree $ (StringLiteral :. Nil) :< Leaf "\7831" in
-          stripDiff (diffTerms compare (decorate termA) (decorate termB)) `shouldBe` replacing termA termB
+          stripDiff (diffTerms (decorate termA) (decorate termB)) `shouldBe` replacing termA termB
 
     prop "produces correct diffs" $
-      \ a b -> let diff = stripDiff $ diffTerms compare (decorate (unListableF a)) (decorate (unListableF b :: SyntaxTerm String '[Category])) in
+      \ a b -> let diff = stripDiff $ diffTerms (decorate (unListableF a)) (decorate (unListableF b :: SyntaxTerm String '[Category])) in
                    (beforeTerm diff, afterTerm diff) `shouldBe` (Just (unListableF a), Just (unListableF b))
 
     prop "constructs zero-cost diffs of equal terms" $
       \ a -> let term = decorate (unListableF a :: SyntaxTerm String '[Category])
-                 diff = diffTerms compare term term in
+                 diff = diffTerms term term in
                  diffCost diff `shouldBe` 0
 
     it "produces unbiased insertions within branches" $
       let term s = decorate (cofree ((StringLiteral :. Nil) :< Indexed [ cofree ((StringLiteral :. Nil) :< Leaf s) ]))
           root = cofree . ((Just (listArray (0, defaultD) (repeat 0)) :. Program :. Nil) :<) . Indexed in
-      stripDiff (diffTerms compare (root [ term "b" ]) (root [ term "a", term "b" ])) `shouldBe` wrap (pure (Program :. Nil) :< Indexed [ inserting (stripTerm (term "a")), cata wrap (fmap pure (stripTerm (term "b"))) ])
+      stripDiff (diffTerms (root [ term "b" ]) (root [ term "a", term "b" ])) `shouldBe` wrap (pure (Program :. Nil) :< Indexed [ inserting (stripTerm (term "a")), cata wrap (fmap pure (stripTerm (term "b"))) ])

test/TOCSpec.hs

@@ -94,7 +94,7 @@ spec = parallel $ do
 
     prop "equal terms produce identity diffs" $
       \a -> let term = defaultFeatureVectorDecorator (Info.category . headF) (unListableF a :: Term') in
-        diffTOC blankDiffBlobs (diffTerms (==) term term) `shouldBe` []
+        diffTOC blankDiffBlobs (diffTerms term term) `shouldBe` []
 
 type Diff' = SyntaxDiff String '[Range, Category, SourceSpan]
 type Term' = SyntaxTerm String '[Range, Category, SourceSpan]
@@ -165,7 +165,7 @@ testDiff sourceBlobs = do
     diffTerms' terms blobs = case runBothWith areNullOids blobs of
       (True, False) -> pure $ Insert (snd terms)
       (False, True) -> pure $ Delete (fst terms)
-      (_, _) -> runBothWith (diffTerms compareCategoryEq) terms
+      (_, _) -> runBothWith diffTerms terms
     areNullOids a b = (hasNullOid a, hasNullOid b)
     hasNullOid blob = oid blob == nullOid || Source.null (source blob)