Merge branch 'master' into reprinting-pipeline-rename

semantic.cabal

@@ -393,6 +393,27 @@ test-suite lint
   build-depends:       base
                      , hlint
 
+test-suite parse-examples
+  type:                exitcode-stdio-1.0
+  hs-source-dirs:      test
+  main-is:             Examples.hs
+  default-language:    Haskell2010
+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -j
+  build-depends:       base
+                     , bytestring
+                     , directory
+                     , effects
+                     , fastsum
+                     , filepath
+                     , Glob
+                     , hspec >= 2.4.1
+                     , hspec-core
+                     , hspec-expectations-pretty-diff
+                     , process
+                     , semantic
+  default-extensions:  RecordWildCards
+                     , FlexibleContexts
+
 test-suite doctests
   type:                exitcode-stdio-1.0
   hs-source-dirs:      test

src/Language/Go/Assignment.hs

@@ -535,7 +535,7 @@ varDeclaration :: Assignment Term
 varDeclaration = (symbol ConstDeclaration <|> symbol VarDeclaration) *> children expressions
 
 variadicArgument :: Assignment Term
-variadicArgument = makeTerm <$> symbol VariadicArgument <*> children (Go.Syntax.Variadic [] <$> expression)
+variadicArgument = makeTerm <$> symbol VariadicArgument <*> children (Go.Syntax.Variadic [] <$> expressions)
 
 variadicParameterDeclaration :: Assignment Term
 variadicParameterDeclaration =  makeTerm <$> symbol VariadicParameterDeclaration <*> children (flip Go.Syntax.Variadic <$> (expression <|> emptyTerm) <* token AnonDotDotDot <*> many expression)

src/Language/Python/Assignment.hs

@@ -465,9 +465,13 @@ raiseStatement :: Assignment Term
 raiseStatement = makeTerm <$> symbol RaiseStatement <*> children (Statement.Throw <$> expressions)
 
 ifStatement :: Assignment Term
