mirror of
https://github.com/github/semantic.git
synced 2024-12-26 00:12:29 +03:00
Rewrite parse-examples target to use tasty.
This gets us a little bit of a speed boost, lets us drop a couple dependencies, and makes us use streaming libraries.
This commit is contained in:
Patrick Thomson
parent
a96a0e105a
commit
978018c1e1
@ -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
|
||||
|
||||
144
test/Examples.hs
144
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"
|
||||
|
||||
Loading…
Reference in New Issue
Block a user