Commit 747a95e2 authored by POTTIER Francois's avatar POTTIER Francois

Recognize groups of files that form a single test case.

parent af4bfadc
true: \
package(str), \
package(unix), \
......@@ -98,3 +98,45 @@ let silent command : command =
let succeeds command : bool =
Sys.command (silent command) = 0
(* [groups eq xs] segments the list [xs] into a list of groups, where several
consecutive elements belong in the same group if they are equivalent in the
sense of the function [eq]. *)
(* The auxiliary function [groups1] deals with the case where we have an open
group [group] of which [x] is a member. The auxiliary function [group0]
deals with the case where we have no open group. [groups] is the list of
closed groups found so far, and [ys] is the list of elements that remain to
be examined. *)
let rec groups1 eq groups x group ys =
match ys with
| [] ->
group :: groups
| y :: ys ->
if eq x y then
groups1 eq groups x (y :: group) ys
groups0 eq (group :: groups) (y :: ys)
and groups0 eq groups ys =
match ys with
| [] ->
| y :: ys ->
groups1 eq groups y [y] ys
let groups eq (xs : 'a list) : 'a list list =
List.rev (groups0 eq [] xs)
(* [chop_numeric_suffix s] removes any numeric suffix off the string [s]. *)
let numeric_suffix =
Str.regexp "[0-9]*$"
let chop_numeric_suffix s =
let offset = Str.search_forward numeric_suffix s 0 in
String.sub s 0 offset
let equal_up_to_numeric_suffix s1 s2 =
chop_numeric_suffix s1 = chop_numeric_suffix s2
......@@ -27,11 +27,20 @@ let menhir =
(* Tests. *)
type input =
| NegativeTest of string (* basename *)
(* A negative test input is a list of basenames, without the .mly extension.
These files must be passed together to menhir. *)
| NegativeTest of filename list
let id basenames =
(* A name for a group of test files. *)
if length basenames = 1 then
hd basenames
sprintf "%s[0-9] (%d files)" (chop_numeric_suffix (hd basenames)) (length basenames)
let print_input = function
| NegativeTest basename ->
| NegativeTest basenames ->
hd basenames
type outcome =
| Success
......@@ -45,15 +54,21 @@ type outputs = output list
let process input : output =
match input with
| NegativeTest basename ->
printf "Testing %s...\n%!" basename;
let command = sprintf "%s %s.mly" menhir basename in
| NegativeTest basenames ->
let id = id basenames in
printf "Testing %s...\n%!" id;
let filenames = map (fun basename -> basename ^ ".mly") basenames in
let command = fold_left (fun s1 s2 -> s1 ^ " " ^ s2) menhir filenames in
if succeeds command then begin
printf "[FAIL] %s\n%!" basename;
input, Failure (sprintf "menhir should not accept %s.mly." basename)
printf "[FAIL] %s\n%!" id;
let message =
sprintf "menhir should not accept %s."
(if length basenames > 1 then "these input files" else "this input file")
input, Failure message
else begin
printf "[OK] %s\n%!" basename;
printf "[OK] %s\n%!" id;
input, Success
......@@ -72,13 +87,18 @@ let run (inputs : inputs) : outputs =
(* Main. *)
(* Menhir can accept several .mly files at once. By convention, if several
files have the same name up to a numeric suffix, then they belong in a
single group and should be fed together to Menhir. *)
let negative : inputs =
readdir bad
|> to_list
|> filter (has_suffix ".mly")
|> map chop_extension
|> sort compare
|> map (fun basename -> NegativeTest basename)
|> groups equal_up_to_numeric_suffix
|> map (fun basenames -> NegativeTest basenames)
let inputs =
Markdown is supported
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment