From f50aad91033ad51e5a3c29c8e2e9d18fa017e626 Mon Sep 17 00:00:00 2001 From: Corentin De Souza <9597216+fantazio@users.noreply.github.com> Date: Wed, 3 Sep 2025 15:31:44 +0200 Subject: [PATCH 1/8] [check] rewriting the test engine Although the previous test engine did report some FP/FN, some were missed/left unreported. This lead to a false sense of security, thinking all the tests were passing when actually some were failing silently. Changes in the expected results are fixes of FP/FN caused by wrongly expected results due to typos. They show the weakness of the old engine and the benefit of the new one. The new engine also uncovers mislocations on optional arguments always/never used that were hidden with the previous one. The new engine relies on the same test suite and organization. --- check/check2.ml | 584 ++++++++++++++++++ check/classic/examples/dir/fn_arg.mlstyle | 6 +- .../examples/dir/hidden_opt_use.mloptn | 2 +- check/classic/examples/let_in.mlopta | 2 +- check/classic/examples/let_in.mloptn | 2 +- check/classic/examples/let_in.mlstyle | 2 +- check/classic/examples/mod_alias.mli | 4 +- check/classic/examples/obj/constraint.mlio | 2 +- check/classic/examples/obj/fun_obj_param.mlio | 2 +- check/classic/examples/obj/inher.mli | 4 +- check/classic/examples/opt_in_opt.mli | 2 +- check/classic/examples/opt_in_opt.mlopta | 4 +- check/classic/examples/opt_in_opt.mloptn | 4 +- check/classic/examples/partial_opt.mlopta | 4 +- check/internal/examples/dir/fn_arg.mlstyle | 6 +- .../examples/dir/hidden_opt_use.mloptn | 2 +- check/internal/examples/dir/matchopt.mli | 2 +- check/internal/examples/let_in.mlopta | 2 +- check/internal/examples/let_in.mloptn | 2 +- check/internal/examples/let_in.mlstyle | 2 +- check/internal/examples/obj/constraint.mlio | 2 +- .../internal/examples/obj/fun_obj_param.mlio | 2 +- check/internal/examples/opt_in_opt.mli | 2 +- check/internal/examples/opt_in_opt.mlopta | 4 +- check/internal/examples/opt_in_opt.mloptn | 4 +- check/internal/examples/partial_opt.mlopta | 4 +- check/threshold-1/examples/dir/fn_arg.mlstyle | 6 +- .../examples/dir/hidden_opt_use.mloptn | 2 +- check/threshold-1/examples/dir/matchopt.mli | 2 +- check/threshold-1/examples/foo.mli1 | 2 +- check/threshold-1/examples/functor.mli1 | 2 +- check/threshold-1/examples/letIn.mli1 | 2 +- check/threshold-1/examples/let_in.mlopta | 2 +- check/threshold-1/examples/let_in.mloptn | 2 +- check/threshold-1/examples/let_in.mlstyle | 2 +- .../threshold-1/examples/obj/constraint.mlio | 2 +- .../examples/obj/fun_obj_param.mlio | 2 +- check/threshold-1/examples/opt_in_opt.mli | 2 +- check/threshold-1/examples/opt_in_opt.mli1 | 2 +- check/threshold-1/examples/opt_in_opt.mlopta | 4 +- check/threshold-1/examples/opt_in_opt.mloptn | 4 +- check/threshold-1/examples/partial_opt.mlopta | 4 +- check/threshold-3-0.5/examples/dir/fn_arg.mli | 1 - .../examples/dir/fn_arg.mlstyle | 6 +- .../examples/dir/hidden_opt_use.mloptn | 2 +- .../threshold-3-0.5/examples/dir/matchopt.mli | 2 +- .../threshold-3-0.5/examples/dir/partial.mli | 1 - check/threshold-3-0.5/examples/foo.mli1 | 2 +- check/threshold-3-0.5/examples/functor.mli1 | 2 +- check/threshold-3-0.5/examples/letIn.mli1 | 2 +- check/threshold-3-0.5/examples/let_in.mlopta | 2 +- check/threshold-3-0.5/examples/let_in.mloptn | 2 +- check/threshold-3-0.5/examples/let_in.mlstyle | 2 +- .../examples/obj/constraint.mlio | 2 +- .../examples/obj/fun_obj_param.mlio | 2 +- check/threshold-3-0.5/examples/opt_in_opt.mli | 2 +- .../threshold-3-0.5/examples/opt_in_opt.mli1 | 2 +- .../threshold-3-0.5/examples/opt_in_opt.mli2 | 2 +- .../examples/opt_in_opt.mlopta | 4 +- .../examples/opt_in_opt.mlopta1 | 2 +- .../examples/opt_in_opt.mloptn | 4 +- .../examples/opt_in_opt.mloptn1 | 2 +- .../examples/partial_opt.mlopta | 4 +- 63 files changed, 666 insertions(+), 84 deletions(-) create mode 100644 check/check2.ml diff --git a/check/check2.ml b/check/check2.ml new file mode 100644 index 00000000..869229ba --- /dev/null +++ b/check/check2.ml @@ -0,0 +1,584 @@ +module Path = struct + type t = string + + (* Convert windows and unix style separator (resp. '\\' and '/') to + the system's separator, remove any intermediate reference to + the current directory ("."), and reduce multiple consecutive separators + into 1. + WARNING: This assumes `path` is a relative path and will ad "./" at + the beginning of it after the above manipulation *) + let normalize path = + String.split_on_char '\\' path + |> List.concat_map (String.split_on_char '/') + |> List.filter (fun s -> s <> "" && s <> ".") + |> List.cons "." + |> String.concat Filename.dir_sep + + (* Paths read in res.out points to files in /examples/ + relatively from /check : '../examples/' + We want to relocate them as relative to the + directory whjich contains its own examples subdirectory with report files + organized similarly to /examples. : + './examples/'. Therefore, removing the first '.' does the + trick *) + let relocate path = + String.sub path 1 (String.length path - 1) + + let fold ~init ~on_file ~on_directory path = + if not (Sys.file_exists path) then init + else if Sys.is_directory path then on_directory init path + else on_file init path + +end + + +module Section : sig + (* The results are organized by section in the dead_code_analyzer's output. *) + type t = + | Constr_and_fields + | Methods + | Opt_always + | Opt_never + | Style + | Threshold of int * t + | Values + + val to_string : t -> string + + val compare : t -> t -> int + + (* The test suite files have extensions corresponding to the sections of + the expected results they contain. *) + val to_extension : t -> string + + (* The test suite files have extensions corresponding to the sections of + the expected results they contain. *) + val of_extension : string -> t option + + (* The sections are preceded by headers to help identify them. + Returns the corresponding section if the given string is header. + Returns None otherwise. *) + val of_header : string -> t option + + (* Folowing the header's title is a separator to indicate the start of the + report for that section *) + val is_start : string -> bool + + (* There is a footer at the end of each section to indicate the reporting for + that section is done *) + val is_end : string -> bool + +end = struct + + type t = + | Constr_and_fields + | Methods + | Opt_always + | Opt_never + | Style + | Threshold of int * t + | Values + + let rec to_string = function + | Constr_and_fields -> "Constr_and_fields" + | Methods -> "Methods" + | Opt_always -> "Opt_always" + | Opt_never -> "Opt_never" + | Style -> "Style" + | Values -> "Values" + | Threshold (n, t) -> + let sub_string = to_string t in + Printf.sprintf "Threshold(%d, %s)" n sub_string + + let compare = compare + + let rec to_extension = function + | Constr_and_fields -> ".mlit" + | Methods -> ".mlio" + | Opt_always -> ".mlopta" + | Opt_never -> ".mloptn" + | Style -> ".mlstyle" + | Values -> ".mli" + | Threshold (n, base) -> to_extension base ^ string_of_int n + + let rec of_extension = function + | ".mlit" -> Some Constr_and_fields + | ".mlio" -> Some Methods + | ".mlopta" -> Some Opt_always + | ".mloptn" -> Some Opt_never + | ".mlstyle" -> Some Style + | ".mli" -> Some Values + | ext -> + let try_threshold prefix = + if String.starts_with ~prefix ext then + let fmt = Scanf.format_from_string (prefix ^ "%d") "%d" in + try + let n = Scanf.sscanf ext fmt Fun.id in + of_extension prefix + |> Option.map (fun constr -> Threshold (n, constr)) + with Scanf.Scan_failure _ -> None + else None + in + let exts = [".mlit"; ".mlio"; ".mlopta"; ".mloptn"; ".mlstyle"; ".mli"] in + List.find_map try_threshold exts + + + let is_start s = + String.for_all (( = ) '=') s (* = is used for main sections *) + || String.for_all (( = ) '~') s (* ~ is used for subsections *) + + let is_end s = + s = "Nothing else to report in this section" (* main sections ending *) + || String.for_all (( = ) '-') s (* subsections ending *) + + let of_header = function + | ".> UNUSED CONSTRUCTORS/RECORD FIELDS:" -> Some Constr_and_fields + | ".> UNUSED METHODS:" -> Some Methods + | ".> OPTIONAL ARGUMENTS: ALWAYS:" -> Some Opt_always + | ".> OPTIONAL ARGUMENTS: NEVER:" -> Some Opt_never + | ".> CODING STYLE:" -> Some Style + | ".> UNUSED EXPORTED VALUES:" -> Some Values + | header -> + let get_threshold prefix constr = + if String.starts_with ~prefix header then + let fmt = Scanf.format_from_string (prefix ^ " %d time(s)") "%d" in + let n = Scanf.sscanf header fmt Fun.id in + Some (Threshold (n, constr)) + else None + in + let get_threshold_constr_and_fields () = + let prefix = ".>-> ALMOST UNUSED CONSTRUCTORS/RECORD FIELDS: Called" in + get_threshold prefix Constr_and_fields + in + let get_threshold_methods () = + let prefix = ".>-> ALMOST UNUSED METHODS: Called" in + get_threshold prefix Methods + in + let get_threshold_opt_always () = + let prefix = ".>-> OPTIONAL ARGUMENTS: ALMOST ALWAYS: Except" in + get_threshold prefix Opt_always + in + let get_threshold_opt_never () = + let prefix = ".>-> OPTIONAL ARGUMENTS: ALMOST NEVER: Except" in + get_threshold prefix Opt_never + in + let get_threshold_values () = + let prefix = ".>-> ALMOST UNUSED EXPORTED VALUES: Called" in + get_threshold prefix Values + in + let getters = [ + get_threshold_constr_and_fields; + get_threshold_methods; + get_threshold_opt_always; + get_threshold_opt_never; + get_threshold_values + ] + in + List.find_map (fun f -> f ()) getters + +end + + +module PP = struct + + let red = "\x1b[31m" + let green = "\x1b[32m" + let yellow = "\x1b[33m" + let blue = "\x1b[34m" + let white = "\x1b[37m" + let bg_red = "\x1b[41m" + let style_reset = "\x1b[0m" + + let error ~err ~ctx () = + Printf.eprintf "%s%s: %s%s%s%s\n%!" red ctx white bg_red err style_reset + +end + +module StringSet = Set.Make(String) + +module SectionMap = Map.Make(Section) + +module State = struct + + type results = { + success : int; + fp : int; + fn : int + } + + let results_to_string results = + Printf.sprintf + "{success = %d; fp = %d; fn = %d}" + results.success results.fp results.fn + + let empty_results = {success = 0; fp = 0; fn = 0} + + type expected_reports = { + current_filepath : string option; (* file containg current expected reports *) + remaining_content : string list; (* expected reports in filename not + observed yet *) + root : string; (* directory containing the expected reports files*) + files_map : StringSet.t SectionMap.t (* remaining files containing expected + reports. Once a file is consumed it + is removed from the map. Same for + sections *) + } + + let expected_reports_to_string expected_reports = + let current_filepath = + Option.value ~default:"None" expected_reports.current_filepath + in + let remaining_content = + if List.is_empty expected_reports.remaining_content + then "[]" + else "[..]" + in + let files_map = + Printf.sprintf "{ %s\n }" ( + SectionMap.bindings expected_reports.files_map + |> List.map (fun (sec, files) -> + Printf.sprintf "%s ->{%s}" + (Section.to_string sec) + (String.concat "; " @@ StringSet.to_list files) + ) + |> String.concat ";\n " + ) + (* + if SectionMap.is_empty expected_reports.files_map + then "{}" + else "{..}" + *) + in + Printf.sprintf + "{ current_filepath = %s;\n remaining_content = %s;\n root = %s;\n files_map =\n %s\n}" + current_filepath remaining_content expected_reports.root files_map + + let empty_expected_reports ={ + current_filepath = None; + remaining_content = []; + root = "."; + files_map = SectionMap.empty + } + + type t = { + line : string; (* line observed in dca's report *) + filepath : string option; + section : Section.t option; (* current section *) + expected_reports : expected_reports; + results : results + } + + let empty = { + line = ""; + filepath = None; + section = None; + expected_reports = empty_expected_reports; + results = empty_results + } + + (* Find all files in root that correspond to test files containing + expected reports. This files are identified using their extension. + See module Section above for more info. *) + let init_expected_reports root = + let rec on_directory files_map path = + Sys.readdir path + |> Array.map (fun filename -> path ^ Filename.dir_sep ^ filename) + |> Array.fold_left (fun init path -> Path.fold ~init ~on_directory ~on_file path) files_map + and on_file files_map path = + let ext = Filename.extension path in + match Section.of_extension ext with + | None -> files_map + | Some sec -> + let add_to_set = function + | None -> Some (StringSet.singleton path) + | Some set -> Some (StringSet.add path set) + in + SectionMap.update sec add_to_set files_map + in + let init = SectionMap.empty in + let files_map = Path.fold ~init ~on_directory ~on_file root in + {empty_expected_reports with files_map; root} + + let init exp_root = + let expected_reports = init_expected_reports exp_root in + {empty with expected_reports} + + let incr_fn state = + let fn = state.results.fn + 1 in + let results = {state.results with fn} in + {state with results} + + let report_fn exp_line state = + PP.error ~err:"Not detected" ~ctx:exp_line (); + incr_fn state + + let incr_fp state = + let fp = state.results.fp + 1 in + let results = {state.results with fp} in + {state with results} + + let report_fp res_line state = + PP.error ~err:"Should not be detected" ~ctx:res_line (); + incr_fp state + + let incr_success state = + let success = state.results.success + 1 in + let results = {state.results with success} in + {state with results} + + let report_success res_line state = + print_endline res_line; + incr_success state + + let update_remaining_content state remaining_content = + let remaining_content = List.filter (( <> ) "") remaining_content in + let expected_reports = {state.expected_reports with remaining_content} in + {state with expected_reports} + + let empty_current_file state = + let clear_current_exp state = + let er = state.expected_reports in + let files_map = + (* Remove file from the expected_reports *) + let ( let* ) x f = Option.bind x f in + let ( let+ ) x f = Option.map f x in + let* sec = state.section in + let* set = SectionMap.find_opt sec er.files_map in + let+ filepath = er.current_filepath in + let set = StringSet.remove filepath set in + SectionMap.add sec set er.files_map + in + let files_map = Option.value files_map ~default:er.files_map in + let expected_reports = + {empty_expected_reports with files_map; root = er.root} + in + {state with expected_reports} + in + let remaining_content = state.expected_reports.remaining_content in + List.fold_left (Fun.flip report_fn) state remaining_content + |> clear_current_exp + + let change_file ?(internal = false) filepath state = + let setup_expected_reports filepath state = + match state.section with + | None -> + let err = "Trying to open a file outside a section" in + PP.error ~err ~ctx:filepath (); + state + | Some sec -> + let ext = Section.to_extension sec in + let no_ext = + try Filename.chop_extension filepath + with Invalid_argument _ -> + let err = "Input file without extension" in + PP.error ~err ~ctx:filepath (); + filepath + in + let exp_filepath = no_ext ^ ext in + let exp_filepath = + if internal then exp_filepath + else + state.expected_reports.root ^ Filename.dir_sep ^ exp_filepath + |> Path.normalize + in + match SectionMap.find_opt sec state.expected_reports.files_map with + | Some set when StringSet.mem exp_filepath set -> + let current_filepath = Some exp_filepath in + let state = + In_channel.with_open_text exp_filepath In_channel.input_lines + |> update_remaining_content state + in + let expected_reports = + {state.expected_reports with current_filepath} + in + let filepath = Some filepath in + {state with expected_reports; filepath} + | _ -> + let err = "Expected report not found" in + PP.error ~err ~ctx:exp_filepath (); + state (* TODO: report empty section?*) + in + empty_current_file state + |> setup_expected_reports filepath + + let maybe_change_file new_filepath state = + let compare_no_ext path1 path2 = + String.compare + (Filename.remove_extension path1) + (Filename.remove_extension path2) + in + match state.filepath with + | Some filepath when compare_no_ext filepath new_filepath = 0 -> + state + | _ -> change_file new_filepath state + + let empty_current_section state = + match state.section with + | None -> state + | Some sec -> + let clear_current_section state = + let er = state.expected_reports in + let expected_reports = + let files_map = SectionMap.remove sec er.files_map in + {er with files_map} + in + let section = None in + {state with section; expected_reports} + in + let state = empty_current_file state in + let remaining_files = + SectionMap.find_opt sec state.expected_reports.files_map + |> Option.value ~default:StringSet.empty + in + StringSet.fold (change_file ~internal:true) remaining_files state + |> empty_current_file + |> clear_current_section + + let change_section section state = + let state = + match state.section with + | None -> state + | Some sec -> + let err = "Missing end of section delimiter" in + let ctx = Section.to_string sec in + PP.error ~err ~ctx (); + empty_current_section state + in + {state with section} + + + let print_results {results; _} = + let total = results.success + results.fp + results.fn in + let errors = results.fp + results.fn in + Printf.printf "Total: %s%d%s\n" PP.blue total PP.style_reset; + Printf.printf "Success: %s%d%s\n" PP.green results.success PP.style_reset; + Printf.printf "Failed: %s%d%s\n" PP.red errors PP.style_reset; + let ratio = 100. *. float_of_int results.success /. float_of_int total in + let color = + if ratio < 50. then PP.red + else if ratio < 80. then PP.yellow + else PP.green + in + Printf.printf "Ratio: %s%F%%%s\n%!" color ratio PP.style_reset + +end + +(* Format of report lines is : "file_path:line_number: report_info" + with report_info possibly containing ':'. In case the line comes from + the direct report of dca (is_res_line), the filepath will be relocated + to correspond to filepaths coming from expected reports *) +let infos_of_report_line ~is_res_line line = + let report_line_format = "filepath:line_nb:report_info" in + match String.split_on_char ':' line with + | [] | _::[] | _::_::[] -> + let err = + Printf.sprintf + "Unrecognized report line format. Expected : '%s'" + report_line_format + in + PP.error ~err ~ctx:line (); + None + | filepath::line_number::report_info -> + try + let line_nb = int_of_string line_number in + let filepath = (* relocate to match expected paths *) + if is_res_line then Path.relocate filepath + else filepath + in + let filepath = Path.normalize filepath in + let report_info = String.concat ":" report_info in + let line = (* recontruct the line with updated fields *) + if is_res_line then + String.concat ":" [filepath; line_number; report_info] + else line + in + Some (filepath, line_nb, report_info, line) + with Failure _int_of_string -> + let err = + Printf.sprintf + "Is not an int. Expected report line format is : '%s'" + report_line_format + in + PP.error ~err ~ctx:line_number (); + None + +let rec process_report_line state (filepath, line_number, report_info, res_line) = + let state = State.maybe_change_file filepath state in + match state.expected_reports.remaining_content with + | [] -> State.report_fp res_line state + | exp_line::remaining_content when exp_line = res_line -> + State.update_remaining_content state remaining_content + |> State.report_success res_line + | exp_line::remaining_content -> + match infos_of_report_line ~is_res_line:false exp_line with + | None -> + (* exp_line reported in infos_of_report_line as misformatted *) + state + | Some (exp_filepath, exp_line_number, _, exp_line) -> + let compare = + let paths_compare = String.compare exp_filepath filepath in + if paths_compare = 0 then exp_line_number - line_number + else paths_compare + in + if compare > 0 then State.report_fp res_line state + else if compare < 0 then + let state = + State.update_remaining_content state remaining_content + |> State.report_fn exp_line + in + process_report_line state (filepath, line_number, report_info, res_line) + else + (* The location is fine but report_info does not match. + The reports are not organized according to the report_info but + only the locations (including the column which is not reported. + Check if the current line exists in the remaining_content. + If so, then it is a successful report which can be removed from + the remaining content. Otherwise, it is a fp. *) + if List.mem res_line remaining_content then + List.filter (( <> ) res_line) remaining_content + |> State.update_remaining_content state + |> State.report_success res_line + else State.report_fp res_line state + +let process state res_line = + let is_report_line, state = + if res_line = "" then + false, State.empty_current_file {state with filepath = None} + else if Section.is_end res_line then + false, State.empty_current_section state + else if Section.is_start res_line then + false, state + else + match Section.of_header res_line with + | Some _ as sec -> + false, State.change_section sec state + | None -> (* res_line is a report line *) + match infos_of_report_line ~is_res_line:true res_line with + | None -> + (* res_line reported in infos_of_report_line as misformatted *) + false, state + | Some infos -> + true, process_report_line state infos + in + if not is_report_line then print_endline res_line; + state + +let get_expected_reports_root () = + if (Array.length Sys.argv) < 2 then "." + else Path.normalize Sys.argv.(1) + +let get_res_filename () = + if (Array.length Sys.argv) < 3 then "res.out" + else Path.normalize Sys.argv.(2) + +let () = + let res_file = get_res_filename () in + let input_lines = In_channel.with_open_text res_file In_channel.input_lines in + let init_state = State.init (get_expected_reports_root ()) in + let state = + List.fold_left + process + init_state + input_lines + in + State.print_results state diff --git a/check/classic/examples/dir/fn_arg.mlstyle b/check/classic/examples/dir/fn_arg.mlstyle index f65d6840..6b2344ce 100644 --- a/check/classic/examples/dir/fn_arg.mlstyle +++ b/check/classic/examples/dir/fn_arg.mlstyle @@ -1,3 +1,3 @@ -./dir/fn_arg.ml:3: val f: ... -> (... -> ?_:_ -> ...) -> ... -./dir/fn_arg.ml:9: val f: ... -> (... -> ?_:_ -> ...) -> ... -./dir/fn_arg.ml:11: val f: ... -> (... -> ?_:_ -> ...) -> ... +./examples/dir/fn_arg.ml:3: val f: ... -> (... -> ?_:_ -> ...) -> ... +./examples/dir/fn_arg.ml:9: val f: ... -> (... -> ?_:_ -> ...) -> ... +./examples/dir/fn_arg.ml:11: val f: ... -> (... -> ?_:_ -> ...) -> ... diff --git a/check/classic/examples/dir/hidden_opt_use.mloptn b/check/classic/examples/dir/hidden_opt_use.mloptn index 4086cb8d..422937ad 100644 --- a/check/classic/examples/dir/hidden_opt_use.mloptn +++ b/check/classic/examples/dir/hidden_opt_use.mloptn @@ -1 +1 @@ -./exmaples/dir/hidden_opt_use.ml:3: ?a +./examples/dir/hidden_opt_use.ml:3: ?a diff --git a/check/classic/examples/let_in.mlopta b/check/classic/examples/let_in.mlopta index 31280567..e7ca7aa5 100644 --- a/check/classic/examples/let_in.mlopta +++ b/check/classic/examples/let_in.mlopta @@ -1 +1 @@ -./examples/opam/let_in.ml:1: ?a +./examples/let_in.ml:1: ?a diff --git a/check/classic/examples/let_in.mloptn b/check/classic/examples/let_in.mloptn index 6f944cb4..e5194518 100644 --- a/check/classic/examples/let_in.mloptn +++ b/check/classic/examples/let_in.mloptn @@ -1 +1 @@ -./examples/opam/let_in.ml:1: ?c +./examples/let_in.ml:1: ?c diff --git a/check/classic/examples/let_in.mlstyle b/check/classic/examples/let_in.mlstyle index 4269833b..3f6602fb 100644 --- a/check/classic/examples/let_in.mlstyle +++ b/check/classic/examples/let_in.mlstyle @@ -1 +1 @@ -./examples/opam/let_in.ml:8: let x = ... in x (=> useless binding) +./examples/let_in.ml:8: let x = ... in x (=> useless binding) diff --git a/check/classic/examples/mod_alias.mli b/check/classic/examples/mod_alias.mli index 206a932f..a8fb1cff 100644 --- a/check/classic/examples/mod_alias.mli +++ b/check/classic/examples/mod_alias.mli @@ -1,2 +1,2 @@ -./examples/mod_alias.ml:2: M1.id -./examples/mod_alias.ml:6: M2.id +./examples/mod_alias.mli:2: M1.id +./examples/mod_alias.mli:6: M2.id diff --git a/check/classic/examples/obj/constraint.mlio b/check/classic/examples/obj/constraint.mlio index e418aaae..48c15015 100644 --- a/check/classic/examples/obj/constraint.mlio +++ b/check/classic/examples/obj/constraint.mlio @@ -1 +1 @@ -./example/obj/constraint.ml:1: p#g +./examples/obj/constraint.ml:1: p#g diff --git a/check/classic/examples/obj/fun_obj_param.mlio b/check/classic/examples/obj/fun_obj_param.mlio index cf3f7c6b..c4991056 100644 --- a/check/classic/examples/obj/fun_obj_param.mlio +++ b/check/classic/examples/obj/fun_obj_param.mlio @@ -1 +1 @@ -examples/obj/fun_obj_param.ml:1: f#n +./examples/obj/fun_obj_param.ml:1: f#n diff --git a/check/classic/examples/obj/inher.mli b/check/classic/examples/obj/inher.mli index 5b373e40..d9cf99f4 100644 --- a/check/classic/examples/obj/inher.mli +++ b/check/classic/examples/obj/inher.mli @@ -1,2 +1,2 @@ -./exmaples/obj/inher.mli:11: o -./exmaples/obj/inher.mli:13: f +./examples/obj/inher.mli:11: o +./examples/obj/inher.mli:13: f diff --git a/check/classic/examples/opt_in_opt.mli b/check/classic/examples/opt_in_opt.mli index ff6ceadc..4ef5d914 100644 --- a/check/classic/examples/opt_in_opt.mli +++ b/check/classic/examples/opt_in_opt.mli @@ -1 +1 @@ -./examples/opt-in_opt.ml:7: x +./examples/opt_in_opt.ml:7: x diff --git a/check/classic/examples/opt_in_opt.mlopta b/check/classic/examples/opt_in_opt.mlopta index 8d331f8a..dd6122f6 100644 --- a/check/classic/examples/opt_in_opt.mlopta +++ b/check/classic/examples/opt_in_opt.mlopta @@ -1,2 +1,2 @@ -./examples/opt-in_opt.ml:1: ?a -./examples/opt-in_opt.ml:5: ?a +./examples/opt_in_opt.ml:1: ?a +./examples/opt_in_opt.ml:5: ?a diff --git a/check/classic/examples/opt_in_opt.mloptn b/check/classic/examples/opt_in_opt.mloptn index 6fce4f84..b8b687ef 100644 --- a/check/classic/examples/opt_in_opt.mloptn +++ b/check/classic/examples/opt_in_opt.mloptn @@ -1,2 +1,2 @@ -./examples/opt-in_opt.ml:2: ?a -./examples/opt-in_opt.ml:2: ?b +./examples/opt_in_opt.ml:2: ?a +./examples/opt_in_opt.ml:2: ?b diff --git a/check/classic/examples/partial_opt.mlopta b/check/classic/examples/partial_opt.mlopta index c3357d7f..8f526fa7 100644 --- a/check/classic/examples/partial_opt.mlopta +++ b/check/classic/examples/partial_opt.mlopta @@ -1,2 +1,2 @@ -./examlpes/partial_opt.ml:1: ?a -./examlpes/partial_opt.ml:1: ?b +./examples/partial_opt.ml:1: ?a +./examples/partial_opt.ml:1: ?b diff --git a/check/internal/examples/dir/fn_arg.mlstyle b/check/internal/examples/dir/fn_arg.mlstyle index f65d6840..6b2344ce 100644 --- a/check/internal/examples/dir/fn_arg.mlstyle +++ b/check/internal/examples/dir/fn_arg.mlstyle @@ -1,3 +1,3 @@ -./dir/fn_arg.ml:3: val f: ... -> (... -> ?_:_ -> ...) -> ... -./dir/fn_arg.ml:9: val f: ... -> (... -> ?_:_ -> ...) -> ... -./dir/fn_arg.ml:11: val f: ... -> (... -> ?_:_ -> ...) -> ... +./examples/dir/fn_arg.ml:3: val f: ... -> (... -> ?_:_ -> ...) -> ... +./examples/dir/fn_arg.ml:9: val f: ... -> (... -> ?_:_ -> ...) -> ... +./examples/dir/fn_arg.ml:11: val f: ... -> (... -> ?_:_ -> ...) -> ... diff --git a/check/internal/examples/dir/hidden_opt_use.mloptn b/check/internal/examples/dir/hidden_opt_use.mloptn index 4086cb8d..422937ad 100644 --- a/check/internal/examples/dir/hidden_opt_use.mloptn +++ b/check/internal/examples/dir/hidden_opt_use.mloptn @@ -1 +1 @@ -./exmaples/dir/hidden_opt_use.ml:3: ?a +./examples/dir/hidden_opt_use.ml:3: ?a diff --git a/check/internal/examples/dir/matchopt.mli b/check/internal/examples/dir/matchopt.mli index 22098c19..ded9b57b 100644 --- a/check/internal/examples/dir/matchopt.mli +++ b/check/internal/examples/dir/matchopt.mli @@ -1 +1 @@ -./examples/matchopt.ml:5: w +./examples/dir/matchopt.ml:5: w diff --git a/check/internal/examples/let_in.mlopta b/check/internal/examples/let_in.mlopta index 31280567..e7ca7aa5 100644 --- a/check/internal/examples/let_in.mlopta +++ b/check/internal/examples/let_in.mlopta @@ -1 +1 @@ -./examples/opam/let_in.ml:1: ?a +./examples/let_in.ml:1: ?a diff --git a/check/internal/examples/let_in.mloptn b/check/internal/examples/let_in.mloptn index 6f944cb4..e5194518 100644 --- a/check/internal/examples/let_in.mloptn +++ b/check/internal/examples/let_in.mloptn @@ -1 +1 @@ -./examples/opam/let_in.ml:1: ?c +./examples/let_in.ml:1: ?c diff --git a/check/internal/examples/let_in.mlstyle b/check/internal/examples/let_in.mlstyle index 4269833b..3f6602fb 100644 --- a/check/internal/examples/let_in.mlstyle +++ b/check/internal/examples/let_in.mlstyle @@ -1 +1 @@ -./examples/opam/let_in.ml:8: let x = ... in x (=> useless binding) +./examples/let_in.ml:8: let x = ... in x (=> useless binding) diff --git a/check/internal/examples/obj/constraint.mlio b/check/internal/examples/obj/constraint.mlio index e418aaae..48c15015 100644 --- a/check/internal/examples/obj/constraint.mlio +++ b/check/internal/examples/obj/constraint.mlio @@ -1 +1 @@ -./example/obj/constraint.ml:1: p#g +./examples/obj/constraint.ml:1: p#g diff --git a/check/internal/examples/obj/fun_obj_param.mlio b/check/internal/examples/obj/fun_obj_param.mlio index cf3f7c6b..c4991056 100644 --- a/check/internal/examples/obj/fun_obj_param.mlio +++ b/check/internal/examples/obj/fun_obj_param.mlio @@ -1 +1 @@ -examples/obj/fun_obj_param.ml:1: f#n +./examples/obj/fun_obj_param.ml:1: f#n diff --git a/check/internal/examples/opt_in_opt.mli b/check/internal/examples/opt_in_opt.mli index ff6ceadc..4ef5d914 100644 --- a/check/internal/examples/opt_in_opt.mli +++ b/check/internal/examples/opt_in_opt.mli @@ -1 +1 @@ -./examples/opt-in_opt.ml:7: x +./examples/opt_in_opt.ml:7: x diff --git a/check/internal/examples/opt_in_opt.mlopta b/check/internal/examples/opt_in_opt.mlopta index 8d331f8a..dd6122f6 100644 --- a/check/internal/examples/opt_in_opt.mlopta +++ b/check/internal/examples/opt_in_opt.mlopta @@ -1,2 +1,2 @@ -./examples/opt-in_opt.ml:1: ?a -./examples/opt-in_opt.ml:5: ?a +./examples/opt_in_opt.ml:1: ?a +./examples/opt_in_opt.ml:5: ?a diff --git a/check/internal/examples/opt_in_opt.mloptn b/check/internal/examples/opt_in_opt.mloptn index 6fce4f84..b8b687ef 100644 --- a/check/internal/examples/opt_in_opt.mloptn +++ b/check/internal/examples/opt_in_opt.mloptn @@ -1,2 +1,2 @@ -./examples/opt-in_opt.ml:2: ?a -./examples/opt-in_opt.ml:2: ?b +./examples/opt_in_opt.ml:2: ?a +./examples/opt_in_opt.ml:2: ?b diff --git a/check/internal/examples/partial_opt.mlopta b/check/internal/examples/partial_opt.mlopta index c3357d7f..8f526fa7 100644 --- a/check/internal/examples/partial_opt.mlopta +++ b/check/internal/examples/partial_opt.mlopta @@ -1,2 +1,2 @@ -./examlpes/partial_opt.ml:1: ?a -./examlpes/partial_opt.ml:1: ?b +./examples/partial_opt.ml:1: ?a +./examples/partial_opt.ml:1: ?b diff --git a/check/threshold-1/examples/dir/fn_arg.mlstyle b/check/threshold-1/examples/dir/fn_arg.mlstyle index f65d6840..6b2344ce 100644 --- a/check/threshold-1/examples/dir/fn_arg.mlstyle +++ b/check/threshold-1/examples/dir/fn_arg.mlstyle @@ -1,3 +1,3 @@ -./dir/fn_arg.ml:3: val f: ... -> (... -> ?_:_ -> ...) -> ... -./dir/fn_arg.ml:9: val f: ... -> (... -> ?_:_ -> ...) -> ... -./dir/fn_arg.ml:11: val f: ... -> (... -> ?_:_ -> ...) -> ... +./examples/dir/fn_arg.ml:3: val f: ... -> (... -> ?_:_ -> ...) -> ... +./examples/dir/fn_arg.ml:9: val f: ... -> (... -> ?_:_ -> ...) -> ... +./examples/dir/fn_arg.ml:11: val f: ... -> (... -> ?_:_ -> ...) -> ... diff --git a/check/threshold-1/examples/dir/hidden_opt_use.mloptn b/check/threshold-1/examples/dir/hidden_opt_use.mloptn index 4086cb8d..422937ad 100644 --- a/check/threshold-1/examples/dir/hidden_opt_use.mloptn +++ b/check/threshold-1/examples/dir/hidden_opt_use.mloptn @@ -1 +1 @@ -./exmaples/dir/hidden_opt_use.ml:3: ?a +./examples/dir/hidden_opt_use.ml:3: ?a diff --git a/check/threshold-1/examples/dir/matchopt.mli b/check/threshold-1/examples/dir/matchopt.mli index 22098c19..ded9b57b 100644 --- a/check/threshold-1/examples/dir/matchopt.mli +++ b/check/threshold-1/examples/dir/matchopt.mli @@ -1 +1 @@ -./examples/matchopt.ml:5: w +./examples/dir/matchopt.ml:5: w diff --git a/check/threshold-1/examples/foo.mli1 b/check/threshold-1/examples/foo.mli1 index 401d5d0a..23413f7a 100644 --- a/check/threshold-1/examples/foo.mli1 +++ b/check/threshold-1/examples/foo.mli1 @@ -1 +1 @@ -./exmaples/foo.mli:1: x +./examples/foo.mli:1: x diff --git a/check/threshold-1/examples/functor.mli1 b/check/threshold-1/examples/functor.mli1 index 42b9d729..c0289f79 100644 --- a/check/threshold-1/examples/functor.mli1 +++ b/check/threshold-1/examples/functor.mli1 @@ -1 +1 @@ -./exmaples/functor.mli:2: M.f +./examples/functor.mli:2: M.f diff --git a/check/threshold-1/examples/letIn.mli1 b/check/threshold-1/examples/letIn.mli1 index 35dd2d38..7a9583dd 100644 --- a/check/threshold-1/examples/letIn.mli1 +++ b/check/threshold-1/examples/letIn.mli1 @@ -1 +1 @@ -./exmaples/letIn.mli:1: f +./examples/letIn.mli:1: f diff --git a/check/threshold-1/examples/let_in.mlopta b/check/threshold-1/examples/let_in.mlopta index 31280567..e7ca7aa5 100644 --- a/check/threshold-1/examples/let_in.mlopta +++ b/check/threshold-1/examples/let_in.mlopta @@ -1 +1 @@ -./examples/opam/let_in.ml:1: ?a +./examples/let_in.ml:1: ?a diff --git a/check/threshold-1/examples/let_in.mloptn b/check/threshold-1/examples/let_in.mloptn index 6f944cb4..e5194518 100644 --- a/check/threshold-1/examples/let_in.mloptn +++ b/check/threshold-1/examples/let_in.mloptn @@ -1 +1 @@ -./examples/opam/let_in.ml:1: ?c +./examples/let_in.ml:1: ?c diff --git a/check/threshold-1/examples/let_in.mlstyle b/check/threshold-1/examples/let_in.mlstyle index 4269833b..3f6602fb 100644 --- a/check/threshold-1/examples/let_in.mlstyle +++ b/check/threshold-1/examples/let_in.mlstyle @@ -1 +1 @@ -./examples/opam/let_in.ml:8: let x = ... in x (=> useless binding) +./examples/let_in.ml:8: let x = ... in x (=> useless binding) diff --git a/check/threshold-1/examples/obj/constraint.mlio b/check/threshold-1/examples/obj/constraint.mlio index e418aaae..48c15015 100644 --- a/check/threshold-1/examples/obj/constraint.mlio +++ b/check/threshold-1/examples/obj/constraint.mlio @@ -1 +1 @@ -./example/obj/constraint.ml:1: p#g +./examples/obj/constraint.ml:1: p#g diff --git a/check/threshold-1/examples/obj/fun_obj_param.mlio b/check/threshold-1/examples/obj/fun_obj_param.mlio index cf3f7c6b..c4991056 100644 --- a/check/threshold-1/examples/obj/fun_obj_param.mlio +++ b/check/threshold-1/examples/obj/fun_obj_param.mlio @@ -1 +1 @@ -examples/obj/fun_obj_param.ml:1: f#n +./examples/obj/fun_obj_param.ml:1: f#n diff --git a/check/threshold-1/examples/opt_in_opt.mli b/check/threshold-1/examples/opt_in_opt.mli index ff6ceadc..4ef5d914 100644 --- a/check/threshold-1/examples/opt_in_opt.mli +++ b/check/threshold-1/examples/opt_in_opt.mli @@ -1 +1 @@ -./examples/opt-in_opt.ml:7: x +./examples/opt_in_opt.ml:7: x diff --git a/check/threshold-1/examples/opt_in_opt.mli1 b/check/threshold-1/examples/opt_in_opt.mli1 index 91c6f90c..4589f4d5 100644 --- a/check/threshold-1/examples/opt_in_opt.mli1 +++ b/check/threshold-1/examples/opt_in_opt.mli1 @@ -1 +1 @@ -./examples/opt-in_opt.ml:5: baz +./examples/opt_in_opt.ml:5: baz diff --git a/check/threshold-1/examples/opt_in_opt.mlopta b/check/threshold-1/examples/opt_in_opt.mlopta index 8d331f8a..dd6122f6 100644 --- a/check/threshold-1/examples/opt_in_opt.mlopta +++ b/check/threshold-1/examples/opt_in_opt.mlopta @@ -1,2 +1,2 @@ -./examples/opt-in_opt.ml:1: ?a -./examples/opt-in_opt.ml:5: ?a +./examples/opt_in_opt.ml:1: ?a +./examples/opt_in_opt.ml:5: ?a diff --git a/check/threshold-1/examples/opt_in_opt.mloptn b/check/threshold-1/examples/opt_in_opt.mloptn index 6fce4f84..b8b687ef 100644 --- a/check/threshold-1/examples/opt_in_opt.mloptn +++ b/check/threshold-1/examples/opt_in_opt.mloptn @@ -1,2 +1,2 @@ -./examples/opt-in_opt.ml:2: ?a -./examples/opt-in_opt.ml:2: ?b +./examples/opt_in_opt.ml:2: ?a +./examples/opt_in_opt.ml:2: ?b diff --git a/check/threshold-1/examples/partial_opt.mlopta b/check/threshold-1/examples/partial_opt.mlopta index c3357d7f..8f526fa7 100644 --- a/check/threshold-1/examples/partial_opt.mlopta +++ b/check/threshold-1/examples/partial_opt.mlopta @@ -1,2 +1,2 @@ -./examlpes/partial_opt.ml:1: ?a -./examlpes/partial_opt.ml:1: ?b +./examples/partial_opt.ml:1: ?a +./examples/partial_opt.ml:1: ?b diff --git a/check/threshold-3-0.5/examples/dir/fn_arg.mli b/check/threshold-3-0.5/examples/dir/fn_arg.mli index 8b137891..e69de29b 100644 --- a/check/threshold-3-0.5/examples/dir/fn_arg.mli +++ b/check/threshold-3-0.5/examples/dir/fn_arg.mli @@ -1 +0,0 @@ - diff --git a/check/threshold-3-0.5/examples/dir/fn_arg.mlstyle b/check/threshold-3-0.5/examples/dir/fn_arg.mlstyle index f65d6840..6b2344ce 100644 --- a/check/threshold-3-0.5/examples/dir/fn_arg.mlstyle +++ b/check/threshold-3-0.5/examples/dir/fn_arg.mlstyle @@ -1,3 +1,3 @@ -./dir/fn_arg.ml:3: val f: ... -> (... -> ?_:_ -> ...) -> ... -./dir/fn_arg.ml:9: val f: ... -> (... -> ?_:_ -> ...) -> ... -./dir/fn_arg.ml:11: val f: ... -> (... -> ?_:_ -> ...) -> ... +./examples/dir/fn_arg.ml:3: val f: ... -> (... -> ?_:_ -> ...) -> ... +./examples/dir/fn_arg.ml:9: val f: ... -> (... -> ?_:_ -> ...) -> ... +./examples/dir/fn_arg.ml:11: val f: ... -> (... -> ?_:_ -> ...) -> ... diff --git a/check/threshold-3-0.5/examples/dir/hidden_opt_use.mloptn b/check/threshold-3-0.5/examples/dir/hidden_opt_use.mloptn index 4086cb8d..422937ad 100644 --- a/check/threshold-3-0.5/examples/dir/hidden_opt_use.mloptn +++ b/check/threshold-3-0.5/examples/dir/hidden_opt_use.mloptn @@ -1 +1 @@ -./exmaples/dir/hidden_opt_use.ml:3: ?a +./examples/dir/hidden_opt_use.ml:3: ?a diff --git a/check/threshold-3-0.5/examples/dir/matchopt.mli b/check/threshold-3-0.5/examples/dir/matchopt.mli index 22098c19..ded9b57b 100644 --- a/check/threshold-3-0.5/examples/dir/matchopt.mli +++ b/check/threshold-3-0.5/examples/dir/matchopt.mli @@ -1 +1 @@ -./examples/matchopt.ml:5: w +./examples/dir/matchopt.ml:5: w diff --git a/check/threshold-3-0.5/examples/dir/partial.mli b/check/threshold-3-0.5/examples/dir/partial.mli index 8b137891..e69de29b 100644 --- a/check/threshold-3-0.5/examples/dir/partial.mli +++ b/check/threshold-3-0.5/examples/dir/partial.mli @@ -1 +0,0 @@ - diff --git a/check/threshold-3-0.5/examples/foo.mli1 b/check/threshold-3-0.5/examples/foo.mli1 index 401d5d0a..23413f7a 100644 --- a/check/threshold-3-0.5/examples/foo.mli1 +++ b/check/threshold-3-0.5/examples/foo.mli1 @@ -1 +1 @@ -./exmaples/foo.mli:1: x +./examples/foo.mli:1: x diff --git a/check/threshold-3-0.5/examples/functor.mli1 b/check/threshold-3-0.5/examples/functor.mli1 index 42b9d729..c0289f79 100644 --- a/check/threshold-3-0.5/examples/functor.mli1 +++ b/check/threshold-3-0.5/examples/functor.mli1 @@ -1 +1 @@ -./exmaples/functor.mli:2: M.f +./examples/functor.mli:2: M.f diff --git a/check/threshold-3-0.5/examples/letIn.mli1 b/check/threshold-3-0.5/examples/letIn.mli1 index 35dd2d38..7a9583dd 100644 --- a/check/threshold-3-0.5/examples/letIn.mli1 +++ b/check/threshold-3-0.5/examples/letIn.mli1 @@ -1 +1 @@ -./exmaples/letIn.mli:1: f +./examples/letIn.mli:1: f diff --git a/check/threshold-3-0.5/examples/let_in.mlopta b/check/threshold-3-0.5/examples/let_in.mlopta index 31280567..e7ca7aa5 100644 --- a/check/threshold-3-0.5/examples/let_in.mlopta +++ b/check/threshold-3-0.5/examples/let_in.mlopta @@ -1 +1 @@ -./examples/opam/let_in.ml:1: ?a +./examples/let_in.ml:1: ?a diff --git a/check/threshold-3-0.5/examples/let_in.mloptn b/check/threshold-3-0.5/examples/let_in.mloptn index 6f944cb4..e5194518 100644 --- a/check/threshold-3-0.5/examples/let_in.mloptn +++ b/check/threshold-3-0.5/examples/let_in.mloptn @@ -1 +1 @@ -./examples/opam/let_in.ml:1: ?c +./examples/let_in.ml:1: ?c diff --git a/check/threshold-3-0.5/examples/let_in.mlstyle b/check/threshold-3-0.5/examples/let_in.mlstyle index 4269833b..3f6602fb 100644 --- a/check/threshold-3-0.5/examples/let_in.mlstyle +++ b/check/threshold-3-0.5/examples/let_in.mlstyle @@ -1 +1 @@ -./examples/opam/let_in.ml:8: let x = ... in x (=> useless binding) +./examples/let_in.ml:8: let x = ... in x (=> useless binding) diff --git a/check/threshold-3-0.5/examples/obj/constraint.mlio b/check/threshold-3-0.5/examples/obj/constraint.mlio index e418aaae..48c15015 100644 --- a/check/threshold-3-0.5/examples/obj/constraint.mlio +++ b/check/threshold-3-0.5/examples/obj/constraint.mlio @@ -1 +1 @@ -./example/obj/constraint.ml:1: p#g +./examples/obj/constraint.ml:1: p#g diff --git a/check/threshold-3-0.5/examples/obj/fun_obj_param.mlio b/check/threshold-3-0.5/examples/obj/fun_obj_param.mlio index cf3f7c6b..c4991056 100644 --- a/check/threshold-3-0.5/examples/obj/fun_obj_param.mlio +++ b/check/threshold-3-0.5/examples/obj/fun_obj_param.mlio @@ -1 +1 @@ -examples/obj/fun_obj_param.ml:1: f#n +./examples/obj/fun_obj_param.ml:1: f#n diff --git a/check/threshold-3-0.5/examples/opt_in_opt.mli b/check/threshold-3-0.5/examples/opt_in_opt.mli index ff6ceadc..4ef5d914 100644 --- a/check/threshold-3-0.5/examples/opt_in_opt.mli +++ b/check/threshold-3-0.5/examples/opt_in_opt.mli @@ -1 +1 @@ -./examples/opt-in_opt.ml:7: x +./examples/opt_in_opt.ml:7: x diff --git a/check/threshold-3-0.5/examples/opt_in_opt.mli1 b/check/threshold-3-0.5/examples/opt_in_opt.mli1 index 91c6f90c..4589f4d5 100644 --- a/check/threshold-3-0.5/examples/opt_in_opt.mli1 +++ b/check/threshold-3-0.5/examples/opt_in_opt.mli1 @@ -1 +1 @@ -./examples/opt-in_opt.ml:5: baz +./examples/opt_in_opt.ml:5: baz diff --git a/check/threshold-3-0.5/examples/opt_in_opt.mli2 b/check/threshold-3-0.5/examples/opt_in_opt.mli2 index d7c8c76f..6da10fec 100644 --- a/check/threshold-3-0.5/examples/opt_in_opt.mli2 +++ b/check/threshold-3-0.5/examples/opt_in_opt.mli2 @@ -1 +1 @@ -./examples/opt-in_opt.ml:1: foo +./examples/opt_in_opt.ml:1: foo diff --git a/check/threshold-3-0.5/examples/opt_in_opt.mlopta b/check/threshold-3-0.5/examples/opt_in_opt.mlopta index 8d331f8a..dd6122f6 100644 --- a/check/threshold-3-0.5/examples/opt_in_opt.mlopta +++ b/check/threshold-3-0.5/examples/opt_in_opt.mlopta @@ -1,2 +1,2 @@ -./examples/opt-in_opt.ml:1: ?a -./examples/opt-in_opt.ml:5: ?a +./examples/opt_in_opt.ml:1: ?a +./examples/opt_in_opt.ml:5: ?a diff --git a/check/threshold-3-0.5/examples/opt_in_opt.mlopta1 b/check/threshold-3-0.5/examples/opt_in_opt.mlopta1 index 7f215f24..31dac25a 100644 --- a/check/threshold-3-0.5/examples/opt_in_opt.mlopta1 +++ b/check/threshold-3-0.5/examples/opt_in_opt.mlopta1 @@ -1 +1 @@ -./examples/opt-in_opt.ml:1: ?b (1/2 calls) +./examples/opt_in_opt.ml:1: ?b (1/2 calls) diff --git a/check/threshold-3-0.5/examples/opt_in_opt.mloptn b/check/threshold-3-0.5/examples/opt_in_opt.mloptn index 6fce4f84..b8b687ef 100644 --- a/check/threshold-3-0.5/examples/opt_in_opt.mloptn +++ b/check/threshold-3-0.5/examples/opt_in_opt.mloptn @@ -1,2 +1,2 @@ -./examples/opt-in_opt.ml:2: ?a -./examples/opt-in_opt.ml:2: ?b +./examples/opt_in_opt.ml:2: ?a +./examples/opt_in_opt.ml:2: ?b diff --git a/check/threshold-3-0.5/examples/opt_in_opt.mloptn1 b/check/threshold-3-0.5/examples/opt_in_opt.mloptn1 index 7f215f24..31dac25a 100644 --- a/check/threshold-3-0.5/examples/opt_in_opt.mloptn1 +++ b/check/threshold-3-0.5/examples/opt_in_opt.mloptn1 @@ -1 +1 @@ -./examples/opt-in_opt.ml:1: ?b (1/2 calls) +./examples/opt_in_opt.ml:1: ?b (1/2 calls) diff --git a/check/threshold-3-0.5/examples/partial_opt.mlopta b/check/threshold-3-0.5/examples/partial_opt.mlopta index c3357d7f..8f526fa7 100644 --- a/check/threshold-3-0.5/examples/partial_opt.mlopta +++ b/check/threshold-3-0.5/examples/partial_opt.mlopta @@ -1,2 +1,2 @@ -./examlpes/partial_opt.ml:1: ?a -./examlpes/partial_opt.ml:1: ?b +./examples/partial_opt.ml:1: ?a +./examples/partial_opt.ml:1: ?b From f69aa815ebd36f45304f86a1d2be4d404d3ff7e0 Mon Sep 17 00:00:00 2001 From: Corentin De Souza <9597216+fantazio@users.noreply.github.com> Date: Sat, 6 Sep 2025 18:08:10 +0200 Subject: [PATCH 2/8] [check] fix expected opta/optn reports If a module has an .mli file, then the reported locations for its opt args depends on whether the associated exported value is used externally. If there is no external use, then the reported locations are the implementation's. Otherwise, they are the interface's. --- check/classic/examples/dir/anonFn.mlopta | 2 +- check/classic/examples/dir/anonFn.mloptn | 4 ++-- check/classic/examples/letIn.mlopta | 2 +- check/classic/examples/letIn.mloptn | 2 +- check/classic/examples/record.mlopta | 2 +- check/classic/examples/record.mloptn | 2 +- check/internal/examples/dir/anonFn.mlopta | 2 +- check/internal/examples/dir/anonFn.mloptn | 4 ++-- check/internal/examples/letIn.mlopta | 2 +- check/internal/examples/letIn.mloptn | 2 +- check/internal/examples/record.mlopta | 2 +- check/internal/examples/record.mloptn | 2 +- check/threshold-1/examples/dir/anonFn.mlopta | 2 +- check/threshold-1/examples/dir/anonFn.mloptn | 4 ++-- check/threshold-1/examples/letIn.mlopta | 2 +- check/threshold-1/examples/letIn.mloptn | 2 +- check/threshold-1/examples/record.mlopta | 2 +- check/threshold-1/examples/record.mloptn | 2 +- check/threshold-3-0.5/examples/dir/anonFn.mlopta | 2 +- check/threshold-3-0.5/examples/dir/anonFn.mloptn | 4 ++-- check/threshold-3-0.5/examples/letIn.mlopta | 2 +- check/threshold-3-0.5/examples/letIn.mloptn | 2 +- check/threshold-3-0.5/examples/record.mlopta | 2 +- check/threshold-3-0.5/examples/record.mloptn | 2 +- 24 files changed, 28 insertions(+), 28 deletions(-) diff --git a/check/classic/examples/dir/anonFn.mlopta b/check/classic/examples/dir/anonFn.mlopta index d778a024..00591c68 100644 --- a/check/classic/examples/dir/anonFn.mlopta +++ b/check/classic/examples/dir/anonFn.mlopta @@ -1 +1 @@ -./examples/dir/anonFn.ml:2: ?a +./examples/dir/anonFn.mli:2: ?a diff --git a/check/classic/examples/dir/anonFn.mloptn b/check/classic/examples/dir/anonFn.mloptn index 62b6b1bc..a1fdc6d9 100644 --- a/check/classic/examples/dir/anonFn.mloptn +++ b/check/classic/examples/dir/anonFn.mloptn @@ -1,2 +1,2 @@ -./examples/dir/anonFn.ml:1: ?b -./examples/dir/anonFn.ml:2: ?b +./examples/dir/anonFn.mli:1: ?b +./examples/dir/anonFn.mli:2: ?b diff --git a/check/classic/examples/letIn.mlopta b/check/classic/examples/letIn.mlopta index ab91bb42..db7b37cd 100644 --- a/check/classic/examples/letIn.mlopta +++ b/check/classic/examples/letIn.mlopta @@ -1 +1 @@ -./examples/letIn.ml:1: ?a +./examples/letIn.mli:1: ?a diff --git a/check/classic/examples/letIn.mloptn b/check/classic/examples/letIn.mloptn index b786cf40..67b96674 100644 --- a/check/classic/examples/letIn.mloptn +++ b/check/classic/examples/letIn.mloptn @@ -1 +1 @@ -./examples/letIn.ml:1: ?b +./examples/letIn.mli:1: ?b diff --git a/check/classic/examples/record.mlopta b/check/classic/examples/record.mlopta index 12a332c8..b1ca412a 100644 --- a/check/classic/examples/record.mlopta +++ b/check/classic/examples/record.mlopta @@ -1 +1 @@ -./examples/record.mli:12: ?a +./examples/record.ml:12: ?a diff --git a/check/classic/examples/record.mloptn b/check/classic/examples/record.mloptn index cba6e498..0c0e7d10 100644 --- a/check/classic/examples/record.mloptn +++ b/check/classic/examples/record.mloptn @@ -1 +1 @@ -./examples/record.mli:12: ?b +./examples/record.ml:12: ?b diff --git a/check/internal/examples/dir/anonFn.mlopta b/check/internal/examples/dir/anonFn.mlopta index d778a024..00591c68 100644 --- a/check/internal/examples/dir/anonFn.mlopta +++ b/check/internal/examples/dir/anonFn.mlopta @@ -1 +1 @@ -./examples/dir/anonFn.ml:2: ?a +./examples/dir/anonFn.mli:2: ?a diff --git a/check/internal/examples/dir/anonFn.mloptn b/check/internal/examples/dir/anonFn.mloptn index 62b6b1bc..a1fdc6d9 100644 --- a/check/internal/examples/dir/anonFn.mloptn +++ b/check/internal/examples/dir/anonFn.mloptn @@ -1,2 +1,2 @@ -./examples/dir/anonFn.ml:1: ?b -./examples/dir/anonFn.ml:2: ?b +./examples/dir/anonFn.mli:1: ?b +./examples/dir/anonFn.mli:2: ?b diff --git a/check/internal/examples/letIn.mlopta b/check/internal/examples/letIn.mlopta index ab91bb42..db7b37cd 100644 --- a/check/internal/examples/letIn.mlopta +++ b/check/internal/examples/letIn.mlopta @@ -1 +1 @@ -./examples/letIn.ml:1: ?a +./examples/letIn.mli:1: ?a diff --git a/check/internal/examples/letIn.mloptn b/check/internal/examples/letIn.mloptn index b786cf40..67b96674 100644 --- a/check/internal/examples/letIn.mloptn +++ b/check/internal/examples/letIn.mloptn @@ -1 +1 @@ -./examples/letIn.ml:1: ?b +./examples/letIn.mli:1: ?b diff --git a/check/internal/examples/record.mlopta b/check/internal/examples/record.mlopta index 12a332c8..b1ca412a 100644 --- a/check/internal/examples/record.mlopta +++ b/check/internal/examples/record.mlopta @@ -1 +1 @@ -./examples/record.mli:12: ?a +./examples/record.ml:12: ?a diff --git a/check/internal/examples/record.mloptn b/check/internal/examples/record.mloptn index cba6e498..0c0e7d10 100644 --- a/check/internal/examples/record.mloptn +++ b/check/internal/examples/record.mloptn @@ -1 +1 @@ -./examples/record.mli:12: ?b +./examples/record.ml:12: ?b diff --git a/check/threshold-1/examples/dir/anonFn.mlopta b/check/threshold-1/examples/dir/anonFn.mlopta index d778a024..00591c68 100644 --- a/check/threshold-1/examples/dir/anonFn.mlopta +++ b/check/threshold-1/examples/dir/anonFn.mlopta @@ -1 +1 @@ -./examples/dir/anonFn.ml:2: ?a +./examples/dir/anonFn.mli:2: ?a diff --git a/check/threshold-1/examples/dir/anonFn.mloptn b/check/threshold-1/examples/dir/anonFn.mloptn index 62b6b1bc..a1fdc6d9 100644 --- a/check/threshold-1/examples/dir/anonFn.mloptn +++ b/check/threshold-1/examples/dir/anonFn.mloptn @@ -1,2 +1,2 @@ -./examples/dir/anonFn.ml:1: ?b -./examples/dir/anonFn.ml:2: ?b +./examples/dir/anonFn.mli:1: ?b +./examples/dir/anonFn.mli:2: ?b diff --git a/check/threshold-1/examples/letIn.mlopta b/check/threshold-1/examples/letIn.mlopta index ab91bb42..db7b37cd 100644 --- a/check/threshold-1/examples/letIn.mlopta +++ b/check/threshold-1/examples/letIn.mlopta @@ -1 +1 @@ -./examples/letIn.ml:1: ?a +./examples/letIn.mli:1: ?a diff --git a/check/threshold-1/examples/letIn.mloptn b/check/threshold-1/examples/letIn.mloptn index b786cf40..67b96674 100644 --- a/check/threshold-1/examples/letIn.mloptn +++ b/check/threshold-1/examples/letIn.mloptn @@ -1 +1 @@ -./examples/letIn.ml:1: ?b +./examples/letIn.mli:1: ?b diff --git a/check/threshold-1/examples/record.mlopta b/check/threshold-1/examples/record.mlopta index 12a332c8..b1ca412a 100644 --- a/check/threshold-1/examples/record.mlopta +++ b/check/threshold-1/examples/record.mlopta @@ -1 +1 @@ -./examples/record.mli:12: ?a +./examples/record.ml:12: ?a diff --git a/check/threshold-1/examples/record.mloptn b/check/threshold-1/examples/record.mloptn index cba6e498..0c0e7d10 100644 --- a/check/threshold-1/examples/record.mloptn +++ b/check/threshold-1/examples/record.mloptn @@ -1 +1 @@ -./examples/record.mli:12: ?b +./examples/record.ml:12: ?b diff --git a/check/threshold-3-0.5/examples/dir/anonFn.mlopta b/check/threshold-3-0.5/examples/dir/anonFn.mlopta index d778a024..00591c68 100644 --- a/check/threshold-3-0.5/examples/dir/anonFn.mlopta +++ b/check/threshold-3-0.5/examples/dir/anonFn.mlopta @@ -1 +1 @@ -./examples/dir/anonFn.ml:2: ?a +./examples/dir/anonFn.mli:2: ?a diff --git a/check/threshold-3-0.5/examples/dir/anonFn.mloptn b/check/threshold-3-0.5/examples/dir/anonFn.mloptn index 62b6b1bc..a1fdc6d9 100644 --- a/check/threshold-3-0.5/examples/dir/anonFn.mloptn +++ b/check/threshold-3-0.5/examples/dir/anonFn.mloptn @@ -1,2 +1,2 @@ -./examples/dir/anonFn.ml:1: ?b -./examples/dir/anonFn.ml:2: ?b +./examples/dir/anonFn.mli:1: ?b +./examples/dir/anonFn.mli:2: ?b diff --git a/check/threshold-3-0.5/examples/letIn.mlopta b/check/threshold-3-0.5/examples/letIn.mlopta index ab91bb42..db7b37cd 100644 --- a/check/threshold-3-0.5/examples/letIn.mlopta +++ b/check/threshold-3-0.5/examples/letIn.mlopta @@ -1 +1 @@ -./examples/letIn.ml:1: ?a +./examples/letIn.mli:1: ?a diff --git a/check/threshold-3-0.5/examples/letIn.mloptn b/check/threshold-3-0.5/examples/letIn.mloptn index b786cf40..67b96674 100644 --- a/check/threshold-3-0.5/examples/letIn.mloptn +++ b/check/threshold-3-0.5/examples/letIn.mloptn @@ -1 +1 @@ -./examples/letIn.ml:1: ?b +./examples/letIn.mli:1: ?b diff --git a/check/threshold-3-0.5/examples/record.mlopta b/check/threshold-3-0.5/examples/record.mlopta index 12a332c8..b1ca412a 100644 --- a/check/threshold-3-0.5/examples/record.mlopta +++ b/check/threshold-3-0.5/examples/record.mlopta @@ -1 +1 @@ -./examples/record.mli:12: ?a +./examples/record.ml:12: ?a diff --git a/check/threshold-3-0.5/examples/record.mloptn b/check/threshold-3-0.5/examples/record.mloptn index cba6e498..0c0e7d10 100644 --- a/check/threshold-3-0.5/examples/record.mloptn +++ b/check/threshold-3-0.5/examples/record.mloptn @@ -1 +1 @@ -./examples/record.mli:12: ?b +./examples/record.ml:12: ?b From d6b3860a744f2bb9a8d5bf4638722633b92682a9 Mon Sep 17 00:00:00 2001 From: Corentin De Souza <9597216+fantazio@users.noreply.github.com> Date: Wed, 3 Sep 2025 18:54:21 +0200 Subject: [PATCH 3/8] [check] fix aggregate --- check/aggregate.ml | 90 +++++++++++++++++++++++++++------------------- 1 file changed, 54 insertions(+), 36 deletions(-) diff --git a/check/aggregate.ml b/check/aggregate.ml index df262aa1..52444add 100644 --- a/check/aggregate.ml +++ b/check/aggregate.ml @@ -1,42 +1,56 @@ let total = ref 0 let err = ref 0 -let res = Hashtbl.create 256 +let unified_res = Hashtbl.create 256 +let sec_res = Hashtbl.create 256 let print_title title = - print_string "\x1b[1;37m"; - print_endline title; - print_endline (String.make (String.length title) '~'); - print_endline "\x1b[0m" + print_string "\x1b[1;37m"; + print_endline title; + print_endline (String.make (String.length title) '~'); + print_endline "\x1b[0m" -let rec update file form value = - try - let line = input_line file in - if String.length line > 2 && not (Hashtbl.mem res line) then - if line.[0] = '.' && line.[1] <> '>' && not (Hashtbl.mem res line) then - Hashtbl.add res line true - else if line.[0] = '\x1b' && not (Hashtbl.mem res line) then - Hashtbl.add res line false; +let update ~total_fmt ~failed_fmt line = + let unique_line = + let rec make_unique_to_sec n = + let new_line = line ^ string_of_int n in + if Hashtbl.mem sec_res new_line then make_unique_to_sec (n + 1) + else new_line + in + let res = make_unique_to_sec 0 in + Hashtbl.add sec_res res (); + res + in + if not (Hashtbl.mem unified_res unique_line) then ( + if String.starts_with ~prefix:"./examples" line then + Hashtbl.add unified_res unique_line true + else if + String.ends_with ~suffix:"Should not be detected\x1b[0m" line + || String.ends_with ~suffix:"Not detected\x1b[0m" line + then + Hashtbl.add unified_res unique_line false + ); + let update_count fmt value = try - let tot = Scanf.sscanf line form (fun _ x _ -> x) in + let fmt = Scanf.format_from_string fmt "%d%d%s" in + let tot = Scanf.sscanf line fmt (fun _ x _ -> x) in print_endline line; value := tot + !value - with - | _ -> update file form value - with End_of_file -> close_in file + with _ -> () + in + update_count total_fmt total; + update_count failed_fmt err -let rec process n = - if n = 0 then () - else begin - let file = open_in Sys.argv.(n) in - print_title (Filename.chop_extension Sys.argv.(n)); +let process filepath = + let input_lines = + In_channel.with_open_text filepath In_channel.input_lines + in + print_title (Filename.remove_extension filepath); - update file "Total: \x1b[0;%dm%d%s" total; - update file "Failed: \x1b[0;%dm%d%s" err; - begin try print_endline (input_line file); print_endline "\n\n" - with _ -> () end; - close_in file; - process (n - 1) - end + let total_fmt = "Total: \x1b[%dm%d%s" in + let failed_fmt = "Failed: \x1b[%dm%d%s" in + List.iter (update ~total_fmt ~failed_fmt) input_lines; + Hashtbl.clear sec_res; + print_endline "\n" let print_res title total err = print_title title; @@ -46,12 +60,16 @@ let print_res title total err = print_int err; let ratio = ( -. ) 100. @@ ( *. ) 100. @@ (float_of_int total |> ( /. ) @@ float_of_int err) in print_string @@ "\x1b[0m\nRatio: \x1b[0;3" - ^ (if ratio < 50. then "1m" else if ratio < 80. then "3m" else "2m"); + ^ (if ratio < 50. then "1m" else if ratio < 80. then "3m" else "2m"); print_float ratio; print_endline "%\x1b[0m" let () = - process (Array.length Sys.argv - 1); + let filepaths = + let argv_len = Array.length Sys.argv in + Array.sub Sys.argv 1 (argv_len - 1) + in + Array.iter process filepaths; print_endline "...............................................\n\n\x1b[1;37m"; print_endline "~~~~~~~~~~~~~~~~~~~~~~"; @@ -60,11 +78,11 @@ let () = print_res "| |" !total !err; let total, err = Hashtbl.fold - (fun _ valid (total, err) -> - if valid then (total + 1, err) - else (total + 1, err + 1)) - res - (0, 0) + (fun _ valid (total, err) -> + if valid then (total + 1, err) + else (total + 1, err + 1)) + unified_res + (0, 0) in print_endline "\n\n\x1b[1;37m"; From 609d41ccbbfc3bf5835c4075f2447e3c00845c88 Mon Sep 17 00:00:00 2001 From: Corentin De Souza <9597216+fantazio@users.noreply.github.com> Date: Wed, 3 Sep 2025 19:39:53 +0200 Subject: [PATCH 4/8] [check] new engine replaces old one --- check/check.ml | 918 ++++++++++++++++++++++++++++++------------------ check/check2.ml | 584 ------------------------------ 2 files changed, 579 insertions(+), 923 deletions(-) delete mode 100644 check/check2.ml diff --git a/check/check.ml b/check/check.ml index 78bb940e..869229ba 100644 --- a/check/check.ml +++ b/check/check.ml @@ -1,344 +1,584 @@ - (******** IDENTIFICATION ********) - -(* Extract an element from a string *) -let get_element ?(f = Str.search_forward) ~regexp ?(start = 0) line = - try - f (Str.regexp regexp) line start - |> ignore; - Str.matched_string line - with _ -> "" - -(* Extract abs_path from current line *) -let get_path = - get_element ~regexp:"\\./.*[ "" then String.sub pos 1 @@ String.length pos - 2 - else pos) - -(* Extract extra info from current line *) -let get_info line = - let info = - get_element ~regexp:": .*$" ~f:Str.search_backward ~start:(String.length line - 1) line - in - String.sub info 1 (String.length info - 1) - -let sec_part ~regexp line = - Str.string_match (Str.regexp regexp) line 0 - -let sec_start = sec_part ~regexp:" *=+" -let sec_end = sec_part ~regexp:"-+\\|\\(Nothing else to report in this section\\)" - - - (******** ERROR HANDLING ********) - -let errors = ref 0 (* Nb FP/FN *) - -let error ~why ~where () = - incr errors; - prerr_string "\x1b[0;31m"; - prerr_string where; - prerr_string ": \x1b[0;37;41m"; - prerr_string why; - prerr_string "\x1b[0m" - |> prerr_newline - - (******** ATTRIBUTES ********) - -let total = ref 0 (* nb tests *) - -let comp = ref "" (* line to compare with *) -let nextl = ref "" (* line to verify *) - -let fnames = ref [] -let dir = ref "" (* directory to find expected outputs *) -let res = ref (open_in_gen [Open_creat] 777 "trash.out") (* output file computed from analysis on ../examples *) - -let fn = ref None (* filename that should currently be processed *) -let in_file = ref !res (* file fn *) -let old_fn = ref None (* previous filename processed *) - -let extend = ref "" (* section specific extension *) - - (******** HELPERS ********) - -let normalize fname = - let rec block fname pos len = - if pos = String.length fname || fname.[pos] = '/' then - String.sub fname (pos - len) len - else block fname (pos + 1) (len + 1) - in - let rec normalize acc fname pos = - if pos = String.length fname then acc - else - let blk = block fname pos 0 in - if blk = "" || blk = "." then - normalize acc fname (pos + 1) - else - normalize (acc ^ "/" ^ blk) fname (pos + String.length blk) - in normalize "." fname 0 - -(* Prints all unreported lines from file *) -let rec empty file = - try - let where = input_line file in - if where <> "" then (error ~why:"Not detected" ~where (); incr total); - empty file - with _ -> close_in file - -(* Empty all files until one respect the condition *) -let rec empty_fnames ?(regexp = ".*") threshold = function - | e::l -> - let extension s = - let tmp = Filename.chop_extension s in - String.sub s (String.length tmp) (String.length s - String.length tmp) - in - if (try extension e <= extension threshold with _ -> true) - && get_element ~regexp ~start:0 e < threshold then ( - empty @@ open_in e; - empty_fnames ~regexp threshold l) - else e::l - | _ -> [] - -let is_trash diff eq = - let tmp = open_in "trash.out" in - if !in_file <> tmp then (close_in tmp; diff ()) - else eq - - (**** Checkers ****) - -(* Filename *) -let rec check_fn name line = - - let ok = match !fn with - | None -> begin match !old_fn with - | Some str when str = name -> - decr total; - error ~why:"Should not be detected" ~where:line (); - nextl := ""; - false - | _ -> fn := Some name; - let name = normalize (!dir ^ name) in - if (try Filename.chop_extension name >= Filename.chop_extension (List.hd !fnames) with _ -> false) then - fnames := List.tl (empty_fnames name !fnames); +module Path = struct + type t = string + + (* Convert windows and unix style separator (resp. '\\' and '/') to + the system's separator, remove any intermediate reference to + the current directory ("."), and reduce multiple consecutive separators + into 1. + WARNING: This assumes `path` is a relative path and will ad "./" at + the beginning of it after the above manipulation *) + let normalize path = + String.split_on_char '\\' path + |> List.concat_map (String.split_on_char '/') + |> List.filter (fun s -> s <> "" && s <> ".") + |> List.cons "." + |> String.concat Filename.dir_sep + + (* Paths read in res.out points to files in /examples/ + relatively from /check : '../examples/' + We want to relocate them as relative to the + directory whjich contains its own examples subdirectory with report files + organized similarly to /examples. : + './examples/'. Therefore, removing the first '.' does the + trick *) + let relocate path = + String.sub path 1 (String.length path - 1) + + let fold ~init ~on_file ~on_directory path = + if not (Sys.file_exists path) then init + else if Sys.is_directory path then on_directory init path + else on_file init path + +end + + +module Section : sig + (* The results are organized by section in the dead_code_analyzer's output. *) + type t = + | Constr_and_fields + | Methods + | Opt_always + | Opt_never + | Style + | Threshold of int * t + | Values + + val to_string : t -> string + + val compare : t -> t -> int + + (* The test suite files have extensions corresponding to the sections of + the expected results they contain. *) + val to_extension : t -> string + + (* The test suite files have extensions corresponding to the sections of + the expected results they contain. *) + val of_extension : string -> t option + + (* The sections are preceded by headers to help identify them. + Returns the corresponding section if the given string is header. + Returns None otherwise. *) + val of_header : string -> t option + + (* Folowing the header's title is a separator to indicate the start of the + report for that section *) + val is_start : string -> bool + + (* There is a footer at the end of each section to indicate the reporting for + that section is done *) + val is_end : string -> bool + +end = struct + + type t = + | Constr_and_fields + | Methods + | Opt_always + | Opt_never + | Style + | Threshold of int * t + | Values + + let rec to_string = function + | Constr_and_fields -> "Constr_and_fields" + | Methods -> "Methods" + | Opt_always -> "Opt_always" + | Opt_never -> "Opt_never" + | Style -> "Style" + | Values -> "Values" + | Threshold (n, t) -> + let sub_string = to_string t in + Printf.sprintf "Threshold(%d, %s)" n sub_string + + let compare = compare + + let rec to_extension = function + | Constr_and_fields -> ".mlit" + | Methods -> ".mlio" + | Opt_always -> ".mlopta" + | Opt_never -> ".mloptn" + | Style -> ".mlstyle" + | Values -> ".mli" + | Threshold (n, base) -> to_extension base ^ string_of_int n + + let rec of_extension = function + | ".mlit" -> Some Constr_and_fields + | ".mlio" -> Some Methods + | ".mlopta" -> Some Opt_always + | ".mloptn" -> Some Opt_never + | ".mlstyle" -> Some Style + | ".mli" -> Some Values + | ext -> + let try_threshold prefix = + if String.starts_with ~prefix ext then + let fmt = Scanf.format_from_string (prefix ^ "%d") "%d" in try - empty !in_file; - in_file := open_in name; - true - with _ -> - error ~why:"File not found or cannot be opened." - ~where:name - (); - fn := None; - nextl := ""; - false - end - | Some str when str = name -> is_trash (fun () -> true) false - | _ -> - if in_channel_length !in_file - 1 <= pos_in !in_file then true - else begin - empty !in_file; - old_fn := !fn; - fn := None; - false - end + let n = Scanf.sscanf ext fmt Fun.id in + of_extension prefix + |> Option.map (fun constr -> Threshold (n, constr)) + with Scanf.Scan_failure _ -> None + else None + in + let exts = [".mlit"; ".mlio"; ".mlopta"; ".mloptn"; ".mlstyle"; ".mli"] in + List.find_map try_threshold exts + + + let is_start s = + String.for_all (( = ) '=') s (* = is used for main sections *) + || String.for_all (( = ) '~') s (* ~ is used for subsections *) + + let is_end s = + s = "Nothing else to report in this section" (* main sections ending *) + || String.for_all (( = ) '-') s (* subsections ending *) + + let of_header = function + | ".> UNUSED CONSTRUCTORS/RECORD FIELDS:" -> Some Constr_and_fields + | ".> UNUSED METHODS:" -> Some Methods + | ".> OPTIONAL ARGUMENTS: ALWAYS:" -> Some Opt_always + | ".> OPTIONAL ARGUMENTS: NEVER:" -> Some Opt_never + | ".> CODING STYLE:" -> Some Style + | ".> UNUSED EXPORTED VALUES:" -> Some Values + | header -> + let get_threshold prefix constr = + if String.starts_with ~prefix header then + let fmt = Scanf.format_from_string (prefix ^ " %d time(s)") "%d" in + let n = Scanf.sscanf header fmt Fun.id in + Some (Threshold (n, constr)) + else None + in + let get_threshold_constr_and_fields () = + let prefix = ".>-> ALMOST UNUSED CONSTRUCTORS/RECORD FIELDS: Called" in + get_threshold prefix Constr_and_fields + in + let get_threshold_methods () = + let prefix = ".>-> ALMOST UNUSED METHODS: Called" in + get_threshold prefix Methods + in + let get_threshold_opt_always () = + let prefix = ".>-> OPTIONAL ARGUMENTS: ALMOST ALWAYS: Except" in + get_threshold prefix Opt_always + in + let get_threshold_opt_never () = + let prefix = ".>-> OPTIONAL ARGUMENTS: ALMOST NEVER: Except" in + get_threshold prefix Opt_never + in + let get_threshold_values () = + let prefix = ".>-> ALMOST UNUSED EXPORTED VALUES: Called" in + get_threshold prefix Values + in + let getters = [ + get_threshold_constr_and_fields; + get_threshold_methods; + get_threshold_opt_always; + get_threshold_opt_never; + get_threshold_values + ] + in + List.find_map (fun f -> f ()) getters + +end + + +module PP = struct + + let red = "\x1b[31m" + let green = "\x1b[32m" + let yellow = "\x1b[33m" + let blue = "\x1b[34m" + let white = "\x1b[37m" + let bg_red = "\x1b[41m" + let style_reset = "\x1b[0m" + + let error ~err ~ctx () = + Printf.eprintf "%s%s: %s%s%s%s\n%!" red ctx white bg_red err style_reset + +end + +module StringSet = Set.Make(String) + +module SectionMap = Map.Make(Section) + +module State = struct + + type results = { + success : int; + fp : int; + fn : int + } + + let results_to_string results = + Printf.sprintf + "{success = %d; fp = %d; fn = %d}" + results.success results.fp results.fn + + let empty_results = {success = 0; fp = 0; fn = 0} + + type expected_reports = { + current_filepath : string option; (* file containg current expected reports *) + remaining_content : string list; (* expected reports in filename not + observed yet *) + root : string; (* directory containing the expected reports files*) + files_map : StringSet.t SectionMap.t (* remaining files containing expected + reports. Once a file is consumed it + is removed from the map. Same for + sections *) + } + + let expected_reports_to_string expected_reports = + let current_filepath = + Option.value ~default:"None" expected_reports.current_filepath + in + let remaining_content = + if List.is_empty expected_reports.remaining_content + then "[]" + else "[..]" + in + let files_map = + Printf.sprintf "{ %s\n }" ( + SectionMap.bindings expected_reports.files_map + |> List.map (fun (sec, files) -> + Printf.sprintf "%s ->{%s}" + (Section.to_string sec) + (String.concat "; " @@ StringSet.to_list files) + ) + |> String.concat ";\n " + ) + (* + if SectionMap.is_empty expected_reports.files_map + then "{}" + else "{..}" + *) + in + Printf.sprintf + "{ current_filepath = %s;\n remaining_content = %s;\n root = %s;\n files_map =\n %s\n}" + current_filepath remaining_content expected_reports.root files_map + + let empty_expected_reports ={ + current_filepath = None; + remaining_content = []; + root = "."; + files_map = SectionMap.empty + } + + type t = { + line : string; (* line observed in dca's report *) + filepath : string option; + section : Section.t option; (* current section *) + expected_reports : expected_reports; + results : results + } + + let empty = { + line = ""; + filepath = None; + section = None; + expected_reports = empty_expected_reports; + results = empty_results + } + + (* Find all files in root that correspond to test files containing + expected reports. This files are identified using their extension. + See module Section above for more info. *) + let init_expected_reports root = + let rec on_directory files_map path = + Sys.readdir path + |> Array.map (fun filename -> path ^ Filename.dir_sep ^ filename) + |> Array.fold_left (fun init path -> Path.fold ~init ~on_directory ~on_file path) files_map + and on_file files_map path = + let ext = Filename.extension path in + match Section.of_extension ext with + | None -> files_map + | Some sec -> + let add_to_set = function + | None -> Some (StringSet.singleton path) + | Some set -> Some (StringSet.add path set) + in + SectionMap.update sec add_to_set files_map + in + let init = SectionMap.empty in + let files_map = Path.fold ~init ~on_directory ~on_file root in + {empty_expected_reports with files_map; root} + + let init exp_root = + let expected_reports = init_expected_reports exp_root in + {empty with expected_reports} + + let incr_fn state = + let fn = state.results.fn + 1 in + let results = {state.results with fn} in + {state with results} + + let report_fn exp_line state = + PP.error ~err:"Not detected" ~ctx:exp_line (); + incr_fn state + + let incr_fp state = + let fp = state.results.fp + 1 in + let results = {state.results with fp} in + {state with results} + + let report_fp res_line state = + PP.error ~err:"Should not be detected" ~ctx:res_line (); + incr_fp state + + let incr_success state = + let success = state.results.success + 1 in + let results = {state.results with success} in + {state with results} + + let report_success res_line state = + print_endline res_line; + incr_success state + + let update_remaining_content state remaining_content = + let remaining_content = List.filter (( <> ) "") remaining_content in + let expected_reports = {state.expected_reports with remaining_content} in + {state with expected_reports} + + let empty_current_file state = + let clear_current_exp state = + let er = state.expected_reports in + let files_map = + (* Remove file from the expected_reports *) + let ( let* ) x f = Option.bind x f in + let ( let+ ) x f = Option.map f x in + let* sec = state.section in + let* set = SectionMap.find_opt sec er.files_map in + let+ filepath = er.current_filepath in + let set = StringSet.remove filepath set in + SectionMap.add sec set er.files_map + in + let files_map = Option.value files_map ~default:er.files_map in + let expected_reports = + {empty_expected_reports with files_map; root = er.root} + in + {state with expected_reports} + in + let remaining_content = state.expected_reports.remaining_content in + List.fold_left (Fun.flip report_fn) state remaining_content + |> clear_current_exp + + let change_file ?(internal = false) filepath state = + let setup_expected_reports filepath state = + match state.section with + | None -> + let err = "Trying to open a file outside a section" in + PP.error ~err ~ctx:filepath (); + state + | Some sec -> + let ext = Section.to_extension sec in + let no_ext = + try Filename.chop_extension filepath + with Invalid_argument _ -> + let err = "Input file without extension" in + PP.error ~err ~ctx:filepath (); + filepath + in + let exp_filepath = no_ext ^ ext in + let exp_filepath = + if internal then exp_filepath + else + state.expected_reports.root ^ Filename.dir_sep ^ exp_filepath + |> Path.normalize + in + match SectionMap.find_opt sec state.expected_reports.files_map with + | Some set when StringSet.mem exp_filepath set -> + let current_filepath = Some exp_filepath in + let state = + In_channel.with_open_text exp_filepath In_channel.input_lines + |> update_remaining_content state + in + let expected_reports = + {state.expected_reports with current_filepath} + in + let filepath = Some filepath in + {state with expected_reports; filepath} + | _ -> + let err = "Expected report not found" in + PP.error ~err ~ctx:exp_filepath (); + state (* TODO: report empty section?*) + in + empty_current_file state + |> setup_expected_reports filepath + + let maybe_change_file new_filepath state = + let compare_no_ext path1 path2 = + String.compare + (Filename.remove_extension path1) + (Filename.remove_extension path2) + in + match state.filepath with + | Some filepath when compare_no_ext filepath new_filepath = 0 -> + state + | _ -> change_file new_filepath state + + let empty_current_section state = + match state.section with + | None -> state + | Some sec -> + let clear_current_section state = + let er = state.expected_reports in + let expected_reports = + let files_map = SectionMap.remove sec er.files_map in + {er with files_map} + in + let section = None in + {state with section; expected_reports} + in + let state = empty_current_file state in + let remaining_files = + SectionMap.find_opt sec state.expected_reports.files_map + |> Option.value ~default:StringSet.empty + in + StringSet.fold (change_file ~internal:true) remaining_files state + |> empty_current_file + |> clear_current_section + + let change_section section state = + let state = + match state.section with + | None -> state + | Some sec -> + let err = "Missing end of section delimiter" in + let ctx = Section.to_string sec in + PP.error ~err ~ctx (); + empty_current_section state + in + {state with section} + + + let print_results {results; _} = + let total = results.success + results.fp + results.fn in + let errors = results.fp + results.fn in + Printf.printf "Total: %s%d%s\n" PP.blue total PP.style_reset; + Printf.printf "Success: %s%d%s\n" PP.green results.success PP.style_reset; + Printf.printf "Failed: %s%d%s\n" PP.red errors PP.style_reset; + let ratio = 100. *. float_of_int results.success /. float_of_int total in + let color = + if ratio < 50. then PP.red + else if ratio < 80. then PP.yellow + else PP.green + in + Printf.printf "Ratio: %s%F%%%s\n%!" color ratio PP.style_reset + +end + +(* Format of report lines is : "file_path:line_number: report_info" + with report_info possibly containing ':'. In case the line comes from + the direct report of dca (is_res_line), the filepath will be relocated + to correspond to filepaths coming from expected reports *) +let infos_of_report_line ~is_res_line line = + let report_line_format = "filepath:line_nb:report_info" in + match String.split_on_char ':' line with + | [] | _::[] | _::_::[] -> + let err = + Printf.sprintf + "Unrecognized report line format. Expected : '%s'" + report_line_format + in + PP.error ~err ~ctx:line (); + None + | filepath::line_number::report_info -> + try + let line_nb = int_of_string line_number in + let filepath = (* relocate to match expected paths *) + if is_res_line then Path.relocate filepath + else filepath + in + let filepath = Path.normalize filepath in + let report_info = String.concat ":" report_info in + let line = (* recontruct the line with updated fields *) + if is_res_line then + String.concat ":" [filepath; line_number; report_info] + else line + in + Some (filepath, line_nb, report_info, line) + with Failure _int_of_string -> + let err = + Printf.sprintf + "Is not an int. Expected report line format is : '%s'" + report_line_format + in + PP.error ~err ~ctx:line_number (); + None + +let rec process_report_line state (filepath, line_number, report_info, res_line) = + let state = State.maybe_change_file filepath state in + match state.expected_reports.remaining_content with + | [] -> State.report_fp res_line state + | exp_line::remaining_content when exp_line = res_line -> + State.update_remaining_content state remaining_content + |> State.report_success res_line + | exp_line::remaining_content -> + match infos_of_report_line ~is_res_line:false exp_line with + | None -> + (* exp_line reported in infos_of_report_line as misformatted *) + state + | Some (exp_filepath, exp_line_number, _, exp_line) -> + let compare = + let paths_compare = String.compare exp_filepath filepath in + if paths_compare = 0 then exp_line_number - line_number + else paths_compare + in + if compare > 0 then State.report_fp res_line state + else if compare < 0 then + let state = + State.update_remaining_content state remaining_content + |> State.report_fn exp_line + in + process_report_line state (filepath, line_number, report_info, res_line) + else + (* The location is fine but report_info does not match. + The reports are not organized according to the report_info but + only the locations (including the column which is not reported. + Check if the current line exists in the remaining_content. + If so, then it is a successful report which can be removed from + the remaining content. Otherwise, it is a fp. *) + if List.mem res_line remaining_content then + List.filter (( <> ) res_line) remaining_content + |> State.update_remaining_content state + |> State.report_success res_line + else State.report_fp res_line state + +let process state res_line = + let is_report_line, state = + if res_line = "" then + false, State.empty_current_file {state with filepath = None} + else if Section.is_end res_line then + false, State.empty_current_section state + else if Section.is_start res_line then + false, state + else + match Section.of_header res_line with + | Some _ as sec -> + false, State.change_section sec state + | None -> (* res_line is a report line *) + match infos_of_report_line ~is_res_line:true res_line with + | None -> + (* res_line reported in infos_of_report_line as misformatted *) + false, state + | Some infos -> + true, process_report_line state infos in + if not is_report_line then print_endline res_line; + state - if ok then - try - input_line !in_file - with End_of_file -> - close_in !in_file; - old_fn := !fn; - fn := None; - check_fn name line - else "" - -let check_elt ~f line x = compare x @@ f line - -let check_aux line status= - if status > 0 then (error ~why:("Not detected") ~where:line (); comp := ""; false) - else if status < 0 then (decr total; error ~why:("Should not be detected") ~where:!nextl (); nextl := ""; false) - else true - -let check_value line x = - check_elt ~f:get_info line x |> check_aux line - -let check_pos line pos = - check_elt ~f:get_pos line pos |> check_aux line - -let check_info line info = - if (check_elt ~f:get_info line info) <> 0 then - (error ~why:("Expected:" ^ (get_info line)) ~where:!nextl (); - nextl := ""; comp := ""; false) - else true - - (**** Blocks ****) - -let rec section ?(path = true) ?(pos = true) ?(value = false) ?(info = true) () = - try - if !nextl = "" then (nextl := input_line !res; section ~path ~pos ~value ~info ()) - else if sec_start !nextl then (nextl := ""; comp := ""; section ~path ~pos ~value ~info ()) - else if sec_end !nextl then - (is_trash (fun () -> empty !in_file) (); - print_string !nextl; print_string "\n\n\n"; nextl := "") - else if !comp <> "" && normalize (get_path !comp) <> normalize (get_path !nextl) then begin - empty !in_file; - comp := ""; - old_fn := !fn; - fn := None; - section ~path ~pos ~value ~info () - end - else begin - incr total; - comp := if path && !comp = "" then ((Filename.chop_extension @@ get_path !nextl) ^ !extend |> check_fn) !nextl else !comp; - if not path || !comp <> "" then - if not ((pos && not @@ check_pos !comp @@ get_pos !nextl) - || (value && not @@ check_value !comp @@ get_info !nextl) - || (info && not @@ check_info !comp @@ get_info !nextl)) then - (print_endline !nextl; nextl := ""; comp := ""); - section ~path ~pos ~value ~info () - end - with End_of_file -> is_trash (fun () -> empty !in_file) () - -let rec sel_section () = - fn := None; old_fn := None; - nextl := ""; comp := ""; - try - match (input_line !res) with - | ".> UNUSED EXPORTED VALUES:" as s -> - (try fnames := empty_fnames ~regexp:"\\.ml[a-z0-9]*$" ".mli" !fnames - with _ -> ()); - print_endline s; - print_endline (input_line !res); - extend := ".mli"; - sel_section (section ()) - | ".> UNUSED METHODS:" as s -> - (try fnames := empty_fnames ~regexp:"\\.ml[a-z0-9]*$" ".mlio" !fnames - with _ -> ()); - print_endline s; - print_endline (input_line !res); - extend := ".mlio"; - sel_section (section ()) - | ".> UNUSED CONSTRUCTORS/RECORD FIELDS:" as s -> - (try fnames := empty_fnames ~regexp:"\\.ml[a-z0-9]*$" ".mlit" !fnames - with _ -> ()); - print_endline s; - print_endline (input_line !res); - extend := ".mlit"; - sel_section (section ()) - | ".> OPTIONAL ARGUMENTS: ALWAYS:" as s -> - (try fnames := empty_fnames ~regexp:"\\.ml[a-z0-9]*$" ".mlopta" !fnames - with _ -> ()); - print_endline s; - print_endline (input_line !res); - extend := ".mlopta"; - sel_section (section ~value:true ~info:false ()) - | ".> OPTIONAL ARGUMENTS: NEVER:" as s -> - (try fnames := empty_fnames ~regexp:"\\.ml[a-z0-9]*$" ".mloptn" !fnames - with _ -> ()); - print_endline s; - print_endline (input_line !res); - extend := ".mloptn"; - sel_section (section ~value:true ~info:false ()) - | ".> CODING STYLE:" as s -> - (try fnames := empty_fnames ~regexp:"\\.ml[a-z0-9]*$" ".mlstyle" !fnames - with _ -> ()); - print_endline s; - print_endline (input_line !res); - extend := ".mlstyle"; - sel_section (section ()) - | s when String.length s > 36 && String.sub s 0 36 = ".>-> ALMOST UNUSED EXPORTED VALUES:" -> - let n = - Scanf.sscanf s ".>-> ALMOST UNUSED EXPORTED VALUES: Called %s time(s)" (fun n -> n) - in - begin try fnames := empty_fnames ~regexp:"\\.ml[a-z0-9]*$" (".mli" ^ n) !fnames - with _ -> () end; - print_endline s; - print_endline (input_line !res); - extend := ".mli" ^ n; - sel_section (section ()) - | s when String.length s > 33 && String.sub s 0 28 = ".>-> ALMOST UNUSED METHODS:" -> - let n = - Scanf.sscanf s ".>-> ALMOST UNUSED METHODS: Called %s time(s)" (fun n -> n) - in - begin try fnames := empty_fnames ~regexp:"\\.ml[a-z0-9]*$" (".mlio" ^ n) !fnames - with _ -> () end; - print_endline s; - print_endline (input_line !res); - extend := ".mlio" ^ n; - sel_section (section ()) - | s when String.length s > 55 - && String.sub s 0 47 = ".>-> ALMOST UNUSED CONSTRUCTORS/RECORD FIELDS:" -> - let n = - Scanf.sscanf s ".>-> ALMOST UNUSED CONSTRUCTORS/RECORD FIELDS: Called %s time(s)" (fun n -> n) - in - begin try fnames := empty_fnames ~regexp:"\\.ml[a-z0-9]*$" (".mlit" ^ n) !fnames - with _ -> () end; - print_endline s; - print_endline (input_line !res); - extend := ".mlit" ^ n; - sel_section (section ()) - | s when String.length s > 40 && String.sub s 0 40 = ".>-> OPTIONAL ARGUMENTS: ALMOST ALWAYS:" -> - let n = - Scanf.sscanf s ".>-> OPTIONAL ARGUMENTS: ALMOST ALWAYS: Except %s time(s)" (fun n -> n) - in - begin try fnames := empty_fnames ~regexp:"\\.ml[a-z0-9]*$" (".mlopta" ^ n) !fnames - with _ -> () end; - print_endline s; - print_endline (input_line !res); - extend := ".mlopta" ^ n; - sel_section (section ()) - | s when String.length s > 39 && String.sub s 0 39 = ".>-> OPTIONAL ARGUMENTS: ALMOST NEVER:" -> - let n = - Scanf.sscanf s ".>-> OPTIONAL ARGUMENTS: ALMOST NEVER: Except %s time(s)" (fun n -> n) - in - begin try fnames := empty_fnames ~regexp:"\\.ml[a-z0-9]*$" (".mloptn" ^ n) !fnames - with _ -> () end; - print_endline s; - print_endline (input_line !res); - extend := ".mloptn" ^ n; - sel_section (section ()) - | _ -> sel_section () - with End_of_file -> () - -let result () = - print_string "Total: \x1b[0;34m"; - print_int !total; - print_string "\x1b[0m\nFailed: \x1b[0;31m"; - print_int !errors; - let ratio = ( -. ) 100. @@ ( *. ) 100. @@ (float_of_int !total |> ( /. ) @@ float_of_int !errors) in - print_string @@ "\x1b[0m\nRatio: \x1b[0;3" - ^ (if ratio < 50. then "1m" else if ratio < 80. then "3m" else "2m"); - print_float ratio; - print_endline "%\x1b[0m" - -let rec get_fnames ?(acc = []) dir = - try - if Sys.is_directory dir then - acc @ Array.fold_left (fun l s -> get_fnames ~acc:l (normalize (dir ^ "/" ^ s))) [] @@ Sys.readdir dir - else if dir <> "./check.ml" && Str.string_match (Str.regexp ".*/[_a-zA-Z0-9-]*.ml[a-z0-9]*") dir 0 then dir::acc - else acc - with _ -> acc +let get_expected_reports_root () = + if (Array.length Sys.argv) < 2 then "." + else Path.normalize Sys.argv.(1) + +let get_res_filename () = + if (Array.length Sys.argv) < 3 then "res.out" + else Path.normalize Sys.argv.(2) let () = - dir := - if (Array.length Sys.argv) < 2 then "." - else Sys.argv.(1); - res := - if (Array.length Sys.argv) < 3 then open_in "res.out" - else open_in Sys.argv.(2); - fnames := List.fast_sort - (fun x y -> - let req s = - get_element ~f:Str.search_backward ~regexp:"\\.ml[a-z0-9]*" ~start:(String.length s - 1) s in - let c = compare (req x) (req y) in - if c = 0 then compare x y - else c) - @@ get_fnames !dir; - dir := !dir ^ "/"; - sel_section () ; - close_in !res; - result () + let res_file = get_res_filename () in + let input_lines = In_channel.with_open_text res_file In_channel.input_lines in + let init_state = State.init (get_expected_reports_root ()) in + let state = + List.fold_left + process + init_state + input_lines + in + State.print_results state diff --git a/check/check2.ml b/check/check2.ml deleted file mode 100644 index 869229ba..00000000 --- a/check/check2.ml +++ /dev/null @@ -1,584 +0,0 @@ -module Path = struct - type t = string - - (* Convert windows and unix style separator (resp. '\\' and '/') to - the system's separator, remove any intermediate reference to - the current directory ("."), and reduce multiple consecutive separators - into 1. - WARNING: This assumes `path` is a relative path and will ad "./" at - the beginning of it after the above manipulation *) - let normalize path = - String.split_on_char '\\' path - |> List.concat_map (String.split_on_char '/') - |> List.filter (fun s -> s <> "" && s <> ".") - |> List.cons "." - |> String.concat Filename.dir_sep - - (* Paths read in res.out points to files in /examples/ - relatively from /check : '../examples/' - We want to relocate them as relative to the - directory whjich contains its own examples subdirectory with report files - organized similarly to /examples. : - './examples/'. Therefore, removing the first '.' does the - trick *) - let relocate path = - String.sub path 1 (String.length path - 1) - - let fold ~init ~on_file ~on_directory path = - if not (Sys.file_exists path) then init - else if Sys.is_directory path then on_directory init path - else on_file init path - -end - - -module Section : sig - (* The results are organized by section in the dead_code_analyzer's output. *) - type t = - | Constr_and_fields - | Methods - | Opt_always - | Opt_never - | Style - | Threshold of int * t - | Values - - val to_string : t -> string - - val compare : t -> t -> int - - (* The test suite files have extensions corresponding to the sections of - the expected results they contain. *) - val to_extension : t -> string - - (* The test suite files have extensions corresponding to the sections of - the expected results they contain. *) - val of_extension : string -> t option - - (* The sections are preceded by headers to help identify them. - Returns the corresponding section if the given string is header. - Returns None otherwise. *) - val of_header : string -> t option - - (* Folowing the header's title is a separator to indicate the start of the - report for that section *) - val is_start : string -> bool - - (* There is a footer at the end of each section to indicate the reporting for - that section is done *) - val is_end : string -> bool - -end = struct - - type t = - | Constr_and_fields - | Methods - | Opt_always - | Opt_never - | Style - | Threshold of int * t - | Values - - let rec to_string = function - | Constr_and_fields -> "Constr_and_fields" - | Methods -> "Methods" - | Opt_always -> "Opt_always" - | Opt_never -> "Opt_never" - | Style -> "Style" - | Values -> "Values" - | Threshold (n, t) -> - let sub_string = to_string t in - Printf.sprintf "Threshold(%d, %s)" n sub_string - - let compare = compare - - let rec to_extension = function - | Constr_and_fields -> ".mlit" - | Methods -> ".mlio" - | Opt_always -> ".mlopta" - | Opt_never -> ".mloptn" - | Style -> ".mlstyle" - | Values -> ".mli" - | Threshold (n, base) -> to_extension base ^ string_of_int n - - let rec of_extension = function - | ".mlit" -> Some Constr_and_fields - | ".mlio" -> Some Methods - | ".mlopta" -> Some Opt_always - | ".mloptn" -> Some Opt_never - | ".mlstyle" -> Some Style - | ".mli" -> Some Values - | ext -> - let try_threshold prefix = - if String.starts_with ~prefix ext then - let fmt = Scanf.format_from_string (prefix ^ "%d") "%d" in - try - let n = Scanf.sscanf ext fmt Fun.id in - of_extension prefix - |> Option.map (fun constr -> Threshold (n, constr)) - with Scanf.Scan_failure _ -> None - else None - in - let exts = [".mlit"; ".mlio"; ".mlopta"; ".mloptn"; ".mlstyle"; ".mli"] in - List.find_map try_threshold exts - - - let is_start s = - String.for_all (( = ) '=') s (* = is used for main sections *) - || String.for_all (( = ) '~') s (* ~ is used for subsections *) - - let is_end s = - s = "Nothing else to report in this section" (* main sections ending *) - || String.for_all (( = ) '-') s (* subsections ending *) - - let of_header = function - | ".> UNUSED CONSTRUCTORS/RECORD FIELDS:" -> Some Constr_and_fields - | ".> UNUSED METHODS:" -> Some Methods - | ".> OPTIONAL ARGUMENTS: ALWAYS:" -> Some Opt_always - | ".> OPTIONAL ARGUMENTS: NEVER:" -> Some Opt_never - | ".> CODING STYLE:" -> Some Style - | ".> UNUSED EXPORTED VALUES:" -> Some Values - | header -> - let get_threshold prefix constr = - if String.starts_with ~prefix header then - let fmt = Scanf.format_from_string (prefix ^ " %d time(s)") "%d" in - let n = Scanf.sscanf header fmt Fun.id in - Some (Threshold (n, constr)) - else None - in - let get_threshold_constr_and_fields () = - let prefix = ".>-> ALMOST UNUSED CONSTRUCTORS/RECORD FIELDS: Called" in - get_threshold prefix Constr_and_fields - in - let get_threshold_methods () = - let prefix = ".>-> ALMOST UNUSED METHODS: Called" in - get_threshold prefix Methods - in - let get_threshold_opt_always () = - let prefix = ".>-> OPTIONAL ARGUMENTS: ALMOST ALWAYS: Except" in - get_threshold prefix Opt_always - in - let get_threshold_opt_never () = - let prefix = ".>-> OPTIONAL ARGUMENTS: ALMOST NEVER: Except" in - get_threshold prefix Opt_never - in - let get_threshold_values () = - let prefix = ".>-> ALMOST UNUSED EXPORTED VALUES: Called" in - get_threshold prefix Values - in - let getters = [ - get_threshold_constr_and_fields; - get_threshold_methods; - get_threshold_opt_always; - get_threshold_opt_never; - get_threshold_values - ] - in - List.find_map (fun f -> f ()) getters - -end - - -module PP = struct - - let red = "\x1b[31m" - let green = "\x1b[32m" - let yellow = "\x1b[33m" - let blue = "\x1b[34m" - let white = "\x1b[37m" - let bg_red = "\x1b[41m" - let style_reset = "\x1b[0m" - - let error ~err ~ctx () = - Printf.eprintf "%s%s: %s%s%s%s\n%!" red ctx white bg_red err style_reset - -end - -module StringSet = Set.Make(String) - -module SectionMap = Map.Make(Section) - -module State = struct - - type results = { - success : int; - fp : int; - fn : int - } - - let results_to_string results = - Printf.sprintf - "{success = %d; fp = %d; fn = %d}" - results.success results.fp results.fn - - let empty_results = {success = 0; fp = 0; fn = 0} - - type expected_reports = { - current_filepath : string option; (* file containg current expected reports *) - remaining_content : string list; (* expected reports in filename not - observed yet *) - root : string; (* directory containing the expected reports files*) - files_map : StringSet.t SectionMap.t (* remaining files containing expected - reports. Once a file is consumed it - is removed from the map. Same for - sections *) - } - - let expected_reports_to_string expected_reports = - let current_filepath = - Option.value ~default:"None" expected_reports.current_filepath - in - let remaining_content = - if List.is_empty expected_reports.remaining_content - then "[]" - else "[..]" - in - let files_map = - Printf.sprintf "{ %s\n }" ( - SectionMap.bindings expected_reports.files_map - |> List.map (fun (sec, files) -> - Printf.sprintf "%s ->{%s}" - (Section.to_string sec) - (String.concat "; " @@ StringSet.to_list files) - ) - |> String.concat ";\n " - ) - (* - if SectionMap.is_empty expected_reports.files_map - then "{}" - else "{..}" - *) - in - Printf.sprintf - "{ current_filepath = %s;\n remaining_content = %s;\n root = %s;\n files_map =\n %s\n}" - current_filepath remaining_content expected_reports.root files_map - - let empty_expected_reports ={ - current_filepath = None; - remaining_content = []; - root = "."; - files_map = SectionMap.empty - } - - type t = { - line : string; (* line observed in dca's report *) - filepath : string option; - section : Section.t option; (* current section *) - expected_reports : expected_reports; - results : results - } - - let empty = { - line = ""; - filepath = None; - section = None; - expected_reports = empty_expected_reports; - results = empty_results - } - - (* Find all files in root that correspond to test files containing - expected reports. This files are identified using their extension. - See module Section above for more info. *) - let init_expected_reports root = - let rec on_directory files_map path = - Sys.readdir path - |> Array.map (fun filename -> path ^ Filename.dir_sep ^ filename) - |> Array.fold_left (fun init path -> Path.fold ~init ~on_directory ~on_file path) files_map - and on_file files_map path = - let ext = Filename.extension path in - match Section.of_extension ext with - | None -> files_map - | Some sec -> - let add_to_set = function - | None -> Some (StringSet.singleton path) - | Some set -> Some (StringSet.add path set) - in - SectionMap.update sec add_to_set files_map - in - let init = SectionMap.empty in - let files_map = Path.fold ~init ~on_directory ~on_file root in - {empty_expected_reports with files_map; root} - - let init exp_root = - let expected_reports = init_expected_reports exp_root in - {empty with expected_reports} - - let incr_fn state = - let fn = state.results.fn + 1 in - let results = {state.results with fn} in - {state with results} - - let report_fn exp_line state = - PP.error ~err:"Not detected" ~ctx:exp_line (); - incr_fn state - - let incr_fp state = - let fp = state.results.fp + 1 in - let results = {state.results with fp} in - {state with results} - - let report_fp res_line state = - PP.error ~err:"Should not be detected" ~ctx:res_line (); - incr_fp state - - let incr_success state = - let success = state.results.success + 1 in - let results = {state.results with success} in - {state with results} - - let report_success res_line state = - print_endline res_line; - incr_success state - - let update_remaining_content state remaining_content = - let remaining_content = List.filter (( <> ) "") remaining_content in - let expected_reports = {state.expected_reports with remaining_content} in - {state with expected_reports} - - let empty_current_file state = - let clear_current_exp state = - let er = state.expected_reports in - let files_map = - (* Remove file from the expected_reports *) - let ( let* ) x f = Option.bind x f in - let ( let+ ) x f = Option.map f x in - let* sec = state.section in - let* set = SectionMap.find_opt sec er.files_map in - let+ filepath = er.current_filepath in - let set = StringSet.remove filepath set in - SectionMap.add sec set er.files_map - in - let files_map = Option.value files_map ~default:er.files_map in - let expected_reports = - {empty_expected_reports with files_map; root = er.root} - in - {state with expected_reports} - in - let remaining_content = state.expected_reports.remaining_content in - List.fold_left (Fun.flip report_fn) state remaining_content - |> clear_current_exp - - let change_file ?(internal = false) filepath state = - let setup_expected_reports filepath state = - match state.section with - | None -> - let err = "Trying to open a file outside a section" in - PP.error ~err ~ctx:filepath (); - state - | Some sec -> - let ext = Section.to_extension sec in - let no_ext = - try Filename.chop_extension filepath - with Invalid_argument _ -> - let err = "Input file without extension" in - PP.error ~err ~ctx:filepath (); - filepath - in - let exp_filepath = no_ext ^ ext in - let exp_filepath = - if internal then exp_filepath - else - state.expected_reports.root ^ Filename.dir_sep ^ exp_filepath - |> Path.normalize - in - match SectionMap.find_opt sec state.expected_reports.files_map with - | Some set when StringSet.mem exp_filepath set -> - let current_filepath = Some exp_filepath in - let state = - In_channel.with_open_text exp_filepath In_channel.input_lines - |> update_remaining_content state - in - let expected_reports = - {state.expected_reports with current_filepath} - in - let filepath = Some filepath in - {state with expected_reports; filepath} - | _ -> - let err = "Expected report not found" in - PP.error ~err ~ctx:exp_filepath (); - state (* TODO: report empty section?*) - in - empty_current_file state - |> setup_expected_reports filepath - - let maybe_change_file new_filepath state = - let compare_no_ext path1 path2 = - String.compare - (Filename.remove_extension path1) - (Filename.remove_extension path2) - in - match state.filepath with - | Some filepath when compare_no_ext filepath new_filepath = 0 -> - state - | _ -> change_file new_filepath state - - let empty_current_section state = - match state.section with - | None -> state - | Some sec -> - let clear_current_section state = - let er = state.expected_reports in - let expected_reports = - let files_map = SectionMap.remove sec er.files_map in - {er with files_map} - in - let section = None in - {state with section; expected_reports} - in - let state = empty_current_file state in - let remaining_files = - SectionMap.find_opt sec state.expected_reports.files_map - |> Option.value ~default:StringSet.empty - in - StringSet.fold (change_file ~internal:true) remaining_files state - |> empty_current_file - |> clear_current_section - - let change_section section state = - let state = - match state.section with - | None -> state - | Some sec -> - let err = "Missing end of section delimiter" in - let ctx = Section.to_string sec in - PP.error ~err ~ctx (); - empty_current_section state - in - {state with section} - - - let print_results {results; _} = - let total = results.success + results.fp + results.fn in - let errors = results.fp + results.fn in - Printf.printf "Total: %s%d%s\n" PP.blue total PP.style_reset; - Printf.printf "Success: %s%d%s\n" PP.green results.success PP.style_reset; - Printf.printf "Failed: %s%d%s\n" PP.red errors PP.style_reset; - let ratio = 100. *. float_of_int results.success /. float_of_int total in - let color = - if ratio < 50. then PP.red - else if ratio < 80. then PP.yellow - else PP.green - in - Printf.printf "Ratio: %s%F%%%s\n%!" color ratio PP.style_reset - -end - -(* Format of report lines is : "file_path:line_number: report_info" - with report_info possibly containing ':'. In case the line comes from - the direct report of dca (is_res_line), the filepath will be relocated - to correspond to filepaths coming from expected reports *) -let infos_of_report_line ~is_res_line line = - let report_line_format = "filepath:line_nb:report_info" in - match String.split_on_char ':' line with - | [] | _::[] | _::_::[] -> - let err = - Printf.sprintf - "Unrecognized report line format. Expected : '%s'" - report_line_format - in - PP.error ~err ~ctx:line (); - None - | filepath::line_number::report_info -> - try - let line_nb = int_of_string line_number in - let filepath = (* relocate to match expected paths *) - if is_res_line then Path.relocate filepath - else filepath - in - let filepath = Path.normalize filepath in - let report_info = String.concat ":" report_info in - let line = (* recontruct the line with updated fields *) - if is_res_line then - String.concat ":" [filepath; line_number; report_info] - else line - in - Some (filepath, line_nb, report_info, line) - with Failure _int_of_string -> - let err = - Printf.sprintf - "Is not an int. Expected report line format is : '%s'" - report_line_format - in - PP.error ~err ~ctx:line_number (); - None - -let rec process_report_line state (filepath, line_number, report_info, res_line) = - let state = State.maybe_change_file filepath state in - match state.expected_reports.remaining_content with - | [] -> State.report_fp res_line state - | exp_line::remaining_content when exp_line = res_line -> - State.update_remaining_content state remaining_content - |> State.report_success res_line - | exp_line::remaining_content -> - match infos_of_report_line ~is_res_line:false exp_line with - | None -> - (* exp_line reported in infos_of_report_line as misformatted *) - state - | Some (exp_filepath, exp_line_number, _, exp_line) -> - let compare = - let paths_compare = String.compare exp_filepath filepath in - if paths_compare = 0 then exp_line_number - line_number - else paths_compare - in - if compare > 0 then State.report_fp res_line state - else if compare < 0 then - let state = - State.update_remaining_content state remaining_content - |> State.report_fn exp_line - in - process_report_line state (filepath, line_number, report_info, res_line) - else - (* The location is fine but report_info does not match. - The reports are not organized according to the report_info but - only the locations (including the column which is not reported. - Check if the current line exists in the remaining_content. - If so, then it is a successful report which can be removed from - the remaining content. Otherwise, it is a fp. *) - if List.mem res_line remaining_content then - List.filter (( <> ) res_line) remaining_content - |> State.update_remaining_content state - |> State.report_success res_line - else State.report_fp res_line state - -let process state res_line = - let is_report_line, state = - if res_line = "" then - false, State.empty_current_file {state with filepath = None} - else if Section.is_end res_line then - false, State.empty_current_section state - else if Section.is_start res_line then - false, state - else - match Section.of_header res_line with - | Some _ as sec -> - false, State.change_section sec state - | None -> (* res_line is a report line *) - match infos_of_report_line ~is_res_line:true res_line with - | None -> - (* res_line reported in infos_of_report_line as misformatted *) - false, state - | Some infos -> - true, process_report_line state infos - in - if not is_report_line then print_endline res_line; - state - -let get_expected_reports_root () = - if (Array.length Sys.argv) < 2 then "." - else Path.normalize Sys.argv.(1) - -let get_res_filename () = - if (Array.length Sys.argv) < 3 then "res.out" - else Path.normalize Sys.argv.(2) - -let () = - let res_file = get_res_filename () in - let input_lines = In_channel.with_open_text res_file In_channel.input_lines in - let init_state = State.init (get_expected_reports_root ()) in - let state = - List.fold_left - process - init_state - input_lines - in - State.print_results state From 9413a047c794cab7fb408547083893219ccc6672 Mon Sep 17 00:00:00 2001 From: Corentin De Souza <9597216+fantazio@users.noreply.github.com> Date: Thu, 4 Sep 2025 18:19:34 +0200 Subject: [PATCH 5/8] [check] start code reorganization Code will be contained in the check/src directory to reduce noise --- check/Makefile | 46 ++++++++++++++++-------------------- check/src/Makefile | 21 ++++++++++++++++ check/{ => src}/aggregate.ml | 0 check/{ => src}/check.ml | 0 4 files changed, 41 insertions(+), 26 deletions(-) create mode 100644 check/src/Makefile rename check/{ => src}/aggregate.ml (100%) rename check/{ => src}/check.ml (100%) diff --git a/check/Makefile b/check/Makefile index adf6b104..274d32e0 100644 --- a/check/Makefile +++ b/check/Makefile @@ -1,53 +1,47 @@ -LIBS=str.cma -COMPFLAGS=-w +A-4-9-40-42 -bin-annot -keep-locs -OCAMLC=ocamlc $(COMPFLAGS) -OCAMLOPT=ocamlopt $(COMPFLAGS) -SRC=check.ml TARGET=res.out EXT=byt - -all: aggr.$(EXT)$(EXE) - make internal > internal.out 2>&1 EXT=$(EXT) - make classic > classic.out 2>&1 EXT=$(EXT) - make threshold-1 > threshold-1.out 2>&1 EXT=$(EXT) - make threshold-3-0.5 > threshold-3-0.5.out 2>&1 EXT=$(EXT) - ./aggr.$(EXT)$(EXE) threshold-3-0.5.out threshold-1.out internal.out classic.out +SCENARIOS=threshold-3-0.5 threshold-1 internal classic + +all: aggregate.$(EXT)$(EXE) + @echo "Running scenarios:" + @# The 2nd echo in the loop below overlaps the 1st one for aesthetics purpose + @for scenario in $(SCENARIOS); do \ + echo -n "$$scenario : In progress"; \ + make $$scenario > $$scenario.out 2>&1 EXT=$(EXT); \ + echo \\r"$$scenario : Done "; \ + done + ./src/aggregate.$(EXT)$(EXE) $(SCENARIOS:=.out) opt: make EXT=opt internal: prepare check.$(EXT)$(EXE) ../_build/install/default/bin/dead_code_analyzer -A --internal ../examples > $(TARGET) - ./check.$(EXT)$(EXE) ./internal $(TARGET) + ./src/check.$(EXT)$(EXE) ./internal $(TARGET) classic: prepare check.$(EXT)$(EXE) ../_build/install/default/bin/dead_code_analyzer -A ../examples > $(TARGET) - ./check.$(EXT)$(EXE) ./classic $(TARGET) + ./src/check.$(EXT)$(EXE) ./classic $(TARGET) threshold-1: prepare check.$(EXT)$(EXE) ../_build/install/default/bin/dead_code_analyzer -A --internal -E threshold:1 -M threshold:1 -T threshold:1 ../examples > $(TARGET) - ./check.$(EXT)$(EXE) ./threshold-1 $(TARGET) + ./src/check.$(EXT)$(EXE) ./threshold-1 $(TARGET) threshold-3-0.5: prepare check.$(EXT)$(EXE) ../_build/install/default/bin/dead_code_analyzer -A --internal -E threshold:3 -Oa both:3,0.5 -On both:3,0.5 -M threshold:3 -T threshold:3 ../examples > $(TARGET) - ./check.$(EXT)$(EXE) ./threshold-3-0.5 $(TARGET) + ./src/check.$(EXT)$(EXE) ./threshold-3-0.5 $(TARGET) prepare: dune build .. make -C ../examples build > /dev/null 2>&1 -check.byt$(EXE): $(SRC) - $(OCAMLC) -o $@ $(LIBS) $^ - -check.opt$(EXE): $(SRC) - $(OCAMLOPT) -o $@ $(LIBS:.cma=.cmxa) $^ - -aggr.byt$(EXE): aggregate.ml - $(OCAMLC) -o $@ $^ +check.$(EXT)$(EXE): + make -C src $@ -aggr.opt$(EXE): aggregate.ml - $(OCAMLOPT) -o $@ $^ +aggregate.$(EXT)$(EXE): + make -C src $@ clean: rm -f *~ *.cm* *.a *.lib *.o *.obj *.byt$(EXE) *.opt$(EXE) **.out + make -C src clean diff --git a/check/src/Makefile b/check/src/Makefile new file mode 100644 index 00000000..0ef203e6 --- /dev/null +++ b/check/src/Makefile @@ -0,0 +1,21 @@ +COMPFLAGS=-w +A-4-9-40-42 -bin-annot -keep-locs +OCAMLC=ocamlc $(COMPFLAGS) +OCAMLOPT=ocamlopt $(COMPFLAGS) + +CHECK_SRC=check.ml +AGGR_SRC=aggregate.ml + +check.byt$(EXE): $(CHECK_SRC) + $(OCAMLC) -o $@ $^ + +check.opt$(EXE): $(CHECK_SRC) + $(OCAMLOPT) -o $@ $^ + +aggregate.byt$(EXE): $(AGGR_SRC) + $(OCAMLC) -o $@ $^ + +aggregate.opt$(EXE): $(AGGR_SRC) + $(OCAMLOPT) -o $@ $^ + +clean: + rm -f *~ *.cm* *.a *.lib *.o *.obj *.byt$(EXE) *.opt$(EXE) **.out diff --git a/check/aggregate.ml b/check/src/aggregate.ml similarity index 100% rename from check/aggregate.ml rename to check/src/aggregate.ml diff --git a/check/check.ml b/check/src/check.ml similarity index 100% rename from check/check.ml rename to check/src/check.ml From 4683ecf86bdb99e4811eedd730e5184bc745458c Mon Sep 17 00:00:00 2001 From: Corentin De Souza <9597216+fantazio@users.noreply.github.com> Date: Thu, 4 Sep 2025 18:58:12 +0200 Subject: [PATCH 6/8] [check] continue code reorganization Extract some modules out of check.ml to debloat it --- check/src/Makefile | 5 +- check/src/aggregate.mli | 0 check/src/check.ml | 327 ++++++++----------------------------- check/src/check.mli | 0 check/src/pretty_print.ml | 10 ++ check/src/pretty_print.mli | 10 ++ check/src/scores.ml | 35 ++++ check/src/scores.mli | 11 ++ check/src/section.ml | 105 ++++++++++++ check/src/section.mli | 34 ++++ 10 files changed, 272 insertions(+), 265 deletions(-) create mode 100644 check/src/aggregate.mli create mode 100644 check/src/check.mli create mode 100644 check/src/pretty_print.ml create mode 100644 check/src/pretty_print.mli create mode 100644 check/src/scores.ml create mode 100644 check/src/scores.mli create mode 100644 check/src/section.ml create mode 100644 check/src/section.mli diff --git a/check/src/Makefile b/check/src/Makefile index 0ef203e6..ecd5fb66 100644 --- a/check/src/Makefile +++ b/check/src/Makefile @@ -2,8 +2,9 @@ COMPFLAGS=-w +A-4-9-40-42 -bin-annot -keep-locs OCAMLC=ocamlc $(COMPFLAGS) OCAMLOPT=ocamlopt $(COMPFLAGS) -CHECK_SRC=check.ml -AGGR_SRC=aggregate.ml +API_SRC=pretty_print.ml section.ml scores.ml +CHECK_SRC=$(API_SRC:.ml=.mli) $(API_SRC) check.mli check.ml +AGGR_SRC=aggregate.mli aggregate.ml check.byt$(EXE): $(CHECK_SRC) $(OCAMLC) -o $@ $^ diff --git a/check/src/aggregate.mli b/check/src/aggregate.mli new file mode 100644 index 00000000..e69de29b diff --git a/check/src/check.ml b/check/src/check.ml index 869229ba..8048fa8a 100644 --- a/check/src/check.ml +++ b/check/src/check.ml @@ -1,5 +1,6 @@ +module PP = Pretty_print + module Path = struct - type t = string (* Convert windows and unix style separator (resp. '\\' and '/') to the system's separator, remove any intermediate reference to @@ -31,189 +32,11 @@ module Path = struct end - -module Section : sig - (* The results are organized by section in the dead_code_analyzer's output. *) - type t = - | Constr_and_fields - | Methods - | Opt_always - | Opt_never - | Style - | Threshold of int * t - | Values - - val to_string : t -> string - - val compare : t -> t -> int - - (* The test suite files have extensions corresponding to the sections of - the expected results they contain. *) - val to_extension : t -> string - - (* The test suite files have extensions corresponding to the sections of - the expected results they contain. *) - val of_extension : string -> t option - - (* The sections are preceded by headers to help identify them. - Returns the corresponding section if the given string is header. - Returns None otherwise. *) - val of_header : string -> t option - - (* Folowing the header's title is a separator to indicate the start of the - report for that section *) - val is_start : string -> bool - - (* There is a footer at the end of each section to indicate the reporting for - that section is done *) - val is_end : string -> bool - -end = struct - - type t = - | Constr_and_fields - | Methods - | Opt_always - | Opt_never - | Style - | Threshold of int * t - | Values - - let rec to_string = function - | Constr_and_fields -> "Constr_and_fields" - | Methods -> "Methods" - | Opt_always -> "Opt_always" - | Opt_never -> "Opt_never" - | Style -> "Style" - | Values -> "Values" - | Threshold (n, t) -> - let sub_string = to_string t in - Printf.sprintf "Threshold(%d, %s)" n sub_string - - let compare = compare - - let rec to_extension = function - | Constr_and_fields -> ".mlit" - | Methods -> ".mlio" - | Opt_always -> ".mlopta" - | Opt_never -> ".mloptn" - | Style -> ".mlstyle" - | Values -> ".mli" - | Threshold (n, base) -> to_extension base ^ string_of_int n - - let rec of_extension = function - | ".mlit" -> Some Constr_and_fields - | ".mlio" -> Some Methods - | ".mlopta" -> Some Opt_always - | ".mloptn" -> Some Opt_never - | ".mlstyle" -> Some Style - | ".mli" -> Some Values - | ext -> - let try_threshold prefix = - if String.starts_with ~prefix ext then - let fmt = Scanf.format_from_string (prefix ^ "%d") "%d" in - try - let n = Scanf.sscanf ext fmt Fun.id in - of_extension prefix - |> Option.map (fun constr -> Threshold (n, constr)) - with Scanf.Scan_failure _ -> None - else None - in - let exts = [".mlit"; ".mlio"; ".mlopta"; ".mloptn"; ".mlstyle"; ".mli"] in - List.find_map try_threshold exts - - - let is_start s = - String.for_all (( = ) '=') s (* = is used for main sections *) - || String.for_all (( = ) '~') s (* ~ is used for subsections *) - - let is_end s = - s = "Nothing else to report in this section" (* main sections ending *) - || String.for_all (( = ) '-') s (* subsections ending *) - - let of_header = function - | ".> UNUSED CONSTRUCTORS/RECORD FIELDS:" -> Some Constr_and_fields - | ".> UNUSED METHODS:" -> Some Methods - | ".> OPTIONAL ARGUMENTS: ALWAYS:" -> Some Opt_always - | ".> OPTIONAL ARGUMENTS: NEVER:" -> Some Opt_never - | ".> CODING STYLE:" -> Some Style - | ".> UNUSED EXPORTED VALUES:" -> Some Values - | header -> - let get_threshold prefix constr = - if String.starts_with ~prefix header then - let fmt = Scanf.format_from_string (prefix ^ " %d time(s)") "%d" in - let n = Scanf.sscanf header fmt Fun.id in - Some (Threshold (n, constr)) - else None - in - let get_threshold_constr_and_fields () = - let prefix = ".>-> ALMOST UNUSED CONSTRUCTORS/RECORD FIELDS: Called" in - get_threshold prefix Constr_and_fields - in - let get_threshold_methods () = - let prefix = ".>-> ALMOST UNUSED METHODS: Called" in - get_threshold prefix Methods - in - let get_threshold_opt_always () = - let prefix = ".>-> OPTIONAL ARGUMENTS: ALMOST ALWAYS: Except" in - get_threshold prefix Opt_always - in - let get_threshold_opt_never () = - let prefix = ".>-> OPTIONAL ARGUMENTS: ALMOST NEVER: Except" in - get_threshold prefix Opt_never - in - let get_threshold_values () = - let prefix = ".>-> ALMOST UNUSED EXPORTED VALUES: Called" in - get_threshold prefix Values - in - let getters = [ - get_threshold_constr_and_fields; - get_threshold_methods; - get_threshold_opt_always; - get_threshold_opt_never; - get_threshold_values - ] - in - List.find_map (fun f -> f ()) getters - -end - - -module PP = struct - - let red = "\x1b[31m" - let green = "\x1b[32m" - let yellow = "\x1b[33m" - let blue = "\x1b[34m" - let white = "\x1b[37m" - let bg_red = "\x1b[41m" - let style_reset = "\x1b[0m" - - let error ~err ~ctx () = - Printf.eprintf "%s%s: %s%s%s%s\n%!" red ctx white bg_red err style_reset - -end - module StringSet = Set.Make(String) - module SectionMap = Map.Make(Section) -module State = struct - - type results = { - success : int; - fp : int; - fn : int - } - - let results_to_string results = - Printf.sprintf - "{success = %d; fp = %d; fn = %d}" - results.success results.fp results.fn - - let empty_results = {success = 0; fp = 0; fn = 0} - - type expected_reports = { +module Reports = struct + type t = { current_filepath : string option; (* file containg current expected reports *) remaining_content : string list; (* expected reports in filename not observed yet *) @@ -224,65 +47,20 @@ module State = struct sections *) } - let expected_reports_to_string expected_reports = - let current_filepath = - Option.value ~default:"None" expected_reports.current_filepath - in - let remaining_content = - if List.is_empty expected_reports.remaining_content - then "[]" - else "[..]" - in - let files_map = - Printf.sprintf "{ %s\n }" ( - SectionMap.bindings expected_reports.files_map - |> List.map (fun (sec, files) -> - Printf.sprintf "%s ->{%s}" - (Section.to_string sec) - (String.concat "; " @@ StringSet.to_list files) - ) - |> String.concat ";\n " - ) - (* - if SectionMap.is_empty expected_reports.files_map - then "{}" - else "{..}" - *) - in - Printf.sprintf - "{ current_filepath = %s;\n remaining_content = %s;\n root = %s;\n files_map =\n %s\n}" - current_filepath remaining_content expected_reports.root files_map - - let empty_expected_reports ={ + let empty ={ current_filepath = None; remaining_content = []; root = "."; files_map = SectionMap.empty } - type t = { - line : string; (* line observed in dca's report *) - filepath : string option; - section : Section.t option; (* current section *) - expected_reports : expected_reports; - results : results - } - - let empty = { - line = ""; - filepath = None; - section = None; - expected_reports = empty_expected_reports; - results = empty_results - } - (* Find all files in root that correspond to test files containing expected reports. This files are identified using their extension. See module Section above for more info. *) - let init_expected_reports root = + let init root = let rec on_directory files_map path = Sys.readdir path - |> Array.map (fun filename -> path ^ Filename.dir_sep ^ filename) + |> Array.map (fun filename -> Filename.concat path filename) |> Array.fold_left (fun init path -> Path.fold ~init ~on_directory ~on_file path) files_map and on_file files_map path = let ext = Filename.extension path in @@ -297,34 +75,76 @@ module State = struct in let init = SectionMap.empty in let files_map = Path.fold ~init ~on_directory ~on_file root in - {empty_expected_reports with files_map; root} + {empty with files_map; root} + + (* useful for debug *) + let[@warning "-32"] to_string ?(show_content=true) expected_reports = + if not show_content then + if SectionMap.is_empty expected_reports.files_map then "{}" + else "{..}" + else + let current_filepath = + Option.value ~default:"None" expected_reports.current_filepath + in + let remaining_content = + if List.is_empty expected_reports.remaining_content + then "[]" + else "[..]" + in + let files_map = + Printf.sprintf "{ %s\n }" ( + SectionMap.bindings expected_reports.files_map + |> List.map (fun (sec, files) -> + Printf.sprintf "%s ->{%s}" + (Section.to_string sec) + (String.concat "; " @@ StringSet.to_list files) + ) + |> String.concat ";\n " + ) + in + Printf.sprintf + "{ current_filepath = %s;\n remaining_content = %s;\n root = %s;\n files_map =\n %s\n}" + current_filepath remaining_content expected_reports.root files_map +end + +module State = struct + type t = { + filepath : string option; + section : Section.t option; (* current section *) + expected_reports : Reports.t; + scores : Scores.t + } + + let empty = { + filepath = None; + section = None; + expected_reports = Reports.empty; + scores = Scores.init + } let init exp_root = - let expected_reports = init_expected_reports exp_root in + let expected_reports = Reports.init exp_root in {empty with expected_reports} let incr_fn state = - let fn = state.results.fn + 1 in - let results = {state.results with fn} in - {state with results} + let scores = Scores.incr_fn state.scores in + {state with scores} let report_fn exp_line state = PP.error ~err:"Not detected" ~ctx:exp_line (); incr_fn state let incr_fp state = - let fp = state.results.fp + 1 in - let results = {state.results with fp} in - {state with results} + let scores = Scores.incr_fp state.scores in + {state with scores} let report_fp res_line state = PP.error ~err:"Should not be detected" ~ctx:res_line (); incr_fp state let incr_success state = - let success = state.results.success + 1 in - let results = {state.results with success} in - {state with results} + let scores = Scores.incr_success state.scores in + {state with scores} let report_success res_line state = print_endline res_line; @@ -350,7 +170,7 @@ module State = struct in let files_map = Option.value files_map ~default:er.files_map in let expected_reports = - {empty_expected_reports with files_map; root = er.root} + {Reports.empty with files_map; root = er.root} in {state with expected_reports} in @@ -378,7 +198,7 @@ module State = struct let exp_filepath = if internal then exp_filepath else - state.expected_reports.root ^ Filename.dir_sep ^ exp_filepath + Filename.concat state.expected_reports.root exp_filepath |> Path.normalize in match SectionMap.find_opt sec state.expected_reports.files_map with @@ -447,20 +267,6 @@ module State = struct {state with section} - let print_results {results; _} = - let total = results.success + results.fp + results.fn in - let errors = results.fp + results.fn in - Printf.printf "Total: %s%d%s\n" PP.blue total PP.style_reset; - Printf.printf "Success: %s%d%s\n" PP.green results.success PP.style_reset; - Printf.printf "Failed: %s%d%s\n" PP.red errors PP.style_reset; - let ratio = 100. *. float_of_int results.success /. float_of_int total in - let color = - if ratio < 50. then PP.red - else if ratio < 80. then PP.yellow - else PP.green - in - Printf.printf "Ratio: %s%F%%%s\n%!" color ratio PP.style_reset - end (* Format of report lines is : "file_path:line_number: report_info" @@ -575,10 +381,5 @@ let () = let res_file = get_res_filename () in let input_lines = In_channel.with_open_text res_file In_channel.input_lines in let init_state = State.init (get_expected_reports_root ()) in - let state = - List.fold_left - process - init_state - input_lines - in - State.print_results state + let state = List.fold_left process init_state input_lines in + Scores.pp state.scores diff --git a/check/src/check.mli b/check/src/check.mli new file mode 100644 index 00000000..e69de29b diff --git a/check/src/pretty_print.ml b/check/src/pretty_print.ml new file mode 100644 index 00000000..f4ada73b --- /dev/null +++ b/check/src/pretty_print.ml @@ -0,0 +1,10 @@ +let red = "\x1b[31m" +let green = "\x1b[32m" +let yellow = "\x1b[33m" +let blue = "\x1b[34m" +let white = "\x1b[37m" +let bg_red = "\x1b[41m" +let style_reset = "\x1b[0m" + +let error ~err ~ctx () = + Printf.eprintf "%s%s: %s%s%s%s\n%!" red ctx white bg_red err style_reset diff --git a/check/src/pretty_print.mli b/check/src/pretty_print.mli new file mode 100644 index 00000000..55d7df17 --- /dev/null +++ b/check/src/pretty_print.mli @@ -0,0 +1,10 @@ +val blue : string +val green : string +val red : string +val white :string +val yellow : string + +val bg_red : string +val style_reset : string + +val error : err:string -> ctx:string -> unit -> unit diff --git a/check/src/scores.ml b/check/src/scores.ml new file mode 100644 index 00000000..599c73c1 --- /dev/null +++ b/check/src/scores.ml @@ -0,0 +1,35 @@ +type t = { + success : int; + fp : int; + fn : int +} + +let total t = t.success + t.fp + t.fn +let expected t = t.success + t.fn +let failed t = t.fp + t.fn + +(* Useful for debug *) +let to_string t = + Printf.sprintf + "{success = %d; fp = %d; fn = %d}" + t.success t.fp t.fn + +let pp t = + let module PP = Pretty_print in + let total = total t in + Printf.printf "Total: %s%d%s\n" PP.blue total PP.style_reset; + Printf.printf "Success: %s%d%s\n" PP.green t.success PP.style_reset; + Printf.printf "Failed: %s%d%s\n" PP.red (failed t) PP.style_reset; + let ratio = 100. *. float_of_int t.success /. float_of_int total in + let color = + if ratio < 50. then PP.red + else if ratio < 80. then PP.yellow + else PP.green + in + Printf.printf "Ratio: %s%F%%%s\n%!" color ratio PP.style_reset + +let init = {success = 0; fp = 0; fn = 0} + +let incr_fp t = {t with fp = t.fp + 1} +let incr_fn t = {t with fn = t.fn + 1} +let incr_success t = {t with success = t.success + 1} diff --git a/check/src/scores.mli b/check/src/scores.mli new file mode 100644 index 00000000..477a1b36 --- /dev/null +++ b/check/src/scores.mli @@ -0,0 +1,11 @@ +type t + +val to_string : t -> string + +val pp : t -> unit + +val init : t + +val incr_fp : t -> t +val incr_fn : t -> t +val incr_success : t -> t diff --git a/check/src/section.ml b/check/src/section.ml new file mode 100644 index 00000000..e7637522 --- /dev/null +++ b/check/src/section.ml @@ -0,0 +1,105 @@ +type t = + | Constr_and_fields + | Methods + | Opt_always + | Opt_never + | Style + | Threshold of int * t + | Values + +let rec to_string = function + | Constr_and_fields -> "Constr_and_fields" + | Methods -> "Methods" + | Opt_always -> "Opt_always" + | Opt_never -> "Opt_never" + | Style -> "Style" + | Values -> "Values" + | Threshold (n, t) -> + let sub_string = to_string t in + Printf.sprintf "Threshold(%d, %s)" n sub_string + +let compare = compare + +let rec to_extension = function + | Constr_and_fields -> ".mlit" + | Methods -> ".mlio" + | Opt_always -> ".mlopta" + | Opt_never -> ".mloptn" + | Style -> ".mlstyle" + | Values -> ".mli" + | Threshold (n, base) -> to_extension base ^ string_of_int n + +let rec of_extension = function + | ".mlit" -> Some Constr_and_fields + | ".mlio" -> Some Methods + | ".mlopta" -> Some Opt_always + | ".mloptn" -> Some Opt_never + | ".mlstyle" -> Some Style + | ".mli" -> Some Values + | ext -> + let try_threshold prefix = + if String.starts_with ~prefix ext then + let fmt = Scanf.format_from_string (prefix ^ "%d") "%d" in + try + let n = Scanf.sscanf ext fmt Fun.id in + of_extension prefix + |> Option.map (fun constr -> Threshold (n, constr)) + with Scanf.Scan_failure _ -> None + else None + in + let exts = [".mlit"; ".mlio"; ".mlopta"; ".mloptn"; ".mlstyle"; ".mli"] in + List.find_map try_threshold exts + + +let is_start s = + String.for_all (( = ) '=') s (* = is used for main sections *) + || String.for_all (( = ) '~') s (* ~ is used for subsections *) + +let is_end s = + s = "Nothing else to report in this section" (* main sections ending *) + || String.for_all (( = ) '-') s (* subsections ending *) + +let of_header = function + | ".> UNUSED CONSTRUCTORS/RECORD FIELDS:" -> Some Constr_and_fields + | ".> UNUSED METHODS:" -> Some Methods + | ".> OPTIONAL ARGUMENTS: ALWAYS:" -> Some Opt_always + | ".> OPTIONAL ARGUMENTS: NEVER:" -> Some Opt_never + | ".> CODING STYLE:" -> Some Style + | ".> UNUSED EXPORTED VALUES:" -> Some Values + | header -> + let get_threshold prefix constr = + if String.starts_with ~prefix header then + let fmt = Scanf.format_from_string (prefix ^ " %d time(s)") "%d" in + let n = Scanf.sscanf header fmt Fun.id in + Some (Threshold (n, constr)) + else None + in + let get_threshold_constr_and_fields () = + let prefix = ".>-> ALMOST UNUSED CONSTRUCTORS/RECORD FIELDS: Called" in + get_threshold prefix Constr_and_fields + in + let get_threshold_methods () = + let prefix = ".>-> ALMOST UNUSED METHODS: Called" in + get_threshold prefix Methods + in + let get_threshold_opt_always () = + let prefix = ".>-> OPTIONAL ARGUMENTS: ALMOST ALWAYS: Except" in + get_threshold prefix Opt_always + in + let get_threshold_opt_never () = + let prefix = ".>-> OPTIONAL ARGUMENTS: ALMOST NEVER: Except" in + get_threshold prefix Opt_never + in + let get_threshold_values () = + let prefix = ".>-> ALMOST UNUSED EXPORTED VALUES: Called" in + get_threshold prefix Values + in + let getters = [ + get_threshold_constr_and_fields; + get_threshold_methods; + get_threshold_opt_always; + get_threshold_opt_never; + get_threshold_values + ] + in + List.find_map (fun f -> f ()) getters diff --git a/check/src/section.mli b/check/src/section.mli new file mode 100644 index 00000000..4fd294f8 --- /dev/null +++ b/check/src/section.mli @@ -0,0 +1,34 @@ +(* The results are organized by section in the dead_code_analyzer's output. *) +type t = + | Constr_and_fields + | Methods + | Opt_always + | Opt_never + | Style + | Threshold of int * t + | Values + +val to_string : t -> string + +val compare : t -> t -> int + +(* The test suite files have extensions corresponding to the sections of + the expected results they contain. *) +val to_extension : t -> string + +(* The test suite files have extensions corresponding to the sections of + the expected results they contain. *) +val of_extension : string -> t option + +(* The sections are preceded by headers to help identify them. + Returns the corresponding section if the given string is header. + Returns None otherwise. *) +val of_header : string -> t option + +(* Folowing the header's title is a separator to indicate the start of the + report for that section *) +val is_start : string -> bool + +(* There is a footer at the end of each section to indicate the reporting for + that section is done *) +val is_end : string -> bool From 644202f9727d4cfd0abd522de08eed2f0e801a7f Mon Sep 17 00:00:00 2001 From: Corentin De Souza <9597216+fantazio@users.noreply.github.com> Date: Sat, 6 Sep 2025 00:44:40 +0200 Subject: [PATCH 7/8] [check] aggregate shares code with check --- check/src/Makefile | 2 +- check/src/aggregate.ml | 170 ++++++++++++++++++++++--------------- check/src/check.ml | 2 +- check/src/pretty_print.ml | 1 + check/src/pretty_print.mli | 2 + check/src/scores.ml | 43 ++++++++-- check/src/scores.mli | 11 +++ 7 files changed, 151 insertions(+), 80 deletions(-) diff --git a/check/src/Makefile b/check/src/Makefile index ecd5fb66..7e68364a 100644 --- a/check/src/Makefile +++ b/check/src/Makefile @@ -4,7 +4,7 @@ OCAMLOPT=ocamlopt $(COMPFLAGS) API_SRC=pretty_print.ml section.ml scores.ml CHECK_SRC=$(API_SRC:.ml=.mli) $(API_SRC) check.mli check.ml -AGGR_SRC=aggregate.mli aggregate.ml +AGGR_SRC=$(API_SRC:.ml=.mli) $(API_SRC) aggregate.mli aggregate.ml check.byt$(EXE): $(CHECK_SRC) $(OCAMLC) -o $@ $^ diff --git a/check/src/aggregate.ml b/check/src/aggregate.ml index 52444add..2e31a0c3 100644 --- a/check/src/aggregate.ml +++ b/check/src/aggregate.ml @@ -1,97 +1,127 @@ -let total = ref 0 -let err = ref 0 -let unified_res = Hashtbl.create 256 -let sec_res = Hashtbl.create 256 +module PP = Pretty_print +module StringSet = Set.Make(String) let print_title title = - print_string "\x1b[1;37m"; - print_endline title; - print_endline (String.make (String.length title) '~'); - print_endline "\x1b[0m" - -let update ~total_fmt ~failed_fmt line = - let unique_line = - let rec make_unique_to_sec n = + let underline = String.make (String.length title) '~' in + Printf.printf "%s%s\n%s%s\n" PP.bold title underline PP.style_reset + +let print_title_box title = + let title_len = String.length title in + let underline = String.make title_len '~' in + let filler = String.make (title_len - 2) ' ' in + (* print_title_box *) + Printf.printf "%s%s\n|%s|\n%s\n|%s|\n%s%s\n" + PP.bold underline filler title filler underline PP.style_reset + +let print_res title scores = + print_title_box title; + Scores.pp scores + +module State = struct + type t = { + scores : Scores.t; + unique_success_lines : StringSet.t; + unique_failure_lines : StringSet.t + } + + let init = { + scores = Scores.init; + unique_success_lines = StringSet.empty; + unique_failure_lines = StringSet.empty + } + + let set_scores total failed state = + let scores = + Scores.set_failures failed state.scores + |> Scores.set_success (total - failed) + in + {state with scores} + + let join state1 state2 = + let unique_success_lines = + StringSet.union state1.unique_success_lines state2.unique_success_lines + in + let unique_failure_lines = + StringSet.union state1.unique_failure_lines state2.unique_failure_lines + in + let total = Scores.total state1.scores + Scores.total state2.scores in + let failed = Scores.failed state1.scores + Scores.failed state2.scores in + set_scores total failed + {init with unique_success_lines; unique_failure_lines} + +end + +let update state line = + let add_unique_line set = + let rec make_unique_to_set n = let new_line = line ^ string_of_int n in - if Hashtbl.mem sec_res new_line then make_unique_to_sec (n + 1) + if StringSet.mem new_line set then make_unique_to_set (n + 1) else new_line in - let res = make_unique_to_sec 0 in - Hashtbl.add sec_res res (); - res + let line = make_unique_to_set 0 in + StringSet.add line set in - if not (Hashtbl.mem unified_res unique_line) then ( + let state = + let end_of_fp = "Should not be detected" ^ PP.style_reset in + let end_of_fn = "Not detected" ^ PP.style_reset in if String.starts_with ~prefix:"./examples" line then - Hashtbl.add unified_res unique_line true + let unique_success_lines = + add_unique_line state.State.unique_success_lines + in + {state with unique_success_lines} else if - String.ends_with ~suffix:"Should not be detected\x1b[0m" line - || String.ends_with ~suffix:"Not detected\x1b[0m" line + String.ends_with ~suffix:end_of_fp line + || String.ends_with ~suffix:end_of_fn line then - Hashtbl.add unified_res unique_line false - ); - let update_count fmt value = - try - let fmt = Scanf.format_from_string fmt "%d%d%s" in - let tot = Scanf.sscanf line fmt (fun _ x _ -> x) in - print_endline line; - value := tot + !value - with _ -> () + let unique_failure_lines = + add_unique_line state.State.unique_failure_lines + in + {state with unique_failure_lines} + else state + in + let get ~default extract_from = + Option.value ~default (extract_from line) + in + let total = + get ~default:(Scores.total state.scores) Scores.extract_total + in + let failed = + get ~default:(Scores.failed state.scores) Scores.extract_failed in - update_count total_fmt total; - update_count failed_fmt err + State.set_scores total failed state -let process filepath = +let process state filepath = let input_lines = In_channel.with_open_text filepath In_channel.input_lines in print_title (Filename.remove_extension filepath); - - let total_fmt = "Total: \x1b[%dm%d%s" in - let failed_fmt = "Failed: \x1b[%dm%d%s" in - List.iter (update ~total_fmt ~failed_fmt) input_lines; - Hashtbl.clear sec_res; - print_endline "\n" - -let print_res title total err = - print_title title; - print_string "Total: \x1b[0;34m"; - print_int total; - print_string "\x1b[0m\nFailed: \x1b[0;31m"; - print_int err; - let ratio = ( -. ) 100. @@ ( *. ) 100. @@ (float_of_int total |> ( /. ) @@ float_of_int err) in - print_string @@ "\x1b[0m\nRatio: \x1b[0;3" - ^ (if ratio < 50. then "1m" else if ratio < 80. then "3m" else "2m"); - print_float ratio; - print_endline "%\x1b[0m" + let local_state = List.fold_left update State.init input_lines in + Scores.pp local_state.scores; + Printf.printf "\n"; + State.join local_state state let () = let filepaths = let argv_len = Array.length Sys.argv in Array.sub Sys.argv 1 (argv_len - 1) in - Array.iter process filepaths; - print_endline "...............................................\n\n\x1b[1;37m"; - - print_endline "~~~~~~~~~~~~~~~~~~~~~~"; - print_endline "| |"; - print_endline "+- Summed Results -+"; - print_res "| |" !total !err; - - let total, err = Hashtbl.fold - (fun _ valid (total, err) -> - if valid then (total + 1, err) - else (total + 1, err + 1)) - unified_res - (0, 0) + let state = Array.fold_left process State.init filepaths in + + Printf.printf "%s\n\n" (String.make 16 '.'); + + print_res "+- Summed Results -+" state.scores; + + let unified_failed = StringSet.cardinal state.unique_failure_lines in + let unified_success = StringSet.cardinal state.unique_success_lines in + let unified_scores = + Scores.set_success unified_success Scores.init + |> Scores.set_failures unified_failed in - print_endline "\n\n\x1b[1;37m"; + Printf.printf "\n"; - print_endline "~~~~~~~~~~~~~~~~~~~~~~~"; - print_endline "| |"; - print_endline "[> Unified Results <]"; - print_res "| |" total err; + print_res "[> Unified Results <]" unified_scores; - if err > 0 then + if unified_failed > 0 then exit 1 diff --git a/check/src/check.ml b/check/src/check.ml index 8048fa8a..a6c863af 100644 --- a/check/src/check.ml +++ b/check/src/check.ml @@ -18,7 +18,7 @@ module Path = struct (* Paths read in res.out points to files in /examples/ relatively from /check : '../examples/' We want to relocate them as relative to the - directory whjich contains its own examples subdirectory with report files + directory whhich contains its own examples subdirectory with report files organized similarly to /examples. : './examples/'. Therefore, removing the first '.' does the trick *) diff --git a/check/src/pretty_print.ml b/check/src/pretty_print.ml index f4ada73b..b5c79357 100644 --- a/check/src/pretty_print.ml +++ b/check/src/pretty_print.ml @@ -5,6 +5,7 @@ let blue = "\x1b[34m" let white = "\x1b[37m" let bg_red = "\x1b[41m" let style_reset = "\x1b[0m" +let bold = "\x1b[01m" let error ~err ~ctx () = Printf.eprintf "%s%s: %s%s%s%s\n%!" red ctx white bg_red err style_reset diff --git a/check/src/pretty_print.mli b/check/src/pretty_print.mli index 55d7df17..126af0fc 100644 --- a/check/src/pretty_print.mli +++ b/check/src/pretty_print.mli @@ -5,6 +5,8 @@ val white :string val yellow : string val bg_red : string + +val bold : string val style_reset : string val error : err:string -> ctx:string -> unit -> unit diff --git a/check/src/scores.ml b/check/src/scores.ml index 599c73c1..1ce057b3 100644 --- a/check/src/scores.ml +++ b/check/src/scores.ml @@ -1,12 +1,13 @@ type t = { success : int; fp : int; - fn : int + fn : int; + other_failures : int } -let total t = t.success + t.fp + t.fn +let total t = t.success + t.fp + t.fn + t.other_failures let expected t = t.success + t.fn -let failed t = t.fp + t.fn +let failed t = t.fp + t.fn + t.other_failures (* Useful for debug *) let to_string t = @@ -14,12 +15,35 @@ let to_string t = "{success = %d; fp = %d; fn = %d}" t.success t.fp t.fn +module PP = Pretty_print + +let make_fmt title color = + let line = + Printf.sprintf "%s: %s%%d%s" title color PP.style_reset + in + Scanf.format_from_string line "%d" + +let total_fmt () = make_fmt "Total" PP.blue +let success_fmt () = make_fmt "Success" PP.green +let failed_fmt () = make_fmt "Failed" PP.red + +let extract_from fmt s = + try Scanf.sscanf s fmt Option.some + with _ -> None + +let extract_total = extract_from (total_fmt ()) +let extract_success = extract_from (success_fmt ()) +let extract_failed = extract_from (failed_fmt ()) + let pp t = - let module PP = Pretty_print in let total = total t in - Printf.printf "Total: %s%d%s\n" PP.blue total PP.style_reset; - Printf.printf "Success: %s%d%s\n" PP.green t.success PP.style_reset; - Printf.printf "Failed: %s%d%s\n" PP.red (failed t) PP.style_reset; + let print_line fmt value = + Printf.printf (fmt ()) value; + Printf.printf "\n" + in + print_line total_fmt total; + print_line success_fmt t.success; + print_line failed_fmt (failed t); let ratio = 100. *. float_of_int t.success /. float_of_int total in let color = if ratio < 50. then PP.red @@ -28,8 +52,11 @@ let pp t = in Printf.printf "Ratio: %s%F%%%s\n%!" color ratio PP.style_reset -let init = {success = 0; fp = 0; fn = 0} +let init = {success = 0; fp = 0; fn = 0; other_failures = 0} let incr_fp t = {t with fp = t.fp + 1} let incr_fn t = {t with fn = t.fn + 1} let incr_success t = {t with success = t.success + 1} + +let set_success success t = {t with success} +let set_failures other_failures t = {t with other_failures} diff --git a/check/src/scores.mli b/check/src/scores.mli index 477a1b36..f24d49b5 100644 --- a/check/src/scores.mli +++ b/check/src/scores.mli @@ -4,8 +4,19 @@ val to_string : t -> string val pp : t -> unit +val total : t -> int +val expected : t -> int +val failed : t -> int + +val extract_total : string -> int option +val extract_success : string -> int option +val extract_failed : string -> int option + val init : t val incr_fp : t -> t val incr_fn : t -> t val incr_success : t -> t + +val set_success : int -> t -> t +val set_failures : int -> t -> t From 8bf03cdcc8f4a9e441a5d04ad6351b903de42bfa Mon Sep 17 00:00:00 2001 From: Corentin De Souza <9597216+fantazio@users.noreply.github.com> Date: Sun, 31 Aug 2025 14:19:01 +0200 Subject: [PATCH 8/8] [windows] fix compatibility + Improve check.ml to normalize expected paths as soon as they are extracted from the report files. + Fix aggregate.ml to avoid explicit usage of '/' when manipulating paths + deadCommon.ml uses Filename.dir_sep instead of '/' when manipulating paths --- check/src/Makefile | 2 +- check/src/aggregate.ml | 2 +- check/src/check.ml | 173 +++++++++++++++++++++-------------------- src/deadCommon.ml | 10 ++- src/deadObj.ml | 2 +- 5 files changed, 99 insertions(+), 90 deletions(-) diff --git a/check/src/Makefile b/check/src/Makefile index 7e68364a..91986b4b 100644 --- a/check/src/Makefile +++ b/check/src/Makefile @@ -1,4 +1,4 @@ -COMPFLAGS=-w +A-4-9-40-42 -bin-annot -keep-locs +COMPFLAGS=-g -w +A-4-9-40-42 -bin-annot -keep-locs OCAMLC=ocamlc $(COMPFLAGS) OCAMLOPT=ocamlopt $(COMPFLAGS) diff --git a/check/src/aggregate.ml b/check/src/aggregate.ml index 2e31a0c3..055f6063 100644 --- a/check/src/aggregate.ml +++ b/check/src/aggregate.ml @@ -64,7 +64,7 @@ let update state line = let state = let end_of_fp = "Should not be detected" ^ PP.style_reset in let end_of_fn = "Not detected" ^ PP.style_reset in - if String.starts_with ~prefix:"./examples" line then + if String.starts_with ~prefix:(Filename.concat "." "examples") line then let unique_success_lines = add_unique_line state.State.unique_success_lines in diff --git a/check/src/check.ml b/check/src/check.ml index a6c863af..77e3eded 100644 --- a/check/src/check.ml +++ b/check/src/check.ml @@ -36,10 +36,54 @@ module StringSet = Set.Make(String) module SectionMap = Map.Make(Section) module Reports = struct + + type report_info = { + filepath: string; + line_nb : int; + value : string; + } + + let line_of_report_info ri = + Printf.sprintf "%s:%d:%s" ri.filepath ri.line_nb ri.value + + (* Format of report lines is : "file_path:line_number: value" + with value possibly containing ':'. In case the line comes from + the direct report of dca (is_res_line), the filepath will be relocated + to correspond to filepaths coming from expected reports *) + let report_info_of_line ~is_res_line line = + let report_line_format = "filepath:line_nb:value" in + match String.split_on_char ':' line with + | [] | _::[] | _::_::[] -> + let err = + Printf.sprintf + "Unrecognized report line format. Expected : '%s'" + report_line_format + in + PP.error ~err ~ctx:line (); + None + | filepath::line_number::value -> + try + let line_nb = int_of_string line_number in + let filepath = (* relocate to match expected paths *) + if is_res_line then Path.relocate filepath + else filepath + in + let filepath = Path.normalize filepath in + let value = String.concat ":" value in + Some {filepath; line_nb; value} + with Failure _int_of_string -> + let err = + Printf.sprintf + "Is not an int. Expected report line format is : '%s'" + report_line_format + in + PP.error ~err ~ctx:line_number (); + None + type t = { current_filepath : string option; (* file containg current expected reports *) - remaining_content : string list; (* expected reports in filename not - observed yet *) + remaining_content : report_info list; (* expected reports in filename not + observed yet *) root : string; (* directory containing the expected reports files*) files_map : StringSet.t SectionMap.t (* remaining files containing expected reports. Once a file is consumed it @@ -130,28 +174,30 @@ module State = struct let scores = Scores.incr_fn state.scores in {state with scores} - let report_fn exp_line state = - PP.error ~err:"Not detected" ~ctx:exp_line (); + let report_fn ri state = + let ctx = Reports.line_of_report_info ri in + PP.error ~err:"Not detected" ~ctx (); incr_fn state let incr_fp state = let scores = Scores.incr_fp state.scores in {state with scores} - let report_fp res_line state = - PP.error ~err:"Should not be detected" ~ctx:res_line (); + let report_fp ri state = + let ctx = Reports.line_of_report_info ri in + PP.error ~err:"Should not be detected" ~ctx (); incr_fp state let incr_success state = let scores = Scores.incr_success state.scores in {state with scores} - let report_success res_line state = - print_endline res_line; + let report_success ri state = + let line = Reports.line_of_report_info ri in + print_endline line; incr_success state let update_remaining_content state remaining_content = - let remaining_content = List.filter (( <> ) "") remaining_content in let expected_reports = {state.expected_reports with remaining_content} in {state with expected_reports} @@ -206,6 +252,8 @@ module State = struct let current_filepath = Some exp_filepath in let state = In_channel.with_open_text exp_filepath In_channel.input_lines + |> List.filter (( <> ) "") + |> List.filter_map (Reports.report_info_of_line ~is_res_line:false) |> update_remaining_content state in let expected_reports = @@ -269,82 +317,39 @@ module State = struct end -(* Format of report lines is : "file_path:line_number: report_info" - with report_info possibly containing ':'. In case the line comes from - the direct report of dca (is_res_line), the filepath will be relocated - to correspond to filepaths coming from expected reports *) -let infos_of_report_line ~is_res_line line = - let report_line_format = "filepath:line_nb:report_info" in - match String.split_on_char ':' line with - | [] | _::[] | _::_::[] -> - let err = - Printf.sprintf - "Unrecognized report line format. Expected : '%s'" - report_line_format - in - PP.error ~err ~ctx:line (); - None - | filepath::line_number::report_info -> - try - let line_nb = int_of_string line_number in - let filepath = (* relocate to match expected paths *) - if is_res_line then Path.relocate filepath - else filepath - in - let filepath = Path.normalize filepath in - let report_info = String.concat ":" report_info in - let line = (* recontruct the line with updated fields *) - if is_res_line then - String.concat ":" [filepath; line_number; report_info] - else line - in - Some (filepath, line_nb, report_info, line) - with Failure _int_of_string -> - let err = - Printf.sprintf - "Is not an int. Expected report line format is : '%s'" - report_line_format - in - PP.error ~err ~ctx:line_number (); - None -let rec process_report_line state (filepath, line_number, report_info, res_line) = - let state = State.maybe_change_file filepath state in +let rec process_report_line state (got : Reports.report_info) = + let state = State.maybe_change_file got.filepath state in match state.expected_reports.remaining_content with - | [] -> State.report_fp res_line state - | exp_line::remaining_content when exp_line = res_line -> + | [] -> State.report_fp got state + | expected::remaining_content when expected = got -> State.update_remaining_content state remaining_content - |> State.report_success res_line - | exp_line::remaining_content -> - match infos_of_report_line ~is_res_line:false exp_line with - | None -> - (* exp_line reported in infos_of_report_line as misformatted *) - state - | Some (exp_filepath, exp_line_number, _, exp_line) -> - let compare = - let paths_compare = String.compare exp_filepath filepath in - if paths_compare = 0 then exp_line_number - line_number - else paths_compare + |> State.report_success expected + | expected::remaining_content -> + let compare = + let paths_compare = String.compare expected.filepath got.filepath in + if paths_compare = 0 then expected.line_nb - got.line_nb + else paths_compare + in + if compare > 0 then State.report_fp got state + else if compare < 0 then + let state = + State.update_remaining_content state remaining_content + |> State.report_fn expected in - if compare > 0 then State.report_fp res_line state - else if compare < 0 then - let state = - State.update_remaining_content state remaining_content - |> State.report_fn exp_line - in - process_report_line state (filepath, line_number, report_info, res_line) - else - (* The location is fine but report_info does not match. - The reports are not organized according to the report_info but - only the locations (including the column which is not reported. - Check if the current line exists in the remaining_content. - If so, then it is a successful report which can be removed from - the remaining content. Otherwise, it is a fp. *) - if List.mem res_line remaining_content then - List.filter (( <> ) res_line) remaining_content - |> State.update_remaining_content state - |> State.report_success res_line - else State.report_fp res_line state + process_report_line state got + else + (* The location is fine but report_info does not match. + The reports are not organized according to the report_info but + only the locations (including the column which is not reported. + Check if the current line exists in the remaining_content. + If so, then it is a successful report which can be removed from + the remaining content. Otherwise, it is a fp. *) + if List.mem got remaining_content then + List.filter (( <> ) got) remaining_content + |> State.update_remaining_content state + |> State.report_success got + else State.report_fp got state let process state res_line = let is_report_line, state = @@ -359,12 +364,12 @@ let process state res_line = | Some _ as sec -> false, State.change_section sec state | None -> (* res_line is a report line *) - match infos_of_report_line ~is_res_line:true res_line with + match Reports.report_info_of_line ~is_res_line:true res_line with | None -> (* res_line reported in infos_of_report_line as misformatted *) false, state - | Some infos -> - true, process_report_line state infos + | Some got -> + true, process_report_line state got in if not is_report_line then print_endline res_line; state diff --git a/src/deadCommon.ml b/src/deadCommon.ml index 7d9b3fb2..0cbd314d 100644 --- a/src/deadCommon.ml +++ b/src/deadCommon.ml @@ -104,17 +104,21 @@ let hashtbl_replace_list hashtbl key l = let hashtbl_merge_unique_list tbl1 key1 tbl2 key2 = List.iter (fun elt -> hashtbl_add_unique_to_list tbl1 key1 elt) (hashtbl_find_list tbl2 key2) -let is_sub_path ?(sep = '/') sub_path path = + +let is_sub_path ~sep sub_path path = let len_sub = String.length sub_path in let len_path = String.length path in let diff_len = len_path - len_sub in + let len_sep = String.length sep in let compatible_length = (* sub_path is smaller than path and would start right after a separator*) - diff_len = 0 || diff_len > 0 && path.[diff_len - 1] = sep + diff_len >= len_sep && String.sub path (diff_len - len_sep) len_sep = sep + || diff_len = 0 in compatible_length && String.sub path diff_len len_sub = sub_path -let find_path fn ?(sep = '/') l = +let find_path fn l = + let sep = Filename.dir_sep in List.find (is_sub_path ~sep fn) l let find_abspath fn = diff --git a/src/deadObj.ml b/src/deadObj.ml index 832bdbf6..02720009 100644 --- a/src/deadObj.ml +++ b/src/deadObj.ml @@ -75,7 +75,7 @@ let get_loc path = let path = let exported_path = Hashtbl.to_seq_values incl - |> Seq.find (fun (_, exported_path) -> is_sub_path ~sep:'.' path exported_path) + |> Seq.find (fun (_, exported_path) -> is_sub_path ~sep:"." path exported_path) in match exported_path with | Some (_, exported_path) -> exported_path