-ifStatement = makeTerm <$> symbol IfStatement <*> children (Statement.If <$> term expression <*> term (makeTerm <$> location <*> manyTermsTill expression (void (symbol ElseClause) <|> void (symbol ElifClause) <|> eof)) <*> (flip (foldr makeElif) <$> many elifClause <*> (symbol ElseClause *> children expressions <|> emptyTerm)))
+ifStatement = makeTerm <$> symbol IfStatement <*> children if'
-  where elifClause = (,) <$> symbol ElifClause <*> children (Statement.If <$> term expression <*> expressions)
+  where
-        makeElif (loc, makeIf) rest = makeTerm loc (makeIf rest)
+    if' = Statement.If <$> term expression <*> thenClause <*> (elseClause <|> emptyTerm)
+    thenClause = makeTerm <$> location <*> manyTermsTill expression (void (symbol ElseClause) <|> void (symbol ElifClause) <|> eof)
+    elseClause = makeTerm <$> location <*> many (comment <|> elif <|> else')
+    elif = makeTerm <$> symbol ElifClause <*> children if'
+    else' = symbol ElseClause *> children expressions
 
 execStatement :: Assignment Term
 execStatement = makeTerm <$> symbol ExecStatement <*> children (Expression.Call [] <$> term (makeTerm <$> location <*> (Syntax.Identifier . name <$> source)) <*> manyTerm (string <|> expression) <*> emptyTerm)

src/Semantic/Parse.hs

@@ -1,5 +1,5 @@
 {-# LANGUAGE GADTs, RankNTypes #-}
-module Semantic.Parse ( runParse ) where
+module Semantic.Parse ( runParse, runParse' ) where
 
 import           Analysis.ConstructorName (ConstructorName)
 import           Analysis.Declaration (HasDeclaration, declarationAlgebra)
@@ -32,6 +32,10 @@ runParse ShowTermRenderer             = withParsedBlobs (\_ _ -> mempty) (const
 runParse (SymbolsTermRenderer fields) = withParsedBlobs (\_ _ -> mempty) (\ blob -> decorate (declarationAlgebra blob) >=> render (renderSymbolTerms . renderToSymbols fields blob)) >=> serialize JSON
 runParse DOTTermRenderer              = withParsedBlobs (\_ _ -> mempty) (const (render renderTreeGraph)) >=> serialize (DOT (termStyle "terms"))
 
+
+runParse' :: (Member (Exc SomeException) effs, Member Task effs) => Blob -> Eff effs Builder
+runParse' blob = parseSomeBlob blob >>= withSomeTerm (serialize Show . quieterm)
+
 withParsedBlobs ::
   ( Member Distribute effs
   , Member (Exc SomeException) effs

src/Semantic/Task.hs

@@ -41,13 +41,15 @@ module Semantic.Task
 , runTaskWithConfig
 , runTraceInTelemetry
 , runTaskF
+-- * Exceptions
+, ParserCancelled(..)
 -- * Re-exports
 , Distribute
 , Eff
 , Exc
 , Lift
 , throwError
-, SomeException
+, SomeException(..)
 , Telemetry
 ) where
 

test/Examples.hs

@@ -0,0 +1,105 @@
+module Main (main) where
+
+import           Control.Exception (displayException)
+import           Control.Monad
+import           Control.Monad.Effect
+import           Control.Monad.Effect.Exception
+import qualified Data.ByteString as B
+import           Data.ByteString.Builder
+import qualified Data.ByteString.Char8 as BC
+import           Data.Either
+import           Data.Foldable
+import           Data.List
+import           Data.Maybe
+import           Data.Project (file)
+import           Data.Quieterm
+import           Data.Typeable (cast)
+import           Data.Void
+import           Parsing.Parser
+import           Rendering.Renderer
+import           Semantic.Config (Config (..), Options (..), defaultOptions)
+import qualified Semantic.IO as IO
+import           Semantic.Parse
+import           Semantic.Task
+import           Semantic.Util (TaskConfig (..))
+import           System.Directory
+import           System.Exit (die)
+import           System.FilePath.Glob
+import           System.FilePath.Posix
+import           System.Process
+import           Test.Hspec
+
+
+main :: IO ()
+main = withOptions opts $ \ config logger statter -> hspec . parallel $ do
+  let args = TaskConfig config logger statter
+
+  runIO setupExampleRepos
+
+  for_ languages $ \ lang@LanguageExample{..} -> do
+    let tsDir = languagesDir </> languageName </> ("vendor/tree-sitter-" <> languageName)
+    parallel . describe languageName $ parseExamples args lang tsDir
+
+  where
+    parseExamples (TaskConfig config logger statter) LanguageExample{..} tsDir = do
+      knownFailures <- runIO $ knownFailuresForPath tsDir languageKnownFailuresTxt
+      files <- runIO $ globDir1 (compile ("**/*" <> languageExtension)) (tsDir </> languageExampleDir)
+      for_ files $ \file -> it file $ do
+        res <- runTaskWithConfig config logger statter (parseFilePath file)
+        case res of
+          Left (SomeException e) -> case cast e of
+            -- We have a number of known assignment timeouts, consider these pending specs instead of failing the build.
+            Just (AssignmentTimedOut _ _) -> pendingWith $ show (displayException e)
+            -- Other exceptions are true failures
+            _ -> expectationFailure (show (displayException e))
+          _ -> if file `elem` knownFailures
+                  then pendingWith $ "Known parse failures " <> show (const "Assignment: OK" <$> res)
+                  else res `shouldSatisfy` isRight
+
+    setupExampleRepos = readProcess "script/clone-example-repos" mempty mempty >>= print
+    opts = defaultOptions { optionsFailOnWarning = True, optionsLogLevel = Nothing }
+
+    knownFailuresForPath :: FilePath -> Maybe FilePath -> IO [FilePath]
+    knownFailuresForPath _     Nothing     = pure []
+    knownFailuresForPath tsDir (Just path) = do
+      known <- BC.lines <$> B.readFile (tsDir </> path)
+      pure $ (tsDir </>) . BC.unpack <$> stripComments known
+      where stripComments = filter (\line -> not (BC.null line) && BC.head line == '#')
+
+data LanguageExample
+  = LanguageExample
+  { languageName :: FilePath
+  , languageExtension :: FilePath
+  , languageExampleDir :: FilePath
+  , languageKnownFailuresTxt :: Maybe FilePath
+  } deriving (Eq, Show)
+
+le :: FilePath -> FilePath -> FilePath -> Maybe FilePath -> LanguageExample
+le = LanguageExample
+
+languages :: [LanguageExample]
+languages =
+  [ le "python" ".py" "examples" (Just "script/known_failures.txt")
+  , le "go" ".go" "examples" (Just "script/known-failures.txt")
+  , le "ruby" ".rb" "examples" (Just "script/known_failures.txt")
+  , le "typescript" ".ts" "examples" (Just "script/known_failures.txt")
+  , le "typescript" ".js" "examples" Nothing -- parse JavaScript with TypeScript parser.
+
+  -- TODO: Java assignment errors need to be investigated
+  -- , le "java" ".java" "examples/guava" (Just "script/known_failures_guava.txt")
+  -- , le "java" ".java" "examples/elasticsearch" (Just "script/known_failures_elasticsearch.txt")
+  -- , le "java" ".java" "examples/RxJava" (Just "script/known_failures_RxJava.txt")
+
+  -- TODO: Haskell assignment errors need to be investigated
+  -- , le "haskell" ".hs" "examples/effects" (Just "script/known-failures-effects.txt")
+  -- , le "haskell" ".hs" "examples/postgrest" (Just "script/known-failures-postgrest.txt")
+  -- , le "haskell" ".hs" "examples/ivory" (Just "script/known-failures-ivory.txt")
+
+  -- , ("php", ".php") -- TODO: No parse-examples in tree-sitter yet
+  ]
+
+parseFilePath :: (Member (Exc SomeException) effs, Member Task effs, Member IO.Files effs) => FilePath -> Eff effs Bool
+parseFilePath path = readBlob (file path) >>= runParse' >>= const (pure True)
+
+languagesDir :: FilePath
+languagesDir = "vendor/haskell-tree-sitter/languages"

test/fixtures/python/corpus/if-statement.diffA-B.txt

@@ -6,12 +6,13 @@
     {+(Identifier)+}
       (Identifier)
     {-(Identifier)-})
-  { (If
+    (Statements
+    {-(If
       {-(Identifier)-}
       {-(Statements
         {-(Identifier)-}
         {-(Identifier)-})-}
+      {-(Statements)-})-}
     {-(Statements
       {-(Identifier)-}
-      {-(Identifier)-})-})
+      {-(Identifier)-})-})))
-  ->(Empty) }))

test/fixtures/python/corpus/if-statement.diffB-A.txt

@@ -6,12 +6,13 @@
     {-(Identifier)-}
       (Identifier)
     {+(Identifier)+})
-  { (Empty)
+    (Statements
-  ->(If
+    {+(If
       {+(Identifier)+}
       {+(Statements
         {+(Identifier)+}
         {+(Identifier)+})+}
+      {+(Statements)+})+}
     {+(Statements
       {+(Identifier)+}
-      {+(Identifier)+})+}) }))
+      {+(Identifier)+})+})))

test/fixtures/python/corpus/if-statement.parseA.txt

@@ -4,11 +4,13 @@
     (Statements
       (Identifier)
       (Identifier))
+    (Statements
       (If
         (Identifier)
         (Statements
           (Identifier)
           (Identifier))
+        (Statements))
       (Statements
         (Identifier)
         (Identifier)))))

test/fixtures/python/corpus/if-statement.parseB.txt

@@ -4,4 +4,4 @@
     (Statements
       (Identifier)
       (Identifier))
-    (Empty)))
+    (Statements)))

vendor/haskell-tree-sitter

@@ -1 +1 @@
-Subproject commit 09ff8a81cd92a696939eb82e0c33111bde3f0376
+Subproject commit f6916c009732b8b1195a05c13942b39cd8bf6829