mirror of
https://github.com/github/semantic.git
synced 2024-12-18 04:11:48 +03:00
Merge branch 'master' into json-and-core-are-breaking-up
This commit is contained in:
Patrick Thomson
GitHub
commit
90f5c78b0d
@ -21,10 +21,6 @@ import Data.Scope (Scope, Incr)
|
||||
import qualified Data.Scope as Scope
|
||||
import Data.Name
|
||||
|
||||
-- We default to deriving the default toEncoding definition (that piggybacks
|
||||
-- off of toJSON) so that we never hit the problematic code paths associated
|
||||
-- with toEncoding above.
|
||||
|
||||
instance ToJSON a => ToJSON (File a) where
|
||||
toJSON File{fileLoc, fileBody} = object
|
||||
[ "location" .= fileLoc
|
||||
|
||||
@ -75,7 +75,6 @@ runParser blob@Blob{..} parser = case parser of
|
||||
time "parse.cmark_parse" languageTag $
|
||||
let term = cmarkParser blobSource
|
||||
in length term `seq` pure term
|
||||
SomeParser parser -> SomeTerm <$> runParser blob parser
|
||||
where languageTag = [("language" :: String, show (blobLanguage blob))]
|
||||
|
||||
data ParserCancelled = ParserTimedOut | AssignmentTimedOut
|
||||
|
||||
@ -65,7 +65,6 @@ runParser timeout blob@Blob{..} parser = case parser of
|
||||
MarkdownParser ->
|
||||
let term = cmarkParser blobSource
|
||||
in length term `seq` pure term
|
||||
SomeParser parser -> SomeTerm <$> runParser timeout blob parser
|
||||
|
||||
data ParseFailure = ParseFailure String
|
||||
deriving (Show, Typeable)
|
||||
|
||||
@ -30,11 +30,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, ann) (FeatureVector, ann)
|
||||
-> (Term syntax (FeatureVector, ann) -> Term syntax (FeatureVector, ann) -> Bool)
|
||||
-> [Term syntax (FeatureVector, ann)]
|
||||
-> [Term syntax (FeatureVector, ann)]
|
||||
-> EditScript (Term syntax (FeatureVector, ann)) (Term syntax (FeatureVector, ann))
|
||||
=> ComparabilityRelation syntax (FeatureVector, ann1) (FeatureVector, ann2)
|
||||
-> (Term syntax (FeatureVector, ann1) -> Term syntax (FeatureVector, ann2) -> Bool)
|
||||
-> [Term syntax (FeatureVector, ann1)]
|
||||
-> [Term syntax (FeatureVector, ann2)]
|
||||
-> EditScript (Term syntax (FeatureVector, ann1)) (Term syntax (FeatureVector, ann2))
|
||||
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]
|
||||
|
||||
@ -1,7 +1,7 @@
|
||||
{-# LANGUAGE GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances #-}
|
||||
{-# LANGUAGE FunctionalDependencies, GeneralizedNewtypeDeriving, TypeOperators, UndecidableInstances #-}
|
||||
module Diffing.Interpreter
|
||||
( diffTerms
|
||||
, diffTermPair
|
||||
, DiffTerms(..)
|
||||
, stripDiff
|
||||
) where
|
||||
|
||||
@ -16,30 +16,33 @@ import Prologue
|
||||
|
||||
-- | Diff two à la carte terms recursively.
|
||||
diffTerms :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax)
|
||||
=> Term syntax ann
|
||||
-> Term syntax ann
|
||||
-> Diff.Diff syntax ann ann
|
||||
=> Term syntax ann1
|
||||
-> Term syntax ann2
|
||||
-> Diff.Diff syntax ann1 ann2
|
||||
diffTerms t1 t2 = stripDiff (fromMaybe (Diff.replacing t1' t2') (run (runNonDetOnce (runDiff (algorithmForTerms 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.Diff syntax (FeatureVector, ann) (FeatureVector, ann)
|
||||
-> Diff.Diff syntax ann ann
|
||||
=> Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2)
|
||||
-> Diff.Diff syntax ann1 ann2
|
||||
stripDiff = bimap snd snd
|
||||
|
||||
-- | Diff a 'These' of terms.
|
||||
diffTermPair :: (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => These (Term syntax ann) (Term syntax ann) -> Diff.Diff syntax ann ann
|
||||
diffTermPair = these Diff.deleting Diff.inserting diffTerms
|
||||
class DiffTerms term diff | diff -> term, term -> diff where
|
||||
-- | Diff a 'These' of terms.
|
||||
diffTermPair :: These (term ann1) (term ann2) -> diff ann1 ann2
|
||||
|
||||
instance (Diffable syntax, Eq1 syntax, Hashable1 syntax, Traversable syntax) => DiffTerms (Term syntax) (Diff.Diff syntax) where
|
||||
diffTermPair = these Diff.deleting Diff.inserting diffTerms
|
||||
|
||||
|
||||
-- | Run an 'Algorithm' to completion in an 'Alternative' context using the supplied comparability & equivalence relations.
|
||||
runDiff :: Algorithm
|
||||
(Term syntax (FeatureVector, ann))
|
||||
(Term syntax (FeatureVector, ann))
|
||||
(Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann))
|
||||
(DiffC (Term syntax (FeatureVector, ann)) (Term syntax (FeatureVector, ann)) (Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann)) m)
|
||||
(Term syntax (FeatureVector, ann1))
|
||||
(Term syntax (FeatureVector, ann2))
|
||||
(Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2))
|
||||
(DiffC (Term syntax (FeatureVector, ann1)) (Term syntax (FeatureVector, ann2)) (Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2)) m)
|
||||
result
|
||||
-> m result
|
||||
runDiff = runDiffC . runAlgorithm
|
||||
@ -57,8 +60,8 @@ instance ( Alternative m
|
||||
, Traversable syntax
|
||||
)
|
||||
=> Carrier
|
||||
(Diff (Term syntax (FeatureVector, ann)) (Term syntax (FeatureVector, ann)) (Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann)) :+: sig)
|
||||
(DiffC (Term syntax (FeatureVector, ann)) (Term syntax (FeatureVector, ann)) (Diff.Diff syntax (FeatureVector, ann) (FeatureVector, ann)) m) where
|
||||
(Diff (Term syntax (FeatureVector, ann1)) (Term syntax (FeatureVector, ann2)) (Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2)) :+: sig)
|
||||
(DiffC (Term syntax (FeatureVector, ann1)) (Term syntax (FeatureVector, ann2)) (Diff.Diff syntax (FeatureVector, ann1) (FeatureVector, ann2)) m) where
|
||||
eff (L op) = case op of
|
||||
Diff t1 t2 k -> runDiff (algorithmForTerms t1 t2) <|> pure (Diff.replacing t1 t2) >>= k
|
||||
Linear (Term (In ann1 f1)) (Term (In ann2 f2)) k -> Diff.merge (ann1, ann2) <$> tryAlignWith (runDiff . diffThese) f1 f2 >>= k
|
||||
|
||||
@ -1,8 +1,6 @@
|
||||
{-# LANGUAGE AllowAmbiguousTypes, ConstraintKinds, GADTs, RankNTypes, ScopedTypeVariables, TypeFamilies, TypeOperators #-}
|
||||
module Parsing.Parser
|
||||
( Parser(..)
|
||||
, SomeTerm(..)
|
||||
, withSomeTerm
|
||||
, SomeAnalysisParser(..)
|
||||
, SomeASTParser(..)
|
||||
, someASTParser
|
||||
@ -112,8 +110,7 @@ data Parser term where
|
||||
-> Parser (Term (Sum syntaxes) Loc)
|
||||
-- | A parser for 'Markdown' using cmark.
|
||||
MarkdownParser :: Parser (Term (TermF [] CMarkGFM.NodeType) (Node Markdown.Grammar))
|
||||
-- | An abstraction over parsers when we don’t know the details of the term type.
|
||||
SomeParser :: ApplyAll typeclasses syntax => Parser (Term syntax ann) -> Parser (SomeTerm typeclasses ann)
|
||||
|
||||
|
||||
-- | Apply all of a list of typeclasses to all of a list of functors using 'Apply'. Used by 'someParser' to constrain all of the language-specific syntax types to the typeclasses in question.
|
||||
type family ApplyAll (typeclasses :: [(* -> *) -> Constraint]) (syntax :: * -> *) :: Constraint where
|
||||
@ -168,12 +165,6 @@ precisePythonParser :: Parser (Py.Term Loc)
|
||||
precisePythonParser = UnmarshalParser tree_sitter_python
|
||||
|
||||
|
||||
data SomeTerm typeclasses ann where
|
||||
SomeTerm :: ApplyAll typeclasses syntax => Term syntax ann -> SomeTerm typeclasses ann
|
||||
|
||||
withSomeTerm :: (forall syntax . ApplyAll typeclasses syntax => Term syntax ann -> a) -> SomeTerm typeclasses ann -> a
|
||||
withSomeTerm with (SomeTerm term) = with term
|
||||
|
||||
-- | A parser for producing specialized (tree-sitter) ASTs.
|
||||
data SomeASTParser where
|
||||
SomeASTParser :: (Bounded grammar, Enum grammar, Show grammar)
|
||||
|
||||
@ -1,7 +1,6 @@
|
||||
{-# LANGUAGE DerivingVia, RankNTypes, ScopedTypeVariables #-}
|
||||
module Rendering.TOC
|
||||
( renderToCDiff
|
||||
, renderToCTerm
|
||||
, diffTOC
|
||||
, Summaries(..)
|
||||
, TOCSummary(..)
|
||||
@ -143,15 +142,6 @@ renderToCDiff blobs = uncurry Summaries . bimap toMap toMap . List.partition isV
|
||||
diffTOC :: (Foldable f, Functor f) => Diff f (Maybe Declaration) (Maybe Declaration) -> [TOCSummary]
|
||||
diffTOC = fmap entrySummary . dedupe . tableOfContentsBy declaration
|
||||
|
||||
renderToCTerm :: (Foldable f, Functor f) => Blob -> Term f (Maybe Declaration) -> Summaries
|
||||
renderToCTerm b@Blob{..} = uncurry Summaries . bimap toMap toMap . List.partition isValidSummary . termToC
|
||||
where
|
||||
toMap [] = mempty
|
||||
toMap as = Map.singleton (T.pack (blobPath b)) (toJSON <$> as)
|
||||
|
||||
termToC :: (Foldable f, Functor f) => Term f (Maybe Declaration) -> [TOCSummary]
|
||||
termToC = fmap (recordSummary "unchanged") . termTableOfContentsBy declaration
|
||||
|
||||
-- The user-facing category name
|
||||
toCategoryName :: Declaration -> T.Text
|
||||
toCategoryName declaration = case declaration of
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE GADTs, ConstraintKinds, TypeOperators, RankNTypes #-}
|
||||
{-# LANGUAGE GADTs, ConstraintKinds, FunctionalDependencies, LambdaCase, RankNTypes #-}
|
||||
module Semantic.Api.Diffs
|
||||
( parseDiffBuilder
|
||||
, DiffOutputFormat(..)
|
||||
@ -8,11 +8,14 @@ module Semantic.Api.Diffs
|
||||
, DiffEffects
|
||||
|
||||
, SomeTermPair(..)
|
||||
, withSomeTermPair
|
||||
|
||||
, LegacySummarizeDiff(..)
|
||||
, SummarizeDiff(..)
|
||||
) where
|
||||
|
||||
import Analysis.ConstructorName (ConstructorName)
|
||||
import Analysis.TOCSummary (HasDeclaration)
|
||||
import Analysis.Decorator (decoratorWithAlgebra)
|
||||
import Analysis.TOCSummary (Declaration, HasDeclaration, declarationAlgebra)
|
||||
import Control.Effect.Error
|
||||
import Control.Effect.Parse
|
||||
import Control.Effect.Reader
|
||||
@ -28,13 +31,13 @@ import Data.Language
|
||||
import Data.Term
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Vector as V
|
||||
import Diffing.Algorithm (Diffable)
|
||||
import Diffing.Interpreter (diffTermPair)
|
||||
import Diffing.Interpreter (DiffTerms(..))
|
||||
import Parsing.Parser
|
||||
import Prologue
|
||||
import Rendering.Graph
|
||||
import Rendering.JSON hiding (JSON)
|
||||
import qualified Rendering.JSON
|
||||
import Rendering.TOC
|
||||
import Semantic.Api.Bridge
|
||||
import Semantic.Config
|
||||
import Semantic.Proto.SemanticPB hiding (Blob, BlobPair)
|
||||
@ -53,83 +56,139 @@ data DiffOutputFormat
|
||||
deriving (Eq, Show)
|
||||
|
||||
parseDiffBuilder :: (Traversable t, DiffEffects sig m) => DiffOutputFormat -> t BlobPair -> m Builder
|
||||
parseDiffBuilder DiffJSONTree = distributeFoldMap (jsonDiff renderJSONTree) >=> serialize Format.JSON -- NB: Serialize happens at the top level for these two JSON formats to collect results of multiple blob pairs.
|
||||
parseDiffBuilder DiffJSONTree = distributeFoldMap jsonDiff >=> serialize Format.JSON -- NB: Serialize happens at the top level for these two JSON formats to collect results of multiple blob pairs.
|
||||
parseDiffBuilder DiffJSONGraph = diffGraph >=> serialize Format.JSON
|
||||
parseDiffBuilder DiffSExpression = distributeFoldMap sexpDiff
|
||||
parseDiffBuilder DiffShow = distributeFoldMap showDiff
|
||||
parseDiffBuilder DiffDotGraph = distributeFoldMap dotGraphDiff
|
||||
parseDiffBuilder DiffSExpression = distributeFoldMap (doDiff (const id) sexprDiff)
|
||||
parseDiffBuilder DiffShow = distributeFoldMap (doDiff (const id) showDiff)
|
||||
parseDiffBuilder DiffDotGraph = distributeFoldMap (doDiff (const id) dotGraphDiff)
|
||||
|
||||
type RenderJSON m syntax = forall syntax . CanDiff syntax => BlobPair -> Diff syntax Loc Loc -> m (Rendering.JSON.JSON "diffs" SomeJSON)
|
||||
|
||||
jsonDiff :: (DiffEffects sig m) => RenderJSON m syntax -> BlobPair -> m (Rendering.JSON.JSON "diffs" SomeJSON)
|
||||
jsonDiff f blobPair = doDiff blobPair (const id) f `catchError` jsonError blobPair
|
||||
jsonDiff :: DiffEffects sig m => BlobPair -> m (Rendering.JSON.JSON "diffs" SomeJSON)
|
||||
jsonDiff blobPair = doDiff (const id) (pure . jsonTreeDiff blobPair) blobPair `catchError` jsonError blobPair
|
||||
|
||||
jsonError :: Applicative m => BlobPair -> SomeException -> m (Rendering.JSON.JSON "diffs" SomeJSON)
|
||||
jsonError blobPair (SomeException e) = pure $ renderJSONDiffError blobPair (show e)
|
||||
|
||||
renderJSONTree :: (Applicative m, ToJSONFields1 syntax) => BlobPair -> Diff syntax Loc Loc -> m (Rendering.JSON.JSON "diffs" SomeJSON)
|
||||
renderJSONTree blobPair = pure . renderJSONDiff blobPair
|
||||
|
||||
diffGraph :: (Traversable t, DiffEffects sig m) => t BlobPair -> m DiffTreeGraphResponse
|
||||
diffGraph blobs = DiffTreeGraphResponse . V.fromList . toList <$> distributeFor blobs go
|
||||
where
|
||||
go :: (DiffEffects sig m) => BlobPair -> m DiffTreeFileGraph
|
||||
go blobPair = doDiff blobPair (const id) render
|
||||
go :: DiffEffects sig m => BlobPair -> m DiffTreeFileGraph
|
||||
go blobPair = doDiff (const id) (pure . jsonGraphDiff blobPair) blobPair
|
||||
`catchError` \(SomeException e) ->
|
||||
pure (DiffTreeFileGraph path lang mempty mempty (V.fromList [ParseError (T.pack (show e))]))
|
||||
where
|
||||
path = T.pack $ pathForBlobPair blobPair
|
||||
lang = bridging # languageForBlobPair blobPair
|
||||
|
||||
render :: (Foldable syntax, Functor syntax, ConstructorName syntax, Applicative m) => BlobPair -> Diff syntax Loc Loc -> m DiffTreeFileGraph
|
||||
render _ diff =
|
||||
let graph = renderTreeGraph diff
|
||||
toEdge (Edge (a, b)) = DiffTreeEdge (diffVertexId a) (diffVertexId b)
|
||||
in pure $ DiffTreeFileGraph path lang (V.fromList (vertexList graph)) (V.fromList (fmap toEdge (edgeList graph))) mempty
|
||||
|
||||
|
||||
sexpDiff :: (DiffEffects sig m) => BlobPair -> m Builder
|
||||
sexpDiff blobPair = doDiff blobPair (const id) (const (serialize (SExpression ByConstructorName)))
|
||||
|
||||
showDiff :: (DiffEffects sig m) => BlobPair -> m Builder
|
||||
showDiff blobPair = doDiff blobPair (const id) (const (serialize Show))
|
||||
|
||||
dotGraphDiff :: (DiffEffects sig m) => BlobPair -> m Builder
|
||||
dotGraphDiff blobPair = doDiff blobPair (const id) render
|
||||
where render _ = serialize (DOT (diffStyle "diffs")) . renderTreeGraph
|
||||
|
||||
type DiffEffects sig m = (Member (Error SomeException) sig, Member (Reader Config) sig, Member Telemetry sig, Member Distribute sig, Member Parse sig, Carrier sig m, MonadIO m)
|
||||
|
||||
type CanDiff syntax = (ConstructorName syntax, Diffable syntax, Eq1 syntax, HasDeclaration syntax, Hashable1 syntax, Show1 syntax, ToJSONFields1 syntax, Traversable syntax)
|
||||
type Decorate a b = forall syntax . CanDiff syntax => Blob -> Term syntax a -> Term syntax b
|
||||
type Decorate a b = forall term diff . DiffActions term diff => Blob -> term a -> term b
|
||||
|
||||
type TermPairConstraints =
|
||||
'[ ConstructorName
|
||||
, Diffable
|
||||
, Eq1
|
||||
, HasDeclaration
|
||||
, Hashable1
|
||||
, Show1
|
||||
, Traversable
|
||||
, ToJSONFields1
|
||||
]
|
||||
|
||||
doDiff :: (DiffEffects sig m)
|
||||
=> BlobPair -> Decorate Loc ann -> (forall syntax . CanDiff syntax => BlobPair -> Diff syntax ann ann -> m output) -> m output
|
||||
doDiff blobPair decorate render = do
|
||||
class DOTGraphDiff diff where
|
||||
dotGraphDiff :: (Carrier sig m, Member (Reader Config) sig) => diff Loc Loc -> m Builder
|
||||
|
||||
instance (ConstructorName syntax, Foldable syntax, Functor syntax) => DOTGraphDiff (Diff syntax) where
|
||||
dotGraphDiff = serialize (DOT (diffStyle "diffs")) . renderTreeGraph
|
||||
|
||||
|
||||
class JSONGraphDiff diff where
|
||||
jsonGraphDiff :: BlobPair -> diff Loc Loc -> DiffTreeFileGraph
|
||||
|
||||
instance (Foldable syntax, Functor syntax, ConstructorName syntax) => JSONGraphDiff (Diff syntax) where
|
||||
jsonGraphDiff blobPair diff
|
||||
= let graph = renderTreeGraph diff
|
||||
toEdge (Edge (a, b)) = DiffTreeEdge (diffVertexId a) (diffVertexId b)
|
||||
in DiffTreeFileGraph path lang (V.fromList (vertexList graph)) (V.fromList (fmap toEdge (edgeList graph))) mempty where
|
||||
path = T.pack $ pathForBlobPair blobPair
|
||||
lang = bridging # languageForBlobPair blobPair
|
||||
|
||||
|
||||
class JSONTreeDiff diff where
|
||||
jsonTreeDiff :: BlobPair -> diff Loc Loc -> Rendering.JSON.JSON "diffs" SomeJSON
|
||||
|
||||
instance ToJSONFields1 syntax => JSONTreeDiff (Diff syntax) where
|
||||
jsonTreeDiff = renderJSONDiff
|
||||
|
||||
|
||||
class SExprDiff diff where
|
||||
sexprDiff :: (Carrier sig m, Member (Reader Config) sig) => diff Loc Loc -> m Builder
|
||||
|
||||
instance (ConstructorName syntax, Foldable syntax, Functor syntax) => SExprDiff (Diff syntax) where
|
||||
sexprDiff = serialize (SExpression ByConstructorName)
|
||||
|
||||
|
||||
class ShowDiff diff where
|
||||
showDiff :: (Carrier sig m, Member (Reader Config) sig) => diff Loc Loc -> m Builder
|
||||
|
||||
instance Show1 syntax => ShowDiff (Diff syntax) where
|
||||
showDiff = serialize Show
|
||||
|
||||
|
||||
class LegacySummarizeDiff term diff | diff -> term, term -> diff where
|
||||
legacyDecorateTerm :: Blob -> term Loc -> term (Maybe Declaration)
|
||||
legacySummarizeDiff :: BlobPair -> diff (Maybe Declaration) (Maybe Declaration) -> Summaries
|
||||
|
||||
instance (Foldable syntax, Functor syntax, HasDeclaration syntax) => LegacySummarizeDiff (Term syntax) (Diff syntax) where
|
||||
legacyDecorateTerm = decoratorWithAlgebra . declarationAlgebra
|
||||
legacySummarizeDiff = renderToCDiff
|
||||
|
||||
|
||||
class SummarizeDiff term diff | diff -> term, term -> diff where
|
||||
decorateTerm :: Blob -> term Loc -> term (Maybe Declaration)
|
||||
summarizeDiff :: BlobPair -> diff (Maybe Declaration) (Maybe Declaration) -> TOCSummaryFile
|
||||
|
||||
instance (Foldable syntax, Functor syntax, HasDeclaration syntax) => SummarizeDiff (Term syntax) (Diff syntax) where
|
||||
decorateTerm = decoratorWithAlgebra . declarationAlgebra
|
||||
summarizeDiff blobPair diff = foldr go (TOCSummaryFile path lang mempty mempty) (diffTOC diff)
|
||||
where
|
||||
path = T.pack $ pathKeyForBlobPair blobPair
|
||||
lang = bridging # languageForBlobPair blobPair
|
||||
|
||||
toChangeType = \case
|
||||
"added" -> Added
|
||||
"modified" -> Modified
|
||||
"removed" -> Removed
|
||||
_ -> None
|
||||
|
||||
go :: TOCSummary -> TOCSummaryFile -> TOCSummaryFile
|
||||
go TOCSummary{..} TOCSummaryFile{..}
|
||||
= TOCSummaryFile path language (V.cons (TOCSummaryChange summaryCategoryName summaryTermName (converting #? summarySpan) (toChangeType summaryChangeType)) changes) errors
|
||||
go ErrorSummary{..} TOCSummaryFile{..}
|
||||
= TOCSummaryFile path language changes (V.cons (TOCSummaryError errorText (converting #? errorSpan)) errors)
|
||||
|
||||
|
||||
type DiffActions term diff =
|
||||
( Bifoldable diff
|
||||
, DiffTerms term diff
|
||||
, DOTGraphDiff diff
|
||||
, JSONGraphDiff diff
|
||||
, JSONTreeDiff diff
|
||||
, SExprDiff diff
|
||||
, ShowDiff diff
|
||||
, LegacySummarizeDiff term diff
|
||||
, SummarizeDiff term diff
|
||||
)
|
||||
|
||||
doDiff
|
||||
:: DiffEffects sig m
|
||||
=> Decorate Loc ann
|
||||
-> (forall term diff . DiffActions term diff => diff ann ann -> m output)
|
||||
-> BlobPair
|
||||
-> m output
|
||||
doDiff decorate render blobPair = do
|
||||
SomeTermPair terms <- doParse blobPair decorate
|
||||
diff <- diffTerms blobPair terms
|
||||
render blobPair diff
|
||||
render diff
|
||||
|
||||
diffTerms :: (CanDiff syntax, Member Telemetry sig, Carrier sig m, MonadIO m)
|
||||
=> BlobPair -> Join These (Term syntax ann) -> m (Diff syntax ann ann)
|
||||
diffTerms :: (DiffActions term diff, Member Telemetry sig, Carrier sig m, MonadIO m)
|
||||
=> BlobPair -> Join These (term ann) -> m (diff ann ann)
|
||||
diffTerms blobs terms = time "diff" languageTag $ do
|
||||
let diff = diffTermPair (runJoin terms)
|
||||
diff <$ writeStat (Stat.count "diff.nodes" (bilength diff) languageTag)
|
||||
where languageTag = languageTagForBlobPair blobs
|
||||
|
||||
doParse :: (Member (Error SomeException) sig, Member Distribute sig, Member Parse sig, Carrier sig m)
|
||||
=> BlobPair -> Decorate Loc ann -> m (SomeTermPair TermPairConstraints ann)
|
||||
=> BlobPair -> Decorate Loc ann -> m (SomeTermPair ann)
|
||||
doParse blobPair decorate = case languageForBlobPair blobPair of
|
||||
Go -> SomeTermPair <$> distributeFor blobPair (\ blob -> decorate blob <$> parse goParser blob)
|
||||
Haskell -> SomeTermPair <$> distributeFor blobPair (\ blob -> decorate blob <$> parse haskellParser blob)
|
||||
@ -144,8 +203,5 @@ doParse blobPair decorate = case languageForBlobPair blobPair of
|
||||
PHP -> SomeTermPair <$> distributeFor blobPair (\ blob -> decorate blob <$> parse phpParser blob)
|
||||
_ -> noLanguageForBlob (pathForBlobPair blobPair)
|
||||
|
||||
data SomeTermPair typeclasses ann where
|
||||
SomeTermPair :: ApplyAll typeclasses syntax => Join These (Term syntax ann) -> SomeTermPair typeclasses ann
|
||||
|
||||
withSomeTermPair :: (forall syntax . ApplyAll typeclasses syntax => Join These (Term syntax ann) -> a) -> SomeTermPair typeclasses ann -> a
|
||||
withSomeTermPair with (SomeTermPair terms) = with terms
|
||||
data SomeTermPair ann where
|
||||
SomeTermPair :: DiffActions term diff => Join These (term ann) -> SomeTermPair ann
|
||||
|
||||
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE GADTs, TypeOperators, DerivingStrategies #-}
|
||||
{-# LANGUAGE MonoLocalBinds, RankNTypes #-}
|
||||
module Semantic.Api.Symbols
|
||||
( legacyParseSymbols
|
||||
, parseSymbols
|
||||
@ -17,25 +17,24 @@ import Data.Term
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Vector as V
|
||||
import Data.Text (pack)
|
||||
import qualified Language.Python as Py
|
||||
import Parsing.Parser
|
||||
import qualified Parsing.Parser as Parser
|
||||
import Prologue
|
||||
import Semantic.Api.Bridge
|
||||
import qualified Semantic.Api.LegacyTypes as Legacy
|
||||
import Semantic.Api.Terms (ParseEffects, doParse)
|
||||
import Semantic.Proto.SemanticPB hiding (Blob)
|
||||
import Semantic.Config
|
||||
import Semantic.Task
|
||||
import Serializing.Format
|
||||
import Serializing.Format (Format)
|
||||
import Source.Loc
|
||||
import Tags.Taggable
|
||||
import Tags.Tagging
|
||||
import qualified Tags.Tagging.Precise as Precise
|
||||
|
||||
legacyParseSymbols :: (Member Distribute sig, ParseEffects sig m, Traversable t) => t Blob -> m Legacy.ParseTreeSymbolResponse
|
||||
legacyParseSymbols :: (Member Distribute sig, Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Carrier sig m, Traversable t) => t Blob -> m Legacy.ParseTreeSymbolResponse
|
||||
legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap go blobs
|
||||
where
|
||||
go :: ParseEffects sig m => Blob -> m [Legacy.File]
|
||||
go blob@Blob{..} = (doParse blob >>= withSomeTerm renderToSymbols) `catchError` (\(SomeException _) -> pure (pure emptyFile))
|
||||
go :: (Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Carrier sig m) => Blob -> m [Legacy.File]
|
||||
go blob@Blob{..} = doParse (pure . renderToSymbols) symbolsToSummarize blob `catchError` (\(SomeException _) -> pure (pure emptyFile))
|
||||
where
|
||||
emptyFile = tagsToFile []
|
||||
|
||||
@ -43,8 +42,8 @@ legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap
|
||||
symbolsToSummarize :: [Text]
|
||||
symbolsToSummarize = ["Function", "Method", "Class", "Module"]
|
||||
|
||||
renderToSymbols :: (IsTaggable f, Applicative m) => Term f Loc -> m [Legacy.File]
|
||||
renderToSymbols = pure . pure . tagsToFile . runTagging blob symbolsToSummarize
|
||||
renderToSymbols :: Precise.ToTags t => t Loc -> [Legacy.File]
|
||||
renderToSymbols = pure . tagsToFile . Precise.tags blobSource
|
||||
|
||||
tagsToFile :: [Tag] -> Legacy.File
|
||||
tagsToFile tags = Legacy.File (pack (blobPath blob)) (pack (show (blobLanguage blob))) (fmap tagToSymbol tags)
|
||||
@ -58,31 +57,22 @@ legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap
|
||||
, symbolSpan = converting #? span
|
||||
}
|
||||
|
||||
parseSymbolsBuilder :: (Member Distribute sig, ParseEffects sig m, Traversable t) => Format ParseTreeSymbolResponse -> t Blob -> m Builder
|
||||
parseSymbolsBuilder :: (Member Distribute sig, Member (Error SomeException) sig, Member Parse sig, Member (Reader Config) sig, Member (Reader PerLanguageModes) sig, Carrier sig m, Traversable t) => Format ParseTreeSymbolResponse -> t Blob -> m Builder
|
||||
parseSymbolsBuilder format blobs = parseSymbols blobs >>= serialize format
|
||||
|
||||
parseSymbols :: (Member Distribute sig, ParseEffects sig m, Traversable t) => t Blob -> m ParseTreeSymbolResponse
|
||||
parseSymbols blobs = do
|
||||
modes <- ask
|
||||
ParseTreeSymbolResponse . V.fromList . toList <$> distributeFor blobs (go modes)
|
||||
parseSymbols :: (Member Distribute sig, Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Carrier sig m, Traversable t) => t Blob -> m ParseTreeSymbolResponse
|
||||
parseSymbols blobs = ParseTreeSymbolResponse . V.fromList . toList <$> distributeFor blobs go
|
||||
where
|
||||
go :: ParseEffects sig m => PerLanguageModes -> Blob -> m File
|
||||
go modes blob@Blob{..}
|
||||
| Precise <- pythonMode modes
|
||||
, Python <- blobLanguage'
|
||||
= catching $ renderPreciseToSymbols <$> parse precisePythonParser blob
|
||||
| otherwise = catching $ withSomeTerm renderToSymbols <$> doParse blob
|
||||
go :: (Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Carrier sig m) => Blob -> m File
|
||||
go blob@Blob{..} = catching $ doParse (pure . renderToSymbols) symbolsToSummarize blob
|
||||
where
|
||||
catching m = m `catchError` (\(SomeException e) -> pure $ errorFile (show e))
|
||||
blobLanguage' = blobLanguage blob
|
||||
blobPath' = pack $ blobPath blob
|
||||
errorFile e = File blobPath' (bridging # blobLanguage') mempty (V.fromList [ParseError (T.pack e)]) blobOid
|
||||
|
||||
renderToSymbols :: IsTaggable f => Term f Loc -> File
|
||||
renderToSymbols term = tagsToFile (runTagging blob symbolsToSummarize term)
|
||||
|
||||
renderPreciseToSymbols :: Py.Term Loc -> File
|
||||
renderPreciseToSymbols term = tagsToFile (Precise.tags blobSource term)
|
||||
renderToSymbols :: Precise.ToTags t => t Loc -> File
|
||||
renderToSymbols term = tagsToFile (Precise.tags blobSource term)
|
||||
|
||||
tagsToFile :: [Tag] -> File
|
||||
tagsToFile tags = File blobPath' (bridging # blobLanguage') (V.fromList (fmap tagToSymbol tags)) mempty blobOid
|
||||
@ -98,3 +88,40 @@ tagToSymbol Tag{..} = Symbol
|
||||
, span = converting #? span
|
||||
, docs = fmap Docstring docs
|
||||
}
|
||||
|
||||
|
||||
data ALaCarteTerm syntax ann = ALaCarteTerm Language [Text] (Term syntax ann)
|
||||
|
||||
instance IsTaggable syntax => Precise.ToTags (ALaCarteTerm syntax) where
|
||||
tags source (ALaCarteTerm lang symbolsToSummarize term) = runTagging lang source symbolsToSummarize term
|
||||
|
||||
|
||||
doParse
|
||||
:: ( Carrier sig m
|
||||
, Member (Error SomeException) sig
|
||||
, Member Parse sig
|
||||
, Member (Reader PerLanguageModes) sig
|
||||
)
|
||||
=> (forall t . Precise.ToTags t => t Loc -> m a)
|
||||
-> [Text]
|
||||
-> Blob
|
||||
-> m a
|
||||
doParse with symbolsToSummarize blob = do
|
||||
modes <- ask @PerLanguageModes
|
||||
case blobLanguage blob of
|
||||
Go -> parse Parser.goParser blob >>= with . mkTerm
|
||||
Haskell -> parse Parser.haskellParser blob >>= with . mkTerm
|
||||
JavaScript -> parse Parser.tsxParser blob >>= with . mkTerm
|
||||
JSON -> parse Parser.jsonParser blob >>= with . mkTerm
|
||||
JSX -> parse Parser.tsxParser blob >>= with . mkTerm
|
||||
Markdown -> parse Parser.markdownParser blob >>= with . mkTerm
|
||||
Python
|
||||
| Precise <- pythonMode modes -> parse Parser.precisePythonParser blob >>= with
|
||||
| otherwise -> parse Parser.pythonParser blob >>= with . mkTerm
|
||||
Ruby -> parse Parser.rubyParser blob >>= with . mkTerm
|
||||
TypeScript -> parse Parser.typescriptParser blob >>= with . mkTerm
|
||||
TSX -> parse Parser.tsxParser blob >>= with . mkTerm
|
||||
PHP -> parse Parser.phpParser blob >>= with . mkTerm
|
||||
_ -> noLanguageForBlob (blobPath blob)
|
||||
where mkTerm :: Term syntax Loc -> ALaCarteTerm syntax Loc
|
||||
mkTerm = ALaCarteTerm (blobLanguage blob) symbolsToSummarize
|
||||
|
||||
@ -1,14 +1,10 @@
|
||||
{-# LANGUAGE GADTs, TypeOperators, DerivingStrategies, LambdaCase #-}
|
||||
module Semantic.Api.TOCSummaries (diffSummary, legacyDiffSummary, diffSummaryBuilder) where
|
||||
|
||||
import Analysis.Decorator (decoratorWithAlgebra)
|
||||
import Analysis.TOCSummary (Declaration, declarationAlgebra)
|
||||
import Control.Effect.Error
|
||||
import Control.Lens
|
||||
import Data.Aeson
|
||||
import Data.Blob
|
||||
import Data.ByteString.Builder
|
||||
import Data.Diff
|
||||
import qualified Data.Map.Monoidal as Map
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Vector as V
|
||||
@ -20,46 +16,26 @@ import Semantic.Proto.SemanticPB hiding (Blob, BlobPair)
|
||||
import Semantic.Task as Task
|
||||
import Serializing.Format
|
||||
|
||||
diffSummaryBuilder :: (DiffEffects sig m) => Format DiffTreeTOCResponse -> [BlobPair] -> m Builder
|
||||
diffSummaryBuilder :: DiffEffects sig m => Format DiffTreeTOCResponse -> [BlobPair] -> m Builder
|
||||
diffSummaryBuilder format blobs = diffSummary blobs >>= serialize format
|
||||
|
||||
legacyDiffSummary :: (DiffEffects sig m) => [BlobPair] -> m Summaries
|
||||
legacyDiffSummary :: DiffEffects sig m => [BlobPair] -> m Summaries
|
||||
legacyDiffSummary = distributeFoldMap go
|
||||
where
|
||||
go :: (DiffEffects sig m) => BlobPair -> m Summaries
|
||||
go blobPair = doDiff blobPair (\ blob -> decoratorWithAlgebra (declarationAlgebra blob)) render
|
||||
go :: DiffEffects sig m => BlobPair -> m Summaries
|
||||
go blobPair = doDiff legacyDecorateTerm (pure . legacySummarizeDiff blobPair) blobPair
|
||||
`catchError` \(SomeException e) ->
|
||||
pure $ Summaries mempty (Map.singleton path [toJSON (ErrorSummary (T.pack (show e)) lowerBound lang)])
|
||||
where path = T.pack $ pathKeyForBlobPair blobPair
|
||||
lang = languageForBlobPair blobPair
|
||||
|
||||
render :: (Foldable syntax, Functor syntax, Applicative m) => BlobPair -> Diff syntax (Maybe Declaration) (Maybe Declaration) -> m Summaries
|
||||
render blobPair = pure . renderToCDiff blobPair
|
||||
|
||||
diffSummary :: (DiffEffects sig m) => [BlobPair] -> m DiffTreeTOCResponse
|
||||
diffSummary :: DiffEffects sig m => [BlobPair] -> m DiffTreeTOCResponse
|
||||
diffSummary blobs = DiffTreeTOCResponse . V.fromList <$> distributeFor blobs go
|
||||
where
|
||||
go :: (DiffEffects sig m) => BlobPair -> m TOCSummaryFile
|
||||
go blobPair = doDiff blobPair (\ blob -> decoratorWithAlgebra (declarationAlgebra blob)) render
|
||||
go :: DiffEffects sig m => BlobPair -> m TOCSummaryFile
|
||||
go blobPair = doDiff decorateTerm (pure . summarizeDiff blobPair) blobPair
|
||||
`catchError` \(SomeException e) ->
|
||||
pure $ TOCSummaryFile path lang mempty (V.fromList [TOCSummaryError (T.pack (show e)) Nothing])
|
||||
where path = T.pack $ pathKeyForBlobPair blobPair
|
||||
lang = bridging # languageForBlobPair blobPair
|
||||
|
||||
render :: (Foldable syntax, Functor syntax, Applicative m) => BlobPair -> Diff syntax (Maybe Declaration) (Maybe Declaration) -> m TOCSummaryFile
|
||||
render blobPair diff = pure $ foldr go (TOCSummaryFile path lang mempty mempty) (diffTOC diff)
|
||||
where
|
||||
path = T.pack $ pathKeyForBlobPair blobPair
|
||||
lang = bridging # languageForBlobPair blobPair
|
||||
|
||||
toChangeType = \case
|
||||
"added" -> Added
|
||||
"modified" -> Modified
|
||||
"removed" -> Removed
|
||||
_ -> None
|
||||
|
||||
go :: TOCSummary -> TOCSummaryFile -> TOCSummaryFile
|
||||
go TOCSummary{..} TOCSummaryFile{..}
|
||||
= TOCSummaryFile path language (V.cons (TOCSummaryChange summaryCategoryName summaryTermName (converting #? summarySpan) (toChangeType summaryChangeType)) changes) errors
|
||||
go ErrorSummary{..} TOCSummaryFile{..}
|
||||
= TOCSummaryFile path language changes (V.cons (TOCSummaryError errorText (converting #? errorSpan)) errors)
|
||||
|
||||
@ -1,19 +1,10 @@
|
||||
{-# LANGUAGE ConstraintKinds, GADTs, TypeOperators, DerivingStrategies #-}
|
||||
{-# LANGUAGE ConstraintKinds, MonoLocalBinds, RankNTypes #-}
|
||||
module Semantic.Api.Terms
|
||||
(
|
||||
termGraph
|
||||
( termGraph
|
||||
, parseTermBuilder
|
||||
, TermOutputFormat(..)
|
||||
|
||||
, doParse
|
||||
, ParseEffects
|
||||
, TermConstraints
|
||||
|
||||
, SomeTerm(..)
|
||||
, withSomeTerm
|
||||
) where
|
||||
|
||||
|
||||
import Analysis.ConstructorName (ConstructorName)
|
||||
import Control.Effect.Error
|
||||
import Control.Effect.Parse
|
||||
@ -21,7 +12,6 @@ import Control.Effect.Reader
|
||||
import Control.Lens
|
||||
import Control.Monad
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Abstract.Declarations
|
||||
import Data.Blob
|
||||
import Data.ByteString.Builder
|
||||
import Data.Either
|
||||
@ -44,23 +34,20 @@ import Semantic.Task
|
||||
import Serializing.Format hiding (JSON)
|
||||
import qualified Serializing.Format as Format
|
||||
import Source.Loc
|
||||
import Tags.Taggable
|
||||
|
||||
import qualified Language.Python as Py
|
||||
|
||||
termGraph :: (Traversable t, Member Distribute sig, ParseEffects sig m) => t Blob -> m ParseTreeGraphResponse
|
||||
termGraph blobs = ParseTreeGraphResponse . V.fromList . toList <$> distributeFor blobs go
|
||||
where
|
||||
go :: ParseEffects sig m => Blob -> m ParseTreeFileGraph
|
||||
go blob = (doParse blob >>= withSomeTerm (pure . render))
|
||||
go blob = doParse (pure . jsonGraphTerm blob) blob
|
||||
`catchError` \(SomeException e) ->
|
||||
pure (ParseTreeFileGraph path lang mempty mempty (V.fromList [ParseError (T.pack (show e))]))
|
||||
where
|
||||
path = T.pack $ blobPath blob
|
||||
lang = bridging # blobLanguage blob
|
||||
|
||||
render :: (Foldable syntax, Functor syntax, ConstructorName syntax) => Term syntax Loc -> ParseTreeFileGraph
|
||||
render t = let graph = renderTreeGraph t
|
||||
toEdge (Edge (a, b)) = TermEdge (vertexId a) (vertexId b)
|
||||
in ParseTreeFileGraph path lang (V.fromList (vertexList graph)) (V.fromList (fmap toEdge (edgeList graph))) mempty
|
||||
|
||||
data TermOutputFormat
|
||||
= TermJSONTree
|
||||
@ -75,28 +62,19 @@ parseTermBuilder :: (Traversable t, Member Distribute sig, ParseEffects sig m, M
|
||||
=> TermOutputFormat -> t Blob -> m Builder
|
||||
parseTermBuilder TermJSONTree = distributeFoldMap jsonTerm >=> serialize Format.JSON -- NB: Serialize happens at the top level for these two JSON formats to collect results of multiple blobs.
|
||||
parseTermBuilder TermJSONGraph = termGraph >=> serialize Format.JSON
|
||||
parseTermBuilder TermSExpression = distributeFoldMap sexpTerm
|
||||
parseTermBuilder TermDotGraph = distributeFoldMap dotGraphTerm
|
||||
parseTermBuilder TermShow = distributeFoldMap showTerm
|
||||
parseTermBuilder TermSExpression = distributeFoldMap (doParse sexprTerm)
|
||||
parseTermBuilder TermDotGraph = distributeFoldMap (doParse dotGraphTerm)
|
||||
parseTermBuilder TermShow = distributeFoldMap (doParse showTerm)
|
||||
parseTermBuilder TermQuiet = distributeFoldMap quietTerm
|
||||
|
||||
jsonTerm :: (ParseEffects sig m) => Blob -> m (Rendering.JSON.JSON "trees" SomeJSON)
|
||||
jsonTerm blob = (doParse blob >>= withSomeTerm (pure . renderJSONTerm blob)) `catchError` jsonError blob
|
||||
jsonTerm :: ParseEffects sig m => Blob -> m (Rendering.JSON.JSON "trees" SomeJSON)
|
||||
jsonTerm blob = doParse (pure . jsonTreeTerm blob) blob `catchError` jsonError blob
|
||||
|
||||
jsonError :: Applicative m => Blob -> SomeException -> m (Rendering.JSON.JSON "trees" SomeJSON)
|
||||
jsonError blob (SomeException e) = pure $ renderJSONError blob (show e)
|
||||
|
||||
sexpTerm :: (ParseEffects sig m) => Blob -> m Builder
|
||||
sexpTerm = doParse >=> withSomeTerm (serialize (SExpression ByConstructorName))
|
||||
|
||||
dotGraphTerm :: (ParseEffects sig m) => Blob -> m Builder
|
||||
dotGraphTerm = doParse >=> withSomeTerm (serialize (DOT (termStyle "terms")) . renderTreeGraph)
|
||||
|
||||
showTerm :: (ParseEffects sig m) => Blob -> m Builder
|
||||
showTerm = doParse >=> withSomeTerm (serialize Show . quieterm)
|
||||
|
||||
quietTerm :: (ParseEffects sig m, MonadIO m) => Blob -> m Builder
|
||||
quietTerm blob = showTiming blob <$> time' ( (doParse blob >>= withSomeTerm (fmap (const (Right ())) . serialize Show . quieterm)) `catchError` timingError )
|
||||
quietTerm blob = showTiming blob <$> time' ( doParse (fmap (const (Right ())) . showTerm) blob `catchError` timingError )
|
||||
where
|
||||
timingError (SomeException e) = pure (Left (show e))
|
||||
showTiming Blob{..} (res, duration) =
|
||||
@ -106,27 +84,70 @@ quietTerm blob = showTiming blob <$> time' ( (doParse blob >>= withSomeTerm (fma
|
||||
|
||||
type ParseEffects sig m = (Member (Error SomeException) sig, Member (Reader PerLanguageModes) sig, Member Parse sig, Member (Reader Config) sig, Carrier sig m)
|
||||
|
||||
type TermConstraints =
|
||||
'[ Taggable
|
||||
, Declarations1
|
||||
, ConstructorName
|
||||
, HasTextElement
|
||||
, Show1
|
||||
, ToJSONFields1
|
||||
, Traversable
|
||||
]
|
||||
|
||||
doParse :: (ParseEffects sig m) => Blob -> m (SomeTerm TermConstraints Loc)
|
||||
doParse blob = case blobLanguage blob of
|
||||
Go -> SomeTerm <$> parse goParser blob
|
||||
Haskell -> SomeTerm <$> parse haskellParser blob
|
||||
JavaScript -> SomeTerm <$> parse tsxParser blob
|
||||
JSON -> SomeTerm <$> parse jsonParser blob
|
||||
JSX -> SomeTerm <$> parse tsxParser blob
|
||||
Markdown -> SomeTerm <$> parse markdownParser blob
|
||||
Python -> SomeTerm <$> parse pythonParser blob
|
||||
Ruby -> SomeTerm <$> parse rubyParser blob
|
||||
TypeScript -> SomeTerm <$> parse typescriptParser blob
|
||||
TSX -> SomeTerm <$> parse tsxParser blob
|
||||
PHP -> SomeTerm <$> parse phpParser blob
|
||||
class ShowTerm term where
|
||||
showTerm :: (Carrier sig m, Member (Reader Config) sig) => term Loc -> m Builder
|
||||
|
||||
instance (Functor syntax, Show1 syntax) => ShowTerm (Term syntax) where
|
||||
showTerm = serialize Show . quieterm
|
||||
|
||||
instance ShowTerm Py.Term where
|
||||
showTerm = serialize Show . Py.getTerm
|
||||
|
||||
|
||||
class SExprTerm term where
|
||||
sexprTerm :: (Carrier sig m, Member (Reader Config) sig) => term Loc -> m Builder
|
||||
|
||||
instance (ConstructorName syntax, Foldable syntax, Functor syntax) => SExprTerm (Term syntax) where
|
||||
sexprTerm = serialize (SExpression ByConstructorName)
|
||||
|
||||
|
||||
class DOTGraphTerm term where
|
||||
dotGraphTerm :: (Carrier sig m, Member (Reader Config) sig) => term Loc -> m Builder
|
||||
|
||||
instance (ConstructorName syntax, Foldable syntax, Functor syntax) => DOTGraphTerm (Term syntax) where
|
||||
dotGraphTerm = serialize (DOT (termStyle "terms")) . renderTreeGraph
|
||||
|
||||
|
||||
class JSONTreeTerm term where
|
||||
jsonTreeTerm :: Blob -> term Loc -> Rendering.JSON.JSON "trees" SomeJSON
|
||||
|
||||
instance ToJSONFields1 syntax => JSONTreeTerm (Term syntax) where
|
||||
jsonTreeTerm = renderJSONTerm
|
||||
|
||||
|
||||
class JSONGraphTerm term where
|
||||
jsonGraphTerm :: Blob -> term Loc -> ParseTreeFileGraph
|
||||
|
||||
instance (Foldable syntax, Functor syntax, ConstructorName syntax) => JSONGraphTerm (Term syntax) where
|
||||
jsonGraphTerm blob t
|
||||
= let graph = renderTreeGraph t
|
||||
toEdge (Edge (a, b)) = TermEdge (vertexId a) (vertexId b)
|
||||
in ParseTreeFileGraph path lang (V.fromList (vertexList graph)) (V.fromList (fmap toEdge (edgeList graph))) mempty where
|
||||
path = T.pack $ blobPath blob
|
||||
lang = bridging # blobLanguage blob
|
||||
|
||||
|
||||
type TermActions t = (DOTGraphTerm t, JSONGraphTerm t, JSONTreeTerm t, SExprTerm t, ShowTerm t)
|
||||
|
||||
doParse
|
||||
:: ( Carrier sig m
|
||||
, Member (Error SomeException) sig
|
||||
, Member Parse sig
|
||||
)
|
||||
=> (forall term . TermActions term => term Loc -> m a)
|
||||
-> Blob
|
||||
-> m a
|
||||
doParse with blob = case blobLanguage blob of
|
||||
Go -> parse goParser blob >>= with
|
||||
Haskell -> parse haskellParser blob >>= with
|
||||
JavaScript -> parse tsxParser blob >>= with
|
||||
JSON -> parse jsonParser blob >>= with
|
||||
JSX -> parse tsxParser blob >>= with
|
||||
Markdown -> parse markdownParser blob >>= with
|
||||
Python -> parse pythonParser blob >>= with
|
||||
Ruby -> parse rubyParser blob >>= with
|
||||
TypeScript -> parse typescriptParser blob >>= with
|
||||
TSX -> parse tsxParser blob >>= with
|
||||
PHP -> parse phpParser blob >>= with
|
||||
_ -> noLanguageForBlob (blobPath blob)
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE DataKinds, FlexibleContexts, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, ScopedTypeVariables, TypeApplications, TypeFamilies, TypeOperators, UndecidableInstances #-}
|
||||
module Serializing.SExpression.Precise
|
||||
( serializeSExpression
|
||||
, ToSExpression(..)
|
||||
) where
|
||||
|
||||
import Data.ByteString.Builder
|
||||
|
||||
@ -29,7 +29,6 @@ import Analysis.ConstructorName
|
||||
import Analysis.HasTextElement
|
||||
import Data.Abstract.Declarations
|
||||
import Data.Abstract.Name
|
||||
import Data.Blob
|
||||
import Data.Language
|
||||
import Data.Term
|
||||
import Data.Text hiding (empty)
|
||||
@ -99,10 +98,10 @@ type IsTaggable syntax =
|
||||
)
|
||||
|
||||
tagging :: (Monad m, IsTaggable syntax)
|
||||
=> Blob
|
||||
=> Language
|
||||
-> Term syntax Loc
|
||||
-> Stream (Of Token) m ()
|
||||
tagging b = foldSubterms (descend (blobLanguage b))
|
||||
tagging = foldSubterms . descend
|
||||
|
||||
descend ::
|
||||
( ConstructorName (TermF syntax Loc)
|
||||
|
||||
@ -14,7 +14,7 @@ import Data.Text as T hiding (empty)
|
||||
import Streaming
|
||||
import qualified Streaming.Prelude as Streaming
|
||||
|
||||
import Data.Blob
|
||||
import Data.Language
|
||||
import Data.Term
|
||||
import Source.Loc
|
||||
import qualified Source.Source as Source
|
||||
@ -22,16 +22,17 @@ import Tags.Tag
|
||||
import Tags.Taggable
|
||||
|
||||
runTagging :: (IsTaggable syntax)
|
||||
=> Blob
|
||||
=> Language
|
||||
-> Source.Source
|
||||
-> [Text]
|
||||
-> Term syntax Loc
|
||||
-> [Tag]
|
||||
runTagging blob symbolsToSummarize
|
||||
runTagging lang source symbolsToSummarize
|
||||
= Eff.run
|
||||
. evalState @[ContextToken] []
|
||||
. Streaming.toList_
|
||||
. contextualizing blob toKind
|
||||
. tagging blob
|
||||
. contextualizing source toKind
|
||||
. tagging lang
|
||||
where
|
||||
toKind x = do
|
||||
guard (x `elem` symbolsToSummarize)
|
||||
@ -49,11 +50,11 @@ type ContextToken = (Text, Range)
|
||||
contextualizing :: ( Member (State [ContextToken]) sig
|
||||
, Carrier sig m
|
||||
)
|
||||
=> Blob
|
||||
=> Source.Source
|
||||
-> (Text -> Maybe Kind)
|
||||
-> Stream (Of Token) m a
|
||||
-> Stream (Of Tag) m a
|
||||
contextualizing Blob{..} toKind = Streaming.mapMaybeM $ \case
|
||||
contextualizing source toKind = Streaming.mapMaybeM $ \case
|
||||
Enter x r -> Nothing <$ enterScope (x, r)
|
||||
Exit x r -> Nothing <$ exitScope (x, r)
|
||||
Iden iden span docsLiteralRange -> get @[ContextToken] >>= pure . \case
|
||||
@ -63,7 +64,7 @@ contextualizing Blob{..} toKind = Streaming.mapMaybeM $ \case
|
||||
-> Just $ Tag iden kind span (firstLine (slice r)) (slice <$> docsLiteralRange)
|
||||
_ -> Nothing
|
||||
where
|
||||
slice = stripEnd . Source.toText . Source.slice blobSource
|
||||
slice = stripEnd . Source.toText . Source.slice source
|
||||
firstLine = T.take 180 . fst . breakOn "\n"
|
||||
|
||||
enterScope, exitScope :: ( Member (State [ContextToken]) sig
|
||||
|
||||
@ -10,40 +10,40 @@ spec = do
|
||||
describe "go" $ do
|
||||
it "produces tags for functions with docs" $ do
|
||||
(blob, tree) <- parseTestFile goParser (Path.relFile "test/fixtures/go/tags/simple_functions.go")
|
||||
runTagging blob symbolsToSummarize tree `shouldBe`
|
||||
runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
|
||||
[ Tag "TestFromBits" Function (Span (Pos 6 1) (Pos 8 2)) "func TestFromBits(t *testing.T) {" (Just "// TestFromBits ...")
|
||||
, Tag "Hi" Function (Span (Pos 10 1) (Pos 11 2)) "func Hi()" Nothing ]
|
||||
|
||||
it "produces tags for methods" $ do
|
||||
(blob, tree) <- parseTestFile goParser (Path.relFile "test/fixtures/go/tags/method.go")
|
||||
runTagging blob symbolsToSummarize tree `shouldBe`
|
||||
runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
|
||||
[ Tag "CheckAuth" Method (Span (Pos 3 1) (Pos 3 100)) "func (c *apiClient) CheckAuth(req *http.Request, user, repo string) (*authenticatedActor, error)" Nothing]
|
||||
|
||||
it "produces tags for calls" $ do
|
||||
(blob, tree) <- parseTestFile goParser (Path.relFile "test/fixtures/go/tags/simple_functions.go")
|
||||
runTagging blob ["Call"] tree `shouldBe`
|
||||
runTagging (blobLanguage blob) (blobSource blob) ["Call"] tree `shouldBe`
|
||||
[ Tag "Hi" Call (Span (Pos 7 2) (Pos 7 6)) "Hi()" Nothing]
|
||||
|
||||
describe "javascript and typescript" $ do
|
||||
it "produces tags for functions with docs" $ do
|
||||
(blob, tree) <- parseTestFile typescriptParser (Path.relFile "test/fixtures/javascript/tags/simple_function_with_docs.js")
|
||||
runTagging blob symbolsToSummarize tree `shouldBe`
|
||||
runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
|
||||
[ Tag "myFunction" Function (Span (Pos 2 1) (Pos 4 2)) "function myFunction()" (Just "// This is myFunction") ]
|
||||
|
||||
it "produces tags for classes" $ do
|
||||
(blob, tree) <- parseTestFile typescriptParser (Path.relFile "test/fixtures/typescript/tags/class.ts")
|
||||
runTagging blob symbolsToSummarize tree `shouldBe`
|
||||
runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
|
||||
[ Tag "FooBar" Class (Span (Pos 1 1) (Pos 1 16)) "class FooBar" Nothing ]
|
||||
|
||||
it "produces tags for modules" $ do
|
||||
(blob, tree) <- parseTestFile typescriptParser (Path.relFile "test/fixtures/typescript/tags/module.ts")
|
||||
runTagging blob symbolsToSummarize tree `shouldBe`
|
||||
runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
|
||||
[ Tag "APromise" Tags.Module (Span (Pos 1 1) (Pos 1 20)) "module APromise { }" Nothing ]
|
||||
|
||||
describe "python" $ do
|
||||
it "produces tags for functions" $ do
|
||||
(blob, tree) <- parseTestFile pythonParser (Path.relFile "test/fixtures/python/tags/simple_functions.py")
|
||||
runTagging blob symbolsToSummarize tree `shouldBe`
|
||||
runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
|
||||
[ Tag "Foo" Function (Span (Pos 1 1) (Pos 5 17)) "def Foo(x):" Nothing
|
||||
, Tag "Bar" Function (Span (Pos 7 1) (Pos 11 13)) "def Bar():" Nothing
|
||||
, Tag "local" Function (Span (Pos 8 5) (Pos 9 17)) "def local():" Nothing
|
||||
@ -51,30 +51,30 @@ spec = do
|
||||
|
||||
it "produces tags for functions with docs" $ do
|
||||
(blob, tree) <- parseTestFile pythonParser (Path.relFile "test/fixtures/python/tags/simple_function_with_docs.py")
|
||||
runTagging blob symbolsToSummarize tree `shouldBe`
|
||||
runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
|
||||
[ Tag "Foo" Function (Span (Pos 1 1) (Pos 3 13)) "def Foo(x):" (Just "\"\"\"This is the foo function\"\"\"") ]
|
||||
|
||||
it "produces tags for classes" $ do
|
||||
(blob, tree) <- parseTestFile pythonParser (Path.relFile "test/fixtures/python/tags/class.py")
|
||||
runTagging blob symbolsToSummarize tree `shouldBe`
|
||||
runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
|
||||
[ Tag "Foo" Class (Span (Pos 1 1) (Pos 5 17)) "class Foo:" (Just "\"\"\"The Foo class\"\"\"")
|
||||
, Tag "f" Function (Span (Pos 3 5) (Pos 5 17)) "def f(self):" (Just "\"\"\"The f method\"\"\"")
|
||||
]
|
||||
|
||||
it "produces tags for multi-line functions" $ do
|
||||
(blob, tree) <- parseTestFile pythonParser (Path.relFile "test/fixtures/python/tags/multiline.py")
|
||||
runTagging blob symbolsToSummarize tree `shouldBe`
|
||||
runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
|
||||
[ Tag "Foo" Function (Span (Pos 1 1) (Pos 3 13)) "def Foo(x," Nothing ]
|
||||
|
||||
describe "ruby" $ do
|
||||
it "produces tags for methods" $ do
|
||||
(blob, tree) <- parseTestFile rubyParser (Path.relFile "test/fixtures/ruby/tags/simple_method.rb")
|
||||
runTagging blob symbolsToSummarize tree `shouldBe`
|
||||
runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
|
||||
[ Tag "foo" Method (Span (Pos 1 1) (Pos 4 4)) "def foo" Nothing ]
|
||||
|
||||
it "produces tags for sends" $ do
|
||||
(blob, tree) <- parseTestFile rubyParser (Path.relFile "test/fixtures/ruby/tags/simple_method.rb")
|
||||
runTagging blob ["Send"] tree `shouldBe`
|
||||
runTagging (blobLanguage blob) (blobSource blob) ["Send"] tree `shouldBe`
|
||||
[ Tag "puts" Call (Span (Pos 2 3) (Pos 2 12)) "puts \"hi\"" Nothing
|
||||
, Tag "bar" Call (Span (Pos 3 3) (Pos 3 8)) "a.bar" Nothing
|
||||
, Tag "a" Call (Span (Pos 3 3) (Pos 3 4)) "a" Nothing
|
||||
@ -82,17 +82,17 @@ spec = do
|
||||
|
||||
it "produces tags for methods with docs" $ do
|
||||
(blob, tree) <- parseTestFile rubyParser (Path.relFile "test/fixtures/ruby/tags/simple_method_with_docs.rb")
|
||||
runTagging blob symbolsToSummarize tree `shouldBe`
|
||||
runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
|
||||
[ Tag "foo" Method (Span (Pos 2 1) (Pos 3 4)) "def foo" (Just "# Public: foo") ]
|
||||
|
||||
it "correctly tags files containing multibyte UTF-8 characters" $ do
|
||||
(blob, tree) <- parseTestFile rubyParser (Path.relFile "test/fixtures/ruby/tags/unicode_identifiers.rb")
|
||||
runTagging blob symbolsToSummarize tree `shouldBe`
|
||||
runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
|
||||
[ Tag "日本語" Method (Span (Pos 2 1) (Pos 4 4)) "def 日本語" (Just "# coding: utf-8")]
|
||||
|
||||
it "produces tags for methods and classes with docs" $ do
|
||||
(blob, tree) <- parseTestFile rubyParser (Path.relFile "test/fixtures/ruby/tags/class_module.rb")
|
||||
runTagging blob symbolsToSummarize tree `shouldBe`
|
||||
runTagging (blobLanguage blob) (blobSource blob) symbolsToSummarize tree `shouldBe`
|
||||
[ Tag "Foo" Tags.Module (Span (Pos 2 1 ) (Pos 12 4)) "module Foo" (Just "# Public: Foo")
|
||||
, Tag "Bar" Class (Span (Pos 5 3 ) (Pos 11 6)) "class Bar" (Just "# Public: Bar")
|
||||
, Tag "baz" Method (Span (Pos 8 5 ) (Pos 10 8)) "def baz(a)" (Just "# Public: baz")
|
||||
|
||||
Loading…
Reference in New Issue
Block a user