tests: Move validation tests to the haskell test suite

.github/workflows/ci.yml

@@ -60,10 +60,8 @@ jobs:
       run: stack build --ghc-options "-O0"
     - name: Build stack tests
       run: stack test --no-run-tests --no-run-benchmarks --ghc-options "-O0"
-    - name: Run stack tests
-      run: stack test --ta --hide-successes
 
-    # Validate the hugr outputs
+    # Install hugr_validator before running tests
     - name: Check for hugr_validator
       id: cached_validator
       run: |
@@ -82,5 +80,7 @@ jobs:
     - name: Install hugr_validator
       if: ${{ steps.cached_validator.outputs.out != 'true' }}
       run: cargo install --path ../hugr_validator
-    - name: Validate compilation output
-      run: tools/validate.sh
+
+    # Run tests
+    - name: Run stack tests
+      run: stack test --ta --hide-successes

brat/brat.cabal

@@ -162,6 +162,7 @@ test-suite tests
   hs-source-dirs:      test
   main-is:             Main.hs
   other-modules:       Test.Abstractor,
+                       Test.Config,
                        Test.Checking,
                        Test.Compile.Hugr,
                        Test.Elaboration,
@@ -194,4 +195,7 @@ test-suite tests
                        utility-ht,
                        partial-order,
                        bytestring,
-                       directory
+                       directory,
+                       process,
+                       ansi-terminal,
+                       tagged

brat/test/Main.hs

@@ -1,7 +1,11 @@
-import Test.Tasty  (testGroup)
-import Test.Tasty.Silver.Interactive (defaultMain)
+import Data.Proxy (Proxy(..))
+import Test.Tasty (includingOptions, testGroup)
+import Test.Tasty.Ingredients.ConsoleReporter (consoleTestReporterWithHook)
+import Test.Tasty.Options (OptionDescription(Option))
+import Test.Tasty.Runners (defaultMainWithIngredients, listingTests)
 
 import Test.Abstractor
+import Test.Config (ValidationConfig)
 import Test.Examples
 import Test.Graph
 import Test.Elaboration
@@ -66,17 +70,23 @@ main = do
        [testCase "coroT1" $ assertChecking coroT1
        ,testCase "coroT2" $ assertCheckingFail "Typechecking blocked on" coroT2
        ]
-  defaultMain $ testGroup "All" [graphTests
-                                ,failureTests
-                                ,examplesTests
-                                ,letTests
-                                ,libDirTests
-                                ,nameTests
-                                ,searchTests
-                                ,elaborationTests
-                                ,substitutionTests
-                                ,abstractorTests
-                                ,typeArithTests
-                                ,coroTests
-                                ,spliceTests
-                                ]
+  -- The default `consoleTestReporter` adds a hook giving a pattern to run with
+  -- `-p` to rerun skipped tests, which adds more noise
+  defaultMainWithIngredients [includingOptions [Option (Proxy :: Proxy ValidationConfig)]
+                             ,listingTests
+                             ,consoleTestReporterWithHook (\_ r -> pure r)
+                             ] $
+    testGroup "All" [graphTests
+                    ,failureTests
+                    ,examplesTests
+                    ,letTests
+                    ,libDirTests
+                    ,nameTests
+                    ,searchTests
+                    ,elaborationTests
+                    ,substitutionTests
+                    ,abstractorTests
+                    ,typeArithTests
+                    ,coroTests
+                    ,spliceTests
+                    ]

brat/test/Test/Compile/Hugr.hs

@@ -3,17 +3,32 @@ module Test.Compile.Hugr (compileToOutput, getHoles) where
 import Control.Monad (forM)
 import qualified Data.Map as M
 import qualified Data.ByteString as BS
+import System.Console.ANSI (Color(..), ColorIntensity(..), ConsoleLayer(..), SGR(..), setSGRCode)
 import System.Directory (createDirectoryIfMissing)
 import System.FilePath
 import Test.Tasty
 import Test.Tasty.HUnit
