diff --git a/semantic.cabal b/semantic.cabal index 01eae1fda..aa7d7406f 100644 --- a/semantic.cabal +++ b/semantic.cabal @@ -405,9 +405,12 @@ test-suite parse-examples main-is: Examples.hs build-depends: semantic , Glob - , hspec - , hspec-core - , hspec-expectations + , foldl ^>= 1.4.5 + , resourcet ^>= 1.2 + , streaming + , streaming-bytestring ^>= 0.1.6 + , tasty + , tasty-hunit benchmark evaluation import: haskell, executable-flags diff --git a/test/Examples.hs b/test/Examples.hs index c0f59b3aa..92a5cf3bf 100644 --- a/test/Examples.hs +++ b/test/Examples.hs @@ -1,90 +1,53 @@ {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -O1 #-} module Main (main) where import Control.Effect import Control.Exception (displayException) +import qualified Control.Foldl as Foldl +import Data.Function ((&)) +import Control.Concurrent.Async (forConcurrently) import Control.Monad import Control.Monad.IO.Class +import Control.Monad.Trans.Resource (ResIO, runResourceT) +import Data.Blob import qualified Data.ByteString as B import Data.ByteString.Builder import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy.Char8 as BLC +import qualified Data.ByteString.Streaming.Char8 as ByteStream import Data.Either -import Data.Blob (fileForRelPath) -import Data.Flag -import Data.Foldable -import Data.List -import Data.Maybe -import Data.Quieterm -import Data.Typeable (cast) -import Data.Void -import Parsing.Parser -import Semantic.Api (TermOutputFormat (..), parseTermBuilder) -import Semantic.Config (Config (..), Options (..), FailOnWarning (..), defaultOptions) -import qualified Semantic.IO as IO -import Semantic.Task -import Semantic.Task.Files -import System.Directory -import System.Exit (die) +import Data.Set (Set) +import Data.Traversable +import Data.Typeable +import qualified Streaming.Prelude as Stream import System.FilePath.Glob -import qualified System.Path as Path import System.Path (()) -import System.Process -import Test.Hspec +import qualified System.Path as Path +import qualified System.Process as Process +import Data.Flag +import Semantic.Api (TermOutputFormat (..), parseTermBuilder) +import Semantic.Config as Config +import Semantic.Task +import Semantic.Task.Files -main :: IO () -main = withOptions opts $ \ config logger statter -> hspec . parallel $ do - let args = TaskSession config "-" False logger statter - - runIO setupExampleRepos - - for_ languages $ \ lang@LanguageExample{..} -> do - let tsLang = Path.relDir ("tree-sitter-" <> languageName) - tsDir = languagesDir tsLang Path.relDir "vendor" tsLang - parallel . describe languageName $ parseExamples args lang tsDir - - where - parseExamples session LanguageExample{..} tsDir = do - knownFailures <- runIO $ knownFailuresForPath tsDir languageKnownFailuresTxt - files <- runIO $ globDir1 (compile ("**/*" <> languageExtension)) (Path.toString (tsDir languageExampleDir)) - let paths = Path.relFile <$> files - for_ paths $ \file -> it (Path.toString file) $ do - res <- runTask session (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) - Just ParserTimedOut -> pendingWith $ show (displayException e) - -- Other exceptions are true failures - _ -> expectationFailure (show (displayException e)) - _ -> if file `elem` knownFailures - then pendingWith $ "Known parse failures " <> show ("Assignment: OK" <$ res) - else res `shouldSatisfy` isRight - - setupExampleRepos = readProcess "script/clone-example-repos" mempty mempty >>= print - opts = defaultOptions { optionsFailOnWarning = flag FailOnWarning True, optionsLogLevel = Nothing } - - knownFailuresForPath :: Path.RelDir -> Maybe Path.RelFile -> IO [Path.RelFile] - knownFailuresForPath _ Nothing = pure [] - knownFailuresForPath tsDir (Just path) = do - known <- BC.lines <$> B.readFile (Path.toString (tsDir path)) - let stripComments = filter (\line -> not (BC.null line) && BC.head line == '#') - let failures = Path.relFile . BC.unpack <$> stripComments known - pure ((tsDir ) <$> failures) +import qualified Test.Tasty as Tasty +import qualified Test.Tasty.HUnit as HUnit data LanguageExample = LanguageExample - { languageName :: String - , languageExtension :: String - , languageExampleDir :: Path.RelDir + { languageName :: String + , languageExtension :: String + , languageExampleDir :: Path.RelDir , languageKnownFailuresTxt :: Maybe Path.RelFile } deriving (Eq, Show) le :: String -> String -> Path.RelDir -> Maybe Path.RelFile -> LanguageExample le = LanguageExample -languages :: [LanguageExample] -languages = +examples :: [LanguageExample] +examples = [ le "python" ".py" examples (Just $ Path.relFile "script/known_failures.txt") , le "ruby" ".rb" examples (Just $ Path.relFile "script/known_failures.txt") , le "typescript" ".ts" examples (Just $ Path.relFile "typescript/script/known_failures.txt") @@ -105,8 +68,57 @@ languages = -- , ("php", ".php") -- TODO: No parse-examples in tree-sitter yet ] where examples = Path.relDir "examples" +buildExamples :: TaskSession -> LanguageExample -> Path.RelDir -> IO Tasty.TestTree +buildExamples session lang tsDir = do + knownFailures <- knownFailuresForPath tsDir (languageKnownFailuresTxt lang) + files <- globDir1 (compile ("**/*" <> languageExtension lang)) (Path.toString (tsDir languageExampleDir lang)) + let paths = Path.relFile <$> files + trees <- for paths $ \file -> pure $ HUnit.testCase (Path.toString file) $ do + res <- runTask session (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 -> pure () + Just ParserTimedOut -> pure () + -- Other exceptions are true failures + _ -> HUnit.assertFailure (show (displayException e)) + _ -> if file `elem` knownFailures + then pure () + else (isRight res) HUnit.@? ("Error: " <> either show show res) + pure (Tasty.testGroup (languageName lang) trees) + +testOptions :: Config.Options +testOptions = defaultOptions + { optionsFailOnWarning = flag FailOnWarning True + , optionsLogLevel = Nothing + } + +main :: IO () +main = withOptions testOptions $ \ config logger statter -> do + void $ Process.system "script/clone-example-repos" + + let session = TaskSession config "-" False logger statter + + allTests <- forConcurrently examples $ \lang@LanguageExample{..} -> do + let tsLang = Path.relDir ("tree-sitter-" <> languageName) + let tsDir = Path.relDir "tmp/haskell-tree-sitter" tsLang Path.relDir "vendor" tsLang + buildExamples session lang tsDir + + Tasty.defaultMain $ Tasty.testGroup "parse-examples" allTests + +knownFailuresForPath :: Path.RelDir -> Maybe Path.RelFile -> IO (Set Path.RelFile) +knownFailuresForPath _ Nothing = pure mempty +knownFailuresForPath tsDir (Just path) + = runResourceT + ( ByteStream.readFile @ResIO (Path.toString (tsDir path)) + & ByteStream.lines + & ByteStream.denull + & Stream.mapped ByteStream.toLazy + & Stream.filter ((/= '#') . BLC.head) + & Stream.map (Path.relFile . BLC.unpack) + & Foldl.purely Stream.fold_ Foldl.set + ) + + parseFilePath :: (Member (Error SomeException) sig, Member Distribute sig, Member Task sig, Member Files sig, Carrier sig m, MonadIO m) => Path.RelFile -> m Bool parseFilePath path = readBlob (fileForRelPath path) >>= parseTermBuilder @[] TermShow . pure >>= const (pure True) - -languagesDir :: Path.RelDir -languagesDir = Path.relDir "tmp/haskell-tree-sitter"