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 (IgnoreValidation)
 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 IgnoreValidation)]
+                             ,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,12 @@
+module Test.Config (IgnoreValidation(..)) where
+
+import Data.Tagged (Tagged(..))
+import Test.Tasty.Options (IsOption(..), flagCLParser)
+
+data IgnoreValidation = IgnoreValidation Bool
+instance IsOption IgnoreValidation where
+  defaultValue = IgnoreValidation False
+  parseValue s = if s == "ignore-validation" then Just defaultValue else Nothing
+  optionName = Tagged "ignore-validation"
+  optionHelp = Tagged "Don't mark validation failures as failures"
+  optionCLParser = flagCLParser Nothing (IgnoreValidation True)

brat/test/Test/Examples.hs

@@ -2,6 +2,7 @@ module Test.Examples (getExamplesTests) where
 
 import Test.Checking (parseAndCheckNamed)
 import Test.Compile.Hugr (compileToOutput, getHoles)
+import Test.Config (IgnoreValidation(..))
 import Brat.Load (parseFile)
 import Brat.Machine (runInterpreter)
 import Data.HugrGraph (to_json)
@@ -10,17 +11,44 @@ import qualified Data.ByteString as BS
 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(..), TestTree(..))
 import Test.Tasty.Silver
 import Test.Tasty.ExpectedFailure
 
 --import Debug.Trace
 
+data HugrTest = Validate TestTree | ValidationConfigErr
+
+instance IsTest HugrTest where
+  -- BAD: Uses implementation details
+  run opts (Validate (SingleTest _ t)) f = run opts t f
+  run opts ValidationConfigErr f = pure $ Result
+                                          outcome
+                                          "hugr_validator not installed"
+                                          (yellowText "SKIPPED")
+                                          0.0
+                                          noResultDetails
+   where
+    outcome = case lookupOption @IgnoreValidation opts of
+      IgnoreValidation False -> Failure TestDepFailed
+      IgnoreValidation True  -> Success
+    yellowText text = setSGRCode [SetColor Foreground Vivid Yellow] ++ text ++ setSGRCode [Reset]
+
+  testOptions = pure [Option (Proxy :: Proxy IgnoreValidation)]
+
 outputDir :: FilePath
 outputDir = "test" </> "examples"
 
@@ -32,11 +60,12 @@ interpreterOutputPrefix = "Finished "
 
 getExamplesTests :: IO TestTree
 getExamplesTests =  do
+  interpreterInPath <- checkValidatorInPath
   paths <- findByExtension [".brat"] "examples"
-  testGroup "examples" <$> mapM mkTest paths
+  testGroup "examples" <$> mapM (mkTest interpreterInPath) 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 +76,64 @@ 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"
+        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"
+              emitHugr = testCase func_name $ 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 @?= []
                 -- output the hugr for validation
                 createDirectoryIfMissing False outputDir
+                let hugr_string = to_json hugr
                 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!"
-            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])
+              validateTestCase = if interpreterInPath
+                                 then Validate (testCase undefined (validateTest outFile))
+                                 else ValidationConfigErr
+          in  emitHugr : [SingleTest ("validate(" ++ func_name ++")") validateTestCase]
+     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") ""
+  if exitCode == ExitSuccess
+  then pure ("hugr_validator 0." `isPrefixOf` output)
+  else pure False
+
+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]