Curry diffing operations.

src/Interpreter.hs

@@ -9,7 +9,6 @@ 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)
@@ -26,25 +25,28 @@ import Term
 
 -- | Diff two terms recursively, given functions characterizing the diffing.
 diffTerms :: HasField fields Category
-          => Both (Term Syntax (Record fields)) -- ^ A pair of terms representing the old and new state, respectively.
+          => Term Syntax (Record fields) -- ^ A term representing the old state.
+          -> Term Syntax (Record fields) -- ^ A term representing the new state.
           -> Diff Syntax (Record fields)
 diffTerms = decoratingWith 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))
+               -> (Term f (Record (FeatureVector ': fields)) -> Term f (Record (FeatureVector ': fields)) -> Diff f (Record (FeatureVector ': fields)))
+               -> Term f (Record fields)
+               -> Term f (Record fields)
                -> Diff f (Record fields)
-decoratingWith getLabel differ = stripDiff . differ . fmap (defaultFeatureVectorDecorator getLabel)
+decoratingWith getLabel differ t1 t2 = stripDiff (differ (defaultFeatureVectorDecorator getLabel t1) (defaultFeatureVectorDecorator getLabel 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) (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.
+              -> Term f (Record fields) -- ^ A term representing the old state.
+              -> Term f (Record fields) -- ^ A term representing the new state.
               -> Diff f (Record fields) -- ^ The resulting diff.
-diffTermsWith refine comparable (Join (a, b)) = runFreer decompose (diff a b)
+diffTermsWith refine comparable t1 t2 = runFreer decompose (diff t1 t2)
   where decompose :: AlgorithmF (Term f) (Diff f) (Record fields) result -> Algorithm (Term f) (Diff f) (Record fields) result
         decompose step = case step of
           Algorithm.Diff t1 t2 -> refine t1 t2

src/Semantic.hs

@@ -88,18 +88,18 @@ diffBlobPair renderer blobs = case (renderer, effectiveLanguage) of
   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 f => (Blob -> Task (Term f a)) -> (Term f a -> Term f a -> Diff f a) -> (Diff f a -> 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 :: (Eq1 f, GAlign f, Show1 f, Traversable f, Diffable f) => Term f (Record fields) -> Term f (Record fields) -> Diff f (Record fields)
         diffRecursively = decoratingWith 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 f => Both Blob -> Differ f a -> Term f a -> Term f a -> Task (Diff f a)
+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 f a -> Term f a -> Term f a -> TaskF (Diff f a)
   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 f a = Term f a -> Term f a -> Diff f a
 
 -- | 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 f a -> Term f a -> Term f a -> Task (Diff f a)
+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

test/DiffSpec.hs

@@ -23,14 +23,14 @@ spec = parallel $ do
 
   prop "equal terms produce identity diffs" $
     \ a -> let term = decorate (a :: Term Syntax (Record '[Category])) in
-      diffCost (diffTerms (pure term)) `shouldBe` 0
+      diffCost (diffTerms term term) `shouldBe` 0
 
   describe "beforeTerm" $ do
     prop "recovers the before term" $
-      \ a b -> let diff = diffTerms (both a b :: Both (Term Syntax (Record '[Category]))) in
+      \ a b -> let diff = diffTerms a b :: Diff Syntax (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 (Term Syntax (Record '[Category]))) in
+      \ a b -> let diff = diffTerms a b :: Diff Syntax (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 (Term Syntax (Record '[Category]))) in
-                   (beforeTerm diff, afterTerm diff) `shouldBe` (Just (unListableF a), Just (unListableF b))
+      \ a b -> let diff = diffTerms a b :: Diff Syntax (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 :: Term Syntax (Record '[Category]))
-                 diff = diffTerms (pure term) in
+      \ a -> let diff = diffTerms a a :: Diff Syntax (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) ]) :: 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/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/TOCSpec.hs

@@ -47,7 +47,7 @@ spec = parallel $ do
       \ 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'))
@@ -132,7 +132,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