New SomeAnalysisParser GADT and a type family to support import graph analysis

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.

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