tests: improve expectFailForPaths

brat/test/Test/Checking.hs

@@ -1,19 +1,31 @@
-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"
                                              ,"karlheinz_alias.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"

brat/test/Test/Compile/Hugr.hs

@@ -2,7 +2,8 @@ module Test.Compile.Hugr where
 
 import Brat.Compiler (compileFile)
 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)
@@ -43,14 +44,9 @@ nonCompilingExamples = (expectedCheckingFails ++ expectedParsingFails ++
   ,"one"
   ,"patterns"
   ,"qft"
-  ,"test"
   ,"type_alias"
   ,"vector"
   ,"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"
   ,"bell"
@@ -80,6 +76,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)

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

brat/test/Test/Libs.hs

@@ -1,6 +1,6 @@
 module Test.Libs where
 
-import Test.Util
+import Test.Checking (parseAndCheck)
 
 import Test.Tasty
 

brat/test/Test/Parsing.hs

@@ -1,12 +1,12 @@
-module Test.Parsing (getParsingTests, expectedParsingFails, expectFailForPaths) where
+module Test.Parsing (getParsingTests, expectedParsingFails) where
 
 import Brat.Load
 
 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"

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