Improve error reporting and remove language

This commit is contained in:
vbot 2024-08-06 18:08:21 +02:00
parent 4b0967d3c5
commit f7f76e26ae
No known key found for this signature in database
GPG Key ID: A2CE1BDBED95DA38
3 changed files with 68 additions and 37 deletions

View File

@ -18,7 +18,6 @@ open Catala_utils
open Otoml open Otoml
type modul = { type modul = {
language : Global.backend_lang;
module_uses : (string * string option) list; module_uses : (string * string option) list;
includes : string list; includes : string list;
} }
@ -38,9 +37,9 @@ let default =
modules = String.Map.empty; 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 match find_opt modul (get_array get_value) ["module_uses"] with
| None -> [] | None | (exception _) -> [] (* [opt] is a lie. *)
| Some module_uses -> | Some module_uses ->
List.map List.map
(function (function
@ -50,57 +49,87 @@ let parse_module_uses modul =
module_name, Some module_alias module_name, Some module_alias
| _ -> | _ ->
Message.error Message.error
"Invalid module use: expected a module name as string or an array \ "While parsing %a: in module @{<italic>%s@}, invalid value for \
of two strings (module name and its alias)") @{<red>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 module_uses
let parse_name_and_language modul = let check_module_sanity ~fname modul =
let name = Helpers.find_string_exn modul ["name"] in match modul with
let lang = | TomlTable kvs ->
let lang_opt = let format_module_name ppf =
Helpers.find_string_opt modul ["language"] match Helpers.find_string_opt modul ["name"] with
|> Option.map String.uncapitalize_ascii | None | (exception _) -> () (* [opt] is a lie. *)
| Some name -> Format.fprintf ppf "in module @{<italic>%s@}, " name
in in
match lang_opt with List.iter
| None -> Message.error "Missing " "language" " field in configuration" (function
| Some lang -> lang | "name", TomlString _ -> ()
in | "name", _ ->
match List.assoc_opt lang Cli.languages with Message.delayed_error ()
| None -> "While parsing %a: invalid value for key @{<red>name@}.@\n\
Message.error Expected a direct string." File.format fname
"Unexpected language '%s' for module @{<bold>%s@}, valid entries are: \ | "module_uses", TomlArray _ -> (* checked in [parse_module_uses] *) ()
@[<h>%a@]" | "module_uses", _ ->
lang name Message.delayed_error ()
Format.( "While parsing %a: %tinvalid value for key @{<red>module_uses@}.@\n\
pp_print_list ~pp_sep:(fun fmt () -> fprintf fmt ",@ ") pp_print_string) It must be an array." File.format fname format_module_name
(List.map fst Cli.languages) | "includes", TomlArray srcs ->
| Some x -> name, x 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 @{<red>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 @{<red>includes@}.@\n\
Expected an array of strings." File.format fname format_module_name
| k, _ ->
Message.delayed_error ()
"While parsing %a: %tunexpected key @{<red>%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 modules = find toml (get_array get_value) ["module"] in
let parse_module modul = let parse_module modul =
let name, language = parse_name_and_language modul in let () = check_module_sanity ~fname modul in
let module_uses = parse_module_uses modul in let name = Helpers.find_string_exn modul ["name"] in
let module_uses = parse_module_uses ~fname ~name modul in
let includes = 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 in
name, { language; module_uses; includes } name, { module_uses; includes }
in 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"]; catala_opts = Helpers.find_strings_exn toml ["build"; "catala_opts"];
build_dir = Helpers.find_string_exn toml ["build"; "build_dir"]; build_dir = Helpers.find_string_exn toml ["build"; "build_dir"];
include_dirs = Helpers.find_strings_exn toml ["project"; "include_dirs"]; 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 table
[ [
"name", string name; "name", string name;
"language", string (Cli.language_code language);
( "module_uses", ( "module_uses",
array array
(List.map (List.map
@ -190,7 +219,7 @@ let read f =
~pos:(Pos.from_info f li col li (col + 1)) ~pos:(Pos.from_info f li col li (col + 1))
"Error in Clerk configuration:@ %a" Format.pp_print_text msg "Error in Clerk configuration:@ %a" Format.pp_print_text msg
in in
toml_to_config (join f default_toml toml) toml_to_config ~fname:f (join f default_toml toml)
let write f t = let write f t =
let toml = config_to_toml t in let toml = config_to_toml t in

View File

@ -17,7 +17,6 @@
open Catala_utils open Catala_utils
type modul = { type modul = {
language : Global.backend_lang;
module_uses : (string * string option) list; module_uses : (string * string option) list;
includes : string list; includes : string list;
} }

View File

@ -1128,6 +1128,9 @@ let main () =
if Catala_utils.Global.options.debug then if Catala_utils.Global.options.debug then
Printexc.print_raw_backtrace stderr bt; Printexc.print_raw_backtrace stderr bt;
exit Cmd.Exit.some_error 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 -> | Sys_error msg ->
let bt = Printexc.get_raw_backtrace () in let bt = Printexc.get_raw_backtrace () in
Message.Content.emit Message.Content.emit