mirror of
https://github.com/CatalaLang/catala.git
synced 2024-09-20 00:41:05 +03:00
Fix typing error missing position (#662)
This commit is contained in:
commit
4b0967d3c5
@ -17,21 +17,100 @@
|
|||||||
open Catala_utils
|
open Catala_utils
|
||||||
open Otoml
|
open Otoml
|
||||||
|
|
||||||
type t = {
|
type modul = {
|
||||||
catala_opts : string list;
|
language : Global.backend_lang;
|
||||||
build_dir : File.t;
|
module_uses : (string * string option) list;
|
||||||
include_dirs : File.t 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 =
|
let toml_to_config 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;
|
||||||
}
|
}
|
||||||
|
|
||||||
|
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 =
|
let config_to_toml t =
|
||||||
table
|
table
|
||||||
[
|
[
|
||||||
@ -42,6 +121,12 @@ let config_to_toml t =
|
|||||||
"build_dir", string t.build_dir;
|
"build_dir", string t.build_dir;
|
||||||
] );
|
] );
|
||||||
"project", table ["include_dirs", array (List.map string t.include_dirs)];
|
"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
|
let default_toml = config_to_toml default
|
||||||
|
@ -16,10 +16,17 @@
|
|||||||
|
|
||||||
open Catala_utils
|
open Catala_utils
|
||||||
|
|
||||||
|
type modul = {
|
||||||
|
language : Global.backend_lang;
|
||||||
|
module_uses : (string * string option) list;
|
||||||
|
includes : string list;
|
||||||
|
}
|
||||||
|
|
||||||
type t = {
|
type t = {
|
||||||
catala_opts : string list;
|
catala_opts : string list;
|
||||||
build_dir : File.t;
|
build_dir : File.t;
|
||||||
include_dirs : File.t list;
|
include_dirs : File.t list;
|
||||||
|
modules : modul String.Map.t;
|
||||||
}
|
}
|
||||||
|
|
||||||
val default : t
|
val default : t
|
||||||
|
@ -437,6 +437,15 @@ let result = make ~level:Result ~cont:emit
|
|||||||
let results r = emit (List.flatten (List.map of_result r)) Result
|
let results r = emit (List.flatten (List.map of_result r)) Result
|
||||||
let warning = make ~level:Warning ~cont:emit
|
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 =
|
let error ?(kind = Generic) : ('a, 'exn) emitter =
|
||||||
fun ?header ?internal ?pos ?pos_msg ?extra_pos ?fmt_pos ?outcome ?suggestion
|
fun ?header ?internal ?pos ?pos_msg ?extra_pos ?fmt_pos ?outcome ?suggestion
|
||||||
fmt ->
|
fmt ->
|
||||||
@ -445,6 +454,7 @@ let error ?(kind = Generic) : ('a, 'exn) emitter =
|
|||||||
Option.iter
|
Option.iter
|
||||||
(fun f ->
|
(fun f ->
|
||||||
let message ppf = Content.emit ~ppf m Error in
|
let message ppf = Content.emit ~ppf m Error in
|
||||||
|
let pos = join_pos ~pos ~fmt_pos ~extra_pos in
|
||||||
f { kind; message; pos; suggestion })
|
f { kind; message; pos; suggestion })
|
||||||
!global_error_hook;
|
!global_error_hook;
|
||||||
raise (CompilerError m))
|
raise (CompilerError m))
|
||||||
@ -466,6 +476,7 @@ let delayed_error ?(kind = Generic) x : ('a, 'exn) emitter =
|
|||||||
Option.iter
|
Option.iter
|
||||||
(fun f ->
|
(fun f ->
|
||||||
let message ppf = Content.emit ~ppf m Error in
|
let message ppf = Content.emit ~ppf m Error in
|
||||||
|
let pos = join_pos ~pos ~fmt_pos ~extra_pos in
|
||||||
f { kind; message; pos; suggestion })
|
f { kind; message; pos; suggestion })
|
||||||
!global_error_hook;
|
!global_error_hook;
|
||||||
if global_errors.stop_on_error then raise (CompilerError m);
|
if global_errors.stop_on_error then raise (CompilerError m);
|
||||||
|
Loading…
Reference in New Issue
Block a user