+import Test.Tasty.Providers (IsTest(..))
+import Test.Tasty.Providers.ConsoleFormat (noResultDetails)
+import Test.Tasty.Runners (FailureReason(..), Result(..), Outcome(..), TestTree(..))
 
 import Data.Hugr (isHole)
 import Data.HugrGraph (to_json, getOp, HugrGraph, getNodes)
 import Data.List (sort)
 import Data.Maybe (isJust)
 import Brat.Compiler (compileFile, CompilingHoles(..))
 
+data HugrTest = Validate TestTree | Skipped String | SkipNoValidator
+
+instance IsTest HugrTest where
+  -- BAD: Uses implementation
+  run opts (Validate (SingleTest _ t)) f = run opts t f
+  run opts (Skipped msg) f = pure $ Result (Failure TestDepFailed) msg (yellowText "SKIPPED") 0.0 noResultDetails
+   where
+    yellowText text = setSGRCode [SetColor Foreground Vivid Yellow] ++ text ++ setSGRCode [Reset]
+
+  testOptions = pure []
+
 prefix = "test/compilation"
 outputDir = prefix </> "output"
 
@@ -32,4 +47,4 @@ compileToOutput name file = testCaseInfo name $ do
         Left (CompilingHoles _) -> pure "Skipped as contains holes"
 
 getHoles :: Ord a => HugrGraph a -> [a]
-getHoles hg = [n | n <- getNodes hg, isJust (isHole $ getOp hg n)]
+getHoles hg = [n | n <- getNodes hg, isJust (isHole $ getOp hg n)]

brat/test/Test/Config.hs

@@ -0,0 +1,13 @@
+module Test.Config (ValidationConfig(..)) where
+
+import Data.Tagged (Tagged(..))
+import Test.Tasty.Options (IsOption(..), flagCLParser)
+
+data ValidationConfig = IgnoreValidation | RunValidation
+
+instance IsOption ValidationConfig where
+  defaultValue = RunValidation
+  parseValue s = if s == "ignore-validation" then Just RunValidation else Nothing
+  optionName = Tagged "ignore-validation"
+  optionHelp = Tagged "Don't mark validation failures as failures"
+  optionCLParser = flagCLParser Nothing IgnoreValidation

brat/test/Test/Examples.hs

@@ -2,25 +2,55 @@ module Test.Examples (getExamplesTests) where
 
 import Test.Checking (parseAndCheckNamed)
 import Test.Compile.Hugr (compileToOutput, getHoles)
+import Test.Config (ValidationConfig(..))
 import Brat.Load (parseFile)
 import Brat.Machine (runInterpreter)
 import Data.HugrGraph (to_json)
 
 import qualified Data.ByteString as BS
+import Data.ByteString.Lazy (ByteString)
 import Data.Char (isAlphaNum)
 import Data.Functor ((<&>))
 import Data.List (isPrefixOf)
-import qualified Data.Text.Lazy as T
 import Data.Maybe (fromJust)
+import Data.Proxy
+import qualified Data.Text.Lazy as T
+import System.Console.ANSI (Color(..), ColorIntensity(..), ConsoleLayer(..), SGR(..), setSGRCode)
 import System.Directory (createDirectoryIfMissing)
+import System.Exit (ExitCode(..))
 import System.FilePath
+import System.Process (readCreateProcessWithExitCode, shell)
 import Test.Tasty
+import Test.Tasty.Providers
+import Test.Tasty.Providers.ConsoleFormat (noResultDetails)
 import Test.Tasty.HUnit
+import Test.Tasty.Options (lookupOption, OptionDescription(..))
+import Test.Tasty.Runners (FailureReason(..), Outcome(..), Result(..))
 import Test.Tasty.Silver
 import Test.Tasty.ExpectedFailure
 
 --import Debug.Trace
 
