github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-26 09:07:39 +03:00
Code Issues Projects Releases Wiki Activity

Generate Def/Ref at moment of tagging

Browse Source
This commit is contained in:
Timothy Clem 2020-06-04 10:39:15 -07:00
parent 38a7158b20
commit 2e44d43452
15 changed files with 149 additions and 530 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

24
semantic-codeql/src/Language/CodeQL/Tags.hs
View File

@ -55,59 +55,59 @@ gtags ::
m ()
gtags = traverse1_ @ToTags (const (pure ())) tags
yieldTag :: (Has (Reader Source) sig m, Has (Writer Tags.Tags) sig m) => Text -> P.SyntaxType -> Loc -> Range -> m ()
yieldTag name kind loc srcLineRange = do
yieldTag :: (Has (Reader Source) sig m, Has (Writer Tags.Tags) sig m) => Text -> P.SyntaxType -> P.NodeType -> Loc -> Range -> m ()
yieldTag name kind ty loc srcLineRange = do
src <- ask @Source
Tags.yield (Tag name kind loc (Tags.firstLine src srcLineRange) Nothing)
Tags.yield (Tag name kind ty loc (Tags.firstLine src srcLineRange) Nothing)
instance ToTags CodeQL.Module where
tags
t@CodeQL.Module
{ ann = Loc {byteRange},
name = CodeQL.ModuleName {extraChildren = CodeQL.SimpleId {text, ann}}
} = yieldTag text P.MODULE ann byteRange >> gtags t
} = yieldTag text P.MODULE P.DEFINITION ann byteRange >> gtags t
instance ToTags CodeQL.ClasslessPredicate where
tags
t@CodeQL.ClasslessPredicate
{ ann = Loc {byteRange},
name = CodeQL.PredicateName {text, ann}
} = yieldTag text P.FUNCTION ann byteRange >> gtags t
} = yieldTag text P.FUNCTION P.DEFINITION ann byteRange >> gtags t
instance ToTags CodeQL.AritylessPredicateExpr where
tags
t@CodeQL.AritylessPredicateExpr
{ ann = Loc {byteRange},
name = CodeQL.LiteralId {text, ann}
} = yieldTag text P.CALL ann byteRange >> gtags t
} = yieldTag text P.CALL P.REFERENCE ann byteRange >> gtags t
instance ToTags CodeQL.Dataclass where
tags
t@CodeQL.Dataclass
{ ann = Loc {byteRange},
name = CodeQL.ClassName {text, ann}
} = yieldTag text P.CLASS ann byteRange >> gtags t
} = yieldTag text P.CLASS P.DEFINITION ann byteRange >> gtags t
instance ToTags CodeQL.MemberPredicate where
tags
t@CodeQL.MemberPredicate
{ ann = Loc {byteRange},
name = CodeQL.PredicateName {text, ann}
} = yieldTag text P.METHOD ann byteRange >> gtags t
} = yieldTag text P.METHOD P.DEFINITION ann byteRange >> gtags t
instance ToTags CodeQL.Datatype where
tags
t@CodeQL.Datatype
{ ann = Loc {byteRange},
name = CodeQL.ClassName {text, ann}
} = yieldTag text P.CLASS ann byteRange >> gtags t
} = yieldTag text P.CLASS P.DEFINITION ann byteRange >> gtags t
instance ToTags CodeQL.DatatypeBranch where
tags
t@CodeQL.DatatypeBranch
{ ann = Loc {byteRange},
name = CodeQL.ClassName {text, ann}
} = yieldTag text P.CLASS ann byteRange >> gtags t
} = yieldTag text P.CLASS P.DEFINITION ann byteRange >> gtags t
instance ToTags CodeQL.ClasslessPredicateCall where
tags
@ -123,7 +123,7 @@ instance ToTags CodeQL.QualifiedRhs where
{ ann = Loc {byteRange},
name = expr
} = case expr of
Just (Prj CodeQL.PredicateName {text, ann}) -> yieldTag text P.CALL ann byteRange >> gtags t
Just (Prj CodeQL.PredicateName {text, ann}) -> yieldTag text P.CALL P.REFERENCE ann byteRange >> gtags t
_ -> gtags t
instance ToTags CodeQL.TypeExpr where
@ -132,7 +132,7 @@ instance ToTags CodeQL.TypeExpr where
{ ann = Loc {byteRange},
name = expr
} = case expr of
Just (Prj CodeQL.ClassName {text, ann}) -> yieldTag text P.TYPE ann byteRange >> gtags t
Just (Prj CodeQL.ClassName {text, ann}) -> yieldTag text P.TYPE P.REFERENCE ann byteRange >> gtags t
_ -> gtags t
instance ToTags CodeQL.AddExpr

12
semantic-go/src/Language/Go/Tags.hs
View File

@ -43,14 +43,14 @@ instance ToTags Go.FunctionDeclaration where
t@Go.FunctionDeclaration
{ ann = Loc {byteRange},
name = Go.Identifier {text, ann}
} = yieldTag text P.FUNCTION ann byteRange >> gtags t
} = yieldTag text P.FUNCTION P.DEFINITION ann byteRange >> gtags t
instance ToTags Go.MethodDeclaration where
tags
t@Go.MethodDeclaration
{ ann = Loc {byteRange},
name = Go.FieldIdentifier {text, ann}
} = yieldTag text P.METHOD ann byteRange >> gtags t
} = yieldTag text P.METHOD P.DEFINITION ann byteRange >> gtags t
instance ToTags Go.CallExpression where
tags
@ -65,7 +65,7 @@ instance ToTags Go.CallExpression where
Prj Go.CallExpression {function = Go.Expression e} -> match e
Prj Go.ParenthesizedExpression {extraChildren = Go.Expression e} -> match e
_ -> gtags t
yield name loc = yieldTag name P.CALL loc byteRange >> gtags t
yield name loc = yieldTag name P.CALL P.REFERENCE loc byteRange >> gtags t
instance (ToTags l, ToTags r) => ToTags (l :+: r) where
tags (L1 l) = tags l
@ -82,10 +82,10 @@ gtags ::
m ()
gtags = traverse1_ @ToTags (const (pure ())) tags
yieldTag :: (Has (Reader Source) sig m, Has (Writer Tags.Tags) sig m) => Text -> P.SyntaxType -> Loc -> Range -> m ()
yieldTag name kind loc srcLineRange = do
yieldTag :: (Has (Reader Source) sig m, Has (Writer Tags.Tags) sig m) => Text -> P.SyntaxType -> P.NodeType -> Loc -> Range -> m ()
yieldTag name kind ty loc srcLineRange = do
src <- ask @Source
Tags.yield (Tag name kind loc (Tags.firstLine src srcLineRange) Nothing)
Tags.yield (Tag name kind ty loc (Tags.firstLine src srcLineRange) Nothing)
instance ToTags Go.ArgumentList

