tests: pass test if files have holes; don't write out file if checkin…

…g fails (#44)

* Refactor: move `CompilingHoles` out of `Error`; make `CompileFile` return `CompilingHoles` rather than `String`.
* Compilation tests use `testCaseInfo` to display a message that validation is still pending
    * And, these now pass (rather than xfail), with note about being skipped, if there are holes.
* Use `evaluate` to turn `error`s in compilation into `IO` monad `die`, rather than empty ByteString

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 @@ data ErrorMsg
  | 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 @@ instance Show ErrorMsg where
   -- 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
 

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