CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-11-08 07:51:43 +03:00
Code Issues Projects Releases Wiki Activity

Generate tests reports from 'clerk test' (#632)

Browse Source
This commit is contained in:
Louis Gesbert 2024-06-19 16:50:01 +02:00 committed by GitHub
commit 8c0d5f006f
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
17 changed files with 834 additions and 334 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

363
build_system/clerk_driver.ml
View File

@ -80,7 +80,26 @@ module Cli = struct
NOTE: if this is set, all inline tests that are $(i,not) \
$(b,catala test-scope) are skipped to avoid redundant testing.")
let runtest_report =
Arg.(
value
& opt (some string) None
& info ["report"] ~docv:"FILE"
~doc:
"If set, $(i,clerk runtest) will output a tests result summary in \
binary format to the given $(b,FILE)")
let runtest_out =
Arg.(
value
& pos 1 (some string) None
& info [] ~docv:"OUTFILE"
~doc:"Write the test outcome to file $(b,OUTFILE) instead of stdout.")
module Global : sig
val color : Catala_utils.Global.when_enum Term.t
val debug : bool Term.t
val term :
(chdir:File.t option ->
catala_exe:File.t option ->
@ -189,6 +208,34 @@ module Cli = struct
"Flags or targets to forward to Ninja directly (use $(b,-- \
ninja_flags) to separate Ninja flags from Clerk flags)")
let report_verbosity =
Arg.(
value
& vflag `Failures
[
( `Summary,
info ["summary"] ~doc:"Only display a summary of the test results"
);
( `Short,
info ["short"] ~doc:"Don't display detailed test failures diff" );
( `Failures,
info ["failures"]
~doc:"Show details of files with failed tests only" );
( `Verbose,
info ["verbose"; "v"]
~doc:"Display the full list of tests that have been run" );
])
let use_patdiff =
Arg.(
value
& flag
& info ["patdiff"]
~env:(Cmd.Env.info "CATALA_USE_PATDIFF")
~doc:
"Enable use of the 'patdiff' command for showing test failure \
details (no effect if the command is not available)")
let ninja_flags =
let env =
Cmd.Env.info
@ -385,26 +432,6 @@ module Poll = struct
let ocaml_link_flags : string list Lazy.t =
lazy (snd (Lazy.force ocaml_include_and_lib_flags))
let has_command cmd =
let check_cmd = Printf.sprintf "type %s >/dev/null 2>&1" cmd in
Sys.command check_cmd = 0
let diff_command =
lazy
(if has_command "patdiff" then
["patdiff"; "-alt-old"; "reference"; "-alt-new"; "current-output"]
else
[
"diff";
"-u";
"-b";
"--color";
"--label";
"reference";
"--label";
"current-output";
])
end
(* Adjusts paths specified from the command-line relative to the user cwd to be
@ -435,8 +462,6 @@ module Var = struct
let ocamlopt_exe = make "OCAMLOPT_EXE"
let ocaml_flags = make "OCAML_FLAGS"
let runtime_ocaml_libs = make "RUNTIME_OCAML_LIBS"
let diff = make "DIFF"
let post_test = make "POST_TEST"
(** Rule vars, Used in specific rules *)
@ -447,7 +472,6 @@ module Var = struct
let orig_src = make "orig-src"
let scope = make "scope"
let test_id = make "test-id"
let test_command = make "test-command"
let ( ! ) = Var.v
end
@ -500,13 +524,10 @@ let base_bindings catala_exe catala_flags build_dir include_dirs test_flags =
Nj.binding Var.ocamlopt_exe ["ocamlopt"];
Nj.binding Var.ocaml_flags (ocaml_flags @ includes);
Nj.binding Var.runtime_ocaml_libs (Lazy.force Poll.ocaml_link_flags);
Nj.binding Var.diff (Lazy.force Poll.diff_command);
Nj.binding Var.post_test [Var.(!diff)];
]
let[@ocamlformat "disable"] static_base_rules =
let open Var in
let color = Message.has_color stdout in
let shellout l = Format.sprintf "$$(%s)" (String.concat " " l) in
[
Nj.rule "copy"
@ -545,30 +566,11 @@ let[@ocamlformat "disable"] static_base_rules =
!input; "-o"; !output]
~description:["<catala>"; "python"; "⇒"; !output];
Nj.rule "out-test"
~command: [
!catala_exe; !test_command; "--plugin-dir="; "-o -"; !catala_flags;
!input; "2>&1";
"|"; "sed";
"'s/\"CM0|[a-zA-Z0-9|]*\"/\"CMX|XXXXXXXX|XXXXXXXX|XXXXXXXX\"/g'";
">"; !output;
"||"; "true"
]
~description:
["<catala>"; "test"; !test_id; "⇐"; !input; "(" ^ !test_command ^ ")"];
Nj.rule "inline-tests"
Nj.rule "tests"
~command:
[!clerk_exe; "runtest"; !clerk_flags; !input; ">"; !output; "2>&1";
"||"; "true"]
~description:["<catala>"; "inline-tests"; "⇐"; !input];
Nj.rule "post-test"
~command:[
!post_test; !input; ";";
"echo"; "-n"; "$$?"; ">"; !output;
]
~description:["<test>"; !test_id];
[!clerk_exe; "runtest"; !clerk_flags; !input;
"--report"; !output;]
~description:["<catala>"; "tests"; "⇐"; !input];
Nj.rule "interpret"
~command:
@ -579,37 +581,6 @@ let[@ocamlformat "disable"] static_base_rules =
Nj.rule "dir-tests"
~command:["cat"; !input; ">"; !output; ";"]
~description:["<test>"; !test_id];
Nj.rule "test-results"
~command:[
"out=" ^ !output; ";";
"success=$$("; "tr"; "-cd"; "0"; "<"; !input; "|"; "wc"; "-c"; ")"; ";";
"total=$$("; "wc"; "-c"; "<"; !input; ")"; ";";
"pass=$$("; ")"; ";";
"if"; "test"; "\"$$success\""; "-eq"; "\"$$total\""; ";"; "then";
"printf";
(if color then "\"\\n[\\033[32mPASS\\033[m] \\033[1m%s\\033[m: \
\\033[32m%3d\\033[m/\\033[32m%d\\033[m\\n\""
else "\"\\n[PASS] %s: %3d/%d\\n\"");
"$${out%@test}"; "$$success"; "$$total"; ";";
"else";
"printf";
(if color then "\"\\n[\\033[31mFAIL\\033[m] \\033[1m%s\\033[m: \
\\033[31m%3d\\033[m/\\033[32m%d\\033[m\\n\""
else "\"\\n[FAIL] %s: %3d/%d\\n\"");
"$${out%@test}"; "$$success"; "$$total"; ";";
"return"; "1"; ";";
"fi";
]
~description:["<test>"; !output];
(* Note: this last rule looks horrible, but the processing is pretty simple:
in the rules above, we output the returning code of diffing individual
tests to a [<testfile>@test] file, then the rules for directories just
concat these files. What this last rule does is then just count the number
of `0` and the total number of characters in the file, and print a readable
message. Instead of this disgusting shell code embedded in the ninja file,
this could be a specialised subcommand of clerk, e.g. `clerk
test-diagnostic <results-file@test>` *)
]
let gen_build_statements
@ -722,75 +693,29 @@ let gen_build_statements
(src /../ "output" / Filename.basename src) -.- test.Scan.id
in
let tests =
let legacy_tests =
List.fold_left
(fun acc test ->
let vars =
[Var.test_id, [test.Scan.id]; Var.test_command, test.Scan.cmd]
in
let reference = legacy_test_reference test in
let test_out =
(!Var.builddir / src /../ "output" / Filename.basename src)
-.- test.id
in
Nj.build "out-test"
~inputs:[inc srcv]
~implicit_in:interp_deps ~outputs:[test_out] ~vars
:: (* The test reference is an input because of the cases when we run
diff; it should actually be an output for the cases when we
reset but that shouldn't cause trouble. *)
Nj.build "post-test" ~inputs:[reference; test_out]
~implicit_in:["always"]
~outputs:[(!Var.builddir / reference) ^ "@post"]
~vars:[Var.test_id, [reference]]
:: acc)
[] item.legacy_tests
let out_tests_references =
List.map (fun test -> legacy_test_reference test) item.legacy_tests
in
let inline_tests =
if not item.has_inline_tests then []
else
[
Nj.build "inline-tests"
~inputs:[inc srcv]
~implicit_in:(!Var.clerk_exe :: interp_deps)
~outputs:[(!Var.builddir / srcv) ^ "@out"];
]
let out_tests_prepare =
List.map
(fun f -> Nj.build "copy" ~inputs:[f] ~outputs:[inc f])
out_tests_references
in
let tests =
let results =
Nj.build "test-results"
~outputs:[srcv ^ "@test"]
~inputs:[inc (srcv ^ "@test")]
in
let inline_test label =
Nj.build "post-test"
~outputs:[inc (srcv ^ label)]
~inputs:[srcv; inc (srcv ^ "@out")]
~implicit_in:["always"]
~vars:[Var.test_id, [srcv]]
in
match item.legacy_tests with
| [] ->
if item.has_inline_tests then [inline_test "@test"; results] else []
| legacy ->
let inline =
if item.has_inline_tests then [inline_test "@inline"] else []
in
inline
@ [
Nj.build "dir-tests"
~outputs:[inc (srcv ^ "@test")]
~inputs:
((if item.has_inline_tests then [inc (srcv ^ "@inline")] else [])
@ List.map
(fun test ->
(!Var.builddir / legacy_test_reference test) ^ "@post")
legacy)
~vars:[Var.test_id, [srcv]];
results;
]
if (not item.has_inline_tests) && item.legacy_tests = [] then []
else
[
Nj.build "tests"
~inputs:[inc srcv]
~implicit_in:
((!Var.clerk_exe :: interp_deps)
@ List.map inc out_tests_references)
~outputs:[inc srcv ^ "@test"; inc srcv ^ "@out"]
~implicit_out:
(List.map (fun o -> inc o ^ "@out") out_tests_references);
]
in
legacy_tests @ inline_tests @ tests
out_tests_prepare @ tests
in
Seq.concat
@@ List.to_seq
@ -839,9 +764,6 @@ let dir_test_rules dir subdirs items =
~outputs:[(Var.(!builddir) / dir) ^ "@test"]
~inputs
~vars:[Var.test_id, [dir]];
Nj.build "test-results"
~outputs:[dir ^ "@test"]
~inputs:[(Var.(!builddir) / dir) ^ "@test"];
]
let build_statements include_dirs dir =
@ -854,11 +776,6 @@ let build_statements include_dirs dir =
let gen_ninja_file catala_exe catala_flags build_dir include_dirs test_flags dir
=
let build_dir =
match test_flags with
| [] -> build_dir
| flags -> File.((build_dir / "test") ^ String.concat "" flags)
in
let ( @+ ) = Seq.append in
Seq.return
(Nj.Comment (Printf.sprintf "File generated by Clerk v.%s\n" version))
@ -883,7 +800,8 @@ let ninja_init
~color
~debug
~ninja_output :
extra:def Seq.t -> test_flags:string list -> (File.t -> 'a) -> 'a =
extra:def Seq.t -> test_flags:string list -> (File.t -> File.t -> 'a) -> 'a
=
let _options = Catala_utils.Global.enforce_options ~debug ~color () in
let chdir =
match chdir with None -> Lazy.force Poll.project_root | some -> some
@ -898,6 +816,11 @@ let ninja_init
in
fun ~extra ~test_flags k ->
Message.debug "building ninja rules...";
let build_dir =
match test_flags with
| [] -> build_dir
| flags -> File.((build_dir / "test") ^ String.concat "" flags)
in
with_ninja_output
@@ fun nin_file ->
File.with_formatter_of_file nin_file (fun nin_ppf ->
@ -912,7 +835,7 @@ let ninja_init
]
in
Nj.format nin_ppf ninja_contents);
k nin_file
k build_dir nin_file
let cleaned_up_env () =
let passthrough_vars =
@ -947,14 +870,14 @@ let run_ninja ~clean_up_env cmdline =
| _, Unix.WEXITED n -> n
| _, (Unix.WSIGNALED n | Unix.WSTOPPED n) -> 128 - n
in
raise (Catala_utils.Cli.Exit_with return_code)
return_code
open Cmdliner
let build_cmd =
let run ninja_init (targets : string list) (ninja_flags : string list) =
ninja_init ~extra:Seq.empty ~test_flags:[]
@@ fun nin_file ->
@@ fun _build_dir nin_file ->
let targets =
List.map
(fun f ->
@ -965,7 +888,7 @@ let build_cmd =
in
let ninja_cmd = ninja_cmdline ninja_flags nin_file targets in
Message.debug "executing '%s'..." (String.concat " " ninja_cmd);
run_ninja ~clean_up_env:false ninja_cmd
raise (Catala_utils.Cli.Exit_with (run_ninja ~clean_up_env:false ninja_cmd))
in
let doc =
"Low-level build command: can be used to forward build targets or options \
@ -975,37 +898,79 @@ let build_cmd =
Term.(
const run $ Cli.Global.term ninja_init $ Cli.targets $ Cli.ninja_flags)
let set_report_verbosity = function
| `Summary -> Clerk_report.set_display_flags ~files:`None ~tests:`None ()
| `Short ->
Clerk_report.set_display_flags ~files:`Failed ~tests:`Failed ~diffs:false ()
| `Failures ->
if Global.options.debug then Clerk_report.set_display_flags ~files:`All ()
| `Verbose -> Clerk_report.set_display_flags ~files:`All ~tests:`All ()
let test_cmd =
let run
ninja_init
(files_or_folders : string list)
(reset_test_outputs : bool)
(test_flags : string list)
verbosity
(use_patdiff : bool)
(ninja_flags : string list) =
set_report_verbosity verbosity;
Clerk_report.set_display_flags ~use_patdiff ();
ninja_init ~extra:Seq.empty ~test_flags
@@ fun build_dir nin_file ->
let targets =
let fs = if files_or_folders = [] then ["."] else files_or_folders in
List.map (fun f -> fix_path f ^ "@test") fs
List.map File.(fun f -> (build_dir / fix_path f) ^ "@test") fs
in
let extra =
List.to_seq
((if reset_test_outputs then
[
Nj.binding Var.post_test
[
"test_reset() { if ! diff -q $$1 $$2 >/dev/null; then cp -f \
$$2 $$1; fi; }";
";";
"test_reset";
];
]
else [])
@ [Nj.default targets])
in
ninja_init ~extra ~test_flags
@@ fun nin_file ->
let ninja_cmd = ninja_cmdline ninja_flags nin_file targets in
Message.debug "executing '%s'..." (String.concat " " ninja_cmd);
run_ninja ~clean_up_env:true ninja_cmd
match run_ninja ~clean_up_env:true ninja_cmd with
| 0 ->
Message.debug "gathering test results...";
let open Clerk_report in
let reports = List.flatten (List.map read_many targets) in
if reset_test_outputs then
let () =
let ppf = Message.formatter_of_out_channel stdout () in
match List.filter (fun f -> f.successful < f.total) reports with
| [] ->
Format.fprintf ppf
"[@{<green>DONE@}] All tests passed, nothing to reset@."
| need_reset ->
List.iter
(fun f ->
let files =
List.fold_left
(fun files t ->
if t.success then files
else
File.Map.add (fst t.result).Lexing.pos_fname
(String.remove_prefix
~prefix:File.(build_dir / "")
(fst t.expected).Lexing.pos_fname)
files)
File.Map.empty f.tests
in
File.Map.iter
(fun result expected ->
Format.kasprintf Sys.command "cp -f %a %a@." File.format
result File.format expected
|> ignore)
files)
need_reset;
Format.fprintf ppf
"[@{<green>DONE@}] @{<yellow;bold>%d@} test files were \
@{<yellow>RESET@}@."
(List.length need_reset)
in
raise (Catala_utils.Cli.Exit_with 0)
else if summary ~build_dir reports then
raise (Catala_utils.Cli.Exit_with 0)
else raise (Catala_utils.Cli.Exit_with 1)
| 1 -> raise (Catala_utils.Cli.Exit_with 10) (* Ninja build failed *)
| err -> raise (Catala_utils.Cli.Exit_with err)
(* Other Ninja error ? *)
in
let doc =
"Scan the given files or directories for catala tests, build their \
@ -1020,6 +985,8 @@ let test_cmd =
$ Cli.files_or_folders
$ Cli.reset_test_outputs
$ Cli.test_flags
$ Cli.report_verbosity
$ Cli.use_patdiff
$ Cli.ninja_flags)
let run_cmd =
@ -1036,10 +1003,10 @@ let run_cmd =
(List.map (fun file -> file ^ "@interpret") files_or_folders)))
in
ninja_init ~extra ~test_flags:[]
@@ fun nin_file ->
@@ fun _build_dir nin_file ->
let ninja_cmd = ninja_cmdline ninja_flags nin_file [] in
Message.debug "executing '%s'..." (String.concat " " ninja_cmd);
run_ninja ~clean_up_env:false ninja_cmd
raise (Catala_utils.Cli.Exit_with (run_ninja ~clean_up_env:false ninja_cmd))
in
let doc =
"Runs the Catala interpreter on the given files, after building their \
@ -1055,15 +1022,15 @@ let run_cmd =
$ Cli.ninja_flags)
let runtest_cmd =
let run catala_exe catala_opts include_dirs test_flags file =
let run catala_exe catala_opts include_dirs test_flags report out file =
let catala_opts =
List.fold_left
(fun opts dir -> "-I" :: dir :: opts)
catala_opts include_dirs
in
Clerk_runtest.run_inline_tests
(Option.value ~default:"catala" catala_exe)
catala_opts test_flags file;
Clerk_runtest.run_tests
~catala_exe:(Option.value ~default:"catala" catala_exe)
~catala_opts ~test_flags ~report ~out file;
0
in
let doc =
@ -1077,9 +1044,37 @@ let runtest_cmd =
$ Cli.catala_opts
$ Cli.include_dirs
$ Cli.test_flags
$ Cli.runtest_report
$ Cli.runtest_out
$ Cli.single_file)
let main_cmd = Cmd.group Cli.info [build_cmd; test_cmd; run_cmd; runtest_cmd]
let report_cmd =
let run color debug verbosity use_patdiff build_dir file =
let _options = Catala_utils.Global.enforce_options ~debug ~color () in
let build_dir = Option.value ~default:"_build" build_dir in
set_report_verbosity verbosity;
Clerk_report.set_display_flags ~use_patdiff ();
let open Clerk_report in
let tests = read_many file in
let success = summary ~build_dir tests in
exit (if success then 0 else 1)
in
let doc =
"Mainly for internal purposes. Reads a test report file and displays a \
summary of the results, returning 0 on success and 1 if any test failed."
in
Cmd.v (Cmd.info ~doc "report")
Term.(
const run
$ Cli.Global.color
$ Cli.Global.debug
$ Cli.report_verbosity
$ Cli.use_patdiff
$ Cli.build_dir
$ Cli.single_file)
let main_cmd =
Cmd.group Cli.info [build_cmd; test_cmd; run_cmd; runtest_cmd; report_cmd]
let main () =
try exit (Cmdliner.Cmd.eval' ~catch:false main_cmd) with

286
build_system/clerk_report.ml Normal file
View File

@ -0,0 +1,286 @@
(* This file is part of the Catala build system, a specification language for
tax and social benefits computation rules. Copyright (C) 2024 Inria,
contributors: Louis Gesbert <louis.gesbert@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
(** This module defines and manipulates Clerk test reports, which can be written
by `clerk runtest` and read to provide test result summaries. This only
concerns inline tests (```catala-test-inline blocks). *)
open Catala_utils
type test = {
success : bool;
command_line : string list;
expected : Lexing.position * Lexing.position;
result : Lexing.position * Lexing.position;
}
type file = { name : File.t; successful : int; total : int; tests : test list }
type disp_flags = {
mutable files : [ `All | `Failed | `None ];
mutable tests : [ `All | `FailedFile | `Failed | `None ];
mutable diffs : bool;
mutable use_patdiff : bool;
}
let disp_flags =
{ files = `Failed; tests = `FailedFile; diffs = true; use_patdiff = false }
let set_display_flags
?(files = disp_flags.files)
?(tests = disp_flags.tests)
?(diffs = disp_flags.diffs)
?(use_patdiff = disp_flags.use_patdiff)
() =
disp_flags.files <- files;
disp_flags.tests <- tests;
disp_flags.diffs <- diffs;
disp_flags.use_patdiff <- use_patdiff
let write_to f file =
File.with_out_channel f (fun oc -> Marshal.to_channel oc (file : file) [])
let read_from f = File.with_in_channel f Marshal.from_channel
let read_many f =
File.with_in_channel f
@@ fun ic ->
let rec results () =
match Marshal.from_channel ic with
| file -> file :: results ()
| exception End_of_file -> []
in
results ()
let has_command cmd =
let check_cmd = Printf.sprintf "type %s >/dev/null 2>&1" cmd in
Sys.command check_cmd = 0
let diff_command =
lazy
(if
disp_flags.use_patdiff
&& has_command "patdiff"
&& Message.has_color stdout
then ["patdiff"; "-alt-old"; "expected"; "-alt-new"; "result"]
else
[
"diff";
"-y";
"-t";
(* "--suppress-common-lines"; "--horizon-lines=3"; *)
"-W";
string_of_int (Message.terminal_columns () - 5);
(* "-b"; *)
("--color=" ^ if Message.has_color stdout then "always" else "never");
"--palette=ad=31:de=32";
"--label";
"expected";
"--label";
"result";
])
let get_diff p1 p2 =
let get_str (pstart, pend) =
assert (pstart.Lexing.pos_fname = pend.Lexing.pos_fname);
File.with_in_channel pstart.Lexing.pos_fname
@@ fun ic ->
seek_in ic pstart.Lexing.pos_cnum;
really_input_string ic (pend.Lexing.pos_cnum - pstart.Lexing.pos_cnum)
in
File.with_temp_file "clerk-diff" "a" ~contents:(get_str p1)
@@ fun f1 ->
File.with_temp_file "clerk_diff" "b" ~contents:(get_str p2)
@@ fun f2 ->
match Lazy.force diff_command with
| [] -> assert false
| cmd :: args ->
File.process_out ~check_exit:(fun _ -> ()) cmd (args @ [f1; f2])
let catala_commands_with_output_flag =
[
"makefile";
"html";
"latex";
"scopelang";
"dcalc";
"lcalc";
"ocaml";
"scalc";
"python";
"r";
"c";
]
let display ~build_dir ppf t =
let pfile f =
f
|> String.remove_prefix ~prefix:(build_dir ^ Filename.dir_sep)
|> String.remove_prefix ~prefix:(Sys.getcwd () ^ Filename.dir_sep)
in
let command_line_cleaned =
List.filter_map
(fun s -> if s = "--directory=" ^ build_dir then None else Some (pfile s))
t.command_line
|> function
| catala :: cmd :: args
when List.mem
(String.lowercase_ascii cmd)
catala_commands_with_output_flag ->
(catala :: cmd :: args) @ ["-o -"]
| cl -> cl
in
let pp_pos ppf (start, stop) =
assert (start.Lexing.pos_fname = stop.Lexing.pos_fname);
Format.fprintf ppf "@{<cyan>%s:%d-%d@}"
(pfile start.Lexing.pos_fname)
start.Lexing.pos_lnum stop.Lexing.pos_lnum
in
let print_command () =
Format.fprintf ppf "@,@[<h>$ @{<yellow>%a@}@]"
(Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_string)
command_line_cleaned
in
Format.pp_open_vbox ppf 2;
if t.success then (
Format.fprintf ppf "@{<green>■@} %a passed" pp_pos t.expected;
if Global.options.debug then print_command ())
else (
Format.fprintf ppf "@{<red>■@} %a failed" pp_pos t.expected;
print_command ();
if disp_flags.diffs then (
Format.pp_print_cut ppf ();
get_diff t.expected t.result
|> String.split_on_char '\n'
|> List.filter (( <> ) "")
|> Format.pp_print_list Format.pp_print_string ppf));
Format.pp_close_box ppf ()
let display_file ~build_dir ppf t =
let pfile f = String.remove_prefix ~prefix:(build_dir ^ Filename.dir_sep) f in
let print_tests tests =
let tests =
match disp_flags.tests with
| `All | `FailedFile -> tests
| `Failed -> List.filter (fun t -> not t.success) tests
| `None -> assert false
in
Format.pp_print_break ppf 0 3;
Format.pp_open_vbox ppf 0;
Format.pp_print_list (display ~build_dir) ppf tests;
Format.pp_close_box ppf ()
in
if t.successful = t.total then (
if disp_flags.files = `All then (
Format.fprintf ppf
"@{<green;reverse;ul> @} @{<cyan>%s@}: @{<green;bold>%d@} / %d tests \
passed"
(pfile t.name) t.successful t.total;
if disp_flags.tests = `All then print_tests t.tests;
Format.pp_print_cut ppf ()))
else
let () =
match t.successful with
| 0 -> Format.fprintf ppf "@{<red;reverse;ul> @}"
| _ -> Format.fprintf ppf "@{<yellow;reverse;ul> @}"
in
Format.fprintf ppf " @{<cyan>%s@}: " (pfile t.name);
(function
| 0 -> Format.fprintf ppf "@{<red;bold>0@}"
| n -> Format.fprintf ppf "@{<yellow;bold>%d@}" n)
t.successful;
Format.fprintf ppf " / %d tests passed" t.total;
if disp_flags.tests <> `None then print_tests t.tests;
Format.pp_print_cut ppf ()
type box = { print_line : 'a. ('a, Format.formatter, unit) format -> 'a }
[@@ocaml.unboxed]
let print_box tcolor ppf title (pcontents : box -> unit) =
let columns = Message.terminal_columns () in
let tpad = columns - String.width title - 6 in
Format.fprintf ppf "@,%t┏%t @{<bold;reverse> %s @} %t┓@}@," tcolor
(Message.pad (tpad / 2) "━")
title
(Message.pad (tpad - (tpad / 2)) "━");
Format.pp_open_tbox ppf ();
Format.fprintf ppf "%t@<1>%s@}%*s" tcolor "┃" (columns - 2) "";
Format.pp_set_tab ppf ();
Format.fprintf ppf "%t┃@}@," tcolor;
let box =
{
print_line =
(fun fmt ->
Format.kfprintf
(fun ppf ->
Format.pp_print_tab ppf ();
Format.fprintf ppf "%t┃@}@," tcolor)
ppf ("%t@<1>%s@} " ^^ fmt) tcolor "┃");
}
in
pcontents box;
box.print_line "";
Format.pp_close_tbox ppf ();
Format.fprintf ppf "%t┗%t┛@}@," tcolor (Message.pad (columns - 2) "━")
let summary ~build_dir tests =
let ppf = Message.formatter_of_out_channel stdout () in
Format.pp_open_vbox ppf 0;
let tests = List.filter (fun f -> f.total > 0) tests in
let files, success_files, success, total =
List.fold_left
(fun (files, success_files, success, total) file ->
( files + 1,
(if file.successful < file.total then success_files
else success_files + 1),
success + file.successful,
total + file.total ))
(0, 0, 0, 0) tests
in
if disp_flags.files <> `None then
List.iter (fun f -> display_file ~build_dir ppf f) tests;
let result_box =
if success < total then
print_box (fun ppf -> Format.fprintf ppf "@{<red>") ppf "TESTS FAILED"
else
print_box
(fun ppf -> Format.fprintf ppf "@{<green>")
ppf "ALL TESTS PASSED"
in
result_box (fun box ->
box.print_line "@{<ul>%-5s %10s %10s %10s@}" "" "FAILED" "PASSED" "TOTAL";
if files > 1 then
box.print_line "%-5s @{<red;bold>%a@} @{<green;bold>%a@} %10d@}" "files"
(fun ppf -> function
| 0 -> Format.fprintf ppf "@{<green>%10d@}" 0
| n -> Format.fprintf ppf "%10d" n)
(files - success_files)
(fun ppf -> function
| 0 -> Format.fprintf ppf "@{<red>%10d@}" 0
| n -> Format.fprintf ppf "%10d" n)
success_files files;
box.print_line "%-5s @{<red;bold>%a@} @{<green;bold>%a@} %10d" "tests"
(fun ppf -> function
| 0 -> Format.fprintf ppf "@{<green>%10d@}" 0
| n -> Format.fprintf ppf "%10d" n)
(total - success)
(fun ppf -> function
| 0 -> Format.fprintf ppf "@{<red>%10d@}" 0
| n -> Format.fprintf ppf "%10d" n)
success total);
Format.pp_close_box ppf ();
Format.pp_print_flush ppf ();
success = total

48
build_system/clerk_report.mli Normal file
View File

@ -0,0 +1,48 @@
(* This file is part of the Catala build system, a specification language for
tax and social benefits computation rules. Copyright (C) 2024 Inria,
contributors: Louis Gesbert <louis.gesbert@inria.fr>
Licensed under the Apache License, Version 2.0 (the "License"); you may not
use this file except in compliance with the License. You may obtain a copy of
the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
License for the specific language governing permissions and limitations under
the License. *)
(** This module defines and manipulates Clerk test reports, which can be written
by `clerk runtest` and read to provide test result summaries. This only
concerns inline tests (```catala-test-inline blocks). *)
open Catala_utils
type test = {
success : bool;
command_line : string list;
expected : Lexing.position * Lexing.position;
(** The precise offsets of the expected result in the source file *)
result : Lexing.position * Lexing.position;
(** Same for the actual result in the destination file *)
}
type file = { name : File.t; successful : int; total : int; tests : test list }
val write_to : File.t -> file -> unit
val read_from : File.t -> file
val read_many : File.t -> file list
val display : build_dir:File.t -> Format.formatter -> test -> unit
val summary : build_dir:File.t -> file list -> bool
(** Displays a summary to stdout; returns true if all tests succeeded *)
val set_display_flags :
?files:[ `All | `Failed | `None ] ->
?tests:[ `All | `FailedFile | `Failed | `None ] ->
?diffs:bool ->
?use_patdiff:bool ->
unit ->
unit

310
build_system/clerk_runtest.ml
View File

@ -16,6 +16,31 @@
open Catala_utils
type output_buf = { oc : out_channel; mutable pos : Lexing.position }
let pos0 pos_fname =
{ Lexing.pos_fname; pos_cnum = 0; pos_lnum = 1; pos_bol = 0 }
let with_output file_opt f =
match file_opt with
| Some file ->
File.with_out_channel file @@ fun oc -> f { oc; pos = pos0 file }
| None -> f { oc = stdout; pos = pos0 "<stdout>" }
let out_line output_buf str =
let len = String.length str in
let has_nl = str <> "" && str.[len - 1] = '\n' in
output_string output_buf.oc str;
if not has_nl then output_char output_buf.oc '\n';
let pos_cnum = output_buf.pos.pos_cnum + len + if has_nl then 0 else 1 in
output_buf.pos <-
{
output_buf.pos with
Lexing.pos_cnum;
pos_lnum = output_buf.pos.pos_lnum + 1;
pos_bol = pos_cnum;
}
let sanitize =
let re_endtest = Re.(compile @@ seq [bol; str "```"]) in
let re_modhash =
@ -37,11 +62,7 @@ let sanitize =
|> Re.replace_string re_endtest ~by:"\\```"
|> Re.replace_string re_modhash ~by:"\"CMX|XXXXXXXX|XXXXXXXX|XXXXXXXX\""
let run_catala_test test_flags catala_exe catala_opts file program args oc =
let cmd_in_rd, cmd_in_wr = Unix.pipe ~cloexec:true () in
let cmd_out_rd, cmd_out_wr = Unix.pipe ~cloexec:true () in
let command_oc = Unix.out_channel_of_descr cmd_in_wr in
let command_ic = Unix.in_channel_of_descr cmd_out_rd in
let catala_test_command test_flags catala_exe catala_opts args out =
let catala_exe =
(* If the exe name contains directories, make it absolute. Otherwise don't
modify it so that it can be looked up in PATH. *)
@ -49,15 +70,15 @@ let run_catala_test test_flags catala_exe catala_opts file program args oc =
Unix.realpath catala_exe
else catala_exe
in
let cmd =
match args with
| cmd0 :: flags ->
match args with
| cmd0 :: flags -> (
try
let cmd0, flags =
match String.lowercase_ascii cmd0, flags, test_flags with
| "test-scope", scope_name :: flags, test_flags ->
"interpret", (("--scope=" ^ scope_name) :: flags) @ test_flags
| "test-scope", [], _ ->
output_string oc
out_line out
"[INVALID TEST] Invalid test command syntax, the 'test-scope' \
pseudo-command takes a scope name as first argument\n";
"interpret", test_flags
@ -65,24 +86,31 @@ let run_catala_test test_flags catala_exe catala_opts file program args oc =
| _, _, _ :: _ ->
raise Exit (* Skip other tests when test-flags is specified *)
in
Array.of_list
((catala_exe :: cmd0 :: catala_opts) @ flags @ ["--name=" ^ file; "-"])
| [] -> Array.of_list ((catala_exe :: catala_opts) @ [file])
in
let env =
Unix.environment ()
|> Array.to_seq
|> Seq.filter (fun s ->
not
(String.starts_with ~prefix:"OCAMLRUNPARAM=" s
|| String.starts_with ~prefix:"CATALA_" s))
|> Seq.cons "CATALA_OUT=-"
(* |> Seq.cons "CATALA_COLOR=never" *)
|> Seq.cons "CATALA_PLUGINS="
|> Array.of_seq
in
Some (Array.of_list ((catala_exe :: cmd0 :: catala_opts) @ flags))
with Exit -> None)
| [] -> Some (Array.of_list (catala_exe :: catala_opts))
let catala_test_env () =
Unix.environment ()
|> Array.to_seq
|> Seq.filter (fun s ->
not
(String.starts_with ~prefix:"OCAMLRUNPARAM=" s
|| String.starts_with ~prefix:"CATALA_" s))
|> Seq.cons "CATALA_OUT=-"
|> Seq.cons "CATALA_COLOR=never"
|> Seq.cons "CATALA_PLUGINS="
|> Array.of_seq
let run_catala_test filename cmd program expected out_line =
let cmd_in_rd, cmd_in_wr = Unix.pipe ~cloexec:true () in
let cmd_out_rd, cmd_out_wr = Unix.pipe ~cloexec:true () in
let command_oc = Unix.out_channel_of_descr cmd_in_wr in
let command_ic = Unix.in_channel_of_descr cmd_out_rd in
let env = catala_test_env () in
let cmd = Array.append cmd [| "--name=" ^ filename; "-" |] in
let pid =
Unix.create_process_env catala_exe cmd env cmd_in_rd cmd_out_wr cmd_out_wr
Unix.create_process_env cmd.(0) cmd env cmd_in_rd cmd_out_wr cmd_out_wr
in
Unix.close cmd_in_rd;
Unix.close cmd_out_wr;
@ -91,21 +119,36 @@ let run_catala_test test_flags catala_exe catala_opts file program args oc =
let out_lines =
Seq.of_dispenser (fun () -> In_channel.input_line command_ic)
in
Seq.iter
(fun line ->
output_string oc (sanitize line);
output_char oc '\n')
out_lines;
let success, expected =
Seq.fold_left
(fun (success, expected) result_line ->
let result_line = sanitize result_line ^ "\n" in
out_line result_line;
match Seq.uncons expected with
| Some (l, expected) -> success && String.equal result_line l, expected
| None -> false, expected)
(true, expected) out_lines
in
let return_code =
match Unix.waitpid [] pid with
| _, Unix.WEXITED n -> n
| _, (Unix.WSIGNALED n | Unix.WSTOPPED n) -> 128 - n
in
if return_code <> 0 then Printf.fprintf oc "#return code %d#\n" return_code
let success, expected =
if return_code = 0 then success, expected
else
let line = Printf.sprintf "#return code %d#\n" return_code in
out_line line;
match Seq.uncons expected with
| Some (l, expected) when String.equal l line -> success, expected
| Some (_, expected) -> false, expected
| None -> false, expected
in
success && Seq.is_empty expected
(** Directly runs the test (not using ninja, this will be called by ninja rules
through the "clerk runtest" command) *)
let run_inline_tests catala_exe catala_opts test_flags filename =
let run_tests ~catala_exe ~catala_opts ~test_flags ~report ~out filename =
let module L = Surface.Lexer_common in
let lang =
match Clerk_scan.get_lang filename with
@ -115,30 +158,83 @@ let run_inline_tests catala_exe catala_opts test_flags filename =
File.format filename
in
let lines = Surface.Parser_driver.lines filename lang in
let oc = stdout in
with_output out
@@ fun out ->
let lines_until_now = Queue.create () in
let push str =
output_string oc str;
let push_line str =
out_line out str;
Queue.add str lines_until_now
in
let rec run_test lines =
let rtests : Clerk_report.test list ref = ref [] in
let rec skip_block lines =
match Seq.uncons lines with
| Some ((l, tok, _), lines) ->
push_line l;
if tok = L.LINE_BLOCK_END then lines else skip_block lines
| None -> lines
in
let rec get_block acc lines =
let return lines acc =
let endpos =
match acc with
| (_, _, (_, epos)) :: _ -> epos
| [] -> { Lexing.dummy_pos with pos_fname = filename }
in
let block = List.rev acc in
let startpos =
match block with
| (_, _, (spos, _)) :: _ -> spos
| [] -> { Lexing.dummy_pos with pos_fname = filename }
in
lines, block, (startpos, endpos)
in
match Seq.uncons lines with
| None -> return lines acc
| Some ((_, L.LINE_BLOCK_END, _), lines) -> return lines acc
| Some (li, lines) -> get_block (li :: acc) lines
in
let broken_test msg =
let opos_start = out.pos in
push_line msg;
{
Clerk_report.success = false;
command_line = [];
expected =
( { Lexing.dummy_pos with pos_fname = filename },
{ Lexing.dummy_pos with pos_fname = filename } );
result = opos_start, out.pos;
}
in
let get_test_command lines =
match Seq.uncons lines with
| None ->
output_string oc
"[INVALID TEST] Missing test command, use '$ catala <args>'\n"
| Some ((str, L.LINE_BLOCK_END), lines) ->
output_string oc
"[INVALID TEST] Missing test command, use '$ catala <args>'\n";
push str;
process lines
| Some ((str, _), lines) -> (
push str;
let t =
broken_test
"[INVALID TEST] Missing test command, use '$ catala <args>'\n"
in
rtests := t :: !rtests;
None, lines
| Some ((str, L.LINE_BLOCK_END, _), lines) ->
let t =
broken_test
"[INVALID TEST] Missing test command, use '$ catala <args>'\n"
in
rtests := t :: !rtests;
push_line str;
None, lines
| Some ((str, _, _), lines) -> (
push_line str;
match Clerk_scan.test_command_args str with
| None ->
output_string oc
"[INVALID TEST] Invalid test command syntax, must match '$ catala \
<args>'\n";
skip_block lines
let t =
broken_test
"[INVALID TEST] Invalid test command syntax, must match '$ catala \
<args>'\n"
in
let lines, _, ipos = get_block [] lines in
push_line "```\n";
rtests := { t with Clerk_report.expected = ipos } :: !rtests;
None, lines
| Some args -> (
let args = String.split_on_char ' ' args in
let program =
@ -152,29 +248,107 @@ let run_inline_tests catala_exe catala_opts test_flags filename =
in
Queue.to_seq lines_until_now |> drop_last |> drop_last
in
let opos_start = out.pos in
match
run_catala_test test_flags catala_exe catala_opts filename program
args oc
catala_test_command test_flags catala_exe catala_opts args out
with
| () -> skip_block lines
| exception Exit -> process lines))
and skip_block lines =
match Seq.uncons lines with
| None -> ()
| Some ((str, L.LINE_BLOCK_END), lines) ->
push str;
| Some cmd -> Some (cmd, program, opos_start), lines
| None -> None, skip_block lines))
in
let rec run_inline_test lines =
match get_test_command lines with
| None, lines -> process lines
| Some (cmd, program, opos_start), lines ->
let lines, expected, ipos = get_block [] lines in
let expected = Seq.map (fun (s, _, _) -> s) (List.to_seq expected) in
let success = run_catala_test filename cmd program expected push_line in
let opos_end = out.pos in
push_line "```\n";
rtests :=
{
Clerk_report.success;
command_line = Array.to_list cmd @ [filename];
result = opos_start, opos_end;
expected = ipos;
}
:: !rtests;
process lines
and run_output_test id lines =
match get_test_command lines with
| None, lines -> process lines
| Some (cmd, program, _), lines ->
let lines = skip_block lines in
let ref_file =
File.((filename /../ "output" / Filename.basename filename) -.- id)
in
if not (Sys.file_exists ref_file) then
(* Create the file if it doesn't exist *)
File.with_out_channel ref_file ignore;
let output = ref_file ^ "@out" in
let ipos_start = pos0 ref_file in
let ipos_end = ref ipos_start in
let report =
File.with_in_channel ref_file
@@ fun ic ->
let expected =
Seq.of_dispenser (fun () ->
match In_channel.input_line ic with
| None -> None
| Some s ->
let s = s ^ "\n" in
let pos_cnum = !ipos_end.pos_cnum + String.length s in
ipos_end :=
{
!ipos_end with
Lexing.pos_cnum;
pos_lnum = !ipos_end.pos_lnum + 1;
pos_bol = pos_cnum;
};
Some s)
in
with_output (Some output)
@@ fun test_out ->
let opos_start = test_out.pos in
let success =
run_catala_test filename cmd program expected (out_line test_out)
in
Seq.iter ignore expected;
{
Clerk_report.success;
command_line = Array.to_list cmd @ [filename];
result = opos_start, test_out.pos;
expected = ipos_start, !ipos_end;
}
in
rtests := report :: !rtests;
process lines
| Some ((str, _), lines) ->
Queue.add str lines_until_now;
skip_block lines
and process lines =
match Seq.uncons lines with
| Some ((str, L.LINE_INLINE_TEST), lines) ->
push str;
run_test lines
| Some ((str, _), lines) ->
push str;
| Some ((str, L.LINE_INLINE_TEST, _), lines) ->
push_line str;
run_inline_test lines
| Some ((str, L.LINE_TEST id, _), lines) ->
push_line str;
run_output_test id lines
| Some ((str, _, _), lines) ->
push_line str;
process lines
| None -> ()
in
process lines
process lines;
let tests_report =
List.fold_left
Clerk_report.(
fun tests t ->
{
tests with
total = tests.total + 1;
successful = (tests.successful + if t.success then 1 else 0);
tests = t :: tests.tests;
})
{ Clerk_report.name = filename; successful = 0; total = 0; tests = [] }
!rtests
in
match report with
| Some file -> Clerk_report.write_to file tests_report
| None -> ()

15
build_system/clerk_runtest.mli
View File

@ -22,7 +22,14 @@
open Catala_utils
val run_inline_tests : string -> string list -> string list -> File.t -> unit
(** [run_inline_tests catala_exe catala_opts test_flags file] runs the tests in
Catala [file] using the given path to the Catala executable and the provided
options. Output is printed to [stdout]. *)
val run_tests :
catala_exe:string ->
catala_opts:string list ->
test_flags:string list ->
report:File.t option ->
out:File.t option ->
File.t ->
unit
(** [run_tests ~catala_exe ~catala_opts ~test_flags ~report ~out file] runs the
tests in Catala [file] using the given path to the Catala executable and the
provided options. Output is printed to [stdout] if [out] is [None]. *)

10
build_system/clerk_scan.ml
View File

@ -60,10 +60,10 @@ let catala_file (file : File.t) (lang : Catala_utils.Global.backend_lang) : item
let rec parse lines n acc =
match Seq.uncons lines with
| None -> acc
| Some ((_, L.LINE_TEST id), lines) ->
| Some ((_, L.LINE_TEST id, _), lines) ->
let test, lines, n = parse_test id lines (n + 1) in
parse lines n { acc with legacy_tests = test :: acc.legacy_tests }
| Some ((_, line), lines) -> (
| Some ((_, line, _), lines) -> (
parse lines (n + 1)
@@
match line with
@ -88,7 +88,7 @@ let catala_file (file : File.t) (lang : Catala_utils.Global.backend_lang) : item
[Format.asprintf "'invalid test syntax at %a:%d'" File.format file n]
in
match Seq.uncons lines with
| Some ((str, L.LINE_ANY), lines) -> (
| Some ((str, L.LINE_ANY, _), lines) -> (
match test_command_args str with
| Some cmd ->
let cmd, lines, n = parse_block lines (n + 1) [cmd] in
@ -103,8 +103,8 @@ let catala_file (file : File.t) (lang : Catala_utils.Global.backend_lang) : item
| None -> { test with cmd = err n }, lines, n
and parse_block lines n acc =
match Seq.uncons lines with
| Some ((_, L.LINE_BLOCK_END), lines) -> List.rev acc, lines, n + 1
| Some ((str, _), lines) -> String.trim str :: acc, lines, n + 1
| Some ((_, L.LINE_BLOCK_END, _), lines) -> List.rev acc, lines, n + 1
| Some ((str, _, _), lines) -> String.trim str :: acc, lines, n + 1
| None -> List.rev acc, lines, n
in
parse

2
build_system/dune
View File

@ -9,7 +9,7 @@
cmdliner
re
ocolor)
(modules clerk_scan clerk_runtest clerk_driver))
(modules clerk_scan clerk_report clerk_runtest clerk_driver))
(rule
(target custom_linking.sexp)

10
compiler/catala_utils/message.ml
View File

@ -34,14 +34,14 @@ let unstyle_formatter ppf =
[Format.sprintf] etc. functions (ignoring them) *)
let () = ignore (unstyle_formatter Format.str_formatter)
let terminal_columns, set_terminal_width_function =
let get_cols = ref (fun () -> 80) in
(fun () -> !get_cols ()), fun f -> get_cols := f
(* Note: we could do the same for std_formatter, err_formatter... but we'd
rather promote the use of the formatting functions of this module and the
below std_ppf / err_ppf *)
let terminal_columns, set_terminal_width_function =
let get_cols = ref (fun () -> 80) in
(fun () -> !get_cols ()), fun f -> get_cols := f
let has_color_raw ~(tty : bool Lazy.t) =
match Global.options.color with
| Global.Never -> false
@ -90,6 +90,8 @@ let unformat (f : Format.formatter -> unit) : string =
Format.pp_print_flush ppf ();
Buffer.contents buf
let pad n s ppf = Pos.pad_fmt n s ppf
(**{2 Message types and output helpers *)
type level = Error | Warning | Debug | Log | Result

5
compiler/catala_utils/message.mli
View File

@ -73,6 +73,11 @@ val unformat : (Format.formatter -> unit) -> string
val has_color : out_channel -> bool
val set_terminal_width_function : (unit -> int) -> unit
val terminal_columns : unit -> int
val pad : int -> string -> Format.formatter -> unit
(** Prints the given character the given number of times (assuming it is of
width 1) *)
(* {1 More general color-enabled formatting helpers}*)

23
compiler/catala_utils/pos.ml
View File

@ -105,14 +105,6 @@ let indent_number (s : string) : int =
aux 0
with Invalid_argument _ -> String.length s
let string_repeat n s =
let slen = String.length s in
let buf = Bytes.create (n * slen) in
for i = 0 to n - 1 do
Bytes.blit_string s 0 buf (i * slen) slen
done;
Bytes.to_string buf
let utf8_byte_index s ui0 =
let rec aux bi ui =
if ui >= ui0 then bi
@ -121,6 +113,11 @@ let utf8_byte_index s ui0 =
in
aux 0 0
let rec pad_fmt n s ppf =
if n > 0 then (
Format.pp_print_as ppf 1 s;
pad_fmt (n - 1) s ppf)
let format_loc_text_parts (pos : t) =
let filename = get_file pos in
if filename = "" then
@ -199,14 +196,12 @@ let format_loc_text_parts (pos : t) =
line;
Format.pp_print_cut ppf ();
if line_no >= sline && line_no <= eline then
Format.fprintf ppf "@{<blue>%s │@} %s@{<bold;red>%a@}"
(string_repeat nspaces " ")
(string_repeat match_start_col " ")
(fun ppf -> Format.pp_print_as ppf match_num_cols)
(string_repeat match_num_cols "‾")
Format.fprintf ppf "@{<blue>%*s │@} %*s@{<bold;red>%t@}" nspaces ""
match_start_col ""
(pad_fmt match_num_cols "‾")
in
let pr_context ppf =
Format.fprintf ppf "@{<blue> %s│@}@," (string_repeat nspaces " ");
Format.fprintf ppf "@{<blue> %*s│@}@," nspaces "";
Format.pp_print_list print_matched_line ppf pos_lines
in
let legal_pos_lines =

5
compiler/catala_utils/pos.mli
View File

@ -69,3 +69,8 @@ val format_loc_text_parts :
val no_pos : t
(** Placeholder position *)
(**/**)
val pad_fmt : int -> string -> Format.formatter -> unit
(** Exported as [Message.pad] *)

34
compiler/driver.ml
View File

@ -1193,6 +1193,12 @@ let main () =
in
let command = catala_t plugins in
let open Cmdliner in
let[@inline] exit_with_error excode fcontent =
let bt = Printexc.get_raw_backtrace () in
Message.Content.emit (fcontent ()) Error;
if Global.options.debug then Printexc.print_raw_backtrace stderr bt;
exit excode
in
match Cmd.eval_value ~catch:false ~argv command with
| Ok _ -> exit Cmd.Exit.ok
| Error e ->
@ -1200,34 +1206,22 @@ let main () =
exit Cmd.Exit.cli_error
| exception Cli.Exit_with n -> exit n
| exception Message.CompilerError content ->
let bt = Printexc.get_raw_backtrace () in
Message.Content.emit content Error;
if Global.options.debug then Printexc.print_raw_backtrace stderr bt;
exit Cmd.Exit.some_error
exit_with_error Cmd.Exit.some_error @@ fun () -> content
| exception Message.CompilerErrors contents ->
let bt = Printexc.get_raw_backtrace () in
List.iter (fun c -> Message.Content.emit c Error) contents;
if Global.options.debug then Printexc.print_raw_backtrace stderr bt;
exit Cmd.Exit.some_error
| exception Failure msg ->
let bt = Printexc.get_raw_backtrace () in
Message.Content.emit (Message.Content.of_string msg) Error;
if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt;
exit Cmd.Exit.some_error
exit_with_error Cmd.Exit.some_error
@@ fun () -> Message.Content.of_string msg
| exception Sys_error msg ->
let bt = Printexc.get_raw_backtrace () in
Message.Content.emit
(Message.Content.of_string ("System error: " ^ msg))
Error;
if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt;
exit Cmd.Exit.internal_error
exit_with_error Cmd.Exit.internal_error
@@ fun () -> Message.Content.of_string ("System error: " ^ msg)
| exception e ->
let bt = Printexc.get_raw_backtrace () in
Message.Content.emit
(Message.Content.of_string ("Unexpected error: " ^ Printexc.to_string e))
Error;
if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt;
exit Cmd.Exit.internal_error
exit_with_error Cmd.Exit.internal_error
@@ fun () ->
Message.Content.of_string ("Unexpected error: " ^ Printexc.to_string e)
(* Export module PluginAPI, hide parent module Plugin *)
module Plugin = struct

12
compiler/lcalc/monomorphize.ml
View File

@ -146,15 +146,9 @@ let collect_monomorphized_instances (prg : typed program) :
collect_typ new_acc t
| TStruct _ | TEnum _ | TAny | TClosureEnv | TLit _ -> acc
| TOption _ | TTuple _ ->
raise
(Message.CompilerError
(Message.Content.add_position
(Message.Content.to_internal_error
(Message.Content.of_message (fun fmt ->
Format.fprintf fmt
"Some types in tuples or option have not been resolved \
by the typechecking before monomorphization.")))
(Mark.get typ)))
Message.error ~internal:true ~pos:(Mark.get typ)
"Some types in tuples or option have not been resolved by the \
typechecking before monomorphization."
in
let rec collect_expr e acc =
Expr.shallow_fold collect_expr e (collect_typ acc (Expr.ty e))

5
compiler/surface/parser_driver.ml
View File

@ -300,12 +300,13 @@ let lines (file : File.t) (language : Global.backend_lang) =
Sedlexing.set_filename lexbuf file;
let rec aux () =
match lex_line lexbuf with
| Some line -> Seq.Cons (line, aux)
| Some (str, tok) ->
Seq.Cons ((str, tok, Sedlexing.lexing_bytes_positions lexbuf), aux)
| None ->
close_in input;
Seq.Nil
in
aux
Seq.once aux
with exc ->
let bt = Printexc.get_raw_backtrace () in
close_in input;

4
compiler/surface/parser_driver.mli
View File

@ -20,7 +20,9 @@
open Catala_utils
val lines :
File.t -> Global.backend_lang -> (string * Lexer_common.line_token) Seq.t
File.t ->
Global.backend_lang ->
(string * Lexer_common.line_token * (Lexing.position * Lexing.position)) Seq.t
(** Raw file parser that doesn't interpret any includes and returns the flat law
structure as is *)

32
tests/backends/output/main.c
View File

@ -52,31 +52,25 @@ int main()
{
char *error_kind;
switch (catala_fatal_error_raised.code)
{
case catala_assertion_failed:
error_kind = "an assertion doesn't hold";
{
case catala_no_value_provided:
error_kind = "No value provided";
break;
case catala_no_value:
error_kind = "no applicable rule to define this variable in this situation";
case catala_conflict:
error_kind = "Conflict between exceptions";
break;
case catala_conflict:
error_kind = "conflict between multiple valid consequences for assigning the same variable";
case catala_crash:
error_kind = "Crash";
break;
case catala_division_by_zero:
error_kind = "a value is being used as denominator in a division and it computed to zero";
case catala_empty:
error_kind = "Empty error not caught";
break;
case catala_not_same_length:
error_kind = "traversing multiple lists of different lengths";
case catala_assertion_failure:
error_kind = "Asssertion failure";
break;
case catala_uncomparable_durations:
error_kind = "ambiguous comparison between durations in different units (e.g. months vs. days)";
break;
case catala_indivisible_durations:
error_kind = "dividing durations that are not in days";
break;
case catala_malloc_error:
case catala_malloc_error:
error_kind = "Malloc error";
}
}
printf("\033[1;31m[ERROR]\033[0m %s in file %s:%d.%d-%d.%d\n",
error_kind,
catala_fatal_error_raised.position.filename,

4
tests/typing/bad/err6.catala_en
View File

@ -24,10 +24,8 @@ scope S2:
definition a equals if r then Int content (number of sub.z) else Dec content 0.0
```
Should be "catala Typecheck", see test err3
```catala-test-inline
$ catala ocaml
$ catala typecheck
┌─[ERROR]─
│
│ Error during typechecking, incompatible types: