github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2025-01-07 16:07:28 +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-java:test
cabal v2-run --project-file=cabal.project.ci semantic-json: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
cabal v2-run --project-file=cabal.project.ci semantic-python:test:compiling # 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:graphing
cabal v2-run --project-file=cabal.project.ci semantic-ruby:test 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-tsx:test
cabal v2-run --project-file=cabal.project.ci semantic-typescript:test cabal v2-run --project-file=cabal.project.ci semantic-typescript:test

1
.hlint.yaml
View File

@ -59,6 +59,7 @@
name: Reduce duplication name: Reduce duplication
within: within:
- Semantic.Util - Semantic.Util
- Language.Ruby.Tags
# hlint has issues with QuantifiedConstraints (see https://github.com/ndmitchell/hlint/issues/759) # hlint has issues with QuantifiedConstraints (see https://github.com/ndmitchell/hlint/issues/759)
# Once the above is fixed, we can drop this error. # 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-go/src"
echo "-isemantic-java/src" echo "-isemantic-java/src"
echo "-isemantic-json/src" echo "-isemantic-json/src"
echo "-isemantic-json/test"
echo "-isemantic-parse/src" echo "-isemantic-parse/src"
echo "-isemantic-php/src" echo "-isemantic-php/src"
echo "-isemantic-proto/src"
echo "-isemantic-python/src" echo "-isemantic-python/src"
echo "-isemantic-python/test" echo "-isemantic-python/test"
echo "-isemantic-ruby/src" echo "-isemantic-ruby/src"

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

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

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

