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) diff --git a/src/Diffing.hs b/src/Diffing.hs index 0382405fc..93d4526ca 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 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,14 +59,8 @@ 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 :: (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 @@ -93,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) $ diff --git a/src/Info.hs b/src/Info.hs index cbb7fa7cb..67adf177c 100644 --- a/src/Info.hs +++ b/src/Info.hs @@ -6,9 +6,6 @@ module Info , Category(..) , category , setCategory -, Cost(..) -, cost -, setCost , SourceSpan(..) , SourcePos(..) , SourceSpans(..) @@ -18,7 +15,6 @@ module Info , sourceText ) where -import Data.Functor.Listable import Data.Record import Prologue import Category @@ -26,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) @@ -44,12 +37,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 @@ -58,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/src/Interpreter.hs b/src/Interpreter.hs index 0196d3137..456435eeb 100644 --- a/src/Interpreter.hs +++ b/src/Interpreter.hs @@ -1,5 +1,5 @@ {-# LANGUAGE GADTs, RankNTypes #-} -module Interpreter (Comparable, DiffConstructor, diffTerms) where +module Interpreter (diffTerms) where import Algorithm import Data.Align.Generic @@ -12,47 +12,34 @@ import Diff import Info import Patch import Prologue hiding (lookup) -import SES import Syntax as S 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. - -> 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 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 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)) - => DiffConstructor (Syntax leaf) (Record fields) - -> Comparable (Syntax leaf) (Record fields) - -> SES.Cost (SyntaxDiff leaf fields) - -> SyntaxTerm leaf fields + => SyntaxTerm leaf fields -> SyntaxTerm leaf fields -> Maybe (SyntaxDiff leaf fields) -diffComparableTerms construct comparable cost = recur +diffComparableTerms = 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) + | (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 :: 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) -> @@ -89,7 +76,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 @@ -100,14 +87,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'. - -> SES.Cost (Free (CofreeF f (Both (Record fields))) (Patch (Cofree f (Record fields)))) -- ^ A function to compute the cost of a given diff node. + => (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 cost = 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 - SES as bs -> cont (ses recur cost as bs) RWS as bs -> cont (rws recur as bs) diff --git a/src/Parse.hs b/src/Parse.hs index 91d7831e4..e395a9440 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]) @@ -89,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 @@ -111,8 +104,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 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/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/Diff/Spec.hs b/test/Diff/Spec.hs index f9134d05f..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 wrap (==) diffCost 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 (==) diffCost (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 (==) diffCost (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 144c32dc2..b51a2e5b5 100644 --- a/test/DiffSummarySpec.hs +++ b/test/DiffSummarySpec.hs @@ -51,12 +51,12 @@ 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 term term) `shouldBe` [] 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 diff --git a/test/InterpreterSpec.hs b/test/InterpreterSpec.hs index 32b5626da..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 wrap compare diffCost (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 wrap compare diffCost (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 wrap compare diffCost 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 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 (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..17a7f9970 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 term term) `shouldBe` [] type Diff' = SyntaxDiff String '[Range, Category, SourceSpan] type Term' = SyntaxTerm String '[Range, Category, SourceSpan] @@ -157,23 +156,18 @@ 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) - (_, _) -> runBothWith (diffTerms construct compareCategoryEq diffCostWithCachedTermCosts) terms + (_, _) -> runBothWith diffTerms 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 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