From 01c47fa0c18b961335fbfb0b1026c37ee0fca71e Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 21 Feb 2017 14:34:24 -0500 Subject: [PATCH 01/12] :fire: the computation of costs. --- src/Diffing.hs | 17 ++--------------- src/Interpreter.hs | 13 ++++--------- test/Diff/Spec.hs | 6 +++--- test/DiffSummarySpec.hs | 2 +- test/InterpreterSpec.hs | 8 ++++---- test/TOCSpec.hs | 10 ++-------- 6 files changed, 16 insertions(+), 40 deletions(-) diff --git a/src/Diffing.hs b/src/Diffing.hs index 0382405fc..7753b3546 100644 --- a/src/Diffing.hs +++ b/src/Diffing.hs @@ -7,8 +7,6 @@ import Data.Functor.Both import Data.RandomWalkSimilarity (defaultFeatureVectorDecorator, stripDiff) import Data.Record import qualified Data.Text.IO as TextIO -import Data.These -import Diff import Info import Interpreter import Patch @@ -34,7 +32,7 @@ import Data.Aeson.Encoding (encodingToLazyByteString) -- | result. -- | Returns the rendered result strictly, so it's always fully evaluated -- | with respect to other IO actions. -diffFiles :: (HasField fields Category, HasField fields Cost) +diffFiles :: HasField fields Category => Parser (Syntax Text) (Record fields) -> Renderer (Record fields) -> Both SourceBlob @@ -48,14 +46,9 @@ diffFiles parse render sourceBlobs = do (True, False) -> pure $ Insert (snd terms) (False, True) -> pure $ Delete (fst terms) (_, _) -> - runBothWith (diffTerms construct compareCategoryEq diffCostWithCachedTermCosts) terms + runBothWith (diffTerms wrap compareCategoryEq) terms areNullOids a b = (hasNullOid a, hasNullOid b) hasNullOid blob = oid blob == nullOid || Source.null (source blob) - construct (info :< syntax) = free (Free ((setCost <$> info <*> sumCost syntax) :< syntax)) - sumCost = fmap getSum . foldMap (fmap Sum . getCost) - getCost diff = case runFree diff of - Free (info :< _) -> cost <$> info - Pure patch -> uncurry both (fromThese 0 0 (unPatch (cost . extract <$> patch))) getLabel :: HasField fields Category => CofreeF (Syntax leaf) (Record fields) b -> (Category, Maybe leaf) getLabel (h :< t) = (category h, case t of @@ -66,12 +59,6 @@ getLabel (h :< t) = (category h, case t of compareCategoryEq :: Functor f => HasField fields Category => Term f (Record fields) -> Term f (Record fields) -> Bool compareCategoryEq = (==) `on` category . extract --- | The sum of the node count of the diff’s patches. -diffCostWithCachedTermCosts :: Functor f => HasField fields Cost => Diff f (Record fields) -> Int -diffCostWithCachedTermCosts diff = unCost $ case runFree diff of - Free (info :< _) -> sum (cost <$> info) - Pure patch -> sum (cost . extract <$> patch) - -- | Returns a rendered diff given a parser, diff arguments and two source blobs. textDiff :: (ToJSON (Record fields), DefaultFields fields, HasField fields Cost) => Parser (Syntax Text) (Record fields) -> DiffArguments -> Both SourceBlob -> IO Output textDiff parser arguments = diffFiles parser $ case format arguments of diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 0196d3137..9cd746e01 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -12,7 +12,6 @@ import Diff import Info import Patch import Prologue hiding (lookup) -import SES import Syntax as S import Term @@ -26,24 +25,22 @@ type DiffConstructor f annotation = TermF f (Both annotation) (Diff f annotation diffTerms :: (Eq leaf, HasField fields Category, HasField fields (Maybe FeatureVector)) => DiffConstructor (Syntax leaf) (Record fields) -- ^ A function to wrap up & possibly annotate every produced diff. -> Comparable (Syntax leaf) (Record fields) -- ^ A function to determine whether or not two terms should even be compared. - -> SES.Cost (SyntaxDiff leaf fields) -- ^ A function to compute the cost of a given diff node. -> SyntaxTerm leaf fields -- ^ A term representing the old state. -> SyntaxTerm leaf fields -- ^ A term representing the new state. -> SyntaxDiff leaf fields -diffTerms construct comparable cost a b = fromMaybe (replacing a b) $ diffComparableTerms construct comparable cost a b +diffTerms construct comparable a b = fromMaybe (replacing a b) $ diffComparableTerms construct comparable 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)) => DiffConstructor (Syntax leaf) (Record fields) -> Comparable (Syntax leaf) (Record fields) - -> SES.Cost (SyntaxDiff leaf fields) -> SyntaxTerm leaf fields -> SyntaxTerm leaf fields -> Maybe (SyntaxDiff leaf fields) -diffComparableTerms construct comparable cost = recur +diffComparableTerms construct comparable = recur where recur a b | (category <$> a) == (category <$> b) = hylo construct runCofree <$> zipTerms a b - | comparable a b = runAlgorithm construct recur cost (Just <$> algorithmWithTerms construct a b) + | comparable a b = runAlgorithm construct recur (Just <$> algorithmWithTerms construct a b) | otherwise = Nothing -- | Construct an algorithm to diff a pair of terms. @@ -102,12 +99,10 @@ algorithmWithTerms construct t1 t2 = maybe (linearly t1 t2) (fmap annotate) $ ca runAlgorithm :: (GAlign f, HasField fields Category, Eq (f (Cofree f Category)), Traversable f, HasField fields (Maybe FeatureVector)) => (CofreeF f (Both (Record fields)) (Free (CofreeF f (Both (Record fields))) (Patch (Cofree f (Record fields)))) -> Free (CofreeF f (Both (Record fields))) (Patch (Cofree f (Record fields)))) -- ^ A function to wrap up & possibly annotate every produced diff. -> (Cofree f (Record fields) -> Cofree f (Record fields) -> Maybe (Free (CofreeF f (Both (Record fields))) (Patch (Cofree f (Record fields))))) -- ^ A function to diff two subterms recursively, if they are comparable, or else return 'Nothing'. - -> SES.Cost (Free (CofreeF f (Both (Record fields))) (Patch (Cofree f (Record fields)))) -- ^ A function to compute the cost of a given diff node. -> Algorithm (Cofree f (Record fields)) (Free (CofreeF f (Both (Record fields))) (Patch (Cofree f (Record fields)))) a -- ^ The algorithm to run. -> a -runAlgorithm construct recur cost = iterAp $ \ r cont -> case r of +runAlgorithm construct recur = iterAp $ \ r cont -> case r of Linear a b -> cont . maybe (replacing a b) (construct . (both (extract a) (extract b) :<)) $ do aligned <- galign (unwrap a) (unwrap b) traverse (these (Just . deleting) (Just . inserting) recur) aligned - SES as bs -> cont (ses recur cost as bs) RWS as bs -> cont (rws recur as bs) diff --git a/test/Diff/Spec.hs b/test/Diff/Spec.hs index f9134d05f..c78c97199 100644 --- a/test/Diff/Spec.hs +++ b/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 wrap (==) diffCost term term) `shouldBe` 0 + diffCost (diffTerms wrap (==) term term) `shouldBe` 0 describe "beforeTerm" $ do prop "recovers the before term" $ - \ a b -> let diff = stripDiff $ diffTerms wrap (==) diffCost (decorate (unListableF a)) (decorate (unListableF b :: SyntaxTerm String '[Category])) in + \ a b -> let diff = stripDiff $ diffTerms wrap (==) (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 wrap (==) diffCost (decorate (unListableF a)) (decorate (unListableF b :: SyntaxTerm String '[Category])) in + \ a b -> let diff = stripDiff $ diffTerms wrap (==) (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 diff --git a/test/DiffSummarySpec.hs b/test/DiffSummarySpec.hs index 144c32dc2..16a188db1 100644 --- a/test/DiffSummarySpec.hs +++ b/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 wrap (==) diffCost term term) `shouldBe` [] + diffSummaries blobs (diffTerms wrap (==) term term) `shouldBe` [] describe "DiffInfo" $ do prop "patches in summaries match the patches in diffs" $ diff --git a/test/InterpreterSpec.hs b/test/InterpreterSpec.hs index 32b5626da..2843935fe 100644 --- a/test/InterpreterSpec.hs +++ b/test/InterpreterSpec.hs @@ -27,18 +27,18 @@ spec = parallel $ do 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 wrap compare diffCost (decorate termA) (decorate termB)) `shouldBe` replacing termA termB + stripDiff (diffTerms wrap compare (decorate termA) (decorate termB)) `shouldBe` replacing termA termB prop "produces correct diffs" $ - \ a b -> let diff = stripDiff $ diffTerms wrap compare diffCost (decorate (unListableF a)) (decorate (unListableF b :: SyntaxTerm String '[Category])) in + \ a b -> let diff = stripDiff $ diffTerms wrap compare (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 wrap compare diffCost term term in + diff = diffTerms wrap compare 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 wrap compare diffCost (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 wrap 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"))) ]) diff --git a/test/TOCSpec.hs b/test/TOCSpec.hs index e4638ea94..1a5cee079 100644 --- a/test/TOCSpec.hs +++ b/test/TOCSpec.hs @@ -6,7 +6,6 @@ import Data.Functor.Both import Data.Functor.Listable import Data.RandomWalkSimilarity import Data.Record -import Data.These import Data.String import Diff import Diffing @@ -95,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 wrap (==) diffCost term term) `shouldBe` [] + diffTOC blankDiffBlobs (diffTerms wrap (==) term term) `shouldBe` [] type Diff' = SyntaxDiff String '[Range, Category, SourceSpan] type Term' = SyntaxTerm String '[Range, Category, SourceSpan] @@ -166,14 +165,9 @@ 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 construct compareCategoryEq diffCostWithCachedTermCosts) terms + (_, _) -> runBothWith (diffTerms wrap compareCategoryEq) terms areNullOids a b = (hasNullOid a, hasNullOid b) hasNullOid blob = oid blob == nullOid || Source.null (source blob) - construct (info :< syntax) = free (Free ((setCost <$> info <*> sumCost syntax) :< syntax)) - sumCost = fmap getSum . foldMap (fmap Sum . getCost) - getCost diff = case runFree diff of - Free (info :< _) -> cost <$> info - Pure patch -> uncurry both (fromThese 0 0 (unPatch (cost . extract <$> patch))) blobsForPaths :: Both FilePath -> IO (Both SourceBlob) blobsForPaths paths = do From cc776a2f6dfe87cff682b7252368ee264a1c8a8c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 21 Feb 2017 14:35:22 -0500 Subject: [PATCH 02/12] :fire: SES algorithms. --- src/Algorithm.hs | 6 ------ 1 file changed, 6 deletions(-) diff --git a/src/Algorithm.hs b/src/Algorithm.hs index 568ad8961..249616fe7 100644 --- a/src/Algorithm.hs +++ b/src/Algorithm.hs @@ -8,8 +8,6 @@ import Prologue hiding (Pure) data AlgorithmF term diff result where -- | Diff two terms recursively in O(n) time, resulting in a single diff node. Linear :: term -> term -> AlgorithmF term diff diff - -- | Diff two lists of terms by each element’s position in O(n³) time, resulting in a list of diffs. - SES :: [term] -> [term] -> AlgorithmF term diff [diff] -- | 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] @@ -29,10 +27,6 @@ iterAp algebra = go linearly :: term -> term -> Algorithm term diff diff linearly a b = liftAp (Linear a b) --- | Diff two terms using SES. -bySES :: [term] -> [term] -> Algorithm term diff [diff] -bySES a b = liftAp (SES a b) - -- | Diff two terms using RWS. byRWS :: [term] -> [term] -> Algorithm term diff [diff] byRWS a b = liftAp (RWS a b) From 67b162895ce6c31ffd0fa4870788eca63ef8c4ea Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 21 Feb 2017 14:48:03 -0500 Subject: [PATCH 03/12] :fire: costs from Split output. --- src/Renderer/Split.hs | 8 +++----- test/diffs/dictionary.split.js | 4 ++-- test/diffs/insert.split.js | 2 +- test/diffs/multiline-insert.split.js | 6 +++--- test/diffs/nested-insert.split.js | 2 +- test/diffs/newline-at-eof.split.js | 2 +- test/diffs/no-newline-at-eof.split.js | 2 +- 7 files changed, 12 insertions(+), 14 deletions(-) diff --git a/src/Renderer/Split.hs b/src/Renderer/Split.hs index 81bbfdea6..e104ceb1c 100644 --- a/src/Renderer/Split.hs +++ b/src/Renderer/Split.hs @@ -158,7 +158,7 @@ splitPatchToClassName patch = stringValue $ "patch " <> case patch of SplitReplace _ -> "replace" -- | Render a diff as an HTML split diff. -split :: (HasField fields Category, HasField fields Cost, HasField fields Range) => Renderer (Record fields) +split :: (HasField fields Category, HasField fields Range) => Renderer (Record fields) split blobs diff = SplitOutput . TL.toStrict . renderHtml . docTypeHtml . ((head $ link ! A.rel "stylesheet" ! A.href "style.css") <>) @@ -220,13 +220,11 @@ instance (ToMarkup f, HasField fields Category, HasField fields Range) => ToMark instance (HasField fields Category, HasField fields Range) => ToMarkup (Renderable (SyntaxTerm leaf fields)) where toMarkup (Renderable source term) = Prologue.fst $ cata (\ t -> (toMarkup $ Renderable source t, byteRange (headF t))) term -instance (HasField fields Category, HasField fields Cost, HasField fields Range) => ToMarkup (Renderable (SplitSyntaxDiff leaf fields)) where +instance (HasField fields Category, HasField fields Range) => ToMarkup (Renderable (SplitSyntaxDiff leaf fields)) where toMarkup (Renderable source diff) = Prologue.fst . iter (\ t -> (toMarkup $ Renderable source t, byteRange (headF t))) $ toMarkupAndRange <$> diff where toMarkupAndRange patch = let term@(info :< _) = runCofree $ getSplitTerm patch in - ((div ! patchAttribute patch `withCostAttribute` cost info) . toMarkup $ Renderable source (cofree term), byteRange info) + ((div ! patchAttribute patch) . toMarkup $ Renderable source (cofree term), byteRange info) patchAttribute patch = A.class_ (splitPatchToClassName patch) - withCostAttribute a (Cost c) | c > 0 = a ! A.data_ (stringValue (show c)) - | otherwise = identity instance ToMarkup a => ToMarkup (Cell a) where toMarkup (Cell hasChanges num line) diff --git a/test/diffs/dictionary.split.js b/test/diffs/dictionary.split.js index a2e6497e3..698982c5b 100644 --- a/test/diffs/dictionary.split.js +++ b/test/diffs/dictionary.split.js @@ -4,9 +4,9 @@ 1
      • {
-2
        • "b"
          • :
        • 4
        • , +2
              • "b"
                • :
              • 4
              • ,
        -2
              • "b"
                • :
              • 5
              • , +2
                    • "b"
                      • :
                    • 5
                    • ,
              3
                    • "a"
                      • :
                    • 5
                    • diff --git a/test/diffs/insert.split.js b/test/diffs/insert.split.js index 4b247c35f..20d0d1bb5 100644 --- a/test/diffs/insert.split.js +++ b/test/diffs/insert.split.js @@ -5,7 +5,7 @@
                  -2
                      • console
                        • .
                      • log
                        • (
                      • 'world'
                        • )
                      • ;
                    • +2
                        • console
                          • .
                        • log
                          • (
                        • 'world'
                          • )
                        • ;
                    2
                      diff --git a/test/diffs/multiline-insert.split.js b/test/diffs/multiline-insert.split.js index d3e951207..70cdf91f9 100644 --- a/test/diffs/multiline-insert.split.js +++ b/test/diffs/multiline-insert.split.js @@ -5,15 +5,15 @@
                    -2
                      • if (
                      • true
                        • )
                        • { +2
                            • if (
                            • true
                              • )
                              • {
                          -3
                                  • console
                                    • .
                                  • log
                                    • (
                                  • 'cruel'
                                    • )
                                  • ;
                                • +3
                                        • console
                                          • .
                                        • log
                                          • (
                                        • 'cruel'
                                          • )
                                        • ;
                                -4
                                    • }
                                  • +4
                                      • }
                                  2
                                      • console
                                        • .
                                      • log
                                        • (
                                      • 'world'
                                        • )
                                      • ;
                                    • diff --git a/test/diffs/nested-insert.split.js b/test/diffs/nested-insert.split.js index 98fffccd4..c15c67c90 100644 --- a/test/diffs/nested-insert.split.js +++ b/test/diffs/nested-insert.split.js @@ -10,7 +10,7 @@
                              -3
                                      • console
                                        • .
                                      • log
                                        • (
                                      • 'world'
                                        • )
                                      • ;
                                    • +3
                                            • console
                                              • .
                                            • log
                                              • (
                                            • 'world'
                                              • )
                                            • ;
                                    3
                                        • }
                                      • diff --git a/test/diffs/newline-at-eof.split.js b/test/diffs/newline-at-eof.split.js index 8415e6b28..499ac877c 100644 --- a/test/diffs/newline-at-eof.split.js +++ b/test/diffs/newline-at-eof.split.js @@ -9,7 +9,7 @@
                                    -3
                                        • console
                                          • .
                                        • log
                                          • (
                                        • "insertion"
                                          • )
                                        • ;
                                      • +3
                                          • console
                                            • .
                                          • log
                                            • (
                                          • "insertion"
                                            • )
                                          • ;
                                      diff --git a/test/diffs/no-newline-at-eof.split.js b/test/diffs/no-newline-at-eof.split.js index 1e0778e6a..e673f63c1 100644 --- a/test/diffs/no-newline-at-eof.split.js +++ b/test/diffs/no-newline-at-eof.split.js @@ -8,6 +8,6 @@
                                    -3
                                        • console
                                          • .
                                        • log
                                          • (
                                        • "insertion"
                                          • )
                                        • ;
                                    +3
                                        • console
                                          • .
                                        • log
                                          • (
                                        • "insertion"
                                          • )
                                        • ;
                                    \ No newline at end of file From 7f2b2746689ba38bdebb2d54910ed2a1d308d18f Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 21 Feb 2017 14:49:22 -0500 Subject: [PATCH 04/12] Diffing does not require the presence of a Cost field. --- src/Diffing.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Diffing.hs b/src/Diffing.hs index 7753b3546..36ef53cef 100644 --- a/src/Diffing.hs +++ b/src/Diffing.hs @@ -60,7 +60,7 @@ compareCategoryEq :: Functor f => HasField fields Category => Term f (Record fie compareCategoryEq = (==) `on` category . extract -- | Returns a rendered diff given a parser, diff arguments and two source blobs. -textDiff :: (ToJSON (Record fields), DefaultFields fields, HasField fields Cost) => Parser (Syntax Text) (Record fields) -> DiffArguments -> Both SourceBlob -> IO Output +textDiff :: (ToJSON (Record fields), DefaultFields fields) => Parser (Syntax Text) (Record fields) -> DiffArguments -> Both SourceBlob -> IO Output textDiff parser arguments = diffFiles parser $ case format arguments of Split -> split Patch -> patch @@ -80,7 +80,7 @@ truncatedDiff arguments sources = pure $ case format arguments of TOC -> TOCOutput mempty -- | Prints a rendered diff to stdio or a filepath given a parser, diff arguments and two source blobs. -printDiff :: (ToJSON (Record fields), DefaultFields fields, HasField fields Cost) => Parser (Syntax Text) (Record fields) -> DiffArguments -> Both SourceBlob -> IO () +printDiff :: (ToJSON (Record fields), DefaultFields fields) => Parser (Syntax Text) (Record fields) -> DiffArguments -> Both SourceBlob -> IO () printDiff parser arguments sources = do rendered <- textDiff parser arguments sources writeToOutput (output arguments) $ From d90957c4bad8d9dff2644c7f6b2e3e41511b8649 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 21 Feb 2017 14:52:17 -0500 Subject: [PATCH 05/12] parserForFilepath does not decorate with Cost. --- src/Parse.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/Parse.hs b/src/Parse.hs index 91d7831e4..5a58de886 100644 --- a/src/Parse.hs +++ b/src/Parse.hs @@ -111,8 +111,8 @@ lineByLineParser SourceBlob{..} = pure . cofree . root $ case foldl' annotateLea (accum <> [ leaf charIndex (Source.toText line) ] , charIndex + Source.length line) -- | Return the parser that should be used for a given path. -parserForFilepath :: FilePath -> Parser (Syntax Text) (Record '[Cost, Range, Category, SourceSpan]) -parserForFilepath path blob = decorateTerm termCostDecorator <$> parserForType (toS (takeExtension path)) blob +parserForFilepath :: FilePath -> Parser (Syntax Text) (Record '[Range, Category, SourceSpan]) +parserForFilepath = parserForType . toS . takeExtension -- | Read the file and convert it to Unicode. readAndTranscodeFile :: FilePath -> IO Source From 652607605671089a5db83438e11dfe0e636e1813 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 21 Feb 2017 14:53:42 -0500 Subject: [PATCH 06/12] =?UTF-8?q?Don=E2=80=99t=20decorate=20terms=20with?= =?UTF-8?q?=20costs.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- src/SemanticDiff.hs | 4 ++-- test/CorpusSpec.hs | 4 ++-- test/TOCSpec.hs | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/src/SemanticDiff.hs b/src/SemanticDiff.hs index 3f9c81968..33f51a723 100644 --- a/src/SemanticDiff.hs +++ b/src/SemanticDiff.hs @@ -88,7 +88,7 @@ diffPaths :: Arguments -> Both FilePath -> IO () diffPaths args@Arguments{..} paths = do sources <- sequence $ readAndTranscodeFile <$> paths let sourceBlobs = Source.SourceBlob <$> sources <*> pure mempty <*> paths <*> pure (Just Source.defaultPlainBlob) - D.printDiff (parserWithCost (fst paths)) (diffArgs args) sourceBlobs + D.printDiff (parserForFilepath (fst paths)) (diffArgs args) sourceBlobs where diffArgs Arguments{..} = R.DiffArguments { format = format, output = output } @@ -113,7 +113,7 @@ fetchDiff' Arguments{..} filepath = do let sources = fromMaybe (Source.emptySourceBlob filepath) <$> sourcesAndOids let sourceBlobs = Source.idOrEmptySourceBlob <$> sources - let textDiff = D.textDiff (parserWithCost filepath) diffArguments sourceBlobs + let textDiff = D.textDiff (parserForFilepath filepath) diffArguments sourceBlobs text <- fetchText textDiff truncatedPatch <- liftIO $ D.truncatedDiff diffArguments sourceBlobs diff --git a/test/CorpusSpec.hs b/test/CorpusSpec.hs index b3e0b4223..c8c18c566 100644 --- a/test/CorpusSpec.hs +++ b/test/CorpusSpec.hs @@ -75,7 +75,7 @@ normalizeName path = addExtension (dropExtension $ dropExtension path) (takeExte -- | Given file paths for A, B, and, optionally, a diff, return whether diffing -- | the files will produce the diff. If no diff is provided, then the result -- | is true, but the diff will still be calculated. -testDiff :: Renderer (Record '[Cost, Range, Category, SourceSpan]) -> Both (Maybe FilePath) -> Maybe FilePath -> (Maybe Verbatim -> Maybe Verbatim -> Expectation) -> Expectation +testDiff :: Renderer (Record '[Range, Category, SourceSpan]) -> Both (Maybe FilePath) -> Maybe FilePath -> (Maybe Verbatim -> Maybe Verbatim -> Expectation) -> Expectation testDiff renderer paths diff matcher = do sources <- traverse (traverse readAndTranscodeFile) paths actual <- fmap Verbatim <$> traverse ((pure . concatOutputs . pure) <=< diffFiles' sources) parser @@ -85,7 +85,7 @@ testDiff renderer paths diff matcher = do expected <- Verbatim <$> readFile file matcher actual (Just expected) where diffFiles' sources parser = diffFiles parser renderer (sourceBlobs sources paths) - parser = parserWithCost <$> runBothWith (<|>) paths + parser = parserForFilepath <$> runBothWith (<|>) paths sourceBlobs :: Both (Maybe (S.Source)) -> Both (Maybe FilePath) -> Both S.SourceBlob sourceBlobs sources paths = case runJoin paths of (Nothing, Nothing) -> Join (S.emptySourceBlob "", S.emptySourceBlob "") diff --git a/test/TOCSpec.hs b/test/TOCSpec.hs index 1a5cee079..45085d6c1 100644 --- a/test/TOCSpec.hs +++ b/test/TOCSpec.hs @@ -156,12 +156,12 @@ isMethodOrFunction a = case runCofree (unListableF a) of (_ :< S.Function{}) -> True _ -> False -testDiff :: Both SourceBlob -> IO (Diff (Syntax Text) (Record '[Cost, Range, Category, SourceSpan])) +testDiff :: Both SourceBlob -> IO (Diff (Syntax Text) (Record '[Range, Category, SourceSpan])) testDiff sourceBlobs = do terms <- traverse (fmap (defaultFeatureVectorDecorator getLabel) . parser) sourceBlobs pure $! stripDiff (diffTerms' terms sourceBlobs) where - parser = parserWithCost (path . fst $ sourceBlobs) + parser = parserForFilepath (path . fst $ sourceBlobs) diffTerms' terms blobs = case runBothWith areNullOids blobs of (True, False) -> pure $ Insert (snd terms) (False, True) -> pure $ Delete (fst terms) From 7be2232bb6ee84e650d270090feb4ef137ccb9fc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 21 Feb 2017 14:54:23 -0500 Subject: [PATCH 07/12] :fire: parserWithCost. --- src/Parse.hs | 3 --- 1 file changed, 3 deletions(-) diff --git a/src/Parse.hs b/src/Parse.hs index 5a58de886..24a792bd8 100644 --- a/src/Parse.hs +++ b/src/Parse.hs @@ -64,9 +64,6 @@ run Arguments{..} = do Nothing -> for_ text putStrLn Just path -> for_ text (T.writeFile path) --- | Return a parser that decorates with the cost of a term and its children. -parserWithCost :: FilePath -> Parser (Syntax Text) (Record '[Cost, Range, Category, SourceSpan]) -parserWithCost path blob = decorateTerm termCostDecorator <$> parserForType (toS (takeExtension path)) blob -- | Return a parser that decorates with the source text. parserWithSource :: FilePath -> Parser (Syntax Text) (Record '[SourceText, Range, Category, SourceSpan]) From a7d73e9bf1278ea00da325fdc8c1819a1e1e379c Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 21 Feb 2017 14:54:54 -0500 Subject: [PATCH 08/12] :fire: termCostDecorator. --- src/Parse.hs | 4 ---- 1 file changed, 4 deletions(-) diff --git a/src/Parse.hs b/src/Parse.hs index 24a792bd8..e395a9440 100644 --- a/src/Parse.hs +++ b/src/Parse.hs @@ -86,10 +86,6 @@ decorateTerm decorator = cata $ \ term -> cofree ((decorator (extract <$> term) -- | A function computing a value to decorate terms with. This can be used to cache synthesized attributes on terms. type TermDecorator f fields field = TermF f (Record fields) (Record (field ': fields)) -> field --- | Term decorator computing the cost of an unpacked term. -termCostDecorator :: (Foldable f, Functor f) => TermDecorator f a Cost -termCostDecorator c = 1 + sum (cost <$> tailF c) - -- | Term decorator extracting the source text for a term. termSourceDecorator :: (HasField fields Range) => Source -> TermDecorator f fields SourceText termSourceDecorator source c = SourceText . toText $ Source.slice range' source From d288ec1d1796237b54a03c954461e72d77007957 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 21 Feb 2017 14:56:34 -0500 Subject: [PATCH 09/12] :fire: cost & setCost. --- src/Info.hs | 8 -------- 1 file changed, 8 deletions(-) diff --git a/src/Info.hs b/src/Info.hs index cbb7fa7cb..0b27950a0 100644 --- a/src/Info.hs +++ b/src/Info.hs @@ -7,8 +7,6 @@ module Info , category , setCategory , Cost(..) -, cost -, setCost , SourceSpan(..) , SourcePos(..) , SourceSpans(..) @@ -44,12 +42,6 @@ category = getField setCategory :: HasField fields Category => Record fields -> Category -> Record fields setCategory = setField -cost :: HasField fields Cost => Record fields -> Cost -cost = getField - -setCost :: HasField fields Cost => Record fields -> Cost -> Record fields -setCost = setField - sourceText :: HasField fields SourceText => Record fields -> SourceText sourceText = getField From 04b929822e4e42cb8c82e20c3eec53cb9fe2e5ad Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 21 Feb 2017 14:58:39 -0500 Subject: [PATCH 10/12] :fire: Cost. --- src/Info.hs | 10 ---------- test/DiffSummarySpec.hs | 2 +- 2 files changed, 1 insertion(+), 11 deletions(-) diff --git a/src/Info.hs b/src/Info.hs index 0b27950a0..67adf177c 100644 --- a/src/Info.hs +++ b/src/Info.hs @@ -6,7 +6,6 @@ module Info , Category(..) , category , setCategory -, Cost(..) , SourceSpan(..) , SourcePos(..) , SourceSpans(..) @@ -16,7 +15,6 @@ module Info , sourceText ) where -import Data.Functor.Listable import Data.Record import Prologue import Category @@ -24,9 +22,6 @@ import Range import SourceSpan import Data.Aeson -newtype Cost = Cost { unCost :: Int } - deriving (Eq, Num, Ord, Show, ToJSON) - newtype SourceText = SourceText { unText :: Text } deriving (Show, ToJSON) @@ -50,8 +45,3 @@ sourceSpan = getField setSourceSpan :: HasField fields SourceSpan => Record fields -> SourceSpan -> Record fields setSourceSpan = setField - --- Instances - -instance Listable Cost where - tiers = cons1 Cost diff --git a/test/DiffSummarySpec.hs b/test/DiffSummarySpec.hs index 16a188db1..82c0e9ca0 100644 --- a/test/DiffSummarySpec.hs +++ b/test/DiffSummarySpec.hs @@ -56,7 +56,7 @@ spec = parallel $ do describe "DiffInfo" $ do prop "patches in summaries match the patches in diffs" $ \a -> let - diff = unListableDiff a :: SyntaxDiff String '[Category, Cost, Range, SourceSpan] + diff = unListableDiff a :: SyntaxDiff String '[Category, Range, SourceSpan] summaries = diffToDiffSummaries (source <$> blobs) diff patches = toList diff in From c4f37454d6e52b30352ba0f984a53950fe84e0b5 Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 21 Feb 2017 15:17:35 -0500 Subject: [PATCH 11/12] :fire: the construct parameter to diffTerms. --- src/Diffing.hs | 2 +- src/Interpreter.hs | 35 ++++++++++++++--------------------- test/Diff/Spec.hs | 6 +++--- test/DiffSummarySpec.hs | 2 +- test/InterpreterSpec.hs | 8 ++++---- test/TOCSpec.hs | 4 ++-- 6 files changed, 25 insertions(+), 32 deletions(-) diff --git a/src/Diffing.hs b/src/Diffing.hs index 36ef53cef..bc5b5783b 100644 --- a/src/Diffing.hs +++ b/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 wrap compareCategoryEq) terms + runBothWith (diffTerms compareCategoryEq) terms areNullOids a b = (hasNullOid a, hasNullOid b) hasNullOid blob = oid blob == nullOid || Source.null (source blob) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index 9cd746e01..dd2095f20 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -1,5 +1,5 @@ {-# LANGUAGE GADTs, RankNTypes #-} -module Interpreter (Comparable, DiffConstructor, diffTerms) where +module Interpreter (Comparable, diffTerms) where import Algorithm import Data.Align.Generic @@ -18,38 +18,32 @@ import Term -- | Returns whether two terms are comparable type Comparable f annotation = Term f annotation -> Term f annotation -> Bool --- | Constructs a diff from the CofreeF containing its annotation and syntax. This function has the opportunity to, for example, cache properties in the annotation. -type DiffConstructor f annotation = TermF f (Both annotation) (Diff f annotation) -> Diff f annotation - -- | Diff two terms recursively, given functions characterizing the diffing. diffTerms :: (Eq leaf, HasField fields Category, HasField fields (Maybe FeatureVector)) - => DiffConstructor (Syntax leaf) (Record fields) -- ^ A function to wrap up & possibly annotate every produced diff. - -> Comparable (Syntax leaf) (Record fields) -- ^ A function to determine whether or not two terms should even be compared. + => 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 new state. -> SyntaxDiff leaf fields -diffTerms construct comparable a b = fromMaybe (replacing a b) $ diffComparableTerms construct comparable a b +diffTerms comparable a b = fromMaybe (replacing a b) $ diffComparableTerms comparable 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)) - => DiffConstructor (Syntax leaf) (Record fields) - -> Comparable (Syntax leaf) (Record fields) + => Comparable (Syntax leaf) (Record fields) -> SyntaxTerm leaf fields -> SyntaxTerm leaf fields -> Maybe (SyntaxDiff leaf fields) -diffComparableTerms construct comparable = recur +diffComparableTerms comparable = recur where recur a b - | (category <$> a) == (category <$> b) = hylo construct runCofree <$> zipTerms a b - | comparable a b = runAlgorithm construct recur (Just <$> algorithmWithTerms construct a b) + | (category <$> a) == (category <$> b) = hylo wrap runCofree <$> zipTerms a b + | comparable a b = runAlgorithm recur (Just <$> algorithmWithTerms a b) | otherwise = Nothing -- | Construct an algorithm to diff a pair of terms. -algorithmWithTerms :: Applicative diff - => (TermF (Syntax leaf) (Both a) (diff (Patch (Term (Syntax leaf) a))) -> diff (Patch (Term (Syntax leaf) a))) - -> Term (Syntax leaf) a +algorithmWithTerms :: MonadFree (TermF (Syntax leaf) (Both a)) diff + => Term (Syntax leaf) a -> Term (Syntax leaf) a -> Algorithm (Term (Syntax leaf) a) (diff (Patch (Term (Syntax leaf) a))) (diff (Patch (Term (Syntax leaf) a))) -algorithmWithTerms construct t1 t2 = maybe (linearly t1 t2) (fmap annotate) $ case (unwrap t1, unwrap t2) of +algorithmWithTerms t1 t2 = maybe (linearly t1 t2) (fmap annotate) $ case (unwrap t1, unwrap t2) of (Indexed a, Indexed b) -> Just $ Indexed <$> byRWS a b (S.Module idA a, S.Module idB b) -> @@ -86,7 +80,7 @@ algorithmWithTerms construct t1 t2 = maybe (linearly t1 t2) (fmap annotate) $ ca <*> byRWS bodyA bodyB _ -> Nothing where - annotate = construct . (both (extract t1) (extract t2) :<) + annotate = wrap . (both (extract t1) (extract t2) :<) maybeLinearly :: Applicative f => Maybe a -> Maybe a -> Algorithm a (f (Patch a)) (Maybe (f (Patch a))) maybeLinearly a b = sequenceA $ case (a, b) of @@ -97,12 +91,11 @@ algorithmWithTerms construct t1 t2 = maybe (linearly t1 t2) (fmap annotate) $ ca -- | Run an algorithm, given functions characterizing the evaluation. runAlgorithm :: (GAlign f, HasField fields Category, Eq (f (Cofree f Category)), Traversable f, HasField fields (Maybe FeatureVector)) - => (CofreeF f (Both (Record fields)) (Free (CofreeF f (Both (Record fields))) (Patch (Cofree f (Record fields)))) -> Free (CofreeF f (Both (Record fields))) (Patch (Cofree f (Record fields)))) -- ^ A function to wrap up & possibly annotate every produced diff. - -> (Cofree f (Record fields) -> Cofree f (Record fields) -> Maybe (Free (CofreeF f (Both (Record fields))) (Patch (Cofree f (Record fields))))) -- ^ A function to diff two subterms recursively, if they are comparable, or else return 'Nothing'. + => (Cofree f (Record fields) -> Cofree f (Record fields) -> Maybe (Free (CofreeF f (Both (Record fields))) (Patch (Cofree f (Record fields))))) -- ^ A function to diff two subterms recursively, if they are comparable, or else return 'Nothing'. -> Algorithm (Cofree f (Record fields)) (Free (CofreeF f (Both (Record fields))) (Patch (Cofree f (Record fields)))) a -- ^ The algorithm to run. -> a -runAlgorithm construct recur = iterAp $ \ r cont -> case r of - Linear a b -> cont . maybe (replacing a b) (construct . (both (extract a) (extract b) :<)) $ do +runAlgorithm recur = iterAp $ \ r cont -> case r of + Linear a b -> cont . maybe (replacing a b) (wrap . (both (extract a) (extract b) :<)) $ do aligned <- galign (unwrap a) (unwrap b) traverse (these (Just . deleting) (Just . inserting) recur) aligned RWS as bs -> cont (rws recur as bs) diff --git a/test/Diff/Spec.hs b/test/Diff/Spec.hs index c78c97199..d39cbacef 100644 --- a/test/Diff/Spec.hs +++ b/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 wrap (==) term term) `shouldBe` 0 + diffCost (diffTerms (==) term term) `shouldBe` 0 describe "beforeTerm" $ do prop "recovers the before term" $ - \ a b -> let diff = stripDiff $ diffTerms wrap (==) (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 wrap (==) (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 diff --git a/test/DiffSummarySpec.hs b/test/DiffSummarySpec.hs index 82c0e9ca0..af49a788f 100644 --- a/test/DiffSummarySpec.hs +++ b/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 wrap (==) term term) `shouldBe` [] + diffSummaries blobs (diffTerms (==) term term) `shouldBe` [] describe "DiffInfo" $ do prop "patches in summaries match the patches in diffs" $ diff --git a/test/InterpreterSpec.hs b/test/InterpreterSpec.hs index 2843935fe..c57753005 100644 --- a/test/InterpreterSpec.hs +++ b/test/InterpreterSpec.hs @@ -27,18 +27,18 @@ spec = parallel $ do 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 wrap compare (decorate termA) (decorate termB)) `shouldBe` replacing termA termB + stripDiff (diffTerms compare (decorate termA) (decorate termB)) `shouldBe` replacing termA termB prop "produces correct diffs" $ - \ a b -> let diff = stripDiff $ diffTerms wrap compare (decorate (unListableF a)) (decorate (unListableF b :: SyntaxTerm String '[Category])) in + \ a b -> let diff = stripDiff $ diffTerms compare (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 wrap compare term term in + diff = diffTerms compare 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 wrap 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 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"))) ]) diff --git a/test/TOCSpec.hs b/test/TOCSpec.hs index 45085d6c1..bfcefe7a3 100644 --- a/test/TOCSpec.hs +++ 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 wrap (==) 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 wrap compareCategoryEq) terms + (_, _) -> runBothWith (diffTerms compareCategoryEq) terms areNullOids a b = (hasNullOid a, hasNullOid b) hasNullOid blob = oid blob == nullOid || Source.null (source blob) From fe326bcf039527173d6734736c8d99637dca3bcc Mon Sep 17 00:00:00 2001 From: Rob Rix Date: Tue, 21 Feb 2017 15:23:30 -0500 Subject: [PATCH 12/12] :fire: the comparability parameter to diffTerms. --- src/Diffing.hs | 2 +- src/Interpreter.hs | 16 ++++++---------- test/Diff/Spec.hs | 6 +++--- test/DiffSummarySpec.hs | 2 +- test/InterpreterSpec.hs | 9 ++++----- test/TOCSpec.hs | 4 ++-- 6 files changed, 17 insertions(+), 22 deletions(-) diff --git a/src/Diffing.hs b/src/Diffing.hs index bc5b5783b..93d4526ca 100644 --- a/src/Diffing.hs +++ b/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) diff --git a/src/Interpreter.hs b/src/Interpreter.hs index dd2095f20..456435eeb 100644 --- a/src/Interpreter.hs +++ b/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 diff --git a/test/Diff/Spec.hs b/test/Diff/Spec.hs index d39cbacef..4fb25d1f5 100644 --- a/test/Diff/Spec.hs +++ b/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 diff --git a/test/DiffSummarySpec.hs b/test/DiffSummarySpec.hs index af49a788f..b51a2e5b5 100644 --- a/test/DiffSummarySpec.hs +++ b/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" $ diff --git a/test/InterpreterSpec.hs b/test/InterpreterSpec.hs index c57753005..696862973 100644 --- a/test/InterpreterSpec.hs +++ b/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"))) ]) diff --git a/test/TOCSpec.hs b/test/TOCSpec.hs index bfcefe7a3..17a7f9970 100644 --- a/test/TOCSpec.hs +++ 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)