diff --git a/semantic-codeql/src/Language/CodeQL/Tags.hs b/semantic-codeql/src/Language/CodeQL/Tags.hs index 19ad35d5e..6a3b3a27d 100644 --- a/semantic-codeql/src/Language/CodeQL/Tags.hs +++ b/semantic-codeql/src/Language/CodeQL/Tags.hs @@ -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 diff --git a/semantic-go/src/Language/Go/Tags.hs b/semantic-go/src/Language/Go/Tags.hs index 9b550ae31..e88a469a1 100644 --- a/semantic-go/src/Language/Go/Tags.hs +++ b/semantic-go/src/Language/Go/Tags.hs @@ -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 diff --git a/semantic-java/src/Language/Java/Tags.hs b/semantic-java/src/Language/Java/Tags.hs index 7a41c5557..de513d744 100644 --- a/semantic-java/src/Language/Java/Tags.hs +++ b/semantic-java/src/Language/Java/Tags.hs @@ -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 diff --git a/semantic-php/src/Language/PHP/Tags.hs b/semantic-php/src/Language/PHP/Tags.hs index 083de5f52..90cf86e58 100644 --- a/semantic-php/src/Language/PHP/Tags.hs +++ b/semantic-php/src/Language/PHP/Tags.hs @@ -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 diff --git a/semantic-python/src/Language/Python/Tags.hs b/semantic-python/src/Language/Python/Tags.hs index 8ab2ba3f0..314657a2a 100644 --- a/semantic-python/src/Language/Python/Tags.hs +++ b/semantic-python/src/Language/Python/Tags.hs @@ -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))) diff --git a/semantic-ruby/src/Language/Ruby/Tags.hs b/semantic-ruby/src/Language/Ruby/Tags.hs index 583176ca4..aeb0791b4 100644 --- a/semantic-ruby/src/Language/Ruby/Tags.hs +++ b/semantic-ruby/src/Language/Ruby/Tags.hs @@ -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 diff --git a/semantic-tags/src/Tags/Tag.hs b/semantic-tags/src/Tags/Tag.hs index 7ec946a64..72373dfee 100644 --- a/semantic-tags/src/Tags/Tag.hs +++ b/semantic-tags/src/Tags/Tag.hs @@ -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) diff --git a/semantic-tags/src/Tags/Tagging/Precise.hs b/semantic-tags/src/Tags/Tagging/Precise.hs index 45d3e55aa..1b8bce2e8 100644 --- a/semantic-tags/src/Tags/Tagging/Precise.hs +++ b/semantic-tags/src/Tags/Tagging/Precise.hs @@ -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] diff --git a/semantic-tsx/src/Language/TSX/Tags.hs b/semantic-tsx/src/Language/TSX/Tags.hs index 9d1e62548..e60e92413 100644 --- a/semantic-tsx/src/Language/TSX/Tags.hs +++ b/semantic-tsx/src/Language/TSX/Tags.hs @@ -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 diff --git a/semantic-typescript/src/Language/TypeScript/Tags.hs b/semantic-typescript/src/Language/TypeScript/Tags.hs index b6941cbc8..748818320 100644 --- a/semantic-typescript/src/Language/TypeScript/Tags.hs +++ b/semantic-typescript/src/Language/TypeScript/Tags.hs @@ -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 diff --git a/semantic.cabal b/semantic.cabal index b88729486..94844c77e 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -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 diff --git a/src/Semantic/Api/StackGraph.hs b/src/Semantic/Api/StackGraph.hs index bfa2cbecb..77d2927c9 100644 --- a/src/Semantic/Api/StackGraph.hs +++ b/src/Semantic/Api/StackGraph.hs @@ -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) diff --git a/src/Semantic/Api/Symbols.hs b/src/Semantic/Api/Symbols.hs index 83b455a3c..6e60f8d68 100644 --- a/src/Semantic/Api/Symbols.hs +++ b/src/Semantic/Api/Symbols.hs @@ -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 diff --git a/src/Tags/Taggable.hs b/src/Tags/Taggable.hs deleted file mode 100644 index 9acc4445f..000000000 --- a/src/Tags/Taggable.hs +++ /dev/null @@ -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 diff --git a/src/Tags/Tagging.hs b/src/Tags/Tagging.hs deleted file mode 100644 index 896bb3d0f..000000000 --- a/src/Tags/Tagging.hs +++ /dev/null @@ -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 ()