github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-20 05:11:44 +03:00
Code Issues Projects Releases Wiki Activity

The end of Record fields

Browse Source
This commit is contained in:
Timothy Clem 2018-09-24 17:14:52 -05:00
parent 38a4bb38f2
commit 9b641b4a4a
5 changed files with 41 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
src/Data/Location.hs
View File

@ -2,12 +2,15 @@ module Data.Location
( Location(..) ( Location(..)
, Span(..) , Span(..)
, Range(..) , Range(..)
, DiffAnnotation
) where ) where
import Data.JSON.Fields import Data.JSON.Fields
import Data.Range import Data.Range
import Data.Span import Data.Span
type DiffAnnotation a = (a, Location)
-- | A location specified as possibly-empty intervals of bytes and line/column positions. -- | A location specified as possibly-empty intervals of bytes and line/column positions.
-- type Location = '[Range, Span] -- type Location = '[Range, Span]

28
src/Diffing/Algorithm/RWS.hs
View File

@ -31,11 +31,11 @@ import Prologue
type ComparabilityRelation syntax ann1 ann2 = forall a b. TermF syntax ann1 a -> TermF syntax ann2 b -> Bool type ComparabilityRelation syntax ann1 ann2 = forall a b. TermF syntax ann1 a -> TermF syntax ann2 b -> Bool
rws :: (Foldable syntax, Functor syntax, Diffable syntax) rws :: (Foldable syntax, Functor syntax, Diffable syntax)
=> ComparabilityRelation syntax (FeatureVector, Location) (FeatureVector, Location) => ComparabilityRelation syntax (FeatureVector, DiffAnnotation a) (FeatureVector, DiffAnnotation a)
-> (Term syntax (FeatureVector, Location) -> Term syntax (FeatureVector, Location) -> Bool) -> (Term syntax (FeatureVector, DiffAnnotation a) -> Term syntax (FeatureVector, DiffAnnotation a) -> Bool)
-> [Term syntax (FeatureVector, Location)] -> [Term syntax (FeatureVector, DiffAnnotation a)]
-> [Term syntax (FeatureVector, Location)] -> [Term syntax (FeatureVector, DiffAnnotation a)]
-> EditScript (Term syntax (FeatureVector, Location)) (Term syntax (FeatureVector, Location)) -> EditScript (Term syntax (FeatureVector, DiffAnnotation a)) (Term syntax (FeatureVector, DiffAnnotation a))
rws _ _ as [] = This <$> as rws _ _ as [] = This <$> as
rws _ _ [] bs = That <$> bs rws _ _ [] bs = That <$> bs
rws canCompare _ [a] [b] = if canCompareTerms canCompare a b then [These a b] else [That b, This a] 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 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) 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. -- | 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. -- | 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) defaultFeatureVectorDecorator :: (Hashable1 syntax, Traversable syntax)
=> Term syntax Location => Term syntax (DiffAnnotation a)
-> Term syntax (FeatureVector, Location) -> Term syntax (FeatureVector, DiffAnnotation a)
defaultFeatureVectorDecorator = featureVectorDecorator . pqGramDecorator defaultP defaultQ 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. -- | 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) -> featureVectorDecorator = cata (\ (In (label, ann) functor) ->
termIn (foldl' addSubtermVector (unitVector (hash label)) functor, ann) functor) termIn (foldl' addSubtermVector (unitVector (hash label)) functor, ann) functor)
where addSubtermVector v term = addVectors v (fst (termAnnotation term)) where addSubtermVector v term = addVectors v (fst (termAnnotation term))
@ -120,8 +120,8 @@ featureVectorDecorator = cata (\ (In (label, ann) functor) ->
pqGramDecorator :: Traversable syntax pqGramDecorator :: Traversable syntax
=> Int -- ^ 'p'; the desired stem length for the grams. => Int -- ^ 'p'; the desired stem length for the grams.
-> Int -- ^ 'q'; the desired base length for the grams. -> Int -- ^ 'q'; the desired base length for the grams.
-> Term syntax Location -- ^ The term to decorate. -> Term syntax (DiffAnnotation a)-- ^ The term to decorate.
-> Term syntax (Gram (Label syntax), Location) -- ^ The decorated term. -> Term syntax (Gram (Label syntax), DiffAnnotation a) -- ^ The decorated term.
pqGramDecorator p q = cata algebra pqGramDecorator p q = cata algebra
where where
algebra term = let label = Label (termFOut term) in 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)) assignParentAndSiblingLabels functor label = (`evalState` (replicate (q `div` 2) Nothing <> siblingLabels functor)) (for functor (assignLabels label))
assignLabels :: label assignLabels :: label
-> Term syntax (Gram label, Location) -> Term syntax (Gram label, DiffAnnotation a)
-> State [Maybe label] (Term syntax (Gram label, Location)) -> State [Maybe label] (Term syntax (Gram label, DiffAnnotation a))
assignLabels label (Term.Term (In (gram, rest) functor)) = do assignLabels label (Term.Term (In (gram, rest) functor)) = do
labels <- get labels <- get
put (drop 1 labels) put (drop 1 labels)
pure $! termIn (gram { stem = padToSize p (Just label : stem gram), base = padToSize q labels }, rest) functor 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) siblingLabels = foldMap (base . fst . termAnnotation)
padToSize n list = take n (list <> repeat empty) padToSize n list = take n (list <> repeat empty)