+data ValidationTest = VTest (IO ByteString) FilePath
+
+instance IsTest ValidationTest where
+  run opts (VTest hugr outFile) _ = do
+    hugr_bytes <- hugr
+    createDirectoryIfMissing True (takeDirectory outFile)
+    BS.writeFile outFile $! (BS.toStrict $ hugr_bytes)
+    (exitCode, stdout, stderr) <- readCreateProcessWithExitCode (shell $ "cat " ++ outFile ++ " | hugr_validator") ""
+    let (outcome, msg1, msg2) = case exitCode of
+          ExitSuccess -> (Success, "Validated hugr", "PASSED")
+          _ -> case lookupOption @ValidationConfig opts of
+            RunValidation -> (Failure TestDepFailed, stderr, "FAILED")
+            -- should we include the error message in the output for the skipped case? It might be a useful diagnostic, or just noise.
+            IgnoreValidation -> (Success, "Validation failed", yellowText "SKIPPED")
+    pure $ Result outcome msg1 msg2 0.0 noResultDetails
+   where
+    yellowText text = setSGRCode [SetColor Foreground Vivid Yellow] ++ text ++ setSGRCode [Reset]
+
+  testOptions = pure [Option (Proxy :: Proxy ValidationConfig)]
+
 outputDir :: FilePath
 outputDir = "test" </> "examples"
 
@@ -32,11 +62,12 @@ interpreterOutputPrefix = "Finished "
 
 getExamplesTests :: IO TestTree
 getExamplesTests =  do
+  validatorAvailable <- checkValidatorInPath
   paths <- findByExtension [".brat"] "examples"
-  testGroup "examples" <$> mapM mkTest paths
+  testGroup "examples" <$> mapM (mkTest validatorAvailable) paths
  where
-  mkTest :: FilePath -> IO TestTree
-  mkTest path = readFile path <&> \cts ->
+  mkTest :: Bool -> FilePath -> IO TestTree
+  mkTest interpreterInPath path = readFile path <&> \cts ->
     let parseTest = testCase "parsing" $ do
           case parseFile path cts of
             Left err -> assertFailure (show err)
@@ -47,41 +78,56 @@ getExamplesTests =  do
        else if isPrefixOf "--!xfail-checking" cts then
          testGroup (show path) [parseTest, expectFail checkTest]
        else
-        let interpreterTests = T.breakOnAll execTestPrefix (T.pack cts) <&> \(_, start) ->
-              let (testLine, newlineDefn) = T.breakOn (T.pack "\n") start
-                  -- this repeats/roughly duplicates the logic for "identifiers" in the parser
-                  func_name = T.unpack $ T.takeWhile (\c -> isAlphaNum c || c == '_' || c == '\'') (T.drop 1 newlineDefn)
-                  -- testLine begins with execTestPrefix, then either
-                  -- " " and the expected result
-                  -- "-xfail " and the (un-)expected result
-                  -- "-hugr\n" (checks no splices, outputs hugr for validation)
-                  restLine = fromJust $ T.stripPrefix execTestPrefix testLine
-              in if (T.pack "-hugr") == restLine then testCaseInfo func_name $ do
-                let outFile = outputDir </> dropExtension (takeFileName path) ++ "_" ++ func_name <.> "json"
-                -- this completely recompiles the file for each test, which is pretty bad
-                hugr <- runInterpreter [] path func_name >>= \case
-                  Left s -> assertFailure $ "Expected hugr, got " ++ T.unpack s
-                  Right hugr -> pure hugr
-                getHoles hugr @?= []
-                -- output the hugr for validation
-                createDirectoryIfMissing False outputDir
-                BS.writeFile outFile $! (BS.toStrict $ to_json hugr)
-                pure $ "Written hugr to " ++ outFile ++ " pending validation"
-              else
-                let (is_xfail, eOut) = case T.stripPrefix (T.pack "-xfail ") restLine of
-                      Just out -> (True, out)
-                      Nothing | Just out <- T.stripPrefix (T.pack " ") restLine -> (False, out)
-                              | otherwise -> error $ "Invalid exec test line: " ++ T.unpack testLine
-                    expectedOutput = interpreterOutputPrefix ++ T.unpack (T.strip eOut)
-                in (if is_xfail then expectFail else id) $ testCase func_name $ do
-                  -- this completely recompiles the file for each test, which is pretty bad
-                  runInterpreter [] path func_name >>= \case
-                    Left t -> T.unpack t @?= expectedOutput
-                    Right _ -> assertFailure $ "Expected output: '" ++ expectedOutput ++ "' but got a hugr!"
+        let execStrings = snd <$> T.breakOnAll execTestPrefix (T.pack cts)
+            interpreterTests = concat $ interpreterTestsForExample interpreterInPath path <$> execStrings
             compileTest = compileToOutput "compilation" path
             checkAndCompile = if isPrefixOf "--!xfail-compilation" cts
               then [checkTest, expectFail compileTest] else [compileTest]
         in case interpreterTests of
           [] -> testGroup (show path) checkAndCompile
           intTests -> sequentialTestGroup path AllSucceed
               (checkAndCompile ++ [testGroup "execution" intTests])
