Fix typing error missing position (#662)

build_system/clerk_config.ml

@@ -17,21 +17,100 @@
 open Catala_utils
 open Otoml
 
-type t = {
-  catala_opts : string list;
-  build_dir : File.t;
-  include_dirs : File.t list;
+type modul = {
+  language : Global.backend_lang;
+  module_uses : (string * string option) list;
+  includes : string list;
 }
 
-let default = { catala_opts = []; build_dir = "_build"; include_dirs = [] }
+type t = {
+  catala_opts : string list;
+  build_dir : string;
+  include_dirs : string list;
+  modules : modul String.Map.t;
+}
+
+let default =
+  {
+    catala_opts = [];
+    build_dir = "_build";
+    include_dirs = [];
+    modules = String.Map.empty;
+  }
+
+let parse_module_uses modul =
+  match find_opt modul (get_array get_value) ["module_uses"] with
+  | None -> []
+  | Some module_uses ->
+    List.map
+      (function
+        | TomlString module_name | TomlArray [TomlString module_name] ->
+          module_name, None
+        | TomlArray [TomlString module_name; TomlString module_alias] ->
+          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)")
+      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
+    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 @{<bold>%s@}, valid entries are: \
+       @[<h>%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
+
+let find_and_parse_modules_exn 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 includes =
+      Helpers.find_strings_opt modul ["includes"] |> Option.value ~default:[]
+    in
+    name, { language; module_uses; includes }
+  in
+  List.map parse_module modules |> String.Map.of_list
 
 let toml_to_config 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;
   }
 
+let module_to_toml name { language; module_uses; includes } =
+  table
+    [
+      "name", string name;
+      "language", string (Cli.language_code language);
+      ( "module_uses",
+        array
+          (List.map
+             (function
+               | name, None -> string name
+               | name, Some alias -> array [string name; string alias])
+             module_uses) );
+      "includes", array (List.map string includes);
+    ]
+
 let config_to_toml t =
   table
     [
@@ -42,6 +121,12 @@ let config_to_toml t =
             "build_dir", string t.build_dir;
           ] );
       "project", table ["include_dirs", array (List.map string t.include_dirs)];
+      ( "module",
+        TomlTableArray
+          (String.Map.fold
+             (fun name modul acc -> module_to_toml name modul :: acc)
+             t.modules []
+          |> List.rev) );
     ]
 
 let default_toml = config_to_toml default

build_system/clerk_config.mli

@@ -16,10 +16,17 @@
 
 open Catala_utils
 
+type modul = {
+  language : Global.backend_lang;
+  module_uses : (string * string option) list;
+  includes : string list;
+}
+
 type t = {
   catala_opts : string list;
   build_dir : File.t;
   include_dirs : File.t list;
+  modules : modul String.Map.t;
 }
 
 val default : t

compiler/catala_utils/message.ml

@@ -437,6 +437,15 @@ let result = make ~level:Result ~cont:emit
 let results r = emit (List.flatten (List.map of_result r)) Result
 let warning = make ~level:Warning ~cont:emit
 
+let join_pos ~pos ~fmt_pos ~extra_pos =
+  (* Error positioning might be provided using multiple options. Thus, we look
+     for each of them and prioritize in this order [fmt_pos] > [extra_pos] >
+     [pos] if multiple positions are present. *)
+  match fmt_pos, extra_pos, pos with
+  | Some ((_, pos) :: _), _, _ | _, Some ((_, pos) :: _), _ | _, _, Some pos ->
+    Some pos
+  | _ -> None
+
 let error ?(kind = Generic) : ('a, 'exn) emitter =
  fun ?header ?internal ?pos ?pos_msg ?extra_pos ?fmt_pos ?outcome ?suggestion
      fmt ->
@@ -445,6 +454,7 @@ let error ?(kind = Generic) : ('a, 'exn) emitter =
       Option.iter
         (fun f ->
           let message ppf = Content.emit ~ppf m Error in
+          let pos = join_pos ~pos ~fmt_pos ~extra_pos in
           f { kind; message; pos; suggestion })
         !global_error_hook;
       raise (CompilerError m))
@@ -466,6 +476,7 @@ let delayed_error ?(kind = Generic) x : ('a, 'exn) emitter =
       Option.iter
         (fun f ->
           let message ppf = Content.emit ~ppf m Error in
+          let pos = join_pos ~pos ~fmt_pos ~extra_pos in
           f { kind; message; pos; suggestion })
         !global_error_hook;
       if global_errors.stop_on_error then raise (CompilerError m);