@ -2,9 +2,11 @@
module AST.Element module AST.Element
( Element(..) ( Element(..)
, pattern Prj , pattern Prj
, pattern EPrj
, (:+:)(..) , (:+:)(..)
) where ) where
import qualified AST.Parse as Parse
import GHC.Generics ((:+:)(..)) import GHC.Generics ((:+:)(..))
import GHC.TypeLits (ErrorMessage(..), TypeError) 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 instance (Element' side sub sup, side ~ Find sub sup) => Element sub sup where
prj = prj' @side prj = prj' @side
-- | A pattern synonym to conveniently project out matching elements. -- | A pattern synonym to conveniently project out matching elements.
pattern Prj :: Element sub sup => sub a -> sup a pattern Prj :: Element sub sup => sub a -> sup a
pattern Prj sub <- (prj -> Just sub) 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? -- | Where does the element occur in the tree?
data Side = None | Here | L | R 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 DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveGeneric #-}
@ -10,6 +12,7 @@ module AST.GenerateSyntax
) where ) where
import AST.Deserialize (Children (..), Datatype (..), DatatypeName (..), Field (..), Multiple (..), Named (..), Required (..), Type (..)) import AST.Deserialize (Children (..), Datatype (..), DatatypeName (..), Field (..), Multiple (..), Named (..), Required (..), Type (..))
import qualified AST.Parse as Parse
import AST.Token import AST.Token
import AST.Traversable1.Class import AST.Traversable1.Class
import qualified AST.Unmarshal as TS import qualified AST.Unmarshal as TS
@ -47,7 +50,7 @@ astDeclarationsForLanguage language filePath = do
debugSymbolNames :: [String] debugSymbolNames :: [String]
debugSymbolNames = $(listE (map (litE . stringL . debugPrefix) allSymbols)) 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 -- Build a list of all symbols
getAllSymbols :: Ptr TS.Language -> IO [(String, Named)] getAllSymbols :: Ptr TS.Language -> IO [(String, Named)]
@ -62,53 +65,54 @@ getAllSymbols language = do
let named = if t == 0 then Named else Anonymous let named = if t == 0 then Named else Anonymous
pure (n, named) pure (n, named)
annParameterName :: Name
annParameterName = mkName "a"
-- Auto-generate Haskell datatypes for sums, products and leaf types -- Auto-generate Haskell datatypes for sums, products and leaf types
syntaxDatatype :: Ptr TS.Language -> [(String, Named)] -> Datatype -> Q [Dec] syntaxDatatype :: Ptr TS.Language -> [(String, Named)] -> Datatype -> Q [Dec]
syntaxDatatype language allSymbols datatype = skipDefined $ do 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 case datatype of
SumType (DatatypeName _) _ subtypes -> do SumType (DatatypeName _) _ subtypes ->
types' <- fieldTypesToNestedSum subtypes let types' = fieldTypesToNestedSum subtypes
let fieldName = mkName ("get" <> nameStr) fieldName = mkName ("get" <> nameStr)
con <- recC name [TH.varBangType fieldName (TH.bangType strictness (pure types' `appT` varT typeParameterName))] con = recC name [varBangType fieldName (bangType strictness (types' `appT` varT annParameterName))]
hasFieldInstance <- makeHasFieldInstance (conT name) (varT typeParameterName) (varE fieldName) hasFieldInstance = makeHasFieldInstance (conT name) (varE fieldName)
traversalInstances <- makeTraversalInstances (conT name) newType = newtypeD (cxt []) name [plainTV annParameterName] Nothing con [deriveGN, deriveStockClause, deriveAnyClassClause]
pure in glue <$> newType <*> hasFieldInstance <*> traversalInstances
( NewtypeD [] name [PlainTV typeParameterName] Nothing con [deriveGN, deriveStockClause, deriveAnyClassClause] ProductType datatypeName named children fields ->
: hasFieldInstance let con = ctorForProductType datatypeName children fields
<> traversalInstances) symbols = symbolMatchingInstance allSymbols name named datatypeName
ProductType (DatatypeName datatypeName) named children fields -> do in glue <$> generatedDatatype [con] <*> symbols <*> traversalInstances
con <- ctorForProductType datatypeName typeParameterName children fields
symbolMatchingInstance <- symbolMatchingInstance allSymbols name named datatypeName
traversalInstances <- makeTraversalInstances (conT name)
pure
( generatedDatatype name [con] typeParameterName
: symbolMatchingInstance
<> traversalInstances)
-- Anonymous leaf types are defined as synonyms for the `Token` datatype -- Anonymous leaf types are defined as synonyms for the `Token` datatype
LeafType (DatatypeName datatypeName) Anonymous -> do LeafType (DatatypeName datatypeName) Anonymous -> do
tsSymbol <- runIO $ withCStringLen datatypeName (\(s, len) -> TS.ts_language_symbol_for_name language s len False) let 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))) ] fmap (pure @[]) (tySynD name [] (conT ''Token `appT` litT (strTyLit datatypeName) `appT` litT (tsSymbol >>= numTyLit . fromIntegral)))
LeafType (DatatypeName datatypeName) Named -> do LeafType datatypeName Named ->
con <- ctorForLeafType (DatatypeName datatypeName) typeParameterName let con = ctorForLeafType datatypeName annParameterName
symbolMatchingInstance <- symbolMatchingInstance allSymbols name Named datatypeName symbols = symbolMatchingInstance allSymbols name Named datatypeName
traversalInstances <- makeTraversalInstances (conT name) in glue <$> generatedDatatype [con] <*> symbols <*> traversalInstances
pure
( generatedDatatype name [con] typeParameterName
: symbolMatchingInstance
<> traversalInstances)
where where
-- Skip generating datatypes that have already been defined (overridden) in the module where the splice is running. -- Skip generating datatypes that have already been defined (overridden) in the module where the splice is running.
skipDefined m = do skipDefined m = do
isLocal <- lookupTypeName nameStr >>= maybe (pure False) isLocalName isLocal <- lookupTypeName nameStr >>= maybe (pure False) isLocalName
if isLocal then pure [] else m if isLocal then pure [] else m
name = mkName nameStr
nameStr = toNameString (datatypeNameStatus datatype) (getDatatypeName (AST.Deserialize.datatypeName datatype)) 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 :: TypeQ -> Q [Dec]
makeTraversalInstances ty = makeTraversalInstances ty =
@ -121,14 +125,14 @@ makeTraversalInstances ty =
traverse = traverseDefault1 traverse = traverseDefault1
|] |]
makeHasFieldInstance :: TypeQ -> TypeQ -> ExpQ -> Q [Dec] makeHasFieldInstance :: TypeQ -> ExpQ -> Q [Dec]
makeHasFieldInstance ty param elim = makeHasFieldInstance ty elim =
[d|instance HasField "ann" $(ty `appT` param) $param where [d|instance HasField "ann" ($ty a) a where
getField = TS.gann . $elim |] getField = TS.gann . $elim |]
-- | Create TH-generated SymbolMatching instances for sums, products, leaves -- | Create TH-generated SymbolMatching instances for sums, products, leaves
symbolMatchingInstance :: [(String, Named)] -> Name -> Named -> String -> Q [Dec] symbolMatchingInstance :: [(String, Named)] -> Name -> Named -> DatatypeName -> Q [Dec]
symbolMatchingInstance allSymbols name named str = do symbolMatchingInstance allSymbols name named (DatatypeName str) = do
let tsSymbols = elemIndices (str, named) allSymbols let tsSymbols = elemIndices (str, named) allSymbols
names = intercalate ", " $ fmap (debugPrefix . (!!) allSymbols) tsSymbols names = intercalate ", " $ fmap (debugPrefix . (!!) allSymbols) tsSymbols
[d|instance TS.SymbolMatching $(conT name) where [d|instance TS.SymbolMatching $(conT name) where
@ -146,40 +150,49 @@ debugPrefix (name, Named) = name
debugPrefix (name, Anonymous) = "_" <> name debugPrefix (name, Anonymous) = "_" <> name
-- | Build Q Constructor for product types (nodes with fields) -- | Build Q Constructor for product types (nodes with fields)
ctorForProductType :: String -> Name -> Maybe Children -> [(String, Field)] -> Q Con ctorForProductType :: DatatypeName -> Maybe Children -> [(String, Field)] -> Q Con
ctorForProductType constructorName typeParameterName children fields = ctorForTypes constructorName lists where ctorForProductType constructorName children fields = ctorForTypes constructorName lists where
lists = annotation : fieldList <> childList lists = annotation : fieldList <> childList
annotation = ("ann", varT typeParameterName) annotation = ("ann", varT annParameterName)
fieldList = map (fmap toType) fields fieldList = map (fmap (toType)) fields
childList = toList $ fmap toTypeChild children childList = toList $ fmap toTypeChild children
inject t = conT ''Parse.Err `appT` t
toType :: Field -> TypeQ
toType (MkField required fieldTypes mult) = 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 in case (required, mult) of
(Required, Multiple) -> appT (conT ''NonEmpty) ftypes (Required, Multiple) -> appT (conT ''NonEmpty) ftypes
(Required, Single) -> ftypes (Required, Single) -> ftypes
(Optional, Multiple) -> appT (conT ''[]) ftypes (Optional, Multiple) -> appT listT ftypes
(Optional, Single) -> appT (conT ''Maybe) ftypes (Optional, Single) -> appT (conT ''Maybe) ftypes
toTypeChild (MkChildren field) = ("extra_children", toType field) toTypeChild (MkChildren field) = ("extra_children", toType field)
-- | Build Q Constructor for leaf types (nodes with no fields or subtypes) -- | Build Q Constructor for leaf types (nodes with no fields or subtypes)
ctorForLeafType :: DatatypeName -> Name -> Q Con ctorForLeafType :: DatatypeName -> Name -> Q Con
ctorForLeafType (DatatypeName name) typeParameterName = ctorForTypes name ctorForLeafType name annParameterName = ctorForTypes name
[ ("ann", varT typeParameterName) -- ann :: a [ ("ann", varT annParameterName) -- ann :: a
, ("text", conT ''Text) -- text :: Text , ("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 -- | Build Q Constructor for records
ctorForTypes :: String -> [(String, Q TH.Type)] -> Q Con ctorForTypes :: DatatypeName -> [(String, Q TH.Type)] -> Q Con
ctorForTypes constructorName types = recC (toName Named constructorName) recordFields where ctorForTypes (DatatypeName constructorName) types = recC (toName Named constructorName) recordFields
recordFields = map (uncurry toVarBangType) types where
toVarBangType str type' = TH.varBangType (mkName . toHaskellCamelCaseIdentifier $ str) (TH.bangType strictness type') recordFields = map (uncurry toVarBangType) types
toVarBangType str type' = TH.varBangType (mkName . toHaskellCamelCaseIdentifier $ str) (TH.bangType strictness type')
-- | Convert field types to Q types -- | Convert field types to Q types
fieldTypesToNestedSum :: NonEmpty AST.Deserialize.Type -> Q TH.Type fieldTypesToNestedSum :: NonEmpty AST.Deserialize.Type -> Q TH.Type
fieldTypesToNestedSum xs = go (toList xs) fieldTypesToNestedSum xs = go (toList xs)
where 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) convertToQType (MkType (DatatypeName n) named) = conT (toName named n)
go [x] = convertToQType x go [x] = convertToQType x
go xs = let (l,r) = splitAt (length xs `div` 2) xs in combine (go l) (go r) 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 #-} {-# LANGUAGE OverloadedStrings #-}
module AST.Test module AST.TestHelpers
( CorpusExample(..) ( CorpusExample(..)
, readCorpusFiles , readCorpusFiles
, 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 module AST.Token
( Token(..) ( Token(..)
) where ) where
@ -14,4 +18,4 @@ import GHC.TypeLits (Symbol, Nat)
-- type AnonymousPlus = Token "+" 123 -- type AnonymousPlus = Token "+" 123
-- @ -- @
newtype Token (symName :: Symbol) (symVal :: Nat) a = Token { ann :: a } 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(..) , GHasAnn(..)
) where ) where
import AST.Token as TS
import AST.Parse
import Control.Algebra (send) import Control.Algebra (send)
import Control.Carrier.Reader hiding (asks) import Control.Carrier.Reader hiding (asks)
import Control.Exception import Control.Exception
@ -35,6 +37,7 @@ import Data.ByteString (ByteString)
import qualified Data.ByteString as B import qualified Data.ByteString as B
import Data.Coerce import Data.Coerce
import Data.Foldable (toList) import Data.Foldable (toList)
import Data.Functor.Identity
import qualified Data.IntMap as IntMap import qualified Data.IntMap as IntMap
import Data.List.NonEmpty (NonEmpty (..)) import Data.List.NonEmpty (NonEmpty (..))
import Data.Proxy import Data.Proxy
@ -55,7 +58,6 @@ import TreeSitter.Cursor as TS
import TreeSitter.Language as TS import TreeSitter.Language as TS
import TreeSitter.Node as TS import TreeSitter.Node as TS
import TreeSitter.Parser as TS import TreeSitter.Parser as TS
import AST.Token as TS
import TreeSitter.Tree as TS import TreeSitter.Tree as TS
asks :: Has (Reader r) sig m => (r -> r') -> m r' 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 instance (Unmarshal f, Unmarshal g) => Unmarshal (f :+: g) where
matchers = fmap (fmap (hoist L1)) matchers <> fmap (fmap (hoist R1)) matchers 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 instance Unmarshal t => Unmarshal (Rec1 t) where
matchers = coerce (matchers @t) matchers = coerce (matchers @t)
@ -206,18 +213,27 @@ pointToPos (TSPoint line column) = Pos (fromIntegral line) (fromIntegral column)
class UnmarshalField t where class UnmarshalField t where
unmarshalField unmarshalField
:: ( Unmarshal f :: ( Unmarshal f
, UnmarshalAnn a , UnmarshalAnn ann
) )
=> String -- ^ datatype name => String -- ^ datatype name
-> String -- ^ field name -> String -- ^ field name
-> [Node] -- ^ nodes -> [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 instance UnmarshalField Maybe where
unmarshalField _ _ [] = pure Nothing unmarshalField _ _ [] = pure Nothing
unmarshalField _ _ [x] = Just <$> unmarshalNode x unmarshalField _ _ [x] = Just <$> unmarshalNode x
unmarshalField d f _ = liftIO . throwIO . UnmarshalError $ "type '" <> d <> "' expected zero or one nodes in field '" <> f <> "' but got multiple" 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 instance UnmarshalField [] where
unmarshalField d f (x:xs) = do unmarshalField d f (x:xs) = do
head' <- unmarshalNode x head' <- unmarshalNode x
@ -232,11 +248,11 @@ instance UnmarshalField NonEmpty where
pure $ head' :| tail' pure $ head' :| tail'
unmarshalField d f [] = liftIO . throwIO . UnmarshalError $ "type '" <> d <> "' expected one or more nodes in field '" <> f <> "' but got zero" unmarshalField d f [] = liftIO . throwIO . UnmarshalError $ "type '" <> d <> "' expected one or more nodes in field '" <> f <> "' but got zero"
class SymbolMatching (a :: * -> *) where class SymbolMatching (sym :: * -> *) where
matchedSymbols :: Proxy a -> [Int] matchedSymbols :: Proxy sym -> [Int]
-- | Provide error message describing the node symbol vs. the symbols this can match -- | 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 instance SymbolMatching f => SymbolMatching (M1 i c f) where
matchedSymbols _ = matchedSymbols (Proxy @f) matchedSymbols _ = matchedSymbols (Proxy @f)
@ -254,6 +270,10 @@ instance (SymbolMatching f, SymbolMatching g) => SymbolMatching (f :+: g) where
matchedSymbols _ = matchedSymbols (Proxy @f) <> matchedSymbols (Proxy @g) matchedSymbols _ = matchedSymbols (Proxy @f) <> matchedSymbols (Proxy @g)
showFailure _ = sep <$> showFailure (Proxy @f) <*> showFailure (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 :: String -> String -> String
sep a b = a ++ ". " ++ b 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. -- Sum types are constructed by using the current node’s symbol to select the corresponding constructor deterministically.
class GUnmarshal f where class GUnmarshal f where
gunmarshalNode gunmarshalNode
:: UnmarshalAnn a :: UnmarshalAnn ann
=> Node => Node
-> MatchM (f a) -> MatchM (f ann)
instance (Datatype d, GUnmarshalData f) => GUnmarshal (M1 D d f) where instance (Datatype d, GUnmarshalData f) => GUnmarshal (M1 D d f) where
gunmarshalNode = go (gunmarshalNode' (datatypeName @d undefined)) 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 go = coerce
instance (GUnmarshal f, Applicative shape) => GUnmarshal (shape :.: f) where
gunmarshalNode = fmap (Comp1 . pure) . gunmarshalNode @f
class GUnmarshalData f where class GUnmarshalData f where
gunmarshalNode' gunmarshalNode'
:: UnmarshalAnn a :: UnmarshalAnn ann
=> String => String
-> Node -> Node
-> MatchM (f a) -> MatchM (f ann)
instance GUnmarshalData f => GUnmarshalData (M1 i c f) where instance GUnmarshalData f => GUnmarshalData (M1 i c f) where
gunmarshalNode' = go gunmarshalNode' where gunmarshalNode' = go gunmarshalNode' where
@ -350,11 +373,11 @@ instance (GUnmarshalProduct f, GUnmarshalProduct g) => GUnmarshalData (f :*: g)
-- | Generically unmarshal products -- | Generically unmarshal products
class GUnmarshalProduct f where class GUnmarshalProduct f where
gunmarshalProductNode gunmarshalProductNode
:: UnmarshalAnn a :: UnmarshalAnn ann
=> String => String
-> Node -> Node
-> Fields -> Fields
-> MatchM (f a) -> MatchM (f ann)
-- Product structure -- Product structure
instance (GUnmarshalProduct f, GUnmarshalProduct g) => GUnmarshalProduct (f :*: g) where 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 fieldName = selName @c undefined
class GHasAnn a t where class GHasAnn ann t where
gann :: t a -> a 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 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 (L1 l) = gann l
gann (R1 r) = gann r gann (R1 r) = gann r
instance {-# OVERLAPPABLE #-} HasField "ann" (t a) a => GHasAnn a t where instance {-# OVERLAPPABLE #-} HasField "ann" (t ann) ann => GHasAnn ann t where
gann = getField @"ann" gann = getField @"ann"

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

@ -6,9 +6,13 @@
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Language.CodeQL.AST module Language.CodeQL.AST
( 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 where
import AST.Element import AST.Element
import qualified AST.Parse as Parse
import AST.Token import AST.Token
import AST.Traversable1 import AST.Traversable1
import Control.Effect.Reader import Control.Effect.Reader
@ -64,57 +65,64 @@ instance ToTags CodeQL.Module where
tags tags
t@CodeQL.Module t@CodeQL.Module
{ ann = Loc {byteRange}, { 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 } = yieldTag text P.MODULE P.DEFINITION ann byteRange >> gtags t
tags _ = pure ()
instance ToTags CodeQL.ClasslessPredicate where instance ToTags CodeQL.ClasslessPredicate where
tags tags
t@CodeQL.ClasslessPredicate t@CodeQL.ClasslessPredicate
{ ann = Loc {byteRange}, { 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 } = yieldTag text P.FUNCTION P.DEFINITION ann byteRange >> gtags t
tags _ = pure ()
instance ToTags CodeQL.AritylessPredicateExpr where instance ToTags CodeQL.AritylessPredicateExpr where
tags tags
t@CodeQL.AritylessPredicateExpr t@CodeQL.AritylessPredicateExpr
{ ann = Loc {byteRange}, { 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 } = yieldTag text P.CALL P.REFERENCE ann byteRange >> gtags t
tags _ = pure ()
instance ToTags CodeQL.Dataclass where instance ToTags CodeQL.Dataclass where
tags tags
t@CodeQL.Dataclass t@CodeQL.Dataclass
{ ann = Loc {byteRange}, { 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 } = yieldTag text P.CLASS P.DEFINITION ann byteRange >> gtags t
tags _ = pure ()
instance ToTags CodeQL.MemberPredicate where instance ToTags CodeQL.MemberPredicate where
tags tags
t@CodeQL.MemberPredicate t@CodeQL.MemberPredicate
{ ann = Loc {byteRange}, { 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 } = yieldTag text P.METHOD P.DEFINITION ann byteRange >> gtags t
tags _ = pure ()
instance ToTags CodeQL.Datatype where instance ToTags CodeQL.Datatype where
tags tags
t@CodeQL.Datatype t@CodeQL.Datatype
{ ann = Loc {byteRange}, { 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 } = yieldTag text P.CLASS P.DEFINITION ann byteRange >> gtags t
tags _ = pure ()
instance ToTags CodeQL.DatatypeBranch where instance ToTags CodeQL.DatatypeBranch where
tags tags
t@CodeQL.DatatypeBranch t@CodeQL.DatatypeBranch
{ ann = Loc {byteRange}, { 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 } = yieldTag text P.CLASS P.DEFINITION ann byteRange >> gtags t
tags _ = pure ()
instance ToTags CodeQL.ClasslessPredicateCall where instance ToTags CodeQL.ClasslessPredicateCall where
tags tags
CodeQL.ClasslessPredicateCall CodeQL.ClasslessPredicateCall
{ extraChildren { extraChildren
} = for_ extraChildren $ \x -> case x of } = for_ extraChildren $ \x -> case x of
Prj t@CodeQL.AritylessPredicateExpr {} -> tags t EPrj t@CodeQL.AritylessPredicateExpr {} -> tags t
_ -> pure () _ -> pure ()
instance ToTags CodeQL.QualifiedRhs where instance ToTags CodeQL.QualifiedRhs where
@ -123,7 +131,7 @@ instance ToTags CodeQL.QualifiedRhs where
{ ann = Loc {byteRange}, { ann = Loc {byteRange},
name = expr name = expr
} = case expr of } = 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 _ -> gtags t
instance ToTags CodeQL.TypeExpr where instance ToTags CodeQL.TypeExpr where
@ -132,7 +140,7 @@ instance ToTags CodeQL.TypeExpr where
{ ann = Loc {byteRange}, { ann = Loc {byteRange},
name = expr name = expr
} = case expr of } = 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 _ -> gtags t
instance ToTags CodeQL.AddExpr instance ToTags CodeQL.AddExpr

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

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

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

@ -6,9 +6,13 @@
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Language.Go.AST module Language.Go.AST
( 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 where
import AST.Element import AST.Element
import qualified AST.Parse as Parse
import AST.Token import AST.Token
import AST.Traversable1 import AST.Traversable1
import Control.Effect.Reader import Control.Effect.Reader
@ -42,30 +43,33 @@ instance ToTags Go.FunctionDeclaration where
tags tags
t@Go.FunctionDeclaration t@Go.FunctionDeclaration
{ ann = Loc {byteRange}, { 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 } = yieldTag text P.FUNCTION P.DEFINITION ann byteRange >> gtags t
tags _ = pure ()
instance ToTags Go.MethodDeclaration where instance ToTags Go.MethodDeclaration where
tags tags
t@Go.MethodDeclaration t@Go.MethodDeclaration
{ ann = Loc {byteRange}, { 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 } = yieldTag text P.METHOD P.DEFINITION ann byteRange >> gtags t
tags _ = pure ()
instance ToTags Go.CallExpression where instance ToTags Go.CallExpression where
tags tags
t@Go.CallExpression t@Go.CallExpression
{ ann = Loc {byteRange}, { ann = Loc {byteRange},
function = Go.Expression expr function = Parse.Success (Go.Expression expr)
} = match expr } = match expr
where where
match expr = case expr of 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.Identifier {text, ann} -> yield text ann
Prj Go.CallExpression {function = Go.Expression e} -> match e Prj Go.CallExpression {function = Parse.Success (Go.Expression e)} -> match e
Prj Go.ParenthesizedExpression {extraChildren = Go.Expression e} -> match e Prj Go.ParenthesizedExpression {extraChildren = Parse.Success (Go.Expression e)} -> match e
_ -> gtags t _ -> gtags t
yield name loc = yieldTag name P.CALL P.REFERENCE loc byteRange >> 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 instance (ToTags l, ToTags r) => ToTags (l :+: r) where
tags (L1 l) = tags l tags (L1 l) = tags l

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

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

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

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

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

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

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

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

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

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

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

@ -6,17 +6,23 @@
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Language.JSON.AST module Language.JSON.AST
( module Language.JSON.AST ( module Language.JSON.AST
, JSON.getTestCorpusDir , JSON.getTestCorpusDir
) where ) where
import Prelude hiding (String)
import AST.GenerateSyntax import AST.GenerateSyntax
import Language.Haskell.TH.Syntax (runIO) import Language.Haskell.TH.Syntax (runIO)
import Prelude hiding (String)
import qualified TreeSitter.JSON as JSON (getNodeTypesPath, getTestCorpusDir, tree_sitter_json) 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" 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 module Main (main) where
import AST.Test import AST.TestHelpers
import AST.Unmarshal import AST.Unmarshal
import qualified Language.JSON.AST as JSON import qualified Language.JSON.AST as JSON
import Language.JSON.Grammar import Language.JSON.Grammar
@ -14,7 +16,7 @@ main
>>= readCorpusFiles' >>= readCorpusFiles'
>>= traverse (testCorpus parse) >>= traverse (testCorpus parse)
>>= defaultMain . tests >>= defaultMain . tests
where parse = parseByteString @JSON.Document @() tree_sitter_json where parse = parseByteString @(JSON.Document) @() tree_sitter_json
tests :: [TestTree] -> TestTree tests :: [TestTree] -> TestTree
tests = testGroup "tree-sitter-json corpus tests" tests = testGroup "tree-sitter-json corpus tests"

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

@ -6,9 +6,13 @@
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Language.PHP.AST module Language.PHP.AST
( 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 where
import AST.Element import AST.Element
import qualified AST.Parse as Parse
import AST.Token import AST.Token
import AST.Traversable1 import AST.Traversable1
import Control.Effect.Reader import Control.Effect.Reader
@ -64,15 +65,17 @@ instance ToTags PHP.FunctionDefinition where
tags tags
t@PHP.FunctionDefinition t@PHP.FunctionDefinition
{ PHP.ann = Loc {byteRange}, { 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 } = yieldTag text P.METHOD P.DEFINITION ann byteRange >> gtags t
tags _ = pure ()
instance ToTags PHP.MethodDeclaration where instance ToTags PHP.MethodDeclaration where
tags tags
t@PHP.MethodDeclaration t@PHP.MethodDeclaration
{ PHP.ann = Loc {byteRange}, { 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 } = yieldTag text P.FUNCTION P.DEFINITION ann byteRange >> gtags t
tags _ = pure ()
instance ToTags PHP.FunctionCallExpression where instance ToTags PHP.FunctionCallExpression where
tags tags
@ -83,8 +86,8 @@ instance ToTags PHP.FunctionCallExpression where
where where
yield name loc = yieldTag name P.CALL P.REFERENCE loc byteRange >> gtags t yield name loc = yieldTag name P.CALL P.REFERENCE loc byteRange >> gtags t
match expr = case expr of match expr = case expr of
Prj PHP.VariableName {extraChildren = PHP.Name {text, ann}} -> yield text ann *> gtags t EPrj PHP.VariableName {extraChildren = Parse.Success (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.QualifiedName {extraChildren = [EPrj PHP.Name {text, ann}]} -> yield text ann *> gtags t
_ -> gtags t _ -> gtags t
@ -92,7 +95,7 @@ instance ToTags PHP.MemberCallExpression where
tags tags
t@PHP.MemberCallExpression t@PHP.MemberCallExpression
{ PHP.ann = Loc {byteRange}, { 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 } = yieldTag text P.CALL P.REFERENCE ann byteRange >> gtags t
tags t = gtags t tags t = gtags t

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

@ -26,11 +26,11 @@ common haskell
, parsers ^>= 0.12.10 , parsers ^>= 0.12.10
, semantic-analysis ^>= 0 , semantic-analysis ^>= 0
, semantic-ast , semantic-ast
, semantic-core ^>= 0.0 -- , semantic-core ^>= 0.0
, semantic-proto ^>= 0 , semantic-proto ^>= 0
, semantic-source ^>= 0.1.0 , semantic-source ^>= 0.1.0
, semantic-tags ^>= 0.0 , semantic-tags ^>= 0.0
, semantic-scope-graph ^>= 0.0 -- , semantic-scope-graph ^>= 0.0
, semilattices ^>= 0 , semilattices ^>= 0
, template-haskell ^>= 2.15 , template-haskell ^>= 2.15
, text ^>= 1.2.3 , text ^>= 1.2.3
@ -58,59 +58,60 @@ library
exposed-modules: exposed-modules:
Language.Python Language.Python
Language.Python.AST Language.Python.AST
Language.Python.Core -- Language.Python.Core
Language.Python.Grammar Language.Python.Grammar
Language.Python.Failure Language.Python.Failure
Language.Python.Patterns Language.Python.Patterns
Language.Python.ScopeGraph -- Language.Python.ScopeGraph
Language.Python.Tags Language.Python.Tags
hs-source-dirs: src hs-source-dirs: src
build-depends: lens ^>= 4.18 build-depends: lens ^>= 4.18
test-suite compiling -- test-suite compiling
import: haskell -- import: haskell
type: exitcode-stdio-1.0 -- type: exitcode-stdio-1.0
hs-source-dirs: test -- hs-source-dirs: test
main-is: CoreTest.hs -- main-is: CoreTest.hs
ghc-options: -threaded -- ghc-options: -threaded
build-depends: semantic-python -- build-depends: semantic-python
, aeson ^>= 1.4.4 -- , aeson ^>= 1.4.4
, aeson-pretty ^>= 0.8.7 -- , aeson-pretty ^>= 0.8.7
, bytestring ^>= 0.10.8.2 -- , bytestring ^>= 0.10.8.2
, containers ^>= 0.6 -- , containers ^>= 0.6
, directory ^>= 1.3.3 -- , directory ^>= 1.3.3
, exceptions ^>= 0.10.2 -- , exceptions ^>= 0.10.2
, pathtype ^>= 0.8.1 -- , pathtype ^>= 0.8.1
, pretty-show ^>= 1.9.5 -- , pretty-show ^>= 1.9.5
, process ^>= 1.6.5 -- , process ^>= 1.6.5
, resourcet ^>= 1.2.2 -- , resourcet ^>= 1.2.2
, semantic-analysis ^>= 0 -- , semantic-analysis ^>= 0
, streaming ^>= 0.2.2 -- , streaming ^>= 0.2.2
, streaming-process ^>= 0.1 -- , streaming-process ^>= 0.1
, streaming-bytestring ^>= 0.1.6 -- , streaming-bytestring ^>= 0.1.6
, tasty ^>= 1.2.3 -- , tasty ^>= 1.2.3
, tasty-hunit ^>= 0.10.0.2 -- , tasty-hunit ^>= 0.10.0.2
, trifecta >= 2 && <3 -- , trifecta >= 2 && <3
, unordered-containers ^>= 0.2.10 -- , unordered-containers ^>= 0.2.10
other-modules: Directive -- other-modules:
, Instances -- Instances
-- , Directive
test-suite graphing -- test-suite graphing
import: haskell -- import: haskell
type: exitcode-stdio-1.0 -- type: exitcode-stdio-1.0
hs-source-dirs: test-graphing -- hs-source-dirs: test-graphing
main-is: GraphTest.hs -- main-is: GraphTest.hs
ghc-options: -threaded -- ghc-options: -threaded
build-depends: base -- build-depends: base
, semantic-python -- , semantic-python
, semantic-scope-graph -- -- , semantic-scope-graph
, bytestring -- , bytestring
, pathtype -- , pathtype
, tasty -- , tasty
, tasty-hunit -- , tasty-hunit
test-suite test 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 Data.Proxy
import qualified Language.Python.AST as Py import qualified Language.Python.AST as Py
import qualified Language.Python.Grammar (tree_sitter_python) import qualified Language.Python.Grammar (tree_sitter_python)
import Language.Python.ScopeGraph -- import Language.Python.ScopeGraph
import qualified Language.Python.Tags as PyTags import qualified Language.Python.Tags as PyTags
import Scope.Graph.Convert -- import Scope.Graph.Convert
import qualified Tags.Tagging.Precise as Tags import qualified Tags.Tagging.Precise as Tags
newtype Term a = Term { getTerm :: Py.Module a } newtype Term a = Term { getTerm :: Py.Module a }
@ -25,5 +25,5 @@ instance TS.Unmarshal Term where
instance Tags.ToTags Term where instance Tags.ToTags Term where
tags src = Tags.runTagging src . PyTags.tags . getTerm tags src = Tags.runTagging src . PyTags.tags . getTerm
instance ToScopeGraph Term where -- instance ToScopeGraph Term where
scopeGraph = scopeGraphModule . getTerm -- scopeGraph = scopeGraphModule . getTerm

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

@ -6,9 +6,14 @@
{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuantifiedConstraints #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
module Language.Python.AST module Language.Python.AST
( 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 TypeOperators #-}
{-# LANGUAGE ViewPatterns #-} {-# 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 module Language.Python.Core
( toplevelCompile ( toplevelCompile
, Bindings , Bindings

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

@ -9,6 +9,7 @@ module Language.Python.Patterns
) where ) where
import AST.Element import AST.Element
import qualified AST.Parse as Parse
import qualified Analysis.Name import qualified Analysis.Name
import qualified Language.Python.AST as Py 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 :: Analysis.Name.Name -> Py.ExpressionList a
pattern SingleIdentifier n <- Py.ExpressionList pattern SingleIdentifier n <- Py.ExpressionList
{ Py.extraChildren = { 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 TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-} {-# 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 module Language.Python.ScopeGraph
( scopeGraphModule ( scopeGraphModule
) where ) where
import qualified Analysis.Name as Name import qualified Analysis.Name as Name
import AST.Element import AST.Element
import qualified AST.Parse as Parse
import Control.Effect.ScopeGraph import Control.Effect.ScopeGraph
import qualified Control.Effect.ScopeGraph.Properties.Declaration as Props import qualified Control.Effect.ScopeGraph.Properties.Declaration as Props
import qualified Control.Effect.ScopeGraph.Properties.Function 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.AssertStatement where scopeGraph = onChildren
instance ToScopeGraph Py.Assignment where 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 declare t Props.Declaration
{ Props.kind = ScopeGraph.Assignment { Props.kind = ScopeGraph.Assignment
, Props.relation = ScopeGraph.Default , Props.relation = ScopeGraph.Default
@ -121,12 +126,12 @@ instance ToScopeGraph Py.BreakStatement where scopeGraph = mempty
instance ToScopeGraph Py.Call where instance ToScopeGraph Py.Call where
scopeGraph Py.Call scopeGraph Py.Call
{ function { function = Parse.Success f
, arguments = L1 Py.ArgumentList { extraChildren = args } , arguments = Parse.Success (L1 Py.ArgumentList { extraChildren = args })
} = do } = do
result <- scopeGraph function result <- scopeGraph f
let scopeGraphArg = \case let scopeGraphArg = \case
Prj expr -> scopeGraph @Py.Expression expr EPrj expr -> scopeGraph @Py.Expression expr
other -> todo other other -> todo other
args <- traverse scopeGraphArg args args <- traverse scopeGraphArg args
pure (result <> mconcat 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.ElseClause where scopeGraph = onField @"body"
instance ToScopeGraph Py.ElifClause where 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 instance ToScopeGraph Py.Ellipsis where scopeGraph = mempty
@ -183,9 +188,9 @@ instance ToScopeGraph Py.ForStatement where scopeGraph = todo
instance ToScopeGraph Py.FunctionDefinition where instance ToScopeGraph Py.FunctionDefinition where
scopeGraph Py.FunctionDefinition scopeGraph Py.FunctionDefinition
{ ann { ann
, name = Py.Identifier _ann1 name , name = Parse.Success (Py.Identifier _ann1 name)
, parameters = Py.Parameters _ann2 parameters , parameters = Parse.Success (Py.Parameters _ann2 parameters)
, body , body = Parse.Success b
} = do } = do
(_, associatedScope) <- declareFunction (Just $ Name.name name) Props.Function (_, associatedScope) <- declareFunction (Just $ Name.name name) Props.Function
{ Props.kind = ScopeGraph.Function { Props.kind = ScopeGraph.Function
@ -207,7 +212,7 @@ instance ToScopeGraph Py.FunctionDefinition where
let parameters' = catMaybes parameterMs let parameters' = catMaybes parameterMs
paramDeclarations <- for parameters' $ \(pos, parameter) -> paramDeclarations <- for parameters' $ \(pos, parameter) ->
complete <* declare parameter (set span_ (pos^.span_) declProps) complete <* declare parameter (set span_ (pos^.span_) declProps)
bodyResult <- scopeGraph body bodyResult <- scopeGraph b
pure (mconcat paramDeclarations <> bodyResult) pure (mconcat paramDeclarations <> bodyResult)
instance ToScopeGraph Py.FutureImportStatement where scopeGraph = todo instance ToScopeGraph Py.FutureImportStatement where scopeGraph = todo
@ -221,7 +226,7 @@ instance ToScopeGraph Py.Identifier where
complete complete
instance ToScopeGraph Py.IfStatement where instance ToScopeGraph Py.IfStatement where
scopeGraph (Py.IfStatement _ alternative body condition) scopeGraph (Py.IfStatement _ alternative (Parse.Success body) (Parse.Success condition))
= scopeGraph condition = scopeGraph condition
<> scopeGraph body <> scopeGraph body
<> foldMap scopeGraph alternative <> foldMap scopeGraph alternative

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

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

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

@ -13,11 +13,11 @@ import Control.Carrier.Fail.Either
import Control.Carrier.Reader import Control.Carrier.Reader
import Control.Monad hiding (fail) import Control.Monad hiding (fail)
import Control.Monad.IO.Class import Control.Monad.IO.Class
import Core.Core -- import Core.Core
import qualified Core.Eval as Eval -- import qualified Core.Eval as Eval
import Core.Name -- import Core.Name
import qualified Core.Parser -- import qualified Core.Parser
import Core.Pretty -- import Core.Pretty
import qualified Data.ByteString.Char8 as ByteString import qualified Data.ByteString.Char8 as ByteString
import Data.Foldable import Data.Foldable
import Data.Function import Data.Function
@ -27,7 +27,7 @@ import qualified Data.Map as Map
import Data.Maybe import Data.Maybe
import Data.Text (Text) import Data.Text (Text)
import GHC.Stack import GHC.Stack
import qualified Language.Python.Core as Py -- import qualified Language.Python.Core as Py
import Language.Python.Failure import Language.Python.Failure
import Prelude hiding (fail) import Prelude hiding (fail)
import Source.Span import Source.Span
@ -45,7 +45,7 @@ import qualified AST.Unmarshal as TS
import qualified Test.Tasty as Tasty import qualified Test.Tasty as Tasty
import qualified Test.Tasty.HUnit as HUnit import qualified Test.Tasty.HUnit as HUnit
import qualified Directive -- import qualified Directive
import Instances () import Instances ()
parsePrelude :: IO (Term (Ann Span :+: Core) Name) 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.Algebra
import Control.Monad import Control.Monad
import Control.Monad.Trans.Resource (ResourceT, runResourceT) import Control.Monad.Trans.Resource (ResourceT, runResourceT)
import Core.Core (Core) -- import Core.Core (Core)
import qualified Core.Core as Core -- import qualified Core.Core as Core
import Core.Name (Name) -- import Core.Name (Name)
import qualified Core.Parser -- import qualified Core.Parser
import qualified Core.Pretty -- import qualified Core.Pretty
import Data.ByteString.Char8 (ByteString) import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as ByteString import qualified Data.ByteString.Char8 as ByteString
import qualified Data.ByteString.Streaming.Char8 as ByteStream 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 qualified System.Path as Path
import Test.Tasty import Test.Tasty
import TreeSitter.Python
import qualified Language.Python.AST as Py import qualified Language.Python.AST as Py
import Language.Python.Grammar import AST.TestHelpers
import AST.Test
import AST.Unmarshal import AST.Unmarshal
main :: IO () main :: IO ()

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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