diff --git a/src/Data/Location.hs b/src/Data/Location.hs index 3fac16081..e71646ab6 100644 --- a/src/Data/Location.hs +++ b/src/Data/Location.hs @@ -2,12 +2,15 @@ module Data.Location ( Location(..) , Span(..) , Range(..) + , DiffAnnotation ) where import Data.JSON.Fields import Data.Range import Data.Span +type DiffAnnotation a = (a, Location) + -- | A location specified as possibly-empty intervals of bytes and line/column positions. -- type Location = '[Range, Span] diff --git a/src/Diffing/Algorithm/RWS.hs b/src/Diffing/Algorithm/RWS.hs index 6a3415f11..b90937e0c 100644 --- a/src/Diffing/Algorithm/RWS.hs +++ b/src/Diffing/Algorithm/RWS.hs @@ -31,11 +31,11 @@ import Prologue type ComparabilityRelation syntax ann1 ann2 = forall a b. TermF syntax ann1 a -> TermF syntax ann2 b -> Bool rws :: (Foldable syntax, Functor syntax, Diffable syntax) - => ComparabilityRelation syntax (FeatureVector, Location) (FeatureVector, Location) - -> (Term syntax (FeatureVector, Location) -> Term syntax (FeatureVector, Location) -> Bool) - -> [Term syntax (FeatureVector, Location)] - -> [Term syntax (FeatureVector, Location)] - -> EditScript (Term syntax (FeatureVector, Location)) (Term syntax (FeatureVector, Location)) + => ComparabilityRelation syntax (FeatureVector, DiffAnnotation a) (FeatureVector, DiffAnnotation a) + -> (Term syntax (FeatureVector, DiffAnnotation a) -> Term syntax (FeatureVector, DiffAnnotation a) -> Bool) + -> [Term syntax (FeatureVector, DiffAnnotation a)] + -> [Term syntax (FeatureVector, DiffAnnotation a)] + -> EditScript (Term syntax (FeatureVector, DiffAnnotation a)) (Term syntax (FeatureVector, DiffAnnotation a)) rws _ _ as [] = This <$> as rws _ _ [] bs = That <$> bs rws canCompare _ [a] [b] = if canCompareTerms canCompare a b then [These a b] else [That b, This a] @@ -97,7 +97,7 @@ defaultP = 0 defaultQ = 3 -toKdMap :: [(Int, Term syntax (FeatureVector, Location))] -> KdMap.KdMap Double FeatureVector (Int, Term syntax (FeatureVector, Location)) +toKdMap :: [(Int, Term syntax (FeatureVector, DiffAnnotation a))] -> KdMap.KdMap Double FeatureVector (Int, Term syntax (FeatureVector, DiffAnnotation a)) toKdMap = KdMap.build unFV . fmap (fst . termAnnotation . snd &&& id) -- | A `Gram` is a fixed-size view of some portion of a tree, consisting of a `stem` of _p_ labels for parent nodes, and a `base` of _q_ labels of sibling nodes. Collectively, the bag of `Gram`s for each node of a tree (e.g. as computed by `pqGrams`) form a summary of the tree. @@ -106,12 +106,12 @@ data Gram label = Gram { stem :: [Maybe label], base :: [Maybe label] } -- | Annotates a term with a feature vector at each node, using the default values for the p, q, and d parameters. defaultFeatureVectorDecorator :: (Hashable1 syntax, Traversable syntax) - => Term syntax Location - -> Term syntax (FeatureVector, Location) + => Term syntax (DiffAnnotation a) + -> Term syntax (FeatureVector, DiffAnnotation a) defaultFeatureVectorDecorator = featureVectorDecorator . pqGramDecorator defaultP defaultQ -- | Annotates a term with a feature vector at each node, parameterized by stem length, base width, and feature vector dimensions. -featureVectorDecorator :: (Foldable syntax, Functor syntax, Hashable label) => Term syntax (Gram label, Location) -> Term syntax (FeatureVector, Location) +featureVectorDecorator :: (Foldable syntax, Functor syntax, Hashable label) => Term syntax (Gram label, DiffAnnotation a) -> Term syntax (FeatureVector, DiffAnnotation a) featureVectorDecorator = cata (\ (In (label, ann) functor) -> termIn (foldl' addSubtermVector (unitVector (hash label)) functor, ann) functor) where addSubtermVector v term = addVectors v (fst (termAnnotation term)) @@ -120,8 +120,8 @@ featureVectorDecorator = cata (\ (In (label, ann) functor) -> pqGramDecorator :: Traversable syntax => Int -- ^ 'p'; the desired stem length for the grams. -> Int -- ^ 'q'; the desired base length for the grams. - -> Term syntax Location -- ^ The term to decorate. - -> Term syntax (Gram (Label syntax), Location) -- ^ The decorated term. + -> Term syntax (DiffAnnotation a)-- ^ The term to decorate. + -> Term syntax (Gram (Label syntax), DiffAnnotation a) -- ^ The decorated term. pqGramDecorator p q = cata algebra where algebra term = let label = Label (termFOut term) in @@ -130,13 +130,13 @@ pqGramDecorator p q = cata algebra assignParentAndSiblingLabels functor label = (`evalState` (replicate (q `div` 2) Nothing <> siblingLabels functor)) (for functor (assignLabels label)) assignLabels :: label - -> Term syntax (Gram label, Location) - -> State [Maybe label] (Term syntax (Gram label, Location)) + -> Term syntax (Gram label, DiffAnnotation a) + -> State [Maybe label] (Term syntax (Gram label, DiffAnnotation a)) assignLabels label (Term.Term (In (gram, rest) functor)) = do labels <- get put (drop 1 labels) pure $! termIn (gram { stem = padToSize p (Just label : stem gram), base = padToSize q labels }, rest) functor - siblingLabels :: Traversable syntax => syntax (Term syntax (Gram label, Location)) -> [Maybe label] + siblingLabels :: Traversable syntax => syntax (Term syntax (Gram label, DiffAnnotation a)) -> [Maybe label] siblingLabels = foldMap (base . fst . termAnnotation) padToSize n list = take n (list <> repeat empty) diff --git a/src/Diffing/Interpreter.hs b/src/Diffing/Interpreter.hs index 1b25f31fa..b4b1a4671 100644 --- a/src/Diffing/Interpreter.hs +++ b/src/Diffing/Interpreter.hs @@ -14,30 +14,30 @@ import Prologue -- | Diff two à la carte terms recursively. diffTerms :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) - => Term syntax Location - -> Term syntax Location - -> Diff syntax Location Location + => Term syntax (DiffAnnotation a) + -> Term syntax (DiffAnnotation a) + -> Diff syntax (DiffAnnotation a) (DiffAnnotation a) diffTerms t1 t2 = stripDiff (fromMaybe (replacing t1' t2') (runAlgorithm (diff t1' t2'))) where (t1', t2') = ( defaultFeatureVectorDecorator t1 , defaultFeatureVectorDecorator t2) -- | Strips the head annotation off a diff annotated with non-empty records. stripDiff :: Functor syntax - => Diff syntax (FeatureVector, Location) (FeatureVector, Location) - -> Diff syntax Location Location + => Diff syntax (FeatureVector, DiffAnnotation a) (FeatureVector, DiffAnnotation a) + -> Diff syntax (DiffAnnotation a) (DiffAnnotation a) stripDiff = bimap snd snd -- | Diff a 'These' of terms. -diffTermPair :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => These (Term syntax Location) (Term syntax Location) -> Diff syntax Location Location +diffTermPair :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => These (Term syntax (DiffAnnotation a)) (Term syntax (DiffAnnotation a)) -> Diff syntax (DiffAnnotation a) (DiffAnnotation a) diffTermPair = these deleting inserting diffTerms -- | Run an 'Algorithm' to completion in an 'Alternative' context using the supplied comparability & equivalence relations. runAlgorithm :: (Diffable syntax, Eq1 syntax, Traversable syntax, Alternative m, Monad m) => Algorithm - (Term syntax (FeatureVector, Location)) - (Term syntax (FeatureVector, Location)) - (Diff syntax (FeatureVector, Location) (FeatureVector, Location)) + (Term syntax (FeatureVector, DiffAnnotation a)) + (Term syntax (FeatureVector, DiffAnnotation a)) + (Diff syntax (FeatureVector, DiffAnnotation a) (FeatureVector, DiffAnnotation a)) result -> m result runAlgorithm = iterFreerA (\ yield step -> case step of diff --git a/src/Semantic/Diff.hs b/src/Semantic/Diff.hs index 7aed9af72..3a85f12b7 100644 --- a/src/Semantic/Diff.hs +++ b/src/Semantic/Diff.hs @@ -6,7 +6,6 @@ module Semantic.Diff import Analysis.ConstructorName (ConstructorName) import Analysis.Declaration (HasDeclaration, declarationAlgebra) -import Data.AST import Data.Blob import Data.Diff import Data.JSON.Fields @@ -27,13 +26,16 @@ import qualified Rendering.JSON as JSON runDiff :: (Member Distribute effs, Member (Exc SomeException) effs, Member (Lift IO) effs, Member Task effs, Member Telemetry effs) => DiffRenderer output -> [BlobPair] -> Eff effs Builder runDiff ToCDiffRenderer = withParsedBlobPairs (decorate . declarationAlgebra) (render . renderToCDiff) >=> serialize JSON -runDiff JSONDiffRenderer = withParsedBlobPairs (const pure) (render . renderJSONDiff) >=> serialize JSON -runDiff JSONGraphDiffRenderer = withParsedBlobPairs (const pure) (render . renderAdjGraph) >=> serialize JSON +runDiff JSONDiffRenderer = withParsedBlobPairs (decorate . passAlgebra) (\blob -> render (renderJSONDiff blob) . bimap snd snd) >=> serialize JSON +runDiff JSONGraphDiffRenderer = withParsedBlobPairs (decorate . passAlgebra) (\blob -> render (renderAdjGraph blob) . bimap snd snd) >=> serialize JSON where renderAdjGraph :: (Recursive t, ToTreeGraph DiffVertex (Base t)) => BlobPair -> t -> JSON.JSON "diffs" SomeJSON renderAdjGraph blob diff = renderJSONAdjDiff blob (renderTreeGraph diff) -runDiff SExpressionDiffRenderer = withParsedBlobPairs (const pure) (const (serialize (SExpression ByConstructorName))) -runDiff ShowDiffRenderer = withParsedBlobPairs (const pure) (const (serialize Show)) -runDiff DOTDiffRenderer = withParsedBlobPairs (const pure) (const (render renderTreeGraph)) >=> serialize (DOT (diffStyle "diffs")) +runDiff SExpressionDiffRenderer = withParsedBlobPairs (decorate . passAlgebra) (const (serialize (SExpression ByConstructorName))) +runDiff ShowDiffRenderer = withParsedBlobPairs (decorate . passAlgebra) (const (serialize Show)) +runDiff DOTDiffRenderer = withParsedBlobPairs (decorate . passAlgebra) (\_ -> render renderTreeGraph . bimap snd snd) >=> serialize (DOT (diffStyle "diffs")) + +passAlgebra :: Blob -> RAlgebra (TermF syntax Location) (Term syntax Location) () +passAlgebra _ (In ann syntax) = () data SomeTermPair typeclasses ann where SomeTermPair :: ApplyAll typeclasses syntax => Join These (Term syntax ann) -> SomeTermPair typeclasses ann @@ -47,21 +49,21 @@ diffBlobTOCPairs = withParsedBlobPairs (decorate . declarationAlgebra) (render . type CanDiff syntax = (ConstructorName syntax, Diffable syntax, Eq1 syntax, HasDeclaration syntax, Hashable1 syntax, Show1 syntax, ToJSONFields1 syntax, Traversable syntax) withParsedBlobPairs :: (Member Distribute effs, Member (Exc SomeException) effs, Member (Lift IO) effs, Member Task effs, Member Telemetry effs, Monoid output) - => (forall syntax . CanDiff syntax => Blob -> Term syntax (Record Location) -> Eff effs (Term syntax (Record fields))) - -> (forall syntax . CanDiff syntax => BlobPair -> Diff syntax (Record fields) (Record fields) -> Eff effs output) + => (forall syntax . CanDiff syntax => Blob -> Term syntax Location -> Eff effs (Term syntax (DiffAnnotation a))) + -> (forall syntax . CanDiff syntax => BlobPair -> Diff syntax (DiffAnnotation a) (DiffAnnotation a) -> Eff effs output) -> [BlobPair] -> Eff effs output withParsedBlobPairs decorate render = distributeFoldMap (\ blobs -> withParsedBlobPair decorate blobs >>= withSomeTermPair (diffTerms blobs >=> render blobs)) - where diffTerms :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax, Member (Lift IO) effs, Member Task effs, Member Telemetry effs) => BlobPair -> Join These (Term syntax (Record fields)) -> Eff effs (Diff syntax (Record fields) (Record fields)) + where diffTerms :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax, Member (Lift IO) effs, Member Task effs, Member Telemetry effs) => BlobPair -> Join These (Term syntax (DiffAnnotation a)) -> Eff effs (Diff syntax (DiffAnnotation a) (DiffAnnotation a)) diffTerms blobs terms = time "diff" languageTag $ do diff <- diff (runJoin terms) diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag) where languageTag = languageTagForBlobPair blobs withParsedBlobPair :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs) - => (forall syntax . (CanDiff syntax) => Blob -> Term syntax (Record Location) -> Eff effs (Term syntax (Record fields))) + => (forall syntax . (CanDiff syntax) => Blob -> Term syntax Location -> Eff effs (Term syntax (DiffAnnotation a))) -> BlobPair - -> Eff effs (SomeTermPair '[ConstructorName, Diffable, Eq1, HasDeclaration, Hashable1, Show1, ToJSONFields1, Traversable] (Record fields)) + -> Eff effs (SomeTermPair '[ConstructorName, Diffable, Eq1, HasDeclaration, Hashable1, Show1, ToJSONFields1, Traversable] (DiffAnnotation a)) withParsedBlobPair decorate blobs | Just (SomeParser parser) <- someParser @'[ConstructorName, Diffable, Eq1, HasDeclaration, Hashable1, Show1, ToJSONFields1, Traversable] (languageForBlobPair blobs) = SomeTermPair <$> distributeFor blobs (\ blob -> parse parser blob >>= decorate blob) diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index b489901fe..4004020f3 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -118,7 +118,7 @@ decorate :: (Functor f, Member Task effs) => RAlgebra (TermF f Location) (Term f decorate algebra = send . Decorate algebra -- | A task which diffs a pair of terms using the supplied 'Differ' function. -diff :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax, Member Task effs) => These (Term syntax Location) (Term syntax Location) -> Eff effs (Diff syntax Location Location) +diff :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax, Member Task effs) => These (Term syntax (DiffAnnotation a)) (Term syntax (DiffAnnotation a)) -> Eff effs (Diff syntax (DiffAnnotation a) (DiffAnnotation a)) diff terms = send (Semantic.Task.Diff terms) -- | A task which renders some input using the supplied 'Renderer' function. @@ -172,7 +172,7 @@ data Task (m :: * -> *) output where Parse :: Parser term -> Blob -> Task m term Analyze :: (Analysis.TermEvaluator term address value effects a -> result) -> Analysis.TermEvaluator term address value effects a -> Task m result Decorate :: Functor f => RAlgebra (TermF f Location) (Term f Location) field -> Term f Location -> Task m (Term f (field, Location)) - Diff :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => These (Term syntax Location) (Term syntax Location) -> Task m (Diff syntax Location Location) + Diff :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => These (Term syntax (DiffAnnotation a)) (Term syntax (DiffAnnotation a)) -> Task m (Diff syntax (DiffAnnotation a) (DiffAnnotation a)) Render :: Renderer input output -> input -> Task m output Serialize :: Format input -> input -> Task m Builder