diff options
135 files changed, 2097 insertions, 7361 deletions
diff --git a/testsuite/README b/testsuite/README index 2e5acaa6fd..ecce6529fb 100644 --- a/testsuite/README +++ b/testsuite/README @@ -1,14 +1,28 @@ Running the test suite against a GHC build ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -To use the test suite to test a GHC build, first say 'make' in -fptools/testsuite. The build system will build the test driver. To -run the tests, cd into tests/ghc-regress and say 'make' to run all the -tests against the GHC build in the same source tree. You'll get a -summary indicating how many tests succeeded and failed (including how -many of the failures were 'expected'), and a list of which tests -failed. To investigate the failures in more detail, see "Running -individual tests" below. +NOTE: you need Python (any version >= 1.5 will probably do) in order +to use the testsuite. + +To run the test suite against a GHC build in the same source tree: + + cd fptools/testsuite/tests/ghc-regress + make + +To run the test suite against a different GHC, say ghc-5.04: + + cd fptools/testsuite/tests/ghc-regress + make TEST_HC=ghc-5.04 + +To run an individual test or tests (eg. tc054): + + cd fptools/testsuite/tests/ghc-regress + make TEST=tc054 + +(you can also go straight to the directory containing the test and say +'make TEST=tc054' from there, which will save some time). + +For more details, see below. Running the testsuite with a compiler other than GHC @@ -30,17 +44,16 @@ Running individual tests or subdirectories of the testsuite ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ Most of the subdirectories in the testsuite have a Makefile. In these -subdirectories you can use 'make' to run the test driver in several +subdirectories you can use 'make' to run the test driver in two ways: make -- run all the tests in the current directory - make verbose -- as make test, but up the verbosity make accept -- run the tests, accepting the current output -The following variables may be set on the make command line, to adjust -various +The following variables may be set on the make command line: TESTS -- specific tests to run + TEST_HC -- compiler to use EXTRA_HC_OPTS -- extra flags to send to the Haskell compiler EXTRA_RUNTEST_OPTS -- extra flags to give the test driver CONFIG -- use a different configuration file @@ -57,79 +70,263 @@ new output like so: where <test-name> is the name of the test. In a directory which contains a single test, or if you want to update *all* the tests in -the current directory, just omit the 'TESTS=' part. +the current directory, just omit the 'TESTS=<test-name>' part. Adding a new test ~~~~~~~~~~~~~~~~~ -Almost all tests have a single source file and fall into one of the -categories should_fail (to compile), should_compile, or should_run. +For a test which can be encapsulated in a single source file, follow +these steps: + +1. Find the appropriate place for the test. The GHC regression suite + is generally organised in a "white-box" manner: a regression which + originally illustrated a bug in a particular part of the compiler + is placed in the directory for that part. For example, typechecker + regression tests go in the typechecker/ directory, parser tests + go in parser/, and so on. + + It's not always possible to find a single best place for a test; + in those cases just pick one which seems reasonable. + + Under each main directory may be up to three subdirectories: + + - should_compile: tests which need to compile only + + - should_fail: tests which should fail to compile + and generate a particular error message -Stuff to do: + - should_run: tests which should compile, run with + some specific input, and generate a + particular output. + + We don't always divide the tests up like this, and it's not + essential to do so (the directory names have no meaning as + far as the test driver is concerned). -1. Place the source and any expected outputs for the test in - ghc-regress/appropriateDirectory/should_<whatever> +2. Having found a suitable place for the test, give the test a name. + Follow the convention for the directory in which you place the + test: for example, in typecheck/should_compile, tests are named + tc001, tc002, and so on. Suppose you name your test T, then + you'll have the following files: + + T.hs The source file containing the test + + T.stdin (for tests that run, and optional) + A file to feed the test as standard input when it + runs. + + T.stdout (for tests that run, and optional) + For tests that run, this file is compared against + the standard output generated by the program. If + T.stdout does not exist, then the program must not + generate anything on stdout. + + T.stderr (optional) For tests that run, this file is compared + against the standard error generated by the program. + + For tests that compile only, this file is compared + against the standard error output of the compiler, + which is normalised to eliminate bogus differences + (eg. absolute pathnames are removed, whitespace + differences are ignored, etc.) - Place a should_xyz test in the should_xyz directory; putting it - elsewhere is possible, but confusing. 2. Edit all.T in the relevant directory and add a line for the - test. How to do this should be obvious. For the record, the - user-level functions are: + test. The line is always of the form + + test(<name>, <opt-fn>, <test-fn>, <args>) + + where + + <name> is the name of the test, in quotes (' or "). + + <opt-fn> is a function (i.e. any callable object in Python) + which allows the options for this test to be changed. + There are several pre-defined functions which can be + used in this field: + + normal don't change any options from the defaults + expect_fail this test is an expected failure + skip skip this test + omit_ways(ways) skip this test for certain ways + set_stdin(file) use a different file for stdin + exit_code(n) expect an exit code of 'n' from the prog + extra_run_opts(opts) pass some extra opts to the prog + + you can compose two of these functions together by + saying compose(f,g). For example, to expect an exit + code of 3 and omit way 'opt', we could use + + compose(omit_ways(['opt']), exit_code(3)) + + as the <opt-fn> argument. Calls to compose() can of + course be nested. + + + <test-fn> is a function which describes how the test should be + run, and determines the form of <args>. The possible + values are: + + compile Just compile the program, the + compilation should succeed. + + compile_fail Just compile the program, the + compilation should fail (error + messages will be in T.stderr). + + compile_and_run + Compile the program and run it, + comparing the output against the + relevant files. + + multimod_compile + Compile a multi-module program + (more about multi-module programs + below). + + multimod_compile_and_run + Compile and run a multi-module + program. + + <args> is a list of arguments to be passed to <test-fn>. + + For compile, compile_fail and compile_and_run, <args> + is a list with a single string which contains extra + compiler options with which to run the test. eg. + + test(tc001, normal, compile, ['-fglasgow-exts']) + + would pass the flag -fglasgow-exts to the compiler + when compiling tc001. + + The multimod_ versions of compile and compile_and_run + expect an extra argument on the front of the list: the + name of the top module in the program to be compiled + (usually this will be 'Main'). + + +A multi-module test is straightforward. It must go in a directory of +its own, and the source files can be named anything you like. The +test must have a name, in the same way as a single-module test; and +the stdin/stdout/stderr files follow the name of the test as before. +In the same directory, place a file 'test.T' containing a line like + + test(multimod001, normal, multimod_compile_and_run, \ + [ 'Main', '-fglasgow-exts', '', 0 ]) + +as described above. + +For some examples, take a look in tests/ghc-regress/programs. + + +The details +~~~~~~~~~~~ + +The test suite driver is just a set of Python scripts, as are all of +the .T files in the test suite. The driver (driver/runtests.py) first +searches for all the .T files it can find, and then proceeds to +execute each one, keeping a track of the number of tests run, and +which ones succeeded and failed. + +The script runtests.py takes several options: + + --config <file> + + <file> is just a file containing Python code which is + executed. The purpose of this option is so that a file + containing settings for the configuration options can + be specified on the command line. Multiple --config options + may be given. + + --rootdir <dir> + + <dir> is the directory below which to search for .T files + to run. + + --output-summary <file> - -- Run a should_run vanilla (single-source-file) test. - You can specify extra compile and run flags, and if the - run is expected to have a non-zero exit code, that too. - The run's .stderr must match the specified .stderr if - it exists. The run's .stdout must match at least one of - the specified .stdouts, if they exist. + In addition to dumping the test summary to stdout, also + put it in <file>. (stdout also gets a lot of other output + when running a series of tests, so redirecting it isn't + always the right thing). - vt ( extra_compile_args, - extra_run_args, - expected_nonzero_run_result ) + --only <test> + Only run tests named <test> (multiple --only options can + be given). Useful for running a single test from a .T file + containing multiple tests. - -- Run a vanilla should_compile test. To pass, the compiler must - exit with 0, and the normalised .stderr, if it exists, must - match the normalised specified .stderr. + -e <stmt> - vtc ( extra_compile_args ) + executes the Python statement <stmt> before running any tests. + The main purpose of this option is to allow certain + configuration options to be tweaked from the command line; for + example, the build system adds '-e config.accept=1' to the + command line when 'make accept' is invoked. - - -- Run a vanilla should_fail test. To pass, the compiler must - exit with non-zero, and the normalised .stderr, which must exist, - must match the normalised specified .stderr. +Most of the code for running tests is located in driver/testlib.py. +Take a look. - vtf ( extra_compile_args ) +There is a single Python class (TestConfig) containing the global +configuration for the test suite. It contains information such as the +kind of compiler being used, which flags to give it, which platform +we're running on, and so on. The idea is that each platform and +compiler would have its own file containing assignments for elements +of the configuration, which are sourced by passing the appropriate +--config options to the test driver. For example, the GHC +configuration is contained in the file config/ghc. +A .T file can obviously contain arbitrary Python code, but the general +idea is that it contains a sequence of calls to the function test(), +which resides in testlib.py. As described above, test() takes four +arguments: -LIMITATIONS + test(<name>, <opt-fn>, <test-fn>, <args>) -1. Only single-source-file tests are properly supported at the mo. - To be fixed. +The function <opt-fn> is allowed to be any Python callable object, +which takes a single argument of type TestOptions. TestOptions is a +class containing options which affect the way that the current test is +run: whether to skip it, whether to expect failure, extra options to +pass to the compiler, etc. (see testlib.py for the definition of the +TestOptions class). The idea is that the <opt-fn> function modifies +the TestOptions object that it is passed. For example, to expect +failure for a test, we might do this in the .T file: -2. All compilations are passed -no-recomp -dcore-lint, so there's - no point in adding them. + def fn(opts): + opts.expect = 'fail' -3. If you want to pass a flag to a whole bunch of tests, write a - small wrapper fn to do this. See vtc vs myvtc in + test(test001, fn, compile, ['']) - ghc-regress/typecheck/should_compile/all.T. +so when fn is called, it sets the instance variable "expect" in the +instance of TestOptions passed as an argument, to the value 'fail'. +This indicates to the test driver that the current test is expected to +fail. -4. Current mis-/un-handled tests are documented in ghc-regress/NOTES. +Some of these functions, such as the one above, are common, so rather +than forcing every .T file to redefine them, we provide canned +versions. For example, the provided function expect_fail does the +same as fn in the example above. See testlib.py for all the canned +functions we provide for <opt-fn>. +The argument <test-fn> is a function which performs the test. It +takes three or more arguments: + <test-fn>( <name>, <way>, ... ) -ERROR MESSAGE NORMALISATION +where <name> is the name of the test, <way> is the way in which it is +to be run (eg. opt, optasm, prof, etc.), and the rest of the arguments +are constructed from the list <args> in the original call to test(). +The following <test-fn>s are provided at the moment: -Is done to reduce spurious failures due to changes in capitalisation -and whitespaces. Expected and actual error messages are normalised -prior to comparison. What it does: + compile + compile_fail + compile_and_run + multimod_compile + multimod_compile_and_run + +and obviously others can be defined. The function should return +either 'pass' or 'fail' indicating that the test passed or failed +respectively. --- Remove all whitespace lines --- Merge all other whitespace into a single space. --- Make all lowercase. --- Look for file names and zap the directory part: - foo/var/xyzzy/somefile.ext --> somefile.ext diff --git a/testsuite/config/ghc b/testsuite/config/ghc new file mode 100644 index 0000000000..dc0612551b --- /dev/null +++ b/testsuite/config/ghc @@ -0,0 +1,17 @@ +# Testsuite configuration setup for GHC +# +# This file is Python source +# +config.compiler_type = 'ghc' +config.compiler = 'ghc' +config.compiler_always_flags = ['-no-recomp', '-dcore-lint'] + +config.compile_ways = ['normal', 'opt', 'optasm'] +config.run_ways = ['normal', 'opt', 'optasm'] + +config.way_flags = { 'normal' : [], + 'opt' : ['-O'], + 'optasm' : ['-O -fasm'], + 'prof' : ['-O -prof -auto-all'], + 'unreg' : ['-unreg'] + } diff --git a/testsuite/config/msrc/cam-02-unx.T b/testsuite/config/msrc/cam-02-unx.T deleted file mode 100644 index 30d44475eb..0000000000 --- a/testsuite/config/msrc/cam-02-unx.T +++ /dev/null @@ -1,2 +0,0 @@ -$arch = "i386" -$os = "linux" diff --git a/testsuite/config/multimod-test.T b/testsuite/config/multimod-test.T deleted file mode 100644 index 66465548e9..0000000000 --- a/testsuite/config/multimod-test.T +++ /dev/null @@ -1,171 +0,0 @@ - ------------------------------------------------------------------------ ---- Stuff to do with multiple-source-file tests. We assume --- ---- that the name of the test is to be used as the basename --- ---- for everything. --- ------------------------------------------------------------------------ - --- global variables: -$stdin = "" -$expect = "pass" -$normalise_errmsg = False -$normalise_output = False - ---------------------------------------------------------------- ---- UTILITY FNs --- ---------------------------------------------------------------- - -include ($confdir ++ "/" ++ $conffilename) -include ($confdir ++ "/../std-macros.T") - --- (eg) "fooble" --> "testdir/fooble" -def testdirify ( $basename ) -{ - return $testdir ++ "/" ++ $basename -} - ---------------------------------------------------------------- ---- COMPILATION --- ---------------------------------------------------------------- - --- Clean up prior to the test, so that we can't spuriously conclude --- that it passed on the basis of old run outputs. -def pretest_cleanup() -{ - rm_nofail(qualify("comp.stderr")) - rm_nofail(qualify("run.stderr")) - rm_nofail(qualify("run.stdout")) - -- simple_build_Main zaps the following: - -- objects - -- executable - -- not interested in the return code -} - --- Guess flags suitable for the compiler. -def guess_compiler_flags() -{ - if $tool contains "ghc" - then - return "-no-recomp --make -dcore-lint" ++ - " -i" ++ $testdir - else - --- Problem here is that nhc and hbc don't understand --make, --- and we rely on it. --- if $tool contains "nhc" --- then --- return "-an-nhc-specific-flag" --- else --- if $tool contains "hbc" --- then --- return "" --- else - - framefail ("Can't guess what kind of Haskell compiler " ++ - "you're testing: $tool = " ++ $tool) - --- fi --- fi - fi -} - --- Build Main, and return the compiler result code. Compilation --- output goes into testname.comp.stderr. Source is assumed to --- be in Main.hs or Main.lhs, and modules reachable from it. - -def simple_build_prog_WRK ( $_main, $_extra_args ) -{ - $flags = guess_compiler_flags() - $errname = qualify("comp.stderr") - $exename = qualify("") -- ie, the exe name == the test name - - rm_or_fail($errname) - rm_or_fail($exename) - rm_nofail(testdirify("*.o")) - $cmd = "\"" ++ $tool ++ "\" " ++ $flags ++ " " ++ $_extra_args ++ " " - ++ (if defined $extra_hc_flags - then $extra_hc_flags - else "") - ++ " -o " ++ $exename ++ " " - ++ $_main ++ " >" ++ $errname ++ " 2>&1" - $res = run $cmd - return $res -} - - ---------------------------------------------------------------- ---- CONDUCTING A COMPLETE TEST --- ---------------------------------------------------------------- - --- Compile and run (should_run) style test - -def multimod-compile( $mod, $extra_compile_args ) -{ - pretest_cleanup() - - $main = if $mod == "" then "Main" else $mod - $res = simple_build_prog_WRK( $main, $extra_compile_args ) - - if $res /= "0" then - say_fail_because_compiler_barfd ( $res ) - return False - else - return True - fi -} - -def multimod-run-test ( $extra_run_args, - $allowable_nonzero_exit_code ) -{ - $exit_code = - if $allowable_nonzero_exit_code /= "" then - $allowable_nonzero_exit_code - else "0" - - return simple_run_pgm( $extra_run_args, $exit_code ) -} - - ---------------------------------------------------------------- ---- TOP-LEVEL FNS --- ---------------------------------------------------------------- - --------------------------------------------------------------- --- top-level --- Compile and run (should_run) style test - -def mtc ( $mod, $extra_compile_args ) -{ - $test_passed = multimod-compile( $mod, $extra_compile_args ) - - if ($expect == "pass") then - expect pass - else - expect fail - fi - pass when $test_passed - fail when otherwise -} - -def mtr ( $extra_compile_args, - $extra_run_args, - $allowable_nonzero_exit_code ) -{ - $test_passed - = multimod-compile( "Main", $extra_compile_args ) - && multimod-run-test( $extra_run_args, - $allowable_nonzero_exit_code ) - - if ($expect == "pass") then - expect pass - else - expect fail - fi - pass when $test_passed - fail when otherwise -} - - ------------------------------------------------------------------------ ---- end multimod-test.T --- ------------------------------------------------------------------------ diff --git a/testsuite/config/simple-idioms/should-compile.T b/testsuite/config/simple-idioms/should-compile.T deleted file mode 100644 index 7e0bbb564c..0000000000 --- a/testsuite/config/simple-idioms/should-compile.T +++ /dev/null @@ -1,9 +0,0 @@ - -include ($confdir ++ "/../singlefile-macros.T") -expect pass - -pretest_cleanup() -$res = simple_compile_Main() -pass when contents("comp.stdout") == "" - -fail when otherwise diff --git a/testsuite/config/simple-idioms/should-not-compile.T b/testsuite/config/simple-idioms/should-not-compile.T deleted file mode 100644 index aa6a942bbd..0000000000 --- a/testsuite/config/simple-idioms/should-not-compile.T +++ /dev/null @@ -1,14 +0,0 @@ - -include ($confdir ++ "/../singlefile-macros.T") -expect pass - -pretest_cleanup() -$res = simple_compile_Main() - -pass when - $tool contains "ghc" - && contents("comp.stdout") contains "Could not deduce" - --- put a pass clause here for NHC - -fail when otherwise diff --git a/testsuite/config/simple-idioms/should-run.T b/testsuite/config/simple-idioms/should-run.T deleted file mode 100644 index 12794b2d70..0000000000 --- a/testsuite/config/simple-idioms/should-run.T +++ /dev/null @@ -1,12 +0,0 @@ - -include ($confdir ++ "/../singlefile-macros.T") -expect pass - -pretest_cleanup() - -simple_build_Main() -$res = simple_run_main_no_stdin() - -pass when contents("run.stdout") == "True\n" - -fail when otherwise
\ No newline at end of file diff --git a/testsuite/config/std-macros.T b/testsuite/config/std-macros.T deleted file mode 100644 index e8a8e727b7..0000000000 --- a/testsuite/config/std-macros.T +++ /dev/null @@ -1,263 +0,0 @@ -$diff = "diff -C 2" -$rm = "rm -f" -$cp = "cp" - --- ----------------------------------------------------------------------------- --- generic useful stuff - --- Gotta do some pretty basic stuff :) -def not ( $_bool ) -{ - if $_bool == "True" then return False - else if $_bool == "False" then return True - else framefail ("not(): invalid input: " ++ $_bool ) - fi fi -} - -def runCmd( $cmd ) -{ - if defined $verbose then - print $cmd - fi - $res = run $cmd - return $res -} - -def runCmdDontFail( $cmd ) -{ - $res = runCmd($cmd) - if $res /= "0" - then framefail ("unexpected cmd failure: " ++ $cmd) - fi -} - --- Delete a file and abort if that doesn't work. -def rm_or_fail ( $_files ) -{ - $cmd = $rm ++ " " ++ $_files - $res = runCmd($cmd) - if $res /= "0" then framefail ("rm_or_fail: can't rm: " ++ $_files) fi -} - --- Delete a file but keep going antidisirregardless of the outcome. -def rm_nofail ( $_files ) -{ - $cmd = $rm ++ " " ++ $_files - $res = runCmd($cmd) -} - ------------------------------------------------------------------------------ - --- (eg) "run.stdout" --> "testdir/testname.run.stdout" -def qualify ( $_filename_frag ) -{ - if $_filename_frag == "" - then - return $testdir ++ "/" ++ $testname - else - return $testdir ++ "/" ++ $testname ++ "." ++ $_filename_frag - fi -} - --- "foo" -> qualify("foo-platform") if it exists, or qualify("foo") otherwise -def platform_qualify ( $_filename_frag ) -{ - $name = qualify($_filename_frag) - if exists($name ++ "-" ++ $platform) - then return $name ++ "-" ++ $platform - else return $name - fi -} - -def testnameWith ( $_filename_frag ) -{ - if $_filename_frag == "" - then - return $testname - else - return $testname ++ "." ++ $_filename_frag - fi -} - --- Clean up prior to the test, so that we can't spuriously conclude --- that it passed on the basis of old run outputs. -def pretest_cleanup() -{ - rm_nofail(qualify("comp.stderr")) - rm_nofail(qualify("run.stderr")) - rm_nofail(qualify("run.stdout")) - -- simple_build_Main zaps the following: - -- rm_nofail(qualify("o")) - -- rm_nofail(qualify("")) - -- not interested in the return code -} - --- Pipe an error message through normalise_errmsg. -def normalise_errmsg ( $errmsg ) -{ - $unpathify = $confdir ++ "/../../utils/normalise_errmsg/normalise_errmsg" - $normd = $errmsg | $unpathify - return $normd -} - --- returns True if both files are identical. -def same ( $_file1, $_file2 ) -{ - if defined $verbose - then print "vanilla-test: comparing " ++ $_file1 - ++ " and " ++ $_file2 - fi - $cts1 = contents($_file1) - $cts2 = contents($_file2) - $same = $cts1 == $cts2 - if not($same) then - say_fail_because_noteq($_file1, $_file2) - fi - return $same -} - --- returns True if both files are identical when normalised (unpathified) -def same_normalised ( $_file1, $_file2 ) -{ - if defined $verbose - then print "vanilla-test: comparing " ++ $_file1 - ++ " and " ++ $_file2 - fi - $cts1 = normalise_errmsg(contents($_file1)) - $cts2 = normalise_errmsg(contents($_file2)) - $same = $cts1 == $cts2 - if not($same) then - say_fail_because_noteq($_file1, $_file2) - fi - return $same -} - --- Give hints as to why a test is failing. -def say_fail_because_noteq ( $filename1, $filename2 ) -{ - print "--- FAIL because the following files differ:" - print "--- " ++ $filename1 - print "--- " ++ $filename2 - if defined $accept then - print "--- (accepting new output)" - runCmdDontFail($cp ++ " " ++ $filename2 ++ " " ++ $filename1) - fi - if defined $verbose then - $ignore = runCmd($diff ++ " " ++ $filename1 ++ " " ++ $filename2) - fi -} - -def say_fail_because_nonempty ( $filename1 ) -{ - print "--- FAIL because the following file is non-empty:" - print "--- " ++ $filename1 - print "--- contents:" - print (contents $filename1) - print ("--- end of " ++ $filename1) -} - -def say_fail_because_exit_code_wrong ( $prg, $exit_code, $should_be ) -{ - print "--- FAIL because $prog had the wrong exit code (" ++ - $exit_code ++ ", should be " ++ $should_be ++ ")" -} - -def say_fail_because_compiler_barfd ( $res ) -{ - print "--- FAIL because the compiler returned non-zero exit code = " ++ $res - $comp_stderr = qualify("comp.stderr") - if exists($comp_stderr) - then print "--- Error messages:" - print contents(qualify("comp.stderr")) - fi -} - ---------------------------------------------------------------- ---- RUNNING, AND ASSESSING RUN RESULTS --- ---------------------------------------------------------------- - --- Run testname. If testname.stdin exists, route input from that, else --- from /dev/null. Route output to testname.run.stdout and --- testname.run.stderr. Returns the exit code of the run. - -def simple_run_pgm( $extra_args, $exit_code ) -{ - -- figure out what to use for stdin - $devnull = "/dev/null" - if $stdin /= "" then - $use_stdin = $stdin - else - $stdin = testnameWith("stdin") - $stdin_path = $testdir ++ "/" ++ $stdin - $use_stdin = if exists($stdin_path) then $stdin else $devnull - fi - - $run_stdout = testnameWith("run.stdout") - $run_stderr = testnameWith("run.stderr") - - rm_or_fail($run_stdout) - rm_or_fail($run_stderr) - $cmd = "cd " ++ $testdir ++ " && " - ++ "./" ++ $testname ++ " " ++ $extra_args - ++ " < " ++ $use_stdin - ++ " > " ++ $run_stdout - ++ " 2> " ++ $run_stderr - - -- run the command - $res = runCmd($cmd) - - -- check the exit code - if $res /= $exit_code then - say_fail_because_exit_code_wrong($testname, $res, $exit_code) - return False - fi - - -- check the stdout and stderr outputs - $test_passed = check_stdout_ok() && check_stderr_ok() - - return $test_passed -} - --- Check that the run.stdout file matches either the .stdout-TARGETPLATFORM --- (if it exists) or the .stdout otherwise. -def check_stdout_ok() -{ - $r_stdout = qualify("run.stdout") - $s_stdout = platform_qualify("stdout") - - if not ( exists($s_stdout) ) - then if ((contents $r_stdout) == "") - then return True - else say_fail_because_nonempty($r_stdout) - return False - fi - fi - - if $normalise_output - then return same_normalised($s_stdout, $r_stdout) - else return same($s_stdout, $r_stdout) - fi -} - --- Check that the run.stderr matches either the .stderr-TARGETPLATFORM --- (if it exists) or the .stderr otherwise. Normalise the stderr if --- $normalise_errmsg is set -def check_stderr_ok() -{ - $r_stderr = qualify("run.stderr") - $s_stderr = platform_qualify("stderr") - - if not ( exists($s_stderr) ) - then if ((contents $r_stderr) == "") - then return True - else say_fail_because_nonempty($r_stderr) - return False - fi - fi - --- if $normalise_errmsg --- then - return same_normalised($s_stderr, $r_stderr) --- else return same($s_stderr, $r_stderr) --- fi -} diff --git a/testsuite/config/vanilla-test.T b/testsuite/config/vanilla-test.T deleted file mode 100644 index e8db26be16..0000000000 --- a/testsuite/config/vanilla-test.T +++ /dev/null @@ -1,246 +0,0 @@ ------------------------------------------------------------------------ ---- Stuff to do with simple single-source-file tests. We assume --- ---- that the name of the test is to be used as the basename --- ---- for everything. --- ------------------------------------------------------------------------ - --- global variables: -$stdin = "" -$expect = "pass" -$normalise_errmsg = False -$normalise_output = False - ---------------------------------------------------------------- --- Define the following things on the command line: --- --- $platform TARGETPLATFORM from config.mk --- $verbose print command lines --- $accept accept any changed output - ---------------------------------------------------------------- ---- UTILITY FNs --- ---------------------------------------------------------------- - -include ($confdir ++ "/" ++ $conffilename) -include ($confdir ++ "/../std-macros.T") - ---------------------------------------------------------------- ---- COMPILATION --- ---------------------------------------------------------------- - --- Guess flags suitable for the compiler. -def guess_compiler_flags() -{ - if $tool contains "ghc" - then - return "-no-recomp -dcore-lint" - else - if $tool contains "nhc" - then - return "-an-nhc-specific-flag" - else - if $tool contains "hbc" - then - return "" - else - framefail ("Can't guess what kind of Haskell compiler " ++ - "you're testing: $tool = " ++ $tool) - fi - fi - fi -} - --- Build Main, and return the compiler result code. Compilation --- output goes into testname.comp.stderr. - -def simple_build_Main_WRK ( $_extra_args, $compile_only ) -{ - $flags = guess_compiler_flags() - $errname = testnameWith("comp.stderr") - $srcname = testnameWith("hs") - rm_or_fail($errname) - rm_or_fail($testname) - - $cmd = "cd " ++ $testdir ++ " && \"" ++ - $tool ++ "\" " - ++ (if defined $compile_to_hc && $compile_to_hc - then "-C " - else if $compile_only - then "-c " - else "-o " ++ $testname ++ " ") - ++ $srcname ++ " " - ++ $flags ++ " " ++ $_extra_args ++ " " - ++ (if defined $extra_hc_flags - then $extra_hc_flags ++ " " - else "") - ++ ">" ++ $errname ++ " 2>&1" - $res = runCmd($cmd) - return $res -} - - ---------------------------------------------------------------- ---- CONDUCTING A COMPLETE TEST --- ---------------------------------------------------------------- - --- Compile and run (should_run) style test - -def vanilla-run-test-actions ( $extra_compile_args, - $extra_run_args, - $allowable_nonzero_exit_code ) -{ - pretest_cleanup() - - $res = simple_build_Main_WRK( $extra_compile_args, False ) - -- If the compiler barf'd, fail. - if $res /= "0" - then say_fail_because_compiler_barfd ( $res ) - return False - fi - - $exit_code = - if $allowable_nonzero_exit_code /= "" then - $allowable_nonzero_exit_code - else "0" - - return simple_run_pgm( $extra_run_args, $exit_code ) -} - - --- Compile only (should_compile) style test. Deemed to have --- succeeded if the compiler returned zero AND (testname.comp.stderr --- matches testname.stderr, if it exists, or is empty). - -def vanilla-compok-test-actions ( $extra_compile_args ) -{ - pretest_cleanup() - $res = simple_build_Main_WRK ( $extra_compile_args, True ) - - -- If the compiler barf'd, fail. - if $res /= "0" - then say_fail_because_compiler_barfd ( $res ) - return False - fi - - -- If there's an expected .stderr, presumably containing - -- warnings, ensure the compiler produced the same. - $actual_stderr = qualify("comp.stderr") - $expected_stderr = platform_qualify("stderr") - if exists($expected_stderr) - then $stderr_a = normalise_errmsg(contents($actual_stderr)) - $stderr_e = normalise_errmsg(contents($expected_stderr)) - if $stderr_e /= $stderr_a - then say_fail_because_noteq($expected_stderr, $actual_stderr) - return False - else return True - fi - fi - - -- There's no expected stderr, so just insist that the compiler - -- produced nothing on stderr. - if (contents $actual_stderr) /= "" - then say_fail_because_nonempty($actual_stderr) - return False - fi - - -- Must have succeeded. - return True -} - - --- Compile with expected fail (should_fail) style test. Deemed to have --- succeeded if the compiler returned nonzero AND testname.comp.stderr --- equals testname.stderr. - -def vanilla-compfail-test-actions ( $extra_compile_args ) -{ - pretest_cleanup() - $expected_stderr = platform_qualify("stderr") - - -- Sanity check - if not(exists($expected_stderr)) - then framefail "should_fail: expected .stderr is missing" - fi - - $res = simple_build_Main_WRK ( $extra_compile_args, True ) - -- print "---> " ++ $res - $actual_stderr = qualify("comp.stderr") - $stderr_a = normalise_errmsg(contents($actual_stderr)) - $stderr_e = normalise_errmsg(contents($expected_stderr)) - - if $stderr_e /= $stderr_a - then say_fail_because_noteq($expected_stderr, $actual_stderr) - return False - fi - - if ($res /= "0") && $stderr_e == $stderr_a - then - return True - else - return False - fi -} - - ---------------------------------------------------------------- ---- TOP-LEVEL FNS --- ---------------------------------------------------------------- - --------------------------------------------------------------- --- top-level --- Compile and run (should_run) style test - -def vtr ( $extra_compile_args, - $extra_run_args, - $allowable_nonzero_exit_code ) -{ - $test_passed - = vanilla-run-test-actions ( $extra_compile_args, - $extra_run_args, - $allowable_nonzero_exit_code ) - if ($expect == "pass") then - expect pass - else - expect fail - fi - pass when $test_passed - fail when otherwise -} - - --- Compile only (should_compile) style test - -def vtc ( $extra_compile_args ) -{ - $test_passed = vanilla-compok-test-actions ( $extra_compile_args ) - - if ($expect == "pass") then - expect pass - else - expect fail - fi - pass when $test_passed - fail when otherwise -} - - --- Compile only, and expect failure (should_fail) style test - -def vtcf ( $extra_compile_args ) -{ - $test_passed = vanilla-compfail-test-actions ( $extra_compile_args ) - - if ($expect == "pass") then - expect pass - else - expect fail - fi - pass when $test_passed - fail when otherwise -} - - - ------------------------------------------------------------------------ ---- end vanilla-test.T --- ------------------------------------------------------------------------ diff --git a/testsuite/config/york/pc173.T b/testsuite/config/york/pc173.T deleted file mode 100644 index 01614a3bac..0000000000 --- a/testsuite/config/york/pc173.T +++ /dev/null @@ -1,2 +0,0 @@ - -$platform = "i386-unknown-linux" diff --git a/testsuite/docs/docs.txt b/testsuite/docs/docs.txt index 280f74324c..3f7d710ca7 100644 --- a/testsuite/docs/docs.txt +++ b/testsuite/docs/docs.txt @@ -1,4 +1,3 @@ - ----------------------------- SYNTAX ------------------------------ TFILE ::= TOPDEF * @@ -22,15 +21,17 @@ STMT ::= VAR = EXPR | expect RESULT | framefail EXPR +RESULT ::= pass | fail | unknown + VAR ::= $identifier MNAME ::= identifier STRING ::= "a string" EXPR ::= EXPR9 || ... || EXPR9 -EXPR8 ::= EXPR7 && ... && EXPR7 -EXPR7 ::= EXPR1 OP EXPR1 - | EXPR1 | EXPR7 - | EXPR1 +EXPR9 ::= EXPR8 && ... && EXPR8 +EXPR8 ::= EXPR0 OP EXPR0 + | EXPR0 "|" EXPR8 + | EXPR0 OP ::= == or /= or contains or lacks or ++ @@ -43,9 +44,9 @@ EXPR0 ::= VAR | if EXPR then EXPR else EXPR fi | otherwise | defined VAR - | contents EXPR - | exists EXPR - | framefail EXPR + | contents EXPR0 + | exists EXPR0 + | framefail EXPR0 | ( EXPR ) diff --git a/testsuite/driver/CmdLexer.hs b/testsuite/driver/CmdLexer.hs deleted file mode 100644 index 8ee843d9be..0000000000 --- a/testsuite/driver/CmdLexer.hs +++ /dev/null @@ -1,168 +0,0 @@ - -module CmdLexer ( Lexeme(..), Token(..), tokenise, - getLex, HasLineNo(..), HasTokNo(..), isVarChar ) -where - - -import Char ( isAlpha, isDigit, isSpace ) - - ---------------------------------------------------------------------- --- nano-lexer -data Lexeme - = LString String -- "string" - | LText String -- some_lump_of_text - | LVar String -- $varname - | LBool Bool -- True or False - | L_Test -- test - | L_Exists -- exists - | L_When -- when - | L_Expect -- expect - | L_And -- && - | L_Or -- || - | L_Append -- ++ - | L_Framefail -- framefail - | L_Pass -- pass - | L_Fail -- fail - | L_Unknown -- unknown - | L_Skip -- skip - | L_Contains -- contains - | L_Lacks -- lacks - | L_Return -- return - | L_Eq -- == - | L_NEq -- /= - | L_Assign -- = - | L_Otherwise -- otherwise - | L_Open -- ( - | L_Close -- ) - | L_LBrace -- { - | L_RBrace -- } - | L_Comma -- , - | L_Bar -- | - | L_Include -- include - | L_If -- if - | L_Then -- then - | L_Else -- else - | L_Fi -- fi - | L_Def -- def - | L_Print -- print - | L_Run -- run - | L_Defined -- defined - | L_Contents -- contents - deriving (Eq, Show) - -data Token - = Tok Int Int Lexeme -- token #, line #, Lex - deriving Show - -getLex (Tok tno lno lexeme) = lexeme - -class HasLineNo a where - getLineNo :: a -> Int -instance HasLineNo Token where - getLineNo (Tok tno lno lex) = lno -instance HasLineNo a => HasLineNo [a] where - getLineNo [] = 999999 -- EOF presumably - getLineNo (t:ts) = getLineNo t - -class HasTokNo a where - getTokNo :: a -> Int -instance HasTokNo Token where - getTokNo (Tok tno lno lex) = tno -instance HasTokNo a => HasTokNo [a] where - getTokNo [] = 999999 -- EOF presumably - getTokNo (t:ts) = getTokNo t - -bomb = 0 :: Int - -tokenise :: Int -> String -> [Token] -tokenise n toks - = let un_numbered = tokenise_wrk n toks - f tok_no (Tok _ lno lex) = Tok tok_no lno lex - in zipWith f [1..] un_numbered - --- do the biz, but don't insert token #s -tokenise_wrk :: Int -> String -> [Token] -tokenise_wrk n [] = [] - -tokenise_wrk n ('&':'&':cs) = (Tok bomb n L_And) : tokenise_wrk n cs -tokenise_wrk n ('|':'|':cs) = (Tok bomb n L_Or) : tokenise_wrk n cs -tokenise_wrk n ('+':'+':cs) = (Tok bomb n L_Append) : tokenise_wrk n cs -tokenise_wrk n ('=':'=':cs) = (Tok bomb n L_Eq) : tokenise_wrk n cs -tokenise_wrk n ('/':'=':cs) = (Tok bomb n L_NEq) : tokenise_wrk n cs - -tokenise_wrk n (c:cs) - | take 2 (c:cs) == "--" - = tokenise_wrk n (dropWhile (/= '\n') (c:cs)) - | c == '\n' - = tokenise_wrk (n+1) cs - | isSpace c - = tokenise_wrk n cs - | c == '$' - = let (vs, rest) = takeDrop isVarChar cs - in (Tok bomb n (LVar vs)) : tokenise_wrk n rest - | c == '"' -- " - = let str = takeLitChars cs - rest = drop (length str) cs - in (Tok bomb n (LString (escIfy str))) : tokenise_wrk n (drop 1 rest) - | c == '(' - = (Tok bomb n L_Open) : tokenise_wrk n cs - | c == ')' - = (Tok bomb n L_Close) : tokenise_wrk n cs - | c == '{' - = (Tok bomb n L_LBrace) : tokenise_wrk n cs - | c == '}' - = (Tok bomb n L_RBrace) : tokenise_wrk n cs - | c == ',' - = (Tok bomb n L_Comma) : tokenise_wrk n cs - | c == '|' - = (Tok bomb n L_Bar) : tokenise_wrk n cs - | c == '=' - = (Tok bomb n L_Assign) : tokenise_wrk n cs - | otherwise - = let (str,rest) = takeDrop (`notElem` "(), \n\t") (c:cs) - kw x = (Tok bomb n x) : tokenise_wrk n rest - in case str of - "framefail" -> kw L_Framefail - "defined" -> kw L_Defined - "contents" -> kw L_Contents - "def" -> kw L_Def - "run" -> kw L_Run - "if" -> kw L_If - "then" -> kw L_Then - "else" -> kw L_Else - "fi" -> kw L_Fi - "print" -> kw L_Print - "test" -> kw L_Test - "exists" -> kw L_Exists - "when" -> kw L_When - "expect" -> kw L_Expect - "pass" -> kw L_Pass - "fail" -> kw L_Fail - "unknown" -> kw L_Unknown - "skip" -> kw L_Skip - "contains" -> kw L_Contains - "lacks" -> kw L_Lacks - "return" -> kw L_Return - "otherwise" -> kw L_Otherwise - "include" -> kw L_Include - "True" -> kw (LBool True) - "False" -> kw (LBool False) - other -> kw (LText other) - -takeDrop :: (Char -> Bool) -> String -> (String, String) -takeDrop p cs = let taken = takeWhile p cs - in (taken, drop (length taken) cs) - -isVarChar c = isAlpha c || isDigit c || c `elem` "_-" - -escIfy [] = [] -escIfy ('\\':'\\':cs) = '\\':escIfy cs -escIfy ('\\':'n':cs) = '\n':escIfy cs -escIfy ('\\':'"':cs) = '"':escIfy cs -escIfy (c:cs) = c : escIfy cs - -takeLitChars [] = [] -takeLitChars ('\\':'"':cs) = '\\':'"':takeLitChars cs -takeLitChars ('"':cs) = [] -- " -takeLitChars (c:cs) = c : takeLitChars cs diff --git a/testsuite/driver/CmdSemantics.hs b/testsuite/driver/CmdSemantics.hs deleted file mode 100644 index 009b518006..0000000000 --- a/testsuite/driver/CmdSemantics.hs +++ /dev/null @@ -1,659 +0,0 @@ - -module CmdSemantics ( parseOneTFile, processParsedTFile ) -where - -import CmdSyntax -import CmdParser ( parseScript ) -import TopSort ( topSort ) -import Maybe ( isJust, fromJust ) -import Monad ( when ) -import Directory ( doesFileExist, removeFile ) -import System ( ExitCode(..) ) -import List ( nub, (\\) ) -import Char ( ord ) -import IO - -#ifdef __NHC__ -import NonStdTrace(trace) -#else -import IOExts(trace) -#endif ---------------------------------------------------------------------- --- Hook into Meurig Sage's regexp library - -import Regexp ( MatcherFlag(..), searchS, legalRegexp, matchedAny ) - -myMatchRegexp :: String -> String -> Maybe Bool -myMatchRegexp rx str - -- | trace (show (rx, str)) True - = let result = searchS rx [Multi_Line] str - in if not (legalRegexp result) - then Nothing - else Just (matchedAny result) - ---------------------------------------------------------------------- --- A monad to carry around the EvalEnv. - -type IOE a = EvalEnv -> IO (EvalEnv, a) - -thenE :: IOE a -> (a -> IOE b) -> IOE b -thenE x y p - = do (p2, xv) <- x p - y xv p2 - -thenE_ :: IOE a -> IOE b -> IOE b -thenE_ x y p - = do (p2, xv) <- x p - y p2 - -returnE :: a -> IOE a -returnE x p = return (p, x) - -getEvalEnv :: IOE EvalEnv -getEvalEnv p = return (p, p) - -setEvalEnv :: EvalEnv -> IOE () -setEvalEnv pnew p = return (pnew, ()) - - -getLocalEnv :: IOE [(Var,String)] -getLocalEnv p = return (p, locals p) - -setLocalEnv :: [(Var,String)] -> IOE () -setLocalEnv l_env p - = return (p{locals=l_env}, ()) - - ---------------------------------------------------------------------- --- Enhanced version of IOE, which propagates failure values immediately. - -data EvalResult a - = FrameFail String -- failure; act like "throw" - | Results (Result, Result) -- final result (exp,act); ditto - | Value a -- value; keep going - - -type IOEV a = IOE (EvalResult a) - -returnEV :: a -> IOE (EvalResult a) -returnEV x p = return (p, Value x) - -failEV :: String -> IOE (EvalResult a) -failEV str p = return (p, FrameFail ("framework failure: " ++ str)) - -resultsEV :: (Result, Result) -> IOE (EvalResult a) -resultsEV (r1,r2) p = return (p, Results (r1,r2)) - -failagainEV :: String -> IOE (EvalResult a) -failagainEV str p = return (p, FrameFail str) - -thenEV :: IOEV a -> (a -> IOEV b) -> IOEV b -thenEV x y - = x `thenE` \ res_x -> - case res_x of - Value x_ok -> y x_ok - FrameFail s -> failagainEV s - Results rs -> resultsEV rs - -thenEV_ :: IOEV a -> IOEV b -> IOEV b -thenEV_ x y - = x `thenE` \ res_x -> - case res_x of - Value x_ok -> y - FrameFail s -> failagainEV s - Results rs -> resultsEV rs - -mapEV :: (a -> IOEV b) -> [a] -> IOEV [b] -mapEV f [] = returnEV [] -mapEV f (x:xs) = f x `thenEV` \ x_done -> - mapEV f xs `thenEV` \ xs_done -> - returnEV (x_done:xs_done) - -whenEV :: Bool -> IOEV () -> IOEV () -whenEV b act - = if b then act else returnEV () - -ioToEV :: IO a -> IOEV a -ioToEV io p - = do r <- io - return (p, Value r) - -bind x f = f x - - ---------------------------------------------------------------------- --- environment management stuff - -data EvalEnv - = EvalEnv { - -- THESE NEVER CHANGE - globals :: [(Var, String)], -- global var binds - mdefs :: [(MacroName, MacroDef)], -- macro defs - -- WRITABLE, DISCARDED AT PROCEDURE EXIT - locals :: [(Var, String)], -- local var binds - -- THREADED - results :: (Maybe Result, Maybe Result), - -- expected and actual results - counter :: Int -- for generating unique file names - } - deriving Show - --- Record in the environment an expected or actual result. --- Complain about duplicate assignments. --- If the assignment now means that both an expected and actual --- result is available, terminate computation and return these --- results to the top level of the driver. -setResult :: Bool -> Result -> IOEV () -setResult is_actual res - = getEvalEnv `thenE` \ p -> - results p `bind` \ (r_exp, r_act) -> - (is_actual && isJust r_act) `bind` \ dup_act -> - ((not is_actual) && isJust r_exp) `bind` \ dup_exp -> - if dup_act - then failEV "duplicate assignment of actual outcome" - else - if dup_exp - then failEV "duplicate assignment of expected outcome" - else - (if is_actual then (r_exp, Just res) - else (Just res, r_act)) `bind` \ (new_exp, new_act) -> - if isJust new_exp && isJust new_act - then resultsEV (fromJust new_exp, fromJust new_act) - else - setEvalEnv (p{results = (new_exp, new_act)}) - `thenE_` - returnEV () - -addLocalVarBind :: Var -> String -> IOEV () -addLocalVarBind v s - = getEvalEnv `thenE` \ p -> - (if v `elem` map fst (globals p) - then setEvalEnv (p{globals = (v,s):(globals p)}) - else setEvalEnv (p{locals = (v,s):(locals p)}) - ) `thenE_` - returnEV () - -getCounterE :: IOE Int -getCounterE - = getEvalEnv `thenE` \ p -> - counter p `bind` \ n -> - setEvalEnv p{counter=n+1} `thenE_` - returnE (n+1) - -lookupVar_maybe :: Var -> IOE (Maybe String) -lookupVar_maybe v - = getEvalEnv `thenE` \ p -> - returnE (lookup v (locals p ++ globals p)) - -lookupVar :: Var -> IOEV String -lookupVar v - = lookupVar_maybe v `thenE` \ maybe_v -> - case maybe_v of - Just xx -> returnEV xx - Nothing -> failEV (missingVar v) - -lookupMacro :: MacroName -> IOEV MacroDef -lookupMacro mnm - = getEvalEnv `thenE` \ p -> - case lookup mnm (mdefs p) of - Just mdef -> returnEV mdef - Nothing -> failEV (missingMacro mnm) - -initialEnv global_env macro_env - = EvalEnv{ globals=global_env, mdefs=macro_env, - locals=[], results=(Nothing,Nothing), counter=0 } - - ---------------------------------------------------------------------- --- Run all the tests defined in a parsed .T file. - -processParsedTFile :: Maybe [String] -- which tests to run - -> FilePath - -> [(Var,String)] - -> [TopDef] - -> IO [TestResult] - -processParsedTFile test_filter tfilepath initial_global_env topdefs - = do { let raw_tests = filter isTTest topdefs - ; when (null raw_tests) - (officialMsg ("=== WARNING: no tests defined in: " ++ tfilepath)) - ; let tests = getApplicableTests test_filter raw_tests - ; if null tests - then return [] - else - - do { officialMsg ("=== running tests in: " ++ tfilepath ++ " ===") - - ; let macs = filter isTMacroDef topdefs - ; let incls = filter isTInclude topdefs -- should be [] - ; let topbinds = [(var,expr) | TAssign var expr <- topdefs] - ; let macro_env = map (\(TMacroDef mnm mrhs) -> (mnm,mrhs)) macs - ; ei_global_env <- evalTopBinds initial_global_env topbinds - ; case ei_global_env of - Left barfage - -> do officialMsg barfage - return [TestFFail (TestID tfilepath tname) - | TTest tname trhs <- tests] - Right global_env - -> do all_done <- mapM (doOne global_env macro_env) tests - return all_done - }} - where - doOne global_env macro_env (TTest tname stmts) - = do putStr "\n" - let test_id = TestID tfilepath tname - officialMsg ("=== " ++ ppTestID test_id ++ " ===") - r <- doOneTest (("testname", tname):global_env) - macro_env stmts - case r of - Left barfage - -> do officialMsg barfage - return (TestFFail test_id) - Right (exp,act) - -> do officialMsg ("=== outcome for " ++ tname - ++ ": exp:" ++ show exp - ++ ", act:" ++ show act ++ " ===") - return (TestRanOK test_id exp act) - - -getApplicableTests :: Maybe [String] -> [TopDef] -> [TopDef] - -getApplicableTests Nothing{-no filter-} topdefs - = filter isTTest topdefs -getApplicableTests (Just these) topdefs - = [ TTest tname stmts | TTest tname stmts <- topdefs, tname `elem` these] - - -evalTopBinds :: [(Var, String)] -- pre-set global bindings - -> [(Var, Expr)] -- top-level binds got from script - -> IO (Either String{-complaint of some kind-} - [(Var, String)]{-augmented global binds-}) - -evalTopBinds globals binds - = let f_map = [(v, nub (freeVars e)) | (v,e) <- binds] - in - case topSort f_map of - Left circular_vars - -> return (Left ("circular dependencies for top-level vars: " - ++ unwords (map ('$':) circular_vars))) - Right eval_order - -> let in_order = [ (v, fromJust (lookup v binds)) | v <- eval_order ] - in - loop globals in_order - where - loop acc [] - = return (Right acc) - loop acc ((v,e):rest) - = do let initial_env = initialEnv acc [] - (final_env, res) <- evalExpr e initial_env - case res of - Value r -> loop ((v,r):acc) rest - Results ress -> panic "evalTopBinds" - FrameFail msg -> return (Left msg) - - ---------------------------------------------------------------------- --- Parsing a complete .T file and the transitive closure of its includes. - -parseOneTFile, - parseOneTFile_wrk :: [(Var,String)] -- global var env - -> FilePath -- the T file to parse - -> IO (Either String{-complaint of some sort-} - (FilePath, [TopDef])) - -parseOneTFile global_env tfile - = do ei_parsed <- parseOneTFile_wrk global_env tfile - case ei_parsed of - Left barfage - -> return (Left barfage) - Right name_and_defs - -> do let testnames - = [testnm | TTest testnm stmts <- snd name_and_defs] - let dups = testnames \\ (nub testnames) - if null dups - then return (Right name_and_defs) - else return (Left (tfile ++ ": duplicate tests: " - ++ unwords dups)) - - -parseOneTFile_wrk global_env tfile - = do { have_f <- doesFileExist tfile - ; if not have_f - then return (Left ("can't open script file `" ++ tfile ++ "'")) - else - do { f_cts <- readFile tfile - ; let p_result = parseScript tfile f_cts - ; case p_result of { - Left errmsg -> return (Left errmsg) ; - Right topdefs -> - do { -- filter out the includes and recurse on them - let here_topdefs = filter (not.isTInclude) topdefs - ; let here_includes = filter isTInclude topdefs - ; incl_paths - <- mapM ( \i -> case i of - TInclude expr -> evalIncludeExpr tfile - global_env expr - ) here_includes - ; let bad_incl_exprs = filter isLeft incl_paths - ; if not (null bad_incl_exprs) - then case head bad_incl_exprs of - Left moanage -> return (Left moanage) - else - do { let names_to_include = map unRight incl_paths - ; incl_topdefss <- mapM (parseOneTFile_wrk global_env) names_to_include - ; let failed_includes = filter isLeft incl_topdefss - ; if not (null failed_includes) - then return (head failed_includes) - else - do { let more_topdefs = concatMap (snd.unRight) incl_topdefss - ; return (Right (tfile, here_topdefs ++ more_topdefs)) - }}}}}} - - --- Simplistically evaluate an expression, using just the global --- value env. Used for evaluating the args of include statements. -evalIncludeExpr :: FilePath -- only used for making err msgs - -> [(Var,String)] - -> Expr - -> IO (Either String{-errmsg-} String{-result-}) -evalIncludeExpr tfilepath global_env expr - = do let initial_env = initialEnv global_env [] - (final_env, res) <- evalExpr expr initial_env - case res of - Value v -> return (Right v) - Results ress -> panic "evalIncludeExpr" - FrameFail msg - -> return (Left (tfilepath ++ ": invalid include expr:\n " - ++ msg)) - - - ---------------------------------------------------------------------- --- Running a single test. - --- Run the whole show for a given test, stopping when: --- * A framework failure occurs --- * Both expected and actual results are determined --- * We run out of statements and neither of the above two --- apply. This also counts as a framework failure. - -doOneTest :: [(Var,String)] -- global var env - -> [(MacroName, MacroDef)] -- macro env - -> [Stmt] -- stmts for this test - -> IO (Either String{-framefail-} - (Result, Result){-outcomes-}) - -doOneTest global_env code_env stmts - = do let initial_env = initialEnv global_env code_env - res <- doStmts stmts initial_env - case snd res of - FrameFail msg -> return (Left msg) - Value _ -> inconclusive - Results ress -> return (Right ress) - where - inconclusive - = return (Left ("test completed but actual/expected " ++ - "results not determined")) - - --- Run a bunch of statements, and return either Nothing if --- there was no return statement, or the value computed by said. -doStmts :: [Stmt] -> IOEV (Maybe String) -doStmts [] = returnEV Nothing -doStmts (s:ss) = doStmt s `thenEV` \ maybe_v -> - case maybe_v of - Just xx -> returnEV (Just xx) - Nothing -> doStmts ss - - -doStmt :: Stmt -> IOEV (Maybe String) -doStmt (SAssign v expr) - = evalExpr expr `thenEV` \ str -> - addLocalVarBind v str `thenEV_` - returnEV Nothing -doStmt (SPrint expr) - = evalExpr expr `thenEV` \ str -> - ioToEV (putStrLn str) `thenEV_` - returnEV Nothing -doStmt (SCond c t maybe_f) - = evalExprToBool c `thenEV` \ c_bool -> - if c_bool - then doStmts t - else case maybe_f of - Nothing -> returnEV Nothing - Just f -> doStmts f - -doStmt (SFFail expr) - = evalExpr expr `thenEV` \ res -> - failagainEV ("=== user-framework-fail: " ++ res) -doStmt (SResult res expr) - = evalExprToBool expr `thenEV` \ b -> - whenEV b (setResult True{-actual-} res) `thenEV_` - returnEV Nothing -doStmt (SExpect res) - = setResult False{-expected-} res `thenEV_` - returnEV Nothing - -doStmt (SMacro mnm args) - = runMacro mnm args `thenEV` \ maybe_v -> - case maybe_v of - Nothing -> returnEV Nothing - Just _ -> failEV (hasValue mnm) - -doStmt (SReturn expr) - = evalExpr expr `thenEV` \ res -> - returnEV (Just res) - -doStmt (SSkip expr) - = evalExprToBool expr `thenEV` \ skip -> - if skip - then resultsEV (Skipped, Skipped) - else returnEV Nothing - -runMacro :: MacroName -> [Expr] -> IOEV (Maybe String) -runMacro mnm args - = - lookupMacro mnm `thenEV` \ mdef -> - case mdef of { MacroDef formals stmts -> - length formals `bind` \ n_formals -> - length args `bind` \ n_args -> - if n_formals /= n_args - then failEV (arityErr mnm n_formals n_args) - else mapEV evalExpr args `thenEV` \ arg_vals -> - zip formals arg_vals `bind` \ new_local_env -> - getLocalEnv `thenE` \ our_local_env -> - setLocalEnv new_local_env `thenE_` - getLocalEnv `thenE` \ xxx -> - doStmts stmts `thenEV` \ res -> - setLocalEnv our_local_env `thenE_` - returnEV res - } - - ---------------------------------------------------------------------- --- The expression evaluator. - -fromBool b - = if b then "True" else "False" - -pipeErr p - = "Can't run pipe `" ++ p ++ "'" -cantOpen f - = "Can't open file `" ++ f ++ "'" -regExpErr rx - = "Invalid regexp `" ++ rx ++ "'" -missingVar v - = "No binding for variable `$" ++ v ++ "'" -missingMacro mnm - = "No binding for macro `" ++ mnm ++ "'" -notABool str - = "String `" ++ str ++ "' is neither `True' nor `False'" -arityErr mnm n_formals n_actuals - = "Macro `" ++ mnm ++ "' expects " ++ show n_formals - ++ " args, but was given " ++ show n_actuals -macroArg mnm arg - = "No binding for formal param `$" ++ arg - ++ "' whilst expanding macro `" ++ mnm ++ "'" -isGlobalVar v - = "Assigments to global variable `$" ++ v ++ "' are not allowed" -hasValue mnm - = "Macro `" ++ mnm ++ "' used in context not expecting a value" -noValue mnm - = "Macro `" ++ mnm ++ "' used in context expecting a value" - - -evalOpExpr :: Op -> String -> String -> IOEV String - -evalOpExpr OpAppend s1 s2 = returnEV (s1 ++ s2) -evalOpExpr OpEq s1 s2 = returnEV (fromBool (s1 == s2)) -evalOpExpr OpNEq s1 s2 = returnEV (fromBool (s1 /= s2)) -evalOpExpr OpContains s rx - = case myMatchRegexp rx s of - Nothing -> failEV (regExpErr rx) - Just bb -> returnEV (fromBool bb) -evalOpExpr OpLacks s rx - = case myMatchRegexp rx s of - Nothing -> failEV (regExpErr rx) - Just bb -> returnEV (fromBool (not bb)) - - -evalExpr :: Expr -> IOEV String -evalExpr (EOp op e1 e2) - | op `elem` [OpEq, OpNEq, OpAppend, OpContains, OpLacks] - = evalExpr e1 `thenEV` \ e1s -> - evalExpr e2 `thenEV` \ e2s -> - evalOpExpr op e1s e2s -evalExpr (EOp OpOr e1 e2) - = evalExprToBool e1 `thenEV` \ b1 -> - if b1 then returnEV (fromBool True) - else evalExprToBool e2 `thenEV` \ b2 -> - returnEV (fromBool b2) -evalExpr (EOp OpAnd e1 e2) - = evalExprToBool e1 `thenEV` \ b1 -> - if not b1 then returnEV (fromBool False) - else evalExprToBool e2 `thenEV` \ b2 -> - returnEV (fromBool b2) -evalExpr (EString str) - = returnEV str -evalExpr (EBool b) - = returnEV (fromBool b) -evalExpr (EContents expr) - = evalExpr expr `thenEV` \ filename -> - readFileEV filename -evalExpr (EExists expr) - = evalExpr expr `thenEV` \ filename -> - doesFileExistEV filename `thenEV` \ b -> - returnEV (fromBool b) -evalExpr (EDefined v) - | null v - = panic ("evalExpr(EDefined): not a var " ++ v) - -- This is a panic because the lexer+parser should have - -- conspired to ensure this - | otherwise - = lookupVar_maybe v `thenE` \ maybe_v -> - returnEV (fromBool (isJust maybe_v)) -evalExpr EOtherwise - = returnEV (fromBool True) -evalExpr (ECond c t f) - = evalExprToBool c `thenEV` \ c_bool -> - if c_bool - then evalExpr t - else evalExpr f -evalExpr (EVar v) - = lookupVar v -evalExpr (EFFail expr) - = evalExpr expr `thenEV` \ res -> - failEV ("=== user-framework-fail: " ++ res) -evalExpr (ERun expr) - = evalExpr expr `thenEV` \ cmd_to_run -> - systemEV cmd_to_run `thenEV` \ exit_code -> - returnEV (show exit_code) - -evalExpr (EMacro mnm args) - = runMacro mnm args `thenEV` \ maybe_v -> - case maybe_v of - Nothing -> failEV (noValue mnm) - Just xx -> returnEV xx - -evalExpr (EPipe src cmd) - = evalExpr src `thenEV` \ src_txt -> - evalExpr cmd `thenEV` \ cmd_txt -> - runPipeEV src_txt cmd_txt - -------------------------- - --- Go to some trouble to manufacture temp file names without recourse --- to the FFI, since ghci can't handle FFI calls right now -myMkTempName :: String -> Int -> String -myMkTempName hashable_str ctr - = "testdriver_" ++ show (hash 0 hashable_str) ++ "_" ++ show ctr - where - hash :: Int -> String -> Int - hash h [] = h - hash h (c:cs) = hash (((h * 7) + ord c) `mod` 1000000000) cs - -runPipeEV :: String{-src-} -> String{-cmd-} -> IOEV String -runPipeEV src cmd - = getCounterE `thenE` \ ctr -> - getEvalEnv `thenE` \ p -> - myMkTempName (show p) ctr `bind` \ tmpf_root -> - (tmpf_root ++ "_in") `bind` \ tmpf_in -> - (tmpf_root ++ "_out") `bind` \ tmpf_out -> - ioToEV (writeFile tmpf_in src) `thenEV_` - ioToEV (my_system - (cmd ++ " < " ++ tmpf_in - ++ " > " ++ tmpf_out)) `thenEV` \ ret_code -> - case ret_code of - ExitFailure m -> failEV (pipeErr cmd) - ExitSuccess - -> ioToEV (myReadFile tmpf_out) `thenEV` \ result -> - ioToEV (removeFile tmpf_in) `thenEV_` - ioToEV (removeFile tmpf_out) `thenEV_` - returnEV result - --- Does filename exist? -doesFileExistEV :: String -> IOEV Bool -doesFileExistEV filename - = ioToEV (doesFileExist filename) `thenEV` \ b -> - returnEV b - --- Get the contents of a file. -readFileEV :: String -> IOEV String -readFileEV filename - = ioToEV (doesFileExist filename) `thenEV` \ exists -> - if not exists - then failEV (cantOpen filename) - else ioToEV (myReadFile filename) `thenEV` \ contents -> - returnEV contents - --- Use this round-the-houses scheme to ensure we don't run out of file --- handles. -myReadFile :: String -> IO String -myReadFile f - = do hdl <- openFile f ReadMode - cts <- hGetContents hdl - case seqList cts of - () -> do hClose hdl - return cts - --- sigh ... -seqList [] = () -seqList (x:xs) = seqList xs - --- Run a command. -systemEV :: String -> IOEV Int -systemEV str - = ioToEV (my_system str) `thenEV` \ ret_code -> - case ret_code of - ExitSuccess -> returnEV 0 - ExitFailure m -> returnEV m - ---------------------------- - -evalExprToBool :: Expr -> IOEV Bool -evalExprToBool e - = evalExpr e `thenEV` \ e_eval -> - case e_eval of - "True" -> returnEV True - "False" -> returnEV False - other -> failEV (notABool other) diff --git a/testsuite/driver/CmdSyntax.hs b/testsuite/driver/CmdSyntax.hs deleted file mode 100644 index d9d7e0a207..0000000000 --- a/testsuite/driver/CmdSyntax.hs +++ /dev/null @@ -1,146 +0,0 @@ - -module CmdSyntax ( Var, MacroName, TestName, MacroDef(..), - TopDef(..), Stmt(..), Expr(..), freeVars, - Op(..), Result(..), - TestID(..), ppTestID, - TestResult(..), ppTestResult, - testid_of_TestResult, results_of_TestResult, - isTInclude, isTTest, isTMacroDef, isTAssign, - isLeft, isRight, unLeft, unRight, - - panic, officialMsg, my_system, die, - ) -where - -import IO -import System ( getProgName, exitWith, ExitCode(..) ) -import KludgedSystem ( system ) - ---------------------------------------------------------------------- --- misc -panic str - = error ("\nruntests: the `impossible' happened:\n\t" ++ str ++ "\n") - -officialMsg str - = do prog <- getProgName - hPutStrLn stderr (prog ++ ": " ++ str) - -die :: String -> IO a -die s = do officialMsg s; exitWith (ExitFailure 1) - -my_system s - = do exit_code <- system s - return exit_code - -isLeft (Left _) = True -isLeft (Right _) = False -isRight = not . isLeft - -unLeft (Left x) = x -unRight (Right x) = x - - ---------------------------------------------------------------------- --- command abs syntax - ------------------- -type TestName = String -type Var = String -type MacroName = String -data MacroDef = MacroDef [Var] [Stmt] - deriving Show - -data TestID = TestID FilePath{-for the .T file-} - TestName{-name within the .T file-} - deriving (Eq, Show, Read) - -ppTestID (TestID tfilepath tname) = tfilepath ++ " " ++ tname - ------------------- - -data Expr - = EOp Op Expr Expr - | EVar Var - | EString String - | EBool Bool - | EContents Expr - | EExists Expr - | EMacro MacroName [Expr] - | ECond Expr Expr Expr - | EOtherwise - | EDefined Var - | EFFail Expr - | EPipe Expr Expr -- input to pipe, name of program - | ERun Expr - deriving Show - -freeVars :: Expr -> [Var] -freeVars (EOp op l r) = freeVars l ++ freeVars r -freeVars (EVar v) = [v] -freeVars (EString _) = [] -freeVars (EBool _) = [] -freeVars (EContents e) = freeVars e -freeVars (EExists e) = freeVars e -freeVars (EMacro _ es) = concatMap freeVars es -freeVars (EDefined v) = [] -- we don't actually use v here -freeVars (EFFail e) = freeVars e - -data Stmt - = SAssign Var Expr - | SPrint Expr - | SCond Expr [Stmt] (Maybe [Stmt]) - | SReturn Expr - | SMacro MacroName [Expr] - | SFFail Expr - | SSkip Expr - | SResult Result Expr - | SExpect Result - deriving Show - -data TopDef - = TInclude Expr - | TMacroDef MacroName MacroDef - | TTest TestName [Stmt] - | TAssign Var Expr - deriving Show - -data Op - = OpAnd | OpOr | OpAppend | OpEq | OpNEq | OpContains | OpLacks - deriving (Eq, Show) - -isTInclude (TInclude _) = True -isTInclude other = False - -isTTest (TTest _ _) = True -isTTest other = False - -isTMacroDef (TMacroDef _ _) = True -isTMacroDef other = False - -isTAssign (TAssign _ _) = True -isTAssign other = False - -data Result - = Pass -- test passed - | Fail -- test failed - | Unknown -- test might have run, but outcome undetermined - | Skipped -- skip-when clause indicated this test to be skipped - deriving (Eq, Show, Read) - --- Overall result of a test -data TestResult - = TestFFail TestID - | TestRanOK TestID Result Result - deriving (Show, Read) - -ppTestResult (TestFFail nm) - = " framefail " ++ ppTestID nm -ppTestResult (TestRanOK nm exp act) - = " exp:" ++ show exp ++ ", act:" ++ show act - ++ " " ++ ppTestID nm - -testid_of_TestResult (TestFFail nm1) = nm1 -testid_of_TestResult (TestRanOK nm1 _ _) = nm1 - -results_of_TestResult (TestFFail nm1) = Nothing -results_of_TestResult (TestRanOK nm1 e a) = Just (e,a) diff --git a/testsuite/driver/KludgedSystem.hs b/testsuite/driver/KludgedSystem.hs deleted file mode 100644 index ed910b89d9..0000000000 --- a/testsuite/driver/KludgedSystem.hs +++ /dev/null @@ -1,32 +0,0 @@ -{-# OPTIONS -cpp -fglasgow-exts #-} ------------------------------------------------------------------------------ --- $Id: KludgedSystem.hs,v 1.1 2001/08/30 17:22:13 rrt Exp $ - --- system that works feasibly under Windows (i.e. passes the command line to sh, --- because system() under Windows doesn't look at SHELL, and always uses CMD.EXE) - -module KludgedSystem (system) where - -#include "../../ghc/includes/config.h" - -#ifndef mingw32_TARGET_OS - -import System (system) - -#else - -import qualified System -import System (ExitCode) -import IO (bracket_) -import Directory (removeFile) - -system :: String -> IO ExitCode -system cmd = do - pid <- getProcessID - let tmp = "sh"++show pid - writeFile tmp (cmd++"\n") - bracket_ (return tmp) removeFile $ System.system ("sh - "++tmp) - -foreign import "_getpid" unsafe getProcessID :: IO Int - -#endif /* mingw32_TARGET_OS */ diff --git a/testsuite/driver/Main.hs b/testsuite/driver/Main.hs deleted file mode 100644 index d08415f0e8..0000000000 --- a/testsuite/driver/Main.hs +++ /dev/null @@ -1,403 +0,0 @@ - -module Main where - -import CmdSyntax -import CmdSemantics ( parseOneTFile, processParsedTFile ) - -import GetOpt -import Directory -import System ( getArgs ) -import List -import Maybe ( isJust, fromJust ) -import Monad ( when ) -import Time ( ClockTime, getClockTime ) -import IO ( try, stdout, hFlush, - hSetBuffering, BufferMode(NoBuffering) ) - - ---import IOExts(trace) - -findTFiles :: FilePath -- name of root dir of tests - -> IO [FilePath] -- full pathnames of all .T files - -findTFiles root_in - = snarf ((reverse . dropWhile (== '/') . reverse) root_in) "." - where - snarf root dir - = do --putStr "snarf: " - --print (root,dir) - let this_dir = root ++ "/" ++ dir - - dir_contents_raw <- getDirectoryContents this_dir - let dir_contents = filter ((/= ".").(take 1)) - dir_contents_raw - - let tag_subdir f = do b <- doesDirectoryExist - (this_dir ++ "/" ++ f) - return (b, f) - - tagged_contents <- mapM tag_subdir dir_contents - --print tagged_contents - let tfiles_in_this_dir - = [this_dir ++ "/" ++ f - | (False, f) <- tagged_contents, - f `hasSuffix` ".T"] - --print tests_in_this_dir - let subdir_names - = [ f | (True, f) <- tagged_contents ] - subdir_tfiless - <- mapM (\d -> snarf root (dir++"/"++d)) subdir_names - let all_tfiless - = tfiles_in_this_dir ++ concat subdir_tfiless - return - (map scrub all_tfiless) - - -hasSuffix :: String -> String -> Bool -hasSuffix str suff - = let r_suff = reverse suff - r_str = reverse str - in r_suff == take (length r_suff) r_str - - --- (eg) "tests/./test1/run.stderr" --> "tests/test1/run.stderr" -scrub :: String -> String -scrub [] = [] -scrub ('/':'.':'/':cs) = scrub ('/':cs) -scrub (c:cs) = c : scrub cs - - -data Opt - = OptConfig String - | OptRootDir String - | OptOutSummary String - | OptSaveSummary String - | OptCompareSummary String - -option_descrs = [ - Option "" ["config"] (ReqArg OptConfig "FILE") - "config file", - Option "" ["rootdir"] (ReqArg OptRootDir "DIR") - "root of tree containing tests (default: .)", - Option "" ["output-summary"] (ReqArg OptOutSummary "PATH") - "file in which to save the (human-readable) summary", - Option "" ["save-summary"] (ReqArg OptSaveSummary "PATH") - "file in which to save the summary", - Option "" ["compare-summary"] (ReqArg OptCompareSummary "PATH") - "old summary to compare against" - ] - -usage = GetOpt.usageInfo header option_descrs ++ '\n':extra_info -header = "runtests [OPTION | VAR=VALUE | TEST]..." - -extra_info - = " You may not set any of the following vars from the\n" ++ - " command line:\n" ++ - concatMap (\w -> " $" ++ w ++ "\n") special_var_names - -getConfigOpt os = exactlyOne "-config" [ t | OptConfig t <- os ] -getRootOpt os = upToOne "-rootdir" [ t | OptRootDir t <- os ] -getOutSuOpt os = upToOne "-output-summary" [ t | OptOutSummary t <- os ] -getSaveSuOpt os = upToOne "-save-summary" [ t | OptSaveSummary t <- os ] -getCompareSuOpt os = upToOne "-compare-summary" [ t | OptCompareSummary t <- os] - -exactlyOne s [] = die ("missing " ++ '-':s ++ " option") -exactlyOne _ [a] = return a -exactlyOne s as = die ("multiple " ++ '-':s ++ " options") - -upToOne s [] = return Nothing -upToOne s [a] = return (Just a) -upToOne s as = die ("multiple " ++ '-':s ++ " options") - -main - = getArgs >>= main_really -imain arg_str - = main_really (words arg_str) -test - = imain ("tool=ghc --config=../config/msrc/cam-02-unx.T " - ++ "--rootdir=../tests/codeGen") - -main_really arg_ws0 - = do start_time <- getClockTime - case getOpt Permute option_descrs arg_ws0 of - (opts, args, []) -> got_args opts args start_time - (_, _, errs) -> die (concat errs ++ usage) - -got_args opts args start_time - = do conf <- getConfigOpt opts - maybe_root <- getRootOpt opts - maybe_save_su <- getSaveSuOpt opts - maybe_cmp_su <- getCompareSuOpt opts - maybe_out_su <- getOutSuOpt opts - - let (not_binds, cmd_binds) = getBinds args - let invalid_binds - = filter (`elem` special_var_names) - (map fst cmd_binds) - - when (not (null invalid_binds)) $ do - die ("cannot set special variable $" ++ head invalid_binds ++ - " on the command line") - - let -- default root is '.' - root | isJust maybe_root = fromJust maybe_root - | otherwise = "." - - (confdir, conffile) = splitPathname conf - - base_genv = [("confdir", confdir), - ("conffilename", conffile)] ++ cmd_binds - - tests_to_run - = if null not_binds then Nothing{-all of them-} - else Just not_binds{-just these-} - - conf_ok <- doesFileExist conf - when (not conf_ok) (die ("config file `" ++ conf ++ "' doesn't exist")) - - -- Find all the .T files - all_tfiles <- findTFiles root - officialMsg ("Found " ++ show (length all_tfiles) - ++ " test description files:") - putStrLn (unlines (map (" "++) all_tfiles)) - -- Parse them all - all_parsed - <- mapM (\tfpath -> parseOneTFile - (addTVars base_genv tfpath) tfpath) - all_tfiles - let parse_fails = filter isLeft all_parsed - when (not (null parse_fails)) ( - do officialMsg ("Parse errors for the following .T files:\n") - putStr (unlines (map ((" "++).unLeft) parse_fails)) - ) - let parsed_ok = map unRight (filter isRight all_parsed) - -- Run all the tests in each successfully-parsed .T file. - hFlush stdout - hSetBuffering stdout NoBuffering - resultss - <- mapM ( \ (path,topdefs) -> processParsedTFile - tests_to_run - path - (addTVars base_genv path) - topdefs) - parsed_ok - let results = concat resultss - putStr "\n" - officialMsg ("=== All done. ===") - -- ; putStr ("\n" ++ ((unlines . map show) results)) - let summary = makeSummary start_time results - - let pp_summary = snd (ppSummary summary) - if isJust maybe_out_su - then writeFile (fromJust maybe_out_su) pp_summary - else putStrLn ("\n" ++ pp_summary) - - case maybe_cmp_su of - Nothing -> return () - Just fn - -> do { officialMsg ("=== Comparing against: " ++ fn ++ " ===") - ; maybe_txt <- try (readFile fn) - ; case maybe_txt of { - Left err -> do - officialMsg ("=== Can't read abovementioned file ===") - print err - ; Right txt -> - do { case ((reads txt) :: [(Summary, String)]) of - ((old_summ, ""):_) - -> do putStrLn "" - putStrLn (ppSummaryDiffs old_summ summary) - other - -> do officialMsg - ("=== Parse error in: " ++ fn ++ " ===") - return () - }}} - case maybe_save_su of - Nothing -> return () - Just fn -> do officialMsg ("=== Saving summary in: " ++ fn ++ " ===") - wr_ok <- try (writeFile fn (show summary)) - case wr_ok of - Right _ -> return () - Left err -> do officialMsg ("=== Can't write abovementioned file ===") - print err - putStrLn "" - -- ; exitWith ExitSuccess - where - addTVars some_genv tfpath - = case splitPathname tfpath of - (tfdir, tfname) -> ("testdir", tfdir) - : ("testfilename", tfname) - : some_genv - - -data Summary - = Summary { - start_time :: String, - n_cands :: Int, - frame_fails, -- Tests which got a framework failure - skipped, -- Tests which asked to be skipped - p_p, -- Tests which: expect Pass, actual Pass - p_f, -- Tests which: expect Pass, actual Fail - f_p, -- Tests which: expect Fail, actual Pass - f_f, -- Tests which: expect Fail, actual Fail - exp_u, -- Tests which: expect Unknown - act_u, -- Tests which: actual Unknown - u_u, -- Tests which: expect Unknown, Actual Unknown - u_notu, -- Tests which: expect Unknown, Actual /= Unknown - unexp -- All tests for which Expected /= Actual - :: [TestResult] - } - deriving (Show, Read) - - --- Cook up a summary from raw test results -makeSummary :: ClockTime -- when the test run started - -> [TestResult] - -> Summary - -makeSummary start_time outcomes - = let n_cands = length outcomes - frame_fails = filter is_frame_fail outcomes - outcomes_ok = filter (not.is_frame_fail) outcomes - skipped = filter is_skip outcomes_ok - - p_p = filter (got (== Pass) (== Pass)) outcomes_ok - p_f = filter (got (== Pass) (== Fail)) outcomes_ok - f_p = filter (got (== Fail) (== Pass)) outcomes_ok - f_f = filter (got (== Fail) (== Fail)) outcomes_ok - - exp_u = filter (got (== Unknown) (const True)) outcomes_ok - act_u = filter (got (const True) (== Unknown)) outcomes_ok - u_u = filter (got (== Unknown) (== Unknown)) outcomes_ok - u_notu = filter (got (== Unknown) (/= Unknown)) outcomes_ok - - unexp = nubBy (\a b -> testid_of_TestResult a == testid_of_TestResult b) - (p_f ++ f_p ++ u_notu) - in - Summary { start_time=show start_time, - n_cands=n_cands, - frame_fails=frame_fails, skipped=skipped, - p_p=p_p, p_f=p_f, f_p=f_p, f_f=f_f, - exp_u=exp_u, act_u=act_u, u_u=u_u, u_notu=u_notu, - unexp=unexp - } - where - is_frame_fail (TestFFail _) = True - is_frame_fail (TestRanOK _ _ _) = False - - got f1 f2 (TestRanOK nm r1 r2) = f1 r1 && f2 r2 - got f1 f2 (TestFFail nm) = False - - is_skip (TestRanOK nm Skipped Skipped) = True - is_skip (TestRanOK nm r1 r2) - | r1 == Skipped || r2 == Skipped - = panic "is_skip" - is_skip other = False - - --- Produce both verbose and ultra-terse versions of a Summary -ppSummary :: Summary -> (String, String) -ppSummary s - = let summary_big - = unlines [ "OVERALL SUMMARY for run started at " - ++ start_time s - , "" - , " " ++ show (n_cands s) - ++ " total test candidates, of which:" - , " " ++ show (length (frame_fails s)) - ++ " framework failures," - , " " ++ show (length (skipped s)) ++ " were skipped," - , "" - , " " ++ show (length (p_p s)) ++ " expected passes," - , " " ++ show (length (f_f s)) ++ " expected failures," - , " " ++ show (length (f_p s)) ++ " unexpected passes," - , " " ++ show (length (p_f s)) ++ " unexpected failures," - , "" - , " " ++ show (length (exp_u s)) ++ " specified as unknown," - , " " ++ show (length (act_u s)) ++ " actual unknowns," - , " " ++ show (length (u_u s)) ++ " expected unknowns." - ] - - summary_short - = show (n_cands s) ++ " cands, " - ++ show (length (frame_fails s)) ++ " framework-failed, " - ++ show (length (skipped s)) ++ " skipped, " - ++ show (length (unexp s)) ++ " unexpected outcomes." - - unexpected_summary - | null (unexp s) - = "" - | otherwise - = "\nThe following tests had unexpected outcomes:\n" - ++ unlines (map ((" "++). ppTestID . testid_of_TestResult) - (unexp s)) - - framefail_summary - | null (frame_fails s) - = "" - | otherwise - = "\nThe following tests had framework failures:\n" - ++ unlines (map ((" "++). ppTestID . testid_of_TestResult) - (frame_fails s)) - in - (summary_short, - summary_big ++ unexpected_summary ++ framefail_summary) - - --- Print differences between two summaries -ppSummaryDiffs old new - = "DIFFERENCES from run of " ++ start_time old ++ "\n" - ++ "\n" - ++ "Prev: " - ++ fst (ppSummary old) - ++ "\n Now: " - ++ fst (ppSummary new) - ++ if null diff_unexp then [] - else "\nNew unexpected outcomes:\n" ++ unlines (map ppTestResult diff_unexp) - - where - old_unexp = unexp old - now_unexp = unexp new - old_unexp_ids = map testid_of_TestResult old_unexp - diff_unexp = filter (\new_u -> testid_of_TestResult new_u - `notElem` old_unexp_ids) - now_unexp - - --- (eg) "foo/bar/xyzzy.ext" --> ("foo/bar", "xyzzy.ext") -splitPathname :: String -> (String, String) -splitPathname full - | '/' `notElem` full = (".", full) - | otherwise - = let full_r = reverse full - f_r = takeWhile (/= '/') full_r - p_r = drop (1 + length f_r) full_r - in if null p_r then (".", reverse f_r) - else (reverse p_r, reverse f_r) - --- Extract all the var=value binds from a bunch of cmd line opts. -getBinds :: [String] -> ([String], [(Var,String)]) -getBinds args = f args [] [] - where - f [] binds rest = (reverse rest, reverse binds) - f (arg:args) binds rest - | isJust maybe_bind = f args (fromJust maybe_bind:binds) rest - | otherwise = f args binds (arg:rest) - where - maybe_bind = is_bind (break (== '=') arg) - is_bind (var, '=':value) = Just (var,value) - is_bind str = Nothing - --- These vars have special meanings and may not be set from the --- command line. -special_var_names - = ["testfilename", "testdir", "conffilename", "confdir", "testname"] - --- (eg) "foo/bar/xyzzy.ext" --> ("foo/bar", "xyzzy", "ext") ---splitPathname3 full --- = let (dir, base_and_ext) = splitPathname full --- in if '.' `elem` base_and_ext --- then let r_bande = reverse base_and_ext --- r_ext = takeWhile (/= '.') r_bande --- r_root = drop (1 + length r_ext) r_bande --- in (dir, reverse r_root, reverse r_ext) --- else (dir, base_and_ext, "") diff --git a/testsuite/driver/TopSort.hs b/testsuite/driver/TopSort.hs deleted file mode 100644 index 345bd74fae..0000000000 --- a/testsuite/driver/TopSort.hs +++ /dev/null @@ -1,120 +0,0 @@ - -module TopSort ( topSort ) where - -import List ( nub ) - - - -data SCC a = NonRec a | Rec [a] - -unNonRec (NonRec x) = x -unRec (Rec xs) = xs - -isRec (Rec _) = True -isRec (NonRec _) = False - - --- Topologically sort a directed graph, given the forward --- mapping as a [(source, [dest])]. Detect circularities --- and return a Left if they are found. -topSort :: Ord a => [(a, [a])] -> Either [a]{-a circular group-} - [a]{-tsorted order-} -topSort fmap - = let vertices = nub (map fst fmap ++ concatMap snd fmap) - f_edges = concat [ [(src,dst) | dst <- dsts] - | (src, dsts) <- fmap ] - bmap_for d = (d, [ss | (ss,dd) <- f_edges, dd == d]) - bmap = [bmap_for d | d <- vertices] - fmap_fn = \ v -> doOrDie (lookup v fmap) - bmap_fn = \ v -> doOrDie (lookup v bmap) - - doOrDie (Just xs) = xs - doOrDie Nothing = error "TopSort.topSort: vertex lookup failed?!?" - - sccs = deScc fmap_fn bmap_fn vertices - classified = map (classify fmap_fn . unSet) sccs - recs = filter isRec classified - nonrecs = filter (not.isRec) classified - in - if null recs - then Right (map unNonRec nonrecs) - else Left (unRec (head recs)) - - --- Given the forward edge map, decide whether a SCC is circular or --- not. -classify :: Eq a => (a -> [a]) -> [a] -> SCC a -classify fmap_fn (x:y:rest) - = Rec (x:y:rest) -classify fmap_fn [x] - = if x `elem` fmap_fn x then Rec [x] else NonRec x - - --- Appallingly inefficient -newtype Set a = Set [a] - -utSetUnion (Set xs) (Set ys) = Set (nub (xs ++ ys)) -utSetSingleton x = Set [x] -utSetEmpty = Set [] -utSetFromList xs = Set (nub xs) -utSetElementOf x (Set xs) = x `elem` xs -unSet (Set xs) = xs - - - - - -deDepthFirstSearch :: (Ord a) => - (a -> [a]) -> -- The map, - (Set a, [a]) -> -- state: visited set, - -- current sequence of vertices - [a] -> -- input vertices sequence - (Set a, [a]) -- final state -deDepthFirstSearch - = foldl . search - where - search relation (visited, sequence) vertex - | utSetElementOf vertex visited = (visited, sequence ) - | otherwise = (visited', vertex: sequence') - where - (visited', sequence') - = deDepthFirstSearch relation - (utSetUnion visited (utSetSingleton vertex), sequence) - (relation vertex) - - - - - -deSpanningSearch :: (Ord a) => - (a -> [a]) -> -- The map - (Set a, [Set a]) -> -- Current state: visited set, - -- current sequence of vertice sets - [a] -> -- Input sequence of vertices - (Set a, [Set a]) -- Final state -deSpanningSearch - = foldl . search - where - search relation (visited, utSetSequence) vertex - | utSetElementOf vertex visited = (visited, utSetSequence ) - | otherwise = (visited', utSetFromList (vertex: sequence): utSetSequence) - where - (visited', sequence) - = deDepthFirstSearch relation - (utSetUnion visited (utSetSingleton vertex), []) - (relation vertex) - - - - - -deScc :: (Ord a) => - (a -> [a]) -> -- The "ins" map - (a -> [a]) -> -- The "outs" map - [a] -> -- The root vertices - [Set a] -- The topologically sorted components -deScc ins outs - = spanning . depthFirst - where depthFirst = snd . deDepthFirstSearch outs (utSetEmpty, []) - spanning = snd . deSpanningSearch ins (utSetEmpty, []) - diff --git a/testsuite/driver/basicRxLib/AbsTreeDefs.hs b/testsuite/driver/basicRxLib/AbsTreeDefs.hs deleted file mode 100644 index 4ddb3d2f49..0000000000 --- a/testsuite/driver/basicRxLib/AbsTreeDefs.hs +++ /dev/null @@ -1,338 +0,0 @@ -module AbsTreeDefs - (AbsTree(..),Regexp, - mkEl,mkBackref,mkEnd,justPrefix, - mkSub,mkOpt,mkStar,mkPlus,mkMin,mkExact,mkMinMax,mkNg, - mkCon,mkAlt, - mkMinDef,mkMinMaxDef, - addEnd, - isElem,isBref,isEnd, - isSub,isStar,isPlus,isOpt,isMin,isMinmax,isNg,isInterval,isRepeatable, - isCon,isAlt, - isLeaf,isUn,isBin,child,left,right,updateChild,updateLeft,updateRight, - getMin,getMinMax,getPrefix, - getElem,getBref,getSEName, - getExtraRE,updateExtraRE, - foldPostT,foldPreT - ) - - -where - -import FiniteMap -import Matchers - -data AbsTree a b = ABS (Regexp a b,b) -- regexp with some extra info at each node - -data Regexp a b = - -- These have no children - EL (MatcherImpl a) -- An element matcher - Bool -- is this a prefix matcher - | BACKREF String -- Match the nth subexp, for given n - ([a]->MatcherImpl a)-- The matcher function to use - - | END -- End of the Regexp - - -- These are have 1 child - | SUB String -- the name to reference the subexp - (AbsTree a b) -- Root of a subexpression - | STAR (AbsTree a b) -- Match 0 or more - | PLUS (AbsTree a b) -- Match 1 or more - | OPT (AbsTree a b) -- Match 0 or 1 - | MIN Int -- Match at least n times, for given n - (AbsTree a b) - - | MINMAX Int Int -- Match between n and m times, for given n,m - (AbsTree a b) - - | NGMIN Int -- Match at least n times, non-greedily - (AbsTree a b) - - | NGMINMAX Int Int -- Match between n and m times, non-greedily - (AbsTree a b) - - -- These have two children - | CON (AbsTree a b) -- Match concatenation of two subregexps - (AbsTree a b) - - | ALT (AbsTree a b) -- Match first or second subregexp - (AbsTree a b) - - --- Build a regexp tree --- mk functions are wrappers to build the abstract syntax tree for a node. - -junk = error "Not defined yet" - --- leaf nodes -mkEl f = ABS (EL f False,junk) -mkBackref x f = ABS (BACKREF x f,junk) -mkEnd = ABS (END,junk) -justPrefix (ABS (EL f _,stuff))= ABS (EL f True,stuff) - --- nodes with one child -mkSub s n = ABS (SUB s n,junk) -mkOpt n = ABS (OPT n,junk) -mkStar n = ABS (STAR n, junk) -mkPlus n = ABS (PLUS n,junk) - -mkMin 0 n = ABS (STAR n,junk) -mkMin 1 n = ABS (PLUS n,junk) -mkMin x n | isElem n = - let bef = (mkEl . foldl1 regseq . map getElem .take (x-1)) (repeat n) - in mkCon bef (mkPlus n) - | otherwise = ABS (MIN x n,junk) --- JRS: redundant clause: mkMin x n = ABS (MIN x n,junk) - --- make a min node that is not to be optimised into a plus or star -mkMinDef x n other = ABS (MIN x n,other) - -mkExact x n | isElem n = - (mkEl . foldl1 regseq . map getElem . take x) (repeat n) -mkExact 1 n = n -mkExact x n = ABS (MINMAX x x n,junk) - -mkMinMax 0 1 n = ABS (OPT n,junk) -mkMinMax x y n | x <= 1 = ABS (MINMAX x y n,junk) -mkMinMax x y n | isElem n = - let bef = (mkEl . foldl1 regseq . map getElem.take (x-1)) (repeat n) - in mkCon bef (ABS (MINMAX 1 (y-x+1) n,junk)) -mkMinMax x y n = ABS (MINMAX x y n, junk) - --- make a MINMAX node that is not to be optimised into a plus or star -mkMinMaxDef x y n other = ABS (MINMAX x y n,other) - --- make a repetition node into a nongreedy one -mkNg n = - case n of - (ABS (STAR n,junk)) -> mkAlt -- both nodes must be nullable as AugTrees - --(this is done by making them intervals) - (ABS (NGMINMAX 0 1 --prefer to match 0 length - (mkEl matchNull),junk)) - (ABS (NGMIN 0 n ,junk)) - (ABS (PLUS n,junk)) -> ABS (NGMIN 1 n ,junk) - (ABS (OPT n,junk)) -> mkAlt -- both nodes must be nullable as AugTrees - --(this is done by making them intervals) - (ABS (NGMINMAX 0 1 --prefer to match 0 length - (mkEl matchNull),junk)) - (ABS (NGMINMAX 0 1 n, - junk)) - (ABS (MIN x n,junk)) -> ABS (NGMIN x n ,junk) - - (ABS (MINMAX x y n,junk)) - -> if (x /= y) then -- if matching exactly num times, - -- then non-greedy irrelevant - ABS (NGMINMAX x y n ,junk) - else if x > 0 then - ABS (NGMINMAX x y n ,junk) - else - mkAlt (ABS (NGMINMAX 0 1 - (mkEl matchNull),junk)) - (ABS (NGMINMAX x y n ,junk)) - _ -> n - --- binary nodes -mkCon n1 n2 = ABS (CON n1 n2 ,junk) -mkAlt n1 n2 = ABS (ALT n1 n2 ,junk) - - --- add a final node to the tree - -addEnd :: AbsTree a b -- a tree without a final node - -> AbsTree a b -- a tree with a final node -addEnd n = ABS (CON n (ABS (END, junk)) ,junk) - - --- Interrogate regexps --- all of type AbsTree a b -> Bool - -isElem (ABS (EL _ _, _)) = True -isElem _ = False - -isBref (ABS (BACKREF _ _ ,_)) = True -isBref _ = False - -isEnd (ABS (END, _)) = True -isEnd _ = False - -isSub (ABS (SUB _ _, _)) = True -isSub _ = False - -isStar (ABS (STAR _, _)) = True -isStar _ = False - -isPlus (ABS (PLUS _, _)) = True -isPlus _ = False - -isOpt (ABS (OPT _, _)) = True -isOpt _ = False - -isMin (ABS (MIN _ _, _)) = True -isMin (ABS (NGMIN _ _, _)) = True -isMin _ = False - -isMinmax (ABS (MINMAX _ _ _, _)) = True -isMinmax (ABS (NGMINMAX _ _ _, _)) = True -isMinmax _ = False - -isNg (ABS (NGMIN _ _, _)) = True -isNg (ABS (NGMINMAX _ _ _, _)) = True -isNg _ = False - -isInterval x = isMinmax x || isMin x -isRepeatable x = isMinmax x && snd (getMinMax x) > 1 || isMin x || isPlus x || isStar x - -isCon (ABS (CON _ _, _)) = True -isCon _ = False - -isAlt (ABS (ALT _ _, _)) = True -isAlt _ = False - -isLeaf x = isElem x || isBref x || isEnd x -isUn x = isInterval x || isStar x || isPlus x || isOpt x || isSub x -isBin x = isCon x || isAlt x - - --- get contents of regexps - -child :: AbsTree a b -> AbsTree a b -child (ABS (SUB _ re, _)) = re -child (ABS (STAR re, _)) = re -child (ABS (PLUS re, _)) = re -child (ABS (OPT re, _)) = re -child (ABS (MIN _ re, _)) = re -child (ABS (NGMIN _ re, _)) = re -child (ABS (MINMAX _ _ re, _)) = re -child (ABS (NGMINMAX _ _ re, _)) = re - -left :: AbsTree a b -> AbsTree a b -left (ABS (CON re1 _, _)) = re1 -left (ABS (ALT re1 _, _)) = re1 - -right :: AbsTree a b -> AbsTree a b -right (ABS (CON _ re2, _)) = re2 -right (ABS (ALT _ re2, _)) = re2 - --- get the extra info from an AbsTree -getExtraRE :: AbsTree a b -> b -getExtraRE (ABS (_,other)) = other - --- get contents of an element regexps -getElem :: AbsTree a b -- a regexp (only an El one allowed) - -> MatcherImpl a -- the matcher function at that leaf - - -getElem (ABS (EL f _, _)) = f - -getPrefix :: AbsTree a b -- a regexp (only an El one allowed) - -> Bool -- whether that regexp is a prefix only matcher -getPrefix (ABS (EL _ prefix, _)) = prefix - --- get contents of a backref regexp -getBref :: AbsTree a b - -> (String, -- which subexp to refer to - [a] -> MatcherImpl a) -- the matcher function to use - - -getBref (ABS (BACKREF x f, _)) = (x,f) - - --- get the minimum num interations from an interval regexp -getMin :: AbsTree a b -> Int -getMin (ABS (MIN x _, _)) = x -getMin (ABS (MINMAX x _ _, _)) = x -getMin (ABS (NGMIN x _, _)) = x -getMin (ABS (NGMINMAX x _ _, _)) = x - --- get the minimum & maximum num interations from a minmax regexp -getMinMax :: AbsTree a b -> (Int,Int) -getMinMax (ABS (MINMAX x y _ ,_)) = (x,y) -getMinMax (ABS (NGMINMAX x y _ ,_)) = (x,y) - --- get the name of the subexp to use to reference it -getSEName :: AbsTree a b -> String -getSEName (ABS (SUB s _,_)) = s - --- update an AbsTree - -updateExtraRE :: b -- new bit of extra info - -> AbsTree a b -- the regexp to be updated - -> AbsTree a b -- the new regexp - -updateExtraRE newother (ABS (re,_)) = (ABS (re,newother)) - - -updateChild :: AbsTree a b -> AbsTree a b -> AbsTree a b -updateChild newchild (ABS (MINMAX x y child ,other)) - = (ABS (MINMAX x y newchild ,other)) -updateChild newchild (ABS (MIN x child ,other)) - = (ABS (MIN x newchild ,other)) -updateChild newchild (ABS (NGMIN x child ,other)) - = (ABS (NGMIN x newchild ,other)) -updateChild newchild (ABS (NGMINMAX x y child ,other)) - = (ABS (NGMINMAX x y newchild ,other)) -updateChild newchild (ABS (STAR child ,other)) - = (ABS (STAR newchild ,other)) -updateChild newchild (ABS (OPT child ,other)) - = (ABS (OPT newchild ,other)) -updateChild newchild (ABS (PLUS child ,other)) - = (ABS (PLUS newchild ,other)) -updateChild newchild (ABS (SUB s child ,other)) - = (ABS (SUB s newchild ,other)) - -updateLeft :: AbsTree a b -> AbsTree a b -> AbsTree a b -updateLeft newchild (ABS (CON l r ,other)) - = (ABS (CON newchild r ,other)) -updateLeft newchild (ABS (ALT l r ,other)) - = (ABS (ALT newchild r ,other)) - - -updateRight :: AbsTree a b -> AbsTree a b -> AbsTree a b -updateRight newchild (ABS (CON l r ,other)) - = (ABS (CON l newchild ,other)) -updateRight newchild (ABS (ALT l r ,other)) - = (ABS (ALT l newchild ,other)) - - - - -foldPostT :: (AbsTree a b -> c -> c) -- function to apply to each node - -> c -- initial - -> AbsTree a b -- Tree to fold over - -> c -- result - -foldPostT f a t - | isLeaf t = f t a - | isUn t = f t (foldPostT f a (child t)) - | isBin t = f t (foldPostT f (foldPostT f a (left t)) (right t)) - -foldPreT :: (AbsTree a b -> c -> c) -- function to apply to each node - -> c -- initial - -> AbsTree a b -- Tree to fold over - -> c -- result - -foldPreT f a t - | isLeaf t = f t a - | isUn t = (foldPostT f (f t a) (child t)) - | isBin t =(foldPostT f (foldPostT f (f t a) (left t)) (right t)) - - - -works (ABS (EL a x, other)) = (ABS (EL a x, 10)) -works (ABS (BACKREF a d, other)) = (ABS (BACKREF a d, 10)) -works (ABS (END,_)) = (ABS (END,10)) -works (ABS (SUB x c, other)) = (ABS (SUB x (works c), 10)) -works (ABS (STAR c,other)) = (ABS (STAR (works c),10)) -works (ABS (PLUS c,other)) = (ABS (PLUS (works c),10)) -works (ABS (OPT c,other)) = (ABS (OPT (works c),10)) -works (ABS (MIN a c,other)) = (ABS (MIN a (works c),10)) -works (ABS (NGMIN a c,other)) = (ABS (NGMIN a (works c),10)) -works (ABS (MINMAX a b c,other)) = (ABS (MINMAX a b (works c),10)) -works (ABS (NGMINMAX a b c,other)) = (ABS (NGMINMAX a b (works c),10)) -works (ABS (CON l r,_)) = (ABS (CON (works l) (works r),10)) -works (ABS (ALT l r,_)) = (ABS (ALT (works l) (works r),10)) - - - - - - diff --git a/testsuite/driver/basicRxLib/Assertions.hs b/testsuite/driver/basicRxLib/Assertions.hs deleted file mode 100644 index c9e6f45a07..0000000000 --- a/testsuite/driver/basicRxLib/Assertions.hs +++ /dev/null @@ -1,83 +0,0 @@ -module Assertions - (Assert, - doAssert, - prefix, - suffix, - bol, - eol, - wordBound, - notWordBound) - -where - -import Matchers - --- a lookahead/lookbehind assertion to be applied to matcher -type Assert a = [a] -- before this position (look behind) - -> [a] -- after this position (look ahead) - -> Bool -- whether assertion about these holds - - - -doAssert :: Assert a -- assertions that must be tried - -> MatcherImpl a -- The matcher - -doAssert assertion bef as - = if assertion bef as then - Just ([],as) - else - Nothing - --- make the given matcher accept only prefixes -prefix :: Assert a -prefix [] _ = True -prefix (x:xs) _ = False - --- make the given matcher accept only suffixes -suffix :: Assert a -suffix _ [] = True -suffix _ (x:xs) = False - --- make an assertion to allow matching from only beginning of lines -bol:: Assert Char -bol [] _ = True -bol ('\n':xs) _ = True -bol _ _ = False - --- make an assertion to allow matching at only end of lines -eol:: Assert Char -eol _ [] = True -eol _ ('\n':xs) = True -eol _ _ = False - -wordBound:: Assert Char -wordBound = wbound True - -notWordBound:: Assert Char -notWordBound = wbound False - --- make an assertion about word boundaries. --- will pass if for two adjoining characters one is a \w & one is a \W - -wbound :: Bool -- whether this is a positive assertion (want wboundary) - -> Assert Char -- the resulting assertion -wbound _ [] [] = False - -wbound isWbound [] (m:_) = (isWordChar m) == isWbound - --- before info is reversed!!! -wbound isWbound (b:_) [] = (isWordChar b) == isWbound - - -- exclusive or combination, as - -- either want to have a \w & be looking for \W - -- or want to have a \W & be looking for \w -wbound isWbound (b:_) (m:_) = - ((isWordChar b && not (isWordChar m)) - || (not (isWordChar b) && (isWordChar m))) - == isWbound - - - - - - diff --git a/testsuite/driver/basicRxLib/AugTreeDefs.hs b/testsuite/driver/basicRxLib/AugTreeDefs.hs deleted file mode 100644 index 2f99f696ec..0000000000 --- a/testsuite/driver/basicRxLib/AugTreeDefs.hs +++ /dev/null @@ -1,115 +0,0 @@ -module AugTreeDefs - (Aug,AugTree, - AugInfo(..),updateAugTree, - getAugInfo, - getLbl, - firstPos, - lastPos,children,followPos, - followInfo,followInfoNoInt,follows,followsWithoutInt, - isNullable) - -where - - -import OrdList -import BagRE -import FiniteMap -import AbsTreeDefs - -{- An augmented Abstract syntax tree contains more info: - 1 Labels on the leafs - and for each node, n, info about - 2 firstpos (the leafs with which the regexp rooted at n can start) - 3 lastpos (the leafs with which the regexp rooted at n can end) - 4 children (all the leaf nodes which are child nodes of n) - 5 followpos information about what follows each leaf node, based - on regexp rooted at n. - this is a pair, there's follow info counting intervals, - and follow info without counting intervals. - Adding subexp info requires the first, adding - interval info requires the second. - 6 Nullable (Whether regular expression rooted at n can match 0 times) --} - -type AugTree a = AbsTree a (Aug a) -data Aug a = AUG (Maybe Int) -- label for node, only labelled if its a leaf - AugInfo -- extra AugInfo - -data AugInfo = AUGINFO (OrdList Int, -- The firstpos info - OrdList Int, -- The lastpos info - OrdList Int, -- The children info - ([(Int,BagRE Int)], -- without interval follows - -- for use with HandleInterval - [(Int,OrdList Int)])-- including interval follows - -- for use with HandleSubexp - ) -- follow info for regexp rooted here - Bool -- Nullable - --- update an AugTree - -updateAugTree :: Maybe Int - -> (OrdList Int, - OrdList Int, - OrdList Int, - ([(Int,BagRE Int)], - [(Int,OrdList Int)])) - -> Bool - -> AugTree a - -> AugTree a -updateAugTree a b c re = updateExtraRE (AUG a (AUGINFO b c)) re - - --- interrogate AugTree - -getAugInfo :: AugTree a -- an augmented tree - -> AugInfo -- the firstpos,lastpos... info - -getAugInfo re = case (getExtraRE re) of - (AUG _ ainfo) -> ainfo - -getLbl :: AugTree a -> Maybe Int -getLbl re = case (getExtraRE re) of - (AUG lbl _) -> lbl - -firstPos :: AugTree a -> OrdList Int -firstPos re = case (getAugInfo re) of - (AUGINFO (fs,_,_,_) _) -> fs - -lastPos :: AugTree a -> OrdList Int -lastPos re = case (getAugInfo re) of - (AUGINFO (_,ls,_,_) _) -> ls - -children :: AugTree a -> OrdList Int -children re = case (getAugInfo re) of - (AUGINFO (_,_,chs,_) _) -> chs - -followInfoNoInt :: AugTree a -> [(Int,BagRE Int)] -followInfoNoInt re = case (getAugInfo re) of - (AUGINFO (_,_,_,fi) _) -> fst fi - -followInfo :: AugTree a -> [(Int,OrdList Int)] -followInfo re = case (getAugInfo re) of - (AUGINFO (_,_,_,fi) _) -> snd fi - -followPos :: Int -> AugTree a -> OrdList Int -followPos x re = (snd.head.(filter ((== x).fst)).followInfo) re - -follows :: OrdList Int -> AugTree a -> [(Int,OrdList Int)] -{- For instance with "((a)(b))*c{2,}", if there are 3 nodes, "a", "b" and "c". - follows [2,3] will give, [(2,[1,3]),(3,[3,4])]. - --} -follows xs t = filter (\(a,b) -> a `elem` xs) (followInfo t) - -followsWithoutInt :: OrdList Int -> AugTree a -> [(Int,OrdList Int)] -{- For instance with "((a)(b))*c{2,}", if there are 3 nodes, "a", "b" and "c". - follows [2,3] will give, [(2,[1,3]),(3,[4])]. --} -followsWithoutInt xs t = map (\(a,b) -> (a,bagREToOL b)) - ( filter (\(a,b) -> a `elem` xs) - (followInfoNoInt t) ) - -isNullable :: AugTree a -> Bool -isNullable t = case getAugInfo t of - (AUGINFO _ null) -> null - diff --git a/testsuite/driver/basicRxLib/AugmentTree.hs b/testsuite/driver/basicRxLib/AugmentTree.hs deleted file mode 100644 index e8d93c133c..0000000000 --- a/testsuite/driver/basicRxLib/AugmentTree.hs +++ /dev/null @@ -1,124 +0,0 @@ -module AugmentTree - (augmentT) -where - - -import FiniteMap -import OrdList -import BagRE -import AbsTreeDefs -import AugTreeDefs -import ConstructorMonad - --- Augment the abstract syntax tree to contain extra info - -augmentT :: AugTree a -> (AugTree a,Int) -augmentT t = initLbl (mapCM augM t) 1 - -augM :: AugTree a -> LblM (AugTree a) -augM t | isLeaf t = getNewLbl `thenLbl` \name -> - returnLbl (doAug (Just name) t) - | otherwise = returnLbl (doAug Nothing t) - - -doAug :: Maybe Int -> AugTree a -> AugTree a -doAug x t - | isLeaf t = - let (Just n) = x - in - updateAugTree x - (singletonOL n,singletonOL n,singletonOL n,([],[])) - False - t - - | isUn t = let (AUGINFO (fst,lst,chs,(flwNI,flwI)) nullable) = getAugInfo (child t) - followers = if isRepeatable t && isInterval t then - (flwNI, - foldS (update fst) flwI lst ) - else - if isRepeatable t && (not (isInterval t)) then - (foldS (updateNoInt fst) flwNI lst, - foldS (update fst) flwI lst) - else - (flwNI,flwI) - - auginfo = (fst,lst,chs,followers) - in - if isInterval t then - updateAugTree x auginfo (nullable || (getMin t == 0)) t - else if isOpt t || isStar t then - updateAugTree x auginfo True t - else - updateAugTree x auginfo nullable t - - | isBin t = - let - (AUGINFO (fst1,lst1,chs1,(flw1a,flw1b)) null1) = getAugInfo (left t) - (AUGINFO (fst2,lst2,chs2,(flw2a,flw2b)) null2) = getAugInfo (right t) - - in - if isCon t then - let - fstn = if null1 then - unionOL fst1 fst2 - else - fst1 - lstn = if null2 then - unionOL lst1 lst2 - else - lst2 - nulln = null1 && null2 - - followers = - (foldS (updateNoInt (firstPos (right t))) - (flw1a++flw2a) - (lastPos (left t)) - , - foldS (update (firstPos (right t))) - (flw1b++flw2b) - (lastPos (left t)) - ) - - in - updateAugTree x (fstn,lstn,unionOL chs1 chs2,followers) nulln t - - - else -- is an "ALT" node - let followers = (flw1a++flw2a,flw1b++flw2b) - in - updateAugTree x (unionOL fst1 fst2, unionOL lst1 lst2, unionOL chs1 chs2,followers) - (null1 || null2) t - - - -updateNoInt :: OrdList Int -- followers - -> Int -- node to follow - -> [(Int,BagRE Int)] -- current follow info - -> [(Int,BagRE Int)] -- updated follow info - -updateNoInt newnodes node [] = [(node,listToBagRE newnodes)] -updateNoInt newnodes node ((cn,cfollows):xs) = - if cn == node then - (cn,cfollows `unionBagRE` (listToBagRE newnodes)):xs - else if cn < node then - (cn,cfollows):(updateNoInt newnodes node xs) - else - (node, listToBagRE newnodes):(cn,cfollows):xs - - -update :: OrdList Int -- followers - -> Int -- node to follow - -> [(Int,OrdList Int)] -- current follow info - -> [(Int,OrdList Int)] -- updated follow info - -update newnodes node [] = [(node,newnodes)] -update newnodes node ((cn,cfollows):xs) = - if cn == node then - (cn,cfollows `unionOL` newnodes):xs - else if cn < node then - (cn,cfollows):(update newnodes node xs) - else - (node,newnodes):(cn,cfollows):xs - - - diff --git a/testsuite/driver/basicRxLib/BagRE.hs b/testsuite/driver/basicRxLib/BagRE.hs deleted file mode 100644 index 0441a4ff3f..0000000000 --- a/testsuite/driver/basicRxLib/BagRE.hs +++ /dev/null @@ -1,43 +0,0 @@ -module BagRE where - -{- - a Bag module, also offering minusBag, based on finite map. --} - -import FiniteMap -import OrdList - -type BagRE a = FiniteMap a Int - - -emptyBagRE :: BagRE a -emptyBagRE = emptyFM - -unitBagRE :: elt -> BagRE elt -unitBagRE x = unitFM x 1 - -unionBagRE :: Ord elt => BagRE elt -> BagRE elt -> BagRE elt -unionBagRE b1 b2 = plusFM_C (+) b1 b2 - -listToBagRE :: Ord elt => [elt] -> BagRE elt -listToBagRE xs = foldr (\x fm -> addToFM_C (+) fm x 1) emptyFM xs - -bagREToList :: Ord elt => BagRE elt -> [elt] -bagREToList b = foldFM (\k el xs -> xs ++ take el (repeat k)) [] b - -elemBagRE :: Ord elt => elt -> BagRE elt -> Bool -elemBagRE e b = maybeToBool (lookupFM b e) - where - maybeToBool (Just x) = True - maybeToBool Nothing = False - -filterBagRE :: Ord elt => (elt -> Bool) -> BagRE elt -> BagRE elt -filterBagRE f b = filterFM (\ a b -> f a) b - -minusBagRE :: Ord elt => BagRE elt -> BagRE elt -> BagRE elt -minusBagRE b1 b2 = (filterFM (\ a b -> b > 0)) (plusFM_C (-) b1 b2) - -bagREToOL :: Ord elt => BagRE elt -> OrdList elt -bagREToOL = (listToOL.keysFM) - - diff --git a/testsuite/driver/basicRxLib/CompileREP.hs b/testsuite/driver/basicRxLib/CompileREP.hs deleted file mode 100644 index c27818d6b7..0000000000 --- a/testsuite/driver/basicRxLib/CompileREP.hs +++ /dev/null @@ -1,45 +0,0 @@ -module CompileREP where - - -import OrdList - -import FiniteMap -import AbsTreeDefs -import AugTreeDefs -import Assertions(Assert) -import Matchers(Matcher,MatcherFlag) -import NFADefs -import ParsePolyRegexp(mkAbstreeP) -import IsPrefix(isPrefix) -import ConstructorMonad(initLbl) -import AugmentTree(augmentT) -import MakeNFA(makeNFA) - - -compileRegexpP :: (Ord a,Enum a,Read a,Show a) => - String -- AbsTree in string format - -> [MatcherFlag]-- matcher flags - -> [Matcher a]-- Extra matcher functions - -> [Assert a] -- extra assertions - -> Maybe - (NFA a, -- The Resulting NFA - Int, -- The last node of the NFA - [Node], -- The initial nodes of the NFA - Int, -- The number of intervals in the AbsTree - Bool) -- Whether we are just matching a prefix - - -compileRegexpP re flags fs as - = let abstree1 = (mkAbstreeP re fs as) - abstree = case abstree1 of - (Just a) -> a - prefix = isPrefix abstree - (augtree,numnodes) = augmentT abstree - nfa1 = initNFA numnodes - (nfa2,numintervals) = makeNFA augtree nfa1 - initnodes = firstPos augtree - in - case abstree1 of - Just a -> - Just (nfa2,numnodes,initnodes,numintervals,False) - Nothing -> Nothing diff --git a/testsuite/driver/basicRxLib/CompileREPB.hs b/testsuite/driver/basicRxLib/CompileREPB.hs deleted file mode 100644 index 4a6bdc8f94..0000000000 --- a/testsuite/driver/basicRxLib/CompileREPB.hs +++ /dev/null @@ -1,46 +0,0 @@ -module CompileREPB where - - -import OrdList - -import FiniteMap -import AbsTreeDefs -import AugTreeDefs -import Assertions(Assert) -import Matchers(Matcher,MatcherFlag) -import NFADefs -import ParsePolyRegexpBasic(mkAbstreePB) -import IsPrefix(isPrefix) -import ConstructorMonad(initLbl) -import AugmentTree(augmentT) -import MakeNFA(makeNFA) - - - -compileRegexpPB :: (Eq a,Read a,Show a) => - String -- AbsTree in string format - -> [MatcherFlag]-- matcher flags - -> [Matcher a]-- Extra matcher functions - -> [Assert a] -- extra assertions - -> Maybe - (NFA a, -- The Resulting NFA - Int, -- The last node of the NFA - [Node], -- The initial nodes of the NFA - Int, -- The number of intervals in the AbsTree - Bool) -- Whether we are just matching a prefix - - -compileRegexpPB re flags fs as - = let abstree1 = (mkAbstreePB re fs as) - abstree = case abstree1 of - (Just a) -> a - prefix = isPrefix abstree - (augtree,numnodes) = augmentT abstree - nfa1 = initNFA numnodes - (nfa2,numintervals) = makeNFA augtree nfa1 - initnodes = firstPos augtree - in - case abstree1 of - Just a -> - Just (nfa2,numnodes,initnodes,numintervals,False) - Nothing -> Nothing diff --git a/testsuite/driver/basicRxLib/CompileRES.hs b/testsuite/driver/basicRxLib/CompileRES.hs deleted file mode 100644 index 66683c2853..0000000000 --- a/testsuite/driver/basicRxLib/CompileRES.hs +++ /dev/null @@ -1,58 +0,0 @@ -module CompileRES where - - -import FiniteMap -import AbsTreeDefs -import AugTreeDefs(firstPos,Aug) -import Assertions(Assert) -import Matchers(Matcher,MatcherFlag) -import NFADefs(Node,NFA,NFANode,initNFA) -import ParseStringRegexp(mkAbstreeS) -import IsPrefix(isPrefix) -import ConstructorMonad(initLbl) -import AugmentTree(augmentT) -import MakeNFA(makeNFA) - - -compileRegexpS :: - String -- AbsTree in string format - -> [MatcherFlag]-- matcher flags - -> [Matcher Char]-- Extra matcher functions - -> [Assert Char] -- extra assertions - -> Maybe - (NFA Char,-- The Resulting NFA - Int, -- The last node of the NFA - [Node], -- The initial nodes of the NFA - Int, -- The number of intervals in the AbsTree - Bool) -- Whether we are just matching a prefix - - -compileRegexpS re flags fs as - = let (abstree0) = (mkAbstreeS re fs as flags) - abstree = case abstree0 of - (Just a) -> a - prefix = isPrefix abstree - (augtree,numnodes) = augmentT abstree - nfa1 = initNFA numnodes - (nfa2,numintervals) = makeNFA augtree nfa1 - initnodes = firstPos augtree - in - case abstree0 of - Just a -> - Just (nfa2,numnodes,initnodes,numintervals,prefix) - Nothing -> Nothing - - - - -makeit re = - let (abstree0) = (mkAbstreeS re [] [] []) - abstree = case abstree0 of - (Just a) -> a - prefix = isPrefix abstree - (augtree,numnodes) = augmentT abstree - nfa1 = initNFA numnodes - (nfa2,numintervals) = makeNFA augtree nfa1 - initnodes = firstPos augtree - in - augtree diff --git a/testsuite/driver/basicRxLib/ConstructorMonad.hs b/testsuite/driver/basicRxLib/ConstructorMonad.hs deleted file mode 100644 index 3d094f4fca..0000000000 --- a/testsuite/driver/basicRxLib/ConstructorMonad.hs +++ /dev/null @@ -1,95 +0,0 @@ -module ConstructorMonad - (LblM, - initLbl, - returnLbl, - getNewLbl, - thenLbl, - thenLbl_, - foldPostM,foldPreM,mapCM,foldlM - ) - -where - - -import FiniteMap -import AbsTreeDefs - -infixr 9 `thenLbl_`, `thenLbl` - -{- This monad is used to allow easy inclusion of - a name supply for the compileRegexp functions -} - -type LblM a = Int -- name supply - -> (a, -- result of the LblM action - Int) -- the remaining name supply - --- run the Lbl thing and return result, and new name supply --- (number of names used = new_name_supply - 1) -initLbl :: LblM a -> Int -> (a,Int) -initLbl act ns = case (act ns) of - (result,new_ns) -> (result,new_ns-1) - --- make a LblM thing from a thing -returnLbl :: a -> LblM a -returnLbl thing ns = (thing,ns) - --- get a new name from the name supply -getNewLbl :: LblM Int -getNewLbl ns = (ns,ns+1) - --- sequence two actions; the second uses the result of the first -thenLbl :: LblM a -> (a -> LblM c ) -> LblM c -thenLbl act1 act2 ns - = case (act1 ns ) of - (result,newns) -> act2 result newns - --- sequence two actions; the second doesn't care about the result of --- the first -thenLbl_ :: LblM a -> LblM c -> LblM c -thenLbl_ act1 act2 ns - = case (act1 ns ) of - (_,newns) -> act2 newns - - -foldPostM :: (AbsTree a b -> c -> LblM c) -> c -> AbsTree a b -> LblM c - -foldPostM f res re | isLeaf re = f re res -foldPostM f res re | isUn re = foldPostM f res (child re) `thenLbl` \res1 -> - f re res1 -foldPostM f res re | isBin re = foldPostM f res (left re) `thenLbl` \res1 -> - foldPostM f res1 (right re) `thenLbl` \res2 -> - f re res2 - - -foldPreM :: (AbsTree a b -> c -> LblM c) -> c -> AbsTree a b -> LblM c - -foldPreM f res re | isLeaf re = f re res -foldPreM f res re | isUn re = f re res `thenLbl` \res1 -> - foldPreM f res1 (child re) -foldPreM f res re | isBin re = f re res `thenLbl` \res1 -> - foldPreM f res1 (left re) `thenLbl` \res2 -> - foldPreM f res2 (right re) - - -mapCM :: (AbsTree a b -> LblM (AbsTree a b)) -> AbsTree a b - -> LblM (AbsTree a b) -mapCM f t | isLeaf t = f t - | isUn t = mapCM f (child t) `thenLbl` \res1 -> - f (updateChild res1 t) - | isBin t = mapCM f (left t) `thenLbl` \res1 -> - mapCM f (right t) `thenLbl` \res2 -> - f (updateLeft res1 (updateRight res2 t)) - - -foldrM :: (a -> b -> LblM b) -> b -> [a] -> LblM b -foldrM f a [] = returnLbl a -foldrM f a (x:xs) = foldrM f a xs `thenLbl` \res -> - f x res - - - -foldlM :: (a -> b -> LblM b) -> b -> [a] -> LblM b -foldlM f a [] = returnLbl a -foldlM f a (x:xs) = f x a `thenLbl` \res -> - foldlM f res xs - diff --git a/testsuite/driver/basicRxLib/ExecRE.hs b/testsuite/driver/basicRxLib/ExecRE.hs deleted file mode 100644 index 63b1540776..0000000000 --- a/testsuite/driver/basicRxLib/ExecRE.hs +++ /dev/null @@ -1,562 +0,0 @@ -module ExecRE - (execRegexp, - ReturnREM) -where - -import OrdList -import FiniteMap -import Array -import List -import NFADefs - -{- A REM contains matchinfo used when running the nfa, nfaRun returns -a list of them. If there is no altered interval or subexp info, & -every match is of the same length then said list will be of length 1, -otherwise we can take the first of them, which reaches a totally final -state. This makes the match in a totally perlesque manner. --} - -type REM a = (OrdList Node, -- current nodes - ([a], -- what matched - [a], -- what's left to match - Altered (Intervals, -- state of all interval matches - Subexps a))) -- state of all subexp matches - - -mkInitrem :: [REM a] -- takes an initial - -> [a] -- and rest of input - -> [REM a] -- adds "rest of input" info -mkInitrem [(ns,(ms,[],other))] xs = [(ns,(ms,xs,other))] - - -type ReturnREM a = Maybe (FiniteMap String [a], -- subexp matchinfo - [a], -- what's before the match - [a], -- what matched - [a]) -- what's after the match - -type Intervals = Array Int Interval -- state of all interval matches -data Interval = NILL -- not entered interval yet - | IN Int -- IN n: still inside interval, - -- and have matched n times, - | OUT -- have matched the minimum number of times - -- required for a min interval - deriving Eq - -type Subexps a = FiniteMap String (SE a) -- state of all subexp matches - -data SE a = OPEN [a] -- OPEN xs: entered subexp, and matched xs so far - | CLOSED [a] -- CLOSED xs: finished subexp, and matched xs - -data Altered a = OLD a -- subexp or interval info is unchanged - | NEW a -- subexp or interval info has changed - -extractcore :: Altered a -> a -extractcore (OLD a) = a -extractcore (NEW a) = a - -execRegexp :: (Show a,Read a,Eq a) => - (NFA a, -- the nfa - Node, -- the final node of the nfa - [Node], -- the initial nodes of the nfa - Int, -- number of intervals in nfa - Bool) -- whether we're just matching a prefix - - -> [a] -- input list - -> ReturnREM a -- either "Nothing", or "Just" the - -- match results - -execRegexp (nfa,final,inits,numintervals,pre) inp = - let - initSE = emptyFM - initIntervals = listArray (0,numintervals) (repeat NILL) - initREM = [(inits,([],[],OLD (initIntervals,initSE)))] - resultses ses = (mapFM change.snd.extractcore) ses - - in - case (runNFA nfa final initREM (mkInitrem initREM inp) [] inp pre) of - ([],[]) -> Nothing - (((_,(whole,after,ses)):xs),before) -> - Just (resultses ses,reverse before, - reverse whole,after) - - -change :: String -> SE a -> [a] -change _ (OPEN xs) = xs -change _ (CLOSED xs) = xs - -runNFA :: (Eq a) => - NFA a -- the nfa - -> Node -- the final node of the nfa - -> [REM a] -- the initial REM info, for - -- restarting search - -> [REM a] -- the current REM info - -> [a] -- everything before the start of the - -- current match - -> [a] -- everything after the start of the - -- current match - -> Bool -- whether we're just matching a prefix - - -> ([REM a],-- the new REM info, after this step - [a]) -- what's in the input list before the - -- current match -{- runNFA - - we step through the nfa. A REM stores match info, and current nodes. - We are therefore currently in all the states stored in the REM's. - All the nodes in one REM state have matched exactly the same - thing, and have the same interval information. - We keep matching until we reach a purely final state, or until - a match fails. If we were to stop when one of the initial states - was a final one, then we'd stop after a repeatable thing had - matched only once. Eg a* will initially be in a final state, as it can - match 0 times. - - We don't stop when there is no input left. Instead we try - matching again! Why? Assertions are full nodes. They may have to - be applied at the end of a match, when there is no input left. - eg a$ against "a". after matching the "a" node there's no input - left. But we wish to try firing the "$" (suffix) node. - Assertions are usually the only nodes that can fire against empty - input. A user defined matcher function could match empty input, - this case is ignored so runNFA could loop infinitely. Eg a<<1>>* - where function 1 matches the empty list would loop, as we keep - trying to match <<1>> as it's repeatable, and it never fails. - But then this would happen whatever we do. - - Order matters. We're only interested in when the head of the REM - list reaches a final state. If we put left's of "|" before right, - and move to beginning of repeatable expression before moving out - of it then we have fulfilled the matching semantics. Non-greedy - nodes simply put results of moving out of interval before those of - moving to start of interval. --} - -runNFA nfa final initrem rems@((ns,(_,as,_)):_) before rest prefix - | ns ==[final] = (rems,before) - -- in only final state so definitely finished - -- if we wanted to do full longest matching then we should not stop - -- until all states are final - -runNFA nfa final initrem rems@((ns,(_,as,_)):_) before rest prefix - = case (foldr (stepSingleREM nfa final before) [] rems) of - [] -> case (filter ((final `elem`). fst) rems) of - [] -> if prefix then - ([],[]) - else - case rest of - [] -> ([],[]) -- no more to match against - (r:rs) -> -- there is input left so try - runNFA nfa final initrem (mkInitrem initrem rs) (r:before) rs prefix - -- try matching from next - -- position - (rem:_) -> ([rem],before) - newrems@(y:ys) -> - runNFA nfa final initrem newrems before rest prefix - - - - - - -stepSingleREM :: (Eq a) => - NFA a -- the nfa - -> Node -- the final node of the nfa - -> [a] -- everything before the start of - -- current match - -> REM a -- the current REM we're stepping on - -> [REM a] -- the results of REM steps so far - -> [REM a] -- the new results of REM steps - -stepSingleREM nfa final before (cns,(ms,as,extrabit)) sofar - = (foldS (combine (nfa,(ms,as,extractcore extrabit)) before) [] cns) - ++ sofar - -- step each node, from the current list & combine results - - where - combine (nfa,stuff@(_,_,oldextra)) before n newrems - = case (nfaStep nfa stuff before n) of - - [] -> newrems -- that node did not match - - (rem@(ns,(ms,as,OLD _)):[]) -> -- node matched & subexp - -- and interval info unchanged - -- by stepping it through - case newrems of - [] -> [rem] -- tis the first REM so just - all@((lastns,(lastms,_,OLD _)):xs) -> - (unionOL ns lastns,(ms,as,OLD oldextra)):xs - -- this and last REM matched the same - -- thing so combine them - all@(x:xs) -> rem:all - -- last REM did something fancy so just - -- add new one to front - rems -> - rems ++ newrems - -- this REM did something fancy so add it to front - -nfaStep :: Eq a => - NFA a -- the nfa - -> ([a], -- what matched so far - [a], -- what's left to match - (Intervals, -- interval info - Subexps a)) -- subexp info - -> [a] -- what's before the match - -> Node -- the current node we're going to step - -> [REM a] -- the results (possibly several for several) - -nfaStep nfa (whole,after,extra@(intervals,subexps)) before x - = case nfa!x of -- get the node - (Node n next ints ses) -> - let bef = whole ++ before - in - case (fire n bef after subexps) of - -- fire it on current input - Nothing -> [] -- it failed to match anything - (Just (ms,as)) -> -- it did match - let newms = (reverse ms) ++ whole -- we're returning - -- match back to front - - -- handle changes to subexps and intervals - -- no subexp or interval changes here - dealfancy [] [] = - -- if length ms >1 then we've got something else - -- fancy so just tell em we've got NEW stuff - if length ms == 1 then - [(next,(newms,as,OLD extra))] - else - [(next,(newms,as,NEW extra))] - - -- interval changes only - dealfancy (x:xs) [] - = case (dealInts ints (intervals,next)) of - s -> - map (dointerval newms as subexps) (nub s) - - -- subexp changes only - dealfancy [] (y:ys) - = case (dealSubexps1 ses subexps ms next) of - newsubs -> - map (dosubexp newms as intervals) newsubs - - - -- interval and subexp changes - dealfancy (x:xs) (y:ys) - = case (dealInts ints (intervals,next)) of - - s -> - concat - (map (\(ints,ns)-> - map (dosubexp newms as ints) - (dealSubexps1 ses subexps ms ns)) - (nub s)) - - - dosubexp newms as ints (subs,nexts) = - (nexts,(newms,as,NEW (ints,subs))) - dointerval newms as subs (ints,nexts) = - (nexts,(newms,as,NEW (ints,subs))) - - in - dealfancy ints ses - -dealInts :: - [IntervalInfo] -- interval changes fired by node - -> (Intervals,[Node]) - -> [(Intervals, -- new intervals - [Node])] -- new possibly changed next nodes - -dealInts [] (intervals,ns) = [(intervals,ns)] -dealInts (i:intRules) (intervals,ns) = - case (handle i ns intervals) of - - {- got an IntContinue from handle, we therefore store - the current interval state, with the next nodes. - when we come back round we'll try finishing - the interval in them. - If greedy we store state first so that we match longest. - (ie end interval in last place possible) - otherwise (non-greedy) store state second so that try - with this iteration of interval ending here first - -} - (_,Nothing,non_greedy,Just ns1,_) -> - if non_greedy then - (dealInts intRules (intervals,ns))++[(intervals,ns1)] - else - (intervals,ns1):(dealInts intRules (intervals,ns)) - - -- done some form of interval start or end - (x,Just el,non_greedy,nodes1,nodes2) -> - let newints = intervals // [(x,el)] - in - case (nodes1,nodes2) of - - -- done an interval start, so store nothing but move on - (Nothing,Nothing) -> - dealInts intRules (newints,ns) - - -- not looped min times yet, store this state, but - -- don't move on - (Just ns1,Nothing) -> - [(newints,ns1)] - - -- looped max times, so don't store state yet. instead - -- try passing on to higher intervals - (Nothing,Just ns2) -> - dealInts intRules (newints,ns2) - - {- between min & max, or got min only interval - either way store the state (going back to start - of interval) and move on to higher intervals - non-greedy move on to higher ones first, - greedy move to higher ones second, so we try - continuing this interval as many times as possible first - -} - (Just ns1,Just ns2) -> - if non_greedy then - (dealInts intRules (newints,ns2))++[(newints,ns1)] - else - (newints,ns1):(dealInts intRules (newints,ns2)) - - where - - - handle :: - IntervalInfo -- interval change we're trying - -> [Node] -- what the next nodes are supposed to be - -> Intervals -- current intervals - -> (Int, -- interval to update - Maybe Interval, -- what to update it with - Bool, -- non-greedy - Maybe [Node],-- nodes to record - Maybe [Node])-- nodes if leaving an interval - -- or mid - - - -- just reset interval x, to NILL - handle (Reset x) ns intervals = - (x,Just NILL,False,Nothing,Nothing) - - -- start up interval x, if the lookbehind assertion holds - -- if it's already started then do nothing - handle (IntStart x) ns intervals = - case (intervals!x) of - NILL -> (x,Just (IN 1),False,Nothing,Nothing) - - (IN y) -> (x,Just (IN y),False,Nothing,Nothing) - OUT -> (x,Just OUT,False,Nothing,Nothing) - - - -- continue a greedy interval, by sending back the follow nodes - -- of this one, then we store current interval state - handle (IntContinue ns1) ns - intervals = - (error "nothing",Nothing,False,Just ns1,Nothing) - - -- continue a greedy interval, by sending back the follow nodes - -- of this one, then we store the current interval state - handle (NGIntContinue ns1) ns - intervals = - (error "nothing",Nothing,True,Just ns1,Nothing) - - -- end a minmax interval, if we've not looped enough then just - -- just try moving to ns1 (start), if we're between min & max - -- try moving to ns1 (start) & ns2 (outside), ie send both back - -- if we've matched max times send back ns2 (outside) - handle (IntEnd x min max ns1 ns2) ns - intervals = - case (intervals!x) of - NILL -> error "NILL in IntEnd" - (IN y) -> - if y < min then - (x,Just (IN (y+1)),False,Just ns1,Nothing) - else if (y>=min && y<max) then - (x,Just (IN (y+1)),False,Just ns1,Just ns2) - else -- y > max - (x,Just NILL,False,Nothing,Just ns2) - - OUT -> error "out in IntEnd" - - -- end a min interval, if we've not looped enough then just - -- just try moving to ns1 (start), (send ns1 back) - -- if we've matched min times try moving to start & to outside - -- send back ns1 (start) & ns2 (outside) - handle (MinEnd x min ns1 ns2) ns - intervals = - - case (intervals!x) of - NILL -> error "NILL in MinEnd" - (IN y) -> if y < min then - (x,Just (IN (y+1)),False,Just ns1,Nothing) - else - (x,Just OUT,False,Just ns1,Just ns2) - OUT -> (x,Just OUT,False,Just ns1,Just ns2) - - - {- - ns2 is nodes after end of interval, ns1 start of interval - so want to jump to ns2 in preference to ns1 - -} - - -- end a min interval, if we've not looped enough then just - -- just try moving to ns1 (start), (send ns1 back) - -- if we've matched min times try moving to start & to outside - -- send back ns2 (outside) & ns1 (start) - handle (NGMinEnd x min ns1 ns2) ns - intervals = - - case (intervals!x) of - NILL -> error "NILL in MinEnd" - (IN y) -> if y < min then - (x,Just (IN (y+1)),True,Just ns1,Nothing) - else - - (x,Just OUT,True, Just ns1, Just ns2) - - OUT -> (x,Just OUT,True, Just ns1, Just ns2) - - -- end a minmax NGinterval, if we've not looped enough then just - -- just try moving to ns1 (start), if we're between min & max - -- try moving to ns2 (outside) & ns1 (start), ie send both back - -- if we've matched max times send back ns2 (outside) - handle (NGIntEnd x min max ns1 ns2) ns - intervals = - case (intervals!x) of - NILL -> error "NILL in IntEnd" - (IN y) -> - if y < min then - (x,Just (IN (y+1)),True,Just ns1,Nothing) - else if (y>=min && y<max) then - (x,Just (IN (y+1)),True,Just ns1,Just ns2) - else -- y >= max - (x,Just NILL,True,Nothing,Just ns2) - - OUT -> error "out in IntEnd" - - - -fire :: Eq a => NFAElem a -- the matching function wrapped in an NFA node - -> [a] -- everything before start of this match - -> [a] -- list to match against - -> Subexps a -- the subexp info (incase of backreferencing) - -> - Maybe ([a], -- what matched - [a])-- what's left over - -fire (NFABack x f) before inps subexps = - case getsubexp (lookupFM subexps x) of - Nothing -> Nothing - (Just ms) -> f ms before inps - - -fire (NFAEl f) before inps _ = f before inps - -fire NFAFinal before inps _ = Just ([],inps) - - -getsubexp:: Maybe (SE a)-- a subexpression - -> Maybe [a]-- what it's match contains, or nothing if its - -- not been initialised --- both errors should have been caught at initial parser level -getsubexp Nothing = Nothing -- can happen, eg ((a)|(b))\\3 against "aa" - -- b don't match anything, so is still NOUGHT -getsubexp (Just (OPEN as)) = Just as-- can happen eg ((a){2})\\1 as - -- closed at 2nd (\\1) node, and subexp - -- stuff done AFTER matching -getsubexp (Just (CLOSED as)) = Just as -{- -dealsubexps :: [SubexpInfo] -- subexp alterations from this node - -> Subexps a -- the current subexps status - -> [a] -- what to match against - -> Subexps a -- the new subexps status - -dealsubexps [] subexps ms = subexps - -dealsubexps (s:ses) subexps ms - = let - updateSubStart el1 (OPEN ms) = - case el1 of -- subexp's current status is - OPEN xs -> OPEN (xs ++ ms)-- currently open so add more - CLOSED xs -> OPEN ms -- closed so restart it - updateSubMid el1 (OPEN ms) = - case el1 of -- subexp's current status is - OPEN xs -> OPEN (xs ++ ms) -- currently open so add more - CLOSED xs -> OPEN (xs ++ ms) -- closed too early, add more - - - newsubexps = - case s of - (NFASubStart x) -> -- start a subexpression - addToFM_C updateSubStart subexps x (OPEN ms) - -- default is to just newly open it - (NFASubMid x) -> -- in middle of a subexpression - addToFM_C updateSubMid subexps x (OPEN ms) - -- default should never be needed. - - (NFASubEnd x) -> -- close a subexpression - case (lookupFM subexps x) of -- subexp's current status is - Nothing -> subexps -- unstarted, leave it - -- (eg match (a*)b against b, - -- a never fires, and so will - -- get Nothing in b - (Just (OPEN xs)) -> addToFM subexps x (CLOSED xs) - -- open so close it - (Just (CLOSED xs)) -> addToFM subexps x (CLOSED xs) - -- its closed so keep it closed - - in - newsubexps --dealsubexps ses newsubexps ms --} - - -dealSubexps1 :: [SubexpInfo] -- subexp alterations from this node - -> Subexps a -- the current subexps status - -> [a] -- what to match against - -> [Node] -- the next nodes, need to divide up to - -- prevent premature closure - -> [(Subexps a,-- the new subexps status - [Node])] - -dealSubexps1 [] subexps ms ns = [(subexps,ns)] - -dealSubexps1 (s:ses) subexps ms ns - = let - updateSubAdd el1 (OPEN ms) = - case el1 of -- subexp's current status is - OPEN xs -> OPEN (xs ++ ms)-- currently open so add more - CLOSED xs -> OPEN ms -- closed so restart it - - (newsubexps, newnodes) = - case s of - (NFASubAdd x) -> -- add match info to a subexpression - (addToFM_C updateSubAdd subexps x (OPEN ms),Nothing) - -- default is to just newly open it - - (NFASubContinue nexts) -> -- this node may close a subexp - -- but there are others (nexts) after it, that could also - -- do so. Make sure we don't close it prematurely. - -- Need this complexity to allow things like (a*b*)* to work. - (subexps,Just (nexts `intersectOL` ns,ns `minusOL` nexts)) - - (NFASubEnd x) -> -- close a subexpression - case (lookupFM subexps x) of -- subexp's current status is - Nothing -> (subexps,Nothing) - -- unstarted, leave it - -- (eg match (a*)b against b, - -- a never fires, and so will - -- get Nothing in b - (Just (OPEN xs)) -> (addToFM subexps x (CLOSED xs),Nothing) - -- open so close it - (Just (CLOSED xs)) -> (addToFM subexps x (CLOSED xs),Nothing) - -- its closed so keep it closed - - in - case newnodes of - Nothing -> dealSubexps1 ses newsubexps ms ns - (Just (ns1,ns2)) -> - (subexps,ns1):dealSubexps1 ses subexps ms ns2 - - - - - - - diff --git a/testsuite/driver/basicRxLib/FiniteMap.hs b/testsuite/driver/basicRxLib/FiniteMap.hs deleted file mode 100644 index 298d331019..0000000000 --- a/testsuite/driver/basicRxLib/FiniteMap.hs +++ /dev/null @@ -1,87 +0,0 @@ -module FiniteMap where - -type FiniteMap key elt = [(key,elt)] - --- Building -emptyFM :: FiniteMap key elt -emptyFM = [] - -unitFM :: key -> elt -> FiniteMap key elt -unitFM key elt = [(key,elt)] - -listToFM :: [(key,elt)] -> FiniteMap key elt -listToFM l = l - --- Adding to - -addToFM :: Eq key => FiniteMap key elt -> key -> elt -> FiniteMap key elt -addToFM [] key elt = [(key,elt)] -addToFM ((k,e):xs) key elt = if (key == k) then - (k,elt):xs - else - (k,e):(addToFM xs key elt) - -addToFM_C :: Eq key => (elt -> elt -> elt) - -> FiniteMap key elt -> key -> elt -> FiniteMap key elt - -addToFM_C f [] key elt = [(key,elt)] -addToFM_C f ((k,e):xs) key elt = if key == k then - (k,f e elt):xs - else - (k,e):(addToFM_C f xs key elt) - - --- Combining - - -- Bind right argument over left -plusFM :: Eq key => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt -plusFM fm1 fm2 = foldr (\(k,e) fm -> addToFM fm k e) fm1 fm2 - - -- Combines bindings for the same thing with given function -plusFM_C :: Eq key => (elt -> elt -> elt) - -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt -plusFM_C f fm1 fm2 = foldr (\(k,e) fm -> addToFM_C f fm k e) fm1 fm2 - ---Interrogating - -sizeFM :: FiniteMap key elt -> Int -sizeFM fm = length fm - -isEmptyFM :: FiniteMap key elt -> Bool -isEmptyFM [] = True -isEmptyFM (x:xs) = False - -elemFM :: Eq key => key -> FiniteMap key elt -> Bool -elemFM key fm = key `elem` (keysFM fm) - -lookupFM :: Eq key => FiniteMap key elt -> key -> Maybe elt -lookupFM [] key = Nothing -lookupFM ((k,e):fm) key = if key == k then - Just e - else - lookupFM fm key - - - ---Mapping,Folding,Filtering - -foldFM :: (key -> elt -> a -> a) -> a -> FiniteMap key elt -> a -foldFM f k fm = foldr (\(x,y)-> f x y) k fm - -mapFM :: (key -> elt1 -> elt2) -> FiniteMap key elt1 -> FiniteMap key elt2 -mapFM f fm = map (\(x,y) -> (x,f x y)) fm - -filterFM :: (key -> elt -> Bool) -> FiniteMap key elt - -> FiniteMap key elt -filterFM f fm = filter (\(a,b) -> f a b) fm - --- Listifying -fmToList :: FiniteMap key elt -> [(key,elt)] -fmToList xs = xs - -keysFM :: FiniteMap key elt -> [key] -keysFM fm = map fst fm - -eltsFM :: FiniteMap key elt -> [elt] -eltsFM fm = map snd fm - diff --git a/testsuite/driver/basicRxLib/Global.hs b/testsuite/driver/basicRxLib/Global.hs deleted file mode 100644 index ea30734364..0000000000 --- a/testsuite/driver/basicRxLib/Global.hs +++ /dev/null @@ -1,12 +0,0 @@ -module Global where - -data Maybe a = Nothing | Just a - -maybeToBool Nothing = False -maybeToBool (Just _) = True -maybeToA Nothing = error "tried to get something from Maybe Nothing" -maybeToA (Just x) = x -catMaybes [] = [] -catMaybes (Nothing:xs) = catMaybes xs -catMaybes (Just x:xs) = x:catMaybes xs - diff --git a/testsuite/driver/basicRxLib/HandleInterval.hs b/testsuite/driver/basicRxLib/HandleInterval.hs deleted file mode 100644 index d73b331998..0000000000 --- a/testsuite/driver/basicRxLib/HandleInterval.hs +++ /dev/null @@ -1,232 +0,0 @@ -module HandleInterval - (handleInterval) -where - -{- adds interval info to the nfa, eg a{1,3} stuff - augtree is being parsed in post order, so - nested intervals: child has lower number than parent, - left child lower than right child --} - -import OrdList -import FiniteMap -import BagRE -import AbsTreeDefs -import AugTreeDefs -import ConstructorMonad -import NFADefs - - -handleInterval :: AugTree a -- The Info from the augmented tree - -> [(Int,BagRE Int)]-- the follow info from root of whole tree - -> NFA a -- The current nfa - -> LblM (NFA a) -- The updated nfa -handleInterval t followers nfa = - let - rfollows = filter (\(a,b) -> a `elem` (lastPos t)) followers - newfollows = map (\(a,b)->bagREToOL (b `minusBagRE` (getFollow a (followInfoNoInt t )))) rfollows - getFollow a fs = case (filter ((== a).fst) fs) of - [] -> emptyBagRE - ((_,x):_) -> x - - nexts = foldr (\ns next -> next `unionOL` ns) emptyOL newfollows - {- the nodes we go to after leaving the interval, nexts, are all follow - nodes, not including those produced by operators inside the - interval. ie with (ab+){2} the nexts nodes would be [1,3] where - node 1 is "a", and node 3 is the final node. - -} - - in - getNewLbl `thenLbl` \name -> - returnLbl (dealInterval t name nexts nfa) - - -dealInterval :: AugTree a -- The Info from the augmented tree - -> Int -- The label for this interval - -> OrdList Node -- the next nodes that follow after interval - -> NFA a -- The current nfa - -> NFA a -- The updated nfa - -{- For the expression, e, rooted with this node: -} - -{- MIN x - It starts in any of the first nodes of e - It ends in any of the last nodes of e, - Before matching x times, at end of e can go to start of e. - After matching x times, can go to start of e, or next after e. - It must be reset in any node following the last nodes - of e. (nested mins otherwise are never restarted.) - Interval may end prematurely if the last node of the - interval is nullable. In this case add IntContinues, - to make sure we try match through the necessary number - of times. - Eg (ab*c?){4} may end with a, b or c, - we would have [(2,[2,3]),(3,[3])] to allow the *, and - + operators to match as many times as possible - note with (a+|b){2}, that b should not follow a. We - don't face this problem as we're using follownodes - based on what's inside the interval. - With (a{3,}b){4,}, we don't want Node "a" linking to - Node "a" (with an IntContinue), as this would - interfere with the operation - of the inner interval. So we wish to use the follow - nodes without interval information added. --} - -dealInterval t name nexts nfa | isMin t && not (isNg t) - = let - fs = firstPos t - chs = children t - ls = lastPos t - nfa1 = foldS (updateNode (addIntervalStart name)) nfa fs - nfa2 = foldr (addIntContinue False) nfa1 (followsWithoutInt ls t) - nfa3 = foldS (updateNode (addMinEnd name (getMin t) fs nexts)) nfa2 ls - in - foldS (updateNode (addReset name)) nfa3 - (minusOL (followNodes ls nfa) chs) - -{- NGMIN x - As for MIN above, except that given choice we want to - move out of interval as soon matched x times. (if possible) - --} - -dealInterval t name nexts nfa | isMin t - = let - fs = firstPos t - chs = children t - ls = lastPos t - nfa1 = foldS (updateNode (addIntervalStart name)) nfa fs - nfa2 = foldr (addIntContinue True) nfa1 (followsWithoutInt ls t) - nfa3 = foldS (updateNode (addNGMinEnd name (getMin t) fs nexts)) nfa2 ls - in foldS (updateNode (addReset name)) nfa3 - (minusOL (followNodes ls nfa) chs) - - -{- MINMAX x y - Starts in any of the first nodes of e - Ends in any of the last nodes of e, - Before matching x times, at end of e can go to start of e. - Between x and y times, can go to start of e, or next after e. - After matching y times, can go to next after e. - It must be reset in any node following the last nodes - of e. (nested intervals otherwise are never restarted.) - Interval may end prematurely if the last node of the - interval is nullable. We therefore use IntContinues as - discussed above. --} - - -dealInterval t name nexts nfa |isMinmax t && not (isNg t) - = let - fs = firstPos t - chs = children t - ls = lastPos t - (x,y) = getMinMax t - nfa1 = foldS (updateNode (addIntervalStart name)) nfa fs - nfa2 =foldr (addIntContinue False) nfa1 (followsWithoutInt ls t) - nfa3 = foldS (updateNode (addIntEnd name x y fs nexts)) nfa2 ls - in - foldS (updateNode (addReset name)) nfa3 - (minusOL (followNodes ls nfa) chs) - -{- NGMINMAX x y - Same as MINMAX except that between x and y times, - prefer to go t next after e, than start of e --} - -dealInterval t name nexts nfa | isMinmax t - = let fs = firstPos t - chs = children t - ls = lastPos t - (x,y) = getMinMax t - nfa1 = foldS (updateNode (addIntervalStart name)) nfa fs - nfa2 = foldr (addIntContinue True) nfa1 (followsWithoutInt ls t) - nfa3 = foldS (updateNode (addNGIntEnd name x y fs nexts)) nfa2 ls - in - foldS (updateNode (addReset name)) nfa3 - (minusOL (followNodes ls nfa) chs) - - -addIntervalStart :: Int -- the label for the Interval - -> NFANode a -- The node (of the nfa) to be updated - -> NFANode a -- The updated node - -addIntervalStart name node - = changeInts (IntStart name:getInts node) node - - - -addMinEnd :: Int -- the label for the interval - -> Int -- the minimum number of times we have to match - -> OrdList Node -- all the first nodes of the interval - -> OrdList Node -- all the follow nodes, excluding those that - -- are formed from inside interval - -> NFANode a -- The node (of the nfa) to be updated - -> NFANode a -- The updated node - -addMinEnd name min fs nexts node = - changeInts ((getInts node)++[MinEnd name min fs nexts]) node - - -addNGMinEnd :: Int -- the label for the interval - -> Int -- the minimum number of times we have to match - -> OrdList Node -- all the first nodes of the interval - -> OrdList Node -- all the follow nodes, excluding those that - -- are formed from inside interval - -> NFANode a -- The node (of the nfa) to be updated - -> NFANode a -- The updated node - -addNGMinEnd name min fs nexts node = - changeInts ((getInts node)++[NGMinEnd name min fs nexts]) node - -addReset :: Int -- the label for the interval - -> NFANode a -- The node (of the nfa) to be updated - -> NFANode a -- The updated node - - -addReset name node - = changeInts (Reset name:getInts node) node - -- always want to Reset. as will never reset on - -- node that started min interval, can't do harm to - -- put it first - - -addIntEnd :: Int -- the label for the interval - -> Int -- the min number of times we can loop - -> Int -- the max number of times we can loop - -> OrdList Node -- all the first nodes of the interval - -> OrdList Node -- all the follow nodes, excluding those that - -- are formed from inside interval - -> NFANode a -- The node (of the nfa) to be updated - -> NFANode a -- The updated node - - -addIntEnd name min max fs nexts node - = changeInts ((getInts node)++[IntEnd name min max fs nexts]) node - - -addNGIntEnd :: Int -- the label for the interval - -> Int -- the min number of times we can loop - -> Int -- the max number of times we can loop - -> OrdList Node -- all the first nodes of the interval - -> OrdList Node -- all the follow nodes, excluding those that - -- are formed from inside interval - -> NFANode a -- The node (of the nfa) to be updated - -> NFANode a -- The updated node - -addNGIntEnd name min max fs nexts node - = changeInts ((getInts node)++[NGIntEnd name min max fs nexts]) node - - - -addIntContinue :: Bool -- whether it's non-greedy - -> (Node,[Node]) -- the node to modify & all follow nodes of it - -> NFA a -- the nfa to update - -> NFA a -- the updated nfa - -addIntContinue non_greedy (nodeLbl,nexts) nfa = - updateNode (\node -> (changeInts ((getInts node) ++[newint]) node)) - nodeLbl nfa - where - newint = if non_greedy then - NGIntContinue nexts - else - IntContinue nexts - diff --git a/testsuite/driver/basicRxLib/HandleSubexp.hs b/testsuite/driver/basicRxLib/HandleSubexp.hs deleted file mode 100644 index ab6973c3f7..0000000000 --- a/testsuite/driver/basicRxLib/HandleSubexp.hs +++ /dev/null @@ -1,117 +0,0 @@ -module HandleSubexp - (handleSubexp) -where - -{- This module provides functions to add subexp info to the nfa. --} - - - -import FiniteMap -import OrdList -import AbsTreeDefs -import AugTreeDefs -import NFADefs - - - -{- handleSubexp - - add information about a subexp node, assumes it has been - given a subexp node. --} - -handleSubexp :: AugTree a -> NFA a -> NFA a -handleSubexp t nfa - = dealSubexp (getSEName t) t nfa - - -{- dealSubexp i t nfa - Update an nfa with info about subexpression labelled i. The node - contains a few bits of info: - - firsPos - all the nodes that can start the subexpression - lastPos - all the nodes that can end the subexpression - children - all the leaf nodes in the subexpression - (child t) - the immediate child node of the subexpression. - - When we enter a subexpression, we want to start recording what - the subexp matched, with mkSubAdd i. We do this for all the child - nodes of the subexp - - We want to close the subexp when we leave it. This happens - on any of the last nodes in the subexp. (lastPos n) - - We don't want to end the subexp prematurely. We therefore use - NFASubContinue ns. This gives all the follownodes of a - particular lastpos node. These are calculated simply using the - subexpression, not operators outside of it. So - with (a+|b+)*, "a" will be a follownode of "a", and "b" of "b", - but "b" will not follow "a", and vice versa, as the outer STAR - operator will not be included. This therefore assumes that the - NFA has only follow information for the regexp rooted at the - current subexpression. - --} - -dealSubexp :: String -- the label for the new node - -> AugTree a -- the root of tree is node to update with - -> NFA a -- the nfa to update - -> NFA a - -dealSubexp i t nfa = - let - fs = firstPos t - chs = children t - ls = lastPos t - new1nfa = - foldS (updateNode (mkSubAdd i)) nfa chs - -- start or continue a subexp node but add info about - -- what matched here. - - - new2nfa = - foldr mkSubContinue new1nfa (follows ls t) - -- a subexp should not be stopped prematurely, try - -- stopping it later first. We continue with the - -- subexp, moving to any follow nodes of that lastpos - -- node first, before moving on. - -- This allows things like it@(a+), to work, as the - -- inner repeatable operations will be allowed to - -- work. As we're only allowing operators insidee the - -- subexpression to work, we don't have a problem with - -- the likes of (a+|b+)*: "a" is not a follownode of b, - -- and vice versa. - - in - foldS (updateNode (mkSubend i)) new2nfa ls - - -mkSubAdd :: String -- the label for the subexp - -> NFANode a -- the node (of the nfa) to be updated - -> NFANode a -- the node with new substart info in it - -mkSubAdd i node - = changeSES ((NFASubAdd i):(getSES node)) node - -mkSubend :: String -- the label for the subexp - -> NFANode a -- the node (of the nfa) to be updated - -> NFANode a -- the node with new subend info in it - -mkSubend i node - = changeSES (getSES node ++ [NFASubEnd i]) node - - - -mkSubContinue :: (Node,[Node]) -- the node to modify & all follow nodes of it - -> NFA a -- the nfa to update - -> NFA a -- the updated nfa - -mkSubContinue (nodeLbl,nexts) nfa = - updateNode (\node -> (changeSES (getSES node ++ [NFASubContinue nexts]) node)) - nodeLbl nfa - - - - - - diff --git a/testsuite/driver/basicRxLib/IsPrefix.hs b/testsuite/driver/basicRxLib/IsPrefix.hs deleted file mode 100644 index 5c52cc9d68..0000000000 --- a/testsuite/driver/basicRxLib/IsPrefix.hs +++ /dev/null @@ -1,17 +0,0 @@ -module IsPrefix - (isPrefix) -where - - - -import FiniteMap - -import AbsTreeDefs - -isPrefix :: AbsTree a b -> Bool -isPrefix t | isLeaf t = getPrefix t - | isUn t = isPrefix (child t) - | isCon t = (isPrefix (left t)) - | isAlt t = (isPrefix (left t)) && (isPrefix (right t)) - - diff --git a/testsuite/driver/basicRxLib/MakeNFA.hs b/testsuite/driver/basicRxLib/MakeNFA.hs deleted file mode 100644 index a208a5b887..0000000000 --- a/testsuite/driver/basicRxLib/MakeNFA.hs +++ /dev/null @@ -1,45 +0,0 @@ -module MakeNFA - (makeNFA) -where - - -import OrdList -import FiniteMap -import Matchers -import Assertions -import AbsTreeDefs -import AugTreeDefs -import NFADefs -import ConstructorMonad -import HandleSubexp -import HandleInterval -import MakeNFANode -import BagRE - -{- build an NFA from the augmented abstract syntax tree, given an - initial nfa - (contains follow info, interval info, and subexp info) --} - ---makeNFA :: AugTree a -> NFA a -> (NFA a,Int) -makeNFA t nfa = - case (initLbl (foldPostM (handleNode (followInfoNoInt t)) nfa t) 1) of - (nfa,x) -> (addFollowInfo t nfa,x) - --- Add subexp and interval info for nfa - -handleNode :: [(Int,BagRE Int)] -> AugTree a -> NFA a -> LblM (NFA a) - -handleNode fllws t nfa = - returnLbl (makeNode t nfa) `thenLbl` \newnfa -> - (if isInterval t then - handleInterval t fllws newnfa - else - returnLbl (newnfa)) `thenLbl` \newnfa1 -> - if isSub t then - returnLbl (handleSubexp t newnfa1) - else - returnLbl (newnfa1) - - - diff --git a/testsuite/driver/basicRxLib/MakeNFANode.hs b/testsuite/driver/basicRxLib/MakeNFANode.hs deleted file mode 100644 index d779d2c26d..0000000000 --- a/testsuite/driver/basicRxLib/MakeNFANode.hs +++ /dev/null @@ -1,44 +0,0 @@ -module MakeNFANode - (makeNode, - addFollowInfo) -where - - -import OrdList -import FiniteMap -import Matchers -import Assertions -import AbsTreeDefs -import AugTreeDefs -import NFADefs - -{- build an Nfa node from the augmented abstract syntax tree node, given an - initial nfa node. - (contains no follow info, or interval info, or subexp info) --} - -makeNode :: AugTree a -> NFA a -> NFA a -makeNode t nfa = case (getLbl t) of - (Just x) -> updateNode (mkNfanode x t) x nfa - (Nothing) -> nfa - -mkNfanode :: Int -> AugTree a -> NFANode a -> NFANode a -mkNfanode n re cnode - | isElem re = - let f = getElem re - in mkNfaEl f cnode - - | isBref re = - let (x,f) = getBref re - in - mkNfaBack x f cnode - - | otherwise = mkNfaFinal n cnode - -{- Add info about what follows each node, to the nfa -} - -addFollowInfo :: AugTree a -> NFA a -> NFA a -addFollowInfo t nfa = foldr addtoNFA nfa (followInfo t) - where - addtoNFA (x,nexts) nfa = updateNode (changeNexts nexts) x nfa - diff --git a/testsuite/driver/basicRxLib/Matchers.hs b/testsuite/driver/basicRxLib/Matchers.hs deleted file mode 100644 index 0ac6edf43d..0000000000 --- a/testsuite/driver/basicRxLib/Matchers.hs +++ /dev/null @@ -1,146 +0,0 @@ -module Matchers - (MatcherFlag(..), - initFlags, - MatcherImpl, - Matcher, - wrapMatcher, - regseq, - isEl, - isWordChar, - matchEls, - matchAny, - matchAnyBut, - matchNull, - matchBref, - matchIBref) - -where - -import Char -import FiniteMap - -data MatcherFlag = Global_Match -- replace every occurrence of match - -- rather than just the first in "subst" - | Case_Insensitive -- ignore case when using strings - | Case_Sensitive -- don't ignore case when using strings - | Single_Line -- treat string as a single line - -- . matches \n - | Multi_Line -- treat string as multi-line - -- (^ ($) matches from beginning (end) of line) - | Default_Line -- . does not match \n, but - -- (^ does not match from beginning of line...) - - deriving (Read,Show,Eq) - -{- -instance Read MatcherFlag where - readsPrec 0 "Global_Match" = [(Global_Match,"")] - readsPrec 0 "Case_Insensitive" = [(Case_Insensitive,"")] - readsPrec 0 "Case_Sensitive" = [(Case_Sensitive,"")] - readsPrec 0 "Single_Line" = [(Single_Line,"")] - readsPrec 0 "Multi_Line" = [(Multi_Line,"")] - readsPrec 0 "Default_Line" = [(Default_Line,"")] --} - -initFlags :: [MatcherFlag] -> [(String,MatcherFlag)] -initFlags mflgs = let - casere = if Case_Insensitive `elem` mflgs then - Case_Insensitive - else - Case_Sensitive - linere = if Multi_Line `elem` mflgs then - Multi_Line - else if Single_Line `elem` mflgs then - Single_Line - else - Default_Line - in - [("case",casere),("line",linere)] - -type Matcher a = [a] -- what to match against - -> Maybe ([a], -- what matched - [a]) -- everything after match - -wrapMatcher :: Matcher a -> MatcherImpl a -wrapMatcher f bef inp = f inp - -type MatcherImpl a = [a] -- everything before start of this match - -- (allows lookbehind assertions) - -> [a] -- what to match against - -> Maybe ([a],-- what matched - [a])-- everything after match - -regseq :: (MatcherImpl a) -- a matcher function - -> (MatcherImpl a) -- the next matcher function - -> (MatcherImpl a) -- both functions sequenced so - -- one follows the other -regseq f g bef af - = case (f bef af) of - Nothing -> Nothing - Just (ms,as) -> - case (g ((reverse ms)++bef) as) of - Nothing -> Nothing - Just (ms1,as1) -> Just (ms++ms1,as1) - ---isEl takes an element and returns a matching function for it. -isEl :: Eq a => a -> a -> Bool -isEl c = (c ==) - --- match a \w -isWordChar c = isAlphaNum c || (isEl '_') c || (isEl '\'') c - - - --- create a matcher that accepts an element if matched by f -matchEls :: Eq a => (a -> Bool) -> MatcherImpl a -matchEls f _ [] = Nothing -matchEls f _ (a:as) = if f a then - Just ([a],as) - else - Nothing - --- create a matcher that matches 0 elements of any non-empty list, -matchNull :: MatcherImpl a -matchNull _ [] = Nothing -matchNull _ (x:xs) = Just ([],x:xs) - --- create a matcher that matches any element -matchAny :: MatcherImpl a -matchAny _ [] = Nothing -matchAny _ (a:as) = Just ([a],as) - - --- create a matcher that matches any element except '\n' -matchAnyBut :: MatcherImpl Char -matchAnyBut _ [] = Nothing -matchAnyBut _ (a:as) = if a /= '\n' then - Just ([a],as) - else - Nothing - --- create a backreference matcher -matchBref :: Eq a => [a] -- what to try and match - -> MatcherImpl a -- a matcher function - -matchBref [] _ inps = Just ([],inps) -matchBref (x:xs) _ [] = Nothing -matchBref (x:xs) _ (i:inps) = if x==i then - case (matchBref xs [] inps) of - Nothing -> Nothing - Just (ms,afts) -> Just (i:ms,afts) - else - Nothing - --- create a backreference matcher, that is case insensitive (for strings) -matchIBref :: String -- what to try and match - -> MatcherImpl Char -- a matcher function - -matchIBref [] _ inps = Just ([],inps) -matchIBref (x:xs) _ [] = Nothing -matchIBref (x:xs) _ (i:inps) = if (toUpper x) == (toUpper i) then - case (matchIBref xs [] inps) of - Nothing -> Nothing - Just (ms,afts) -> Just (i:ms,afts) - else - Nothing - diff --git a/testsuite/driver/basicRxLib/NFADefs.hs b/testsuite/driver/basicRxLib/NFADefs.hs deleted file mode 100644 index 358f9ac105..0000000000 --- a/testsuite/driver/basicRxLib/NFADefs.hs +++ /dev/null @@ -1,180 +0,0 @@ -module NFADefs where - - -import OrdList -import BagRE -import Matchers -import FiniteMap -import Array - -type Node = Int -- an NFA node is referenced by an integer - -type NFA a = Array Int (NFANode a) -- The NFA itself - -data NFAElem a = - NFAEl (MatcherImpl a) -- matcher function - - | NFABack String -- matches same as the nth subexpression - ([a] -> MatcherImpl a)-- the function to use to match - - | NFAFinal -- Final state of NFA - - -{- NFASubAdd n -> we are inside of subexp n, so add match info to it - NFASubContinue ns -> we're at a possible end of the subexp, but - don't close it prematurely, try closing it in - the other nodes as well. - NFASubEnd n -> we have now left subexp n, so close it down --} - -data SubexpInfo = NFASubAdd String - | NFASubContinue (OrdList Node) - | NFASubEnd String - - -{- IntStart n -> we have now entered the nth Interval - - IntEnd n min max ns1 ns2 -> we have now reached the end of an - iteration of the nth Interval, - it's a MinMax interval, - min the min number of times we can loop, - max is the max number of times we can loop - ns1, nodes go to before reaching min - firspos nodes of interval - ns2, nodes go to after reaching max - lastpos nodes of interval - - MinEnd n min ns1 ns2 -> we have now reached the end of an iteration - of the nth interval, - it's a Min interval, - min is the min number of times we can loop, - ns1, nodes we can go to before reaching min - firspos nodes of interval - ns2, last nodes of the interval - lastpos nodes of interval - - - Reset n -> we have now finished with the nth interval, - by moving on to the following node. We - want to reset it, in case we - come back to the start of it later. - (Important if we've got nested intervals) - - - NGIntEnd n min max ns1 ns2 -> As for IntEnd above, except we're - doing non-greedy matching. When - between min and max matches, we - therefore want to try jumping out - of the interval before we try - continuing it. More on this in - ExecRE module. - - NGMinEnd n min max ns1 ns2 -> Non-Greedy MinEnd equiv. - When we've matched min times, - therefore want to try jumping out - of the interval before we try - continuing it. More on this in - ExecRE module. --} - -data IntervalInfo = IntStart Int - | IntContinue (OrdList Node) - | NGIntContinue (OrdList Node) - | IntEnd Int Int Int (OrdList Node) (OrdList Node) - | MinEnd Int Int (OrdList Node) (OrdList Node) - | Reset Int - | NGIntEnd Int Int Int (OrdList Node) (OrdList Node) - | NGMinEnd Int Int (OrdList Node) (OrdList Node) - -{- Node n ns is ses -> NFA state that matches something using "n". - It will then jump to states "ns". - Unless node is part of an interval, then - nextnodes is calculated with "is". - Node may be part of subexpression, dealt with - using "ses". --} - -data NFANode a = Node (NFAElem a) (OrdList Node) [IntervalInfo] [SubexpInfo] - - - --- building nfa - -initNFA :: Int -- number of nodes in NFA - -> NFA a -- make an initial nfa with the correct number of nodes -initNFA x - = listArray (1,x) (repeat (Node NFAFinal emptyOL [] [])) - -mkNfaBack :: String -- which subexp to refer to - -> ([a] -> MatcherImpl a) -- the matcher function to use - -> NFANode a -- current node - -> NFANode a -- an NFA node that does this -mkNfaBack x f (Node _ nexts ses ints) - = Node (NFABack x f) nexts ses ints - -mkNfaEl :: MatcherImpl a -- a matcher function for simple element - -> NFANode a -- current node - -> NFANode a -- a simple NFA element -mkNfaEl f (Node _ nexts ses ints) - = Node (NFAEl f) nexts ses ints - -mkNfaFinal :: Int -- the label of the final node - -> NFANode a -- current node - -> NFANode a -- a final node, that jumps back to itself if fired -mkNfaFinal n (Node _ _ ses ints) = Node NFAFinal (singletonOL n) ses ints - - --- updating nfa - -updateNode :: (NFANode a -> NFANode a) --updating function - -> Node -- label of node to update - -> NFA a -- nfa to update - -> NFA a -- updated nfa -updateNode f el nfa = nfa // [(el, f (nfa!el))] - -alterNode :: NFANode a -- new nfa node - -> Node -- label of node to update - -> NFA a -- old nfa - -> NFA a -- updated nfa -alterNode newnode el nfa = nfa // [(el, newnode)] - -changeNexts :: [Node] -- the new next nodes - -> NFANode a -- the actual nfa node to update - -> NFANode a -- that updated node -changeNexts newnexts (Node n _ int se) = Node n newnexts int se - -changeInts :: [IntervalInfo] -- the new interval info - -> NFANode a -- the actual nfa node to update - -> NFANode a -- that updated node -changeInts newint (Node n nexts _ se) = Node n nexts newint se - -changeSES :: [SubexpInfo] -- the new subexp info - -> NFANode a -- the actual nfa node to update - -> NFANode a -- that updated node -changeSES newses (Node n nexts int _) = Node n nexts int newses - - --- interrogating the nfa - -getNfaElem :: NFANode a -> NFAElem a -getNfaElem (Node n _ _ _) = n - -getNexts :: NFANode a -> [Node] -getNexts (Node _ nexts _ _) = nexts - -getInts :: NFANode a -> [IntervalInfo] -getInts (Node _ _ ints _) = ints - -getSES :: NFANode a -> [SubexpInfo] -getSES (Node _ _ _ ses) = ses - - -followNodes :: OrdList Int -- some nodes of an nfa - -> NFA a -- the nfa - -> OrdList Int -- all the nodes that follow after those nodes - -followNodes s nfa = foldS (combine nfa) emptyOL s - where - combine nfa e s1 = unionOL (after (nfa!e)) s1 - after (Node _ xs _ _) = xs - diff --git a/testsuite/driver/basicRxLib/OrdList.hs b/testsuite/driver/basicRxLib/OrdList.hs deleted file mode 100644 index 9922f5d39b..0000000000 --- a/testsuite/driver/basicRxLib/OrdList.hs +++ /dev/null @@ -1,70 +0,0 @@ -module OrdList where - -{- an OrdList is an ordered list, with no duplicates, and set like - operations on it --} - -type OrdList a = [a] - - -emptyOL :: Ord a => OrdList a -emptyOL = [] - -unionOL :: Ord a => OrdList a -> OrdList a -> OrdList a -unionOL s1 s2 = foldr addEl s2 s1 - -listToOL :: Ord a => [a] -> OrdList a -listToOL xs = (foldr addEl [] xs) - -addEl :: Ord a => - a -- element - -> OrdList a -- ordered list - -> OrdList a -- list with element added to it -addEl e [] = [e] -addEl e (n:ns) = if n == e then - n:ns - else if n<e then - n:(addEl e ns) - else - e:n:ns - -intersectOL :: Ord a => OrdList a -> OrdList a -> OrdList a -intersectOL s1 s2 = foldr (inboth s2) [] s1 - where - inboth :: Ord a => OrdList a -> a -> OrdList a -> OrdList a - inboth s e new = if e `elem` s then - addEl e new - else - new - -singletonOL :: Ord a => a -> OrdList a -singletonOL x = [x] - -minusOL :: Ord a => OrdList a -> OrdList a -> OrdList a -minusOL s1 s2 = foldr minusel s1 s2 - where - minusel e [] = [] - minusel e (n:ns) = if n == e then - ns - else if n<e then - n:(minusel e ns) - else - n:ns - -member :: Ord a => a -> OrdList a -> Bool -member x [] = False -member x (s:ss) = if x == s then - True - else if x>s then - member x ss - else - False - -foldS :: (a -> b -> b) -> b -> OrdList a -> b -foldS = foldr - -mapS :: (a -> b) -> OrdList a -> OrdList b -mapS = map - - - diff --git a/testsuite/driver/basicRxLib/ParsePolyRegexp.hs b/testsuite/driver/basicRxLib/ParsePolyRegexp.hs deleted file mode 100644 index 6b21b36f78..0000000000 --- a/testsuite/driver/basicRxLib/ParsePolyRegexp.hs +++ /dev/null @@ -1,189 +0,0 @@ -module ParsePolyRegexp - (mkAbstreeP) -where - -{- -This module provides functions to parse a polymorphic regexp. -The main one is mkAbstree. It takes a string form of the AbsTree, and -returns an Abstract Syntax tree for it. --} - -import Matchers -import Assertions -import Parsers -import FiniteMap -import AbsTreeDefs - - --- Turn the regular expression concrete syntax into an abstract syntax tree - -mkAbstreeP :: (Read a, Show a, Eq a, Ord a, Enum a) => - String -- The regexp in string form - -> [Matcher a] -- Extra matcher functions - -> [Assert a] -- extra assertions - -> Maybe (AbsTree a b) -- An abstract syntax tree - -mkAbstreeP [] fs as = Just mkEnd -mkAbstreeP re fs as - = let - matchresults = initParser nnRegexp re fs as [] - (match,rest) = head matchresults - wellformed = (not (null matchresults)) && (null rest) - realmatch = addEnd match - in - if wellformed then - Just realmatch - else - Nothing - - --- --- grammar for regular expressions: --- -{- - Elem = "<" (character)+ ">" - Atom = "." | "<<" Int ">>" | Element. - | "[" ["^"] (Element + | ( Element "-" Element)+) +"]". - XAtom = "\\" Int | "(" AbsTree ")" | "(?:" AbsTree ")" | Atom . - ExtAtom = "(?=" Int ")" - | (XAtom ["*" | "+" | "?" - | "{" Int "}" - | "{" Int "," [Int] "}" - ] ["?"]) - | Atom + - | XAtom. - Factor = "^" ExtAtom + "$". - AbsTree = Factor "|" (Factor *). --} - -nnElem :: (Read a,Show a) => (Parser Char a (Matcher a) (Assert a)) -nnElem = lit '<' ..+ star (butC ['\\','>'] ||| (lit '\\' ..+ anyC)) +.. lit '>' <<< read - --- parse an atom -nnAtom :: (Read a, Show a, Eq a, Ord a, Enum a) - => (Parser Char (AbsTree a b) (Matcher a) (Assert a)) -nnAtom - = - (lit '<' ..+ lit '<' ..+ anyPos +.. lit '>' +.. lit '>') - `then_Px` (\x -> lookupFn x) - <<< mkEl.wrapMatcher - ||| lit '.' <<< const (mkEl matchAny) - ||| lit '[' ..+ opt (lit '^') - +.+ (plus ((plus (nnElem +.+ lit '-' ..+ nnElem) <<< handlerange) - ||| (plus nnElem <<< handleelems))) - +.. lit ']' <<< mkEl.matchEls.handleclass - ||| nnElem <<< mkEl.matchEls.isEl - - where - - handleelems es = (`elem` es) - handlerange es = foldr1 combine (map inrange es) - inrange (e1,e2) c = c >=e1 && c<=e2 - combine f g c = (f c) || (g c) - - -- deal with a class - handleclass ([],fs) = (foldr1 combine fs) - handleclass ([f],fs) = (not.(foldr1 combine fs)) - - - --- parse an extra atom -nnXAtom :: (Read a,Show a, Eq a, Ord a, Enum a) - => (Parser Char (AbsTree a b) (Matcher a) (Assert a)) - -nnXAtom = - - (lit '(' ..+ nnRegexp +.. lit ')' - ||| (lit ' ' ..+ (plus (satisfy isWordChar)) +.. lit '@') +.+ lit '(' ..+ nnRegexp +.. lit ')' <<< handlesub - ||| lit '$' ..+ lit '{' ..+ (plus (satisfy isWordChar)) +.. lit '}' - <<< (\x -> mkBackref x matchBref) - ||| nnAtom) - where - handlesub (s,n) = mkSub s n - - - --- parse an extended atom -nnExtAtom :: (Read a, Show a, Eq a, Ord a, Enum a) - => (Parser Char (AbsTree a b) (Matcher a) (Assert a)) - -nnExtAtom = (star - ((lit '(' ..+ lit '?' ..+ lit '=' ..+ anyPos +.. lit ')') - `then_Px` (\x -> lookupAs x) <<< doAssert) <<< combineAssert) - +.+ ((nnXAtom +.+ opt ((lit '*' <<< const mkStar - ||| lit '+' <<< const mkPlus - ||| lit '?' <<< const mkOpt - ||| lit '{' ..+ anyPos +.. lit '}' - <<< helpexact - ||| lit '{' ..+ anyInt +.+ - lit ',' +.+ (opt anyInt) - +.. lit '}' <<< helpminmax - ) +.+ opt (lit '?') ) - <<< helprepeat) - ||| plus (nnAtom `notFollowedBy` oneofC "*+?{") <<< combine - ||| nnXAtom) - +.+ - (star - ((lit '(' ..+ lit '?' ..+ lit '=' ..+ anyPos +.. lit ')') - `then_Px` (\x -> lookupAs x) <<< doAssert) <<< combineAssert) - <<< helper - where - - helpexact x = mkExact x - - helpminmax (x,(a,[])) = mkMin x - helpminmax (x,(a,[y])) - = if x <= y then - mkMinMax x y - else - error "Invalid interval in Regular Expression" - - helprepeat (ea,[]) = ea - helprepeat (ea,[(f,[])]) = f ea - helprepeat (ea,[(f,[_])]) = mkNg (f ea) - - - combine = (mkEl . foldl1 regseq . map getElem) - - combineAssert [] = [] - combineAssert s@(x:xs) = [(mkEl.foldl1 regseq) s] - helper ([],(t,[])) = t - helper ([e1],(t,[])) = mkCon e1 t - - helper ([e1],(t,[e2])) = mkCon e1 (mkCon t e2) - - helper ([],(t,[e2])) = mkCon t e2 - - --- parse a factor -nnFactor :: (Read a, Show a, Eq a, Ord a, Enum a) - => (Parser Char (AbsTree a b)(Matcher a) (Assert a) ) - -nnFactor = (opt (lit '^')) - +.+ (plus nnExtAtom) - +.+ (opt (lit '$')) - <<< helper - where - helper ([],(xs,[])) = combine xs -- not prefix or suffix - helper ([_],(xs,[])) = mkCon (justPrefix (mkEl (doAssert prefix))) (combine xs) - -- is prefix - helper ([_],(xs,[_])) = mkCon (justPrefix (mkEl (doAssert prefix))) - (mkCon (combine xs) - (mkEl (doAssert suffix))) - -- is prefix & suffix - helper ([],(xs,[_])) = mkCon (combine xs) (mkEl (doAssert suffix)) - combine (x:[]) = x - combine s@(x:xs) = foldl1 mkCon s - - --- parse a regexp -nnRegexp :: (Read a,Show a, Eq a, Ord a, Enum a) - => (Parser Char (AbsTree a b) (Matcher a) (Assert a)) - -nnRegexp = nnFactor +.+ star (lit '|' ..+ nnFactor) <<< helper - where - helper (ea,[]) = ea - helper (ea, s@(x:xs))= foldl mkAlt ea s - - - diff --git a/testsuite/driver/basicRxLib/ParsePolyRegexpBasic.hs b/testsuite/driver/basicRxLib/ParsePolyRegexpBasic.hs deleted file mode 100644 index e2f7347509..0000000000 --- a/testsuite/driver/basicRxLib/ParsePolyRegexpBasic.hs +++ /dev/null @@ -1,185 +0,0 @@ -module ParsePolyRegexpBasic - (mkAbstreePB) -where - -{- -This module provides functions to parse a polymorphic regexp. -The main one is mkAbstree. It takes a string form of the AbsTree, and -returns an Abstract Syntax tree for it. --} - -import Matchers -import Assertions -import Parsers -import FiniteMap -import AbsTreeDefs - - --- Turn the regular expression concrete syntax into an abstract syntax tree - -mkAbstreePB :: (Read a, Show a, Eq a) => - String -- The regexp in string form - -> [Matcher a] -- Extra matcher functions - -> [Assert a] -- extra assertions - -> Maybe (AbsTree a b) -- An abstract syntax tree - -mkAbstreePB [] fs as = Just mkEnd -mkAbstreePB re fs as - = let - matchresults = initParser nnRegexpPB re fs as [] - (match,rest) = head matchresults - wellformed = (not (null matchresults)) && (null rest) - realmatch = addEnd match - in - if wellformed then - Just realmatch - else - Nothing - - --- --- grammar for regular expressions: --- -{- - Elem = "<" (character)+ ">" - Atom = "." | "<<" Int ">>" | Element. - | "[" ["^"] Element +"]". - XAtom = "\\" Int | "(" AbsTree ")" | "(?:" AbsTree ")" | Atom . - ExtAtom = "(?=" Int ")" - | (XAtom ["*" | "+" | "?" - | "{" Int "}" - | "{" Int "," [Int] "}" - ] ["?"]) - | Atom + - | XAtom. - Factor = "^" ExtAtom + "$". - AbsTree = Factor "|" (Factor *). --} - -nnElemPB :: (Read a, Show a) => (Parser Char a (Matcher a) (Assert a)) -nnElemPB = lit '<' ..+ star (butC ['\\','>'] ||| (lit '\\' ..+ anyC)) +.. lit '>' <<< read - --- parse an atom -nnAtomPB :: (Read a, Show a, Eq a) - => (Parser Char (AbsTree a b) (Matcher a) (Assert a)) -nnAtomPB - = - (lit '<' ..+ lit '<' ..+ anyPos +.. lit '>' +.. lit '>') - `then_Px` (\x -> lookupFn x) - <<< mkEl.wrapMatcher - ||| lit '.' <<< const (mkEl matchAny) - ||| lit '[' ..+ opt (lit '^') - +.+ (plus nnElemPB <<< handleelems) - +.. lit ']' <<< mkEl.matchEls.handleclass - ||| nnElemPB <<< mkEl.matchEls.isEl - - where - - handleelems es = (`elem` es) - - -- deal with a class - handleclass ([],g) = g - handleclass ([f],g) = (not.g) - - - --- parse an extra atom -nnXAtomPB :: (Read a, Show a, Eq a) - => (Parser Char (AbsTree a b) (Matcher a) (Assert a)) - -nnXAtomPB = - - (lit '(' ..+ nnRegexpPB +.. lit ')' - ||| (lit ' ' ..+ (plus (satisfy isWordChar)) +.. lit '@') +.+ lit '(' ..+ nnRegexpPB +.. lit ')' <<< handlesub - ||| lit '$' ..+ lit '{' ..+ (plus (satisfy isWordChar)) +.. lit '}' - <<< (\x -> mkBackref x matchBref) - ||| nnAtomPB) - where - handlesub (s,n) = mkSub s n - - - --- parse an extended atom -nnExtAtomPB :: (Read a, Show a, Eq a) - => (Parser Char (AbsTree a b) (Matcher a) (Assert a)) - -nnExtAtomPB = (star - ((lit '(' ..+ lit '?' ..+ lit '=' ..+ anyPos +.. lit ')') - `then_Px` (\x -> lookupAs x) <<< doAssert) <<< combineAssert) - +.+ ((nnXAtomPB +.+ opt ((lit '*' <<< const mkStar - ||| lit '+' <<< const mkPlus - ||| lit '?' <<< const mkOpt - ||| lit '{' ..+ anyPos +.. lit '}' - <<< helpexact - ||| lit '{' ..+ anyInt +.+ - lit ',' +.+ (opt anyInt) - +.. lit '}' <<< helpminmax - ) +.+ opt (lit '?') ) - <<< helprepeat) - ||| plus (nnAtomPB `notFollowedBy` oneofC "*+?{") <<< combine - ||| nnXAtomPB) - +.+ - (star - ((lit '(' ..+ lit '?' ..+ lit '=' ..+ anyPos +.. lit ')') - `then_Px` (\x -> lookupAs x) <<< doAssert) <<< combineAssert) - <<< helper - where - - helpexact x = mkExact x - - helpminmax (x,(a,[])) = mkMin x - helpminmax (x,(a,[y])) - = if x <= y then - mkMinMax x y - else - error "Invalid interval in Regular Expression" - - helprepeat (ea,[]) = ea - helprepeat (ea,[(f,[])]) = f ea - helprepeat (ea,[(f,[_])]) = mkNg (f ea) - - - combine = (mkEl . foldl1 regseq . map getElem) - - combineAssert [] = [] - combineAssert s@(x:xs) = [(mkEl.foldl1 regseq) s] - helper ([],(t,[])) = t - helper ([e1],(t,[])) = mkCon e1 t - - helper ([e1],(t,[e2])) = mkCon e1 (mkCon t e2) - - helper ([],(t,[e2])) = mkCon t e2 - - --- parse a factor -nnFactorPB :: (Read a, Show a, Eq a) - => (Parser Char (AbsTree a b)(Matcher a) (Assert a) ) - -nnFactorPB = (opt (lit '^')) - +.+ (plus nnExtAtomPB) - +.+ (opt (lit '$')) - <<< helper - where - helper ([],(xs,[])) = combine xs -- not prefix or suffix - helper ([_],(xs,[])) = mkCon (justPrefix (mkEl (doAssert prefix))) (combine xs) - -- is prefix - helper ([_],(xs,[_])) = mkCon (justPrefix (mkEl (doAssert prefix))) - (mkCon (combine xs) - (mkEl (doAssert suffix))) - -- is prefix & suffix - helper ([],(xs,[_])) = mkCon (combine xs) (mkEl (doAssert suffix)) - combine (x:[]) = x - combine s@(x:xs) = foldl1 mkCon s - - --- parse a regexp -nnRegexpPB :: (Read a, Show a, Eq a) - => (Parser Char (AbsTree a b) (Matcher a) (Assert a)) - -nnRegexpPB = nnFactorPB +.+ star (lit '|' ..+ nnFactorPB) <<< helper - where - helper (ea,[]) = ea - helper (ea, s@(x:xs))= foldl mkAlt ea s - - - diff --git a/testsuite/driver/basicRxLib/ParseStringRegexp.hs b/testsuite/driver/basicRxLib/ParseStringRegexp.hs deleted file mode 100644 index efa0a0fc7e..0000000000 --- a/testsuite/driver/basicRxLib/ParseStringRegexp.hs +++ /dev/null @@ -1,349 +0,0 @@ -module ParseStringRegexp - (mkAbstreeS) -where - -{- -This module provides functions to parse a string regexp. -The main one is mkAbstree. It takes a string form of the AbsTree, and -returns an Abstract Syntax tree for it. --} - - -import Matchers -import Assertions -import Parsers -import FiniteMap -import AbsTreeDefs -import Char - --- Turn the regular expression concrete syntax into an abstract syntax tree - -mkAbstreeS :: - String -- The regexp in string form - -> [Matcher Char] -- Extra matcher functions - -> [Assert Char] - -> [MatcherFlag] -- The necessary matcher flags - -> Maybe (AbsTree Char b) -- An abstract syntax tree - - -mkAbstreeS [] fs as flags = Just mkEnd -mkAbstreeS re fs as flags - = let - matchresults = initParser nnRegexpS re fs as (initFlags flags) - (match,rest) = head matchresults - wellformed = (not (null matchresults)) && (null rest) - realmatch = addEnd match - in - if wellformed then - Just realmatch - else - Nothing - --- --- grammar for regular expressions: --- -{- - Element = nonmeta char | "\\" special meta char | "\\" character - Atom = ("(?" (Mode [","]) +")") - ( "." | "<<" Int ">>" | Element - | "[" ["^"] (Element + | ( Element "-" Element)+) +"]" - )("(?" (Mode [","]) +")"). - XAtom = "\\" Int | "(" AbsTree ")" | "(?:" AbsTree ")" | Atom . - ExtAtom = "(?=" Int ")" - | (XAtom ["*" | "+" | "?" - | "{" Int "}" - | "{" Int "," [Int] "}" - ] ["?"]) - | Atom + - | XAtom. - Factor = ("^" | "\\A") ExtAtom + ("$" | "\\Z"). - AbsTree = Factor "|" (Factor *). --} - - -nnElemS :: (Parser Char Char (Matcher Char) (Assert Char)) -nnElemS = butC "$.*+?@|()^[]\\" ||| lit '\\' ..+ butC ("wWsSdDbBAZ"++['0'..'9']) - --- match a character class element -nnCCEl::(Parser Char Char (Matcher Char) (Assert Char)) -nnCCEl = butC "]\\" ||| lit '\\' ..+ butC ("wWsSdD") - ---get a special meta character -parseMeta :: (Parser Char (Char -> Bool) (Matcher Char) (Assert Char)) -parseMeta = - lit '\\' ..+ lit 'w' <<< const isWordChar - ||| lit '\\' ..+ lit 'W' <<< const (not.isWordChar) - ||| lit '\\' ..+ lit 's' <<< const isSpace - ||| lit '\\' ..+ lit 'S' <<< const (not.isSpace) - ||| lit '\\' ..+ lit 'd' <<< const isDigit - ||| lit '\\' ..+ lit 'D' <<< const (not.isDigit) - --- parse a mode change -parseChange :: (Parser Char ([String]) (Matcher Char) (Assert Char)) -parseChange = (lit '(' ..+ lit '?' - ..+ plus ((isWord "Case_Insensitive" - ||| isWord "Case_Sensitive" - ||| isWord "Default_Line" - ||| isWord "Multi_Line" - ||| isWord "Single_Line") +.. opt (lit ',')) - +.. lit ')') - `thenxP_` \xs -> changemode xs - where - changemode xs = foldl1 compose (map mkUpdate xs) - compose f g = f ..+ g - mkUpdate "Case_Insensitive" = (updateEnv "case" Case_Insensitive) - mkUpdate "Case_Sensitive" = (updateEnv "case" Case_Sensitive) - mkUpdate "Default_Line" = (updateEnv "line" Default_Line) - mkUpdate "Multi_Line" = (updateEnv "line" Multi_Line) - mkUpdate "Single_Line" = (updateEnv "line" Single_Line) - --- parse an assertion -parseAssert :: (Parser Char (MatcherImpl Char) (Matcher Char) (Assert Char)) -parseAssert = - (lit '(' ..+ lit '?' ..+ lit '=' ..+ anyPos +.. lit ')') - `then_Px` (\x -> lookupAs x <<< doAssert ) - ||| lit '\\' ..+ (lit 'b' ||| lit 'B') <<< handlewbound - where - handlewbound 'b' = doAssert wordBound - handlewbound 'B' = doAssert notWordBound - - --- parse an atom -nnAtomS :: (Parser Char (AbsTree Char b)(Matcher Char) (Assert Char)) - -nnAtomS - = - star parseChange - ..+ - - (((lit '<' ..+ lit '<' ..+ anyPos +.. lit '>' +.. lit '>') - `then_Px` \x -> lookupFn x) - <<< mkEl.wrapMatcher - - ||| lookupEnv "line" +.. - lit '.' <<< mkEl.handleany - - ||| lookupEnv "case" `then_Px` \x -> - (lit '[' ..+ opt (lit '^') - +.+ (plus (parseMeta - ||| (plus (nnCCEl +.+ lit '-' ..+ nnCCEl) <<< handlerange x) - ||| (plus nnCCEl <<< handleelems x))) - +.. lit ']' <<< mkEl.matchEls.handleclass) - - ||| parseMeta <<< mkEl.matchEls - - ||| lookupEnv "case" +.+ - nnElemS <<< mkEl.matchEls.handlecase) - +.. - star parseChange - - where - - handleany Single_Line = matchAny - handleany _ = matchAnyBut - - handlecase (Case_Sensitive,x) = isEl x - handlecase (Case_Insensitive,x) - | isLower x = \y -> isEl x y || isEl (toUpper x) y - | isUpper x = \y -> isEl x y || isEl (toLower x) y - | otherwise = isEl x - - handleelems Case_Sensitive es el = (el `elem` es) - handleelems Case_Insensitive es el - = (toUpper el) `elem` (map toUpper es) - - handlerange Case_Sensitive es = foldr1 combine (map inrange es) - handlerange Case_Insensitive es = foldr1 combine (map inrangeI es) - - inrange (e1,e2) c = c >=e1 && c<=e2 - inrangeI (e1,e2) = doinIrange e1 e2 - combine f g c = (f c) || (g c) - - -- deal with a class - handleclass ([],fs) = (foldr1 combine fs) - handleclass ([f],fs) = (not.(foldr1 combine fs)) - -{- - handle a case insensitive range efficiently, by working out which - characters should be covered. - Upper case letters occur before lower case, with some characters in - between. This is ascii dependent. --} -doinIrange :: Char -> Char -> (Char -> Bool) -doinIrange e1 e2 = if (e1 <= 'A' && e2 >= 'z') || (e2 < 'A') || (e1 > 'z') - || (e1 >'Z' && e2 < 'a') - then -- either all letters already covered or none covered - (\c -> c >=e1 && c<=e2) - - else if e1 <= 'A' then -- start before before uppers - if e2 >= 'a' then -- end in lower cases - (\c -> c >= e1 && c<= 'z') -- all alpha have to be covered - - else if e2 < 'Z' then -- covered some of - -- uppers, so cover equiv lowers - (\c -> (c >=e1 && c<=e2) - || (c >= 'a' && c<= (toLower e2))) - - else -- all uppers covered and finish before lower - (\c -> (c >=e1 && c<=e2) || isLower c) - -- so cover all lowers as well - - else if e2 >= 'z' then -- finish after lowers - if e1 <= 'Z' then -- start in uppers - (\c -> c >= 'A' && c <= e2)-- all alpha have to be covered - - else if e1 > 'A' then -- covers some of lowers, - -- so cover equiv uppers - (\c -> (c >=e1 && c<=e2) - || (c >= 'A' && c<= (toUpper e2))) - - else -- all lowers covered and finish before upper - (\c -> (c >=e1 && c<=e2) || isUpper c)--so cover all uppers too - - else if e1 < 'Z' then -- start in uppers - if e2 <= 'Z' then -- end in uppers, so cover equiv lowers - (\c -> (c >=e1 && c<=e2) - || (c >= (toLower e1) && c<= (toLower e2))) - - else if e2 >= 'a' then -- end in lowers - if (toLower e1) <= e2 then -- start in uppers - -- between the two all characters - -- have to be covered - (\c -> (c>='A' && c<='z'))-- make all alpha to be covered - else -- some letters covered, so cover equiv - (\c -> (c >=e1 && c<=e2) - || (c >= 'A' && c <= (toUpper e2)) - || (c >=(toLower e1) && c<= 'z')) - - else -- start in uppers & end between uppers & lowers - (\c -> (c >=e1 && c<=e2) -- cover eqiv lowers - || (c >=(toLower e1) && c<= 'z')) - - else if e1 > 'a' then -- start in lowers & end in lowers - (\c -> (c >=e1 && c<=e2) -- so cover equiv uppers - || (c >=(toUpper e1) && c<= (toUpper e2))) - - else -- start between uppers & lowers & end in lowers - (\c -> (c >=e1 && c<=e2) -- cover equiv uppers - || (c >= 'A' && c <= (toUpper e2))) - --- parse an XAtom -nnXAtomS :: (Parser Char (AbsTree Char b)(Matcher Char) (Assert Char)) - -nnXAtomS = - star parseChange - ..+ - (lit '(' ..+ nnRegexpS +.. lit ')' - ||| startSubexp +.+ lit '(' ..+ nnRegexpS +.. lit ')' <<< handlesub - ||| lookupEnv "case" +.+ - (lit '$' ..+ lit '{' ..+ (plus (satisfy isWordChar)) +.. lit '}') - <<< handlecase - ) - +.. - star parseChange - - where - handlecase (Case_Sensitive,x) = mkBackref x matchBref - handlecase (Case_Insensitive,x) = mkBackref x matchIBref - handlesub (s,n) = mkSub s n - - -startSubexp = lit ' ' ..+ (plus (satisfy isWordChar)) +.. lit '@' - --- parse an extended atom -nnExtAtomS :: (Parser Char (AbsTree Char b)(Matcher Char) (Assert Char)) - -nnExtAtomS = star parseChange ..+ - (star parseAssert <<< combineAssert) - +.+ ((nnXAtomS ||| nnAtomS) - +.+ ((lit '*' <<< const mkStar - ||| lit '+' <<< const mkPlus - ||| lit '?' <<< const mkOpt - ||| lit '{' ..+ anyPos +.. lit '}' - <<< helpexact - ||| lit '{' ..+ anyInt +.+ - lit ',' +.+ (opt anyInt) - +.. lit '}' <<< helpminmax - ) +.+ opt (lit '?') ) <<< helprepeat - ||| nnXAtomS - ||| plus (nnAtomS `notFollowedBy` (startSubexp <<< const 'x' ||| oneofC "*+?{")) - <<< combine - -- don't want to eat up the name for a subexpression - -- want to catch the last atom separately as it is to be - -- made into a repeatable node - ||| nnAtomS) - +.+ (star parseAssert <<< combineAssert) - +.. star parseChange - <<< helper - - where - - helpexact x = mkExact x - - helpminmax (x,(a,[])) = mkMin x - helpminmax (x,(a,[y])) - = if x <= y then - mkMinMax x y - else - error "Invalid interval in Regular Expression" - - - helprepeat (ea,(f,[])) = f ea - helprepeat (ea,(f,[_])) = mkNg (f ea) - - combine = mkEl . foldl1 regseq . map getElem - - combineAssert [] = [] - combineAssert s@(x:xs) = [(mkEl.foldl1 regseq) s] - - helper ([],(t,[])) = t - helper ([e1],(t,[])) = mkCon e1 t - - helper ([e1],(t,[e2])) = mkCon e1 (mkCon t e2) - - helper ([],(t,[e2])) = mkCon t e2 - - --- parse a factor -nnFactorS :: (Parser Char (AbsTree Char b)(Matcher Char) (Assert Char)) - -nnFactorS = star parseChange ..+ - (opt (lookupEnv "line" +.+ (lit '^' -- may match begin any line - ||| lit '\\' ..+ lit 'A'))) - -- match only begin string - +.+ (plus nnExtAtomS) - +.+ (opt (lookupEnv "line" +.+ (lit '$' -- may match end any line - ||| lit '\\' ..+ lit 'Z'))) - -- match only end line - +.. star parseChange - <<< helper - - where - helper ([],(xs,[])) = combine xs -- not prefix or suffix - helper ([(mode,what)],(xs,[])) - = handlepre (mode,what) (combine xs) - helper ([],(xs,[(mode,what)])) - = handlesuff (mode,what) (combine xs) - helper ([(mode1,what1)],(xs,[(mode2,what2)])) - = handlepre (mode1,what1) (handlesuff (mode2,what2) (combine xs)) - - handlepre (_,'A') t = mkCon (justPrefix (mkEl (doAssert prefix))) t - handlepre (Multi_Line,'^') t = mkCon (mkEl (doAssert bol)) t - handlepre (_,'^') t = mkCon (justPrefix (mkEl (doAssert prefix))) t - - handlesuff (_,'Z') t = mkCon t (mkEl (doAssert suffix)) - handlesuff (Multi_Line,'$') t = mkCon t (mkEl (doAssert eol)) - handlesuff (_,'$') t = mkCon t (mkEl (doAssert suffix)) - - combine (x:[]) = x - combine s@(x:xs) = foldl1 mkCon s - - --- parse a regexp -nnRegexpS :: (Parser Char (AbsTree Char b)(Matcher Char) (Assert Char)) - -nnRegexpS = nnFactorS +.+ star (lit '|' ..+ nnFactorS) <<< helper - where - helper (ea,[]) = ea - helper (ea, s@(x:xs))= foldl mkAlt ea s - diff --git a/testsuite/driver/basicRxLib/Parsers.hs b/testsuite/driver/basicRxLib/Parsers.hs deleted file mode 100644 index b5c5b2caac..0000000000 --- a/testsuite/driver/basicRxLib/Parsers.hs +++ /dev/null @@ -1,272 +0,0 @@ -{- -This module contains combinator parser functions based on ones by -Peter Thiemann. -They have been tweaked with extra info to allow them to work for the -ParseRegexp module. Its a recursive descent DETERMINISTIC parser. -Particularly that means that, it does not do full backtracking. -For instance, (rpt (lit 'a')) will return only the longest match it -can. ((rpt (lit 'a')) `thn` (lit 'a')) will not match "a". --} - -module Parsers - (Parser, - initParser, - lookupEnv, - updateEnv, - lookupFn, - lookupAs, - satisfy, - lit, - isWord, - oneofC, - anyC, - butC, - anyInt, - anyPos, - unitL, - thenxPx, - thenxP_, - then_Px, - (+.+), - (..+), - (+..), - (|||), - (<<<), - (<<*), - plus, - star, - opt, - followedBy, - notFollowedBy - ) - -where - -import FiniteMap -import Matchers(MatcherFlag) - -infixr 8 +.+ , +.. , ..+ -infixl 7 <<< , <<* -infixr 6 ||| - - -type Env = FiniteMap String MatcherFlag - -type Parser a b c d =[c] -- some kind of function list, labeled by - -- posn in list - -> [d] -- an assertion list, labeled by posn in list - -> (Env, -- Environment info about state of regexp - [a]) -- The input list - -> [(b,(Env,[a]))]-- Updated info - -- The empty list here, - -- represents a failed parse - --- initParser - Run a parser -initParser :: Parser a b c d -- the parser to run - -> [a] -- the list to parse - -> [c] -- lookup environment, label by posn in list - -> [d] -- another lookup environment for assertions - -> [(String,MatcherFlag)] -- environment info about state we're in - -> [(b, -- The result of parser - [a])] -- rest of list left over - - -initParser p1 inp fs as mfs = - let env =listToFM mfs - in - case p1 fs as (env,inp) of - ((res,(env,after)):xs) -> [(res,after)] - [] -> [] - - --- lookupFn - look for the nth item, from the function list -lookupFn :: Int -> Parser a c c d -lookupFn key fs _ tkns - = if key > length fs then - [] - else -- finds eth function in given list, first is 1. - [(fs !! (key-1),tkns)] - --- lookupAs - look for the nth item, from the assertion list -lookupAs :: Int -> Parser a d e d -lookupAs key fs as tkns - = if key > length as then - [] - else -- finds eth function in given list, first is 1. - [(as !! (key-1),tkns)] - --- lookupEnv - look for the nth item, from the environment list -lookupEnv :: String -> Parser a MatcherFlag c d -lookupEnv key fs as (env,tkns) - = case lookupFM env key of - Just x -> [(x,(env,tkns))] - -updateEnv :: String -> MatcherFlag -> Parser a MatcherFlag c d -updateEnv key elt fs as (env,tkns) - = [(elt,(addToFM env key elt,tkns))] - --- Sequence two parser actions, second uses result of first --- don't care about result returned by second -thenxP_ :: Parser a b c e -> (b -> Parser a d c e) -> Parser a b c e -thenxP_ p1 p2 fs as tkns = - (concat - . map (\ (v1, tokens1) -> map (\ (v2, tokens2) -> (v1, tokens2)) (p2 v1 fs as tokens1))) - (p1 fs as tkns) - --- Sequence two parser actions, second uses result of first --- don't care about result returned by first -then_Px :: Parser a b c e -> (b -> Parser a d c e) -> Parser a d c e -then_Px p1 p2 fs as tkns = - (concat - . map (\ (v1, tokens1) -> map (\ (v2, tokens2) -> (v2, tokens2)) (p2 v1 fs as tokens1))) - (p1 fs as tkns) - --- Sequence two parser actions, second uses result of first, --- pair off result of first and second action -thenxPx :: Parser a b c e -> (b -> Parser a d c e) -> Parser a (b,d) c e -thenxPx p1 p2 fs as tkns = - (concat - . map (\ (v1, tokens1) -> map (\ (v2, tokens2) -> ((v1,v2), tokens2)) (p2 v1 fs as tokens1))) - (p1 fs as tkns) - - --- have successfully matched something so return it - -succeed :: b -> Parser a b c e -succeed value fs as rest = [(value, rest)] - --- the parser --- satisfy p --- accepts the language { token | p(token) } - -satisfy :: (a -> Bool) -> Parser a a b e -satisfy p fs as (_,[]) = [] -satisfy p fs as (env,(token:tokens)) | p token = succeed token fs as (env,tokens) - | otherwise = [] - -isnull :: Parser a [b] c e -isnull _ _ (env,[]) = [([],(env,[]))] -isnull _ _ _ = [] - -cut :: [a] -> [a] -cut [] = [] -cut (x:xs) = [x] - -unitL :: a -> [a] -unitL = \x -> [x] - --- match any element -anyC :: Parser a a c e -anyC = satisfy (const True) - --- match any element not a member of the list -butC :: Eq a => [a] -> Parser a a c e -butC cs = satisfy (not.(`elem` cs)) - -oneofC :: Eq a => [a] -> Parser a a c e -oneofC cs = satisfy (`elem` cs) - -isWord :: Eq a => [a] -> (Parser a [a] b e) -isWord [x] = (lit x <<< unitL) -isWord (x:xs) = (lit x <<< unitL) +.+ (isWord xs) <<* (++) - --- anyInt recognises any non-negative integer, from longest possible --- list of digit chars -anyInt :: Parser Char Int a e -anyInt = ((plus (satisfy (\c -> (c >= '0') && (c <= '9'))))) <<< read - --- anyPos recognises any positive integer, from longest possible list --- of digit chars -anyPos :: Parser Char Int a e -anyPos = ((satisfy (\c -> (c > '0') && (c <= '9'))) <<< unitL) - +.+ - ((star (satisfy (\c -> (c >= '0') && (c <= '9'))))) - <<* (++) - <<< read - --- the parser --- lit word --- accepts { word } - -lit :: Eq a => a -> Parser a a b e -lit token = satisfy (== token) - - --- if p1 and p2 are parsers accepting L1 and L2 then --- then p1 p2 --- accepts L1.L2 - --- (+.+) - pair off result of first and second parser ---(+.+) :: Parser a b c e -> Parser a d c e -> Parser a (b,d) c e -p1 +.+ p2 = - \fs as tkns -> - (concat - . map (\ (v1, tokens1) -> map (\ (v2, tokens2) -> ((v1,v2), tokens2)) (p2 fs as tokens1))) - (p1 fs as tkns) - --- (+..) - don't care about result of second parser -(+..) :: Parser a b c e -> Parser a d c e -> Parser a b c e -p1 +.. p2 = - \fs as tkns -> - (concat - . map (\ (v1, tokens1) -> map (\ (v2, tokens2) -> (v1, tokens2)) (p2 fs as tokens1))) - (p1 fs as tkns) - --- (..+) - don't care about result of first parser -(..+) :: Parser a b c e -> Parser a d c e -> Parser a d c e -p1 ..+ p2 = - \fs as tkns -> - (concat - . map (\ (v1, tokens1) -> map (\ (v2, tokens2) -> (v2,tokens2)) (p2 fs as tokens1))) - (p1 fs as tkns) - - --- if p1 and p2 are parsers accepting L1 and L2 then --- alt p1 p2 --- accepts L1 | L2 - -(|||) :: Parser a b c e -> Parser a b c e -> Parser a b c e -p1 ||| p2 = \fs as tokens -> cut (p1 fs as tokens ++ p2 fs as tokens) - --- if p1 is a parser then --- p1 <<< f --- is a parser that accepts the same language as p1 --- but mangles the semantic value with f - -(<<<) :: Parser a b c e -> (b -> d) -> Parser a d c e -p1 <<< f = \fs as tkns -> map (\ (v, tokens) -> (f v, tokens)) (p1 fs as tkns) - -(<<*) :: Parser a (b,c) d f -> (b -> c -> e) -> Parser a e d f -p <<* f = \fs as tkns -> map ( \((v,w), tokens) -> (f v w, tokens)) (p fs as tkns) - --- if p accepts L then plus p accepts L+ - -plus :: Parser a b c e -> Parser a [b] c e -plus p fs as tkns = cut (((p +.+ star p) <<* (:)) fs as tkns) - --- if p accepts L then star p accepts L* - -star :: Parser a b c e -> Parser a [b] c e -star p fs as tkns = cut ((plus p ||| succeed []) fs as tkns) - --- if p accepts L then opt p accepts L? - -opt :: Parser a b c e -> Parser a [b] c e -opt p fs as tkns = cut (((p <<< \x -> [x]) ||| succeed []) fs as tkns) - --- followedBy p1 p2 recognizes L(p1) if followed by a word in L (p2) - -followedBy :: Parser a b d e -> Parser a c d e -> Parser a b d e -followedBy p q fs as tks = [(v, rest) | (v, rest) <- p fs as tks, x <- q fs as rest] - - -notFollowedBy :: Parser a b d e -> Parser a c d e -> Parser a b d e -notFollowedBy p q fs as tkns = --((p +.. q) ||| (p +.. isnull)) fs as tkns - - case p fs as tkns of - res@([(a,(_,[]))]) -> res - res@([(a,res1)]) -> case q fs as res1 of - [] -> res - (x:xs) -> [] - - [] -> [] diff --git a/testsuite/driver/basicRxLib/Regexp.hs b/testsuite/driver/basicRxLib/Regexp.hs deleted file mode 100644 index 84805fca87..0000000000 --- a/testsuite/driver/basicRxLib/Regexp.hs +++ /dev/null @@ -1,368 +0,0 @@ -module Regexp - (MatcherFlag(..), - Assert, - Matcher, - REmatch, - legalRegexp, - matchedAny, - numSubexps, - subexpMatch, - matchedSubexp, - allSubexps, - wholeMatch, - beforeMatch, - afterMatch, - searchP, - searchS, - searchExtP,searchBasicP, - searchExtS, - substP, - substS, - substExtP,substExtS) - -where - -import Matchers(MatcherFlag(..),Matcher) -import Assertions(Assert) -import NFADefs(NFANode(..),NFAElem,IntervalInfo,SubexpInfo) -import ExecRE(execRegexp) -import CompileRES(compileRegexpS) -import CompileREP(compileRegexpP) -import CompileREPB(compileRegexpPB) -import FiniteMap - - - - --- The search function returns an REmatch. The result from this can be --- accessed with the functions below. - -data REmatch a - = ILLEGAL - | NOTHING -- Match failed - | JUST (FiniteMap String [a], -- matched subexpressions ($1..$n) - [a], -- everything before match ($` in perl) - [a], -- entire match ($& in perl) - [a] -- everything after match ($' in perl) - ) - - -matchedAny :: (REmatch a) -- given match result - -> Bool -- whether there was a match - -matchedAny (JUST (_,_,_,_)) = True -matchedAny NOTHING = False -matchedAny ILLEGAL = False - -legalRegexp :: (REmatch a) -> Bool -legalRegexp ILLEGAL = False -legalRegexp _ = True - -numSubexps :: (REmatch a) -- given match result - -> Int -- how many subexpressions matched -numSubexps (JUST (subexps,_,_,_)) = - length (fmToList subexps) - -numSubexps (NOTHING) = 0 -numSubexps ILLEGAL = 0 - -matchedSubexp :: (REmatch a) -> String -> Bool -matchedSubexp (JUST (subexps,_,_,_)) x = case lookupFM subexps x of - Nothing -> False - (Just _) -> True -matchedSubexp (NOTHING) x = False -matchedSubexp ILLEGAL x = False - -subexpMatch :: (REmatch a) -- given match result - -> String -- the subexp we're interested in - -- (referred to by number, the first is 1...) - -> [a] -- what the subexp matched -subexpMatch rem@(JUST (subexps,_,_,_)) x = - case lookupFM subexps x of - Nothing -> [] - (Just xs) -> xs -subexpMatch NOTHING x = [] -subexpMatch ILLEGAL x = [] - -allSubexps :: REmatch a -> [(String,[a])] -allSubexps (JUST (subexps,_,_,_)) = fmToList subexps -allSubexps NOTHING = [] -allSubexps ILLEGAL = [] - -wholeMatch :: (REmatch a) -- given match result - -> [a] -- the entire match -wholeMatch (JUST (_,_,piece,_)) = piece -wholeMatch NOTHING = [] -wholeMatch ILLEGAL = [] - -beforeMatch :: (REmatch a) -- given match result - -> [a] -- everything before the match -beforeMatch (JUST (_,before,_,_)) = before -beforeMatch NOTHING = [] -beforeMatch ILLEGAL = [] - -afterMatch :: (REmatch a) -- given match result - -> [a] -- everything after the match -afterMatch (JUST (_,_,_,after)) = after -afterMatch NOTHING = [] -afterMatch ILLEGAL = [] - - --- The polymorphic search function, it compiles the regexp and then performs --- the match. It finds the first match, of longest(isH) length. --- It returns an REmatch, defined above. -searchP :: (Eq a, Ord a, Enum a, Read a, Show a) => - String -- regexp - -> [a] -- list to match along - -> (REmatch a) -- what matched and where -searchP re inp = searchExtP re [] [] inp - -searchExtP :: (Eq a, Ord a, Enum a, Read a, Show a) => - String -- regexp - -> [Matcher a] -- pass in own match functions - -> [Assert a] -- pass in own assertions - -> [a] -- list to match along - -> (REmatch a) -- what matched and where -searchExtP re fs as inp - = case (compileRegexpP re [] fs as) of - (Just matcher) -> - case (execRegexp matcher inp) of - Nothing -> NOTHING - Just stuff -> JUST stuff - Nothing -> ILLEGAL - - --- a polymorphic regexp without the need for enum ... - -searchBasicP :: (Eq a, Read a, Show a) => - String -- regexp - -> [Matcher a] -- pass in own match functions - -> [Assert a] -- pass in own assertions - -> [a] -- list to match along - -> (REmatch a) -- what matched and where -searchBasicP re fs as inp - = case (compileRegexpPB re [] fs as) of - (Just matcher) -> - case (execRegexp matcher inp) of - Nothing -> NOTHING - Just stuff -> JUST stuff - Nothing -> ILLEGAL - --- The string search function, it compiles the regexp and then performs the --- match. It finds the first match, of longest(isH) length. --- It returns an REmatch, defined above. - -searchS :: - String -- regexp - -> [MatcherFlag] -- flags to modify match - -> String -- list to match along - -> (REmatch Char) -- what matched and where - -searchS re flags inp = searchExtS re flags [] [] inp - -searchExtS :: - String -- regexp - -> [MatcherFlag] -- flags to modify match - -> [Matcher Char]-- pass in own match functions - -> [Assert Char] -- pass in own assertions - -> String -- list to match along - -> (REmatch Char) -- what matched and where - -searchExtS re flags fs as inp - = case (compileRegexpS re flags fs as) of - (Just matcher) -> - case (execRegexp matcher inp) of - Nothing -> NOTHING - Just stuff -> JUST stuff - Nothing -> ILLEGAL - -resultsS re flags fs as inp = case (searchExtS re flags fs as inp) of - NOTHING -> Nothing - JUST (ses,a,b,c) -> Just (eltsFM ses,a,b,c) - - - - --- search and replace functions. - -substP :: (Ord a,Enum a,Read a, Show a) => - String -- regexp - -> String -- what to replace it with - -> [MatcherFlag] -- flags to modify match - -> [a] -- list to match along - -> [a] -- result -substP rexp repl flags inp - = substExtP rexp repl flags [] [] inp - - -substS :: String -- regexp - -> String -- what to replace it with - -> [MatcherFlag] -- flags to modify match - -> String -- list to match along - -> String -- result -substS rexp repl flags inp - = substExtS rexp repl flags [] [] inp - - -substExtS :: String -- regexp - -> String -- what to replace it with - -> [MatcherFlag] -- flags to modify match - -> [Matcher Char] -- pass in own match functions - -> [Assert Char] -- pass in own assertions - -> String -- list to match along - -> String -- result -substExtS rexp repl flags fs as inp - = find inp - where - global = Global_Match `elem` flags - searcher= searchExtS rexp flags fs as - replacer = replaceS repl - find sub - = let - search_res = searcher sub - success = matchedAny search_res - in - if not success then - sub - else - let - match = wholeMatch search_res - prefix = beforeMatch search_res - afterthis = afterMatch search_res - suffix - = if global && ((not.null) match) then - find afterthis - else - afterthis - in - concat [prefix, - replacer search_res, - suffix] - - -{- -substExtP - - does a search and replace using Input regexp and replace info - of perl like format, single elements still in curly brackets. - Allowed MatcherFlag is Global_Match for doing global replacement; - otherwise only replaces first occurrence --} - -substExtP :: - (Ord a,Enum a,Read a, Show a) => - String -- regexp - -> String -- what to replace it with - -> [MatcherFlag] -- flags to modify match - -> [Matcher a] -- pass in own match functions - -> [Assert a] -- pass in own assertions - -> [a] -- list to match along - -> [a] -- result - -substExtP rexp repl flags as fs inp - = find inp - where - global = Global_Match `elem` flags - searcher= searchExtP rexp as fs - replacer = replaceP repl - find sub - = let - search_res = searcher sub - success = matchedAny search_res - in - if not success then - sub - else - let - match = wholeMatch search_res - prefix = beforeMatch search_res - afterthis = afterMatch search_res - suffix - = if global && ((not.null) match) then - find afterthis - else - afterthis - in - concat [prefix, - replacer search_res, - suffix] - - - ---------------------------------------------------------- -{- -replaceP - uses the REmatch given, and a string of replacement info to - build the replacement list. - eg if working on type Days of Week, and ${m} = [Monday,Tuesday] - replace rem "${m}<Sunday>" = [Monday,Tuesday,Sunday] --} -replaceP :: (Read a, Show a) => - String - -> REmatch a - -> [a] - -replaceP replacement rem = replace' replacement rem - where - replacer = searchS "\\< elem@(([^\\\\>]|\\.)+)\\>|\\$" [] - replace' repl rem = - let matchres = replacer repl - in - if not (matchedAny matchres) then - [] - else if matchedSubexp matchres "elem" then - [(read (subexpMatch matchres "elem"))] ++ - replace' (afterMatch matchres) rem - else - case handleReference rem (afterMatch matchres) of - Nothing -> replace' (afterMatch matchres) rem - (Just (ms,as)) -> ms ++ replace' as rem - - -ref = searchS "^\\{( bef@(m_before_)| aft@(m_after_)| whole@(m)| sub@(\\w+))\\}" [] - -handleReference :: (Read a, Show a) => - REmatch a -> String -> Maybe ([a],[Char]) -handleReference rem repl = - let matchres = ref repl - in - if not (matchedAny matchres) then - Nothing - else if (matchedSubexp matchres "whole") then -- matched ${m} - Just (wholeMatch rem, afterMatch matchres) - else if matchedSubexp matchres "bef" then -- matched ${m_before_} - Just (beforeMatch rem, afterMatch matchres) - else if matchedSubexp matchres "aft" then -- matched ${m_after_} - Just (afterMatch rem,afterMatch matchres) - else --if matchedSubexp matchres "sub" then -- matched ${..}... - Just (subexpMatch rem (subexpMatch matchres "sub"), - afterMatch matchres) - -{- -replaceS - uses the REmatch given, and a string of replacement info to - build the replacement list. - eg if ${m} = "ab" - replace "${m}d" rem = "abd" --} -replaceS replacement rem = replace' replacement rem - where - replacer = searchS "\\\\ el@(.)|\\$" [] - replace' repl rem = - let matchres = replacer repl - in - if not (matchedAny matchres) then - repl - else if matchedSubexp matchres "el" then - beforeMatch matchres ++ subexpMatch matchres "el" - ++ replace' (afterMatch matchres) rem - else - beforeMatch matchres ++ - (case handleReference rem (afterMatch matchres) of - Nothing -> replace' (afterMatch matchres) rem - (Just (ms,as)) -> ms ++ replace' as rem) - - - - - - - - diff --git a/testsuite/driver/runtests.py b/testsuite/driver/runtests.py new file mode 100644 index 0000000000..060249514e --- /dev/null +++ b/testsuite/driver/runtests.py @@ -0,0 +1,86 @@ +# +# (c) Simon Marlow 2002 +# + +# ToDo: +# GHCi tests +# expect failure for some ways only + +import sys +import os +import string +import getopt + +from testlib import * + +global config +config = getConfig() # get it from testlib + +global testopts +testopts = getTestOpts() + +global thisdir_testopts +thisdir_testopts = getThisDirTestOpts() + +# ----------------------------------------------------------------------------- +# cmd-line options + +long_options = [ + "config=", # config file + "rootdir=", # root of tree containing tests (default: .) + "output-summary=", # file in which to save the (human-readable) summary + "only=", # just this test (can be give multiple --only= flags) + ] + +opts, args = getopt.getopt(sys.argv[1:], "e:", long_options) + +for opt,arg in opts: + if opt == '--config': + execfile(arg) + + # -e is a string to execute from the command line. For example: + # testframe -e 'config.compiler=ghc-5.04' + if opt == '-e': + exec arg + + if opt == '--rootdir': + config.rootdir = arg + + if opt == '--output-summary': + config.output_summary = arg + + if opt == '--only': + config.only.append(arg) + +# ----------------------------------------------------------------------------- +# The main dude + +t_files = findTFiles(config.rootdir) + +print 'Found', len(t_files), '.T files...' + +t = getTestRun() + +t.start_time = chop(os.popen('date').read()) +print 'Beginning test run at', t.start_time + +# set stdout to unbuffered (is this the best way to do it?) +sys.stdout.flush() +sys.stdout = os.fdopen(sys.__stdout__.fileno(), "w", 0) + +for file in t_files: + print '====> Running', file + newTestDir(os.path.dirname(file)) + try: + execfile(file) + except: + print '*** found an error while executing ', file, ':' + traceback.print_exc() + +summary(t, sys.stdout) + +if config.output_summary != '': + summary(t, open(config.output_summary, 'w')) + +sys.exit(0) + diff --git a/testsuite/driver/testlib.py b/testsuite/driver/testlib.py new file mode 100644 index 0000000000..512dddc4d4 --- /dev/null +++ b/testsuite/driver/testlib.py @@ -0,0 +1,687 @@ +# +# (c) Simon Marlow 2002 +# + +import sys +import os +import string +import re +import traceback +import copy + +from string import join +from testutil import * + +# ----------------------------------------------------------------------------- +# Configuration info + +class TestConfig: + def __init__(self): + + # Directory below which to look for test description files (foo.T) + self.rootdir = '.' + + # Run these tests only (run all tests if empty) + self.only = [] + + # Accept new output which differs from the sample? + self.accept = 0 + + # File in which to save the summary + self.output_summary = '' + + # What platform are we running on? + self.platform = '' + + # Verbosity level + self.verbose = 1 + + # Compiler type (ghc, hugs, nhc, etc.) + self.compiler_type = '' + + # Path to the compiler + self.compiler = '' + + # Flags we always give to this compiler + self.compiler_always_flags = [] + + # Which ways to run tests (when compiling and running respectively) + # Other ways are added from the command line if we have the appropriate + # libraries. + self.compile_ways = [] + self.run_ways = [] + + # Lists of flags for each way + self.way_flags = {} + +global config +config = TestConfig() + +def getConfig(): + return config + +# ----------------------------------------------------------------------------- +# Information about the current test run + +class TestRun: + def __init__(self): + self.start_time = '' + self.total_tests = 0 + self.total_test_cases = 0 + self.n_framework_failures = 0 + self.framework_failures = [] + self.n_tests_skipped = 0 + self.tests_skipped = [] + self.n_expected_passes = 0 + self.expected_passes = [] + self.n_expected_failures = 0 + self.expected_failures = [] + self.n_unexpected_passes = 0 + self.unexpected_passes = [] + self.n_unexpected_failures = 0 + self.unexpected_failures = [] + +global t +t = TestRun() + +def getTestRun(): + return t + +# ----------------------------------------------------------------------------- +# Information about the current test + +class TestOptions: + def __init__(self): + + # skip this test? + self.skip = 0; + + # skip these ways + self.omit_ways = [] + + # skip all ways except these ([] == do all ways) + self.only_ways = [] + + # the result we normally expect for this test + self.expect = 'pass'; + + # override the expected result for certain ways + self.expect_fail_for = []; + + # the stdin file that this test will use (empty for <name>.stdin) + self.stdin = '' + + # compile this test to .hc only + self.compile_to_hc = 0 + + # extra compiler opts for this test + self.extra_hc_opts = '' + + # extra run opts for this test + self.extra_run_opts = '' + + # expected exit code + self.exit_code = 0 + + +# The default set of options +global default_testopts +default_testopts = TestOptions() + +# Options valid for all the tests in the current "directory". After +# each test, we reset the options to these. To change the options for +# multiple tests, the function setTestOpts() below can be used to alter +# these options. +global thisdir_testopts +thisdir_testopts = TestOptions() + +def getThisDirTestOpts(): + return thisdir_testopts + +# Options valid for the current test only (these get reset to +# testdir_testopts after each test). +global testopts +testopts = TestOptions() + +def getTestOpts(): + return testopts + +def resetTestOpts(): + global testopts + testopts = copy.copy(thisdir_testopts) + +# This can be called at the top of a file of tests, to set default test options +# for the following tests. +def setTestOpts( f ): + f( thisdir_testopts ); + +# ----------------------------------------------------------------------------- +# Canned setup functions for common cases. eg. for a test you might say +# +# test('test001', normal, compile, ['']) +# +# to run it without any options, but change it to +# +# test('test001', expect_fail, compile, ['']) +# +# to expect failure for this test. + +def normal( opts ): + return; + +def skip( opts ): + opts.skip = 1 + +def expect_fail( opts ): + opts.expect = 'fail'; + +# ----- + +def expect_fail_for( ways ): + return lambda opts, w=ways: _expect_fail_for( opts, w ) + +def _expect_fail_for( opts, ways ): + opts.expect_fail_for = ways + +# ----- + +def omit_ways( ways ): + return lambda opts, w=ways: _omit_ways( opts, w ) + +def _omit_ways( opts, ways ): + opts.omit_ways = ways + +# ----- + +def expect_fail_if_platform( plat ): + return lambda opts, p=plat: _expect_fail_if_platform(opts, p) + +def _expect_fail_if_platform( opts, plat ): + if config.platform == plat: + opts.expect = 'fail' + +# ----- + +def set_stdin( file ): + return lambda opts, f=file: _set_stdin(opts, f); + +def _set_stdin( opts, f ): + opts.stdin = f + +# ----- + +def exit_code( val ): + return lambda opts, v=val: _exit_code(opts, v); + +def _exit_code( opts, v ): + opts.exit_code = v + +# ----- + +def extra_run_opts( val ): + return lambda opts, v=val: _extra_run_opts(opts, v); + +def _extra_run_opts( opts, v ): + opts.extra_run_opts = v + +# ---- +# Function for composing two opt-fns together + +def compose( f, g ): + return lambda opts, f=f, g=g: _compose(opts,f,g) + +def _compose( opts, f, g ): + f(opts) + g(opts) + +# ----------------------------------------------------------------------------- +# The current directory of tests + +global testdir +testdir = '.' + +def newTestDir( dir ): + global testdir, thisdir_testopts + testdir = dir + # reset the options for this test directory + thisdir_testopts = copy.copy(default_testopts) + +def getTestDir(): + return testdir + +# ----------------------------------------------------------------------------- +# Actually doing tests + +# name :: String +# setup :: TestOpts -> IO () +def test( name, setup, func, args ): + t.total_tests = t.total_tests + 1 + + if func == compile or func == multimod_compile: + ways = config.compile_ways + elif func == compile_and_run or func == multimod_compile_and_run: + ways = config.run_ways + else: + ways = ['normal'] + + for way in ways: + do_test( name, way, setup, func, args ) + + +def do_test(name, way, setup, func, args): + full_name = name + '(' + way + ')' + t.total_test_cases = t.total_test_cases + 1 + + try: + # Reset the test-local options to the options for this "set" + resetTestOpts() + + # Set our test-local options + setup(testopts) + + if testopts.skip \ + or (config.only != [] and name not in config.only) \ + or (testopts.only_ways != [] and way not in testopts.only_ways) \ + or way in testopts.omit_ways: + skiptest(name) + return + + print '=====>', full_name + + result = apply(func, [name,way] + args) + + if testopts.expect != 'pass' and testopts.expect != 'fail' or \ + result != 'pass' and result != 'fail': + framework_fail(full_name) + + if result == 'pass': + if testopts.expect == 'pass' \ + and way not in testopts.expect_fail_for: + t.n_expected_passes = t.n_expected_passes + 1 + t.expected_passes.append(full_name) + else: + print '*** unexpected pass for', full_name + t.n_unexpected_passes = t.n_unexpected_passes + 1 + t.unexpected_passes.append(full_name) + else: + if testopts.expect == 'pass' \ + and way not in testopts.expect_fail_for: + print '*** unexpected failure for', full_name + t.n_unexpected_failures = t.n_unexpected_failures + 1 + t.unexpected_failures.append(full_name) + else: + t.n_expected_failures = t.n_expected_failures + 1 + t.expected_failures.append(full_name) + + except: + print '*** framework failure for', full_name, ':' + traceback.print_exc() + framework_fail(full_name) + +def skiptest( name ): + # print 'Skipping test \"', name, '\"' + t.n_tests_skipped = t.n_tests_skipped + 1 + t.tests_skipped.append(name) + +def framework_fail( name ): + t.n_framework_failures = t.n_framework_failures + 1 + t.framework_failures.append(name) + +# ----------------------------------------------------------------------------- +# Compile-only tests + +def compile( name, way, extra_hc_opts ): + return do_compile( name, way, 0, '', extra_hc_opts ) + +def compile_fail( name, way, extra_hc_opts ): + return do_compile( name, way, 1, '', extra_hc_opts ) + +def multimod_compile( name, way, top_mod, extra_hc_opts ): + return do_compile( name, way, 0, top_mod, extra_hc_opts ) + +def do_compile( name, way, should_fail, top_mod, extra_hc_opts ): + # print 'Compile only, extra args = ', extra_hc_opts + pretest_cleanup(name) + result = simple_build( name, way, extra_hc_opts, should_fail, top_mod, 0 ) + + if should_fail: + if result == 0: + return 'fail' + else: + if result != 0: + return 'fail' + + # the actual stderr should always match the expected, regardless + # of whether we expected the compilation to fail or not (successful + # compilations may generate warnings). + + expected_stderr_file = platform_qualify(name, 'stderr') + actual_stderr_file = qualify(name, 'comp.stderr') + actual_stderr = normalise_errmsg(open(actual_stderr_file).read()) + + if os.path.exists(expected_stderr_file): + expected_stderr = normalise_errmsg(open(expected_stderr_file).read()) + else: + expected_stderr = '' + expected_stderr_file = '' + + if expected_stderr != actual_stderr: + # print stderr_e, '\n', stderr_a + if not outputs_differ('stderr', expected_stderr_file, actual_stderr_file): + return 'fail' + + # no problems found, this test passed + return 'pass' + +# ----------------------------------------------------------------------------- +# Compile-and-run tests + +def compile_and_run( name, way, extra_hc_opts ): + # print 'Compile and run, extra args = ', extra_hc_opts + pretest_cleanup(name) + result = simple_build( name, way, extra_hc_opts, 0, '', 1 ) + + if result != 0: + return 'fail' + + # we don't check the compiler's stderr for a compile-and-run test + return simple_run( name ) + + +def multimod_compile_and_run( name, way, top_mod, extra_hc_opts ): + pretest_cleanup(name) + result = simple_build( name, way, extra_hc_opts, 0, top_mod, 1 ) + + if result != 0: + return 'fail' + + # we don't check the compiler's stderr for a compile-and-run test + return simple_run( name ) + +# ----------------------------------------------------------------------------- +# Build a single-module program + +def simple_build( name, way, extra_hc_opts, should_fail, top_mod, link ): + errname = add_suffix(name, 'comp.stderr') + rm_no_fail( errname ) + rm_no_fail( name ) + + if top_mod != '': + srcname = top_mod + else: + srcname = add_suffix(name, 'hs') + + to_do = '' + if top_mod != '': + to_do = '--make -o ' + name + elif link: + to_do = '-o ' + name + elif testopts.compile_to_hc: + to_do = '-C' + else: + to_do = '-c' # just compile + + + cmd = 'cd ' + testdir + " && '" \ + + config.compiler + "' " \ + + join(config.compiler_always_flags,' ') + ' ' \ + + extra_hc_opts + ' ' \ + + testopts.extra_hc_opts + ' ' \ + + join(config.way_flags[way],' ') + ' ' \ + + to_do + ' ' \ + + srcname + ' >' + errname + ' 2>&1' + + result = runCmd(cmd) + + if result != 0 and not should_fail: + actual_stderr = qualify(name, 'comp.stderr') + if_verbose(1,'Compile failed (status ' + `result` + ') errors were:') + if_verbose(1,open(actual_stderr).read()) + + # ToDo: if the sub-shell was killed by ^C, then exit + + return result + +# ----------------------------------------------------------------------------- +# Run a program and check its output +# +# If testname.stdin exists, route input from that, else +# from /dev/null. Route output to testname.run.stdout and +# testname.run.stderr. Returns the exit code of the run. + +def simple_run( name ): + # figure out what to use for stdin + if testopts.stdin != '': + use_stdin = testopts.stdin + else: + stdin_file = add_suffix(name, 'stdin') + if os.path.exists(in_testdir(stdin_file)): + use_stdin = stdin_file + else: + use_stdin = '/dev/null' + + run_stdout = add_suffix(name,'run.stdout') + run_stderr = add_suffix(name,'run.stderr') + + rm_no_fail(qualify(name,'run.stdout')) + rm_no_fail(qualify(name,'run_stderr,')) + + cmd = 'cd ' + testdir + ' && ' \ + + './' + name + ' ' + testopts.extra_run_opts + ' ' \ + + ' < ' + use_stdin \ + + ' > ' + run_stdout \ + + ' 2> ' + run_stderr + + # run the command + result = runCmd(cmd) + + exit_code = result >> 8; + signal = result & 0xff + + # check the exit code + if exit_code != testopts.exit_code: + print 'Wrong exit code (expected', testopts.exit_code, ', actual', exit_code, ')' + return 'fail' + + if check_stdout_ok(name) and check_stderr_ok(name): + return 'pass' + else: + return 'fail' + +# ----------------------------------------------------------------------------- +# Utils + +def check_stdout_ok( name ): + actual_stdout_file = qualify(name, 'run.stdout') + expected_stdout_file = platform_qualify(name, 'stdout') + + if os.path.exists(expected_stdout_file): + expected_stdout = open(expected_stdout_file).read() + else: + expected_stdout = '' + expected_stdout_file = '' + + if os.path.exists(actual_stdout_file): + actual_stdout = open(actual_stdout_file).read() + else: + actual_stdout = '' + actual_stdout_file = '' + + if actual_stdout != expected_stdout: + return outputs_differ( 'stdout', expected_stdout_file, actual_stdout_file ) + else: + return 1 + +def check_stderr_ok( name ): + actual_stderr_file = qualify(name, 'run.stderr') + expected_stderr_file = platform_qualify(name, 'stderr') + + if os.path.exists(expected_stderr_file): + expected_stderr = open(expected_stderr_file).read() + else: + expected_stderr = '' + expected_stderr_file = '' + + if os.path.exists(actual_stderr_file): + actual_stderr = open(actual_stderr_file).read() + else: + actual_stderr = '' + actual_stderr_file = '' + + if actual_stderr != expected_stderr: + return outputs_differ( 'stderr', expected_stderr_file, actual_stderr_file ) + else: + return 1 + + +# Output a message indicating that an expected output differed from the +# actual output, and optionally accept the new output. Returns true +# if the output was accepted, or false otherwise. +def outputs_differ( kind, expected, actual ): + print 'Actual ' + kind + ' output differs from expected:' + + if expected == '': + expected1 = '/dev/null' + else: + expected1 = expected + + if actual == '': + actual1 = '/dev/null' + else: + actual1 = actual + + os.system( 'diff -c ' + expected1 + ' ' + actual1 ) + + if config.accept: + if expected == '': + print '*** cannot accept new output: ' + kind + \ + ' file does not exist.' + return 0 + else: + print 'Accepting new output.' + os.system( 'cp ' + actual + ' ' + expected ) + return 1 + + +def normalise_errmsg( str ): + # Merge contiguous whitespace characters into a single space. + str = re.sub('[ \t\n]+', ' ', str) + # Look for file names and zap the directory part: + # foo/var/xyzzy/somefile --> somefile + str = re.sub('([^\\s/]+/)*([^\\s/])', '\\2', str) + # If somefile ends in ".exe" or ".exe:", zap ".exe" (for Windows) + # the colon is there because it appears in error messages; this + # hacky solution is used in place of more sophisticated filename + # mangling + str = re.sub('([^\\s]+)\\.exe', '\\1', str) + return str + +def if_verbose( n, str ): + if config.verbose >= n: + print str + +# Guess flags suitable for the compiler. +def guess_compiler_flags(): + if config.compiler_type == 'ghc': + return ['-no-recomp', '-dcore-lint'] + elif config.compiler_type == 'nhc': + return ['-an-nhc-specific-flag'] + else: + return [] + +def runCmd( cmd ): + if_verbose( 1, cmd ) + return os.system( cmd ) + +def runCmdNoFail( cmd ): + if_verbose( 1, cmd ) + return os.system( cmd ) + +def rm_no_fail( file ): + try: + os.remove( file ) + finally: + return + +def add_suffix( name, suffix ): + if suffix == '': + return name + else: + return name + '.' + suffix + +def in_testdir( name ): + return os.path.join(testdir, name) + +def qualify( name, suff ): + return in_testdir(add_suffix(name, suff)) + +# "foo" -> qualify("foo-platform") if it exists, or qualify("foo") otherwise +def platform_qualify( name, suff ): + path = qualify(name, suff) + platform_path = path + '-' + config.platform + if os.path.exists(platform_path): + return platform_path + else: + return path + +# Clean up prior to the test, so that we can't spuriously conclude +# that it passed on the basis of old run outputs. +def pretest_cleanup(name): + rm_no_fail(qualify(name,'comp.stderr')) + rm_no_fail(qualify(name,'run.stderr')) + rm_no_fail(qualify(name,'run.stdout')) + # simple_build zaps the following: + # rm_nofail(qualify("o")) + # rm_nofail(qualify("")) + # not interested in the return code + +# ----------------------------------------------------------------------------- +# Return a list of all the files ending in '.T' below the directory dir. + +def findTFiles(path): + if os.path.isdir(path): + paths = map(lambda x, p=path: p + '/' + x, os.listdir(path)) + return concat(map(findTFiles, paths)) + elif path[-2:] == '.T': + return [path] + else: + return [] + +# ----------------------------------------------------------------------------- +# Output a test summary to the specified file object + +def summary(t, file): + file.write('\n') + file.write('OVERALL SUMMARY for test run started at ' \ + + t.start_time + '\n\n'\ + + string.rjust(`t.total_tests`, 8) \ + + ' total tests, which gave rise to\n' \ + + string.rjust(`t.total_test_cases`, 8) \ + + ' test cases, of which\n' \ + + string.rjust(`t.n_framework_failures`, 8) \ + + ' caused framework failures\n' \ + + string.rjust(`t.n_tests_skipped`, 8) + + ' were skipped\n\n' \ + + string.rjust(`t.n_expected_passes`, 8) + + ' expected passes\n' \ + + string.rjust(`t.n_expected_failures`, 8) \ + + ' expected failures\n' \ + + string.rjust(`t.n_unexpected_passes`, 8) \ + + ' unexpected passes\n' + + string.rjust(`t.n_unexpected_failures`, 8) \ + + ' unexpected failures\n' + + '\n') + + if t.n_unexpected_passes > 0: + file.write('Unexpected passes:\n') + for test in t.unexpected_passes: + file.write(' ' + test + '\n') + file.write('\n') + + if t.n_unexpected_failures > 0: + file.write('Unexpected failures:\n') + for test in t.unexpected_failures: + file.write(' ' + test + '\n') + file.write('\n') + + diff --git a/testsuite/driver/testutil.py b/testsuite/driver/testutil.py new file mode 100644 index 0000000000..c47780c940 --- /dev/null +++ b/testsuite/driver/testutil.py @@ -0,0 +1,15 @@ +# ----------------------------------------------------------------------------- +# Utils + +def append(x,y): + return x + y + +def concat(xs): + return reduce(append,xs) + +def chop(s): + if s[len(s)-1:] == '\n': + return s[:len(s)-1] + else: + return s + diff --git a/testsuite/mk/test.mk b/testsuite/mk/test.mk index b8d3f9dadd..307d30b18c 100644 --- a/testsuite/mk/test.mk +++ b/testsuite/mk/test.mk @@ -15,14 +15,32 @@ # # ----------------------------------------------------------------------------- +ifeq "$(PYTHON)" "" +$(error Python must be installed in order to use the testsuite) +endif + # ghastly hack, because the driver requires that $tool be an absolute path name. GHC_INPLACE_ABS = $(FPTOOLS_TOP_ABS)/ghc/compiler/ghc-inplace EXTRA_HC_OPTS += -D$(HostPlatform_CPP) # ideally TargetPlatform_CPP, but that doesn't exist; they're always the same anyway -RUNTESTS = $(TOP)/driver/runtests -RUNTEST_OPTS = --config=$(CONFIG) tool=$(GHC_INPLACE_ABS) extra_hc_flags="$(EXTRA_HC_OPTS)" $(EXTRA_RUNTEST_OPTS) -CONFIG = $(TOP)/config/msrc/cam-02-unx.T +RUNTESTS = $(TOP)/driver/runtests.py +CONFIG = $(TOP)/config/ghc + +# can be overriden from the command line +TEST_HC = $(GHC_INPLACE_ABS) + +RUNTEST_OPTS = \ + --config=$(CONFIG) \ + -e config.compiler=\"$(TEST_HC)\" \ + -e config.compiler_always_flags.append"(\"$(EXTRA_HC_OPTS)\")" \ + -e config.platform=\"$(TARGETPLATFORM)\" \ + $(EXTRA_RUNTEST_OPTS) + +ifeq "$(filter p, $(GhcLibWays))" "p" +RUNTEST_OPTS += -e config.compile_ways.append"(\"prof\")" +RUNTEST_OPTS += -e config.run_ways.append"(\"prof\")" +endif TESTS = TEST = @@ -30,11 +48,15 @@ TEST = all :: test test: - $(RUNTESTS) $(RUNTEST_OPTS) platform=$(TARGETPLATFORM) $(TEST) $(TESTS) + $(PYTHON) $(RUNTESTS) $(RUNTEST_OPTS) \ + $(patsubst %, --only=%, $(TEST)) \ + $(patsubst %, --only=%, $(TESTS)) -verbose: - $(RUNTESTS) $(RUNTEST_OPTS) platform=$(TARGETPLATFORM) verbose= $(TEST) $(TESTS) +verbose: test accept: - $(RUNTESTS) $(RUNTEST_OPTS) platform=$(TARGETPLATFORM) verbose= accept= $(TEST) $(TESTS) + $(PYTHON) $(RUNTESTS) $(RUNTEST_OPTS) \ + $(patsubst %, --only=%, $(TEST)) \ + $(patsubst %, --only=%, $(TESTS)) \ + -e config.accept=1 diff --git a/testsuite/tests/ghc-regress/array/Makefile b/testsuite/tests/ghc-regress/array/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/ghc-regress/array/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/ghc-regress/array/should_run/all.T b/testsuite/tests/ghc-regress/array/should_run/all.T index 538fa1f912..b5a05c0489 100644 --- a/testsuite/tests/ghc-regress/array/should_run/all.T +++ b/testsuite/tests/ghc-regress/array/should_run/all.T @@ -1,23 +1,22 @@ -include ($confdir ++ "/../vanilla-test.T") +# Args to compile_and_run are: +# extra compile flags +# extra run flags +# expected process return value, if not zero --- Args to vt are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "arr001" { vtr("", "", "") } -test "arr002" { vtr("", "", "") } -test "arr003" { vtr("", "", "1") } -test "arr004" { vtr("", "", "1") } -test "arr005" { vtr("", "", "") } -test "arr006" { vtr("", "", "") } -test "arr007" { vtr("", "", "1") } -test "arr008" { vtr("", "", "1") } -test "arr009" { vtr("", "", "") } -test "arr010" { vtr("", "", "") } -test "arr011" { vtr("", "", "") } -test "arr012" { vtr("", "", "") } -test "arr013" { vtr("", "", "") } -test "arr014" { vtr("-package lang", "", "") } -test "arr015" { vtr("", "", "") } -test "arr016" { vtr("-fglasgow-exts", "", "") } +test('arr001', normal, compile_and_run, ['']) +test('arr002', normal, compile_and_run, ['']) +test('arr003', exit_code(1), compile_and_run, ['']) +test('arr004', exit_code(1), compile_and_run, ['']) +test('arr005', normal, compile_and_run, ['']) +test('arr006', normal, compile_and_run, ['']) +test('arr007', exit_code(1), compile_and_run, ['']) +test('arr008', exit_code(1), compile_and_run, ['']) +test('arr009', normal, compile_and_run, ['']) +test('arr010', normal, compile_and_run, ['']) +test('arr011', normal, compile_and_run, ['']) +test('arr012', normal, compile_and_run, ['']) +test('arr013', normal, compile_and_run, ['']) +test('arr014', normal, compile_and_run, ['-package lang']) +test('arr015', normal, compile_and_run, ['']) +test('arr016', normal, compile_and_run, ['-fglasgow-exts']) diff --git a/testsuite/tests/ghc-regress/ccall/Makefile b/testsuite/tests/ghc-regress/ccall/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/ghc-regress/ccall/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/ghc-regress/ccall/should_compile/all.T b/testsuite/tests/ghc-regress/ccall/should_compile/all.T index 7c759be479..eeb13cb782 100644 --- a/testsuite/tests/ghc-regress/ccall/should_compile/all.T +++ b/testsuite/tests/ghc-regress/ccall/should_compile/all.T @@ -1,24 +1,19 @@ -include ($confdir ++ "/../vanilla-test.T") +def f( opts ): + opts.compile_to_hc = 1 + opts.omit_ways = ['optasm'] + opts.extra_hc_opts = '-fglasgow-exts' --- Args to vtc are: extra compile flags +setTestOpts(f) --- Use this itsy helper fn to pass in an extra flag -def myvtc($extra_comp_args) -{ - vtc(" -fglasgow-exts " ++ $extra_comp_args) -} - -$compile_to_hc = "True" - -test "cc001" { myvtc("") } -test "cc002" { myvtc("") } -test "cc003" { myvtc("") } -test "cc004" { myvtc("") } -test "cc005" { myvtc("") } -test "cc006" { myvtc("-fno-prune-tydecls") } -test "cc007" { myvtc("") } -test "cc008" { myvtc("") } -test "cc009" { myvtc("") } -test "cc010" { myvtc("") } -test "cc011" { myvtc("") } +test('cc001', normal, compile, ['']) +test('cc002', normal, compile, ['']) +test('cc003', normal, compile, ['']) +test('cc004', normal, compile, ['']) +test('cc005', normal, compile, ['']) +test('cc006', normal, compile, ['']) +test('cc007', normal, compile, ['']) +test('cc008', normal, compile, ['']) +test('cc009', normal, compile, ['']) +test('cc010', normal, compile, ['']) +test('cc011', normal, compile, ['']) diff --git a/testsuite/tests/ghc-regress/ccall/should_fail/all.T b/testsuite/tests/ghc-regress/ccall/should_fail/all.T index 474da35a3c..c21d8b0724 100644 --- a/testsuite/tests/ghc-regress/ccall/should_fail/all.T +++ b/testsuite/tests/ghc-regress/ccall/should_fail/all.T @@ -1,14 +1,9 @@ +def f( opts ): + opts.extra_hc_opts = '-fglasgow-exts -package lang' -include ($confdir ++ "/../vanilla-test.T") +setTestOpts(f) --- Args to vtcf are: extra compile flags - -def myvtcf ( $args ) -{ - vtcf ( " -fglasgow-exts -package lang " ++ $args) -} - -test "cc001" { myvtcf("") } -test "cc002" { myvtcf("") } -test "cc004" { myvtcf("") } -test "cc005" { myvtcf("") } +test('cc001', normal, compile_fail, ['']) +test('cc002', normal, compile_fail, ['']) +test('cc004', normal, compile_fail, ['']) +test('cc005', normal, compile_fail, ['']) diff --git a/testsuite/tests/ghc-regress/ccall/should_run/all.T b/testsuite/tests/ghc-regress/ccall/should_run/all.T index a47cce8b5b..81d058f215 100644 --- a/testsuite/tests/ghc-regress/ccall/should_run/all.T +++ b/testsuite/tests/ghc-regress/ccall/should_run/all.T @@ -1,28 +1,37 @@ -include ($confdir ++ "/../vanilla-test.T") +# Args to compile_and_run are: +# extra compile flags +# extra run flags +# expected process return value, if not zero --- Args to vt are: extra compile flags --- extra run flags --- expected process return value, if not zero +def f( opts ): + opts.extra_hc_opts = '-fglasgow-exts' -test "fed001" { vtr("-fglasgow-exts", "", "") } -test "ffi001" { vtr("-fglasgow-exts", "", "") } +setTestOpts(f) --- skip this test for now: we don't have the machinery to compile the .c file --- separately. -test "ffi002" { vtr("ffi002_c.c -fglasgow-exts -no-hs-main", "", "") } +test('fed001', normal, compile_and_run, ['']) +test('ffi001', normal, compile_and_run, ['']) -test "ffi003" { skip when $platform == "alpha-dec-osf3" -- no NCG on Alpha yet - vtr("-fglasgow-exts", "", "") } +test('ffi002', normal, compile_and_run, ['ffi002_c.c -no-hs-main']) -test "ffi004" { vtr("-fglasgow-exts", "", "") } +if config.platform == 'alpha-dec-osf3': + f = skip +else: + f = normal --- skip this test for now: it is non-portable due to the use of literal values --- instead of CPP symbols for the flag arguments to open(). -test "ffi005" { skip when True - vtr("-fglasgow-exts", "", "3") } +test('ffi003', f, compile_and_run, ['']) -test "ffi006" { vtr("-fglasgow-exts", "", "") } -test "ffi007" { vtr("-fglasgow-exts", "", "") } -test "ffi008" { vtr("-fglasgow-exts", "", "1") } -test "ffi009" { vtr("-fglasgow-exts", "", "") } +test('ffi004', normal, compile_and_run, ['']) + +# skip this test for now: it is non-portable due to the use of literal values +# instead of CPP symbols for the flag arguments to open(). +test('ffi005', compose(skip, exit_code(3)), compile_and_run, ['']) + +test('ffi006', normal, compile_and_run, ['']) +test('ffi007', normal, compile_and_run, ['']) +test('ffi008', exit_code(1), compile_and_run, ['']) + +# expect fail for way optasm, because the native code generator +# doesn't do -ffloat-store and gets different answers when +# optimisation is on. +test('ffi009', expect_fail_for(['optasm']), compile_and_run, ['']) diff --git a/testsuite/tests/ghc-regress/codeGen/Makefile b/testsuite/tests/ghc-regress/codeGen/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/ghc-regress/codeGen/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/ghc-regress/codeGen/should_compile/all.T b/testsuite/tests/ghc-regress/codeGen/should_compile/all.T index 0487245b94..d05f604548 100644 --- a/testsuite/tests/ghc-regress/codeGen/should_compile/all.T +++ b/testsuite/tests/ghc-regress/codeGen/should_compile/all.T @@ -1,7 +1,2 @@ - -include ($confdir ++ "/../vanilla-test.T") - --- Args to vtc are: extra compile flags - -test "cg001" { vtc("") } -test "cg002" { vtc("") } +test('cg001', normal, compile, ['']) +test('cg002', normal, compile, ['']) diff --git a/testsuite/tests/ghc-regress/codeGen/should_run/all.T b/testsuite/tests/ghc-regress/codeGen/should_run/all.T index 8f36430a53..54e37d7009 100644 --- a/testsuite/tests/ghc-regress/codeGen/should_run/all.T +++ b/testsuite/tests/ghc-regress/codeGen/should_run/all.T @@ -1,58 +1,50 @@ +test('cg001', normal, compile_and_run, ['']) +test('cg002', normal, compile_and_run, ['']) +test('cg003', normal, compile_and_run, ['']) +test('cg004', normal, compile_and_run, ['']) +test('cg005', normal, compile_and_run, ['']) +test('cg006', normal, compile_and_run, ['']) +test('cg007', normal, compile_and_run, ['']) +test('cg008', normal, compile_and_run, ['']) +test('cg009', normal, compile_and_run, ['']) +test('cg010', normal, compile_and_run, ['']) +test('cg011', normal, compile_and_run, ['']) +test('cg012', normal, compile_and_run, ['-fglasgow-exts']) +test('cg013', normal, compile_and_run, ['']) +test('cg014', normal, compile_and_run, ['']) +test('cg015', normal, compile_and_run, ['-fglasgow-exts']) +test('cg016', exit_code(1), compile_and_run, ['']) +test('cg017', normal, compile_and_run, ['']) +test('cg018', normal, compile_and_run, ['-fglasgow-exts']) +test('cg019', normal, compile_and_run, ['']) +test('cg020', normal, compile_and_run, ['']) +test('cg021', normal, compile_and_run, ['']) +test('cg022', normal, compile_and_run, ['']) +test('cg024', normal, compile_and_run, ['']) -include ($confdir ++ "/../vanilla-test.T") +test('cg025', compose(extra_run_opts('cg025.hs'),exit_code(1)), \ + compile_and_run, ['']) --- Args to vt are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "cg001" { vtr("", "", "") } -test "cg002" { vtr("", "", "") } -test "cg003" { vtr("", "", "") } -test "cg004" { vtr("", "", "") } -test "cg005" { vtr("", "", "") } -test "cg006" { vtr("", "", "") } -test "cg007" { vtr("", "", "") } -test "cg008" { vtr("", "", "") } -test "cg009" { vtr("", "", "") } -test "cg010" { vtr("", "", "") } -test "cg011" { vtr("", "", "") } -test "cg012" { vtr("-fglasgow-exts", "", "") } -test "cg013" { vtr("", "", "") } -test "cg014" { vtr("", "", "") } -test "cg015" { vtr("-fglasgow-exts", "", "") } -test "cg016" { vtr("", "", "1") } -test "cg017" { vtr("", "", "") } -test "cg018" { vtr("-fglasgow-exts", "", "") } -test "cg019" { vtr("", "", "") } -test "cg020" { vtr("", "", "") } -test "cg021" { vtr("", "", "") } -test "cg022" { vtr("", "", "") } -test "cg024" { vtr("", "", "") } -test "cg025" { vtr("", "cg025.hs", "1") } -test "cg026" { vtr("-fglasgow-exts -package lang -fvia-C", "", "") } -test "cg027" { vtr("", "", "") } -test "cg028" { vtr("", "", "") } -test "cg031" { vtr("-fglasgow-exts", "", "") } -test "cg032" { vtr("-fglasgow-exts", "", "") } -test "cg033" { vtr("-fglasgow-exts", "", "") } -test "cg034" { vtr("", "", "") } -test "cg035" { vtr("-fglasgow-exts", "", "") } -test "cg036" { vtr("", "", "") } -test "cg037" { vtr("", "", "") } -test "cg038" { vtr("", "", "") } -test "cg039" { vtr("", "", "") } -test "cg040" { vtr("", "", "") } -test "cg042" { vtr("-fglasgow-exts -package lang", "", "") } -test "cg043" { vtr("", "", "") } -test "cg044" { vtr("-cpp -package lang", "", "" ) } - --- -O is temporary, until we fix the problems with seq#... -test "cg045" { vtr( "-O", "", "1") } -test "cg046" { vtr("", "", "") } -test "cg047" { vtr("", "", "") } -test "cg048" { vtr("", "", "") } -test "cg049" { vtr( "-funbox-strict-fields", "", "") } - --- NB: be sure to run cg050 *without* -O; that's what showed the bug -test "cg050" { vtr( "", "", "") } -test "cg051" { vtr( "", "", "1") } -- Expected to fail +test('cg026', normal, compile_and_run, ['-fglasgow-exts -package lang']) +test('cg027', normal, compile_and_run, ['']) +test('cg028', normal, compile_and_run, ['']) +test('cg031', normal, compile_and_run, ['-fglasgow-exts']) +test('cg032', normal, compile_and_run, ['-fglasgow-exts']) +test('cg033', normal, compile_and_run, ['-fglasgow-exts']) +test('cg034', normal, compile_and_run, ['']) +test('cg035', normal, compile_and_run, ['-fglasgow-exts']) +test('cg036', normal, compile_and_run, ['']) +test('cg037', normal, compile_and_run, ['']) +test('cg038', normal, compile_and_run, ['']) +test('cg039', normal, compile_and_run, ['']) +test('cg040', normal, compile_and_run, ['']) +test('cg042', normal, compile_and_run, ['-fglasgow-exts -package lang']) +test('cg043', normal, compile_and_run, ['']) +test('cg044', normal, compile_and_run, ['-cpp -package lang']) +test('cg045', exit_code(1), compile_and_run, ['']) +test('cg046', normal, compile_and_run, ['']) +test('cg047', normal, compile_and_run, ['']) +test('cg048', normal, compile_and_run, ['']) +test('cg049', normal, compile_and_run, ['-funbox-strict-fields']) +test('cg050', normal, compile_and_run, ['']) +test('cg051', exit_code(1), compile_and_run, ['']) diff --git a/testsuite/tests/ghc-regress/concurrent/Makefile b/testsuite/tests/ghc-regress/concurrent/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/ghc-regress/concurrent/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/ghc-regress/concurrent/should_run/all.T b/testsuite/tests/ghc-regress/concurrent/should_run/all.T index 5c84d1d663..1a95ffa56b 100644 --- a/testsuite/tests/ghc-regress/concurrent/should_run/all.T +++ b/testsuite/tests/ghc-regress/concurrent/should_run/all.T @@ -1,55 +1,51 @@ +# Args to compile_and_run are: +# extra compile flags +# extra run flags +# expected process return value, if not zero -include ($confdir ++ "/../vanilla-test.T") +def f( opts ): + opts.extra_hc_opts = '-fglasgow-exts' --- Args to vtr are: extra compile flags --- extra run flags --- expected process return value, if not zero --- whether to normalise (depathify) stderr output +setTestOpts(f) -def myvtr ( $args_c, $args_r, $ret_res ) -{ - vtr ( " -fglasgow-exts " ++ $args_c, - $args_r, $ret_res ) -} +test('conc001', normal, compile_and_run, ['']) +test('conc002', normal, compile_and_run, ['']) +test('conc003', normal, compile_and_run, ['']) +test('conc004', normal, compile_and_run, ['']) +test('conc005', normal, compile_and_run, ['-package concurrent']) +test('conc006', normal, compile_and_run, ['']) +test('conc007', extra_run_opts('+RTS -H128M -RTS'), compile_and_run, ['']) +test('conc008', normal, compile_and_run, ['']) +test('conc009', exit_code(1), compile_and_run, ['']) +test('conc010', normal, compile_and_run, ['']) +test('conc012', normal, compile_and_run, ['']) +test('conc013', normal, compile_and_run, ['']) +test('conc014', normal, compile_and_run, ['']) +test('conc015', normal, compile_and_run, ['']) +test('conc016', normal, compile_and_run, ['']) +test('conc017', normal, compile_and_run, ['']) +test('conc018', normal, compile_and_run, ['']) +test('conc019', normal, compile_and_run, ['']) +test('conc020', normal, compile_and_run, ['']) +test('conc021', exit_code(1), compile_and_run, ['']) +test('conc022', normal, compile_and_run, ['']) +test('conc023', normal, compile_and_run, ['']) +test('conc024', normal, compile_and_run, ['']) +test('conc025', normal, compile_and_run, ['']) +test('conc026', normal, compile_and_run, ['']) +test('conc027', normal, compile_and_run, ['']) +test('conc028', normal, compile_and_run, ['']) +test('conc029', normal, compile_and_run, ['']) +test('conc030', extra_run_opts('+RTS -K2M -RTS'), compile_and_run, ['']) +test('conc031', normal, compile_and_run, ['']) +test('conc032', normal, compile_and_run, ['']) +test('conc033', normal, compile_and_run, ['']) +test('conc034', extra_run_opts('+RTS -C0 -RTS'), compile_and_run, ['']) +test('conc035', normal, compile_and_run, ['']) +test('conc036', normal, compile_and_run, ['']) -test "conc001" { myvtr("", "", "") } -test "conc002" { myvtr("", "", "") } -test "conc003" { myvtr("", "", "") } -test "conc004" { myvtr("", "", "") } -test "conc005" { myvtr("-package concurrent", "", "") } -test "conc006" { myvtr("", "", "") } -test "conc007" { myvtr("", "+RTS -H128M -RTS", "") } -test "conc008" { myvtr("", "", "") } -test "conc009" { myvtr("", "", "1") } -test "conc010" { myvtr("", "", "") } -test "conc012" { myvtr("", "", "") } -test "conc013" { myvtr("", "", "") } -test "conc014" { myvtr("", "", "") } -test "conc015" { myvtr("", "", "") } -test "conc016" { myvtr("", "", "") } -test "conc017" { myvtr("", "", "") } -test "conc018" { myvtr("", "", "") } -test "conc019" { myvtr("", "", "") } -test "conc020" { myvtr("", "", "") } -test "conc021" { $normalise_errmsg = True myvtr("", "", "1") } -test "conc022" { myvtr("", "", "") } -test "conc023" { myvtr("", "", "") } -test "conc024" { myvtr("", "", "") } -test "conc025" { myvtr("", "", "") } -test "conc026" { myvtr("", "", "") } -test "conc027" { myvtr("", "", "") } -test "conc028" { myvtr("", "", "") } -test "conc029" { myvtr("", "", "") } -test "conc030" { myvtr("", "+RTS -K2M -RTS", "") } -test "conc031" { myvtr("", "", "") } -test "conc032" { myvtr("", "", "") } -test "conc033" { myvtr("", "", "") } -test "conc034" { myvtr("", "+RTS -C0 -RTS", "") } -test "conc035" { myvtr("", "", "") } -test "conc036" { myvtr("", "", "") } +# These two depend on $(GhcThreadedRts) at the moment, so until we can find +# a way to turn them off when $(GhcThreadedRts) == NO, disable them by default: --- These two depend on $(GhcThreadedRts) at the moment, so until we can find --- a way to turn them off when $(GhcThreadedRts) == NO, disable them by default: --- --- test "conc037" { myvtr("", "", "") } --- test "conc038" { myvtr("", "", "") } +test('conc037', skip, compile_and_run, ['']) +test('conc038', skip, compile_and_run, ['']) diff --git a/testsuite/tests/ghc-regress/concurrent/should_run/conc021.stderr b/testsuite/tests/ghc-regress/concurrent/should_run/conc021.stderr index b6019d18a1..a005889c33 100644 --- a/testsuite/tests/ghc-regress/concurrent/should_run/conc021.stderr +++ b/testsuite/tests/ghc-regress/concurrent/should_run/conc021.stderr @@ -1,3 +1,2 @@ Fail: wurble - diff --git a/testsuite/tests/ghc-regress/cpranal/Makefile b/testsuite/tests/ghc-regress/cpranal/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/ghc-regress/cpranal/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/ghc-regress/cpranal/should_compile/all.T b/testsuite/tests/ghc-regress/cpranal/should_compile/all.T index 0e7689e124..0912488e91 100644 --- a/testsuite/tests/ghc-regress/cpranal/should_compile/all.T +++ b/testsuite/tests/ghc-regress/cpranal/should_compile/all.T @@ -1,7 +1,8 @@ +# Just do the opt way... +def f( opts ): + opts.only_ways = ['opt'] -include ($confdir ++ "/../vanilla-test.T") +setTestOpts(f) --- Args to vtc are: extra compile flags - -test "Cpr001_imp" { vtc("-O") } -test "Cpr001" { vtc("-O") } +test('Cpr001_imp', normal, compile, ['']) +test('Cpr001', normal, compile, ['']) diff --git a/testsuite/tests/ghc-regress/deSugar/Makefile b/testsuite/tests/ghc-regress/deSugar/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/ghc-regress/deSugar/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/ghc-regress/deSugar/should_compile/all.T b/testsuite/tests/ghc-regress/deSugar/should_compile/all.T index e64dd65cbb..1b08a214be 100644 --- a/testsuite/tests/ghc-regress/deSugar/should_compile/all.T +++ b/testsuite/tests/ghc-regress/deSugar/should_compile/all.T @@ -1,65 +1,60 @@ +# Just do the normal way... +def f( opts ): + opts.only_ways = ['normal'] -include ($confdir ++ "/../vanilla-test.T") +setTestOpts(f) --- Args to vtc are: extra compile flags - --- Use this itsy helper fn to pass in an extra flag ---def myvtc($extra_comp_args) ---{ --- vtc(" -fno-warn-incomplete-patterns " ++ $extra_comp_args) ---} - -test "ds-wildcard" { vtc("") } -test "ds001" { vtc("") } -test "ds002" { vtc("") } -test "ds003" { vtc("") } -test "ds004" { vtc("") } -test "ds005" { vtc("") } -test "ds006" { vtc("") } -test "ds007" { vtc("") } -test "ds008" { vtc("") } -test "ds009" { vtc("") } -test "ds010" { vtc("") } -test "ds011" { vtc("") } -test "ds012" { vtc("") } -test "ds013" { vtc("") } -test "ds014" { vtc("") } -test "ds015" { vtc("") } -test "ds016" { vtc("") } -test "ds017" { vtc("") } -test "ds018" { vtc("") } -test "ds019" { vtc("") } -test "ds020" { vtc("") } -test "ds021" { vtc("") } -test "ds022" { vtc("") } -test "ds023" { vtc("") } -test "ds024" { vtc("") } -test "ds025" { vtc("") } -test "ds026" { vtc("") } -test "ds027" { vtc("") } -test "ds028" { vtc("") } -test "ds029" { vtc("") } -test "ds030" { vtc("") } -test "ds031" { vtc("") } -test "ds032" { vtc("") } -test "ds033" { vtc("") } -test "ds034" { vtc("") } -test "ds035" { vtc("-fglasgow-exts -package lang") } -test "ds036" { vtc("") } -test "ds037" { vtc("") } -test "ds038" { vtc("") } -test "ds039" { vtc("") } -test "ds040" { vtc("") } -test "ds041" { vtc("") } -test "ds042" { vtc("") } -test "ds043" { vtc("") } -test "ds044" { vtc("") } -test "ds045" { vtc("") } -test "ds046" { vtc("-O -funbox-strict-fields") } -test "ds047" { vtc("") } -test "ds048" { vtc("") } -test "ds049" { vtc("-fvia-C -package lang") } -test "ds050" { vtc("-fglasgow-exts") } -test "ds051" { vtc("") } -test "ds052" { $expect = "fail" vtc("") } -test "ds053" { $expect = "fail" vtc("") } +test('ds-wildcard', normal, compile, ['']) +test('ds001', normal, compile, ['']) +test('ds002', normal, compile, ['']) +test('ds003', normal, compile, ['']) +test('ds004', normal, compile, ['']) +test('ds005', normal, compile, ['']) +test('ds006', normal, compile, ['']) +test('ds007', normal, compile, ['']) +test('ds008', normal, compile, ['']) +test('ds009', normal, compile, ['']) +test('ds010', normal, compile, ['']) +test('ds011', normal, compile, ['']) +test('ds012', normal, compile, ['']) +test('ds013', normal, compile, ['']) +test('ds014', normal, compile, ['']) +test('ds015', normal, compile, ['']) +test('ds016', normal, compile, ['']) +test('ds017', normal, compile, ['']) +test('ds018', normal, compile, ['']) +test('ds019', normal, compile, ['']) +test('ds020', normal, compile, ['']) +test('ds021', normal, compile, ['']) +test('ds022', normal, compile, ['']) +test('ds023', normal, compile, ['']) +test('ds024', normal, compile, ['']) +test('ds025', normal, compile, ['']) +test('ds026', normal, compile, ['']) +test('ds027', normal, compile, ['']) +test('ds028', normal, compile, ['']) +test('ds029', normal, compile, ['']) +test('ds030', normal, compile, ['']) +test('ds031', normal, compile, ['']) +test('ds032', normal, compile, ['']) +test('ds033', normal, compile, ['']) +test('ds034', normal, compile, ['']) +test('ds035', normal, compile, ['-fglasgow-exts -package lang']) +test('ds036', normal, compile, ['']) +test('ds037', normal, compile, ['']) +test('ds038', normal, compile, ['']) +test('ds039', normal, compile, ['']) +test('ds040', normal, compile, ['']) +test('ds041', normal, compile, ['']) +test('ds042', normal, compile, ['']) +test('ds043', normal, compile, ['']) +test('ds044', normal, compile, ['']) +test('ds045', normal, compile, ['']) +test('ds046', normal, compile, ['-funbox-strict-fields']) +test('ds047', normal, compile, ['']) +test('ds048', normal, compile, ['']) +test('ds049', normal, compile, ['-package lang']) +test('ds050', normal, compile, ['-fglasgow-exts']) +test('ds051', normal, compile, ['']) +test('ds052', expect_fail, compile, ['']) +test('ds053', expect_fail, compile, ['']) diff --git a/testsuite/tests/ghc-regress/deSugar/should_run/all.T b/testsuite/tests/ghc-regress/deSugar/should_run/all.T index 8262ff55bb..57448d32bc 100644 --- a/testsuite/tests/ghc-regress/deSugar/should_run/all.T +++ b/testsuite/tests/ghc-regress/deSugar/should_run/all.T @@ -1,16 +1,14 @@ +# Args to compile_and_run are: +# extra compile flags +# extra run flags +# expected process return value, if not zero -include ($confdir ++ "/../vanilla-test.T") - --- Args to vt are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "dsrun001" { vtr("", "", "") } -test "dsrun002" { vtr("", "", "") } -test "dsrun003" { vtr("", "", "") } -test "dsrun004" { vtr("", "", "") } -test "dsrun005" { vtr("", "", "1") } -test "dsrun006" { vtr("", "", "") } -test "dsrun007" { vtr("", "", "1") } -test "dsrun008" { vtr("", "", "1") } -test "dsrun009" { vtr("", "", "") } +test('dsrun001', normal, compile_and_run, ['']) +test('dsrun002', normal, compile_and_run, ['']) +test('dsrun003', normal, compile_and_run, ['']) +test('dsrun004', normal, compile_and_run, ['']) +test('dsrun005', exit_code(1), compile_and_run, ['']) +test('dsrun006', normal, compile_and_run, ['']) +test('dsrun007', exit_code(1), compile_and_run, ['']) +test('dsrun008', exit_code(1), compile_and_run, ['']) +test('dsrun009', normal, compile_and_run, ['']) diff --git a/testsuite/tests/ghc-regress/deriving/Makefile b/testsuite/tests/ghc-regress/deriving/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/ghc-regress/deriving/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/ghc-regress/deriving/should_compile/all.T b/testsuite/tests/ghc-regress/deriving/should_compile/all.T index 7e44b8e51b..62e219818f 100644 --- a/testsuite/tests/ghc-regress/deriving/should_compile/all.T +++ b/testsuite/tests/ghc-regress/deriving/should_compile/all.T @@ -1,17 +1,12 @@ - -include ($confdir ++ "/../vanilla-test.T") - --- Args to vtc are: extra compile flags - -test "drv001" { vtc("") } -test "drv002" { vtc("") } -test "drv003" { vtc("") } -test "drv004" { vtc("") } -test "drv005" { vtc("") } -test "drv006" { vtc("") } -test "drv007" { vtc("") } -test "drv008" { vtc("") } -test "drv009" { vtc("") } -test "drv010" { vtc("") } -test "drv011" { vtc("") } +test('drv001', normal, compile, ['']) +test('drv002', normal, compile, ['']) +test('drv003', normal, compile, ['']) +test('drv004', normal, compile, ['']) +test('drv005', normal, compile, ['']) +test('drv006', normal, compile, ['']) +test('drv007', normal, compile, ['']) +test('drv008', normal, compile, ['']) +test('drv009', normal, compile, ['']) +test('drv010', normal, compile, ['']) +test('drv011', normal, compile, ['']) diff --git a/testsuite/tests/ghc-regress/deriving/should_fail/all.T b/testsuite/tests/ghc-regress/deriving/should_fail/all.T index 34b0637774..f614ac28b2 100644 --- a/testsuite/tests/ghc-regress/deriving/should_fail/all.T +++ b/testsuite/tests/ghc-regress/deriving/should_fail/all.T @@ -1,10 +1,6 @@ -include ($confdir ++ "/../vanilla-test.T") - --- Args to vtcf are: extra compile flags - -test "drvfail001" { vtcf("") } -test "drvfail002" { vtcf("") } -test "drvfail003" { vtcf("") } -test "drvfail004" { vtcf("") } -test "drvfail007" { vtcf("") } +test('drvfail001', normal, compile_fail, ['']) +test('drvfail002', normal, compile_fail, ['']) +test('drvfail003', normal, compile_fail, ['']) +test('drvfail004', normal, compile_fail, ['']) +test('drvfail007', normal, compile_fail, ['']) diff --git a/testsuite/tests/ghc-regress/deriving/should_run/all.T b/testsuite/tests/ghc-regress/deriving/should_run/all.T index 4d6fe4792e..8bbbe86a41 100644 --- a/testsuite/tests/ghc-regress/deriving/should_run/all.T +++ b/testsuite/tests/ghc-regress/deriving/should_run/all.T @@ -1,17 +1,15 @@ +# Args to vt are: +# extra compile flags +# extra run flags +# expected process return value, if not zero -include ($confdir ++ "/../vanilla-test.T") - --- Args to vt are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "drvrun001" { vtr("", "", "") } -test "drvrun002" { vtr("", "", "") } -test "drvrun003" { vtr("", "", "") } -test "drvrun004" { vtr("", "", "") } -test "drvrun005" { vtr("", "", "") } -test "drvrun006" { vtr("", "", "") } -test "drvrun007" { vtr("", "", "") } -test "drvrun008" { vtr("-funbox-strict-fields", "", "") } -test "drvrun009" { vtr("", "", "") } -test "drvrun010" { vtr("", "", "") } +test('drvrun001', normal, compile_and_run, ['']) +test('drvrun002', normal, compile_and_run, ['']) +test('drvrun003', normal, compile_and_run, ['']) +test('drvrun004', normal, compile_and_run, ['']) +test('drvrun005', normal, compile_and_run, ['']) +test('drvrun006', normal, compile_and_run, ['']) +test('drvrun007', normal, compile_and_run, ['']) +test('drvrun008', normal, compile_and_run, ['-funbox-strict-fields']) +test('drvrun009', normal, compile_and_run, ['']) +test('drvrun010', normal, compile_and_run, ['']) diff --git a/testsuite/tests/ghc-regress/deriving/should_run/drvrun005.stderr b/testsuite/tests/ghc-regress/deriving/should_run/drvrun005.stderr index 8b13789179..e69de29bb2 100644 --- a/testsuite/tests/ghc-regress/deriving/should_run/drvrun005.stderr +++ b/testsuite/tests/ghc-regress/deriving/should_run/drvrun005.stderr @@ -1 +0,0 @@ - diff --git a/testsuite/tests/ghc-regress/lib/CPUTime/all.T b/testsuite/tests/ghc-regress/lib/CPUTime/all.T index 565fc36346..d204b0a7aa 100644 --- a/testsuite/tests/ghc-regress/lib/CPUTime/all.T +++ b/testsuite/tests/ghc-regress/lib/CPUTime/all.T @@ -1,4 +1 @@ - -include ($confdir ++ "/../vanilla-test.T") - -test "CPUTime001" { vtr("","","") } +test('CPUTime001', normal, compile_and_run, ['']) diff --git a/testsuite/tests/ghc-regress/lib/Directory/all.T b/testsuite/tests/ghc-regress/lib/Directory/all.T index ead7028d53..e66dadc67a 100644 --- a/testsuite/tests/ghc-regress/lib/Directory/all.T +++ b/testsuite/tests/ghc-regress/lib/Directory/all.T @@ -1,7 +1,4 @@ - -include ($confdir ++ "/../vanilla-test.T") - -test "currentDirectory001" { vtr("","","") } -test "directory001" { vtr("","","") } -test "getDirectoryContents001" { vtr("","","") } -test "getPermissions001" { vtr("-cpp","","") } +test('currentDirectory001', normal, compile_and_run, ['']) +test('directory001', normal, compile_and_run, ['']) +test('getDirectoryContents001', normal, compile_and_run, ['']) +test('getPermissions001', normal, compile_and_run, ['-cpp']) diff --git a/testsuite/tests/ghc-regress/lib/IO/all.T b/testsuite/tests/ghc-regress/lib/IO/all.T index e0a0dfe20f..e06723d746 100644 --- a/testsuite/tests/ghc-regress/lib/IO/all.T +++ b/testsuite/tests/ghc-regress/lib/IO/all.T @@ -1,53 +1,51 @@ -include ($confdir ++ "/../vanilla-test.T") - -test "IOError001" { $stdin = "IOError001.hs" - vtr("","","") } -test "IOError002" { vtr("","","") } -test "finalization001" { vtr("","","") } -test "hClose001" { vtr("","","") } -test "hFileSize001" { vtr("","","") } -test "hFileSize002" { vtr("","","") } -test "hFlush001" { vtr("","","") } -test "hGetBuffering001" { $stdin = "hGetBuffering001.hs" - vtr("","","") } -test "hGetChar001" { vtr("","","") } -test "hGetLine001" { $stdin = "hGetLine001.hs" - vtr("-cpp","","") } -test "hGetLine002" { vtr("","","") } -test "hGetLine003" { vtr("","","") } -test "hGetPosn001" { vtr("-cpp","","") } -test "hIsEOF001" { vtr("","","") } -test "hIsEOF002" { vtr("-cpp","","") } - --- hReady doesn't work at the end of a file in GHC -test "hReady001" { $expect = "fail" - vtr("-cpp","","") } - -test "hSeek001" { vtr("-cpp","","") } -test "hSeek002" { vtr("-cpp","","") } -test "hSeek003" { vtr("-cpp","","") } -test "hSeek004" { vtr("-cpp","","") } -test "hSetBuffering002" { $stdin = "hSetBuffering002.hs" - vtr("","","") } -test "hSetBuffering003" { $stdin = "hSetBuffering003.hs" - vtr("","","") } -test "ioeGetErrorString001" { vtr("-cpp","","") } -test "ioeGetFileName001" { vtr("-cpp","","") } -test "ioeGetHandle001" { vtr("-cpp","","") } -test "isEOF001" { vtr("","","") } -test "misc001" { vtr("","misc001.hs misc001.out","") } -test "openFile001" { vtr("","","") } -test "openFile002" { vtr("","","1") } -test "openFile003" { vtr("","","") } -test "openFile004" { vtr("","","") } -test "openFile005" { if $platform == "i386-unknown-mingw32" then $expect = "fail" fi - vtr("","","") } -test "openFile006" { vtr("","","") } -test "openFile007" { if $platform == "i386-unknown-mingw32" then $expect = "fail" fi - vtr("","","") } -test "putStr001" { vtr("","","") } -test "readFile001" { if $platform == "i386-unknown-mingw32" then $expect = "fail" fi - vtr("","","") } -test "readwrite001" { vtr("-cpp","","") } -test "readwrite002" { $stdin = "readwrite002.hs" - vtr("-cpp","","") } + +def expect_fail_if_windows( opts ): + return expect_fail_if_platform("i386-unknown-mingw32"); + +test('IOError001', set_stdin('IOError001.hs'), compile_and_run, ['']) +test('IOError002', normal, compile_and_run, ['']) +test('finalization001', normal, compile_and_run, ['']) +test('hClose001', normal, compile_and_run, ['']) +test('hFileSize001', normal, compile_and_run, ['']) +test('hFileSize002', normal, compile_and_run, ['']) +test('hFlush001', normal, compile_and_run, ['']) +test('hGetBuffering001', set_stdin('hGetBuffering001.hs'), compile_and_run, ['']) +test('hGetChar001', normal, compile_and_run, ['']) +test('hGetLine001', set_stdin('hGetLine001.hs'), compile_and_run, ['-cpp']) +test('hGetLine002', normal, compile_and_run, ['']) +test('hGetLine003', normal, compile_and_run, ['']) +test('hGetPosn001', normal, compile_and_run, ['-cpp']) +test('hIsEOF001', normal, compile_and_run, ['']) +test('hIsEOF002', normal, compile_and_run, ['-cpp']) + +# hReady doesn't work at the end of a file in GHC +test('hReady001', expect_fail, compile_and_run, ['-cpp']) + +test('hSeek001', normal, compile_and_run, ['-cpp']) +test('hSeek002', normal, compile_and_run, ['-cpp']) +test('hSeek003', normal, compile_and_run, ['-cpp']) +test('hSeek004', normal, compile_and_run, ['-cpp']) + +test('hSetBuffering002', set_stdin('hSetBuffering002.hs'), compile_and_run, ['']) + +test('hSetBuffering003', set_stdin('hSetBuffering003.hs'), compile_and_run, ['']) + +test('ioeGetErrorString001', normal, compile_and_run, ['-cpp']) +test('ioeGetFileName001', normal, compile_and_run, ['-cpp']) +test('ioeGetHandle001', normal, compile_and_run, ['-cpp']) +test('isEOF001', normal, compile_and_run, ['']) + +test('misc001', extra_run_opts('misc001.hs misc001.out'), \ + compile_and_run, ['']) + +test('openFile001', normal, compile_and_run, ['']) +test('openFile002', exit_code(1), compile_and_run, ['']) +test('openFile003', normal, compile_and_run, ['']) +test('openFile004', normal, compile_and_run, ['']) +test('openFile005', expect_fail_if_windows, compile_and_run, ['']) +test('openFile006', normal, compile_and_run, ['']) +test('openFile007', expect_fail_if_windows, compile_and_run, ['']) +test('putStr001', normal, compile_and_run, ['']) +test('readFile001', expect_fail_if_windows, compile_and_run, ['']) +test('readwrite001', normal, compile_and_run, ['-cpp']) +test('readwrite002', set_stdin('readwrite002.hs'), compile_and_run, ['-cpp']) diff --git a/testsuite/tests/ghc-regress/lib/IOExts/all.T b/testsuite/tests/ghc-regress/lib/IOExts/all.T index 0ec5c41cdc..c69ff1b394 100644 --- a/testsuite/tests/ghc-regress/lib/IOExts/all.T +++ b/testsuite/tests/ghc-regress/lib/IOExts/all.T @@ -1,18 +1,21 @@ -include ($confdir ++ "/../vanilla-test.T") +def set_opts(opts): + opts.extra_hc_opts = '-package lang' --- Use this itsy helper fn to pass in an extra flag -def myvtr($extra_comp_args, $a, $b) -{ - vtr("-package lang " ++ $extra_comp_args, $a, $b) -} +setTestOpts(set_opts) -test "echo001" { $stdin = "echo001.hs" myvtr("","","") } -test "hTell001" { if $platform == "i386-unknown-mingw32" then $expect = "fail" fi - myvtr("","","") } -test "hTell002" { if $platform == "i386-unknown-mingw32" then $expect = "fail" fi - myvtr("","","") } -test "performGC001" { myvtr("","","") } -test "trace001" { myvtr("","","") } -test "hGetBuf001" { myvtr("","","") } -test "hPutBuf001" { myvtr("","","") } -test "hPutBuf002" { myvtr("","","") } +test('echo001', set_stdin("echo001.hs"), compile_and_run, ['']) + +test('hTell001', expect_fail_if_platform("i386-unknown-mingw32"), \ + compile_and_run, ['']) + +test('hTell002', expect_fail_if_platform("i386-unknown-mingw32"), \ + compile_and_run, ['']) + +test('performGC001', normal, compile_and_run, ['']) + +# optimisation screws up this test because some of the traces get commoned up +test('trace001', omit_ways(['opt','optasm']), compile_and_run, ['']) + +test('hGetBuf001', normal, compile_and_run, ['']) +test('hPutBuf001', normal, compile_and_run, ['']) +test('hPutBuf002', normal, compile_and_run, ['']) diff --git a/testsuite/tests/ghc-regress/lib/IORef/all.T b/testsuite/tests/ghc-regress/lib/IORef/all.T index d151e74267..06e78d9662 100644 --- a/testsuite/tests/ghc-regress/lib/IORef/all.T +++ b/testsuite/tests/ghc-regress/lib/IORef/all.T @@ -1,10 +1,3 @@ -include ($confdir ++ "/../vanilla-test.T") - --- Use this itsy helper fn to pass in an extra flag -def myvtr($extra_comp_args, $a, $b) -{ - vtr("-package lang " ++ $extra_comp_args, $a, $b) -} - -test "ioref001" { myvtr("","+RTS -K16m -RTS","") } +test('ioref001', extra_run_opts('+RTS -K16m -RTS'), \ + compile_and_run, ['-package lang']) diff --git a/testsuite/tests/ghc-regress/lib/Makefile b/testsuite/tests/ghc-regress/lib/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/ghc-regress/lib/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/ghc-regress/lib/Numeric/all.T b/testsuite/tests/ghc-regress/lib/Numeric/all.T index 65a994c9bc..c31f09d346 100644 --- a/testsuite/tests/ghc-regress/lib/Numeric/all.T +++ b/testsuite/tests/ghc-regress/lib/Numeric/all.T @@ -1,15 +1,8 @@ - -include ($confdir ++ "/../vanilla-test.T") - --- Args to vt are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "num001" { vtr("", "", "") } -test "num002" { vtr("", "", "") } -test "num003" { vtr("", "", "") } -test "num004" { vtr("", "", "") } -test "num005" { vtr("", "", "") } -test "num006" { vtr("-package lang", "", "") } -test "num007" { vtr("", "", "") } -test "num008" { vtr("", "", "") } +test('num001', normal, compile_and_run, ['']) +test('num002', normal, compile_and_run, ['']) +test('num003', normal, compile_and_run, ['']) +test('num004', normal, compile_and_run, ['']) +test('num005', normal, compile_and_run, ['']) +test('num006', normal, compile_and_run, ['-package lang']) +test('num007', normal, compile_and_run, ['']) +test('num008', normal, compile_and_run, ['']) diff --git a/testsuite/tests/ghc-regress/lib/System/all.T b/testsuite/tests/ghc-regress/lib/System/all.T index 64454abc5d..cd59a6dae1 100644 --- a/testsuite/tests/ghc-regress/lib/System/all.T +++ b/testsuite/tests/ghc-regress/lib/System/all.T @@ -1,6 +1,8 @@ -include ($confdir ++ "/../vanilla-test.T") -test "exitWith001" { vtr("","","42") } -test "getArgs001" { $normalise_output = True vtr("","","") } -test "getEnv001" { vtr("","","") } -test "system001" { skip when $platform == "i386-unknown-mingw32" vtr("","","") } +test('exitWith001', exit_code(42), compile_and_run, ['']) +test('getArgs001', normal, compile_and_run, ['']) +test('getEnv001', normal, compile_and_run, ['']) + +test('system001', expect_fail_if_platform("i386-unknown-mingw32"), \ + compile_and_run, ['']) + diff --git a/testsuite/tests/ghc-regress/lib/Time/all.T b/testsuite/tests/ghc-regress/lib/Time/all.T index f600e2ea04..25b40820c0 100644 --- a/testsuite/tests/ghc-regress/lib/Time/all.T +++ b/testsuite/tests/ghc-regress/lib/Time/all.T @@ -1,5 +1,3 @@ -include ($confdir ++ "/../vanilla-test.T") - -test "time002" { vtr("","","") } -test "time003" { vtr("","","") } -test "time004" { vtr("","","") } +test('time002', normal, compile_and_run, ['']) +test('time003', normal, compile_and_run, ['']) +test('time004', normal, compile_and_run, ['']) diff --git a/testsuite/tests/ghc-regress/lib/TimeExts/all.T b/testsuite/tests/ghc-regress/lib/TimeExts/all.T index 357a3c20d9..26adad8803 100644 --- a/testsuite/tests/ghc-regress/lib/TimeExts/all.T +++ b/testsuite/tests/ghc-regress/lib/TimeExts/all.T @@ -1,3 +1 @@ -include ($confdir ++ "/../vanilla-test.T") - -test "timeexts001" { vtr("-package lang","","") } +test('timeexts001', normal, compile_and_run, ['-package lang']) diff --git a/testsuite/tests/ghc-regress/lib/net/all.T b/testsuite/tests/ghc-regress/lib/net/all.T index 2699b5d0fe..da8b2d4060 100644 --- a/testsuite/tests/ghc-regress/lib/net/all.T +++ b/testsuite/tests/ghc-regress/lib/net/all.T @@ -1,5 +1,4 @@ -include ($confdir ++ "/../vanilla-test.T") -test "net001" { vtr("-package concurrent -package net","","") } -test "uri001" { vtr("-package network","","") } -test "net002" { vtr("-package net", "3", "") } +test('net001', normal, compile_and_run, [ '-package concurrent -package net']) +test('uri001', normal, compile_and_run, ['-package network']) +test('net002', extra_run_opts('3'), compile_and_run, ['-package net']) diff --git a/testsuite/tests/ghc-regress/lib/should_run/all.T b/testsuite/tests/ghc-regress/lib/should_run/all.T index f8378f18fd..2d082d5f48 100644 --- a/testsuite/tests/ghc-regress/lib/should_run/all.T +++ b/testsuite/tests/ghc-regress/lib/should_run/all.T @@ -1,29 +1,35 @@ -include ($confdir ++ "/../vanilla-test.T") +test('char001', normal, compile_and_run, ['']) +test('rand001', normal, compile_and_run, ['']) +test('show001', normal, compile_and_run, ['']) +test('text001', normal, compile_and_run, ['']) -def lang_vtr($extra_comp_args, $a, $b) -{ - vtr("-package lang " ++ $extra_comp_args, $a, $b) -} +# The rest of these tests need -package lang... +def set_opts( opts ): + opts.extra_hc_opts = '-package lang' +resetTestOpts( set_opts ) -test "addr001" { lang_vtr("","","") } -test "char001" { vtr("","","") } -test "dynamic001" { lang_vtr("","","") } -test "dynamic002" { lang_vtr("","","") } -test "enum01" { lang_vtr("-cpp","","") } -test "enum02" { lang_vtr("-cpp","","") } -test "enum03" { lang_vtr("-cpp","","") } -test "enum04" { $expect = "fail" lang_vtr("","","") } -test "exceptions001" { lang_vtr("","","") } -test "list001" { lang_vtr("","","") } -test "list002" { lang_vtr("","","") } -test "memo001" { lang_vtr("-package util","+RTS -A10k -G1 -RTS","") } -test "memo002" { lang_vtr("-package util","20","") } -test "packedstring001" { lang_vtr("","","") } -test "rand001" { vtr("","","") } -test "show001" { vtr("","","") } -test "stableptr001" { lang_vtr("","+RTS -K4m -RTS","") } -test "stableptr003" { lang_vtr("","","") } -test "stableptr004" { lang_vtr("","+RTS -K4m -RTS","") } -test "stableptr005" { lang_vtr("","","") } -test "text001" { vtr("","","") } -test "weak001" { lang_vtr("-fglasgow-exts","","") } +test('addr001', normal, compile_and_run, ['']) +test('dynamic001', normal, compile_and_run, ['']) +test('dynamic002', normal, compile_and_run, ['']) +test('enum01', normal, compile_and_run, ['-cpp']) +test('enum02', normal, compile_and_run, ['-cpp']) +test('enum03', normal, compile_and_run, ['-cpp']) +test('enum04', expect_fail, compile_and_run, [ '']) +test('exceptions001', normal, compile_and_run, ['']) +test('list001' , normal, compile_and_run, ['']) + +test('memo001', extra_run_opts('+RTS -A10k -G1 -RTS'), \ + compile_and_run, ['-package util']) + +test('memo002', extra_run_opts('20'), \ + compile_and_run, ['-package util']) + +test('packedstring001', normal, compile_and_run, ['']) + +test('stableptr001', extra_run_opts('+RTS -K4m -RTS'), compile_and_run, ['']) +test('stableptr003', normal, compile_and_run, ['']) +test('stableptr004', extra_run_opts('+RTS -K4m -RTS'), compile_and_run, ['']) +test('stableptr005', normal, compile_and_run, ['']) + +test('text001' normal, compile_and_run, ['']) +test('weak001', normal, compile_and_run, ['-fglasgow-exts']) diff --git a/testsuite/tests/ghc-regress/lib/win32/all.T b/testsuite/tests/ghc-regress/lib/win32/all.T index ca100a48ea..15e40aaea3 100644 --- a/testsuite/tests/ghc-regress/lib/win32/all.T +++ b/testsuite/tests/ghc-regress/lib/win32/all.T @@ -1,16 +1,12 @@ --- This isn't a very good test to run automatically at the moment, since --- it doesn't terminate +# This isn't a very good test to run automatically at the moment, since +# it doesn't terminate -include ($confdir ++ "/../vanilla-test.T") +def set_opts( opts ): + opts.extra_hc_opts = '-package lang -package win32' + opts.skip = 1 --- Use this itsy helper fn to pass in an extra flag -def myvtr($extra_comp_args, $a, $b) -{ - -- Only run the tests on Windows...no, let's not as it will - -- only block an automatic testrun. - skip when True || ($platform /= "i386-unknown-mingw32" && - $platform /= "i386-unknown-cygwin32") - vtr("-package lang -package win32 " ++ $extra_comp_args, $a, $b) -} +# if config.platform != "i386-unknown-mingw32" and \ +# config.platform != "i386-unknown-cygwin32": +# opts.skip = 1 -test "win32001" { myvtr("","","") } +test('win32001', set_opts, compile_and_run, ['']) diff --git a/testsuite/tests/ghc-regress/numeric/Makefile b/testsuite/tests/ghc-regress/numeric/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/ghc-regress/numeric/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/ghc-regress/numeric/should_run/all.T b/testsuite/tests/ghc-regress/numeric/should_run/all.T index 34d3afa172..d0c6dcea04 100644 --- a/testsuite/tests/ghc-regress/numeric/should_run/all.T +++ b/testsuite/tests/ghc-regress/numeric/should_run/all.T @@ -1,26 +1,31 @@ +# Args to compile_and_run are: +# extra compile flags +# extra run flags +# expected process return value, if not zero -include ($confdir ++ "/../vanilla-test.T") +test('arith001', normal, compile_and_run, ['']) +test('arith002', normal, compile_and_run, ['']) +test('arith003', normal, compile_and_run, ['']) +test('arith004', normal, compile_and_run, ['']) +test('arith005', normal, compile_and_run, ['']) +test('arith006', normal, compile_and_run, ['-package lang']) +test('arith007', normal, compile_and_run, ['']) --- Args to vt are: extra compile flags --- extra run flags --- expected process return value, if not zero +# This test generates slightly different results with the NCG on x86, +# because of the extra precision when floating point computations are +# done in registers rather than going via memory. +test('arith008', expect_fail_for(['optasm']), compile_and_run, ['']) -test "arith001" { vtr("", "", "") } -test "arith002" { vtr("", "", "") } -test "arith003" { vtr("", "", "") } -test "arith004" { vtr("", "", "") } -test "arith005" { vtr("", "", "") } -test "arith006" { vtr("-package lang", "", "") } -test "arith007" { vtr("", "", "") } -test "arith008" { vtr("", "", "") } -test "arith009" { vtr("", "", "") } -test "arith010" { vtr("-package lang", "", "") } -test "arith011" { vtr("-package lang", "", "") } -test "arith012" { vtr("-package lang", "", "") } -test "arith013" { vtr("", "", "") } -test "arith014" { vtr("", "", "") } -test "arith015" { vtr("", "", "") } -test "num009" { vtr("", "", "") } -test "num010" { vtr("", "", "") } -test "num011" { vtr("", "", "") } -test "arith016" { vtr("-fglasgow-exts", "", "") } +test('arith009', normal, compile_and_run, ['']) +test('arith010', normal, compile_and_run, ['-package lang']) +test('arith011', normal, compile_and_run, ['-package lang']) + +test('arith012', expect_fail_for(['optasm']), compile_and_run, ['-package lang']) + +test('arith013', normal, compile_and_run, ['']) +test('arith014', normal, compile_and_run, ['']) +test('arith015', normal, compile_and_run, ['']) +test('num009', normal, compile_and_run, ['']) +test('num010', normal, compile_and_run, ['']) +test('num011', normal, compile_and_run, ['']) +test('arith016', normal, compile_and_run, ['-fglasgow-exts']) diff --git a/testsuite/tests/ghc-regress/parser/Makefile b/testsuite/tests/ghc-regress/parser/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/ghc-regress/parser/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/ghc-regress/parser/should_compile/all.T b/testsuite/tests/ghc-regress/parser/should_compile/all.T index 2f1a09f5f4..b92e6c431f 100644 --- a/testsuite/tests/ghc-regress/parser/should_compile/all.T +++ b/testsuite/tests/ghc-regress/parser/should_compile/all.T @@ -1,43 +1,41 @@ -include ($confdir ++ "/../vanilla-test.T") +test('read001', normal, compile, ['']) +test('read002', normal, compile, ['']) +test('read003', normal, compile, ['']) +test('read004', normal, compile, ['']) +test('read005', normal, compile, ['']) -test "read001" { vtc("") } -test "read002" { vtc("") } -test "read003" { vtc("") } -test "read004" { vtc("") } -test "read005" { vtc("") } +# these two are really a multi-module test, order is important +test('read006', normal, compile, ['']) +test('read007', normal, compile, ['']) --- these two are really a multi-module test, order is important -test "read006" { vtc("") } -test "read007" { vtc("") } +test('read008', normal, compile, ['']) +test('read009', normal, compile, ['']) +test('read010', normal, compile, ['']) +test('read011', normal, compile, ['']) -test "read008" { vtc("") } -test "read009" { vtc("") } -test "read010" { vtc("") } -test "read011" { vtc("") } +# these two are really a multi-module test, order is important +test('read012', omit_ways(['optasm']), compile, ['-fvia-C -funfold-casms-in-hi-file -fglasgow-exts']) +test('read013', normal, compile, ['-fglasgow-exts']) --- these two are really a multi-module test, order is important -test "read012" { vtc("-fvia-C -O -funfold-casms-in-hi-file -fglasgow-exts") } -test "read013" { vtc("-O -fglasgow-exts") } - -test "read014" { vtc("-Wall") } -test "read015" { vtc("") } -test "read016" { vtc("") } -test "read017" { vtc("") } -test "read018" { vtc("") } -test "read019" { vtc("") } -test "read020" { vtc("") } -test "read021" { vtc("") } -test "read022" { vtc("-fglasgow-exts") } -test "read023" { vtc("") } -test "read024" { vtc("-fglasgow-exts") } -test "read025" { vtc("") } -test "read026" { vtc("") } -test "read027" { vtc("") } -test "read028" { vtc("") } -test "read029" { vtc("") } -test "read030" { vtc("") } -test "read031" { vtc("") } -test "read032" { vtc("") } -test "read033" { vtc("") } -test "read034" { vtc("") } +test('read014', normal, compile, ['-Wall']) +test('read015', normal, compile, ['']) +test('read016', normal, compile, ['']) +test('read017', normal, compile, ['']) +test('read018', normal, compile, ['']) +test('read019', normal, compile, ['']) +test('read020', normal, compile, ['']) +test('read021', normal, compile, ['']) +test('read022', normal, compile, ["-fglasgow-exts"]) +test('read023', normal, compile, ['']) +test('read024', normal, compile, ["-fglasgow-exts"]) +test('read025', normal, compile, ['']) +test('read026', normal, compile, ['']) +test('read027', normal, compile, ['']) +test('read028', normal, compile, ['']) +test('read029', normal, compile, ['']) +test('read030', normal, compile, ['']) +test('read031', normal, compile, ['']) +test('read032', normal, compile, ['']) +test('read033', normal, compile, ['']) +test('read034', normal, compile, ['']) diff --git a/testsuite/tests/ghc-regress/parser/should_fail/all.T b/testsuite/tests/ghc-regress/parser/should_fail/all.T index 947fc1c7ab..cda3e0c983 100644 --- a/testsuite/tests/ghc-regress/parser/should_fail/all.T +++ b/testsuite/tests/ghc-regress/parser/should_fail/all.T @@ -1,31 +1,30 @@ -include ($confdir ++ "/../vanilla-test.T") +test('read001', normal, compile_fail, ['']) +test('read002', expect_fail, compile_fail, ['']) +test('read003', normal, compile_fail, ['']) +test('read004', normal, compile_fail, ['']) +test('read005', normal, compile_fail, ['']) +test('read006', normal, compile_fail, ['']) +test('read007', normal, compile_fail, ['']) +test('read008', normal, compile_fail, ['']) +test('read009', normal, compile_fail, ['']) +# test10: missing +test('read011', normal, compile_fail, ['']) +test('read012', normal, compile_fail, ['']) +test('read013', normal, compile_fail, ['-fglasgow-exts']) +test('read014', normal, compile_fail, ['']) +test('read015', normal, compile_fail, ['']) +test('read016', normal, compile_fail, ['']) +test('read017', normal, compile_fail, ['']) +test('read018', normal, compile_fail, ['']) +test('read019', normal, compile_fail, ['']) +test('read020', normal, compile_fail, ['']) -test "read001" { vtcf("") } -test "read002" { $expect = "fail" vtcf("") } -test "read003" { vtcf("") } -test "read004" { vtcf("") } -test "read005" { vtcf("") } -test "read006" { vtcf("") } -test "read007" { vtcf("") } -test "read008" { vtcf("") } -test "read009" { vtcf("") } ---test "read010" { vtcf("") } -test "read011" { vtcf("") } -test "read012" { vtcf("") } -test "read013" { vtcf("-fglasgow-exts") } -test "read014" { vtcf("") } -test "read015" { vtcf("") } -test "read016" { vtcf("") } -test "read017" { vtcf("") } -test "read018" { vtcf("") } -test "read019" { vtcf("") } -test "read020" { vtcf("") } +# empty file (length zero) is a legal Haskell module. It fails to compile +# because it doesn't contain a definition of Main.main. GHC 5.02 crashed +# on this example. +test('read021', normal, compile_fail, ['']) --- empty file (length zero) is a legal Haskell module. It fails to compile --- because it doesn't contain a definition of Main.main. GHC 5.02 crashed --- on this example. -test "read021" { vtcf("") } -test "read022" { vtcf("") } -test "read023" { vtcf("") } -test "read024" { $expect = "fail" vtcf("") } +test('read022', normal, compile_fail, ['']) +test('read023', normal, compile_fail, ['']) +test('read024', expect_fail, compile_fail, ['']) diff --git a/testsuite/tests/ghc-regress/programs/10queens/test.T b/testsuite/tests/ghc-regress/programs/10queens/test.T index bd721cc5b8..f9fda0d4e9 100644 --- a/testsuite/tests/ghc-regress/programs/10queens/test.T +++ b/testsuite/tests/ghc-regress/programs/10queens/test.T @@ -1,9 +1,2 @@ -include ($confdir ++ "/../multimod-test.T") - --- Args to mtr are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "10queens" { mtr("", "", "") } - +test('10queens', normal, multimod_compile_and_run, ['Main', '']) diff --git a/testsuite/tests/ghc-regress/programs/Makefile b/testsuite/tests/ghc-regress/programs/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/ghc-regress/programs/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/ghc-regress/programs/andre_monad/test.T b/testsuite/tests/ghc-regress/programs/andre_monad/test.T index 44250a6084..9ca1884164 100644 --- a/testsuite/tests/ghc-regress/programs/andre_monad/test.T +++ b/testsuite/tests/ghc-regress/programs/andre_monad/test.T @@ -1,9 +1,3 @@ -include ($confdir ++ "/../multimod-test.T") - --- Args to mtr are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "andre_monad" { mtr("", "", "") } +test('andre_monad', normal, multimod_compile_and_run, ['Main', '']) diff --git a/testsuite/tests/ghc-regress/programs/andy_cherry/test.T b/testsuite/tests/ghc-regress/programs/andy_cherry/test.T index 984575c7d7..30ec335f08 100644 --- a/testsuite/tests/ghc-regress/programs/andy_cherry/test.T +++ b/testsuite/tests/ghc-regress/programs/andy_cherry/test.T @@ -1,11 +1,4 @@ -include ($confdir ++ "/../multimod-test.T") - --- Args to mtr are: extra compile flags --- extra run flags --- expected process return value, if not zero - --- The program wants to read stuff from its own directory, --- so we pass it the test dir as its single argument. -test "andy_cherry" { mtr("-package lang -cpp", ".", "") } +test('andy_cherry', extra_run_opts('.'), multimod_compile_and_run, \ + ['Main', '-package lang -cpp']) diff --git a/testsuite/tests/ghc-regress/programs/barton-mangler-bug/test.T b/testsuite/tests/ghc-regress/programs/barton-mangler-bug/test.T index df779b9061..9ecd6d399d 100644 --- a/testsuite/tests/ghc-regress/programs/barton-mangler-bug/test.T +++ b/testsuite/tests/ghc-regress/programs/barton-mangler-bug/test.T @@ -1,9 +1,3 @@ -include ($confdir ++ "/../multimod-test.T") - --- Args to mtr are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "barton-mangler-bug" { mtr("", "", "") } +test('barton-mangler-bug', normal, multimod_compile_and_run, ['Main', '']) diff --git a/testsuite/tests/ghc-regress/programs/callback/test.T b/testsuite/tests/ghc-regress/programs/callback/test.T index f774029a5c..e3fcf9d1e2 100644 --- a/testsuite/tests/ghc-regress/programs/callback/test.T +++ b/testsuite/tests/ghc-regress/programs/callback/test.T @@ -1,9 +1,3 @@ -include ($confdir ++ "/../multimod-test.T") - --- Args to mtr are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "callback" { mtr("-fglasgow-exts -package lang -fvia-C", "", "") } - +test('callback', omit_ways(['optasm']), multimod_compile_and_run, \ + ['Main', '-fglasgow-exts -package lang -fvia-C']) diff --git a/testsuite/tests/ghc-regress/programs/cholewo-eval/test.T b/testsuite/tests/ghc-regress/programs/cholewo-eval/test.T index 449e0341e2..49f0302e59 100644 --- a/testsuite/tests/ghc-regress/programs/cholewo-eval/test.T +++ b/testsuite/tests/ghc-regress/programs/cholewo-eval/test.T @@ -1,9 +1,3 @@ -include ($confdir ++ "/../multimod-test.T") - --- Args to mtr are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "cholewo-eval" { mtr("", "", "") } +test('cholewo-eval', normal, multimod_compile_and_run, ['Main', '']) diff --git a/testsuite/tests/ghc-regress/programs/cvh_unboxing/test.T b/testsuite/tests/ghc-regress/programs/cvh_unboxing/test.T index 1615806247..4d4aed7ea5 100644 --- a/testsuite/tests/ghc-regress/programs/cvh_unboxing/test.T +++ b/testsuite/tests/ghc-regress/programs/cvh_unboxing/test.T @@ -1,9 +1,4 @@ -include ($confdir ++ "/../multimod-test.T") - --- Args to mtr are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "cvh_unboxing" { mtr("-fglasgow-exts", "", "") } +test('cvh_unboxing', normal, multimod_compile_and_run, \ + ['Main', '-fglasgow-exts']) diff --git a/testsuite/tests/ghc-regress/programs/fast2haskell/test.T b/testsuite/tests/ghc-regress/programs/fast2haskell/test.T index 7d35942e22..d2c8575d1c 100644 --- a/testsuite/tests/ghc-regress/programs/fast2haskell/test.T +++ b/testsuite/tests/ghc-regress/programs/fast2haskell/test.T @@ -1,9 +1,4 @@ -include ($confdir ++ "/../multimod-test.T") - --- Args to mtr are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "fast2haskell" { mtr("-fglasgow-exts -package lang", "", "") } +test('fast2haskell', normal, multimod_compile_and_run, \ + ['Main', '-fglasgow-exts -package lang']) diff --git a/testsuite/tests/ghc-regress/programs/fun_insts/test.T b/testsuite/tests/ghc-regress/programs/fun_insts/test.T index 213d7bedc4..819d72e394 100644 --- a/testsuite/tests/ghc-regress/programs/fun_insts/test.T +++ b/testsuite/tests/ghc-regress/programs/fun_insts/test.T @@ -1,9 +1,3 @@ -include ($confdir ++ "/../multimod-test.T") - --- Args to mtr are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "fun_insts" { mtr("", "", "") } +test('fun_insts', normal, multimod_compile_and_run, ['Main', '']) diff --git a/testsuite/tests/ghc-regress/programs/galois_raytrace/test.T b/testsuite/tests/ghc-regress/programs/galois_raytrace/test.T index 3d61a179f5..d7de92b61b 100644 --- a/testsuite/tests/ghc-regress/programs/galois_raytrace/test.T +++ b/testsuite/tests/ghc-regress/programs/galois_raytrace/test.T @@ -1,10 +1,5 @@ -include ($confdir ++ "/../multimod-test.T") - --- Args to mtr are: extra compile flags --- extra run flags --- expected process return value, if not zero - --- pass $testdir so it knows where its home dir is -test "galois_raytrace" { mtr("-O -package lang -package text", "", "") } +# pass $testdir so it knows where its home dir is +test('galois_raytrace', omit_ways(['normal']), multimod_compile_and_run, \ + ['Main', '-O -package lang -package text']) diff --git a/testsuite/tests/ghc-regress/programs/jeff-bug/test.T b/testsuite/tests/ghc-regress/programs/jeff-bug/test.T index 584c8f29bd..6a84a955e5 100644 --- a/testsuite/tests/ghc-regress/programs/jeff-bug/test.T +++ b/testsuite/tests/ghc-regress/programs/jeff-bug/test.T @@ -1,12 +1,5 @@ -include ($confdir ++ "/../multimod-test.T") - --- Args to mtr are: extra compile flags --- extra run flags --- expected process return value, if not zero - --- Lack sensible input file to test it with. -test "jeff-bug" { - $expect = "fail" - mtr("-package lang -fglasgow-exts -cpp", "-count /dev/null", "") - } +test('jeff-bug', \ + compose(expect_fail, extra_run_opts('-count /dev/null'), \ + multimod_compile_and_run, \ + ['Main', '-package lang -fglasgow-exts -cpp']) diff --git a/testsuite/tests/ghc-regress/programs/jl_defaults/test.T b/testsuite/tests/ghc-regress/programs/jl_defaults/test.T index 7557f11379..85951c3346 100644 --- a/testsuite/tests/ghc-regress/programs/jl_defaults/test.T +++ b/testsuite/tests/ghc-regress/programs/jl_defaults/test.T @@ -1,9 +1,3 @@ -include ($confdir ++ "/../multimod-test.T") - --- Args to mtr are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "jl_defaults" { mtr("", "", "") } +test('jl_defaults', normal, multimod_compile_and_run, ['Main', '']) diff --git a/testsuite/tests/ghc-regress/programs/jq_readsPrec/test.T b/testsuite/tests/ghc-regress/programs/jq_readsPrec/test.T index 81d3a4754f..c78e7bbb16 100644 --- a/testsuite/tests/ghc-regress/programs/jq_readsPrec/test.T +++ b/testsuite/tests/ghc-regress/programs/jq_readsPrec/test.T @@ -1,9 +1,3 @@ -include ($confdir ++ "/../multimod-test.T") - --- Args to mtr are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "jq_readsPrec" { mtr("", "", "") } +test('jq_readsPrec', normal, multimod_compile_and_run, ['Main', '']) diff --git a/testsuite/tests/ghc-regress/programs/jtod_circint/test.T b/testsuite/tests/ghc-regress/programs/jtod_circint/test.T index 7325a7f888..45a1bb2aff 100644 --- a/testsuite/tests/ghc-regress/programs/jtod_circint/test.T +++ b/testsuite/tests/ghc-regress/programs/jtod_circint/test.T @@ -1,9 +1,3 @@ -include ($confdir ++ "/../multimod-test.T") - --- Args to mtr are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "jtod_circint" { mtr("", "", "") } +test('jtod_circint', normal, multimod_compile_and_run, ['Main', '']) diff --git a/testsuite/tests/ghc-regress/programs/jules_xref/test.T b/testsuite/tests/ghc-regress/programs/jules_xref/test.T index 2c78c8d5e5..896a27840c 100644 --- a/testsuite/tests/ghc-regress/programs/jules_xref/test.T +++ b/testsuite/tests/ghc-regress/programs/jules_xref/test.T @@ -1,9 +1,3 @@ -include ($confdir ++ "/../multimod-test.T") - --- Args to mtr are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "jules_xref" { mtr("", "", "") } +test('jules_xref', normal, multimod_compile_and_run, ['']) diff --git a/testsuite/tests/ghc-regress/programs/jules_xref2/test.T b/testsuite/tests/ghc-regress/programs/jules_xref2/test.T index 29991307dd..2db52e53d6 100644 --- a/testsuite/tests/ghc-regress/programs/jules_xref2/test.T +++ b/testsuite/tests/ghc-regress/programs/jules_xref2/test.T @@ -1,9 +1,3 @@ -include ($confdir ++ "/../multimod-test.T") - --- Args to mtr are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "jules_xref2" { mtr("", "", "") } +test('jules_xref2', normal, multimod_compile_and_run, ['']) diff --git a/testsuite/tests/ghc-regress/programs/launchbury/test.T b/testsuite/tests/ghc-regress/programs/launchbury/test.T index 6d3c4e04dd..88d1f56887 100644 --- a/testsuite/tests/ghc-regress/programs/launchbury/test.T +++ b/testsuite/tests/ghc-regress/programs/launchbury/test.T @@ -1,9 +1,3 @@ -include ($confdir ++ "/../multimod-test.T") - --- Args to mtr are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "launchbury" { mtr("", "", "") } +test('launchbury', normal, multimod_compile_and_run, ['']) diff --git a/testsuite/tests/ghc-regress/programs/lennart_range/test.T b/testsuite/tests/ghc-regress/programs/lennart_range/test.T index beafb27cd3..d2ebca0ec6 100644 --- a/testsuite/tests/ghc-regress/programs/lennart_range/test.T +++ b/testsuite/tests/ghc-regress/programs/lennart_range/test.T @@ -1,9 +1,3 @@ -include ($confdir ++ "/../multimod-test.T") - --- Args to mtr are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "lennart_range" { mtr("", "", "") } +test('lennart_range', normal, multimod_compile_and_run, ['']) diff --git a/testsuite/tests/ghc-regress/programs/lex/test.T b/testsuite/tests/ghc-regress/programs/lex/test.T index 1e6b8d1139..8f73b3b3be 100644 --- a/testsuite/tests/ghc-regress/programs/lex/test.T +++ b/testsuite/tests/ghc-regress/programs/lex/test.T @@ -1,9 +1,3 @@ -include ($confdir ++ "/../multimod-test.T") - --- Args to mtr are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "lex" { mtr("", "", "") } +test('lex', normal, multimod_compile_and_run, ['']) diff --git a/testsuite/tests/ghc-regress/programs/life_space_leak/test.T b/testsuite/tests/ghc-regress/programs/life_space_leak/test.T index a2c9104b3e..a5f6bb3108 100644 --- a/testsuite/tests/ghc-regress/programs/life_space_leak/test.T +++ b/testsuite/tests/ghc-regress/programs/life_space_leak/test.T @@ -1,9 +1,3 @@ -include ($confdir ++ "/../multimod-test.T") - --- Args to mtr are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "life_space_leak" { mtr("", "", "") } +test('life_space_leak', normal, multimod_compile_and_run, ['']) diff --git a/testsuite/tests/ghc-regress/programs/north_array/test.T b/testsuite/tests/ghc-regress/programs/north_array/test.T index b7cfd87022..c58b47c1a3 100644 --- a/testsuite/tests/ghc-regress/programs/north_array/test.T +++ b/testsuite/tests/ghc-regress/programs/north_array/test.T @@ -1,9 +1,3 @@ -include ($confdir ++ "/../multimod-test.T") - --- Args to mtr are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "north_array" { mtr("", "", "") } +test('north_array', normal, multimod_compile_and_run, ['']) diff --git a/testsuite/tests/ghc-regress/programs/okeefe_neural/test.T b/testsuite/tests/ghc-regress/programs/okeefe_neural/test.T index 308bfcdef4..b4ec1f4fa6 100644 --- a/testsuite/tests/ghc-regress/programs/okeefe_neural/test.T +++ b/testsuite/tests/ghc-regress/programs/okeefe_neural/test.T @@ -1,14 +1,12 @@ -include ($confdir ++ "/../multimod-test.T") +# this one causes the compiler to run out of heap in the simplifier --- Args to mtr are: extra compile flags --- extra run flags --- expected process return value, if not zero +def set_opts( opts ): + opts.expect = 'fail' + # Skip the test on alpha-dec-osf3, where we + # run into an infinite loop on some builds + if config.platform == "alpha-dec-osf3": + opts.skip = 1; --- this one causes the compiler to run out of heap in the simplifier -test "okeefe_neural" { - -- Skip the test on alpha-dec-osf3, where we - -- run into an infinite loop on some builds - skip when $platform == "alpha-dec-osf3" - $expect = "fail" - mtr("-package lang +RTS -M64m -RTS", "", "") } +test('okeefe_neural', set_opts, multimod_compile_and_run, \ + ['Main', '', '-package lang +RTS -M64m -RTS']) diff --git a/testsuite/tests/ghc-regress/programs/record_upd/test.T b/testsuite/tests/ghc-regress/programs/record_upd/test.T index 37d34ff71b..211e6c13f0 100644 --- a/testsuite/tests/ghc-regress/programs/record_upd/test.T +++ b/testsuite/tests/ghc-regress/programs/record_upd/test.T @@ -1,9 +1,3 @@ -include ($confdir ++ "/../multimod-test.T") - --- Args to mtr are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "record_upd" { mtr("", "", "") } +test('record_upd', normal, multimod_compile_and_run, ['']) diff --git a/testsuite/tests/ghc-regress/programs/rittri/test.T b/testsuite/tests/ghc-regress/programs/rittri/test.T index ecc27a7c29..edc515f87d 100644 --- a/testsuite/tests/ghc-regress/programs/rittri/test.T +++ b/testsuite/tests/ghc-regress/programs/rittri/test.T @@ -1,9 +1,3 @@ -include ($confdir ++ "/../multimod-test.T") - --- Args to mtr are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "rittri" { mtr("", "", "") } +test('rittri', normal, multimod_compile_and_run, ['']) diff --git a/testsuite/tests/ghc-regress/programs/sanders_array/test.T b/testsuite/tests/ghc-regress/programs/sanders_array/test.T index b4293afa8e..255db76f8d 100644 --- a/testsuite/tests/ghc-regress/programs/sanders_array/test.T +++ b/testsuite/tests/ghc-regress/programs/sanders_array/test.T @@ -1,9 +1,3 @@ -include ($confdir ++ "/../multimod-test.T") - --- Args to mtr are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "sanders_array" { mtr("", "", "") } +test('sanders_array', normal, multimod_compile_and_run, ['']) diff --git a/testsuite/tests/ghc-regress/programs/seward-space-leak/test.T b/testsuite/tests/ghc-regress/programs/seward-space-leak/test.T index 3b29a79ed1..dd3119f2d3 100644 --- a/testsuite/tests/ghc-regress/programs/seward-space-leak/test.T +++ b/testsuite/tests/ghc-regress/programs/seward-space-leak/test.T @@ -1,9 +1,3 @@ -include ($confdir ++ "/../multimod-test.T") - --- Args to mtr are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "seward-space-leak" { mtr("", "", "") } +test('seward-space-leak', normal, multimod_compile_and_run, ['']) diff --git a/testsuite/tests/ghc-regress/programs/strict_anns/test.T b/testsuite/tests/ghc-regress/programs/strict_anns/test.T index 466920107a..73abb57e11 100644 --- a/testsuite/tests/ghc-regress/programs/strict_anns/test.T +++ b/testsuite/tests/ghc-regress/programs/strict_anns/test.T @@ -1,9 +1,3 @@ -include ($confdir ++ "/../multimod-test.T") - --- Args to mtr are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "strict_anns" { mtr("", "", "") } +test('strict_anns', normal, multimod_compile_and_run, ['']) diff --git a/testsuite/tests/ghc-regress/rename/Makefile b/testsuite/tests/ghc-regress/rename/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/ghc-regress/rename/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/ghc-regress/rename/should_compile/all.T b/testsuite/tests/ghc-regress/rename/should_compile/all.T index 8e93b33794..9fa7cd50a7 100644 --- a/testsuite/tests/ghc-regress/rename/should_compile/all.T +++ b/testsuite/tests/ghc-regress/rename/should_compile/all.T @@ -1,41 +1,38 @@ +# Args to vtc are: extra compile flags -include ($confdir ++ "/../vanilla-test.T") - --- Args to vtc are: extra compile flags - -test "rn003" { vtc("") } -test "rn005" { vtc("") } -test "rn006" { vtc("") } -test "rn009" { vtc("") } -test "rn010" { vtc("") } -test "rn011" { vtc("") } -test "rn012" { vtc("") } -test "rn013" { vtc("") } -test "rn017" { vtc("") } -test "rn019" { vtc("") } -test "rn020" { vtc("") } -test "rn022" { vtc("") } -test "rn023" { vtc("") } -test "rn024" { vtc("") } -test "rn025" { vtc("") } -test "rn026" { vtc("") } -test "rn027" { vtc("") } -test "rn028" { vtc("") } -test "rn029" { vtc("") } -test "rn031" { vtc("") } -test "rn032" { vtc("") } -test "rn033" { vtc("") } -test "rn034" { vtc("") } -test "rn035" { vtc("") } -test "rn036" { vtc("") } +test('rn003', normal, compile, ['']) +test('rn005', normal, compile, ['']) +test('rn006', normal, compile, ['']) +test('rn009', normal, compile, ['']) +test('rn010', normal, compile, ['']) +test('rn011', normal, compile, ['']) +test('rn012', normal, compile, ['']) +test('rn013', normal, compile, ['']) +test('rn017', normal, compile, ['']) +test('rn019', normal, compile, ['']) +test('rn020', normal, compile, ['']) +test('rn022', normal, compile, ['']) +test('rn023', normal, compile, ['']) +test('rn024', normal, compile, ['']) +test('rn025', normal, compile, ['']) +test('rn026', normal, compile, ['']) +test('rn027', normal, compile, ['']) +test('rn028', normal, compile, ['']) +test('rn029', normal, compile, ['']) +test('rn031', normal, compile, ['']) +test('rn032', normal, compile, ['']) +test('rn033', normal, compile, ['']) +test('rn034', normal, compile, ['']) +test('rn035', normal, compile, ['']) +test('rn036', normal, compile, ['']) --- really a mulit-module test: -test "Rn037Help" { vtc("") } -test "rn037" { vtc("") } +# really a mulit-module test: +test('Rn037Help', normal, compile, ['']) +test('rn037', normal, compile, ['']) -test "rn039" { vtc("") } -test "rn040" { $expect = "fail" vtc("") } +test('rn039', normal, compile, ['']) +test('rn040', expect_fail, compile, ['']) -test "timing001" { vtc("") } -test "timing002" { vtc("") } -test "timing003" { vtc("") } +test('timing001', normal, compile, ['']) +test('timing002', normal, compile, ['']) +test('timing003', normal, compile, ['']) diff --git a/testsuite/tests/ghc-regress/rename/should_fail/all.T b/testsuite/tests/ghc-regress/rename/should_fail/all.T index ae766953a0..c2046a14ea 100644 --- a/testsuite/tests/ghc-regress/rename/should_fail/all.T +++ b/testsuite/tests/ghc-regress/rename/should_fail/all.T @@ -1,44 +1,40 @@ -include ($confdir ++ "/../vanilla-test.T") +test('rnfail001', normal, compile_fail, ['']) +test('rnfail002', normal, compile_fail, ['']) +test('rnfail003', normal, compile_fail, ['']) +test('rnfail004', normal, compile_fail, ['']) +test('rnfail007', normal, compile_fail, ['']) +test('rnfail008', normal, compile_fail, ['']) +test('rnfail009', normal, compile_fail, ['']) +test('rnfail010', normal, compile_fail, ['']) +test('rnfail011', normal, compile_fail, ['']) +test('rnfail012', normal, compile_fail, ['']) +test('rnfail013', normal, compile_fail, ['']) +test('rnfail014', normal, compile_fail, ['']) +test('rnfail015', normal, compile_fail, ['']) +test('rnfail016', normal, compile_fail, ['']) +test('rnfail017', normal, compile_fail, ['']) +test('rnfail018', normal, compile_fail, ['']) +test('rnfail019', normal, compile_fail, ['']) +test('rnfail020', normal, compile_fail, ['']) +test('rnfail021', normal, compile_fail, ['']) +test('rnfail022', normal, compile_fail, ['']) +test('rnfail023', normal, compile_fail, ['']) +test('rnfail024', normal, compile_fail, ['']) +test('rnfail025', normal, compile_fail, ['']) +test('rnfail026', normal, compile_fail, ['']) +test('rnfail027', normal, compile_fail, ['']) +test('rnfail028', normal, compile_fail, ['']) +test('rnfail029', normal, compile_fail, ['']) +test('rnfail030', normal, compile_fail, ['']) +test('rnfail031', normal, compile_fail, ['']) +test('rnfail032', normal, compile_fail, ['']) +test('rnfail033', normal, compile_fail, ['']) +test('rnfail034', expect_fail, compile_fail, ['']) +test('rnfail035', normal, compile_fail, ['']) --- Args to vtcf are: extra compile flags +# these two are really a single multi-module test +test('Rn037Help', normal, compile, ['']) +test('rnfail037', normal, compile_fail, ['']) -test "rnfail001" { vtcf("") } -test "rnfail002" { vtcf("") } -test "rnfail003" { vtcf("") } -test "rnfail004" { vtcf("") } -test "rnfail007" { vtcf("") } -test "rnfail008" { vtcf("") } -test "rnfail009" { vtcf("") } -test "rnfail010" { vtcf("") } -test "rnfail011" { vtcf("") } -test "rnfail012" { vtcf("") } -test "rnfail013" { vtcf("") } -test "rnfail014" { vtcf("") } -test "rnfail015" { vtcf("") } -test "rnfail016" { vtcf("") } -test "rnfail017" { vtcf("") } -test "rnfail018" { vtcf("") } -test "rnfail019" { vtcf("") } -test "rnfail020" { vtcf("") } -test "rnfail021" { vtcf("") } -test "rnfail022" { vtcf("") } -test "rnfail023" { vtcf("") } -test "rnfail024" { vtcf("") } -test "rnfail025" { vtcf("") } -test "rnfail026" { vtcf("") } -test "rnfail027" { vtcf("") } -test "rnfail028" { vtcf("") } -test "rnfail029" { vtcf("") } -test "rnfail030" { vtcf("") } -test "rnfail031" { vtcf("") } -test "rnfail032" { vtcf("") } -test "rnfail033" { vtcf("") } -test "rnfail034" { $expect = "fail" vtcf("") } -test "rnfail035" { vtcf("") } - --- these two are really a multi-module tests -test "Rn037Help" { vtc("") } -test "rnfail037" { vtcf("") } - -test "rnfail038" { vtcf("") } +test('rnfail038', normal, compile_fail, ['']) diff --git a/testsuite/tests/ghc-regress/rename/should_fail/rnfail019.stderr b/testsuite/tests/ghc-regress/rename/should_fail/rnfail019.stderr index e2305c377b..f47d3577c6 100644 --- a/testsuite/tests/ghc-regress/rename/should_fail/rnfail019.stderr +++ b/testsuite/tests/ghc-regress/rename/should_fail/rnfail019.stderr @@ -2,4 +2,4 @@ rnfail019.hs:5: The operator `:' [infixr 5] of a section must have lower precedence than the operand `(:)' [infixr 5] - In the section: `((x : y) :)' + in the section: `((x : y) :)' diff --git a/testsuite/tests/ghc-regress/rename/should_fail/rnfail021.stderr b/testsuite/tests/ghc-regress/rename/should_fail/rnfail021.stderr index 76a236f690..929295bc02 100644 --- a/testsuite/tests/ghc-regress/rename/should_fail/rnfail021.stderr +++ b/testsuite/tests/ghc-regress/rename/should_fail/rnfail021.stderr @@ -1,3 +1,4 @@ rnfail021.hs:5: - Invalid use of qualified name `Baz.f' in its declaration + Invalid use of qualified name `Baz.f' + In its declaration diff --git a/testsuite/tests/ghc-regress/simplCore/Makefile b/testsuite/tests/ghc-regress/simplCore/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/ghc-regress/simplCore/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/ghc-regress/simplCore/should_compile/all.T b/testsuite/tests/ghc-regress/simplCore/should_compile/all.T index 06578930da..5978467634 100644 --- a/testsuite/tests/ghc-regress/simplCore/should_compile/all.T +++ b/testsuite/tests/ghc-regress/simplCore/should_compile/all.T @@ -1,21 +1,16 @@ +test('simpl001', normal, compile, ['']) +test('simpl002', normal, compile, ['']) +test('simpl003', normal, compile, ['']) +test('simpl004', normal, compile, ['-package lang']) +test('simpl005', normal, compile, ['']) -include ($confdir ++ "/../vanilla-test.T") +# these two are really a multi-module test +test('Simpl006Help', normal, compile, ['']) +test('simpl006', normal, compile, ['-package concurrent']) --- Args to vtc are: extra compile flags +test('simpl007', normal, compile, ['']) +test('simpl008', normal, compile, ['-fglasgow-exts']) -test "simpl001" { vtc("") } -test "simpl002" { vtc("") } -test "simpl003" { vtc("") } -test "simpl004" { vtc("-package lang") } -test "simpl005" { vtc("") } - --- these two are really a multi-module test -test "Simpl006Help" { vtc("-O") } -test "simpl006" { vtc("-package concurrent") } - -test "simpl007" { vtc("") } -test "simpl008" { vtc("-fglasgow-exts") } - --- these two are really a multi-module test -test "Simpl009Help" { vtc("-O") } -test "simpl009" { vtc("-O") } +# these two are really a multi-module test +test('Simpl009Help', normal, compile, ['']) +test('simpl009', normal, compile, ['']) diff --git a/testsuite/tests/ghc-regress/simplCore/should_run/all.T b/testsuite/tests/ghc-regress/simplCore/should_run/all.T index e51a7fdbad..90a8c0fbfd 100644 --- a/testsuite/tests/ghc-regress/simplCore/should_run/all.T +++ b/testsuite/tests/ghc-regress/simplCore/should_run/all.T @@ -1,9 +1,13 @@ +# Args to compile_and_run are: +# extra compile flags +# extra run flags +# expected process return value, if not zero -include ($confdir ++ "/../vanilla-test.T") +# Only compile with optimisation +def f( opts ): + opts.only_ways = ['opt'] --- Args to vt are: extra compile flags --- extra run flags --- expected process return value, if not zero +setTestOpts(f) -test "simplrun001" { vtr("-O", "", "") } -test "simplrun002" { vtr("-O", "", "") } +test('simplrun001', normal, compile_and_run, ['']) +test('simplrun002', normal, compile_and_run, ['']) diff --git a/testsuite/tests/ghc-regress/stranal/Makefile b/testsuite/tests/ghc-regress/stranal/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/ghc-regress/stranal/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/ghc-regress/stranal/should_compile/all.T b/testsuite/tests/ghc-regress/stranal/should_compile/all.T index 2f712b7524..1a9218d7fc 100644 --- a/testsuite/tests/ghc-regress/stranal/should_compile/all.T +++ b/testsuite/tests/ghc-regress/stranal/should_compile/all.T @@ -1,25 +1,19 @@ +# Only compile with optimisation +def f( opts ): + opts.only_ways = ['opt'] -include ($confdir ++ "/../vanilla-test.T") +setTestOpts(f) --- Args to vtc are: extra compile flags - --- Use this itsy helper fn to pass in an extra flag -def myvtc($extra_comp_args) -{ - vtc(" -O " ++ $extra_comp_args) -} - - -test "default" { myvtc("") } -test "fact" { myvtc("") } -test "fun" { myvtc("") } -test "goo" { myvtc("") } -test "ins" { myvtc("") } -test "map" { myvtc("") } -test "sim" { myvtc("") } -test "str001" { myvtc("") } -test "str002" { myvtc("") } -test "syn" { myvtc("") } -test "test" { myvtc("") } -test "tst" { myvtc("") } -test "unu" { myvtc("") } +test('default', normal, compile, ['']) +test('fact', normal, compile, ['']) +test('fun', normal, compile, ['']) +test('goo', normal, compile, ['']) +test('ins', normal, compile, ['']) +test('map', normal, compile, ['']) +test('sim', normal, compile, ['']) +test('str001', normal, compile, ['']) +test('str002', normal, compile, ['']) +test('syn', normal, compile, ['']) +test('test', normal, compile, ['']) +test('tst', normal, compile, ['']) +test('unu', normal, compile, ['']) diff --git a/testsuite/tests/ghc-regress/typecheck/prog001/test.T b/testsuite/tests/ghc-regress/typecheck/prog001/test.T index 2e62455624..9032686cc7 100644 --- a/testsuite/tests/ghc-regress/typecheck/prog001/test.T +++ b/testsuite/tests/ghc-regress/typecheck/prog001/test.T @@ -1,5 +1,3 @@ -include ($confdir ++ "/../multimod-test.T") - -test "typecheck.prog001" { mtc("C", "-fglasgow-exts") } - +test('typecheck.prog001', normal, multimod_compile, \ + ['C', '-v0 -fglasgow-exts']) diff --git a/testsuite/tests/ghc-regress/typecheck/should_compile/all.T b/testsuite/tests/ghc-regress/typecheck/should_compile/all.T index b5d904e039..d2d619b08b 100644 --- a/testsuite/tests/ghc-regress/typecheck/should_compile/all.T +++ b/testsuite/tests/ghc-regress/typecheck/should_compile/all.T @@ -1,164 +1,160 @@ +# Args to vtc are: extra compile flags -include ($confdir ++ "/../vanilla-test.T") +def f( opts ): + opts.extra_hc_opts = '-fno-warn-incomplete-patterns' --- Args to vtc are: extra compile flags +setTestOpts(f) --- Use this itsy helper fn to pass in an extra flag -def myvtc($extra_comp_args) -{ - vtc(" -fno-warn-incomplete-patterns " ++ $extra_comp_args) -} - -test "tc001" { myvtc("") } -test "tc002" { myvtc("") } -test "tc003" { myvtc("") } -test "tc004" { myvtc("") } -test "tc005" { myvtc("") } -test "tc006" { myvtc("") } -test "tc007" { myvtc("") } -test "tc008" { myvtc("") } -test "tc009" { myvtc("") } -test "tc010" { myvtc("") } -test "tc011" { myvtc("") } -test "tc012" { myvtc("") } -test "tc013" { myvtc("") } -test "tc014" { myvtc("") } -test "tc015" { myvtc("") } -test "tc016" { myvtc("") } -test "tc017" { myvtc("") } -test "tc018" { myvtc("") } -test "tc019" { myvtc("-fglasgow-exts") } -test "tc020" { myvtc("") } -test "tc021" { myvtc("") } -test "tc022" { myvtc("") } -test "tc023" { myvtc("") } -test "tc024" { myvtc("") } -test "tc025" { myvtc("") } -test "tc026" { myvtc("") } -test "tc027" { myvtc("") } -test "tc028" { myvtc("") } -test "tc029" { myvtc("") } -test "tc030" { myvtc("") } -test "tc031" { myvtc("") } -test "tc032" { myvtc("") } -test "tc033" { myvtc("") } -test "tc034" { myvtc("") } -test "tc035" { myvtc("") } -test "tc036" { myvtc("") } -test "tc037" { myvtc("") } -test "tc038" { myvtc("") } -test "tc039" { myvtc("") } -test "tc040" { myvtc("") } -test "tc041" { myvtc("") } -test "tc042" { myvtc("") } -test "tc043" { myvtc("") } -test "tc044" { myvtc("") } -test "tc045" { myvtc("") } -test "tc046" { myvtc("") } -test "tc047" { myvtc("") } -test "tc048" { myvtc("") } -test "tc049" { myvtc("") } -test "tc050" { myvtc("") } -test "tc051" { myvtc("") } -test "tc052" { myvtc("") } -test "tc053" { myvtc("") } -test "tc054" { myvtc("") } -test "tc055" { myvtc("") } -test "tc056" { myvtc("") } -test "tc057" { myvtc("") } -test "tc058" { myvtc("") } -test "tc059" { myvtc("") } -test "tc060" { myvtc("") } -test "tc061" { myvtc("") } -test "tc062" { myvtc("") } -test "tc063" { myvtc("") } -test "tc064" { myvtc("") } -test "tc065" { myvtc("-package lang -package data") } -test "tc066" { myvtc("") } -test "tc067" { myvtc("") } -test "tc068" { myvtc("") } -test "tc069" { myvtc("") } -test "tc070" { myvtc("") } -test "tc073" { myvtc("") } -test "tc074" { myvtc("") } -test "tc076" { myvtc("") } -test "tc077" { myvtc("") } -test "tc078" { myvtc("") } -test "tc079" { myvtc("") } -test "tc080" { myvtc("") } -test "tc081" { myvtc("") } -test "tc082" { myvtc("") } -test "tc084" { myvtc("") } -test "tc085" { myvtc("-package lang") } -test "tc086" { myvtc("") } -test "tc087" { myvtc("-fglasgow-exts") } -test "tc088" { myvtc("-package lang") } -test "tc089" { myvtc("") } -test "tc090" { myvtc("") } -test "tc091" { myvtc("") } -test "tc092" { myvtc("") } -test "tc093" { myvtc("") } -test "tc094" { myvtc("") } -test "tc095" { myvtc("") } -test "tc096" { myvtc("") } -test "tc097" { myvtc("-fglasgow-exts") } -test "tc098" { myvtc("") } -test "tc099" { myvtc("") } -test "tc100" { myvtc("-O") } -test "tc101" { myvtc("") } -test "tc102" { myvtc("") } -test "tc103" { myvtc("") } -test "tc104" { myvtc("") } -test "tc105" { myvtc("") } -test "tc106" { myvtc("") } -test "tc107" { myvtc("") } -test "tc108" { myvtc("-fglasgow-exts") } -test "tc109" { myvtc("") } -test "tc111" { myvtc("") } -test "tc112" { myvtc("") } -test "tc113" { myvtc("") } -test "tc114" { myvtc("") } -test "tc115" { myvtc("") } -test "tc116" { myvtc("") } -test "tc117" { myvtc("") } -test "tc118" { myvtc("") } -test "tc119" { myvtc("") } -test "tc120" { myvtc("") } -test "tc121" { myvtc("") } -test "tc122" { myvtc("") } -test "tc123" { myvtc("") } -test "tc124" { myvtc("") } -test "tc125" { myvtc("") } -test "tc126" { myvtc("") } -test "tc127" { myvtc("") } -test "tc128" { myvtc("") } -test "tc129" { myvtc("") } -test "tc130" { myvtc("") } -test "tc131" { myvtc("") } -test "tc132" { myvtc("-package lang") } -test "tc133" { myvtc("") } -test "tc134" { myvtc("") } -test "tc135" { myvtc("") } -test "tc136" { myvtc("") } -test "tc137" { myvtc("") } -test "tc140" { myvtc("") } -test "tc141" { myvtc("") } -test "tc142" { myvtc("") } -test "tc143" { myvtc("") } -test "tc144" { myvtc("") } -test "tc145" { myvtc("") } -test "tc146" { myvtc("") } -test "tc147" { myvtc("") } -test "tc148" { myvtc("") } -test "tc149" { myvtc("") } -test "tc150" { myvtc("") } -test "tc151" { myvtc("") } -test "tc152" { myvtc("") } -test "tc153" { myvtc("") } -test "tc154" { myvtc("") } -test "tc155" { myvtc("") } -test "tc156" { myvtc("") } -test "tc157" { myvtc("") } -test "tc158" { myvtc("") } -test "tc159" { myvtc("") } -test "tc160" { myvtc("") } +test('tc001', normal, compile, ['']) +test('tc002', normal, compile, ['']) +test('tc003', normal, compile, ['']) +test('tc004', normal, compile, ['']) +test('tc005', normal, compile, ['']) +test('tc006', normal, compile, ['']) +test('tc007', normal, compile, ['']) +test('tc008', normal, compile, ['']) +test('tc009', normal, compile, ['']) +test('tc010', normal, compile, ['']) +test('tc011', normal, compile, ['']) +test('tc012', normal, compile, ['']) +test('tc013', normal, compile, ['']) +test('tc014', normal, compile, ['']) +test('tc015', normal, compile, ['']) +test('tc016', normal, compile, ['']) +test('tc017', normal, compile, ['']) +test('tc018', normal, compile, ['']) +test('tc019', normal, compile, ['-fglasgow-exts']) +test('tc020', normal, compile, ['']) +test('tc021', normal, compile, ['']) +test('tc022', normal, compile, ['']) +test('tc023', normal, compile, ['']) +test('tc024', normal, compile, ['']) +test('tc025', normal, compile, ['']) +test('tc026', normal, compile, ['']) +test('tc027', normal, compile, ['']) +test('tc028', normal, compile, ['']) +test('tc029', normal, compile, ['']) +test('tc030', normal, compile, ['']) +test('tc031', normal, compile, ['']) +test('tc032', normal, compile, ['']) +test('tc033', normal, compile, ['']) +test('tc034', normal, compile, ['']) +test('tc035', normal, compile, ['']) +test('tc036', normal, compile, ['']) +test('tc037', normal, compile, ['']) +test('tc038', normal, compile, ['']) +test('tc039', normal, compile, ['']) +test('tc040', normal, compile, ['']) +test('tc041', normal, compile, ['']) +test('tc042', normal, compile, ['']) +test('tc043', normal, compile, ['']) +test('tc044', normal, compile, ['']) +test('tc045', normal, compile, ['']) +test('tc046', normal, compile, ['']) +test('tc047', normal, compile, ['']) +test('tc048', normal, compile, ['']) +test('tc049', normal, compile, ['']) +test('tc050', normal, compile, ['']) +test('tc051', normal, compile, ['']) +test('tc052', normal, compile, ['']) +test('tc053', normal, compile, ['']) +test('tc054', normal, compile, ['']) +test('tc055', normal, compile, ['']) +test('tc056', normal, compile, ['']) +test('tc057', normal, compile, ['']) +test('tc058', normal, compile, ['']) +test('tc059', normal, compile, ['']) +test('tc060', normal, compile, ['']) +test('tc061', normal, compile, ['']) +test('tc062', normal, compile, ['']) +test('tc063', normal, compile, ['']) +test('tc064', normal, compile, ['']) +test('tc065', normal, compile, ['-package lang -package data']) +test('tc066', normal, compile, ['']) +test('tc067', normal, compile, ['']) +test('tc068', normal, compile, ['']) +test('tc069', normal, compile, ['']) +test('tc070', normal, compile, ['']) +test('tc073', normal, compile, ['']) +test('tc074', normal, compile, ['']) +test('tc076', normal, compile, ['']) +test('tc077', normal, compile, ['']) +test('tc078', normal, compile, ['']) +test('tc079', normal, compile, ['']) +test('tc080', normal, compile, ['']) +test('tc081', normal, compile, ['']) +test('tc082', normal, compile, ['']) +test('tc084', normal, compile, ['']) +test('tc085', normal, compile, ['-package lang']) +test('tc086', normal, compile, ['']) +test('tc087', normal, compile, ['-fglasgow-exts']) +test('tc088', normal, compile, ['-package lang']) +test('tc089', normal, compile, ['']) +test('tc090', normal, compile, ['']) +test('tc091', normal, compile, ['']) +test('tc092', normal, compile, ['']) +test('tc093', normal, compile, ['']) +test('tc094', normal, compile, ['']) +test('tc095', normal, compile, ['']) +test('tc096', normal, compile, ['']) +test('tc097', normal, compile, ['-fglasgow-exts']) +test('tc098', normal, compile, ['']) +test('tc099', normal, compile, ['']) +test('tc100', normal, compile, ['']) +test('tc101', normal, compile, ['']) +test('tc102', normal, compile, ['']) +test('tc103', normal, compile, ['']) +test('tc104', normal, compile, ['']) +test('tc105', normal, compile, ['']) +test('tc106', normal, compile, ['']) +test('tc107', normal, compile, ['']) +test('tc108', normal, compile, ['-fglasgow-exts']) +test('tc109', normal, compile, ['']) +test('tc111', normal, compile, ['']) +test('tc112', normal, compile, ['']) +test('tc113', normal, compile, ['']) +test('tc114', normal, compile, ['']) +test('tc115', normal, compile, ['']) +test('tc116', normal, compile, ['']) +test('tc117', normal, compile, ['']) +test('tc118', normal, compile, ['']) +test('tc119', normal, compile, ['']) +test('tc120', normal, compile, ['']) +test('tc121', normal, compile, ['']) +test('tc122', normal, compile, ['']) +test('tc123', normal, compile, ['']) +test('tc124', normal, compile, ['']) +test('tc125', normal, compile, ['']) +test('tc126', normal, compile, ['']) +test('tc127', normal, compile, ['']) +test('tc128', normal, compile, ['']) +test('tc129', normal, compile, ['']) +test('tc130', normal, compile, ['']) +test('tc131', normal, compile, ['']) +test('tc132', normal, compile, ['-package lang']) +test('tc133', normal, compile, ['']) +test('tc134', normal, compile, ['']) +test('tc135', normal, compile, ['']) +test('tc136', normal, compile, ['']) +test('tc137', normal, compile, ['']) +test('tc140', normal, compile, ['']) +test('tc141', normal, compile, ['']) +test('tc142', normal, compile, ['']) +test('tc143', normal, compile, ['']) +test('tc144', normal, compile, ['']) +test('tc145', normal, compile, ['']) +test('tc146', normal, compile, ['']) +test('tc147', normal, compile, ['']) +test('tc148', normal, compile, ['']) +test('tc149', normal, compile, ['']) +test('tc150', normal, compile, ['']) +test('tc151', normal, compile, ['']) +test('tc152', normal, compile, ['']) +test('tc153', normal, compile, ['']) +test('tc154', normal, compile, ['']) +test('tc155', normal, compile, ['']) +test('tc156', normal, compile, ['']) +test('tc157', normal, compile, ['']) +test('tc158', normal, compile, ['']) +test('tc159', normal, compile, ['']) +test('tc160', normal, compile, ['']) diff --git a/testsuite/tests/ghc-regress/typecheck/should_fail/all.T b/testsuite/tests/ghc-regress/typecheck/should_fail/all.T index ebd2ae8d3a..5a8603179a 100644 --- a/testsuite/tests/ghc-regress/typecheck/should_fail/all.T +++ b/testsuite/tests/ghc-regress/typecheck/should_fail/all.T @@ -1,108 +1,101 @@ -include ($confdir ++ "/../vanilla-test.T") +test('tcfail001', normal, compile_fail, ['']) +test('tcfail002', normal, compile_fail, ['']) +test('tcfail003', normal, compile_fail, ['']) +test('tcfail004', normal, compile_fail, ['']) +test('tcfail005', normal, compile_fail, ['']) +test('tcfail006', normal, compile_fail, ['']) +test('tcfail007', normal, compile_fail, ['']) +test('tcfail008', normal, compile_fail, ['']) +test('tcfail009', normal, compile_fail, ['']) +test('tcfail010', normal, compile_fail, ['']) +test('tcfail011', normal, compile_fail, ['']) +test('tcfail012', normal, compile_fail, ['']) +test('tcfail013', normal, compile_fail, ['']) +test('tcfail014', normal, compile_fail, ['']) +test('tcfail015', normal, compile_fail, ['']) +test('tcfail016', normal, compile_fail, ['']) +test('tcfail017', normal, compile_fail, ['']) +test('tcfail018', normal, compile_fail, ['']) +test('tcfail019', normal, compile_fail, ['']) +test('tcfail020', normal, compile_fail, ['']) +test('tcfail021', normal, compile_fail, ['']) +test('tcfail023', normal, compile_fail, ['']) +test('tcfail027', normal, compile_fail, ['']) +test('tcfail028', normal, compile_fail, ['']) +test('tcfail029', normal, compile_fail, ['']) +test('tcfail030', normal, compile_fail, ['']) +test('tcfail031', normal, compile_fail, ['']) +test('tcfail032', normal, compile_fail, ['']) +test('tcfail033', normal, compile_fail, ['']) +test('tcfail034', normal, compile_fail, ['']) +test('tcfail035', normal, compile_fail, ['']) +test('tcfail036', normal, compile_fail, ['']) +test('tcfail037', normal, compile_fail, ['']) +test('tcfail038', normal, compile_fail, ['']) +test('tcfail040', normal, compile_fail, ['']) +test('tcfail042', normal, compile_fail, ['']) +test('tcfail043', normal, compile_fail, ['']) +test('tcfail044', normal, compile_fail, ['']) +test('tcfail045', normal, compile_fail, ['-fglasgow-exts -package lang']) +test('tcfail046', normal, compile_fail, ['']) +test('tcfail047', normal, compile_fail, ['']) +test('tcfail048', normal, compile_fail, ['']) +test('tcfail049', normal, compile_fail, ['']) +test('tcfail050', normal, compile_fail, ['']) +test('tcfail051', normal, compile_fail, ['']) +test('tcfail052', normal, compile_fail, ['']) +test('tcfail053', normal, compile_fail, ['']) +test('tcfail054', normal, compile_fail, ['']) +test('tcfail055', normal, compile_fail, ['']) +test('tcfail056', normal, compile_fail, ['']) +test('tcfail057', normal, compile_fail, ['']) +test('tcfail058', normal, compile_fail, ['']) +test('tcfail061', normal, compile_fail, ['']) +test('tcfail062', normal, compile_fail, ['']) +test('tcfail063', normal, compile_fail, ['']) +test('tcfail065', normal, compile_fail, ['']) +test('tcfail067', normal, compile_fail, ['']) +test('tcfail068', normal, compile_fail, ['-fglasgow-exts -package lang']) +test('tcfail069', normal, compile_fail, ['']) +test('tcfail070', normal, compile_fail, ['']) +test('tcfail071', normal, compile_fail, ['']) +test('tcfail072', normal, compile_fail, ['']) +test('tcfail073', normal, compile_fail, ['']) +test('tcfail075', normal, compile_fail, ['']) +test('tcfail076', normal, compile_fail, ['']) +test('tcfail077', normal, compile_fail, ['']) +test('tcfail078', normal, compile_fail, ['']) +test('tcfail079', normal, compile_fail, ['']) +test('tcfail080', expect_fail, compile_fail, ['-fglasgow-exts -package lang']) +test('tcfail082', normal, compile_fail, ['']) +test('tcfail083', normal, compile_fail, ['']) +test('tcfail084', normal, compile_fail, ['']) +test('tcfail085', normal, compile_fail, ['']) +test('tcfail086', normal, compile_fail, ['']) +test('tcfail087', normal, compile_fail, ['']) +test('tcfail088', normal, compile_fail, ['']) +test('tcfail089', normal, compile_fail, ['']) +test('tcfail090', normal, compile_fail, ['']) +test('tcfail091', normal, compile_fail, ['']) +test('tcfail092', normal, compile_fail, ['']) +test('tcfail093', normal, compile_fail, ['']) +test('tcfail094', normal, compile_fail, ['']) +test('tcfail095', normal, compile_fail, ['']) +test('tcfail096', normal, compile_fail, ['']) +test('tcfail097', normal, compile_fail, ['']) --- Args to vtcf are: extra compile flags +# The compiler should reject tc098, but it doesn't. Hence +# this is an expected failure. +test('tcfail098', expect_fail, compile_fail, ['']) -test "tcfail001" { vtcf("") } -test "tcfail002" { vtcf("") } -test "tcfail003" { vtcf("") } -test "tcfail004" { vtcf("") } -test "tcfail005" { vtcf("") } -test "tcfail006" { vtcf("") } -test "tcfail007" { vtcf("") } -test "tcfail008" { vtcf("") } -test "tcfail009" { vtcf("") } -test "tcfail010" { vtcf("") } -test "tcfail011" { vtcf("") } -test "tcfail012" { vtcf("") } -test "tcfail013" { vtcf("") } -test "tcfail014" { vtcf("") } -test "tcfail015" { vtcf("") } -test "tcfail016" { vtcf("") } -test "tcfail017" { vtcf("") } -test "tcfail018" { vtcf("") } -test "tcfail019" { vtcf("") } -test "tcfail020" { vtcf("") } -test "tcfail021" { vtcf("") } -test "tcfail023" { vtcf("") } -test "tcfail027" { vtcf("") } -test "tcfail028" { vtcf("") } -test "tcfail029" { vtcf("") } -test "tcfail030" { vtcf("") } -test "tcfail031" { vtcf("") } -test "tcfail032" { vtcf("") } -test "tcfail033" { vtcf("") } -test "tcfail034" { vtcf("") } -test "tcfail035" { vtcf("") } -test "tcfail036" { vtcf("") } -test "tcfail037" { vtcf("") } -test "tcfail038" { vtcf("") } -test "tcfail040" { vtcf("") } -test "tcfail042" { vtcf("") } -test "tcfail043" { vtcf("") } -test "tcfail044" { vtcf("") } -test "tcfail045" { vtcf("-fglasgow-exts -package lang") } -test "tcfail046" { vtcf("") } -test "tcfail047" { vtcf("") } -test "tcfail048" { vtcf("") } -test "tcfail049" { vtcf("") } -test "tcfail050" { vtcf("") } -test "tcfail051" { vtcf("") } -test "tcfail052" { vtcf("") } -test "tcfail053" { vtcf("") } -test "tcfail054" { vtcf("") } -test "tcfail055" { vtcf("") } -test "tcfail056" { vtcf("") } -test "tcfail057" { vtcf("") } -test "tcfail058" { vtcf("") } -test "tcfail061" { vtcf("") } -test "tcfail062" { vtcf("") } -test "tcfail063" { vtcf("") } -test "tcfail065" { vtcf("") } -test "tcfail067" { vtcf("") } -test "tcfail068" { vtcf("-fglasgow-exts -package lang") } -test "tcfail069" { vtcf("") } -test "tcfail070" { vtcf("") } -test "tcfail071" { vtcf("") } -test "tcfail072" { vtcf("") } -test "tcfail073" { vtcf("") } -test "tcfail075" { vtcf("") } -test "tcfail076" { vtcf("") } -test "tcfail077" { vtcf("") } -test "tcfail078" { vtcf("") } -test "tcfail079" { vtcf("") } -test "tcfail080" { $expect = "fail" - vtcf("-fglasgow-exts -package lang") } -test "tcfail082" { vtcf("") } -test "tcfail083" { vtcf("") } -test "tcfail084" { vtcf("") } -test "tcfail085" { vtcf("") } -test "tcfail086" { vtcf("") } -test "tcfail087" { vtcf("") } -test "tcfail088" { vtcf("") } -test "tcfail089" { vtcf("-O") } -test "tcfail090" { vtcf("") } -test "tcfail091" { vtcf("") } -test "tcfail092" { vtcf("") } -test "tcfail093" { vtcf("") } -test "tcfail094" { vtcf("") } -test "tcfail095" { vtcf("") } -test "tcfail096" { vtcf("") } -test "tcfail097" { vtcf("") } - --- The compiler should reject tc098, but it doesn't. Hence --- this is an expected failure. -test "tcfail098" { $expect = "fail" - vtcf("") } - -test "tcfail099" { vtcf("") } - -test "tcfail100" { vtcf("") } -test "tcfail101" { vtcf("") } -test "tcfail102" { vtcf("") } -test "tcfail103" { vtcf("") } -test "tcfail104" { vtcf("") } -test "tcfail105" { vtcf("") } -test "tcfail106" { vtcf("") } -test "tcfail107" { vtcf("") } -test "tcfail108" { vtcf("") } +test('tcfail099', normal, compile_fail, ['']) +test('tcfail100', normal, compile_fail, ['']) +test('tcfail101', normal, compile_fail, ['']) +test('tcfail102', normal, compile_fail, ['']) +test('tcfail103', normal, compile_fail, ['']) +test('tcfail104', normal, compile_fail, ['']) +test('tcfail105', normal, compile_fail, ['']) +test('tcfail106', normal, compile_fail, ['']) +test('tcfail107', normal, compile_fail, ['']) +test('tcfail108', normal, compile_fail, ['']) diff --git a/testsuite/tests/ghc-regress/typecheck/should_fail/tcfail004.stderr b/testsuite/tests/ghc-regress/typecheck/should_fail/tcfail004.stderr index 5325da03db..465abaa67a 100644 --- a/testsuite/tests/ghc-regress/typecheck/should_fail/tcfail004.stderr +++ b/testsuite/tests/ghc-regress/typecheck/should_fail/tcfail004.stderr @@ -3,4 +3,4 @@ tcfail004.hs:3: Couldn't match `(t, t1)' against `(t2, t3, t4)' Expected type: (t, t1) Inferred type: (t2, t3, t4) - in a pattern binding: (1, 2, 3) + In a pattern binding: (1, 2, 3) diff --git a/testsuite/tests/ghc-regress/typecheck/should_fail/tcfail038.stderr b/testsuite/tests/ghc-regress/typecheck/should_fail/tcfail038.stderr index d16461ee67..8c7e05e977 100644 --- a/testsuite/tests/ghc-regress/typecheck/should_fail/tcfail038.stderr +++ b/testsuite/tests/ghc-regress/typecheck/should_fail/tcfail038.stderr @@ -1,8 +1,8 @@ tcfail038.hs:9: Conflicting definitions for `==' - in the bindings in an instance declaration + In the bindings in an instance declaration tcfail038.hs:10: Conflicting definitions for `/=' - in the bindings in an instance declaration + In the bindings in an instance declaration diff --git a/testsuite/tests/ghc-regress/typecheck/should_fail/tcfail043.stderr b/testsuite/tests/ghc-regress/typecheck/should_fail/tcfail043.stderr index 3dd8884368..f2a6332590 100644 --- a/testsuite/tests/ghc-regress/typecheck/should_fail/tcfail043.stderr +++ b/testsuite/tests/ghc-regress/typecheck/should_fail/tcfail043.stderr @@ -3,7 +3,7 @@ tcfail043.hs:38: Ambiguous type variable(s) `a' in the constraint `Ord_ a' arising from use of `gt' at tcfail043.hs:38 In the predicate expression: gt (hd bs) a - in a lambda abstraction: + In a lambda abstraction: if gt (hd bs) a then False else diff --git a/testsuite/tests/ghc-regress/typecheck/should_fail/tcfail044.stderr b/testsuite/tests/ghc-regress/typecheck/should_fail/tcfail044.stderr index f7687ffcc4..8b68d12b36 100644 --- a/testsuite/tests/ghc-regress/typecheck/should_fail/tcfail044.stderr +++ b/testsuite/tests/ghc-regress/typecheck/should_fail/tcfail044.stderr @@ -1,12 +1,12 @@ -./tcfail044.hs:5: +tcfail044.hs:5: Illegal instance declaration for `Eq (a -> a)' - (the instance type must be of form (T a b c) + (The instance type must be of form (T a b c) where T is not a synonym, and a,b,c are distinct type variables) In the instance declaration for `Eq (a -> a)' -./tcfail044.hs:8: +tcfail044.hs:8: Illegal instance declaration for `Num (a -> a)' - (the instance type must be of form (T a b c) + (The instance type must be of form (T a b c) where T is not a synonym, and a,b,c are distinct type variables) In the instance declaration for `Num (a -> a)' diff --git a/testsuite/tests/ghc-regress/typecheck/should_fail/tcfail047.stderr b/testsuite/tests/ghc-regress/typecheck/should_fail/tcfail047.stderr index a82ce5676a..cc32a6d6ce 100644 --- a/testsuite/tests/ghc-regress/typecheck/should_fail/tcfail047.stderr +++ b/testsuite/tests/ghc-regress/typecheck/should_fail/tcfail047.stderr @@ -1,6 +1,6 @@ -./tcfail047.hs:6: +tcfail047.hs:6: Illegal instance declaration for `A (a, (b, c))' - (the instance type must be of form (T a b c) + (The instance type must be of form (T a b c) where T is not a synonym, and a,b,c are distinct type variables) In the instance declaration for `A (a, (b, c))' diff --git a/testsuite/tests/ghc-regress/typecheck/should_run/all.T b/testsuite/tests/ghc-regress/typecheck/should_run/all.T index 7e27860891..36a3db21d5 100644 --- a/testsuite/tests/ghc-regress/typecheck/should_run/all.T +++ b/testsuite/tests/ghc-regress/typecheck/should_run/all.T @@ -1,28 +1,26 @@ +# Args to compile_and_run are: +# extra compile flags +# extra run flags +# expected process return value, if not zero -include ($confdir ++ "/../vanilla-test.T") - --- Args to vt are: extra compile flags --- extra run flags --- expected process return value, if not zero - -test "tcrun001" { vtr("", "", "") } -test "tcrun002" { vtr("", "", "") } -test "tcrun003" { vtr("-fglasgow-exts", "", "") } -test "tcrun004" { vtr("-fglasgow-exts", "", "") } -test "tcrun005" { vtr("", "", "") } -test "tcrun006" { vtr("", "", "") } -test "tcrun007" { vtr("", "", "") } -test "tcrun008" { vtr("", "", "") } -test "tcrun009" { vtr("", "", "") } -test "tcrun010" { vtr("", "", "") } -test "tcrun011" { vtr("", "", "") } -test "tcrun012" { vtr("", "", "") } -test "tcrun013" { vtr("", "", "") } -test "tcrun014" { vtr("", "", "") } -test "tcrun015" { vtr("-O", "", "") } -test "tcrun016" { vtr("", "", "") } -test "tcrun017" { vtr("", "", "") } -test "tcrun018" { vtr("", "", "") } -test "tcrun019" { vtr("", "", "") } -test "tcrun020" { vtr("", "", "") } -test "tcrun021" { vtr("-package data", "", "") } +test('tcrun001', normal, compile_and_run, ['']) +test('tcrun002', normal, compile_and_run, ['']) +test('tcrun003', normal, compile_and_run, ['-fglasgow-exts']) +test('tcrun004', normal, compile_and_run, ['-fglasgow-exts']) +test('tcrun005', normal, compile_and_run, ['']) +test('tcrun006', normal, compile_and_run, ['']) +test('tcrun007', normal, compile_and_run, ['']) +test('tcrun008', normal, compile_and_run, ['']) +test('tcrun009', normal, compile_and_run, ['']) +test('tcrun010', normal, compile_and_run, ['']) +test('tcrun011', normal, compile_and_run, ['']) +test('tcrun012', normal, compile_and_run, ['']) +test('tcrun013', normal, compile_and_run, ['']) +test('tcrun014', normal, compile_and_run, ['']) +test('tcrun015', normal, compile_and_run, ['-O']) +test('tcrun016', normal, compile_and_run, ['']) +test('tcrun017', normal, compile_and_run, ['']) +test('tcrun018', normal, compile_and_run, ['']) +test('tcrun019', normal, compile_and_run, ['']) +test('tcrun020', normal, compile_and_run, ['']) +test('tcrun021', normal, compile_and_run, ['-package data']) diff --git a/testsuite/tests/ghc-regress/typecheck/should_run/tcrun022.hs b/testsuite/tests/ghc-regress/typecheck/should_run/tcrun022.hs deleted file mode 100644 index 0988220342..0000000000 --- a/testsuite/tests/ghc-regress/typecheck/should_run/tcrun022.hs +++ /dev/null @@ -1,19 +0,0 @@ --- Test the implementation of negative patterns. --- We should get a call to 'negate'. - -module Main where - -main = print (minusTwo,trueOrFalse) - -minusTwo = -2::N - -trueOrFalse = - case minusTwo of - -2 -> True - _ -> False - -data N = Negate N | FromInteger Integer deriving (Eq,Show) - -instance Num N where - negate = Negate - fromInteger = FromInteger diff --git a/testsuite/tests/ghc-regress/typecheck/should_run/tcrun022.stdout b/testsuite/tests/ghc-regress/typecheck/should_run/tcrun022.stdout deleted file mode 100644 index 1f0a31b942..0000000000 --- a/testsuite/tests/ghc-regress/typecheck/should_run/tcrun022.stdout +++ /dev/null @@ -1 +0,0 @@ -(Negate (FromInteger 2),True) |