+
+
+interpreterTestsForExample :: Bool -> FilePath -> T.Text -> [TestTree]
+interpreterTestsForExample interpreterInPath path start =
+  let (testLine, newlineDefn) = T.breakOn (T.pack "\n") start
+      -- this repeats/roughly duplicates the logic for "identifiers" in the parser
+      func_name = T.unpack $ T.takeWhile (\c -> isAlphaNum c || c == '_' || c == '\'') (T.drop 1 newlineDefn)
+      -- testLine begins with execTestPrefix, then either
+      -- " " and the expected result
+      -- "-xfail " and the (un-)expected result
+      -- "-hugr\n" (checks no splices, outputs hugr for validation)
+      restLine = fromJust $ T.stripPrefix execTestPrefix testLine
+  in if (T.pack "-hugr") == restLine
+     then let outFile = outputDir </> dropExtension (takeFileName path) ++ "_" ++ func_name <.> "json"
+              makeHugr = do
+                -- this completely recompiles the file for each test, which is pretty bad
+                hugr <- runInterpreter [] path func_name >>= \case
+                  Left s -> assertFailure $ "Expected hugr, got " ++ T.unpack s
+                  Right hugr -> pure hugr
+                getHoles hugr @?= []
+                pure $ to_json hugr
+          in [singleTest func_name (VTest makeHugr outFile)]
+     else let (is_xfail, eOut) = case T.stripPrefix (T.pack "-xfail ") restLine of
+                Just out -> (True, out)
+                Nothing | Just out <- T.stripPrefix (T.pack " ") restLine -> (False, out)
+                        | otherwise -> error $ "Invalid exec test line: " ++ T.unpack testLine
+              expectedOutput = interpreterOutputPrefix ++ T.unpack (T.strip eOut)
+          in (:[]) . (if is_xfail then expectFail else id) . testCase func_name $ do
+            -- this completely recompiles the file for each test, which is pretty bad
+            runInterpreter [] path func_name >>= \case
+              Left t -> T.unpack t @?= expectedOutput
+              Right _ -> assertFailure $ "Expected output: '" ++ expectedOutput ++ "' but got a hugr!"
+
+checkValidatorInPath :: IO Bool
+checkValidatorInPath = do
+  (exitCode, output, _) <- readCreateProcessWithExitCode (shell "hugr_validator --version") ""
+  pure (exitCode == ExitSuccess && "hugr_validator 0." `isPrefixOf` output)
+
+validateTest :: FilePath -> Assertion
+validateTest file = do
+  (exitCode, stdout, stderr) <- readCreateProcessWithExitCode (shell $ "cat " ++ file ++ " | hugr_validator") "" -- TODO: Put hugr output there
+  case exitCode of
+    ExitSuccess -> pure () --  "Validated hugr" -- TODO: Can we give a msg?
+    _ -> assertFailure stderr

hugr_validator/Cargo.toml

@@ -1,6 +1,6 @@
 [package]
 name = "hugr_validator"
-version = "0.4.0"
+version = "0.4.1"
 edition = "2021"
 
 [dependencies]

hugr_validator/src/main.rs

@@ -31,11 +31,22 @@ fn parse_and_validate() -> Result<(), ValidationError> {
 }
 
 fn main() {
-    match parse_and_validate() {
-        Ok(()) => (),
-        Err(err) => {
-            println!("{}", err);
-            exit(1);
+    use std::env;
+    let args: Vec<String> = env::args().collect();
+    let num_args = args.len();
+    if num_args <= 1 {
+        match parse_and_validate() {
+            Ok(()) => (),
+            Err(err) => {
+                println!("{}", err);
+                exit(1);
+            }
         }
+    } else if num_args == 2 && args[1] == "--version" {
+        println!("hugr_validator 0.4.1");
+        exit(0);
+    } else {
+        println!("hugr_validator [--version] -- [HUGR]");
+        exit(2);
     }
 }