From b4a14bb102e0d9b4c09c642d42e81661ebace506 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Fri, 31 May 2024 16:24:34 +0200 Subject: [PATCH 1/4] Small code cleanups --- compiler/driver.ml | 34 ++++++++++++++-------------------- compiler/lcalc/monomorphize.ml | 12 +++--------- 2 files changed, 17 insertions(+), 29 deletions(-) diff --git a/compiler/driver.ml b/compiler/driver.ml index c37d79df..f9c3f15a 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -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 diff --git a/compiler/lcalc/monomorphize.ml b/compiler/lcalc/monomorphize.ml index bf2115e8..9c6eda89 100644 --- a/compiler/lcalc/monomorphize.ml +++ b/compiler/lcalc/monomorphize.ml @@ -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)) From 45b0feaf20382db3a25e764e3d79db8180937423 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Fri, 14 Jun 2024 21:05:19 +0200 Subject: [PATCH 2/4] Generate tests reports from 'clerk test' This is a proper replacement for the previous shell-based placeholder hack. Here is a summary: - `clerk runtest` (normally run by ninja) is much extended: * besides generating the test@out file, it checks individual tests for success and can write a report file containing their status, and the positions for their (expected/current) outputs (this uses `Marshal`) * it now handles out-tests directly in addition to inline-tests, for which it generates the separate output file ; they are included in the report - ninja is now tasked with building all the test reports (which shouldn't fail); for directories, individual reports are concatenated (as before). Removing intermediate report rules, and out-test rules means that the ninja file is much simplified. - then, clerk takes back control, reads the final reports and formats them in a user-friendly way. Printing the reports may imply running `diff` internally. In particular, the commands to easily reproduce each test are provided. Resetting the test results if required is also done directly by clerk, at this stage. A few switches are available to customise the output, but I am waiting for some feedback before deciding what to make available from the CLI. The `clerk report` command is available to manually explore test reports, but normally the processing is done directly at the end of `clerk test` (i.e. ninja will no longer call that command) --- build_system/clerk_driver.ml | 317 ++++++++++++----------------- build_system/clerk_report.ml | 272 +++++++++++++++++++++++++ build_system/clerk_report.mli | 50 +++++ build_system/clerk_runtest.ml | 310 +++++++++++++++++++++------- build_system/clerk_runtest.mli | 15 +- build_system/clerk_scan.ml | 10 +- build_system/dune | 2 +- compiler/catala_utils/message.ml | 8 +- compiler/catala_utils/message.mli | 1 + compiler/catala_utils/pos.ml | 16 +- compiler/catala_utils/string.ml | 8 + compiler/catala_utils/string.mli | 3 + compiler/surface/parser_driver.ml | 5 +- compiler/surface/parser_driver.mli | 4 +- tests/backends/output/main.c | 32 ++- tests/typing/bad/err6.catala_en | 4 +- 16 files changed, 754 insertions(+), 303 deletions(-) create mode 100644 build_system/clerk_report.ml create mode 100644 build_system/clerk_report.mli diff --git a/build_system/clerk_driver.ml b/build_system/clerk_driver.ml index 2237d103..b7d74cad 100644 --- a/build_system/clerk_driver.ml +++ b/build_system/clerk_driver.ml @@ -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 -> @@ -385,26 +404,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 +434,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 +444,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 +496,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 +538,11 @@ let[@ocamlformat "disable"] static_base_rules = !input; "-o"; !output] ~description:[""; "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: - [""; "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:[""; "inline-tests"; "⇐"; !input]; - - Nj.rule "post-test" - ~command:[ - !post_test; !input; ";"; - "echo"; "-n"; "$$?"; ">"; !output; - ] - ~description:[""; !test_id]; + [!clerk_exe; "runtest"; !clerk_flags; !input; + "--report"; !output;] + ~description:[""; "tests"; "⇐"; !input]; Nj.rule "interpret" ~command: @@ -579,37 +553,6 @@ let[@ocamlformat "disable"] static_base_rules = Nj.rule "dir-tests" ~command:["cat"; !input; ">"; !output; ";"] ~description:[""; !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:[""; !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 [@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 ` *) ] let gen_build_statements @@ -722,75 +665,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 +736,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 +748,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 +772,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 +788,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 +807,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 +842,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 +860,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 \ @@ -982,30 +877,60 @@ let test_cmd = (reset_test_outputs : bool) (test_flags : string list) (ninja_flags : string list) = + 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 + "[@{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 + "[@{DONE@}] @{%d@} test files were \ + @{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 \ @@ -1036,10 +961,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 +980,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 +1002,33 @@ 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 build_dir file = + let _options = Catala_utils.Global.enforce_options ~debug ~color () in + let build_dir = Option.value ~default:"_build" build_dir in + 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.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 diff --git a/build_system/clerk_report.ml b/build_system/clerk_report.ml new file mode 100644 index 00000000..2303296e --- /dev/null +++ b/build_system/clerk_report.ml @@ -0,0 +1,272 @@ +(* 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 + + 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_toggle = DAll | DFailed | DNone + +type disp_flags = { + mutable files : disp_toggle; + mutable tests : disp_toggle; + mutable diffs : bool; + mutable use_patdiff : bool; +} + +let disp_flags = + { files = DFailed; tests = DAll; 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 "@{%s:%d-%d@}" + (pfile start.Lexing.pos_fname) + start.Lexing.pos_lnum stop.Lexing.pos_lnum + in + if t.success then ( + if disp_flags.tests = DAll then + Format.fprintf ppf "@{■@} %a passed" pp_pos t.expected) + else ( + Format.pp_open_vbox ppf 2; + Format.fprintf ppf "@{■@} %a failed@," pp_pos t.expected; + Format.fprintf ppf "@[$ @{%a@}@]@," + (Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_string) + command_line_cleaned; + if disp_flags.diffs then + 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 + if t.successful = t.total then ( + if disp_flags.files = DAll then + Format.fprintf ppf + "@{ @} @{%s@}: @{%d@} / %d tests \ + passed@," + (pfile t.name) t.successful t.total) + else ( + (function + | 0 -> Format.fprintf ppf "@{ @}" + | _ -> Format.fprintf ppf "@{ @}") + t.successful; + Format.fprintf ppf " @{%s@}: " (pfile t.name); + (function + | 0 -> Format.fprintf ppf "@{0@}" + | n -> Format.fprintf ppf "@{%d@}" n) + t.successful; + Format.fprintf ppf " / %d tests passed" t.total; + Format.pp_print_break ppf 0 3; + if disp_flags.tests <> DNone then ( + Format.pp_open_vbox ppf 0; + Format.pp_print_list (display ~build_dir) ppf t.tests; + Format.pp_close_box ppf ()); + 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┏%s @{ %s @} %s┓@}@," tcolor + (String.repeat (tpad / 2) "━") + title + (String.repeat (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┗%s┛@}@," tcolor (String.repeat (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 <> DNone 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 "@{") ppf "TESTS FAILED" + else + print_box + (fun ppf -> Format.fprintf ppf "@{") + ppf "ALL TESTS PASSED" + in + result_box (fun box -> + box.print_line "@{
    %-5s %10s %10s %10s@}" "" "FAILED" "PASSED" "TOTAL"; + if files > 1 then + box.print_line "%-5s @{%a@} @{%a@} %10d@}" "files" + (fun ppf -> function + | 0 -> Format.fprintf ppf "@{%10d@}" 0 + | n -> Format.fprintf ppf "%10d" n) + (files - success_files) + (fun ppf -> function + | 0 -> Format.fprintf ppf "@{%10d@}" 0 + | n -> Format.fprintf ppf "%10d" n) + success_files files; + box.print_line "%-5s @{%a@} @{%a@} %10d" "tests" + (fun ppf -> function + | 0 -> Format.fprintf ppf "@{%10d@}" 0 + | n -> Format.fprintf ppf "%10d" n) + (total - success) + (fun ppf -> function + | 0 -> Format.fprintf ppf "@{%10d@}" 0 + | n -> Format.fprintf ppf "%10d" n) + success total); + Format.pp_close_box ppf (); + Format.pp_print_flush ppf (); + success = total diff --git a/build_system/clerk_report.mli b/build_system/clerk_report.mli new file mode 100644 index 00000000..3d4781be --- /dev/null +++ b/build_system/clerk_report.mli @@ -0,0 +1,50 @@ +(* 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 + + 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 *) + +type disp_toggle = DAll | DFailed | DNone + +val set_display_flags : + ?files:disp_toggle -> + ?tests:disp_toggle -> + ?diffs:bool -> + ?use_patdiff:bool -> + unit -> + unit diff --git a/build_system/clerk_runtest.ml b/build_system/clerk_runtest.ml index b9daad31..b5e1c91f 100644 --- a/build_system/clerk_runtest.ml +++ b/build_system/clerk_runtest.ml @@ -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 "" } + +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 '\n" - | Some ((str, L.LINE_BLOCK_END), lines) -> - output_string oc - "[INVALID TEST] Missing test command, use '$ catala '\n"; - push str; - process lines - | Some ((str, _), lines) -> ( - push str; + let t = + broken_test + "[INVALID TEST] Missing test command, use '$ catala '\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 '\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 \ - '\n"; - skip_block lines + let t = + broken_test + "[INVALID TEST] Invalid test command syntax, must match '$ catala \ + '\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 -> () diff --git a/build_system/clerk_runtest.mli b/build_system/clerk_runtest.mli index 06e4f506..cabd75c6 100644 --- a/build_system/clerk_runtest.mli +++ b/build_system/clerk_runtest.mli @@ -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]. *) diff --git a/build_system/clerk_scan.ml b/build_system/clerk_scan.ml index 217b51f6..e438f73d 100644 --- a/build_system/clerk_scan.ml +++ b/build_system/clerk_scan.ml @@ -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 diff --git a/build_system/dune b/build_system/dune index cc515c2b..0296e25c 100644 --- a/build_system/dune +++ b/build_system/dune @@ -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) diff --git a/compiler/catala_utils/message.ml b/compiler/catala_utils/message.ml index ca18575e..f14579cc 100644 --- a/compiler/catala_utils/message.ml +++ b/compiler/catala_utils/message.ml @@ -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 diff --git a/compiler/catala_utils/message.mli b/compiler/catala_utils/message.mli index 32c33480..f094ab8a 100644 --- a/compiler/catala_utils/message.mli +++ b/compiler/catala_utils/message.mli @@ -73,6 +73,7 @@ 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 (* {1 More general color-enabled formatting helpers}*) diff --git a/compiler/catala_utils/pos.ml b/compiler/catala_utils/pos.ml index ea150e0b..1b14e6b0 100644 --- a/compiler/catala_utils/pos.ml +++ b/compiler/catala_utils/pos.ml @@ -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 @@ -200,13 +192,13 @@ let format_loc_text_parts (pos : t) = Format.pp_print_cut ppf (); if line_no >= sline && line_no <= eline then Format.fprintf ppf "@{%s │@} %s@{%a@}" - (string_repeat nspaces " ") - (string_repeat match_start_col " ") + (String.repeat nspaces " ") + (String.repeat match_start_col " ") (fun ppf -> Format.pp_print_as ppf match_num_cols) - (string_repeat match_num_cols "‾") + (String.repeat match_num_cols "‾") in let pr_context ppf = - Format.fprintf ppf "@{ %s│@}@," (string_repeat nspaces " "); + Format.fprintf ppf "@{ %s│@}@," (String.repeat nspaces " "); Format.pp_print_list print_matched_line ppf pos_lines in let legal_pos_lines = diff --git a/compiler/catala_utils/string.ml b/compiler/catala_utils/string.ml index 0af8ec76..a488242a 100644 --- a/compiler/catala_utils/string.ml +++ b/compiler/catala_utils/string.ml @@ -50,6 +50,14 @@ let remove_prefix ~prefix s = sub s plen (length s - plen) else s +let repeat n s = + let slen = 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 + (* Note: this should do, but remains incorrect for combined unicode characters that display as one (e.g. `e` + postfix `'`). We should switch to Uuseg at some poing *) diff --git a/compiler/catala_utils/string.mli b/compiler/catala_utils/string.mli index b16b6723..0dce624a 100644 --- a/compiler/catala_utils/string.mli +++ b/compiler/catala_utils/string.mli @@ -56,3 +56,6 @@ val width : string -> int (** Returns the width of a given string in screen columns (assuming a monospace font). Useful for alignment. This takes unicode (except composite chars) and tabs into account, but not escape sequences. *) + +val repeat : int -> string -> string +(** Repeats the given string the given number of times *) diff --git a/compiler/surface/parser_driver.ml b/compiler/surface/parser_driver.ml index 2481239d..4c5140e3 100644 --- a/compiler/surface/parser_driver.ml +++ b/compiler/surface/parser_driver.ml @@ -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; diff --git a/compiler/surface/parser_driver.mli b/compiler/surface/parser_driver.mli index bfaea93d..82847306 100644 --- a/compiler/surface/parser_driver.mli +++ b/compiler/surface/parser_driver.mli @@ -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 *) diff --git a/tests/backends/output/main.c b/tests/backends/output/main.c index 8db237c6..b8e7b80b 100644 --- a/tests/backends/output/main.c +++ b/tests/backends/output/main.c @@ -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, diff --git a/tests/typing/bad/err6.catala_en b/tests/typing/bad/err6.catala_en index 54ad8d95..1ac76ab4 100644 --- a/tests/typing/bad/err6.catala_en +++ b/tests/typing/bad/err6.catala_en @@ -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: From 80400d838a06a0d630eac9ae96b0ad1c312d7a49 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Tue, 18 Jun 2024 15:10:29 +0200 Subject: [PATCH 3/4] Messages: improve string padding processing --- build_system/clerk_report.ml | 8 ++++---- compiler/catala_utils/message.ml | 2 ++ compiler/catala_utils/message.mli | 4 ++++ compiler/catala_utils/pos.ml | 15 +++++++++------ compiler/catala_utils/pos.mli | 5 +++++ compiler/catala_utils/string.ml | 8 -------- compiler/catala_utils/string.mli | 3 --- 7 files changed, 24 insertions(+), 21 deletions(-) diff --git a/build_system/clerk_report.ml b/build_system/clerk_report.ml index 2303296e..ef83c31c 100644 --- a/build_system/clerk_report.ml +++ b/build_system/clerk_report.ml @@ -198,10 +198,10 @@ type box = { print_line : 'a. ('a, Format.formatter, unit) format -> 'a } 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┏%s @{ %s @} %s┓@}@," tcolor - (String.repeat (tpad / 2) "━") + Format.fprintf ppf "@,%t┏%t @{ %s @} %t┓@}@," tcolor + (Message.pad (tpad / 2) "━") title - (String.repeat (tpad - (tpad / 2)) "━"); + (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 (); @@ -220,7 +220,7 @@ let print_box tcolor ppf title (pcontents : box -> unit) = pcontents box; box.print_line ""; Format.pp_close_tbox ppf (); - Format.fprintf ppf "%t┗%s┛@}@," tcolor (String.repeat (columns - 2) "━") + Format.fprintf ppf "%t┗%t┛@}@," tcolor (Message.pad (columns - 2) "━") let summary ~build_dir tests = let ppf = Message.formatter_of_out_channel stdout () in diff --git a/compiler/catala_utils/message.ml b/compiler/catala_utils/message.ml index f14579cc..055ba412 100644 --- a/compiler/catala_utils/message.ml +++ b/compiler/catala_utils/message.ml @@ -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 diff --git a/compiler/catala_utils/message.mli b/compiler/catala_utils/message.mli index f094ab8a..d8effcc2 100644 --- a/compiler/catala_utils/message.mli +++ b/compiler/catala_utils/message.mli @@ -75,6 +75,10 @@ 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}*) val formatter_of_out_channel : out_channel -> unit -> Format.formatter diff --git a/compiler/catala_utils/pos.ml b/compiler/catala_utils/pos.ml index 1b14e6b0..552ee2f5 100644 --- a/compiler/catala_utils/pos.ml +++ b/compiler/catala_utils/pos.ml @@ -113,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 @@ -191,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 "@{%s │@} %s@{%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 "@{%*s │@} %*s@{%t@}" nspaces "" + match_start_col "" + (pad_fmt match_num_cols "‾") in let pr_context ppf = - Format.fprintf ppf "@{ %s│@}@," (String.repeat nspaces " "); + Format.fprintf ppf "@{ %*s│@}@," nspaces ""; Format.pp_print_list print_matched_line ppf pos_lines in let legal_pos_lines = diff --git a/compiler/catala_utils/pos.mli b/compiler/catala_utils/pos.mli index a6019e7b..f019bad7 100644 --- a/compiler/catala_utils/pos.mli +++ b/compiler/catala_utils/pos.mli @@ -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] *) diff --git a/compiler/catala_utils/string.ml b/compiler/catala_utils/string.ml index a488242a..0af8ec76 100644 --- a/compiler/catala_utils/string.ml +++ b/compiler/catala_utils/string.ml @@ -50,14 +50,6 @@ let remove_prefix ~prefix s = sub s plen (length s - plen) else s -let repeat n s = - let slen = 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 - (* Note: this should do, but remains incorrect for combined unicode characters that display as one (e.g. `e` + postfix `'`). We should switch to Uuseg at some poing *) diff --git a/compiler/catala_utils/string.mli b/compiler/catala_utils/string.mli index 0dce624a..b16b6723 100644 --- a/compiler/catala_utils/string.mli +++ b/compiler/catala_utils/string.mli @@ -56,6 +56,3 @@ val width : string -> int (** Returns the width of a given string in screen columns (assuming a monospace font). Useful for alignment. This takes unicode (except composite chars) and tabs into account, but not escape sequences. *) - -val repeat : int -> string -> string -(** Repeats the given string the given number of times *) From 859a602c0bc9440c5b1bd33e88d4a1706c157cc0 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Wed, 19 Jun 2024 12:14:26 +0200 Subject: [PATCH 4/4] Clerk reports: add verbosity flags `--summary` `--short` `--failures` (default) `--verbose` (`--debug` also adds some detail, e.g. the commands to reproduce non-failing tests, or the files without failures in the default mode) --- build_system/clerk_driver.ml | 48 ++++++++++++++++++++++- build_system/clerk_report.ml | 72 +++++++++++++++++++++-------------- build_system/clerk_report.mli | 6 +-- 3 files changed, 92 insertions(+), 34 deletions(-) diff --git a/build_system/clerk_driver.ml b/build_system/clerk_driver.ml index b7d74cad..5e19a7e2 100644 --- a/build_system/clerk_driver.ml +++ b/build_system/clerk_driver.ml @@ -208,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 @@ -870,13 +898,25 @@ 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 = @@ -945,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 = @@ -1007,9 +1049,11 @@ let runtest_cmd = $ Cli.single_file) let report_cmd = - let run color debug build_dir file = + 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 @@ -1024,6 +1068,8 @@ let report_cmd = const run $ Cli.Global.color $ Cli.Global.debug + $ Cli.report_verbosity + $ Cli.use_patdiff $ Cli.build_dir $ Cli.single_file) diff --git a/build_system/clerk_report.ml b/build_system/clerk_report.ml index ef83c31c..a5423ed1 100644 --- a/build_system/clerk_report.ml +++ b/build_system/clerk_report.ml @@ -28,17 +28,16 @@ type test = { } type file = { name : File.t; successful : int; total : int; tests : test list } -type disp_toggle = DAll | DFailed | DNone type disp_flags = { - mutable files : disp_toggle; - mutable tests : disp_toggle; + mutable files : [ `All | `Failed | `None ]; + mutable tests : [ `All | `FailedFile | `Failed | `None ]; mutable diffs : bool; mutable use_patdiff : bool; } let disp_flags = - { files = DFailed; tests = DAll; diffs = true; use_patdiff = false } + { files = `Failed; tests = `FailedFile; diffs = true; use_patdiff = false } let set_display_flags ?(files = disp_flags.files) @@ -150,47 +149,62 @@ let display ~build_dir ppf t = (pfile start.Lexing.pos_fname) start.Lexing.pos_lnum stop.Lexing.pos_lnum in - if t.success then ( - if disp_flags.tests = DAll then - Format.fprintf ppf "@{■@} %a passed" pp_pos t.expected) - else ( - Format.pp_open_vbox ppf 2; - Format.fprintf ppf "@{■@} %a failed@," pp_pos t.expected; - Format.fprintf ppf "@[$ @{%a@}@]@," + let print_command () = + Format.fprintf ppf "@,@[$ @{%a@}@]" (Format.pp_print_list ~pp_sep:Format.pp_print_space Format.pp_print_string) - command_line_cleaned; - if disp_flags.diffs then + command_line_cleaned + in + Format.pp_open_vbox ppf 2; + if t.success then ( + Format.fprintf ppf "@{■@} %a passed" pp_pos t.expected; + if Global.options.debug then print_command ()) + else ( + Format.fprintf ppf "@{■@} %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 ()) + |> 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 = DAll then + if disp_flags.files = `All then ( Format.fprintf ppf "@{ @} @{%s@}: @{%d@} / %d tests \ - passed@," - (pfile t.name) t.successful t.total) - else ( - (function + 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 "@{ @}" - | _ -> Format.fprintf ppf "@{ @}") - t.successful; + | _ -> Format.fprintf ppf "@{ @}" + in Format.fprintf ppf " @{%s@}: " (pfile t.name); (function | 0 -> Format.fprintf ppf "@{0@}" | n -> Format.fprintf ppf "@{%d@}" n) t.successful; Format.fprintf ppf " / %d tests passed" t.total; - Format.pp_print_break ppf 0 3; - if disp_flags.tests <> DNone then ( - Format.pp_open_vbox ppf 0; - Format.pp_print_list (display ~build_dir) ppf t.tests; - Format.pp_close_box ppf ()); - Format.pp_print_cut ppf ()) + 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] @@ -236,7 +250,7 @@ let summary ~build_dir tests = total + file.total )) (0, 0, 0, 0) tests in - if disp_flags.files <> DNone then + if disp_flags.files <> `None then List.iter (fun f -> display_file ~build_dir ppf f) tests; let result_box = if success < total then diff --git a/build_system/clerk_report.mli b/build_system/clerk_report.mli index 3d4781be..b7936c16 100644 --- a/build_system/clerk_report.mli +++ b/build_system/clerk_report.mli @@ -39,11 +39,9 @@ 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 *) -type disp_toggle = DAll | DFailed | DNone - val set_display_flags : - ?files:disp_toggle -> - ?tests:disp_toggle -> + ?files:[ `All | `Failed | `None ] -> + ?tests:[ `All | `FailedFile | `Failed | `None ] -> ?diffs:bool -> ?use_patdiff:bool -> unit ->