tests: pass test if files have holes; don't write out file if checking fails

brat/Brat/Compiler.hs

@@ -3,15 +3,18 @@ module Brat.Compiler (printAST
                      ,writeDot
                      ,compileFile
                      ,compileAndPrintFile
+                     ,CompilingHoles(..)
                      ) where
 
+import Brat.Checker.Types (TypedHole)
 import Brat.Compile.Hugr
 import Brat.Dot (toDotString)
 import Brat.Elaborator
 import Brat.Error
 import Brat.Load
 import Brat.Naming (root, split)
 
+import Control.Exception (evaluate)
 import Control.Monad (when)
 import Control.Monad.Except
 import qualified Data.ByteString.Lazy as BS
@@ -61,16 +64,23 @@ writeDot libDirs file out = do
   isMain _ = False
 -}
 
-compileFile :: [FilePath] -> String -> IO (Either String BS.ByteString)
+newtype CompilingHoles = CompilingHoles [TypedHole]
+
+instance Show CompilingHoles where
+  show (CompilingHoles hs) = unlines $
+    "Can't compile file with remaining holes": fmap (("  " ++) . show) hs
+
+compileFile :: [FilePath] -> String -> IO (Either CompilingHoles BS.ByteString)
 compileFile libDirs file = do
   let (checkRoot, newRoot) = split "checking" root
   env <- runExceptT $ loadFilename checkRoot libDirs file
   (venv, _, holes, defs, outerGraph) <- eitherIO env
-  pure $ case holes of
-    [] -> Right $ compile defs newRoot outerGraph venv
-    xs -> Left (show (CompilingHoles (show <$> xs)))
+  case holes of
+    [] -> Right <$> (evaluate -- turns 'error' into IO 'die'
+            $ compile defs newRoot outerGraph venv)
+    hs -> pure $ Left (CompilingHoles hs)
 
 compileAndPrintFile :: [FilePath] -> String -> IO ()
 compileAndPrintFile libDirs file = compileFile libDirs file >>= \case
   Right bs -> BS.putStr bs
-  Left err -> die err
+  Left err -> die (show err)

brat/Brat/Error.hs

@@ -78,8 +78,6 @@
  | UnreachableBranch
  | UnrecognisedTypeCon String
  | WrongModeForType String
- -- TODO: Add file context here
- | CompilingHoles [String]
  -- For thunks which don't address enough inputs, or produce enough outputs.
  -- The argument is the row of unused connectors
  | ThunkLeftOvers String
@@ -165,9 +163,6 @@
   -- TODO: Make all of these use existing errors
   show (UnificationError str) = "Unification error: " ++ str
   show UnreachableBranch = "Branch cannot be reached"
-  show (CompilingHoles hs) = unlines ("Can't compile file with remaining holes": indent hs)
-   where
-    indent = fmap ("  " ++)
   show (ThunkLeftOvers overs) = "Expected function to address all inputs, but " ++ overs ++ " wasn't used"
   show (ThunkLeftUnders unders) = "Expected function to return additional values of type: " ++ unders
 
@@ -209,8 +204,8 @@
     ls = lines contents
   in case endLineN - startLineN of
        0 -> [ls!!startLineN, highlightSection startCol endCol]
        n | n > 0 -> let (first:rest) = drop (startLineN - 1) $ take (endLineN + 1) ls
                         (last:rmid) = reverse rest
                     in [first, highlightSection startCol (length first)]
                        ++ (reverse rmid >>= (\l -> [l, highlightSection 0 (length l)]))
                        ++ [last, highlightSection 0 endCol]

brat/test/Test/Compile/Hugr.hs

@@ -1,6 +1,6 @@
 module Test.Compile.Hugr where
 
-import Brat.Compiler (compileFile)
+import Brat.Compiler (compileFile, CompilingHoles(..))
 import Test.Checking (expectedCheckingFails)
 import Test.Parsing (expectedParsingFails, expectFailForPaths)
 
@@ -25,35 +25,23 @@ invalidExamples = map ((++ ".brat") . ("examples" </>))
   ,"repeated_app" -- missing coercions, https://github.com/CQCL-DEV/brat/issues/413
   ,"thunks"]
 
--- examples that we expect not to compile
--- Note this includes those with remaining holes; it would be better
--- to detect those automatically (as this is not a bug, they *shouldn't* compile)
+-- examples that we expect not to compile.
+-- Note this does not include those with remaining holes; these are automatically skipped.
 nonCompilingExamples = (expectedCheckingFails ++ expectedParsingFails ++
   map ((++ ".brat") . ("examples" </>))
   ["fzbz"
-  ,"full"
-  ,"graph"
-  ,"holes"
   ,"ising"
-  ,"kernel"
-  ,"kernel-syntax"
-  ,"kinds"
   ,"let"
-  ,"listpair"
-  ,"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"
   ,"cqcconf"
   ,"imports"
   ,"ising"
@@ -65,14 +53,13 @@ nonCompilingExamples = (expectedCheckingFails ++ expectedParsingFails ++
   ])
 
 compileToOutput :: FilePath -> TestTree
-compileToOutput file = testCase (show file) $ do
-  -- for non-compiling examples we end up writing out an empty file so that's invalid too
-  let isValid = not (file `elem` nonCompilingExamples || file `elem` invalidExamples)
-  let outputExt = if isValid  then "json" else "json.invalid"
-  let outFile = outputDir </> replaceExtension (takeFileName file) outputExt
-  compileFile [] file >>= \case
-    Right bs -> BS.writeFile outFile bs
-    Left err -> assertFailure err
+compileToOutput file = testCaseInfo (show file) $ compileFile [] file >>= \case
+    Right bs -> do
+      let outputExt = if file `elem` invalidExamples then "json.invalid" else "json"
+      let outFile = outputDir </> replaceExtension (takeFileName file) outputExt
+      BS.writeFile outFile bs
+      pure $ "Written to " ++ outFile ++ " pending validation"
+    Left (CompilingHoles _) -> pure "Skipped as contains holes"
 
 setupCompilationTests :: IO TestTree
 setupCompilationTests = do