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

Clerk reports: postprocess diff output (#638)

Browse Source
This commit is contained in:
Louis Gesbert 2024-06-21 18:20:08 +02:00 committed by GitHub
commit 1cb2763587
No known key found for this signature in database
GPG Key ID: B5690EEEBB952194
3 changed files with 101 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

116
build_system/clerk_report.ml
View File

@ -69,31 +69,87 @@ let has_command cmd =
let check_cmd = Printf.sprintf "type %s >/dev/null 2>&1" cmd in
Sys.command check_cmd = 0
let longuest_common_prefix_length s1 s2 =
let len = min (String.length s1) (String.length s2) in
let rec aux i =
if i >= len then i
else
let c1 = String.get_utf_8_uchar s1 i in
let c2 = String.get_utf_8_uchar s2 i in
if c1 = c2 then aux (i + Uchar.utf_decode_length c1) else i
in
aux 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";
])
begin
if
disp_flags.use_patdiff
&& has_command "patdiff"
&& Message.has_color stdout
then
( ["patdiff"; "-alt-old"; "expected"; "-alt-new"; "result"],
fun ppf s ->
s
|> String.split_on_char '\n'
|> List.filter (( <> ) "")
|> Format.pp_print_list Format.pp_print_string ppf )
else
let width = Message.terminal_columns () - 5 in
( [
"diff";
"-y";
"-t";
"-W";
string_of_int (Message.terminal_columns () - 5);
],
fun ppf s ->
let mid = (width - 1) / 2 in
Format.fprintf ppf "@{<blue;ul>%*sReference%*s│%*sResult%*s@}@,"
((mid - 9) / 2)
""
(mid - 9 - ((mid - 9) / 2))
""
((width - mid - 7) / 2)
""
(width - mid - 7 - ((width - mid - 7) / 2))
"";
s
|> String.trim_end
|> String.split_on_char '\n'
|> Format.pp_print_list
(fun ppf li ->
let rec find_cut col index =
if index >= String.length li then None
else if col = mid then Some index
else
let c = String.get_utf_8_uchar li index in
find_cut (col + 1) (index + Uchar.utf_decode_length c)
in
match find_cut 0 0 with
| None ->
if li = "" then Format.fprintf ppf "%*s@{<blue>│@}" mid ""
else Format.pp_print_string ppf li
| Some i -> (
let l, c, r =
( String.sub li 0 i,
li.[i],
String.sub li (i + 1) (String.length li - i - 1) )
in
match c with
| ' ' -> Format.fprintf ppf "%s@{<blue>│@}%s" l r
| '>' -> Format.fprintf ppf "%s@{<blue>│@}@{<red>%s@}" l r
| '<' -> Format.fprintf ppf "%s@{<blue>│@}@{<red>-@}" l
| '|' ->
let w = longuest_common_prefix_length (" " ^ l) r in
Format.fprintf ppf "%s@{<blue>│@}%s@{<red>%s@}" l
(String.sub r 0 w)
(String.sub r w (String.length r - w))
| _ -> Format.pp_print_string ppf li))
ppf )
end
let get_diff p1 p2 =
let print_diff ppf p1 p2 =
let get_str (pstart, pend) =
assert (pstart.Lexing.pos_fname = pend.Lexing.pos_fname);
File.with_in_channel pstart.Lexing.pos_fname
@ -106,9 +162,10 @@ let get_diff p1 p2 =
File.with_temp_file "clerk_diff" "b" ~contents:(get_str p2)
@@ fun f2 ->
match Lazy.force diff_command with
| [] -> assert false
| cmd :: args ->
| [], _ -> assert false
| cmd :: args, printer ->
File.process_out ~check_exit:(fun _ -> ()) cmd (args @ [f1; f2])
|> printer ppf
let catala_commands_with_output_flag =
["makefile"; "html"; "latex"; "ocaml"; "python"; "r"; "c"]
@ -155,10 +212,7 @@ let display ~build_dir file ppf t =
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));
print_diff ppf t.expected t.result));
Format.pp_close_box ppf ()
let display_file ~build_dir ppf t =
@ -255,7 +309,8 @@ let summary ~build_dir tests =
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"
box.print_line "%-5s @{<red;bold>%a@} @{<green;bold>%a@} @{<bold>%10d@}"
"files"
(fun ppf -> function
| 0 -> Format.fprintf ppf "@{<green>%10d@}" 0
| n -> Format.fprintf ppf "%10d" n)
@ -264,7 +319,8 @@ let summary ~build_dir tests =
| 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"
box.print_line "%-5s @{<red;bold>%a@} @{<green;bold>%a@} @{<bold>%10d@}"
"tests"
(fun ppf -> function
| 0 -> Format.fprintf ppf "@{<green>%10d@}" 0
| n -> Format.fprintf ppf "%10d" n)

12
compiler/catala_utils/string.ml
View File

@ -50,6 +50,18 @@ let remove_prefix ~prefix s =
sub s plen (length s - plen)
else s
let trim_end s =
let rec stop n =
if n < 0 then n
else
match get s n with
| ' ' | '\x0c' | '\n' | '\r' | '\t' -> stop (n - 1)
| _ -> n
in
let last = length s - 1 in
let i = stop last in
if i = last then s else sub s 0 (i + 1)
(* 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 *)

3
compiler/catala_utils/string.mli
View File

@ -50,6 +50,9 @@ val remove_prefix : prefix:string -> string -> string
- if [str] starts with [prefix], a string [s] such that [prefix ^ s = str]
- otherwise, [str] unchanged *)
val trim_end : string -> string
(** Like [Stdlib.String.trim], but only trims at the end of the string *)
val format : Format.formatter -> string -> unit
val width : string -> int