10
semantic-java/src/Language/Java/Tags.hs
View File

@ -62,7 +62,7 @@ instance ToTags Java.MethodDeclaration where
Just Java.Block {ann = Loc Range {end} _} -> end
Nothing -> end range
}
Tags.yield (Tag text P.METHOD ann line Nothing)
Tags.yield (Tag text P.METHOD P.DEFINITION ann line Nothing)
gtags t
-- TODO: we can coalesce a lot of these instances given proper use of HasField
@ -76,7 +76,7 @@ instance ToTags Java.ClassDeclaration where
body = Java.ClassBody {ann = Loc Range {start = end} _}
} = do
src <- ask @Source
Tags.yield (Tag text P.CLASS ann (Tags.firstLine src (Range start end)) Nothing)
Tags.yield (Tag text P.CLASS P.DEFINITION ann (Tags.firstLine src (Range start end)) Nothing)
gtags t
instance ToTags Java.MethodInvocation where
@ -86,7 +86,7 @@ instance ToTags Java.MethodInvocation where
name = Java.Identifier {text, ann}
} = do
src <- ask @Source
Tags.yield (Tag text P.CALL ann (Tags.firstLine src range) Nothing)
Tags.yield (Tag text P.CALL P.REFERENCE ann (Tags.firstLine src range) Nothing)
gtags t
instance ToTags Java.InterfaceDeclaration where
@ -96,7 +96,7 @@ instance ToTags Java.InterfaceDeclaration where
name = Java.Identifier {text, ann}
} = do
src <- ask @Source
Tags.yield (Tag text P.INTERFACE ann (Tags.firstLine src byteRange) Nothing)
Tags.yield (Tag text P.INTERFACE P.DEFINITION ann (Tags.firstLine src byteRange) Nothing)
gtags t
instance ToTags Java.InterfaceTypeList where
@ -104,7 +104,7 @@ instance ToTags Java.InterfaceTypeList where
src <- ask @Source
for_ interfaces $ \x -> case x of
Java.Type (Prj (Java.UnannotatedType (Prj (Java.SimpleType (Prj Java.TypeIdentifier {ann = loc@Loc {byteRange = range}, text = name}))))) ->
Tags.yield (Tag name P.IMPLEMENTATION loc (Tags.firstLine src range) Nothing)
Tags.yield (Tag name P.IMPLEMENTATION P.REFERENCE loc (Tags.firstLine src range) Nothing)
_ -> pure ()
gtags t

14
semantic-php/src/Language/PHP/Tags.hs
View File

@ -55,24 +55,24 @@ gtags ::
m ()
gtags = traverse1_ @ToTags (const (pure ())) tags
yieldTag :: (Has (Reader Source) sig m, Has (Writer Tags.Tags) sig m) => Text -> P.SyntaxType -> Loc -> Range -> m ()
yieldTag name kind loc srcLineRange = do
yieldTag :: (Has (Reader Source) sig m, Has (Writer Tags.Tags) sig m) => Text -> P.SyntaxType -> P.NodeType -> Loc -> Range -> m ()
yieldTag name kind ty loc srcLineRange = do
src <- ask @Source
Tags.yield (Tag name kind loc (Tags.firstLine src srcLineRange) Nothing)
Tags.yield (Tag name kind ty loc (Tags.firstLine src srcLineRange) Nothing)
instance ToTags PHP.FunctionDefinition where
tags
t@PHP.FunctionDefinition
{ PHP.ann = Loc {byteRange},
PHP.name = PHP.Name {text, ann}
} = yieldTag text P.METHOD ann byteRange >> gtags t
} = yieldTag text P.METHOD P.DEFINITION ann byteRange >> gtags t
instance ToTags PHP.MethodDeclaration where
tags
t@PHP.MethodDeclaration
{ PHP.ann = Loc {byteRange},
PHP.name = PHP.Name {text, ann}
} = yieldTag text P.FUNCTION ann byteRange >> gtags t
} = yieldTag text P.FUNCTION P.DEFINITION ann byteRange >> gtags t
instance ToTags PHP.FunctionCallExpression where
tags
@ -81,7 +81,7 @@ instance ToTags PHP.FunctionCallExpression where
PHP.function = func
} = match func
where
yield name loc = yieldTag name P.CALL loc byteRange >> gtags t
yield name loc = yieldTag name P.CALL P.REFERENCE loc byteRange >> gtags t
match expr = case expr of
Prj PHP.VariableName {extraChildren = PHP.Name {text, ann}} -> yield text ann *> gtags t
Prj PHP.QualifiedName {extraChildren = [Prj PHP.Name {text, ann}]} -> yield text ann *> gtags t
@ -93,7 +93,7 @@ instance ToTags PHP.MemberCallExpression where
t@PHP.MemberCallExpression
{ PHP.ann = Loc {byteRange},
PHP.name = Prj PHP.Name {text, ann}
} = yieldTag text P.CALL ann byteRange >> gtags t
} = yieldTag text P.CALL P.REFERENCE ann byteRange >> gtags t
tags t = gtags t

14
semantic-python/src/Language/Python/Tags.hs
View File

