From f7f76e26aed115eb3aa8d269b3d21e033fd3c7be Mon Sep 17 00:00:00 2001 From: vbot Date: Tue, 6 Aug 2024 18:08:21 +0200 Subject: [PATCH] Improve error reporting and remove language --- build_system/clerk_config.ml | 101 ++++++++++++++++++++++------------ build_system/clerk_config.mli | 1 - build_system/clerk_driver.ml | 3 + 3 files changed, 68 insertions(+), 37 deletions(-) diff --git a/build_system/clerk_config.ml b/build_system/clerk_config.ml index 4dd200fa..00e6868b 100644 --- a/build_system/clerk_config.ml +++ b/build_system/clerk_config.ml @@ -18,7 +18,6 @@ open Catala_utils open Otoml type modul = { - language : Global.backend_lang; module_uses : (string * string option) list; includes : string list; } @@ -38,9 +37,9 @@ let default = modules = String.Map.empty; } -let parse_module_uses modul = +let parse_module_uses ~fname ~name modul = match find_opt modul (get_array get_value) ["module_uses"] with - | None -> [] + | None | (exception _) -> [] (* [opt] is a lie. *) | Some module_uses -> List.map (function @@ -50,57 +49,87 @@ let parse_module_uses modul = module_name, Some module_alias | _ -> Message.error - "Invalid module use: expected a module name as string or an array \ - of two strings (module name and its alias)") + "While parsing %a: in module @{%s@}, invalid value for \ + @{module_uses@}. Expected a module name as string or an \ + array of two strings (module name and its alias)." + File.format fname name) module_uses -let parse_name_and_language modul = - let name = Helpers.find_string_exn modul ["name"] in - let lang = - let lang_opt = - Helpers.find_string_opt modul ["language"] - |> Option.map String.uncapitalize_ascii +let check_module_sanity ~fname modul = + match modul with + | TomlTable kvs -> + let format_module_name ppf = + match Helpers.find_string_opt modul ["name"] with + | None | (exception _) -> () (* [opt] is a lie. *) + | Some name -> Format.fprintf ppf "in module @{%s@}, " name in - match lang_opt with - | None -> Message.error "Missing " "language" " field in configuration" - | Some lang -> lang - in - match List.assoc_opt lang Cli.languages with - | None -> - Message.error - "Unexpected language '%s' for module @{%s@}, valid entries are: \ - @[%a@]" - lang name - Format.( - pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ",@ ") pp_print_string) - (List.map fst Cli.languages) - | Some x -> name, x + List.iter + (function + | "name", TomlString _ -> () + | "name", _ -> + Message.delayed_error () + "While parsing %a: invalid value for key @{name@}.@\n\ + Expected a direct string." File.format fname + | "module_uses", TomlArray _ -> (* checked in [parse_module_uses] *) () + | "module_uses", _ -> + Message.delayed_error () + "While parsing %a: %tinvalid value for key @{module_uses@}.@\n\ + It must be an array." File.format fname format_module_name + | "includes", TomlArray srcs -> + let only_strings = + List.for_all (function TomlString _ -> true | _ -> false) srcs + in + if not only_strings then + Message.delayed_error () + "While parsing %a: %tinvalid value for key @{includes@}.@\n\ + It must only contain direct strings." File.format fname + format_module_name + | "includes", _ -> + Message.delayed_error () + "While parsing %a: %tinvalid content for key @{includes@}.@\n\ + Expected an array of strings." File.format fname format_module_name + | k, _ -> + Message.delayed_error () + "While parsing %a: %tunexpected key @{%S@}.@\n\ + Allowed keys are: 'name', 'module_uses' and 'includes'." + File.format fname format_module_name k) + kvs + | _ -> + Message.delayed_error () + "While parsing %a: invalid module definition, expected a table." + File.format fname -let find_and_parse_modules_exn toml = +let find_and_parse_modules_exn ~fname toml = let modules = find toml (get_array get_value) ["module"] in let parse_module modul = - let name, language = parse_name_and_language modul in - let module_uses = parse_module_uses modul in + let () = check_module_sanity ~fname modul in + let name = Helpers.find_string_exn modul ["name"] in + let module_uses = parse_module_uses ~fname ~name modul in let includes = - Helpers.find_strings_opt modul ["includes"] |> Option.value ~default:[] + try + Helpers.find_strings_opt modul ["includes"] |> Option.value ~default:[] + with _ -> + (* opt is a lie, the error will be triggered later on by the sanity + check. *) + [] in - name, { language; module_uses; includes } + name, { module_uses; includes } in - List.map parse_module modules |> String.Map.of_list + Message.with_delayed_errors + @@ fun () -> List.map parse_module modules |> String.Map.of_list -let toml_to_config toml = +let toml_to_config ~fname toml = { catala_opts = Helpers.find_strings_exn toml ["build"; "catala_opts"]; build_dir = Helpers.find_string_exn toml ["build"; "build_dir"]; include_dirs = Helpers.find_strings_exn toml ["project"; "include_dirs"]; - modules = find_and_parse_modules_exn toml; + modules = find_and_parse_modules_exn ~fname toml; } -let module_to_toml name { language; module_uses; includes } = +let module_to_toml name { module_uses; includes } = table [ "name", string name; - "language", string (Cli.language_code language); ( "module_uses", array (List.map @@ -190,7 +219,7 @@ let read f = ~pos:(Pos.from_info f li col li (col + 1)) "Error in Clerk configuration:@ %a" Format.pp_print_text msg in - toml_to_config (join f default_toml toml) + toml_to_config ~fname:f (join f default_toml toml) let write f t = let toml = config_to_toml t in diff --git a/build_system/clerk_config.mli b/build_system/clerk_config.mli index 5e09fb7a..38ea47dd 100644 --- a/build_system/clerk_config.mli +++ b/build_system/clerk_config.mli @@ -17,7 +17,6 @@ open Catala_utils type modul = { - language : Global.backend_lang; module_uses : (string * string option) list; includes : string list; } diff --git a/build_system/clerk_driver.ml b/build_system/clerk_driver.ml index c62d5c43..c2a21771 100644 --- a/build_system/clerk_driver.ml +++ b/build_system/clerk_driver.ml @@ -1128,6 +1128,9 @@ let main () = if Catala_utils.Global.options.debug then Printexc.print_raw_backtrace stderr bt; exit Cmd.Exit.some_error + | Message.CompilerErrors contents -> + List.iter (fun c -> Message.Content.emit c Error) contents; + exit Cmd.Exit.some_error | Sys_error msg -> let bt = Printexc.get_raw_backtrace () in Message.Content.emit