diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index 2c82a5a0..b6b7a64e 100644 --- a/.github/workflows/ci.yml +++ b/.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 diff --git a/brat/brat.cabal b/brat/brat.cabal index f237c89e..620e3692 100644 --- a/brat/brat.cabal +++ b/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 diff --git a/brat/test/Main.hs b/brat/test/Main.hs index 3e0fda2b..6655222e 100644 --- a/brat/test/Main.hs +++ b/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 + ] diff --git a/brat/test/Test/Compile/Hugr.hs b/brat/test/Test/Compile/Hugr.hs index 1551f85c..83cc241c 100644 --- a/brat/test/Test/Compile/Hugr.hs +++ b/brat/test/Test/Compile/Hugr.hs @@ -3,10 +3,14 @@ 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) @@ -14,6 +18,17 @@ 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)] \ No newline at end of file +getHoles hg = [n | n <- getNodes hg, isJust (isHole $ getOp hg n)] diff --git a/brat/test/Test/Config.hs b/brat/test/Test/Config.hs new file mode 100644 index 00000000..1934c488 --- /dev/null +++ b/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 diff --git a/brat/test/Test/Examples.hs b/brat/test/Test/Examples.hs index 41c547ff..7bf6820e 100644 --- a/brat/test/Test/Examples.hs +++ b/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,37 +78,8 @@ 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] @@ -85,3 +87,47 @@ getExamplesTests = do [] -> 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 diff --git a/brat/tools/validate.sh b/brat/tools/validate.sh deleted file mode 100755 index 7a9d414a..00000000 --- a/brat/tools/validate.sh +++ /dev/null @@ -1,56 +0,0 @@ -#!/bin/bash - -set -u - -if ! which hugr_validator; then - "hugr_validator not found in path" - exit 1 -fi - -declare -a FAILED_TEST_NAMES -declare -a FAILED_TEST_MSGS -UNEXPECTED_PASSES= -NUM_FAILURES=0 - -for dir in test/compilation/output test/examples test/hugr/output; do - for json in $(find $dir -maxdepth 1 -name "*.json"); do - echo Validating "$json" - RESULT=$(cat "$json" | hugr_validator 2>&1) - if [ $? -ne 0 ]; then - FAILED_TEST_NAMES[NUM_FAILURES]=$json - FAILED_TEST_MSGS[NUM_FAILURES]=$RESULT - NUM_FAILURES=$((NUM_FAILURES + 1)) - fi - done -done - -for invalid_json in $(find test/compilation/output -maxdepth 1 -name "*.json.invalid"); do - if (hugr_validator < $invalid_json 2>/dev/null > /dev/null); then - UNEXPECTED_PASSES="$UNEXPECTED_PASSES $invalid_json" - fi -done - -RED='\033[0;31m' -GREEN='\033[0;32m' -NO_COLOUR='\033[0m' - -RESULT=0 # I.e., an "ok" exit value - -if [ $NUM_FAILURES -gt 0 ]; then - echo -e $RED - for ix in $(seq 0 $((NUM_FAILURES - 1))); do - echo Validation failed: "${FAILED_TEST_NAMES[$ix]}" - echo "${FAILED_TEST_MSGS[$ix]}" - done - - echo $NUM_FAILURES failures. $NO_COLOUR - RESULT=1 # I.e. a "bad" exit value -else - echo -e $GREEN All Hugrs validated $NO_COLOUR -fi - -if [ "$UNEXPECTED_PASSES" != "" ]; then - echo -e $RED "There were unexpected passes: $UNEXPECTED_PASSES" $NO_COLOUR - RESULT=1 -fi -exit $RESULT diff --git a/hugr_validator/Cargo.toml b/hugr_validator/Cargo.toml index f3cfa792..66d345e9 100644 --- a/hugr_validator/Cargo.toml +++ b/hugr_validator/Cargo.toml @@ -1,6 +1,6 @@ [package] name = "hugr_validator" -version = "0.4.0" +version = "0.4.1" edition = "2021" [dependencies] diff --git a/hugr_validator/src/main.rs b/hugr_validator/src/main.rs index 02884917..a16d6b4c 100644 --- a/hugr_validator/src/main.rs +++ b/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 = 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); } }