@ -60,7 +60,7 @@ keywordFunctionCall ::
Range ->
Text ->
m ()
keywordFunctionCall t loc range name = yieldTag name P.FUNCTION loc range Nothing >> gtags t
keywordFunctionCall t loc range name = yieldTag name P.FUNCTION P.DEFINITION loc range Nothing >> gtags t
instance ToTags Py.String where
tags Py.String {extraChildren} = for_ extraChildren $ \x -> case x of
@ -102,7 +102,7 @@ instance ToTags Py.FunctionDefinition where
} = do
src <- ask @Source
let docs = listToMaybe extraChildren >>= docComment src
yieldTag text P.FUNCTION ann (Range start end) docs >> gtags t
yieldTag text P.FUNCTION P.DEFINITION ann (Range start end) docs >> gtags t
instance ToTags Py.ClassDefinition where
tags
@ -113,7 +113,7 @@ instance ToTags Py.ClassDefinition where
} = do
src <- ask @Source
let docs = listToMaybe extraChildren >>= docComment src
yieldTag text P.CLASS ann (Range start end) docs >> gtags t
yieldTag text P.CLASS P.DEFINITION ann (Range start end) docs >> gtags t
instance ToTags Py.Call where
tags
@ -128,12 +128,12 @@ instance ToTags Py.Call where
Prj Py.Call {function = Py.PrimaryExpression expr'} -> match expr' -- Nested call expression like this in Python represent creating an instance of a class and calling it: e.g. AClass()()
Prj (Py.ParenthesizedExpression _ (Prj (Py.Expression (Prj (Py.PrimaryExpression expr'))))) -> match expr' -- Parenthesized expressions
_ -> gtags t
yield name loc = yieldTag name P.CALL loc byteRange Nothing >> gtags t
yield name loc = yieldTag name P.CALL P.REFERENCE loc byteRange Nothing >> gtags t
yieldTag :: (Has (Reader Source) sig m, Has (Writer Tags.Tags) sig m) => Text -> P.SyntaxType -> Loc -> Range -> Maybe Text -> m ()
yieldTag name kind loc srcLineRange docs = do
yieldTag :: (Has (Reader Source) sig m, Has (Writer Tags.Tags) sig m) => Text -> P.SyntaxType -> P.NodeType -> Loc -> Range -> Maybe Text -> m ()
yieldTag name kind ty loc srcLineRange docs = do
src <- ask @Source
Tags.yield (Tag name kind loc (Tags.firstLine src srcLineRange) docs)
Tags.yield (Tag name kind ty loc (Tags.firstLine src srcLineRange) docs)
docComment :: Source -> (Py.CompoundStatement :+: Py.SimpleStatement) Loc -> Maybe Text
docComment src (R1 (Py.SimpleStatement (Prj Py.ExpressionStatement {extraChildren = L1 (Prj (Py.Expression (Prj (Py.PrimaryExpression (Prj Py.String {ann}))))) :| _}))) = Just (toText (slice src (byteRange ann)))

28
semantic-ruby/src/Language/Ruby/Tags.hs
View File

@ -73,11 +73,11 @@ nameBlacklist =
"lambda"
]
yieldTag :: (Has (Reader Source) sig m, Has (Writer Tags.Tags) sig m) => Text -> P.SyntaxType -> Loc -> Range -> m ()
yieldTag name P.CALL _ _ | name `elem` nameBlacklist = pure ()
yieldTag name kind loc srcLineRange = do
yieldTag :: (Has (Reader Source) sig m, Has (Writer Tags.Tags) sig m) => Text -> P.SyntaxType -> P.NodeType -> Loc -> Range -> m ()
yieldTag name P.CALL _ _ _ | name `elem` nameBlacklist = pure ()
yieldTag name kind ty loc srcLineRange = do
src <- ask @Source
Tags.yield (Tag name kind loc (Tags.firstLine src srcLineRange) Nothing)
Tags.yield (Tag name kind ty loc (Tags.firstLine src srcLineRange) Nothing)
instance ToTags Rb.Class where
tags
@ -95,7 +95,7 @@ instance ToTags Rb.Class where
Prj Rb.Superclass {ann = Loc {byteRange = Range {end}}} : _ -> Range start end
_ -> Range start (getEnd expr)
getEnd = Range.end . byteRange . TS.gann
yield name loc = yieldTag name P.CLASS loc range' >> gtags t
yield name loc = yieldTag name P.CLASS P.DEFINITION loc range' >> gtags t
instance ToTags Rb.SingletonClass where
tags
@ -113,7 +113,7 @@ instance ToTags Rb.SingletonClass where
x : _ -> Range start (getStart x)
_ -> range
getStart = Range.start . byteRange . TS.gann
yield name loc = yieldTag name P.CLASS loc range' >> gtags t
yield name loc = yieldTag name P.CLASS P.DEFINITION loc range' >> gtags t
instance ToTags Rb.Module where
tags
@ -132,7 +132,7 @@ instance ToTags Rb.Module where
_ -> Range start (getEnd expr)
getEnd = Range.end . byteRange . TS.gann
getStart = Range.start . byteRange . TS.gann
yield name loc = yieldTag name P.MODULE loc range' >> gtags t
yield name loc = yieldTag name P.MODULE P.DEFINITION loc range' >> gtags t
yieldMethodNameTag ::
( Has (State [Text]) sig m,
@ -156,7 +156,7 @@ yieldMethodNameTag t range (Rb.MethodName expr) = enterScope True $ case expr of
-- Prj Rb.Symbol { extraChildren = [Prj Rb.EscapeSequence { text = name }] } -> yield name
_ -> gtags t
where
yield name loc = yieldTag name P.METHOD loc range >> gtags t
yield name loc = yieldTag name P.METHOD P.DEFINITION loc range >> gtags t
enterScope :: (Has (State [Text]) sig m) => Bool -> m () -> m ()
enterScope createNew m = do
@ -248,10 +248,10 @@ instance ToTags Rb.Lhs where
Prj Rb.ScopeResolution { ann = loc@Loc { byteRange }, name = Prj Rb.Constant { text } } -> yield text P.CALL loc byteRange -- TODO: Should yield Constant
_ -> gtags t
where
yieldCall name loc range = yieldTag name P.CALL loc range >> gtags t
yieldCall name loc range = yieldTag name P.CALL P.REFERENCE loc range >> gtags t
yield name kind loc range = do
locals <- get @[Text]
unless (name `elem` locals) $ yieldTag name kind loc range
unless (name `elem` locals) $ yieldTag name kind P.REFERENCE loc range
gtags t
-- TODO: Line of source produced here could be better.
@ -272,7 +272,7 @@ instance ToTags Rb.MethodCall where
_ -> gtags t
_ -> gtags t
where
yield name kind loc = yieldTag name kind loc byteRange >> gtags t
yield name kind loc = yieldTag name kind P.REFERENCE loc byteRange >> gtags t
instance ToTags Rb.Alias where
tags
@ -282,10 +282,10 @@ instance ToTags Rb.Alias where
ann = Loc {byteRange}
} = do
case aliasExpr of
Prj Rb.Identifier {ann, text} -> yieldTag text P.FUNCTION ann byteRange
Prj Rb.Identifier {ann, text} -> yieldTag text P.FUNCTION P.DEFINITION ann byteRange
_ -> tags aliasExpr
case nameExpr of
Prj Rb.Identifier {ann, text} -> yieldTag text P.CALL ann byteRange
Prj Rb.Identifier {ann, text} -> yieldTag text P.CALL P.REFERENCE ann byteRange
_ -> tags nameExpr
gtags t
@ -296,7 +296,7 @@ instance ToTags Rb.Undef where
ann = Loc {byteRange}
} = for_ extraChildren $ \(Rb.MethodName expr) -> do
case expr of
Prj Rb.Identifier {ann, text} -> yieldTag text P.CALL ann byteRange
Prj Rb.Identifier {ann, text} -> yieldTag text P.CALL P.REFERENCE ann byteRange
_ -> tags expr
gtags t

11
semantic-tags/src/Tags/Tag.hs
View File

@ -6,10 +6,11 @@ import Source.Loc
data Tag
= Tag
{ name :: Text,
kind :: P.SyntaxType,
loc :: Loc,
line :: Text,
docs :: Maybe Text
{ tagName :: Text,
tagSyntaxType :: P.SyntaxType,
tagNodeType :: P.NodeType,
tagLoc :: Loc,
tagLine :: Text,
tagDocs :: Maybe Text
}
deriving (Eq, Show)

3
semantic-tags/src/Tags/Tagging/Precise.hs
View File

@ -1,5 +1,6 @@
module Tags.Tagging.Precise
( Tags
, Tag(..)
, ToTags(..)
, yield
, runTagging
@ -26,7 +27,7 @@ class ToTags t where
yield :: Has (Writer Tags) sig m => Tag -> m ()
yield = tell . Endo . (:) . modSpan toOneIndexed where
modSpan f t@Tag{ loc = l } = t { loc = l { span = f (span l) } }
modSpan f t@Tag{ tagLoc = l } = t { tagLoc = l { span = f (span l) } }
toOneIndexed (Span (Pos l1 c1) (Pos l2 c2)) = Span (Pos (l1 + 1) (c1 + 1)) (Pos (l2 + 1) (c2 + 1))
runTagging :: Source -> ReaderC Source (WriterC Tags Identity) () -> [Tag]

30
semantic-tsx/src/Language/TSX/Tags.hs
View File

@ -43,20 +43,20 @@ class ToTags t where
instance ToTags Tsx.Function where
tags t@Tsx.Function {ann = Loc {byteRange}, name = Just Tsx.Identifier {text, ann}} =
yieldTag text P.FUNCTION ann byteRange >> gtags t
yieldTag text P.FUNCTION P.DEFINITION ann byteRange >> gtags t
tags t = gtags t
instance ToTags Tsx.FunctionSignature where
tags t@Tsx.FunctionSignature {ann = Loc {byteRange}, name = Tsx.Identifier {text, ann}} =
yieldTag text P.FUNCTION ann byteRange >> gtags t
yieldTag text P.FUNCTION P.DEFINITION ann byteRange >> gtags t
instance ToTags Tsx.FunctionDeclaration where
tags t@Tsx.FunctionDeclaration {ann = Loc {byteRange}, name = Tsx.Identifier {text, ann}} =
yieldTag text P.FUNCTION ann byteRange >> gtags t
yieldTag text P.FUNCTION P.DEFINITION ann byteRange >> gtags t
instance ToTags Tsx.MethodDefinition where
tags t@Tsx.MethodDefinition {ann = Loc {byteRange}, name} = case name of
Prj Tsx.PropertyIdentifier {text, ann} -> yieldTag text P.METHOD ann byteRange >> gtags t
Prj Tsx.PropertyIdentifier {text, ann} -> yieldTag text P.METHOD P.DEFINITION ann byteRange >> gtags t
_ -> gtags t
instance ToTags Tsx.Pair where
@ -65,11 +65,11 @@ instance ToTags Tsx.Pair where
(Prj Tsx.PropertyIdentifier {text, ann}, Prj Tsx.ArrowFunction {}) -> yield text ann
_ -> gtags t
where
yield text loc = yieldTag text P.FUNCTION loc byteRange >> gtags t
yield text loc = yieldTag text P.FUNCTION P.DEFINITION loc byteRange >> gtags t
instance ToTags Tsx.ClassDeclaration where
tags t@Tsx.ClassDeclaration {ann = Loc {byteRange}, name = Tsx.TypeIdentifier {text, ann}} =
yieldTag text P.CLASS ann byteRange >> gtags t
yieldTag text P.CLASS P.DEFINITION ann byteRange >> gtags t
instance ToTags Tsx.CallExpression where
tags t@Tsx.CallExpression {ann = Loc {byteRange}, function = Tsx.Expression expr} = match expr
@ -84,16 +84,16 @@ instance ToTags Tsx.CallExpression where
Prj (Tsx.Expression expr) -> match expr
_ -> tags x
_ -> gtags t
yield name loc = yieldTag name P.CALL loc byteRange >> gtags t
yield name loc = yieldTag name P.CALL P.REFERENCE loc byteRange >> gtags t
instance ToTags Tsx.Class where
tags t@Tsx.Class {ann = Loc {byteRange}, name = Just Tsx.TypeIdentifier {text, ann}} =
yieldTag text P.CLASS ann byteRange >> gtags t
yieldTag text P.CLASS P.DEFINITION ann byteRange >> gtags t
tags t = gtags t
instance ToTags Tsx.Module where
tags t@Tsx.Module {ann = Loc {byteRange}, name} = case name of
Prj Tsx.Identifier {text, ann} -> yieldTag text P.MODULE ann byteRange >> gtags t
Prj Tsx.Identifier {text, ann} -> yieldTag text P.MODULE P.DEFINITION ann byteRange >> gtags t
_ -> gtags t
instance ToTags Tsx.VariableDeclarator where
@ -103,7 +103,7 @@ instance ToTags Tsx.VariableDeclarator where
(Prj Tsx.ArrowFunction {}, Prj Tsx.Identifier {text, ann}) -> yield text ann
_ -> gtags t
where
yield text loc = yieldTag text P.FUNCTION loc byteRange >> gtags t
yield text loc = yieldTag text P.FUNCTION P.DEFINITION loc byteRange >> gtags t
tags t = gtags t
instance ToTags Tsx.AssignmentExpression where
@ -115,7 +115,7 @@ instance ToTags Tsx.AssignmentExpression where
(Prj Tsx.MemberExpression {property = Tsx.PropertyIdentifier {text, ann}}, Prj Tsx.ArrowFunction {}) -> yield text ann
_ -> gtags t
where
yield text loc = yieldTag text P.FUNCTION loc byteRange >> gtags t
yield text loc = yieldTag text P.FUNCTION P.DEFINITION loc byteRange >> gtags t
instance (ToTags l, ToTags r) => ToTags (l :+: r) where
tags (L1 l) = tags l
@ -138,11 +138,11 @@ gtags = traverse1_ @ToTags (const (pure ())) tags
nameBlacklist :: [Text]
nameBlacklist = ["require"]
yieldTag :: (Has (Reader Source) sig m, Has (Writer Tags.Tags) sig m) => Text -> P.SyntaxType -> Loc -> Range -> m ()
yieldTag name P.CALL _ _ | name `elem` nameBlacklist = pure ()
yieldTag name kind loc srcLineRange = do
yieldTag :: (Has (Reader Source) sig m, Has (Writer Tags.Tags) sig m) => Text -> P.SyntaxType -> P.NodeType -> Loc -> Range -> m ()
yieldTag name P.CALL _ _ _ | name `elem` nameBlacklist = pure ()
yieldTag name kind ty loc srcLineRange = do
src <- ask @Source
Tags.yield (Tag name kind loc (Tags.firstLine src srcLineRange) Nothing)
Tags.yield (Tag name kind ty loc (Tags.firstLine src srcLineRange) Nothing)
{- ORMOLU_DISABLE -}
instance ToTags Tsx.AbstractClassDeclaration

30
semantic-typescript/src/Language/TypeScript/Tags.hs
View File

@ -43,20 +43,20 @@ class ToTags t where
instance ToTags Ts.Function where
tags t@Ts.Function {ann = Loc {byteRange}, name = Just Ts.Identifier {text, ann}} =
yieldTag text P.FUNCTION ann byteRange >> gtags t
yieldTag text P.FUNCTION P.DEFINITION ann byteRange >> gtags t
tags t = gtags t
instance ToTags Ts.FunctionSignature where
tags t@Ts.FunctionSignature {ann = Loc {byteRange}, name = Ts.Identifier {text, ann}} =
yieldTag text P.FUNCTION ann byteRange >> gtags t
yieldTag text P.FUNCTION P.DEFINITION ann byteRange >> gtags t
instance ToTags Ts.FunctionDeclaration where
tags t@Ts.FunctionDeclaration {ann = Loc {byteRange}, name = Ts.Identifier {text, ann}} =
yieldTag text P.FUNCTION ann byteRange >> gtags t
yieldTag text P.FUNCTION P.DEFINITION ann byteRange >> gtags t
instance ToTags Ts.MethodDefinition where
tags t@Ts.MethodDefinition {ann = Loc {byteRange}, name} = case name of
Prj Ts.PropertyIdentifier {text, ann} -> yieldTag text P.METHOD ann byteRange >> gtags t
Prj Ts.PropertyIdentifier {text, ann} -> yieldTag text P.METHOD P.DEFINITION ann byteRange >> gtags t
_ -> gtags t
instance ToTags Ts.Pair where
@ -65,11 +65,11 @@ instance ToTags Ts.Pair where
(Prj Ts.PropertyIdentifier {text, ann}, Prj Ts.ArrowFunction {}) -> yield text ann
_ -> gtags t
where
yield text loc = yieldTag text P.FUNCTION loc byteRange >> gtags t
yield text loc = yieldTag text P.FUNCTION P.DEFINITION loc byteRange >> gtags t
instance ToTags Ts.ClassDeclaration where
tags t@Ts.ClassDeclaration {ann = Loc {byteRange}, name = Ts.TypeIdentifier {text, ann}} =
yieldTag text P.CLASS ann byteRange >> gtags t
yieldTag text P.CLASS P.DEFINITION ann byteRange >> gtags t
instance ToTags Ts.CallExpression where
tags t@Ts.CallExpression {ann = Loc {byteRange}, function = Ts.Expression expr} = match expr
@ -84,16 +84,16 @@ instance ToTags Ts.CallExpression where
Prj (Ts.Expression expr) -> match expr
_ -> tags x
_ -> gtags t
yield name loc = yieldTag name P.CALL loc byteRange >> gtags t
yield name loc = yieldTag name P.CALL P.REFERENCE loc byteRange >> gtags t
instance ToTags Ts.Class where
tags t@Ts.Class {ann = Loc {byteRange}, name = Just Ts.TypeIdentifier {text, ann}} =
yieldTag text P.CLASS ann byteRange >> gtags t
yieldTag text P.CLASS P.DEFINITION ann byteRange >> gtags t
tags t = gtags t
instance ToTags Ts.Module where
tags t@Ts.Module {ann = Loc {byteRange}, name} = case name of
Prj Ts.Identifier {text, ann} -> yieldTag text P.MODULE ann byteRange >> gtags t
Prj Ts.Identifier {text, ann} -> yieldTag text P.MODULE P.DEFINITION ann byteRange >> gtags t
_ -> gtags t
instance ToTags Ts.VariableDeclarator where
@ -103,7 +103,7 @@ instance ToTags Ts.VariableDeclarator where
(Prj Ts.ArrowFunction {}, Prj Ts.Identifier {text, ann}) -> yield text ann
_ -> gtags t
where
yield text loc = yieldTag text P.FUNCTION loc byteRange >> gtags t
yield text loc = yieldTag text P.FUNCTION P.DEFINITION loc byteRange >> gtags t
tags t = gtags t
instance ToTags Ts.AssignmentExpression where
@ -115,7 +115,7 @@ instance ToTags Ts.AssignmentExpression where
(Prj Ts.MemberExpression {property = Ts.PropertyIdentifier {text, ann}}, Prj Ts.ArrowFunction {}) -> yield text ann
_ -> gtags t
where
yield text loc = yieldTag text P.FUNCTION loc byteRange >> gtags t
yield text loc = yieldTag text P.FUNCTION P.DEFINITION loc byteRange >> gtags t
instance (ToTags l, ToTags r) => ToTags (l :+: r) where
tags (L1 l) = tags l
@ -138,11 +138,11 @@ gtags = traverse1_ @ToTags (const (pure ())) tags
nameBlacklist :: [Text]
nameBlacklist = ["require"]
yieldTag :: (Has (Reader Source) sig m, Has (Writer Tags.Tags) sig m) => Text -> P.SyntaxType -> Loc -> Range -> m ()
yieldTag name P.CALL _ _ | name `elem` nameBlacklist = pure ()
yieldTag name kind loc srcLineRange = do
yieldTag :: (Has (Reader Source) sig m, Has (Writer Tags.Tags) sig m) => Text -> P.SyntaxType -> P.NodeType -> Loc -> Range -> m ()
yieldTag name P.CALL _ _ _ | name `elem` nameBlacklist = pure ()
yieldTag name kind ty loc srcLineRange = do
src <- ask @Source
Tags.yield (Tag name kind loc (Tags.firstLine src srcLineRange) Nothing)
Tags.yield (Tag name kind ty loc (Tags.firstLine src srcLineRange) Nothing)
{- ORMOLU_DISABLE -}
instance ToTags Ts.AbstractClassDeclaration

2
semantic.cabal
View File

@ -242,8 +242,6 @@ library
, Serializing.Format
, Serializing.SExpression
, Serializing.SExpression.Precise
, Tags.Taggable
, Tags.Tagging
-- Custom Prelude
autogen-modules: Paths_semantic
other-modules: Paths_semantic

2
src/Semantic/Api/StackGraph.hs
View File

@ -109,8 +109,8 @@ data SGNode
{ nodeId :: Int64,
nodeName :: Text,
nodeLine :: Text,
nodeSyntaxType :: P.SyntaxType,
nodeSpan :: Loc.Span,
nodeSyntaxType :: P.SyntaxType,
nodeNodeType :: P.NodeType
}
deriving (Eq, Show)

176
src/Semantic/Api/Symbols.hs
View File

@ -10,137 +10,79 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Semantic.Api.Symbols
( legacyParseSymbols
, parseSymbols
, parseSymbolsBuilder
, tagsForBlob
) where
( parseSymbols,
parseSymbolsBuilder,
tagsForBlob,
)
where
import Control.Effect.Error
import Control.Effect.Parse
import Control.Effect.Reader
import Control.Exception
import Control.Lens
import Data.Abstract.Declarations
import Data.Blob
import Data.ByteString.Builder
import Data.Foldable
import Data.Functor.Foldable
import Data.Language
import Data.Map.Strict (Map)
import Data.ProtoLens (defMessage)
import Data.Term (IsTerm (..), TermF)
import Data.Text (Text)
import Data.Text (pack)
import Control.Effect.Error
import Control.Effect.Parse
import Control.Effect.Reader
import Control.Exception
import Control.Lens
import Data.Blob
import Data.ByteString.Builder
import Data.Foldable
import Data.Language
import Data.Map.Strict (Map)
import Data.ProtoLens (defMessage)
import Data.Text (pack, toTitle)
import qualified Parsing.Parser as Parser
import Proto.Semantic as P hiding (Blob)
import Proto.Semantic_Fields as P
import Proto.Semantic_JSON ()
import Semantic.Api.Bridge
import qualified Semantic.Api.LegacyTypes as Legacy
import Semantic.Config
import Semantic.Task
import Serializing.Format (Format)
import Source.Loc as Loc
import Tags.Tagging
import qualified Tags.Tagging.Precise as Precise
import Proto.Semantic as P hiding (Blob)
import Proto.Semantic_Fields as P
import Proto.Semantic_JSON ()
import Semantic.Api.Bridge
import Semantic.Config
import Semantic.Task
import Serializing.Format (Format)
import Source.Loc as Loc
import Tags.Tagging.Precise
legacyParseSymbols :: (Has Distribute sig m, Has (Error SomeException) sig m, Has (Reader PerLanguageModes) sig m, Has Parse sig m, Traversable t) => t Blob -> m Legacy.ParseTreeSymbolResponse
legacyParseSymbols blobs = Legacy.ParseTreeSymbolResponse <$> distributeFoldMap go blobs
where
go :: (Has (Error SomeException) sig m, Has (Reader PerLanguageModes) sig m, Has Parse sig m) => Blob -> m [Legacy.File]
go blob@Blob{..} = asks toTagsParsers >>= \ p -> parseWith p (pure . renderToSymbols) blob `catchError` (\(SomeException _) -> pure (pure emptyFile))
where
emptyFile = tagsToFile []
-- Legacy symbols output doesn't include Function Calls.
symbolsToSummarize :: [Text]
symbolsToSummarize = ["Function", "Method", "Class", "Module"]
renderToSymbols :: ToTags t => t Loc -> [Legacy.File]
renderToSymbols = pure . tagsToFile . tags symbolsToSummarize blob
tagsToFile :: [Tag] -> Legacy.File
tagsToFile tags = Legacy.File (pack (blobFilePath blob)) (pack (show (blobLanguage blob))) (fmap tagToSymbol tags)
tagToSymbol :: Tag -> Legacy.Symbol
tagToSymbol Tag{..}
= Legacy.Symbol
{ symbolName = name
, symbolKind = pack (show kind)
, symbolLine = line
, symbolSpan = converting #? Loc.span loc
}
parseSymbolsBuilder :: (Has Distribute sig m, Has (Error SomeException) sig m, Has Parse sig m, Has (Reader Config) sig m, Has (Reader PerLanguageModes) sig m, Traversable t) => Format ParseTreeSymbolResponse -> t Blob -> m Builder
parseSymbolsBuilder :: (Has Distribute sig m, Has (Error SomeException) sig m, Has Parse sig m, Has (Reader Config) sig m, Traversable t) => Format ParseTreeSymbolResponse -> t Blob -> m Builder
parseSymbolsBuilder format blobs = parseSymbols blobs >>= serialize format
parseSymbols :: (Has Distribute sig m, Has (Error SomeException) sig m, Has (Reader PerLanguageModes) sig m, Has Parse sig m, Traversable t) => t Blob -> m ParseTreeSymbolResponse
parseSymbols :: (Has Distribute sig m, Has (Error SomeException) sig m, Has Parse sig m, Traversable t) => t Blob -> m ParseTreeSymbolResponse
parseSymbols blobs = do
terms <- distributeFor blobs go
pure $ defMessage & P.files .~ toList terms
where
go :: (Has (Error SomeException) sig m, Has (Reader PerLanguageModes) sig m, Has Parse sig m) => Blob -> m File
go blob@Blob{..} = catching $ tagsToFile <$> tagsForBlob blob
go :: (Has (Error SomeException) sig m, Has Parse sig m) => Blob -> m File
go blob@Blob {..} = catching $ tagsToFile <$> tagsForBlob blob
where
catching m = m `catchError` (\(SomeException e) -> pure $ errorFile (show e))
blobLanguage' = blobLanguage blob
blobPath' = pack $ blobFilePath blob
errorFile e = defMessage
& P.path .~ blobPath'
& P.language .~ (bridging # blobLanguage')
& P.symbols .~ mempty
& P.errors .~ [defMessage & P.error .~ pack e]
errorFile e =
defMessage
& P.path .~ blobPath'
& P.language .~ (bridging # blobLanguage')
& P.symbols .~ mempty
& P.errors .~ [defMessage & P.error .~ pack e]
tagsToFile :: [Tag] -> File
tagsToFile tags = defMessage
& P.path .~ blobPath'
& P.language .~ (bridging # blobLanguage')
& P.symbols .~ fmap tagToSymbol tags
& P.errors .~ mempty
tagsToFile tags =
defMessage
& P.path .~ blobPath'
& P.language .~ (bridging # blobLanguage')
& P.symbols .~ fmap tagToSymbol tags
& P.errors .~ mempty
tagToSymbol :: Tag -> Symbol
tagToSymbol Tag{..} = defMessage
& P.symbol .~ name
& P.kind .~ pack (show kind)
& P.nodeType .~ nodeTypeForKind kind
& P.line .~ line
& P.maybe'span ?~ converting # Loc.span loc
& P.maybe'docs .~ fmap (flip (set P.docstring) defMessage) docs
tagToSymbol tag =
defMessage
& P.symbol .~ tagName tag
& P.kind .~ toKind tag
& P.nodeType .~ tagNodeType tag
& P.syntaxType .~ tagSyntaxType tag
& P.line .~ tagLine tag
& P.maybe'span ?~ converting # Loc.span (tagLoc tag)
& P.maybe'docs .~ fmap (flip (set P.docstring) defMessage) (tagDocs tag)
where
toKind = toTitle . pack . show . tagSyntaxType
nodeTypeForKind :: Kind -> NodeType
nodeTypeForKind = \case
Function -> DEFINITION
Method -> DEFINITION
Class -> DEFINITION
Module -> DEFINITION
Interface -> DEFINITION
Call -> REFERENCE
Type -> REFERENCE
Implementation -> REFERENCE
tagsForBlob :: (Has (Error SomeException) sig m, Has Parse sig m, Has (Reader PerLanguageModes) sig m) => Blob -> m [Tag]
tagsForBlob blob = asks toTagsParsers >>= \p -> parseWith p (pure . tags symbolsToSummarize blob) blob
symbolsToSummarize :: [Text]
symbolsToSummarize = ["Function", "AmbientFunction", "Method", "Class", "Module", "Call", "Send"]
class ToTags t where
tags :: [Text] -> Blob -> t Loc -> [Tag]
instance (Parser.TermMode term ~ strategy, ToTagsBy strategy term) => ToTags term where
tags = tagsBy @strategy
class ToTagsBy (strategy :: LanguageMode) term where
tagsBy :: [Text] -> Blob -> term Loc -> [Tag]
instance (IsTerm term, IsTaggable (Syntax term), Base (term Loc) ~ TermF (Syntax term) Loc, Recursive (term Loc), Declarations (term Loc)) => ToTagsBy 'ALaCarte term where
tagsBy symbols blob = runTagging (blobLanguage blob) symbols (blobSource blob)
instance Precise.ToTags term => ToTagsBy 'Precise term where
tagsBy _ = Precise.tags . blobSource
toTagsParsers :: PerLanguageModes -> Map Language (Parser.SomeParser ToTags Loc)
toTagsParsers = Parser.allParsers
tagsForBlob :: (Has (Error SomeException) sig m, Has Parse sig m) => Blob -> m [Tag]
tagsForBlob blob = parseWith toTagsParsers (pure . tags (blobSource blob)) blob
where
toTagsParsers :: Map Language (Parser.SomeParser ToTags Loc)
toTagsParsers = Parser.preciseParsers

235
src/Tags/Taggable.hs
View File

@ -1,235 +0,0 @@
{- |
Taggable allows projecting syntax terms to a list of named symbols. In order to
identify a new syntax as Taggable, you need to:
1. Give that syntax a non-derived @TaggableBy 'Custom@ instance and implement at least the
'symbolName'' method.
2. Add an equation to 'TaggableInstance' for the type with the value ''Custom'.
3. Make sure that 'symbolsToSummarize' in Tagging.hs includes the string
constructor name of this syntax.
-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Tags.Taggable
( Tagger
, Token(..)
, Taggable(..)
, IsTaggable
, HasTextElement
, tagging
)
where
import Analysis.ConstructorName
import Analysis.HasTextElement
import Analysis.Name
import Data.Abstract.Declarations
import Data.Algebra
import Data.Foldable
import Data.Functor.Foldable
import Data.Language
import Data.Sum
import Data.Term
import Data.Text hiding (empty)
import Source.Loc as Loc
import Source.Range
import Streaming hiding (Sum)
import Streaming.Prelude (yield)
import qualified Data.Syntax as Syntax
import qualified Data.Syntax.Declaration as Declaration
import qualified Data.Syntax.Expression as Expression
import qualified Language.Ruby.Syntax as Ruby
import qualified Language.TypeScript.Syntax as TypeScript
-- TODO: Move to src/Data
data Token
= Enter Text Range
| Exit Text Range
| Iden Text Loc (Maybe Range)
deriving (Eq, Show)
type Tagger = Stream (Of Token)
enter, exit :: Monad m => String -> Range -> Tagger m ()
enter c = yield . Enter (pack c)
exit c = yield . Exit (pack c)
emitIden :: Monad m => Loc -> Maybe Range -> Name -> Tagger m ()
emitIden loc docsLiteralRange name = yield (Iden (formatName name) loc docsLiteralRange)
class Taggable constr where
docsLiteral ::
( Foldable (Syntax term)
, IsTerm term
, HasTextElement (Syntax term)
)
=> Language -> constr (term Loc) -> Maybe Range
snippet :: (IsTerm term, Foldable (Syntax term)) => Loc -> constr (term Loc) -> Range
symbolName :: (IsTerm term, Declarations (term Loc)) => constr (term Loc) -> Maybe Name
data Strategy = Default | Custom
class TaggableBy (strategy :: Strategy) constr where
docsLiteral' ::
( Foldable (Syntax term)
, IsTerm term
, HasTextElement (Syntax term)
)
=> Language -> constr (term Loc) -> Maybe Range
docsLiteral' _ _ = Nothing
snippet' :: (IsTerm term, Foldable (Syntax term)) => Loc -> constr (term Loc) -> Range
snippet' ann _ = byteRange ann
symbolName' :: (IsTerm term, Declarations (term Loc)) => constr (term Loc) -> Maybe Name
symbolName' _ = Nothing
type IsTaggable syntax =
( Functor syntax
, Foldable syntax
, Taggable syntax
, ConstructorName syntax
, HasTextElement syntax
)
tagging :: (Monad m, IsTerm term, IsTaggable (Syntax term), Base (term Loc) ~ TermF (Syntax term) Loc, Recursive (term Loc), Declarations (term Loc))
=> Language
-> term Loc
-> Stream (Of Token) m ()
tagging = foldSubterms . descend
descend ::
( ConstructorName (TermF (Syntax term) Loc)
, Declarations (term Loc)
, IsTerm term
, IsTaggable (Syntax term)
, Monad m
)
=> Language -> SubtermAlgebra (TermF (Syntax term) Loc) (term Loc) (Tagger m ())
descend lang t@(In loc _) = do
let term = fmap subterm t
let snippetRange = snippet loc term
let litRange = docsLiteral lang term
enter (constructorName term) snippetRange
maybe (pure ()) (emitIden loc litRange) (symbolName term)
traverse_ subtermRef t
exit (constructorName term) snippetRange
subtractLoc :: Loc -> Loc -> Range
subtractLoc a b = subtractRange (byteRange a) (byteRange b)
-- Instances
instance (TaggableBy strategy t, strategy ~ TaggableInstance t) => Taggable t where
docsLiteral = docsLiteral' @strategy
snippet = snippet' @strategy
symbolName = symbolName' @strategy
type family TaggableInstance (t :: * -> *) :: Strategy where
TaggableInstance (Sum _) = 'Custom
TaggableInstance (TermF _ _) = 'Custom
TaggableInstance Syntax.Context = 'Custom
TaggableInstance Declaration.Function = 'Custom
TaggableInstance Declaration.Method = 'Custom
TaggableInstance Declaration.Class = 'Custom
TaggableInstance Ruby.Class = 'Custom
TaggableInstance Ruby.Module = 'Custom
TaggableInstance TypeScript.Module = 'Custom
TaggableInstance TypeScript.AmbientFunction = 'Custom
TaggableInstance Expression.Call = 'Custom
TaggableInstance Ruby.Send = 'Custom
TaggableInstance _ = 'Default
instance TaggableBy 'Default t
instance Apply Taggable fs => TaggableBy 'Custom (Sum fs) where
docsLiteral' a = apply @Taggable (docsLiteral a)
snippet' x = apply @Taggable (snippet x)
symbolName' = apply @Taggable symbolName
instance Taggable a => TaggableBy 'Custom (TermF a Loc) where
docsLiteral' l t = docsLiteral l (termFOut t)
snippet' ann t = snippet ann (termFOut t)
symbolName' t = symbolName (termFOut t)
instance TaggableBy 'Custom Syntax.Context where
snippet' ann (Syntax.Context _ subj) = subtractLoc ann (termAnnotation subj)
instance TaggableBy 'Custom Declaration.Function where
docsLiteral' Python (Declaration.Function _ _ _ body)
| bodyF <- termOut body
, expr:_ <- toList bodyF
, In exprAnn exprF <- toTermF expr
, isTextElement exprF = Just (byteRange exprAnn)
| otherwise = Nothing
docsLiteral' _ _ = Nothing
snippet' ann (Declaration.Function _ _ _ body) = subtractLoc ann (termAnnotation body)
symbolName' = declaredName . Declaration.functionName
instance TaggableBy 'Custom TypeScript.AmbientFunction where
snippet' ann _ = byteRange ann
symbolName' = declaredName . TypeScript.ambientFunctionIdentifier
instance TaggableBy 'Custom Declaration.Method where
docsLiteral' Python (Declaration.Method _ _ _ _ body _)
| bodyF <- termOut body
, expr:_ <- toList bodyF
, In exprAnn exprF <- toTermF expr
, isTextElement exprF = Just (byteRange exprAnn)
| otherwise = Nothing
docsLiteral' _ _ = Nothing
snippet' ann (Declaration.Method _ _ _ _ body _) = subtractLoc ann (termAnnotation body)
symbolName' = declaredName . Declaration.methodName
instance TaggableBy 'Custom Declaration.Class where
docsLiteral' Python (Declaration.Class _ _ _ body)
| bodyF <- termOut body
, expr:_ <- toList bodyF
, In exprAnn exprF <- toTermF expr
, isTextElement exprF = Just (byteRange exprAnn)
| otherwise = Nothing
docsLiteral' _ _ = Nothing
snippet' ann (Declaration.Class _ _ _ body) = subtractLoc ann (termAnnotation body)
symbolName' = declaredName . Declaration.classIdentifier
instance TaggableBy 'Custom Ruby.Class where
snippet' ann (Ruby.Class _ _ body) = subtractLoc ann (termAnnotation body)
symbolName' = declaredName . Ruby.classIdentifier
instance TaggableBy 'Custom Ruby.Module where
snippet' ann (Ruby.Module _ (body:_)) = subtractLoc ann (termAnnotation body)
snippet' ann (Ruby.Module _ _) = byteRange ann
symbolName' = declaredName . Ruby.moduleIdentifier
instance TaggableBy 'Custom TypeScript.Module where
snippet' ann (TypeScript.Module _ (body:_)) = subtractLoc ann (termAnnotation body)
snippet' ann (TypeScript.Module _ _ ) = byteRange ann
symbolName' = declaredName . TypeScript.moduleIdentifier
instance TaggableBy 'Custom Expression.Call where
snippet' ann (Expression.Call _ _ _ body) = subtractLoc ann (termAnnotation body)
symbolName' = declaredName . Expression.callFunction
instance TaggableBy 'Custom Ruby.Send where
snippet' ann (Ruby.Send _ _ _ (Just body)) = subtractLoc ann (termAnnotation body)
snippet' ann _ = byteRange ann
symbolName' Ruby.Send{..} = declaredName =<< sendSelector

88
src/Tags/Tagging.hs
View File

@ -1,88 +0,0 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Tags.Tagging
( runTagging
, Tag(..)
, Kind(..)
, IsTaggable
)
where
import Prelude hiding (fail, filter, log)
import Control.Carrier.State.Strict as Eff
import Control.Monad
import Data.Abstract.Declarations (Declarations)
import Data.Functor.Foldable
import Data.Text as T hiding (empty)
import Streaming
import qualified Streaming.Prelude as Streaming
import Data.Language
import Data.Term
import Source.Loc
import qualified Source.Source as Source
import Tags.Tag
import Tags.Taggable
runTagging :: (IsTerm term, IsTaggable (Syntax term), Base (term Loc) ~ TermF (Syntax term) Loc, Recursive (term Loc), Declarations (term Loc))
=> Language
-> [Text]
-> Source.Source
-> term Loc
-> [Tag]
runTagging lang symbolsToSummarize source
= Eff.run
. evalState @[ContextToken] []
. Streaming.toList_
. contextualizing source toKind
. tagging lang
where
toKind x = do
guard (x `elem` symbolsToSummarize)
case x of
"Function" -> Just Function
"Method" -> Just Method
"Class" -> Just Class
"Module" -> Just Module
"Call" -> Just Call
"Send" -> Just Call -- Ruby’s Send is considered to be a kind of 'Call'
"AmbientFunction" -> Just Function -- Classify TypeScript ambient functions as 'Function'
_ -> Nothing
type ContextToken = (Text, Range)
contextualizing :: Has (State [ContextToken]) sig m
=> Source.Source
-> (Text -> Maybe Kind)
-> Stream (Of Token) m a
-> Stream (Of Tag) m a
contextualizing source toKind = Streaming.mapMaybeM $ \case
Enter x r -> Nothing <$ enterScope (x, r)
Exit x r -> Nothing <$ exitScope (x, r)
Iden iden loc docsLiteralRange -> fmap go (get @[ContextToken]) where
go = \case
((x, r):("Context", cr):_) | Just kind <- toKind x -> Just $ Tag iden kind loc (firstLine r) (Just (sliceDocs cr))
((x, r):_) | Just kind <- toKind x -> Just $ Tag iden kind loc (firstLine r) (sliceDocs <$> docsLiteralRange)
_ -> Nothing
where
slice = Source.toText . Source.slice source
sliceDocs = T.stripEnd . slice
firstLine = T.stripEnd . T.take 180 . T.takeWhile (/= '\n') . slice
enterScope, exitScope :: Has (State [ContextToken]) sig m
=> ContextToken
-> m ()
enterScope c = modify @[ContextToken] (c :)
exitScope c = get @[ContextToken] >>= \case
x:xs -> when (x == c) (put xs)
-- If we run out of scopes to match, we've hit a tag balance issue;
-- just continue onwards.
[] -> pure ()