Commit 9a89416f authored by Kim Nguyễn's avatar Kim Nguyễn
Browse files

Fix the pretty-printer for types and add some tests.

parent 84f8ec82
profile = conventional
align-cases = true
exp-grouping=preserve
exp-grouping = preserve
......@@ -24,9 +24,9 @@ directory may be present to share code and input files between `good` and `bad`.
- `good`:
- `bad`:
- `ocamliface`:
- `good`:
- `bad`:
- `ocaml_ext`:
- `good`: Like `full/good` but uses OCaml primitives embeded in the runtime
- `bad`: Like `full/bad` but uses OCaml primitives embeded in the runtime
## Running tests
Tests are simply run by invoking
......
(* Inspired by F. Pottier's test infrastructure for Menhir *)
type kind = Good | Bad
let kind = ref Good
let files = ref []
let spec =
Arg.[
( "--kind",
String
(function
| "good" -> kind := Good
| "bad" -> kind := Bad
| _ -> raise @@ Bad "the kind must be `good` or `bad`."),
" <good|bad> sets the kind of tests to generate (defeault: good)" );
]
Arg.
[
( "--kind",
String
(function
| "good" -> kind := Good
| "bad" -> kind := Bad
| _ -> raise @@ Bad "the kind must be `good` or `bad`."),
" <good|bad> sets the kind of tests to generate (defeault: good)" );
]
let input_files s = files := s :: !files
let usage = Format.sprintf "%s [options] <file> [...]" Sys.argv.(0)
let parse_argv ?(extra=[]) () =
let parse_argv ?(extra = []) () =
let spec = Arg.align (spec @ extra) in
Arg.parse spec input_files usage
let check_file f ext =
Filename.check_suffix f ext && Sys.file_exists f
let check_file f ext = Filename.check_suffix f ext && Sys.file_exists f
let protect f g =
try
......@@ -34,12 +36,9 @@ let protect f g =
g ();
raise e
let cduce_prog ext =
if ext then "cduce_external"
else "cduce"
let cduce_prog ext = if ext then "cduce_external" else "cduce"
let cduce_compile_rule ?(ext=false) base =
let cduce_compile_rule ?(ext = false) base =
let cduce = cduce_prog ext in
let cflags = base ^ ".cflags" in
let cdo = base ^ ".cdo" in
......@@ -47,15 +46,18 @@ let cduce_compile_rule ?(ext=false) base =
let cf = if Sys.file_exists cflags then "%%{read:" ^ cflags ^ "}" else "" in
Format.printf
"(rule (deps %s) (target %s)\n\
\ (action (ignore-outputs (with-accepted-exit-codes 0 (run %s --compile %s %%{deps})))))\n"
\ (action (ignore-outputs (with-accepted-exit-codes 0 (run %s --compile \
%s %%{deps})))))\n"
cd cdo cduce cf
let cduce_run_rule ?(ext=false) base kind =
let cduce_run_rule ?(ext = false) base kind =
let cduce = cduce_prog ext in
let rflags = base ^ ".rflags" in
let cdo = base ^ ".cdo" in
let out = base ^ ".out" in
let rf = if Sys.file_exists rflags then "%{read-lines:" ^ rflags ^ "}" else "" in
let rf =
if Sys.file_exists rflags then "%{read-lines:" ^ rflags ^ "}" else ""
in
let write_output, close, code =
match kind with
| Good -> ("ignore-stderr (with-stdout-to", ")", "0")
......@@ -63,8 +65,8 @@ let cduce_run_rule ?(ext=false) base kind =
in
Format.printf
"(rule (deps %s) (target %s)\n\
\ (action (%s %%{target} (with-accepted-exit-codes %s (run %s --run \
%s %%{deps})))%s))\n"
\ (action (%s %%{target} (with-accepted-exit-codes %s (run %s --run %s \
%%{deps})))%s))\n"
cdo out write_output code cduce rf close
let diff_rule base =
......@@ -72,7 +74,7 @@ let diff_rule base =
let out = base ^ ".out" in
Format.printf "(rule (alias %s) (action (diff %s %s)))\n" base exp out
let gen_cduce_test ?(ext=false) kind acc f =
let gen_cduce_test ?(ext = false) kind acc f =
if check_file f ".cd" then begin
let base = Filename.remove_extension f in
Format.printf "; begin: %s\n" f;
......@@ -85,12 +87,37 @@ let gen_cduce_test ?(ext=false) kind acc f =
end
else acc
let cduce_type_rule base file =
let out = base ^ ".out" in
Format.printf
"(rule (alias %s) \n\
(action (with-outputs-to %s (with-accepted-exit-codes 0 (run \
../src/test_type.exe %s)))))"
base out file
let gen_type_test acc f =
if check_file f ".cd" then begin
let base = Filename.remove_extension f in
Format.printf "; begin: %s\n" f;
cduce_type_rule base f;
diff_rule base;
Format.printf "; end: %s\n\n" f;
Format.sprintf "(alias %s)" base :: acc
end
else acc
let gen_cduce_tests kind files =
let files = List.sort_uniq String.compare files in
let aliases = List.fold_left (gen_cduce_test kind) [] files in
Format.printf
"(alias (name runtest)
(deps
(source_tree ../../common)\n";
"(alias (name runtest)\n (deps\n (source_tree ../../common)\n";
List.iter (Format.printf " %s\n") (List.rev aliases);
Format.printf "))\n"
let gen_type_tests files =
let files = List.sort_uniq String.compare files in
let aliases = List.fold_left gen_type_test [] files in
Format.printf
"(alias (name runtest)\n (deps\n (source_tree ../../common)\n";
List.iter (Format.printf " %s\n") (List.rev aliases);
Format.printf "))\n"
;Taken from Menhir's test directory, all credits to F. Pottier and Y. Regis-Gianas
(rule
(target dune.auto.gen)
(deps (source_tree .))
(action (with-stdout-to %{target} (run ../src/gen_dune.exe --kind good %{deps})))
)
(include dune.auto)
(rule
(alias depend)
(action (diff dune.auto dune.auto.gen))
)
; begin: test1.cd
(rule (alias test1)
(action (with-outputs-to test1.out (with-accepted-exit-codes 0 (run ../src/test_type.exe test1.cd)))))(rule (alias test1) (action (diff test1.exp test1.out)))
; end: test1.cd
(alias (name runtest)
(deps
(source_tree ../../common)
(alias test1)
))
type t = Int
type s = (Int -> Int) & ( (Bool | Int) -> Float)
type u = [ Int | Int * | Bool ]
\ No newline at end of file
(executable
(name gen_dune)
(modules gen_dune)
(libraries libtest))
(executable
(name test_type)
(modules test_type)
(libraries cduce.lib cduce-types))
let () =
Libtest.parse_argv ();
Libtest.gen_type_tests !Libtest.files
let parse_type_defs env cs =
let open Cduce_lib in
let open Cduce_types in
let ast = Parse.prog cs in
let ast_types =
List.fold_left
(fun acc d ->
match d.Cduce_loc.descr with
| Ast.TypeDecl ((c, l), n) -> (c, l, n) :: acc
| _ -> acc)
[] ast
in
let env = Typer.type_defs env ast_types in
let orig_types =
List.fold_left
(fun acc (_, l, _) ->
(l, Types.descr (Typer.typ env (Cduce_loc.mknoloc (Ast.PatVar [ l ]))))
:: acc)
[] ast_types
in
(env, orig_types)
let () =
if Array.length Sys.argv != 2 then exit 1
else
try
let ic = open_in Sys.argv.(1) in
let cs = Stream.of_channel ic in
let open Cduce_types in
let open Cduce_lib in
let env, orig_types = parse_type_defs Builtin.env cs in
let new_types_txt =
let open Format in
asprintf "%a"
(pp_print_list (fun ppf (u, t) ->
fprintf ppf "type %a_new = %a;;\n" Encodings.Utf8.print u
Types.Print.print_noname t))
orig_types
in
let cs2 = Stream.of_string new_types_txt in
let _, new_types = parse_type_defs env cs2 in
if
List.for_all2
(fun (n, ta) (_, tb) ->
if not (Types.equiv ta tb) then begin
Format.eprintf
"ERROR:\noriginal type %a:\n%a\n-----\nprinted as:\n%a\n"
Encodings.Utf8.print n Types.Print.print_noname ta
Types.Print.print_noname tb;
false
end
else true)
orig_types new_types
then exit 0
else exit 0
with Cduce_core.Cduce_loc.Location (_, _, e) ->
Format.eprintf "%s" (Printexc.to_string e);
exit 1
......@@ -108,3 +108,16 @@ let contains_sample s t =
| None, `Finite _ -> false
| Some (_,Some tag),_ -> contains tag t
| Some (ns, None),_ -> is_empty (diff (any_in_ns ns) t)
let extract s =
let tr l =
List.map (fun (ns, ss) -> ns, match ss with
SymbolSet.Finite l -> `Finite l
| SymbolSet.Cofinite l -> `Cofinite l) l
in
match get s with
`Finite l -> `Finite (tr l)
| `Cofinite l -> `Cofinite (tr l)
let is_finite s = match get s with `Finite _ -> true | `Cofinite _ -> false
\ No newline at end of file
......@@ -60,3 +60,9 @@ val mk_map : (t * 'a) list -> 'a map
val get_map : V.t -> 'a map -> 'a
val map_map : ('a -> 'b) -> 'a map -> 'b map
val extract : t -> [ `Finite of (Ns.Uri.t * [`Finite of V.t list |`Cofinite of V.t list]) list
| `Cofinite of (Ns.Uri.t * [`Finite of V.t list |`Cofinite of V.t list]) list
]
val is_finite : t -> bool
......@@ -37,6 +37,9 @@ end
open V
include Custom.List (Custom.Pair (V) (V))
let extract l = l
let rec check = function
| [] -> ()
| (a, b) :: ((c, _) :: _ as tl) ->
......
......@@ -30,6 +30,7 @@ val sample : t -> V.t
val is_char : t -> V.t option
val single : t -> V.t
val extract : t -> (V.t * V.t) list
type 'a map
val mk_map: (t * 'a) list -> 'a map
......
......@@ -79,6 +79,10 @@ type interval =
type t = interval list
let is_bounded l =
List.for_all (function Left _ | Any -> false | _ -> true) l,
List.for_all (function Right _ | Any -> false | _ -> true) l
let dump ppf _ = Format.fprintf ppf "<Intervals.t>"
let rec check = function
......
......@@ -73,3 +73,5 @@ val negat : t -> t
val int32: t
val int64: t
val is_bounded : t -> bool * bool
This diff is collapsed.
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment