github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2025-01-05 22:28:10 +03:00
Code Issues Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/master' into bazel-experiments

Browse Source
This commit is contained in:
Patrick Thomson 2020-06-23 11:03:39 -04:00
commit 3aecbcc98a
45 changed files with 593 additions and 346 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
.github/workflows/haskell.yml vendored
View File

@ -62,8 +62,8 @@ jobs:
cabal v2-run --project-file=cabal.project.ci semantic-java:test
cabal v2-run --project-file=cabal.project.ci semantic-json:test
cabal v2-run --project-file=cabal.project.ci semantic-python:test
cabal v2-run --project-file=cabal.project.ci semantic-python:test:compiling
cabal v2-run --project-file=cabal.project.ci semantic-python:test:graphing
# cabal v2-run --project-file=cabal.project.ci semantic-python:test:compiling
# cabal v2-run --project-file=cabal.project.ci semantic-python:test:graphing
cabal v2-run --project-file=cabal.project.ci semantic-ruby:test
cabal v2-run --project-file=cabal.project.ci semantic-tsx:test
cabal v2-run --project-file=cabal.project.ci semantic-typescript:test

1
.hlint.yaml
View File

@ -59,6 +59,7 @@
name: Reduce duplication
within:
- Semantic.Util
- Language.Ruby.Tags
# hlint has issues with QuantifiedConstraints (see https://github.com/ndmitchell/hlint/issues/759)
# Once the above is fixed, we can drop this error.

2
script/ghci-flags
View File

@ -56,8 +56,10 @@ function flags {
echo "-isemantic-go/src"
echo "-isemantic-java/src"
echo "-isemantic-json/src"
echo "-isemantic-json/test"
echo "-isemantic-parse/src"
echo "-isemantic-php/src"
echo "-isemantic-proto/src"
echo "-isemantic-python/src"
echo "-isemantic-python/test"
echo "-isemantic-ruby/src"

19
semantic-ast/semantic-ast.cabal
View File

@ -43,11 +43,12 @@ library
AST.GenerateSyntax
AST.Grammar.TH
AST.Marshal.JSON
AST.Parse
AST.Token
AST.Traversable1
AST.Traversable1.Class
AST.Unmarshal
AST.Test
AST.TestHelpers
-- other-modules:
@ -69,14 +70,14 @@ library
, tree-sitter-python ^>= 0.9.0.1
, text ^>= 1.2.3.1
, unordered-containers ^>= 0.2.10
, hedgehog >= 0.6 && <2
, pathtype ^>= 0.8.1
, Glob
, attoparsec
, text
, tasty
, tasty-hedgehog
, tasty-hunit
, hedgehog >= 0.6 && <2
, pathtype ^>= 0.8.1
, Glob ^>= 0.10.0
, attoparsec ^>= 0.13.2.2
, text ^>= 1.2.3
, tasty ^>= 1.2.3
, tasty-hedgehog ^>= 1.0.0.1
, tasty-hunit ^>= 0.10.0.2
hs-source-dirs: src
default-language: Haskell2010

11
semantic-ast/src/AST/Element.hs
View File

@ -2,9 +2,11 @@
module AST.Element
( Element(..)
, pattern Prj
, pattern EPrj
, (:+:)(..)
) where
import qualified AST.Parse as Parse
import GHC.Generics ((:+:)(..))
import GHC.TypeLits (ErrorMessage(..), TypeError)
@ -16,12 +18,19 @@ class Element sub sup where
instance (Element' side sub sup, side ~ Find sub sup) => Element sub sup where
prj = prj' @side
-- | A pattern synonym to conveniently project out matching elements.
pattern Prj :: Element sub sup => sub a -> sup a
pattern Prj sub <- (prj -> Just sub)
-- A pattern synonym that combines matching on @Success@ and @Prj@
eprj :: Element sub sup => Parse.Err (sup a) -> Maybe (sub a)
eprj (Parse.Success x) = prj x
eprj _ = Nothing
pattern EPrj :: Element sub sup => sub a -> Parse.Err (sup a)
pattern EPrj sub <- (eprj -> Just sub)
-- | Where does the element occur in the tree?
data Side = None | Here | L | R

119
semantic-ast/src/AST/GenerateSyntax.hs
View File

@ -1,3 +1,5 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
@ -10,6 +12,7 @@ module AST.GenerateSyntax
) where
import AST.Deserialize (Children (..), Datatype (..), DatatypeName (..), Field (..), Multiple (..), Named (..), Required (..), Type (..))
import qualified AST.Parse as Parse
import AST.Token
import AST.Traversable1.Class
import qualified AST.Unmarshal as TS
@ -47,7 +50,7 @@ astDeclarationsForLanguage language filePath = do
debugSymbolNames :: [String]
debugSymbolNames = $(listE (map (litE . stringL . debugPrefix) allSymbols))
|]
(debugSymbolNames <>) . concat @[] <$> traverse (syntaxDatatype language allSymbols) input
mappend debugSymbolNames . concat @[] <$> traverse (syntaxDatatype language allSymbols) input
-- Build a list of all symbols
getAllSymbols :: Ptr TS.Language -> IO [(String, Named)]
@ -62,53 +65,54 @@ getAllSymbols language = do
let named = if t == 0 then Named else Anonymous
pure (n, named)
annParameterName :: Name
annParameterName = mkName "a"
-- Auto-generate Haskell datatypes for sums, products and leaf types
syntaxDatatype :: Ptr TS.Language -> [(String, Named)] -> Datatype -> Q [Dec]
syntaxDatatype language allSymbols datatype = skipDefined $ do
typeParameterName <- newName "a"
let traversalInstances = mappend <$> makeStandaloneDerivings (conT name) <*> makeTraversalInstances (conT name)
glue a b c = a : b <> c
name = mkName nameStr
generatedDatatype cons = dataD (cxt []) name [plainTV annParameterName] Nothing cons [deriveStockClause, deriveAnyClassClause]
deriveStockClause = derivClause (Just StockStrategy) [conT ''Generic, conT ''Generic1]
deriveAnyClassClause = derivClause (Just AnyclassStrategy) [conT ''Traversable1 `appT` varT (mkName "someConstraint")]
deriveGN = derivClause (Just NewtypeStrategy) [conT ''TS.SymbolMatching]
case datatype of
SumType (DatatypeName _) _ subtypes -> do
types' <- fieldTypesToNestedSum subtypes
let fieldName = mkName ("get" <> nameStr)
con <- recC name [TH.varBangType fieldName (TH.bangType strictness (pure types' `appT` varT typeParameterName))]
hasFieldInstance <- makeHasFieldInstance (conT name) (varT typeParameterName) (varE fieldName)
traversalInstances <- makeTraversalInstances (conT name)
pure
( NewtypeD [] name [PlainTV typeParameterName] Nothing con [deriveGN, deriveStockClause, deriveAnyClassClause]
: hasFieldInstance
<> traversalInstances)
ProductType (DatatypeName datatypeName) named children fields -> do
con <- ctorForProductType datatypeName typeParameterName children fields
symbolMatchingInstance <- symbolMatchingInstance allSymbols name named datatypeName
traversalInstances <- makeTraversalInstances (conT name)
pure
( generatedDatatype name [con] typeParameterName
: symbolMatchingInstance
<> traversalInstances)
SumType (DatatypeName _) _ subtypes ->
let types' = fieldTypesToNestedSum subtypes
fieldName = mkName ("get" <> nameStr)
con = recC name [varBangType fieldName (bangType strictness (types' `appT` varT annParameterName))]
hasFieldInstance = makeHasFieldInstance (conT name) (varE fieldName)
newType = newtypeD (cxt []) name [plainTV annParameterName] Nothing con [deriveGN, deriveStockClause, deriveAnyClassClause]
in glue <$> newType <*> hasFieldInstance <*> traversalInstances
ProductType datatypeName named children fields ->
let con = ctorForProductType datatypeName children fields
symbols = symbolMatchingInstance allSymbols name named datatypeName
in glue <$> generatedDatatype [con] <*> symbols <*> traversalInstances
-- Anonymous leaf types are defined as synonyms for the `Token` datatype
LeafType (DatatypeName datatypeName) Anonymous -> do
tsSymbol <- runIO $ withCStringLen datatypeName (\(s, len) -> TS.ts_language_symbol_for_name language s len False)
pure [ TySynD name [] (ConT ''Token `AppT` LitT (StrTyLit datatypeName) `AppT` LitT (NumTyLit (fromIntegral tsSymbol))) ]
LeafType (DatatypeName datatypeName) Named -> do
con <- ctorForLeafType (DatatypeName datatypeName) typeParameterName
symbolMatchingInstance <- symbolMatchingInstance allSymbols name Named datatypeName
traversalInstances <- makeTraversalInstances (conT name)
pure
( generatedDatatype name [con] typeParameterName
: symbolMatchingInstance
<> traversalInstances)
let tsSymbol = runIO $ withCStringLen datatypeName (\(s, len) -> TS.ts_language_symbol_for_name language s len False)
fmap (pure @[]) (tySynD name [] (conT ''Token `appT` litT (strTyLit datatypeName) `appT` litT (tsSymbol >>= numTyLit . fromIntegral)))
LeafType datatypeName Named ->
let con = ctorForLeafType datatypeName annParameterName
symbols = symbolMatchingInstance allSymbols name Named datatypeName
in glue <$> generatedDatatype [con] <*> symbols <*> traversalInstances
where
-- Skip generating datatypes that have already been defined (overridden) in the module where the splice is running.
skipDefined m = do
isLocal <- lookupTypeName nameStr >>= maybe (pure False) isLocalName
if isLocal then pure [] else m
name = mkName nameStr
nameStr = toNameString (datatypeNameStatus datatype) (getDatatypeName (AST.Deserialize.datatypeName datatype))
deriveStockClause = DerivClause (Just StockStrategy) [ ConT ''Eq, ConT ''Ord, ConT ''Show, ConT ''Generic, ConT ''Generic1]
deriveAnyClassClause = DerivClause (Just AnyclassStrategy) [ConT ''TS.Unmarshal, ConT ''Traversable1 `AppT` VarT (mkName "someConstraint")]
deriveGN = DerivClause (Just NewtypeStrategy) [ConT ''TS.SymbolMatching]
generatedDatatype name cons typeParameterName = DataD [] name [PlainTV typeParameterName] Nothing cons [deriveStockClause, deriveAnyClassClause]
makeStandaloneDerivings :: TypeQ -> Q [Dec]
makeStandaloneDerivings ty =
[d|
deriving instance (Eq a) => Eq ($ty a)
deriving instance (Ord a) => Ord ($ty a)
deriving instance (Show a) => Show ($ty a)
instance TS.Unmarshal ($ty)
|]
makeTraversalInstances :: TypeQ -> Q [Dec]
makeTraversalInstances ty =
@ -121,14 +125,14 @@ makeTraversalInstances ty =
traverse = traverseDefault1
|]
makeHasFieldInstance :: TypeQ -> TypeQ -> ExpQ -> Q [Dec]
makeHasFieldInstance ty param elim =
[d|instance HasField "ann" $(ty `appT` param) $param where
makeHasFieldInstance :: TypeQ -> ExpQ -> Q [Dec]
makeHasFieldInstance ty elim =
[d|instance HasField "ann" ($ty a) a where
getField = TS.gann . $elim |]
-- | Create TH-generated SymbolMatching instances for sums, products, leaves
symbolMatchingInstance :: [(String, Named)] -> Name -> Named -> String -> Q [Dec]
symbolMatchingInstance allSymbols name named str = do
symbolMatchingInstance :: [(String, Named)] -> Name -> Named -> DatatypeName -> Q [Dec]
symbolMatchingInstance allSymbols name named (DatatypeName str) = do
let tsSymbols = elemIndices (str, named) allSymbols
names = intercalate ", " $ fmap (debugPrefix . (!!) allSymbols) tsSymbols
[d|instance TS.SymbolMatching $(conT name) where
@ -146,40 +150,49 @@ debugPrefix (name, Named) = name
debugPrefix (name, Anonymous) = "_" <> name
-- | Build Q Constructor for product types (nodes with fields)
ctorForProductType :: String -> Name -> Maybe Children -> [(String, Field)] -> Q Con
ctorForProductType constructorName typeParameterName children fields = ctorForTypes constructorName lists where
ctorForProductType :: DatatypeName -> Maybe Children -> [(String, Field)] -> Q Con
ctorForProductType constructorName children fields = ctorForTypes constructorName lists where
lists = annotation : fieldList <> childList
annotation = ("ann", varT typeParameterName)
fieldList = map (fmap toType) fields
annotation = ("ann", varT annParameterName)
fieldList = map (fmap (toType)) fields
childList = toList $ fmap toTypeChild children
inject t = conT ''Parse.Err `appT` t
toType :: Field -> TypeQ
toType (MkField required fieldTypes mult) =
let ftypes = fieldTypesToNestedSum fieldTypes `appT` varT typeParameterName
let ftypes = inject (fieldTypesToNestedSum fieldTypes `appT` varT annParameterName)
in case (required, mult) of
(Required, Multiple) -> appT (conT ''NonEmpty) ftypes
(Required, Single) -> ftypes
(Optional, Multiple) -> appT (conT ''[]) ftypes
(Optional, Multiple) -> appT listT ftypes
(Optional, Single) -> appT (conT ''Maybe) ftypes
toTypeChild (MkChildren field) = ("extra_children", toType field)
-- | Build Q Constructor for leaf types (nodes with no fields or subtypes)
ctorForLeafType :: DatatypeName -> Name -> Q Con
ctorForLeafType (DatatypeName name) typeParameterName = ctorForTypes name
[ ("ann", varT typeParameterName) -- ann :: a
ctorForLeafType name annParameterName = ctorForTypes name
[ ("ann", varT annParameterName) -- ann :: a
, ("text", conT ''Text) -- text :: Text
]
-- TODO: clarify the paths in ctorForProductType, ctorForLeafType, and ctorForTypes,
-- inserting an appropriate (''f `appT`) thing
-- | Build Q Constructor for records
ctorForTypes :: String -> [(String, Q TH.Type)] -> Q Con
ctorForTypes constructorName types = recC (toName Named constructorName) recordFields where
recordFields = map (uncurry toVarBangType) types
toVarBangType str type' = TH.varBangType (mkName . toHaskellCamelCaseIdentifier $ str) (TH.bangType strictness type')
ctorForTypes :: DatatypeName -> [(String, Q TH.Type)] -> Q Con
ctorForTypes (DatatypeName constructorName) types = recC (toName Named constructorName) recordFields
where
recordFields = map (uncurry toVarBangType) types
toVarBangType str type' = TH.varBangType (mkName . toHaskellCamelCaseIdentifier $ str) (TH.bangType strictness type')
-- | Convert field types to Q types
fieldTypesToNestedSum :: NonEmpty AST.Deserialize.Type -> Q TH.Type
fieldTypesToNestedSum xs = go (toList xs)
where
combine lhs rhs = (conT ''(:+:) `appT` lhs) `appT` rhs -- (((((a :+: b) :+: c) :+: d)) :+: e) ((a :+: b) :+: (c :+: d))
combine lhs rhs = uInfixT lhs ''(:+:) rhs -- (((((a :+: b) :+: c) :+: d)) :+: e) ((a :+: b) :+: (c :+: d))
convertToQType (MkType (DatatypeName n) named) = conT (toName named n)
go [x] = convertToQType x
go xs = let (l,r) = splitAt (length xs `div` 2) xs in combine (go l) (go r)

32
semantic-ast/src/AST/Parse.hs Normal file
View File

@ -0,0 +1,32 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE KindSignatures #-}
module AST.Parse
( Err(..)
) where
import GHC.Generics (Generic, Generic1)
-- | An AST node representing an Error, showing a parse that's succeeded or failed.
--
-- Error types are isomorphic to Either String.
--
-- For example, consider the following:
-- @
-- data If f a = If { ann :: a, condition :: f (Expr f a), consequence :: f (Stmt f a), alternative :: f (Stmt f a) }
-- @
-- When the parse fails, the f will be substituted with Err
-- TODO: this could work with AST.Element Prj given the kindedness was adjusted from (*) to (* -> *).
data Err a = Fail String | Success a
deriving (Eq, Foldable, Functor, Generic, Generic1, Ord, Traversable)
instance Applicative Err where
pure = Success
Fail e <*> _ = Fail e
Success a <*> r = fmap a r
instance Show a => Show (Err a) where
show (Fail msg) = msg
show (Success a) = show a

2
semantic-ast/src/AST/Test.hs → semantic-ast/src/AST/TestHelpers.hs
View File

@ -1,5 +1,5 @@
{-# LANGUAGE OverloadedStrings #-}
module AST.Test
module AST.TestHelpers
( CorpusExample(..)
, readCorpusFiles
, readCorpusFiles'

8
semantic-ast/src/AST/Token.hs
View File

@ -1,4 +1,8 @@
{-# LANGUAGE DataKinds, DeriveGeneric, DeriveTraversable, KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE KindSignatures #-}
module AST.Token
( Token(..)
) where
@ -14,4 +18,4 @@ import GHC.TypeLits (Symbol, Nat)
-- type AnonymousPlus = Token "+" 123
-- @
newtype Token (symName :: Symbol) (symVal :: Nat) a = Token { ann :: a }
deriving (Eq, Foldable, Functor, Generic, Generic1, Ord, Show, Traversable)
deriving (Eq, Foldable, Functor, Generic, Generic1, Ord, Show, Traversable)

61
semantic-ast/src/AST/Unmarshal.hs
View File

@ -27,6 +27,8 @@ module AST.Unmarshal
, GHasAnn(..)
) where
import AST.Token as TS
import AST.Parse
import Control.Algebra (send)
import Control.Carrier.Reader hiding (asks)
import Control.Exception
@ -35,6 +37,7 @@ import Data.ByteString (ByteString)
import qualified Data.ByteString as B
import Data.Coerce
import Data.Foldable (toList)
import Data.Functor.Identity
import qualified Data.IntMap as IntMap
import Data.List.NonEmpty (NonEmpty (..))
import Data.Proxy
@ -55,7 +58,6 @@ import TreeSitter.Cursor as TS
import TreeSitter.Language as TS
import TreeSitter.Node as TS
import TreeSitter.Parser as TS
import AST.Token as TS
import TreeSitter.Tree as TS
asks :: Has (Reader r) sig m => (r -> r') -> m r'
@ -152,6 +154,11 @@ class SymbolMatching t => Unmarshal t where
instance (Unmarshal f, Unmarshal g) => Unmarshal (f :+: g) where
matchers = fmap (fmap (hoist L1)) matchers <> fmap (fmap (hoist R1)) matchers
instance (Applicative shape, Unmarshal f) => Unmarshal (shape :.: f) where
matchers = let base = matchers @f in fmap (fmap promote) base
where
promote (Match f) = Match (fmap (fmap (Comp1 . pure)) f)
instance Unmarshal t => Unmarshal (Rec1 t) where
matchers = coerce (matchers @t)
@ -206,18 +213,27 @@ pointToPos (TSPoint line column) = Pos (fromIntegral line) (fromIntegral column)
class UnmarshalField t where
unmarshalField
:: ( Unmarshal f
, UnmarshalAnn a
, UnmarshalAnn ann
)
=> String -- ^ datatype name
-> String -- ^ field name
-> [Node] -- ^ nodes
-> MatchM (t (f a))
-> MatchM (t (f ann))
instance UnmarshalField Err where
unmarshalField _ _ [] = pure $ Fail "No items provided to unmarshalField."
unmarshalField _ _ [x] = Success <$> unmarshalNode x
unmarshalField d f _ = pure $ Fail ("type '" <> d <> "' expected zero or one nodes in field '" <> f <> "' but got multiple")
instance UnmarshalField Maybe where
unmarshalField _ _ [] = pure Nothing
unmarshalField _ _ [x] = Just <$> unmarshalNode x
unmarshalField d f _ = liftIO . throwIO . UnmarshalError $ "type '" <> d <> "' expected zero or one nodes in field '" <> f <> "' but got multiple"
instance UnmarshalField Identity where
unmarshalField _ _ [x] = Identity <$> unmarshalNode x
unmarshalField d f _ = liftIO . throwIO . UnmarshalError $ "type '" <> d <> "' expected zero or one nodes in field '" <> f <> "' but got multiple"
instance UnmarshalField [] where
unmarshalField d f (x:xs) = do
head' <- unmarshalNode x
@ -232,11 +248,11 @@ instance UnmarshalField NonEmpty where
pure $ head' :| tail'
unmarshalField d f [] = liftIO . throwIO . UnmarshalError $ "type '" <> d <> "' expected one or more nodes in field '" <> f <> "' but got zero"
class SymbolMatching (a :: * -> *) where
matchedSymbols :: Proxy a -> [Int]
class SymbolMatching (sym :: * -> *) where
matchedSymbols :: Proxy sym -> [Int]
-- | Provide error message describing the node symbol vs. the symbols this can match
showFailure :: Proxy a -> Node -> String
showFailure :: Proxy sym -> Node -> String
instance SymbolMatching f => SymbolMatching (M1 i c f) where
matchedSymbols _ = matchedSymbols (Proxy @f)
@ -254,6 +270,10 @@ instance (SymbolMatching f, SymbolMatching g) => SymbolMatching (f :+: g) where
matchedSymbols _ = matchedSymbols (Proxy @f) <> matchedSymbols (Proxy @g)
showFailure _ = sep <$> showFailure (Proxy @f) <*> showFailure (Proxy @g)
instance SymbolMatching f => SymbolMatching (shape :.: f) where
matchedSymbols _ = matchedSymbols (Proxy @f)
showFailure _ = showFailure (Proxy @f)
sep :: String -> String -> String
sep a b = a ++ ". " ++ b
@ -300,21 +320,24 @@ newtype FieldName = FieldName { getFieldName :: String }
-- Sum types are constructed by using the current node’s symbol to select the corresponding constructor deterministically.
class GUnmarshal f where
gunmarshalNode
:: UnmarshalAnn a
:: UnmarshalAnn ann
=> Node
-> MatchM (f a)
-> MatchM (f ann)
instance (Datatype d, GUnmarshalData f) => GUnmarshal (M1 D d f) where
gunmarshalNode = go (gunmarshalNode' (datatypeName @d undefined)) where
go :: (Node -> MatchM (f a)) -> Node -> MatchM (M1 i c f a)
go :: (Node -> MatchM (f ann)) -> Node -> MatchM (M1 i c f ann)
go = coerce
instance (GUnmarshal f, Applicative shape) => GUnmarshal (shape :.: f) where
gunmarshalNode = fmap (Comp1 . pure) . gunmarshalNode @f
class GUnmarshalData f where
gunmarshalNode'
:: UnmarshalAnn a
:: UnmarshalAnn ann
=> String
-> Node
-> MatchM (f a)
-> MatchM (f ann)
instance GUnmarshalData f => GUnmarshalData (M1 i c f) where
gunmarshalNode' = go gunmarshalNode' where
@ -350,11 +373,11 @@ instance (GUnmarshalProduct f, GUnmarshalProduct g) => GUnmarshalData (f :*: g)
-- | Generically unmarshal products
class GUnmarshalProduct f where
gunmarshalProductNode
:: UnmarshalAnn a
:: UnmarshalAnn ann
=> String
-> Node
-> Fields
-> MatchM (f a)
-> MatchM (f ann)
-- Product structure
instance (GUnmarshalProduct f, GUnmarshalProduct g) => GUnmarshalProduct (f :*: g) where
@ -391,15 +414,15 @@ instance (Unmarshal t, Selector c) => GUnmarshalProduct (M1 S c (Rec1 t)) where
fieldName = selName @c undefined
class GHasAnn a t where
gann :: t a -> a
class GHasAnn ann t where
gann :: t ann -> ann
instance GHasAnn a f => GHasAnn a (M1 i c f) where
instance GHasAnn ann f => GHasAnn ann (M1 i c f) where
gann = gann . unM1
instance (GHasAnn a l, GHasAnn a r) => GHasAnn a (l :+: r) where
instance (GHasAnn ann l, GHasAnn ann r) => GHasAnn ann (l :+: r) where
gann (L1 l) = gann l
gann (R1 r) = gann r
instance {-# OVERLAPPABLE #-} HasField "ann" (t a) a => GHasAnn a t where
gann = getField @"ann"
instance {-# OVERLAPPABLE #-} HasField "ann" (t ann) ann => GHasAnn ann t where
gann = getField @"ann"

4
semantic-codeql/src/Language/CodeQL/AST.hs
View File

@ -6,9 +6,13 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Language.CodeQL.AST
( module Language.CodeQL.AST

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

@ -11,6 +11,7 @@ module Language.CodeQL.Tags
where
import AST.Element
import qualified AST.Parse as Parse
import AST.Token
import AST.Traversable1
import Control.Effect.Reader
@ -64,57 +65,64 @@ instance ToTags CodeQL.Module where
tags
t@CodeQL.Module
{ ann = Loc {byteRange},
name = CodeQL.ModuleName {extraChildren = CodeQL.SimpleId {text, ann}}
name = Parse.Success (CodeQL.ModuleName {extraChildren = Parse.Success (CodeQL.SimpleId {text, ann})})
} = yieldTag text P.MODULE P.DEFINITION ann byteRange >> gtags t
tags _ = pure ()
instance ToTags CodeQL.ClasslessPredicate where
tags
t@CodeQL.ClasslessPredicate
{ ann = Loc {byteRange},
name = CodeQL.PredicateName {text, ann}
name = Parse.Success (CodeQL.PredicateName {text, ann})
} = yieldTag text P.FUNCTION P.DEFINITION ann byteRange >> gtags t
tags _ = pure ()
instance ToTags CodeQL.AritylessPredicateExpr where
tags
t@CodeQL.AritylessPredicateExpr
{ ann = Loc {byteRange},
name = CodeQL.LiteralId {text, ann}
name = Parse.Success (CodeQL.LiteralId {text, ann})
} = yieldTag text P.CALL P.REFERENCE ann byteRange >> gtags t
tags _ = pure ()
instance ToTags CodeQL.Dataclass where
tags
t@CodeQL.Dataclass
{ ann = Loc {byteRange},
name = CodeQL.ClassName {text, ann}
name = Parse.Success (CodeQL.ClassName {text, ann})
} = yieldTag text P.CLASS P.DEFINITION ann byteRange >> gtags t
tags _ = pure ()
instance ToTags CodeQL.MemberPredicate where
tags
t@CodeQL.MemberPredicate
{ ann = Loc {byteRange},
name = CodeQL.PredicateName {text, ann}
name = Parse.Success (CodeQL.PredicateName {text, ann})
} = yieldTag text P.METHOD P.DEFINITION ann byteRange >> gtags t
tags _ = pure ()
instance ToTags CodeQL.Datatype where
tags
t@CodeQL.Datatype
{ ann = Loc {byteRange},
name = CodeQL.ClassName {text, ann}
name = Parse.Success (CodeQL.ClassName {text, ann})
} = yieldTag text P.CLASS P.DEFINITION ann byteRange >> gtags t
tags _ = pure ()
instance ToTags CodeQL.DatatypeBranch where
tags
t@CodeQL.DatatypeBranch
{ ann = Loc {byteRange},
name = CodeQL.ClassName {text, ann}
name = Parse.Success (CodeQL.ClassName {text, ann})
} = yieldTag text P.CLASS P.DEFINITION ann byteRange >> gtags t
tags _ = pure ()
instance ToTags CodeQL.ClasslessPredicateCall where
tags
CodeQL.ClasslessPredicateCall
{ extraChildren
} = for_ extraChildren $ \x -> case x of
Prj t@CodeQL.AritylessPredicateExpr {} -> tags t
EPrj t@CodeQL.AritylessPredicateExpr {} -> tags t
_ -> pure ()
instance ToTags CodeQL.QualifiedRhs where
@ -123,7 +131,7 @@ instance ToTags CodeQL.QualifiedRhs where
{ ann = Loc {byteRange},
name = expr
} = case expr of
Just (Prj CodeQL.PredicateName {text, ann}) -> yieldTag text P.CALL P.REFERENCE ann byteRange >> gtags t
Just (EPrj CodeQL.PredicateName {text, ann}) -> yieldTag text P.CALL P.REFERENCE ann byteRange >> gtags t
_ -> gtags t
instance ToTags CodeQL.TypeExpr where
@ -132,7 +140,7 @@ instance ToTags CodeQL.TypeExpr where
{ ann = Loc {byteRange},
name = expr
} = case expr of
Just (Prj CodeQL.ClassName {text, ann}) -> yieldTag text P.TYPE P.REFERENCE ann byteRange >> gtags t
Just (EPrj CodeQL.ClassName {text, ann}) -> yieldTag text P.TYPE P.REFERENCE ann byteRange >> gtags t
_ -> gtags t
instance ToTags CodeQL.AddExpr

8
semantic-codeql/test/PreciseTest.hs
View File

@ -1,12 +1,12 @@
{-# LANGUAGE DisambiguateRecordFields, OverloadedStrings, TypeApplications #-}
module Main (main) where
import qualified System.Path as Path
import Test.Tasty
import AST.TestHelpers
import AST.Unmarshal
import qualified Language.CodeQL.AST as CodeQL
import Language.CodeQL.Grammar
import AST.Test
import AST.Unmarshal
import qualified System.Path as Path
import Test.Tasty
main :: IO ()
main

4
semantic-go/src/Language/Go/AST.hs
View File

@ -6,9 +6,13 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Language.Go.AST
( module Language.Go.AST

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

@ -10,6 +10,7 @@ module Language.Go.Tags
where
import AST.Element
import qualified AST.Parse as Parse
import AST.Token
import AST.Traversable1
import Control.Effect.Reader
@ -42,30 +43,33 @@ instance ToTags Go.FunctionDeclaration where
tags
t@Go.FunctionDeclaration
{ ann = Loc {byteRange},
name = Go.Identifier {text, ann}
name = Parse.Success (Go.Identifier {text, ann})
} = yieldTag text P.FUNCTION P.DEFINITION ann byteRange >> gtags t
tags _ = pure ()
instance ToTags Go.MethodDeclaration where
tags
t@Go.MethodDeclaration
{ ann = Loc {byteRange},
name = Go.FieldIdentifier {text, ann}
name = Parse.Success (Go.FieldIdentifier {text, ann})
} = yieldTag text P.METHOD P.DEFINITION ann byteRange >> gtags t
tags _ = pure ()
instance ToTags Go.CallExpression where
tags
t@Go.CallExpression
{ ann = Loc {byteRange},
function = Go.Expression expr
function = Parse.Success (Go.Expression expr)
} = match expr
where
match expr = case expr of
Prj Go.SelectorExpression {field = Go.FieldIdentifier {text, ann}} -> yield text ann
Prj Go.SelectorExpression {field = Parse.Success (Go.FieldIdentifier {text, ann})} -> yield text ann
Prj Go.Identifier {text, ann} -> yield text ann
Prj Go.CallExpression {function = Go.Expression e} -> match e
Prj Go.ParenthesizedExpression {extraChildren = Go.Expression e} -> match e
Prj Go.CallExpression {function = Parse.Success (Go.Expression e)} -> match e
Prj Go.ParenthesizedExpression {extraChildren = Parse.Success (Go.Expression e)} -> match e
_ -> gtags t
yield name loc = yieldTag name P.CALL P.REFERENCE loc byteRange >> gtags t
tags _ = pure ()
instance (ToTags l, ToTags r) => ToTags (l :+: r) where
tags (L1 l) = tags l

6
semantic-go/test/PreciseTest.hs
View File

@ -1,13 +1,15 @@
{-# LANGUAGE DisambiguateRecordFields, OverloadedStrings, TypeApplications #-}
module Main (main) where
import AST.Test
import AST.Unmarshal
import qualified Language.Go.AST as Go
import Language.Go.Grammar
import AST.TestHelpers
import AST.Unmarshal
import qualified System.Path as Path
import Test.Tasty
main :: IO ()
main
= Path.absDir <$> Go.getTestCorpusDir

4
semantic-java/src/Language/Java/AST.hs
View File

@ -6,9 +6,13 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Language.Java.AST
( module Language.Java.AST

1
semantic-java/src/Language/Java/Grammar.hs
View File

@ -1,4 +1,5 @@
{-# LANGUAGE TemplateHaskell #-}
module Language.Java.Grammar
( tree_sitter_java
, Grammar(..)

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

@ -11,6 +11,7 @@ module Language.Java.Tags
where
import AST.Element
import qualified AST.Parse as Parse
import AST.Token
import AST.Traversable1
import Control.Effect.Reader
@ -50,7 +51,7 @@ instance ToTags Java.MethodDeclaration where
tags
t@Java.MethodDeclaration
{ ann = Loc {byteRange = range},
name = Java.Identifier {text, ann},
name = Parse.Success (Java.Identifier {text, ann}),
body
} = do
src <- ask @Source
@ -59,11 +60,13 @@ instance ToTags Java.MethodDeclaration where
src
range
{ end = case body of
Just Java.Block {ann = Loc Range {end} _} -> end
Just (Parse.Success (Java.Block {ann = Loc Range {end} _})) -> end
Nothing -> end range
Just (Parse.Fail _) -> end range
}
Tags.yield (Tag text P.METHOD P.DEFINITION ann line Nothing)
gtags t
tags _ = pure ()
-- TODO: we can coalesce a lot of these instances given proper use of HasField
-- to do the equivalent of type-generic pattern-matching.
@ -72,38 +75,41 @@ instance ToTags Java.ClassDeclaration where
tags
t@Java.ClassDeclaration
{ ann = Loc {byteRange = Range {start}},
name = Java.Identifier {text, ann},
body = Java.ClassBody {ann = Loc Range {start = end} _}
name = Parse.Success (Java.Identifier {text, ann}),
body = Parse.Success (Java.ClassBody {ann = Loc Range {start = end} _})
} = do
src <- ask @Source
Tags.yield (Tag text P.CLASS P.DEFINITION ann (Tags.firstLine src (Range start end)) Nothing)
gtags t
tags _ = pure ()
instance ToTags Java.MethodInvocation where
tags
t@Java.MethodInvocation
{ ann = Loc {byteRange = range},
name = Java.Identifier {text, ann}
name = Parse.Success (Java.Identifier {text, ann})
} = do
src <- ask @Source
Tags.yield (Tag text P.CALL P.REFERENCE ann (Tags.firstLine src range) Nothing)
gtags t
tags _ = pure ()
instance ToTags Java.InterfaceDeclaration where
tags
t@Java.InterfaceDeclaration
{ ann = Loc {byteRange},
name = Java.Identifier {text, ann}
name = Parse.Success (Java.Identifier {text, ann})
} = do
src <- ask @Source
Tags.yield (Tag text P.INTERFACE P.DEFINITION ann (Tags.firstLine src byteRange) Nothing)
gtags t
tags _ = pure ()
instance ToTags Java.InterfaceTypeList where
tags t@Java.InterfaceTypeList {extraChildren = interfaces} = do
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}))))) ->
Parse.Success (Java.Type (Prj (Java.UnannotatedType (Prj (Java.SimpleType (Prj Java.TypeIdentifier {ann = loc@Loc {byteRange = range}, text = name})))))) ->
Tags.yield (Tag name P.IMPLEMENTATION P.REFERENCE loc (Tags.firstLine src range) Nothing)
_ -> pure ()
gtags t

5
semantic-java/test/PreciseTest.hs
View File

@ -1,10 +1,11 @@
{-# LANGUAGE OverloadedStrings, TypeApplications #-}
module Main (main) where
import AST.Test
import TreeSitter.Java
import AST.TestHelpers
import AST.Unmarshal
import qualified Language.Java.AST as Java
import Language.Java.Grammar
import qualified System.Path as Path
import Test.Tasty

8
semantic-json/src/Language/JSON/AST.hs
View File

@ -6,17 +6,23 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Language.JSON.AST
( module Language.JSON.AST
, JSON.getTestCorpusDir
) where
import Prelude hiding (String)
import AST.GenerateSyntax
import Language.Haskell.TH.Syntax (runIO)
import Prelude hiding (String)
import qualified TreeSitter.JSON as JSON (getNodeTypesPath, getTestCorpusDir, tree_sitter_json)
astDeclarationsForLanguage JSON.tree_sitter_json "/Users/patrickt/src/semantic/vendor/json-node-types.json"

8
semantic-json/test/PreciseTest.hs
View File

@ -1,7 +1,9 @@
{-# LANGUAGE DisambiguateRecordFields, OverloadedStrings, TypeApplications #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Main (main) where
import AST.Test
import AST.TestHelpers
import AST.Unmarshal
import qualified Language.JSON.AST as JSON
import Language.JSON.Grammar
@ -14,7 +16,7 @@ main
>>= readCorpusFiles'
>>= traverse (testCorpus parse)
>>= defaultMain . tests
where parse = parseByteString @JSON.Document @() tree_sitter_json
where parse = parseByteString @(JSON.Document) @() tree_sitter_json
tests :: [TestTree] -> TestTree
tests = testGroup "tree-sitter-json corpus tests"

4
semantic-php/src/Language/PHP/AST.hs
View File

@ -6,9 +6,13 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Language.PHP.AST
( module Language.PHP.AST

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

@ -12,6 +12,7 @@ module Language.PHP.Tags
where
import AST.Element
import qualified AST.Parse as Parse
import AST.Token
import AST.Traversable1
import Control.Effect.Reader
@ -64,15 +65,17 @@ instance ToTags PHP.FunctionDefinition where
tags
t@PHP.FunctionDefinition
{ PHP.ann = Loc {byteRange},
PHP.name = PHP.Name {text, ann}
PHP.name = Parse.Success (PHP.Name {text, ann})
} = yieldTag text P.METHOD P.DEFINITION ann byteRange >> gtags t
tags _ = pure ()
instance ToTags PHP.MethodDeclaration where
tags
t@PHP.MethodDeclaration
{ PHP.ann = Loc {byteRange},
PHP.name = PHP.Name {text, ann}
PHP.name = Parse.Success (PHP.Name {text, ann})
} = yieldTag text P.FUNCTION P.DEFINITION ann byteRange >> gtags t
tags _ = pure ()
instance ToTags PHP.FunctionCallExpression where
tags
@ -83,8 +86,8 @@ instance ToTags PHP.FunctionCallExpression where
where
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
EPrj PHP.VariableName {extraChildren = Parse.Success (PHP.Name {text, ann})} -> yield text ann *> gtags t
EPrj PHP.QualifiedName {extraChildren = [EPrj PHP.Name {text, ann}]} -> yield text ann *> gtags t
_ -> gtags t
@ -92,7 +95,7 @@ instance ToTags PHP.MemberCallExpression where
tags
t@PHP.MemberCallExpression
{ PHP.ann = Loc {byteRange},
PHP.name = Prj PHP.Name {text, ann}
PHP.name = Parse.Success (Prj PHP.Name {text, ann})
} = yieldTag text P.CALL P.REFERENCE ann byteRange >> gtags t
tags t = gtags t

89
semantic-python/semantic-python.cabal
View File

@ -26,11 +26,11 @@ common haskell
, parsers ^>= 0.12.10
, semantic-analysis ^>= 0
, semantic-ast
, semantic-core ^>= 0.0
-- , semantic-core ^>= 0.0
, semantic-proto ^>= 0
, semantic-source ^>= 0.1.0
, semantic-tags ^>= 0.0
, semantic-scope-graph ^>= 0.0
-- , semantic-scope-graph ^>= 0.0
, semilattices ^>= 0
, template-haskell ^>= 2.15
, text ^>= 1.2.3
@ -58,59 +58,60 @@ library
exposed-modules:
Language.Python
Language.Python.AST
Language.Python.Core
-- Language.Python.Core
Language.Python.Grammar
Language.Python.Failure
Language.Python.Patterns
Language.Python.ScopeGraph
-- Language.Python.ScopeGraph
Language.Python.Tags
hs-source-dirs: src
build-depends: lens ^>= 4.18
test-suite compiling
import: haskell
type: exitcode-stdio-1.0
hs-source-dirs: test
main-is: CoreTest.hs
ghc-options: -threaded
-- test-suite compiling
-- import: haskell
-- type: exitcode-stdio-1.0
-- hs-source-dirs: test
-- main-is: CoreTest.hs
-- ghc-options: -threaded
build-depends: semantic-python
, aeson ^>= 1.4.4
, aeson-pretty ^>= 0.8.7
, bytestring ^>= 0.10.8.2
, containers ^>= 0.6
, directory ^>= 1.3.3
, exceptions ^>= 0.10.2
, pathtype ^>= 0.8.1
, pretty-show ^>= 1.9.5
, process ^>= 1.6.5
, resourcet ^>= 1.2.2
, semantic-analysis ^>= 0
, streaming ^>= 0.2.2
, streaming-process ^>= 0.1
, streaming-bytestring ^>= 0.1.6
, tasty ^>= 1.2.3
, tasty-hunit ^>= 0.10.0.2
, trifecta >= 2 && <3
, unordered-containers ^>= 0.2.10
-- build-depends: semantic-python
-- , aeson ^>= 1.4.4
-- , aeson-pretty ^>= 0.8.7
-- , bytestring ^>= 0.10.8.2
-- , containers ^>= 0.6
-- , directory ^>= 1.3.3
-- , exceptions ^>= 0.10.2
-- , pathtype ^>= 0.8.1
-- , pretty-show ^>= 1.9.5
-- , process ^>= 1.6.5
-- , resourcet ^>= 1.2.2
-- , semantic-analysis ^>= 0
-- , streaming ^>= 0.2.2
-- , streaming-process ^>= 0.1
-- , streaming-bytestring ^>= 0.1.6
-- , tasty ^>= 1.2.3
-- , tasty-hunit ^>= 0.10.0.2
-- , trifecta >= 2 && <3
-- , unordered-containers ^>= 0.2.10
other-modules: Directive
, Instances
-- other-modules:
-- Instances
-- , Directive
test-suite graphing
import: haskell
type: exitcode-stdio-1.0
hs-source-dirs: test-graphing
main-is: GraphTest.hs
ghc-options: -threaded
-- test-suite graphing
-- import: haskell
-- type: exitcode-stdio-1.0
-- hs-source-dirs: test-graphing
-- main-is: GraphTest.hs
-- ghc-options: -threaded
build-depends: base
, semantic-python
, semantic-scope-graph
, bytestring
, pathtype
, tasty
, tasty-hunit
-- build-depends: base
-- , semantic-python
-- -- , semantic-scope-graph
-- , bytestring
-- , pathtype
-- , tasty
-- , tasty-hunit
test-suite test

8
semantic-python/src/Language/Python.hs
View File

@ -8,9 +8,9 @@ import qualified AST.Unmarshal as TS
import Data.Proxy
import qualified Language.Python.AST as Py
import qualified Language.Python.Grammar (tree_sitter_python)
import Language.Python.ScopeGraph
-- import Language.Python.ScopeGraph
import qualified Language.Python.Tags as PyTags
import Scope.Graph.Convert
-- import Scope.Graph.Convert
import qualified Tags.Tagging.Precise as Tags
newtype Term a = Term { getTerm :: Py.Module a }
@ -25,5 +25,5 @@ instance TS.Unmarshal Term where
instance Tags.ToTags Term where
tags src = Tags.runTagging src . PyTags.tags . getTerm
instance ToScopeGraph Term where
scopeGraph = scopeGraphModule . getTerm
-- instance ToScopeGraph Term where
-- scopeGraph = scopeGraphModule . getTerm

5
semantic-python/src/Language/Python/AST.hs
View File

@ -6,9 +6,14 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Language.Python.AST
( module Language.Python.AST

4
semantic-python/src/Language/Python/Core.hs
View File

@ -15,6 +15,10 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE ViewPatterns #-}
-- NOTE: This file needs to be updated to accommodate new AST shapes.
-- A portion of instances have been updated to include the Err functor;
-- remaining instances are to be updated once this is stable.
module Language.Python.Core
( toplevelCompile
, Bindings

3
semantic-python/src/Language/Python/Patterns.hs
View File

@ -9,6 +9,7 @@ module Language.Python.Patterns
) where
import AST.Element
import qualified AST.Parse as Parse
import qualified Analysis.Name
import qualified Language.Python.AST as Py
@ -19,6 +20,6 @@ import qualified Language.Python.AST as Py
pattern SingleIdentifier :: Analysis.Name.Name -> Py.ExpressionList a
pattern SingleIdentifier n <- Py.ExpressionList
{ Py.extraChildren =
[ Py.Expression (Prj (Py.PrimaryExpression (Prj Py.Identifier { text = Analysis.Name.name -> n })))
[ Parse.Success (Py.Expression (Prj (Py.PrimaryExpression (Prj Py.Identifier { text = Analysis.Name.name -> n }))))
]
}

27
semantic-python/src/Language/Python/ScopeGraph.hs
View File

@ -17,12 +17,17 @@
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
-- NOTE: This file needs to be updated to accommodate new AST shapes.
-- A portion of instances have been updated to include the Err functor;
-- remaining instances are to be updated once this is stable.
module Language.Python.ScopeGraph
( scopeGraphModule
) where
import qualified Analysis.Name as Name
import AST.Element
import qualified AST.Parse as Parse
import Control.Effect.ScopeGraph
import qualified Control.Effect.ScopeGraph.Properties.Declaration as Props
import qualified Control.Effect.ScopeGraph.Properties.Function as Props
@ -92,7 +97,7 @@ scopeGraphModule = getAp . scopeGraph
instance ToScopeGraph Py.AssertStatement where scopeGraph = onChildren
instance ToScopeGraph Py.Assignment where
scopeGraph (Py.Assignment ann (SingleIdentifier t) val _typ) = do
scopeGraph (Py.Assignment ann (Parse.Success (SingleIdentifier t)) val _typ) = do
declare t Props.Declaration
{ Props.kind = ScopeGraph.Assignment
, Props.relation = ScopeGraph.Default
@ -121,12 +126,12 @@ instance ToScopeGraph Py.BreakStatement where scopeGraph = mempty
instance ToScopeGraph Py.Call where
scopeGraph Py.Call
{ function
, arguments = L1 Py.ArgumentList { extraChildren = args }
{ function = Parse.Success f
, arguments = Parse.Success (L1 Py.ArgumentList { extraChildren = args })
} = do
result <- scopeGraph function
result <- scopeGraph f
let scopeGraphArg = \case
Prj expr -> scopeGraph @Py.Expression expr
EPrj expr -> scopeGraph @Py.Expression expr
other -> todo other
args <- traverse scopeGraphArg args
pure (result <> mconcat args)
@ -160,7 +165,7 @@ deriving instance ToScopeGraph Py.Expression
instance ToScopeGraph Py.ElseClause where scopeGraph = onField @"body"
instance ToScopeGraph Py.ElifClause where
scopeGraph (Py.ElifClause _ body condition) = scopeGraph condition <> scopeGraph body
scopeGraph (Py.ElifClause _ (Parse.Success body) (Parse.Success condition)) = scopeGraph condition <> scopeGraph body
instance ToScopeGraph Py.Ellipsis where scopeGraph = mempty
@ -183,9 +188,9 @@ instance ToScopeGraph Py.ForStatement where scopeGraph = todo
instance ToScopeGraph Py.FunctionDefinition where
scopeGraph Py.FunctionDefinition
{ ann
, name = Py.Identifier _ann1 name
, parameters = Py.Parameters _ann2 parameters
, body
, name = Parse.Success (Py.Identifier _ann1 name)
, parameters = Parse.Success (Py.Parameters _ann2 parameters)
, body = Parse.Success b
} = do
(_, associatedScope) <- declareFunction (Just $ Name.name name) Props.Function
{ Props.kind = ScopeGraph.Function
@ -207,7 +212,7 @@ instance ToScopeGraph Py.FunctionDefinition where
let parameters' = catMaybes parameterMs
paramDeclarations <- for parameters' $ \(pos, parameter) ->
complete <* declare parameter (set span_ (pos^.span_) declProps)
bodyResult <- scopeGraph body
bodyResult <- scopeGraph b
pure (mconcat paramDeclarations <> bodyResult)
instance ToScopeGraph Py.FutureImportStatement where scopeGraph = todo
@ -221,7 +226,7 @@ instance ToScopeGraph Py.Identifier where
complete
instance ToScopeGraph Py.IfStatement where
scopeGraph (Py.IfStatement _ alternative body condition)
scopeGraph (Py.IfStatement _ alternative (Parse.Success body) (Parse.Success condition))
= scopeGraph condition
<> scopeGraph body
<> foldMap scopeGraph alternative

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

@ -12,6 +12,7 @@ module Language.Python.Tags
where
import AST.Element
import qualified AST.Parse as Parse
import AST.Token
import AST.Traversable1
import Control.Effect.Reader
@ -64,12 +65,12 @@ keywordFunctionCall t loc range name = yieldTag name P.FUNCTION P.DEFINITION loc
instance ToTags Py.String where
tags Py.String {extraChildren} = for_ extraChildren $ \x -> case x of
Prj t@Py.Interpolation {} -> tags t
Parse.Success (Prj t@Py.Interpolation {}) -> tags t
_ -> pure ()
instance ToTags Py.Interpolation where
tags Py.Interpolation {extraChildren} = for_ extraChildren $ \x -> case x of
Prj (Py.Expression expr) -> tags expr
Parse.Success (Prj (Py.Expression expr)) -> tags expr
_ -> pure ()
instance ToTags Py.AssertStatement where
@ -97,46 +98,66 @@ instance ToTags Py.FunctionDefinition where
tags
t@Py.FunctionDefinition
{ ann = Loc {byteRange = Range {start}},
name = Py.Identifier {text, ann},
body = Py.Block {ann = Loc Range {start = end} _, extraChildren}
name = Parse.Success (Py.Identifier {text, ann}),
body = Parse.Success (Py.Block {ann = Loc Range {start = end} _, extraChildren})
} = do
src <- ask @Source
let docs = listToMaybe extraChildren >>= docComment src
yieldTag text P.FUNCTION P.DEFINITION ann (Range start end) docs >> gtags t
tags _ = pure ()
instance ToTags Py.ClassDefinition where
tags
t@Py.ClassDefinition
{ ann = Loc {byteRange = Range {start}},
name = Py.Identifier {text, ann},
body = Py.Block {ann = Loc Range {start = end} _, extraChildren}
name = Parse.Success (Py.Identifier {text, ann}),
body = Parse.Success (Py.Block {ann = Loc Range {start = end} _, extraChildren})
} = do
src <- ask @Source
let docs = listToMaybe extraChildren >>= docComment src
yieldTag text P.CLASS P.DEFINITION ann (Range start end) docs >> gtags t
tags _ = pure ()
instance ToTags Py.Call where
tags
t@Py.Call
{ ann = Loc {byteRange},
function = Py.PrimaryExpression expr
function = Parse.Success (Py.PrimaryExpression expr)
} = match expr
where
match expr = case expr of
Prj Py.Attribute {attribute = Py.Identifier {text, ann}} -> yield text ann
Prj Py.Attribute {attribute = Parse.Success (Py.Identifier {text, ann})} -> yield text ann
Prj Py.Identifier {text, ann} -> yield text ann
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
Prj Py.Call {function = Parse.Success (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 _ (Parse.Success (Prj (Py.Expression (Prj (Py.PrimaryExpression expr')))))) -> match expr' -- Parenthesized expressions
_ -> gtags t
yield name loc = yieldTag name P.CALL P.REFERENCE loc byteRange Nothing >> gtags t
tags _ = pure ()
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 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)))
docComment :: Source -> Parse.Err ((Py.CompoundStatement :+: Py.SimpleStatement) Loc) -> Maybe Text
docComment
src
( Parse.Success
( R1
( Py.SimpleStatement
( Prj
Py.ExpressionStatement
{ extraChildren =
Parse.Success
( L1
(Prj (Py.Expression (Prj (Py.PrimaryExpression (Prj Py.String {ann})))))
)
:| _
}
)
)
)
) = Just (toText (slice src (byteRange ann)))
docComment _ _ = Nothing
gtags ::

14
semantic-python/test/CoreTest.hs
View File

@ -13,11 +13,11 @@ import Control.Carrier.Fail.Either
import Control.Carrier.Reader
import Control.Monad hiding (fail)
import Control.Monad.IO.Class
import Core.Core
import qualified Core.Eval as Eval
import Core.Name
import qualified Core.Parser
import Core.Pretty
-- import Core.Core
-- import qualified Core.Eval as Eval
-- import Core.Name
-- import qualified Core.Parser
-- import Core.Pretty
import qualified Data.ByteString.Char8 as ByteString
import Data.Foldable
import Data.Function
@ -27,7 +27,7 @@ import qualified Data.Map as Map
import Data.Maybe
import Data.Text (Text)
import GHC.Stack
import qualified Language.Python.Core as Py
-- import qualified Language.Python.Core as Py
import Language.Python.Failure
import Prelude hiding (fail)
import Source.Span
@ -45,7 +45,7 @@ import qualified AST.Unmarshal as TS
import qualified Test.Tasty as Tasty
import qualified Test.Tasty.HUnit as HUnit
import qualified Directive
-- import qualified Directive
import Instances ()
parsePrelude :: IO (Term (Ann Span :+: Core) Name)

10
semantic-python/test/Directive.hs
View File

@ -10,11 +10,11 @@ import Analysis.Concrete (Concrete (..))
import Control.Algebra
import Control.Monad
import Control.Monad.Trans.Resource (ResourceT, runResourceT)
import Core.Core (Core)
import qualified Core.Core as Core
import Core.Name (Name)
import qualified Core.Parser
import qualified Core.Pretty
-- import Core.Core (Core)
-- import qualified Core.Core as Core
-- import Core.Name (Name)
-- import qualified Core.Parser
-- import qualified Core.Pretty
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as ByteString
import qualified Data.ByteString.Streaming.Char8 as ByteStream

4
semantic-python/test/PreciseTest.hs
View File

@ -3,9 +3,9 @@ module Main (main) where
import qualified System.Path as Path
import Test.Tasty
import TreeSitter.Python
import qualified Language.Python.AST as Py
import Language.Python.Grammar
import AST.Test
import AST.TestHelpers
import AST.Unmarshal
main :: IO ()

4
semantic-ruby/src/Language/Ruby/AST.hs
View File

@ -6,9 +6,13 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Language.Ruby.AST
( module Language.Ruby.AST

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

@ -1,13 +1,12 @@
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}
{-# HLINT ignore "Reduce duplication" #-}
module Language.Ruby.Tags
( ToTags (..),
@ -15,6 +14,7 @@ module Language.Ruby.Tags
where
import AST.Element
import qualified AST.Parse as Parse
import AST.Token
import AST.Traversable1
import qualified AST.Unmarshal as TS
@ -83,56 +83,59 @@ instance ToTags Rb.Class where
tags
t@Rb.Class
{ ann = Loc {byteRange = Range {start}},
name = expr,
name = Parse.Success expr,
extraChildren
} = enterScope True $ case expr of
Prj Rb.Constant {text, ann} -> yield text ann
Prj Rb.ScopeResolution {name = Prj Rb.Constant {text, ann}} -> yield text ann
Prj Rb.ScopeResolution {name = Prj Rb.Identifier {text, ann}} -> yield text ann
Prj Rb.ScopeResolution {name = EPrj Rb.Constant {text, ann}} -> yield text ann
Prj Rb.ScopeResolution {name = EPrj Rb.Identifier {text, ann}} -> yield text ann
_ -> gtags t
where
range' = case extraChildren of
Prj Rb.Superclass {ann = Loc {byteRange = Range {end}}} : _ -> Range start end
EPrj 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 P.DEFINITION loc range' >> gtags t
tags _ = pure ()
instance ToTags Rb.SingletonClass where
tags
t@Rb.SingletonClass
{ ann = Loc {byteRange = range@Range {start}},
value = Rb.Arg expr,
value = Parse.Success (Rb.Arg expr),
extraChildren
} = enterScope True $ case expr of
Prj (Rb.Primary (Prj (Rb.Lhs (Prj (Rb.Variable (Prj Rb.Constant {text, ann})))))) -> yield text ann
Prj (Rb.Primary (Prj (Rb.Lhs (Prj Rb.ScopeResolution {name = Prj Rb.Constant {text, ann}})))) -> yield text ann
Prj (Rb.Primary (Prj (Rb.Lhs (Prj Rb.ScopeResolution {name = Prj Rb.Identifier {text, ann}})))) -> yield text ann
Prj (Rb.Primary (Prj (Rb.Lhs (Prj Rb.ScopeResolution {name = EPrj Rb.Constant {text, ann}})))) -> yield text ann
Prj (Rb.Primary (Prj (Rb.Lhs (Prj Rb.ScopeResolution {name = EPrj Rb.Identifier {text, ann}})))) -> yield text ann
_ -> gtags t
where
range' = case extraChildren of
x : _ -> Range start (getStart x)
Parse.Success x : _ -> Range start (getStart x)
_ -> range
getStart = Range.start . byteRange . TS.gann
yield name loc = yieldTag name P.CLASS P.DEFINITION loc range' >> gtags t
tags _ = pure ()
instance ToTags Rb.Module where
tags
t@Rb.Module
{ ann = Loc {byteRange = Range {start}},
name = expr,
name = Parse.Success expr,
extraChildren
} = enterScope True $ case expr of
Prj Rb.Constant {text, ann} -> yield text ann
Prj Rb.ScopeResolution {name = Prj Rb.Constant {text, ann}} -> yield text ann
Prj Rb.ScopeResolution {name = Prj Rb.Identifier {text, ann}} -> yield text ann
Prj Rb.ScopeResolution {name = EPrj Rb.Constant {text, ann}} -> yield text ann
Prj Rb.ScopeResolution {name = EPrj Rb.Identifier {text, ann}} -> yield text ann
_ -> gtags t
where
range' = case extraChildren of
x : _ -> Range start (getStart x)
Parse.Success x : _ -> Range start (getStart x)
_ -> Range start (getEnd expr)
getEnd = Range.end . byteRange . TS.gann
getStart = Range.start . byteRange . TS.gann
yield name loc = yieldTag name P.MODULE P.DEFINITION loc range' >> gtags t
tags _ = pure ()
yieldMethodNameTag ::
( Has (State [Text]) sig m,
@ -151,7 +154,7 @@ yieldMethodNameTag t range (Rb.MethodName expr) = enterScope True $ case expr of
Prj Rb.Operator {text, ann} -> yield text ann
-- Prj Rb.GlobalVariable { text = name } -> yield name
-- Prj Rb.InstanceVariable { text = name } -> yield name
Prj Rb.Setter {extraChildren = Rb.Identifier {text, ann}} -> yield (text <> "=") ann-- NB: Matches existing tags output, TODO: Remove this.
Prj Rb.Setter {extraChildren = Parse.Success (Rb.Identifier {text, ann})} -> yield (text <> "=") ann-- NB: Matches existing tags output, TODO: Remove this.
-- TODO: Should we report symbol method names as tags?
-- Prj Rb.Symbol { extraChildren = [Prj Rb.EscapeSequence { text = name }] } -> yield name
_ -> gtags t
@ -169,27 +172,29 @@ instance ToTags Rb.Method where
tags
t@Rb.Method
{ ann = Loc {byteRange = Range {start}},
name,
name = Parse.Success n,
parameters
} = yieldMethodNameTag t range' name
} = yieldMethodNameTag t range' n
where
range' = case parameters of
Just Rb.MethodParameters {ann = Loc {byteRange = Range {end}}} -> Range start end
_ -> Range start (getEnd name)
Just (Parse.Success (Rb.MethodParameters {ann = Loc {byteRange = Range {end}}})) -> Range start end
_ -> Range start (getEnd n)
getEnd = Range.end . byteRange . TS.gann
tags _ = pure ()
instance ToTags Rb.SingletonMethod where
tags
t@Rb.SingletonMethod
{ ann = Loc {byteRange = Range {start}},
name,
name = Parse.Success n,
parameters
} = yieldMethodNameTag t range' name
} = yieldMethodNameTag t range' n
where
range' = case parameters of
Just Rb.MethodParameters {ann = Loc {byteRange = Range {end}}} -> Range start end
_ -> Range start (getEnd name)
Just (Parse.Success (Rb.MethodParameters {ann = Loc {byteRange = Range {end}}})) -> Range start end
_ -> Range start (getEnd n)
getEnd = Range.end . byteRange . TS.gann
tags _ = pure ()
instance ToTags Rb.Block where
tags = enterScope False . gtags
@ -198,33 +203,53 @@ instance ToTags Rb.DoBlock where
tags = enterScope False . gtags
instance ToTags Rb.Lambda where
tags Rb.Lambda {body, parameters} = enterScope False $ do
maybe (pure ()) tags parameters
tags body
tags Rb.Lambda {body = Parse.Success b, parameters} = enterScope False $ do
case parameters of
Just (Parse.Success p) -> tags p
_ -> pure ()
tags b
tags _ = pure ()
instance ToTags Rb.If where
tags Rb.If {condition, consequence, alternative} = do
tags condition
maybe (pure ()) tags consequence
maybe (pure ()) tags alternative
tags Rb.If {condition = Parse.Success cond, consequence, alternative} = do
tags cond
case consequence of
Just (Parse.Success cons) -> tags cons
_ -> pure ()
case alternative of
Just (Parse.Success alt) -> tags alt
_ -> pure ()
tags _ = pure ()
instance ToTags Rb.Elsif where
tags Rb.Elsif {condition, consequence, alternative} = do
tags condition
maybe (pure ()) tags consequence
maybe (pure ()) tags alternative
tags Rb.Elsif {condition = Parse.Success cond, consequence, alternative} = do
tags cond
case consequence of
Just (Parse.Success cons) -> tags cons
_ -> pure ()
case alternative of
Just (Parse.Success alt) -> tags alt
_ -> pure ()
tags _ = pure ()
instance ToTags Rb.Unless where
tags Rb.Unless {condition, consequence, alternative} = do
tags condition
maybe (pure ()) tags consequence
maybe (pure ()) tags alternative
tags Rb.Unless {condition = Parse.Success cond, consequence, alternative} = do
tags cond
case consequence of
Just (Parse.Success cons) -> tags cons
_ -> pure ()
case alternative of
Just (Parse.Success alt) -> tags alt
_ -> pure ()
tags _ = pure ()
instance ToTags Rb.While where
tags Rb.While {condition, body} = tags condition >> tags body
tags Rb.While {condition = Parse.Success cond, body = Parse.Success b} = tags cond >> tags b
tags _ = pure ()
instance ToTags Rb.Until where
tags Rb.Until {condition, body} = tags condition >> tags body
tags Rb.Until {condition = Parse.Success cond, body = Parse.Success b} = tags cond >> tags b
tags _ = pure ()
instance ToTags Rb.Regex where
tags Rb.Regex {} = pure ()
@ -237,15 +262,15 @@ instance ToTags Rb.Lhs where
tags t@(Rb.Lhs expr) = case expr of
-- NOTE: Calls do not look for locals
Prj Rb.Call {ann = Loc {byteRange}, method} -> case method of
Prj Rb.Identifier {text, ann} -> yieldCall text ann byteRange
Prj Rb.Constant {text, ann} -> yieldCall text ann byteRange
Prj Rb.Operator {text, ann} -> yieldCall text ann byteRange
EPrj Rb.Identifier {text, ann} -> yieldCall text ann byteRange
EPrj Rb.Constant {text, ann} -> yieldCall text ann byteRange
EPrj Rb.Operator {text, ann} -> yieldCall text ann byteRange
_ -> gtags t
-- These do check for locals before yielding a call tag
Prj (Rb.Variable (Prj Rb.Identifier {ann = loc@Loc {byteRange}, text})) -> yield text P.CALL loc byteRange
Prj Rb.ScopeResolution {ann = loc@Loc {byteRange}, name = Prj Rb.Identifier {text}} -> yield text P.CALL loc byteRange
Prj Rb.ScopeResolution {ann = loc@Loc {byteRange}, name = EPrj Rb.Identifier {text}} -> yield text P.CALL loc byteRange
Prj (Rb.Variable (Prj Rb.Constant { ann = loc@Loc { byteRange }, text })) -> yield text P.CALL loc byteRange -- TODO: Should yield Constant
Prj Rb.ScopeResolution { ann = loc@Loc { byteRange }, name = Prj Rb.Constant { text } } -> yield text P.CALL loc byteRange -- TODO: Should yield Constant
Prj Rb.ScopeResolution { ann = loc@Loc { byteRange }, name = EPrj Rb.Constant { text } } -> yield text P.CALL loc byteRange -- TODO: Should yield Constant
_ -> gtags t
where
yieldCall name loc range = yieldTag name P.CALL P.REFERENCE loc range >> gtags t
@ -261,14 +286,14 @@ instance ToTags Rb.MethodCall where
{ ann = Loc {byteRange = byteRange@Range {}},
method = expr
} = case expr of
Prj (Rb.Variable (Prj Rb.Identifier {text, ann})) -> yield text P.CALL ann
Prj (Rb.Variable (Prj Rb.Constant {text, ann})) -> yield text P.CALL ann -- TODO: Should yield Constant
Prj Rb.ScopeResolution {name = Prj Rb.Identifier {text, ann}} -> yield text P.CALL ann
Prj Rb.ScopeResolution {name = Prj Rb.Constant {text, ann}} -> yield text P.CALL ann -- TODO: Should yield Constant
Prj Rb.Call {method} -> case method of
Prj Rb.Identifier {text, ann} -> yield text P.CALL ann
Prj Rb.Constant {text, ann} -> yield text P.CALL ann
Prj Rb.Operator {text, ann} -> yield text P.CALL ann
EPrj (Rb.Variable (Prj Rb.Identifier {text, ann})) -> yield text P.CALL ann
EPrj (Rb.Variable (Prj Rb.Constant {text, ann})) -> yield text P.CALL ann -- TODO: Should yield Constant
EPrj Rb.ScopeResolution {name = EPrj Rb.Identifier {text, ann}} -> yield text P.CALL ann
EPrj Rb.ScopeResolution {name = EPrj Rb.Constant {text, ann}} -> yield text P.CALL ann -- TODO: Should yield Constant
EPrj Rb.Call {method} -> case method of
EPrj Rb.Identifier {text, ann} -> yield text P.CALL ann
EPrj Rb.Constant {text, ann} -> yield text P.CALL ann
EPrj Rb.Operator {text, ann} -> yield text P.CALL ann
_ -> gtags t
_ -> gtags t
where
@ -277,8 +302,8 @@ instance ToTags Rb.MethodCall where
instance ToTags Rb.Alias where
tags
t@Rb.Alias
{ alias = Rb.MethodName aliasExpr,
name = Rb.MethodName nameExpr,
{ alias = Parse.Success (Rb.MethodName aliasExpr),
name = Parse.Success (Rb.MethodName nameExpr),
ann = Loc {byteRange}
} = do
case aliasExpr of
@ -288,37 +313,53 @@ instance ToTags Rb.Alias where
Prj Rb.Identifier {ann, text} -> yieldTag text P.CALL P.REFERENCE ann byteRange
_ -> tags nameExpr
gtags t
tags _ = pure ()
instance ToTags Rb.Undef where
tags
t@Rb.Undef
{ extraChildren,
ann = Loc {byteRange}
} = for_ extraChildren $ \(Rb.MethodName expr) -> do
case expr of
Prj Rb.Identifier {ann, text} -> yieldTag text P.CALL P.REFERENCE ann byteRange
_ -> tags expr
} = do
for_ extraChildren $
\case
Parse.Success (Rb.MethodName expr) -> do
case expr of
Prj Rb.Identifier {ann, text} -> yieldTag text P.CALL P.REFERENCE ann byteRange
_ -> tags expr
Parse.Fail _ -> pure ()
gtags t
introduceLocals ::
( Has (Reader Source) sig m,
Has (Writer Tags.Tags) sig m,
Has (State [Text]) sig m
) =>
[ ( (Rb.BlockParameter :+: Rb.DestructuredParameter :+: Rb.HashSplatParameter)
:+: ((Rb.Identifier :+: Rb.KeywordParameter) :+: (Rb.OptionalParameter :+: Rb.SplatParameter))
)
Loc
[ Parse.Err
( (:+:)
Rb.BlockParameter
( Rb.DestructuredParameter
:+: ( Rb.HashSplatParameter
:+: ( Rb.Identifier
:+: ( Rb.KeywordParameter
:+: (Rb.OptionalParameter :+: Rb.SplatParameter)
)
)
)
)
Loc
)
] ->
m ()
introduceLocals params = for_ params $ \param -> case param of
Prj Rb.BlockParameter {name = Rb.Identifier {text = lvar}} -> modify (lvar :)
Prj Rb.DestructuredParameter {extraChildren} -> introduceLocals extraChildren
Prj Rb.HashSplatParameter {name = Just Rb.Identifier {text = lvar}} -> modify (lvar :)
Prj Rb.Identifier {text = lvar} -> modify (lvar :)
Prj Rb.KeywordParameter {name = Rb.Identifier {text = lvar}} -> modify (lvar :)
Prj Rb.OptionalParameter {name = Rb.Identifier {text = lvar}} -> modify (lvar :)
Prj Rb.SplatParameter {name = Just Rb.Identifier {text = lvar}} -> modify (lvar :)
EPrj Rb.BlockParameter {name = Parse.Success (Rb.Identifier {text = lvar})} -> modify (lvar :)
EPrj Rb.DestructuredParameter {extraChildren} -> introduceLocals extraChildren
EPrj Rb.HashSplatParameter {name = Just (Parse.Success (Rb.Identifier {text = lvar}))} -> modify (lvar :)
EPrj Rb.Identifier {text = lvar} -> modify (lvar :)
EPrj Rb.KeywordParameter {name = Parse.Success (Rb.Identifier {text = lvar})} -> modify (lvar :)
EPrj Rb.OptionalParameter {name = Parse.Success (Rb.Identifier {text = lvar})} -> modify (lvar :)
EPrj Rb.SplatParameter {name = Just (Parse.Success (Rb.Identifier {text = lvar}))} -> modify (lvar :)
_ -> pure ()
instance ToTags Rb.MethodParameters where
@ -333,21 +374,21 @@ instance ToTags Rb.BlockParameters where
instance ToTags Rb.Assignment where
tags t@Rb.Assignment {left} = do
case left of
Prj (Rb.Lhs (Prj (Rb.Variable (Prj Rb.Identifier {text})))) -> modify (text :)
Prj Rb.LeftAssignmentList {extraChildren} -> introduceLhsLocals extraChildren
EPrj (Rb.Lhs (Prj (Rb.Variable (Prj Rb.Identifier {text})))) -> modify (text :)
EPrj Rb.LeftAssignmentList {extraChildren} -> introduceLhsLocals extraChildren
_ -> pure ()
gtags t
where
introduceLhsLocals xs = for_ xs $ \x -> case x of
Prj (Rb.Lhs (Prj (Rb.Variable (Prj Rb.Identifier {text})))) -> modify (text :)
Prj Rb.DestructuredLeftAssignment {extraChildren} -> introduceLhsLocals extraChildren
Prj Rb.RestAssignment {extraChildren = Just (Rb.Lhs (Prj (Rb.Variable (Prj Rb.Identifier {text}))))} -> modify (text :)
EPrj (Rb.Lhs (Prj (Rb.Variable (Prj Rb.Identifier {text})))) -> modify (text :)
EPrj Rb.DestructuredLeftAssignment {extraChildren} -> introduceLhsLocals extraChildren
EPrj Rb.RestAssignment {extraChildren = Just (Parse.Success (Rb.Lhs (Prj (Rb.Variable (Prj Rb.Identifier {text})))))} -> modify (text :)
_ -> pure ()
instance ToTags Rb.OperatorAssignment where
tags t@Rb.OperatorAssignment {left} = do
case left of
Prj (Rb.Lhs (Prj (Rb.Variable (Prj Rb.Identifier {text})))) -> modify (text :)
EPrj (Rb.Lhs (Prj (Rb.Variable (Prj Rb.Identifier {text})))) -> modify (text :)
_ -> pure ()
gtags t

4
semantic-ruby/test/PreciseTest.hs
View File

@ -1,10 +1,10 @@
{-# LANGUAGE DisambiguateRecordFields, OverloadedStrings, TypeApplications #-}
module Main (main) where
import AST.Test
import TreeSitter.Ruby
import AST.TestHelpers
import AST.Unmarshal
import qualified Language.Ruby.AST as Rb
import Language.Ruby.Grammar
import qualified System.Path as Path
import Test.Tasty

3
semantic-rust/src/Language/Rust/AST.hs
View File

@ -7,8 +7,11 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Language.Rust.AST
( module Language.Rust.AST

3
semantic-rust/test/Test.hs
View File

@ -2,10 +2,9 @@
{-# LANGUAGE TypeApplications #-}
module Main (main) where
import AST.Test
import AST.TestHelpers
import AST.Unmarshal (parseByteString)
import qualified Language.Rust.AST as Rust
import Language.Rust.Grammar
import qualified System.Path as Path
import Test.Tasty
import Control.Monad (liftM)

4
semantic-tsx/src/Language/TSX/AST.hs
View File

@ -6,9 +6,13 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Language.TSX.AST
( module Language.TSX.AST

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

@ -12,6 +12,7 @@ module Language.TSX.Tags
where
import AST.Element
import qualified AST.Parse as Parse
import AST.Token
import AST.Traversable1
import Control.Effect.Reader
@ -42,80 +43,87 @@ class ToTags t where
tags = gtags
instance ToTags Tsx.Function where
tags t@Tsx.Function {ann = Loc {byteRange}, name = Just Tsx.Identifier {text, ann}} =
tags t@Tsx.Function {ann = Loc {byteRange}, name = Just (Parse.Success (Tsx.Identifier {text, ann}))} =
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}} =
tags t@Tsx.FunctionSignature {ann = Loc {byteRange}, name = Parse.Success (Tsx.Identifier {text, ann})} =
yieldTag text P.FUNCTION P.DEFINITION ann byteRange >> gtags t
tags _ = pure ()
instance ToTags Tsx.FunctionDeclaration where
tags t@Tsx.FunctionDeclaration {ann = Loc {byteRange}, name = Tsx.Identifier {text, ann}} =
tags t@Tsx.FunctionDeclaration {ann = Loc {byteRange}, name = Parse.Success (Tsx.Identifier {text, ann})} =
yieldTag text P.FUNCTION P.DEFINITION ann byteRange >> gtags t
tags _ = pure ()
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 P.DEFINITION ann byteRange >> gtags t
EPrj Tsx.PropertyIdentifier {text, ann} -> yieldTag text P.METHOD P.DEFINITION ann byteRange >> gtags t
_ -> gtags t
instance ToTags Tsx.Pair where
tags t@Tsx.Pair {ann = Loc {byteRange}, key, value = Tsx.Expression expr} = case (key, expr) of
(Prj Tsx.PropertyIdentifier {text, ann}, Prj Tsx.Function {}) -> yield text ann
(Prj Tsx.PropertyIdentifier {text, ann}, Prj Tsx.ArrowFunction {}) -> yield text ann
tags t@Tsx.Pair {ann = Loc {byteRange}, key, value = Parse.Success (Tsx.Expression expr)} = case (key, expr) of
(EPrj Tsx.PropertyIdentifier {text, ann}, Prj Tsx.Function {}) -> yield text ann
(EPrj Tsx.PropertyIdentifier {text, ann}, Prj Tsx.ArrowFunction {}) -> yield text ann
_ -> gtags t
where
yield text loc = yieldTag text P.FUNCTION P.DEFINITION loc byteRange >> gtags t
tags _ = pure ()
instance ToTags Tsx.ClassDeclaration where
tags t@Tsx.ClassDeclaration {ann = Loc {byteRange}, name = Tsx.TypeIdentifier {text, ann}} =
tags t@Tsx.ClassDeclaration {ann = Loc {byteRange}, name = Parse.Success (Tsx.TypeIdentifier {text, ann})} =
yieldTag text P.CLASS P.DEFINITION ann byteRange >> gtags t
tags _ = pure ()
instance ToTags Tsx.CallExpression where
tags t@Tsx.CallExpression {ann = Loc {byteRange}, function = Tsx.Expression expr} = match expr
tags t@Tsx.CallExpression {ann = Loc {byteRange}, function = Parse.Success (Tsx.Expression expr)} = match expr
where
match expr = case expr of
Prj Tsx.Identifier {text, ann} -> yield text ann
Prj Tsx.NewExpression {constructor = Prj Tsx.Identifier {text, ann}} -> yield text ann
Prj Tsx.CallExpression {function = Tsx.Expression expr} -> match expr
Prj Tsx.MemberExpression {property = Tsx.PropertyIdentifier {text, ann}} -> yield text ann
Prj Tsx.Function {name = Just Tsx.Identifier {text, ann}} -> yield text ann
Prj Tsx.NewExpression {constructor = EPrj Tsx.Identifier {text, ann}} -> yield text ann
Prj Tsx.CallExpression {function = Parse.Success (Tsx.Expression expr)} -> match expr
Prj Tsx.MemberExpression {property = Parse.Success (Tsx.PropertyIdentifier {text, ann})} -> yield text ann
Prj Tsx.Function {name = Just (Parse.Success (Tsx.Identifier {text, ann}))} -> yield text ann
Prj Tsx.ParenthesizedExpression {extraChildren} -> for_ extraChildren $ \x -> case x of
Prj (Tsx.Expression expr) -> match expr
_ -> tags x
EPrj (Tsx.Expression expr) -> match expr
Parse.Success x -> tags x
Parse.Fail _ -> pure ()
_ -> gtags t
yield name loc = yieldTag name P.CALL P.REFERENCE loc byteRange >> gtags t
tags _ = pure ()
instance ToTags Tsx.Class where
tags t@Tsx.Class {ann = Loc {byteRange}, name = Just Tsx.TypeIdentifier {text, ann}} =
tags t@Tsx.Class {ann = Loc {byteRange}, name = Just (Parse.Success (Tsx.TypeIdentifier {text, ann}))} =
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 P.DEFINITION ann byteRange >> gtags t
EPrj Tsx.Identifier {text, ann} -> yieldTag text P.MODULE P.DEFINITION ann byteRange >> gtags t
_ -> gtags t
instance ToTags Tsx.VariableDeclarator where
tags t@Tsx.VariableDeclarator {ann = Loc {byteRange}, name, value = Just (Tsx.Expression expr)} =
tags t@Tsx.VariableDeclarator {ann = Loc {byteRange}, name, value = Just (Parse.Success (Tsx.Expression expr))} =
case (expr, name) of
(Prj Tsx.Function {}, Prj Tsx.Identifier {text, ann}) -> yield text ann
(Prj Tsx.ArrowFunction {}, Prj Tsx.Identifier {text, ann}) -> yield text ann
(Prj Tsx.Function {}, EPrj Tsx.Identifier {text, ann}) -> yield text ann
(Prj Tsx.ArrowFunction {}, EPrj Tsx.Identifier {text, ann}) -> yield text ann
_ -> gtags t
where
yield text loc = yieldTag text P.FUNCTION P.DEFINITION loc byteRange >> gtags t
tags t = gtags t
instance ToTags Tsx.AssignmentExpression where
tags t@Tsx.AssignmentExpression {ann = Loc {byteRange}, left, right = (Tsx.Expression expr)} =
tags t@Tsx.AssignmentExpression {ann = Loc {byteRange}, left, right = Parse.Success (Tsx.Expression expr)} =
case (left, expr) of
(Prj Tsx.Identifier {text, ann}, Prj Tsx.Function {}) -> yield text ann
(Prj Tsx.Identifier {text, ann}, Prj Tsx.ArrowFunction {}) -> yield text ann
(Prj Tsx.MemberExpression {property = Tsx.PropertyIdentifier {text, ann}}, Prj Tsx.Function {}) -> yield text ann
(Prj Tsx.MemberExpression {property = Tsx.PropertyIdentifier {text, ann}}, Prj Tsx.ArrowFunction {}) -> yield text ann
(EPrj Tsx.Identifier {text, ann}, Prj Tsx.Function {}) -> yield text ann
(EPrj Tsx.Identifier {text, ann}, Prj Tsx.ArrowFunction {}) -> yield text ann
(EPrj Tsx.MemberExpression {property = Parse.Success (Tsx.PropertyIdentifier {text, ann})}, Prj Tsx.Function {}) -> yield text ann
(EPrj Tsx.MemberExpression {property = Parse.Success (Tsx.PropertyIdentifier {text, ann})}, Prj Tsx.ArrowFunction {}) -> yield text ann
_ -> gtags t
where
yield text loc = yieldTag text P.FUNCTION P.DEFINITION loc byteRange >> gtags t
tags _ = pure ()
instance (ToTags l, ToTags r) => ToTags (l :+: r) where
tags (L1 l) = tags l

5
semantic-tsx/test/PreciseTest.hs
View File

@ -1,10 +1,11 @@
{-# LANGUAGE DisambiguateRecordFields, OverloadedStrings, TypeApplications #-}
module Main (main) where
import AST.Test
import TreeSitter.TSX
import AST.TestHelpers
import AST.Unmarshal
import qualified Language.TSX.AST as Tsx
import Language.TSX.Grammar
import qualified System.Path as Path
import Test.Tasty

4
semantic-typescript/src/Language/TypeScript/AST.hs
View File

@ -6,9 +6,13 @@
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Language.TypeScript.AST
( module Language.TypeScript.AST

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

@ -1,6 +1,9 @@
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE DisambiguateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
@ -12,6 +15,7 @@ module Language.TypeScript.Tags
where
import AST.Element
import qualified AST.Parse as Parse
import AST.Token
import AST.Traversable1
import Control.Effect.Reader
@ -25,7 +29,7 @@ import Source.Source as Source
import Tags.Tag
import qualified Tags.Tagging.Precise as Tags
class ToTags t where
class ToTags (t :: * -> *) where
tags ::
( Has (Reader Source) sig m,
Has (Writer Tags.Tags) sig m
@ -42,80 +46,88 @@ class ToTags t where
tags = gtags
instance ToTags Ts.Function where
tags t@Ts.Function {ann = Loc {byteRange}, name = Just Ts.Identifier {text, ann}} =
tags t@Ts.Function {ann = Loc {byteRange}, name = Just (Parse.Success Ts.Identifier {text, ann})} =
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}} =
tags t@Ts.FunctionSignature {ann = Loc {byteRange}, name = Parse.Success (Ts.Identifier {text, ann})} =
yieldTag text P.FUNCTION P.DEFINITION ann byteRange >> gtags t
tags _ = pure ()
instance ToTags Ts.FunctionDeclaration where
tags t@Ts.FunctionDeclaration {ann = Loc {byteRange}, name = Ts.Identifier {text, ann}} =
tags t@Ts.FunctionDeclaration {ann = Loc {byteRange}, name = Parse.Success (Ts.Identifier {text, ann})} =
yieldTag text P.FUNCTION P.DEFINITION ann byteRange >> gtags t
tags _ = pure ()
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 P.DEFINITION ann byteRange >> gtags t
Parse.Success (Prj Ts.PropertyIdentifier {text, ann}) -> yieldTag text P.METHOD P.DEFINITION ann byteRange >> gtags t
_ -> gtags t
instance ToTags Ts.Pair where
tags t@Ts.Pair {ann = Loc {byteRange}, key, value = Ts.Expression expr} = case (key, expr) of
tags t@Ts.Pair {ann = Loc {byteRange}, key = Parse.Success key, value = Parse.Success (Ts.Expression expr)} = case (key, expr) of
(Prj Ts.PropertyIdentifier {text, ann}, Prj Ts.Function {}) -> yield text ann
(Prj Ts.PropertyIdentifier {text, ann}, Prj Ts.ArrowFunction {}) -> yield text ann
_ -> gtags t
where
yield text loc = yieldTag text P.FUNCTION P.DEFINITION loc byteRange >> gtags t
tags _ = pure ()
instance ToTags Ts.ClassDeclaration where
tags t@Ts.ClassDeclaration {ann = Loc {byteRange}, name = Ts.TypeIdentifier {text, ann}} =
tags t@Ts.ClassDeclaration {ann = Loc {byteRange}, name = Parse.Success (Ts.TypeIdentifier {text, ann})} =
yieldTag text P.CLASS P.DEFINITION ann byteRange >> gtags t
tags _ = pure ()
instance ToTags Ts.CallExpression where
tags t@Ts.CallExpression {ann = Loc {byteRange}, function = Ts.Expression expr} = match expr
tags t@Ts.CallExpression {ann = Loc {byteRange}, function = Parse.Success (Ts.Expression expr)} = match expr
where
match expr = case expr of
Prj Ts.Identifier {text, ann} -> yield text ann
Prj Ts.NewExpression {constructor = Prj Ts.Identifier {text, ann}} -> yield text ann
Prj Ts.CallExpression {function = Ts.Expression expr} -> match expr
Prj Ts.MemberExpression {property = Ts.PropertyIdentifier {text, ann}} -> yield text ann
Prj Ts.Function {name = Just Ts.Identifier {text, ann}} -> yield text ann
Prj Ts.NewExpression {constructor = EPrj Ts.Identifier {text, ann}} -> yield text ann
Prj Ts.CallExpression {function = Parse.Success (Ts.Expression expr)} -> match expr
Prj Ts.MemberExpression {property = Parse.Success (Ts.PropertyIdentifier {text, ann})} -> yield text ann
Prj Ts.Function {name = Just (Parse.Success (Ts.Identifier {text, ann}))} -> yield text ann
Prj Ts.ParenthesizedExpression {extraChildren} -> for_ extraChildren $ \x -> case x of
Prj (Ts.Expression expr) -> match expr
_ -> tags x
EPrj (Ts.Expression expr) -> match expr
Parse.Success x -> tags x
Parse.Fail _ -> pure ()
_ -> gtags t
yield name loc = yieldTag name P.CALL P.REFERENCE loc byteRange >> gtags t
tags _ = pure ()
instance ToTags Ts.Class where
tags t@Ts.Class {ann = Loc {byteRange}, name = Just Ts.TypeIdentifier {text, ann}} =
tags t@Ts.Class {ann = Loc {byteRange}, name = Just (Parse.Success Ts.TypeIdentifier {text, ann})} =
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 P.DEFINITION ann byteRange >> gtags t
Parse.Success (Prj Ts.Identifier {text, ann}) -> yieldTag text P.MODULE P.DEFINITION ann byteRange >> gtags t
_ -> gtags t
instance ToTags Ts.VariableDeclarator where
tags t@Ts.VariableDeclarator {ann = Loc {byteRange}, name, value = Just (Ts.Expression expr)} =
tags t@Ts.VariableDeclarator {ann = Loc {byteRange}, name, value = Just (Parse.Success (Ts.Expression expr))} =
case (expr, name) of
(Prj Ts.Function {}, Prj Ts.Identifier {text, ann}) -> yield text ann
(Prj Ts.ArrowFunction {}, Prj Ts.Identifier {text, ann}) -> yield text ann
(Prj Ts.Function {}, Parse.Success (Prj Ts.Identifier {text, ann})) -> yield text ann
(Prj Ts.ArrowFunction {}, Parse.Success (Prj Ts.Identifier {text, ann})) -> yield text ann
_ -> gtags t
where
yield text loc = yieldTag text P.FUNCTION P.DEFINITION loc byteRange >> gtags t
tags t = gtags t
instance ToTags Ts.AssignmentExpression where
tags t@Ts.AssignmentExpression {ann = Loc {byteRange}, left, right = (Ts.Expression expr)} =
tags t@Ts.AssignmentExpression {ann = Loc {byteRange}, left, right = Parse.Success (Ts.Expression expr)} =
case (left, expr) of
(Prj Ts.Identifier {text, ann}, Prj Ts.Function {}) -> yield text ann
(Prj Ts.Identifier {text, ann}, Prj Ts.ArrowFunction {}) -> yield text ann
(Prj Ts.MemberExpression {property = Ts.PropertyIdentifier {text, ann}}, Prj Ts.Function {}) -> yield text ann
(Prj Ts.MemberExpression {property = Ts.PropertyIdentifier {text, ann}}, Prj Ts.ArrowFunction {}) -> yield text ann
(Parse.Success (Prj Ts.Identifier {text, ann}), Prj Ts.Function {}) -> yield text ann
(Parse.Success (Prj Ts.Identifier {text, ann}), Prj Ts.ArrowFunction {}) -> yield text ann
(EPrj Ts.MemberExpression {property = Parse.Success (Ts.PropertyIdentifier {text, ann})}, Prj Ts.Function {}) -> yield text ann
(EPrj Ts.MemberExpression {property = Parse.Success (Ts.PropertyIdentifier {text, ann})}, Prj Ts.ArrowFunction {}) -> yield text ann
_ -> gtags t
where
yield text loc = yieldTag text P.FUNCTION P.DEFINITION loc byteRange >> gtags t
tags _ = pure ()
instance (ToTags l, ToTags r) => ToTags (l :+: r) where
tags (L1 l) = tags l

4
semantic-typescript/test/PreciseTest.hs
View File

@ -1,10 +1,10 @@
{-# LANGUAGE DisambiguateRecordFields, OverloadedStrings, TypeApplications #-}
module Main (main) where
import AST.Test
import TreeSitter.TypeScript
import AST.TestHelpers
import AST.Unmarshal
import qualified Language.TypeScript.AST as Ts
import Language.TypeScript.Grammar
import qualified System.Path as Path
import Test.Tasty