diff --git a/src/Parsing/Parser.hs b/src/Parsing/Parser.hs index 91471222f..9a0ea00d7 100644 --- a/src/Parsing/Parser.hs +++ b/src/Parsing/Parser.hs @@ -2,8 +2,11 @@ module Parsing.Parser ( Parser(..) , SomeParser(..) +, SomeAnalysisParser(..) , someParser +, someAnalysisParser , ApplyAll +, ApplyAll' -- À la carte parsers , goParser , jsonParser @@ -39,6 +42,32 @@ import TreeSitter.Python import TreeSitter.Ruby import TreeSitter.TypeScript + +type family ApplyAll' (typeclasses :: [(* -> *) -> Constraint]) (fs :: [* -> *]) :: Constraint where + ApplyAll' (typeclass ': typeclasses) fs = (Apply typeclass fs, ApplyAll' typeclasses fs) + ApplyAll' '[] fs = () + +data SomeAnalysisParser typeclasses ann where + SomeAnalysisParser :: (Member Syntax.Identifier fs, ApplyAll' typeclasses fs) => Parser (Term (Union fs) ann) -> [String] -> SomeAnalysisParser typeclasses ann + +someAnalysisParser :: ( ApplyAll' typeclasses Go.Syntax + , ApplyAll' typeclasses PHP.Syntax + , ApplyAll' typeclasses Python.Syntax + , ApplyAll' typeclasses Ruby.Syntax + , ApplyAll' typeclasses TypeScript.Syntax + ) + => proxy typeclasses -- ^ A proxy for the list of typeclasses required, e.g. @(Proxy :: Proxy '[Show1])@. + -> Language -- ^ The 'Language' to select. + -> SomeAnalysisParser typeclasses (Record Location) -- ^ A 'SomeAnalysisParser abstracting the syntax type to be produced. +someAnalysisParser _ Go = SomeAnalysisParser goParser ["go"] +someAnalysisParser _ JavaScript = SomeAnalysisParser typescriptParser ["js"] +someAnalysisParser _ PHP = SomeAnalysisParser phpParser ["php"] +someAnalysisParser _ Python = SomeAnalysisParser pythonParser ["py"] +someAnalysisParser _ Ruby = SomeAnalysisParser rubyParser ["rb"] +someAnalysisParser _ TypeScript = SomeAnalysisParser typescriptParser ["ts", "tsx", "d.tsx"] +someAnalysisParser _ l = error $ "Analysis not supported for: " <> show l + + -- | A parser from 'Source' onto some term type. data Parser term where -- | A parser producing 'AST' using a 'TS.Language'. @@ -51,11 +80,13 @@ data Parser term where -- | A parser for 'Markdown' using cmark. MarkdownParser :: Parser (Term (TermF [] CMarkGFM.NodeType) (Node Markdown.Grammar)) --- | Apply all of a list of typeclasses to all of a list of functors using 'Apply'. Used by 'someParser' to constrain all of the language-specific syntax types to the typeclasses in question. +-- | Apply all of a list of typeclasses to all of a list of functors using 'Apply'. Used by 'someAnalysisParser to constrain all of the language-specific syntax types to the typeclasses in question. type family ApplyAll (typeclasses :: [(* -> *) -> Constraint]) (syntax :: * -> *) :: Constraint where ApplyAll (typeclass ': typeclasses) syntax = (typeclass syntax, ApplyAll typeclasses syntax) ApplyAll '[] syntax = () + + -- | A parser for some specific language, producing 'Term's whose syntax satisfies a list of typeclass constraints. -- -- This enables us to abstract over the details of the specific syntax types in cases where we can describe all the requirements on the syntax with a list of typeclasses. diff --git a/src/Semantic/Parse.hs b/src/Semantic/Parse.hs index 5413c1172..913b5528d 100644 --- a/src/Semantic/Parse.hs +++ b/src/Semantic/Parse.hs @@ -5,6 +5,8 @@ import Analysis.ConstructorName (ConstructorName, constructorLabel) import Analysis.IdentifierName (IdentifierName, identifierLabel) import Analysis.Declaration (HasDeclaration, declarationAlgebra) import Analysis.PackageDef (HasPackageDef, packageDefAlgebra) +import qualified Data.Abstract.Evaluatable as Analysis +import Data.Abstract.FreeVariables import Data.Blob import Data.JSON.Fields import Data.Output @@ -15,21 +17,20 @@ import Rendering.Renderer import Semantic.IO (NoLanguageForBlob(..), Files) import Semantic.Task import System.FilePath.Posix -import Data.Language as Language +import Data.ByteString.Char8 as BC (pack) -graph :: (Members '[Distribute WrappedTask, Files, Task, Exc SomeException] effs, Output output) => TermRenderer output -> Blob -> Eff effs ByteString -graph renderer blob@Blob{..} = do - parser <- parserForLanguage blobLanguage + +graph :: (Members '[Distribute WrappedTask, Files, Task, Exc SomeException] effs) => TermRenderer output -> Blob -> Eff effs ByteString +graph _ Blob{..} + | Just (SomeAnalysisParser parser exts) <- someAnalysisParser + (Proxy :: Proxy '[ Analysis.Evaluatable, FreeVariables1, Functor, Eq1, Ord1, Show1 ]) <$> blobLanguage = do let rootDir = takeDirectory blobPath - paths <- filter (/= blobPath) <$> listFiles rootDir ["go"] - package <- parsePackage "test" parser rootDir (blobPath : paths) + paths <- filter (/= blobPath) <$> listFiles rootDir exts + package <- parsePackage (packageName blobPath) parser rootDir (blobPath : paths) graphImports package + | otherwise = throwError (SomeException (NoLanguageForBlob blobPath)) - - where - -- parserForLanguage (Just Language.Ruby) = pure rubyParser - parserForLanguage (Just Language.Go) = pure goParser - parserForLanguage _ = throwError (SomeException (NoLanguageForBlob blobPath)) + where packageName = name . BC.pack . dropExtensions . takeFileName parseBlobs :: (Members '[Distribute WrappedTask, Task, Exc SomeException] effs, Output output) => TermRenderer output -> [Blob] -> Eff effs ByteString