diff --git a/brat/test/Test/Checking.hs b/brat/test/Test/Checking.hs index 83839a24..ef0bc352 100644 --- a/brat/test/Test/Checking.hs +++ b/brat/test/Test/Checking.hs @@ -1,10 +1,14 @@ -module Test.Checking (getCheckingTests, expectedCheckingFails) where +module Test.Checking (parseAndCheck, getCheckingTests, expectedCheckingFails) where -import Test.Parsing (expectedParsingFails, expectFailForPaths) -import Test.Util (parseAndCheck) +import Brat.Load +import Brat.Naming (root) +import Test.Parsing (expectedParsingFails) +import Test.Util (expectFailForPaths) +import Control.Monad.Except import System.FilePath import Test.Tasty +import Test.Tasty.HUnit import Test.Tasty.Silver expectedCheckingFails = map ("examples" ) ["nested-abstractors.brat" @@ -12,8 +16,16 @@ expectedCheckingFails = map ("examples" ) ["nested-abstractors.brat" ,"hea.brat" ] -parseAndCheckXF :: FilePath -> TestTree +parseAndCheckXF :: [FilePath] -> [TestTree] parseAndCheckXF = expectFailForPaths (expectedParsingFails ++ expectedCheckingFails) (parseAndCheck []) getCheckingTests :: IO TestTree -getCheckingTests = testGroup "checking" . fmap parseAndCheckXF <$> findByExtension [".brat"] "examples" +getCheckingTests = testGroup "checking" . parseAndCheckXF <$> findByExtension [".brat"] "examples" + +parseAndCheck :: [FilePath] -> FilePath -> TestTree +parseAndCheck libDirs file = testCase (show file) $ do + env <- runExceptT $ loadFilename root libDirs file + case env of + Left err -> assertFailure (show err) + Right (venv, nouns, holes, _, _) -> + ((length venv) + (length nouns) + (length holes) > 0) @? "Should produce something" diff --git a/brat/test/Test/Compile/Hugr.hs b/brat/test/Test/Compile/Hugr.hs index d0f5fe55..6f30c606 100644 --- a/brat/test/Test/Compile/Hugr.hs +++ b/brat/test/Test/Compile/Hugr.hs @@ -2,7 +2,8 @@ module Test.Compile.Hugr where import Brat.Compiler (compileFile, CompilingHoles(..)) import Test.Checking (expectedCheckingFails) -import Test.Parsing (expectedParsingFails, expectFailForPaths) +import Test.Parsing (expectedParsingFails) +import Test.Util (expectFailForPaths) import qualified Data.ByteString.Lazy as BS import System.Directory (createDirectoryIfMissing) @@ -34,12 +35,7 @@ nonCompilingExamples = (expectedCheckingFails ++ expectedParsingFails ++ ,"let" ,"patterns" ,"qft" - ,"test" ,"fanout" -- Contains Selectors - -- Conjecture: These examples don't compile because number patterns in type - -- signatures causes `kindCheck` to call `abstract`, creating "Selector" - -- nodes, which we don't attempt to compile because we want to get rid of them - ,"vec-pats" -- Victims of #13 ,"arith" ,"cqcconf" @@ -67,6 +63,6 @@ setupCompilationTests = do examples <- findByExtension [".brat"] examplesPrefix createDirectoryIfMissing False outputDir let compileTests = compileToOutput <$> tests - let examplesTests = testGroup "examples" $ expectFailForPaths nonCompilingExamples compileToOutput <$> examples + let examplesTests = testGroup "examples" $ expectFailForPaths nonCompilingExamples compileToOutput examples pure $ testGroup "compilation" (examplesTests:compileTests) diff --git a/brat/test/Test/Failure.hs b/brat/test/Test/Failure.hs index b51df71f..a6f44b69 100644 --- a/brat/test/Test/Failure.hs +++ b/brat/test/Test/Failure.hs @@ -10,7 +10,7 @@ import System.IO.Silently import Data.Text (pack) import Brat.Compiler -import Test.Parsing (expectFailForPaths) +import Test.Util (expectFailForPaths) goldenTest file = goldenVsAction (takeBaseName file) (file <.> "golden") (runGetStderr file $ compileAndPrintFile [] file) pack @@ -31,7 +31,7 @@ getBindingTests :: IO TestTree getBindingTests = testGroup "binding" . fmap goldenTest <$> findByExtension [".brat"] "test/golden/binding" getErrorTests :: IO TestTree -getErrorTests = testGroup "error" . fmap (expectFailForPaths ["test/golden/error/unreachablebranch.brat"] goldenTest) <$> findByExtension [".brat"] "test/golden/error" +getErrorTests = testGroup "error" . expectFailForPaths ["test/golden/error/unreachablebranch.brat"] goldenTest <$> findByExtension [".brat"] "test/golden/error" runGetStderr :: String -> IO () -> IO String runGetStderr name action = do diff --git a/brat/test/Test/Libs.hs b/brat/test/Test/Libs.hs index e71182e7..b1483810 100644 --- a/brat/test/Test/Libs.hs +++ b/brat/test/Test/Libs.hs @@ -1,6 +1,6 @@ module Test.Libs where -import Test.Util +import Test.Checking (parseAndCheck) import Test.Tasty diff --git a/brat/test/Test/Parsing.hs b/brat/test/Test/Parsing.hs index 6ca1be01..02841f5a 100644 --- a/brat/test/Test/Parsing.hs +++ b/brat/test/Test/Parsing.hs @@ -1,4 +1,4 @@ -module Test.Parsing (getParsingTests, expectedParsingFails, expectFailForPaths) where +module Test.Parsing (getParsingTests, expectedParsingFails) where import Brat.Load @@ -6,7 +6,7 @@ import System.FilePath import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.Silver -import Test.Tasty.ExpectedFailure +import Test.Util (expectFailForPaths) testParse :: FilePath -> TestTree testParse file = testCase (show file) $ do @@ -19,10 +19,7 @@ expectedParsingFails = map ("examples" ) [ "karlheinz.brat", "thin.brat"] -expectFailForPaths :: [FilePath] -> (FilePath -> TestTree) -> FilePath -> TestTree -expectFailForPaths xf f path = (if path `elem` xf then expectFail else id) $ f path - parseXF = expectFailForPaths expectedParsingFails testParse getParsingTests :: IO TestTree -getParsingTests = testGroup "parsing" . fmap parseXF <$> findByExtension [".brat"] "examples" +getParsingTests = testGroup "parsing" . parseXF <$> findByExtension [".brat"] "examples" diff --git a/brat/test/Test/Util.hs b/brat/test/Test/Util.hs index e53eda4f..1f50d9cc 100644 --- a/brat/test/Test/Util.hs +++ b/brat/test/Test/Util.hs @@ -5,12 +5,12 @@ import Brat.Checker.Monad import Brat.Checker.Types (initStore, emptyEnv) import Brat.Error import Brat.FC -import Brat.Load import Brat.Naming -import Control.Monad.Except +import qualified Data.Set as S import Test.Tasty import Test.Tasty.HUnit +import Test.Tasty.ExpectedFailure runEmpty m = run emptyEnv initStore root m @@ -19,10 +19,11 @@ assertChecking m = case runEmpty $ localFC (FC (Pos 0 0) (Pos 0 0)) m of Right _ -> pure () Left err -> assertFailure (showError err) -parseAndCheck :: [FilePath] -> FilePath -> TestTree -parseAndCheck libDirs file = testCase (show file) $ do - env <- runExceptT $ loadFilename root libDirs file - case env of - Left err -> assertFailure (show err) - Right (venv, nouns, holes, _, _) -> - ((length venv) + (length nouns) + (length holes) > 0) @? "Should produce something" +expectFailForPaths :: [FilePath] -> (FilePath -> TestTree) -> [FilePath] -> [TestTree] +expectFailForPaths xf makeTest paths = if S.null not_found then tests else + error $ "Tried to XFAIL non-existent tests " ++ show not_found + where + f :: FilePath -> ([TestTree], S.Set FilePath) -> ([TestTree], S.Set FilePath) + f path (ts, remaining_xfs) = let newTest = (if S.member path remaining_xfs then expectFail else id) $ makeTest path + in (newTest:ts, S.delete path remaining_xfs) + (tests, not_found) = foldr f ([], S.fromList xf) paths