18
src/Diffing/Interpreter.hs
View File

@ -14,30 +14,30 @@ import Prologue
-- | Diff two à la carte terms recursively. -- | Diff two à la carte terms recursively.
diffTerms :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) diffTerms :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax)
=> Term syntax Location => Term syntax (DiffAnnotation a)
-> Term syntax Location -> Term syntax (DiffAnnotation a)
-> Diff syntax Location Location -> Diff syntax (DiffAnnotation a) (DiffAnnotation a)
diffTerms t1 t2 = stripDiff (fromMaybe (replacing t1' t2') (runAlgorithm (diff t1' t2'))) diffTerms t1 t2 = stripDiff (fromMaybe (replacing t1' t2') (runAlgorithm (diff t1' t2')))
where (t1', t2') = ( defaultFeatureVectorDecorator t1 where (t1', t2') = ( defaultFeatureVectorDecorator t1
, defaultFeatureVectorDecorator t2) , defaultFeatureVectorDecorator t2)
-- | Strips the head annotation off a diff annotated with non-empty records. -- | Strips the head annotation off a diff annotated with non-empty records.
stripDiff :: Functor syntax stripDiff :: Functor syntax
=> Diff syntax (FeatureVector, Location) (FeatureVector, Location) => Diff syntax (FeatureVector, DiffAnnotation a) (FeatureVector, DiffAnnotation a)
-> Diff syntax Location Location -> Diff syntax (DiffAnnotation a) (DiffAnnotation a)
stripDiff = bimap snd snd stripDiff = bimap snd snd
-- | Diff a 'These' of terms. -- | 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 diffTermPair = these deleting inserting diffTerms
-- | Run an 'Algorithm' to completion in an 'Alternative' context using the supplied comparability & equivalence relations. -- | 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) runAlgorithm :: (Diffable syntax, Eq1 syntax, Traversable syntax, Alternative m, Monad m)
=> Algorithm => Algorithm
(Term syntax (FeatureVector, Location)) (Term syntax (FeatureVector, DiffAnnotation a))
(Term syntax (FeatureVector, Location)) (Term syntax (FeatureVector, DiffAnnotation a))
(Diff syntax (FeatureVector, Location) (FeatureVector, Location)) (Diff syntax (FeatureVector, DiffAnnotation a) (FeatureVector, DiffAnnotation a))
result result
-> m result -> m result
runAlgorithm = iterFreerA (\ yield step -> case step of runAlgorithm = iterFreerA (\ yield step -> case step of

24
src/Semantic/Diff.hs
View File

@ -6,7 +6,6 @@ module Semantic.Diff
import Analysis.ConstructorName (ConstructorName) import Analysis.ConstructorName (ConstructorName)
import Analysis.Declaration (HasDeclaration, declarationAlgebra) import Analysis.Declaration (HasDeclaration, declarationAlgebra)
import Data.AST
import Data.Blob import Data.Blob
import Data.Diff import Data.Diff
import Data.JSON.Fields 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 :: (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 ToCDiffRenderer = withParsedBlobPairs (decorate . declarationAlgebra) (render . renderToCDiff) >=> serialize JSON
runDiff JSONDiffRenderer = withParsedBlobPairs (const pure) (render . renderJSONDiff) >=> serialize JSON runDiff JSONDiffRenderer = withParsedBlobPairs (decorate . passAlgebra) (\blob -> render (renderJSONDiff blob) . bimap snd snd) >=> serialize JSON
runDiff JSONGraphDiffRenderer = withParsedBlobPairs (const pure) (render . renderAdjGraph) >=> 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 where renderAdjGraph :: (Recursive t, ToTreeGraph DiffVertex (Base t)) => BlobPair -> t -> JSON.JSON "diffs" SomeJSON
renderAdjGraph blob diff = renderJSONAdjDiff blob (renderTreeGraph diff) renderAdjGraph blob diff = renderJSONAdjDiff blob (renderTreeGraph diff)
runDiff SExpressionDiffRenderer = withParsedBlobPairs (const pure) (const (serialize (SExpression ByConstructorName))) runDiff SExpressionDiffRenderer = withParsedBlobPairs (decorate . passAlgebra) (const (serialize (SExpression ByConstructorName)))
runDiff ShowDiffRenderer = withParsedBlobPairs (const pure) (const (serialize Show)) runDiff ShowDiffRenderer = withParsedBlobPairs (decorate . passAlgebra) (const (serialize Show))
runDiff DOTDiffRenderer = withParsedBlobPairs (const pure) (const (render renderTreeGraph)) >=> serialize (DOT (diffStyle "diffs")) 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 data SomeTermPair typeclasses ann where
SomeTermPair :: ApplyAll typeclasses syntax => Join These (Term syntax ann) -> SomeTermPair typeclasses ann 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) 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) 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 => Blob -> Term syntax Location -> Eff effs (Term syntax (DiffAnnotation a)))
-> (forall syntax . CanDiff syntax => BlobPair -> Diff syntax (Record fields) (Record fields) -> Eff effs output) -> (forall syntax . CanDiff syntax => BlobPair -> Diff syntax (DiffAnnotation a) (DiffAnnotation a) -> Eff effs output)
-> [BlobPair] -> [BlobPair]
-> Eff effs output -> Eff effs output
withParsedBlobPairs decorate render = distributeFoldMap (\ blobs -> withParsedBlobPair decorate blobs >>= withSomeTermPair (diffTerms blobs >=> render blobs)) 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 diffTerms blobs terms = time "diff" languageTag $ do
diff <- diff (runJoin terms) diff <- diff (runJoin terms)
diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag) diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)
where languageTag = languageTagForBlobPair blobs where languageTag = languageTagForBlobPair blobs
withParsedBlobPair :: (Member Distribute effs, Member (Exc SomeException) effs, Member Task effs) 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 -> 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 withParsedBlobPair decorate blobs
| Just (SomeParser parser) <- someParser @'[ConstructorName, Diffable, Eq1, HasDeclaration, Hashable1, Show1, ToJSONFields1, Traversable] (languageForBlobPair blobs) | Just (SomeParser parser) <- someParser @'[ConstructorName, Diffable, Eq1, HasDeclaration, Hashable1, Show1, ToJSONFields1, Traversable] (languageForBlobPair blobs)
= SomeTermPair <$> distributeFor blobs (\ blob -> parse parser blob >>= decorate blob) = SomeTermPair <$> distributeFor blobs (\ blob -> parse parser blob >>= decorate blob)

4
src/Semantic/Task.hs
View File

@ -118,7 +118,7 @@ decorate :: (Functor f, Member Task effs) => RAlgebra (TermF f Location) (Term f
decorate algebra = send . Decorate algebra decorate algebra = send . Decorate algebra
-- | A task which diffs a pair of terms using the supplied 'Differ' function. -- | 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) diff terms = send (Semantic.Task.Diff terms)
-- | A task which renders some input using the supplied 'Renderer' function. -- | 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 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 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)) 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 Render :: Renderer input output -> input -> Task m output
Serialize :: Format input -> input -> Task m Builder Serialize :: Format input -> input -> Task m Builder