diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 2f0dfc7dc..29de031b7 100644 --- a/src/Interpreter.hs +++ b/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 diff --git a/src/Semantic.hs b/src/Semantic.hs index 388a6ebee..b66115fb6 100644 --- a/src/Semantic.hs +++ b/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) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 538238c28..1ca726dcf 100644 --- a/src/Semantic/Task.hs +++ b/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 diff --git a/test/DiffSpec.hs b/test/DiffSpec.hs index f2f531666..03330a681 100644 --- a/test/DiffSpec.hs +++ b/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 diff --git a/test/InterpreterSpec.hs b/test/InterpreterSpec.hs index 7ee205282..32d0827a2 100644 --- a/test/InterpreterSpec.hs +++ 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") ]) diff --git a/test/SemanticSpec.hs b/test/SemanticSpec.hs index 74166f726..456db2a1e 100644 --- a/test/SemanticSpec.hs +++ 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 diff --git a/test/TOCSpec.hs b/test/TOCSpec.hs index 98f47a0dd..bcf460478 100644 --- a/test/TOCSpec.hs +++ b/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