github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-12-24 07:25: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(..)
, 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]

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
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)

18
src/Diffing/Interpreter.hs
View File

@ -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

24
src/Semantic/Diff.hs
View File

@ -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)

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
-- | 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