CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-09-19 00:15:39 +03:00
Code Issues Projects Releases Wiki Activity

Messages renamed to Message (lighter syntax)

Browse Source
This commit is contained in:
Aminata-Dev 2023-06-13 11:27:45 +02:00
parent 5f9cb55e34
commit 10d147a8b1
37 changed files with 304 additions and 304 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

32
build_system/clerk_driver.ml
View File

@ -237,7 +237,7 @@ let [@ocamlformat "disable"] scan_for_inline_tests (file : string)
1
(String.sub file_str 0 pos)
in
Messages.raise_error "Bad inline-test format at %s line %d" file line
Message.raise_error "Bad inline-test format at %s line %d" file line
in
let params =
List.filter (( <> ) "")
@ -305,7 +305,7 @@ let search_for_expected_outputs (file : string) : expected_output_descr list =
match Re.Group.get_opt groups 1 with
| Some x -> x
| None ->
Messages.raise_error
Message.raise_error
"A test declaration is missing its identifier in the file %s"
file
in
@ -525,7 +525,7 @@ let collect_all_ninja_build
(reset_test_outputs : bool) : (string * ninja) option =
let expected_outputs = search_for_expected_outputs tested_file in
if expected_outputs = [] then (
Messages.emit_debug "No expected outputs were found for test file %s"
Message.emit_debug "No expected outputs were found for test file %s"
tested_file;
None)
else
@ -621,7 +621,7 @@ let run_inline_tests
(catala_exe : string)
(catala_opts : string list) =
match scan_for_inline_tests file with
| None -> Messages.emit_warning "No inline tests found in %s" file
| None -> Message.emit_warning "No inline tests found in %s" file
| Some file_tests ->
let run oc =
List.iter
@ -694,7 +694,7 @@ let run_file
(fun s -> s <> "")
[catala_exe; catala_opts; "-s " ^ scope; "Interpret"; file])
in
Messages.emit_debug "Running: %s" command;
Message.emit_debug "Running: %s" command;
Sys.command command
(** {1 Driver} *)
@ -705,7 +705,7 @@ let get_catala_files_in_folder (dir : string) : string list =
let f_is_dir =
try Sys.is_directory f
with Sys_error e ->
Messages.emit_warning "skipping %s" e;
Message.emit_warning "skipping %s" e;
false
in
if f_is_dir then
@ -905,7 +905,7 @@ let driver
in
match String.lowercase_ascii command with
| "test" -> (
Messages.emit_debug "building ninja rules...";
Message.emit_debug "building ninja rules...";
let ctx =
add_test_builds
(ninja_building_context_init (ninja_start catala_exe catala_opts))
@ -919,7 +919,7 @@ let driver
in
if there_is_some_fails then
List.iter
(Messages.emit_warning "No test case found for @{<magenta>%s@}")
(Message.emit_warning "No test case found for @{<magenta>%s@}")
ctx.all_failed_names;
if 0 = List.compare_lengths ctx.all_failed_names files_or_folders then
return_ok
@ -928,7 +928,7 @@ let driver
@@ fun nin ->
match
File.with_formatter_of_file nin (fun fmt ->
Messages.emit_debug "writing %s..." nin;
Message.emit_debug "writing %s..." nin;
Nj.format fmt
(add_root_test_build ninja ctx.all_file_names
ctx.all_test_builds))
@ -937,9 +937,9 @@ let driver
let ninja_cmd =
"ninja -k 0 -f " ^ nin ^ " " ^ ninja_flags ^ " test"
in
Messages.emit_debug "executing '%s'..." ninja_cmd;
Message.emit_debug "executing '%s'..." ninja_cmd;
Sys.command ninja_cmd
| exception Sys_error e -> Messages.raise_error "can not write in %s" e)
| exception Sys_error e -> Message.raise_error "can not write in %s" e)
| "run" -> (
match scope with
| Some scope ->
@ -950,19 +950,19 @@ let driver
in
if 0 <> res then return_err else return_ok
| None ->
Messages.raise_error "Please provide a scope to run with the -s option")
Message.raise_error "Please provide a scope to run with the -s option")
| "runtest" -> (
match files_or_folders with
| [f] ->
run_inline_tests ~reset:reset_test_outputs f catala_exe
(List.filter (( <> ) "") (String.split_on_char ' ' catala_opts));
0
| _ -> Messages.raise_error "Please specify a single catala file to test")
| _ -> Message.raise_error "Please specify a single catala file to test")
| _ ->
Messages.raise_error "The command \"%s\" is unknown to clerk." command
with Messages.CompilerError content ->
Message.raise_error "The command \"%s\" is unknown to clerk." command
with Message.CompilerError content ->
let bt = Printexc.get_raw_backtrace () in
Messages.emit_content content Error;
Message.emit_content content Error;
if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt;
return_err

2
compiler/catala_utils/file.ml
View File

@ -41,7 +41,7 @@ let with_in_channel filename f =
finally (fun () -> close_in oc) (fun () -> f oc)
let with_formatter_of_out_channel oc f =
let fmt = Messages.formatter_of_out_channel oc in
let fmt = Message.formatter_of_out_channel oc in
finally (fun () -> Format.pp_print_flush fmt ()) @@ fun () -> f fmt
let with_formatter_of_file filename f =

14
compiler/dcalc/from_scopelang.ml
View File

@ -227,7 +227,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
let case_e =
try EnumConstructor.Map.find constructor e_cases
with Not_found ->
Messages.raise_spanned_error (Expr.pos e)
Message.raise_spanned_error (Expr.pos e)
"The constructor %a of enum %a is missing from this pattern \
matching"
EnumConstructor.format_t constructor EnumName.format_t name
@ -239,7 +239,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
(EnumConstructor.Map.empty, e_cases)
in
if not (EnumConstructor.Map.is_empty remaining_e_cases) then
Messages.raise_spanned_error (Expr.pos e)
Message.raise_spanned_error (Expr.pos e)
"Pattern matching is incomplete for enum %a: missing cases %a"
EnumName.format_t name
(Format.pp_print_list
@ -272,7 +272,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
| _ -> false)
var_ctx.scope_input_io (translate_expr ctx e) )
| Some var_ctx, None ->
Messages.raise_multispanned_error
Message.raise_multispanned_error
[
None, pos;
( Some "Declaration of the missing input variable",
@ -281,7 +281,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
"Definition of input variable '%a' missing in this scope call"
ScopeVar.format_t var_name
| None, Some _ ->
Messages.raise_multispanned_error
Message.raise_multispanned_error
[
None, pos;
( Some "Declaration of scope '%a'",
@ -493,12 +493,12 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
match typ with
| TArrow (tin, (tout, _)) -> List.map Mark.remove tin, tout
| _ ->
Messages.raise_spanned_error (Expr.pos e)
Message.raise_spanned_error (Expr.pos e)
"Application of non-function toplevel variable")
| _ -> ListLabels.map new_args ~f:(fun _ -> TAny), TAny
in
(* Messages.emit_debug "new_args %d, input_typs: %d, input_typs %a"
(* Message.emit_debug "new_args %d, input_typs: %d, input_typs %a"
(List.length new_args) (List.length input_typs) (Format.pp_print_list
Print.typ_debug) (List.map (Mark.add Pos.no_pos) input_typs); *)
let new_args =
@ -567,7 +567,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm Scopelang.Ast.expr) :
in
Expr.evar v m
with Not_found ->
Messages.raise_multispanned_error
Message.raise_multispanned_error
[
Some "Incriminated variable usage:", Expr.pos e;
( Some "Incriminated subscope variable declaration:",

4
compiler/dcalc/invariants.ml
View File

@ -37,7 +37,7 @@ let check_invariant (inv : string * invariant_expr) (p : typed program) : bool =
match inv e with
| Ignore -> true
| Fail ->
Messages.raise_spanned_error (Expr.pos e) "%s failed\n\n%a" name
Message.raise_spanned_error (Expr.pos e) "%s failed\n\n%a" name
(Print.expr ()) e
| Pass ->
incr ok;
@ -52,7 +52,7 @@ let check_invariant (inv : string * invariant_expr) (p : typed program) : bool =
e')
in
assert (Bindlib.free_vars p' = Bindlib.empty_ctxt);
Messages.emit_result "Invariant %s\n checked. result: [%d/%d]" name !ok
Message.emit_result "Invariant %s\n checked. result: [%d/%d]" name !ok
!total;
!result

12
compiler/desugared/dependency.ml
View File

@ -151,7 +151,7 @@ let check_for_cycle (scope : Ast.scope) (g : ScopeDependencies.t) : unit =
cycle
(List.tl cycle @ [List.hd cycle])
in
Messages.raise_multispanned_error spans
Message.raise_multispanned_error spans
"@[<hov 2>Cyclic dependency detected between the following variables of \
scope %a:@ @[<hv>%a@]@]"
ScopeName.format_t scope.scope_uid
@ -204,7 +204,7 @@ let build_scope_dependencies (scope : Ast.scope) : ScopeDependencies.t =
&& Option.equal StateName.equal s_used s_defined
then
(* variable definitions cannot be recursive *)
Messages.raise_spanned_error fv_def_pos
Message.raise_spanned_error fv_def_pos
"The variable %a is used in one of its definitions, but \
recursion is forbidden in Catala"
Ast.ScopeDef.format_t def_key
@ -232,7 +232,7 @@ let build_scope_dependencies (scope : Ast.scope) : ScopeDependencies.t =
another subscope *)
if SubScopeName.equal used defined then
(* subscopes are not recursive functions *)
Messages.raise_spanned_error fv_def_pos
Message.raise_spanned_error fv_def_pos
"The subscope %a is used when defining one of its inputs, \
but recursion is forbidden in Catala"
SubScopeName.format_t defined
@ -450,12 +450,12 @@ let build_exceptions_graph
in
(* We check the consistency*)
if LabelName.compare label_from label_to = 0 then
Messages.raise_spanned_error edge_pos
Message.raise_spanned_error edge_pos
"Cannot define rule as an exception to itself";
List.iter
(fun edge ->
if LabelName.compare edge.label_to label_to <> 0 then
Messages.raise_multispanned_error
Message.raise_multispanned_error
(( Some
"This definition contradicts other exception \
definitions:",
@ -541,7 +541,7 @@ let check_for_exception_cycle
scc
in
let v, _ = RuleName.Map.choose (List.hd scc).rules in
Messages.raise_multispanned_error spans
Message.raise_multispanned_error spans
"Exception cycle detected when defining %a: each of these %d exceptions \
applies over the previous one, and the first applies over the last"
RuleName.format_t v (List.length scc)

96
compiler/desugared/from_surface.ml
View File

@ -69,7 +69,7 @@ let translate_binop : Surface.Ast.binop -> Pos.t -> Ast.expr boxed =
| S.KDec -> [TLit TRat; TLit TRat]
| S.KMoney -> [TLit TMoney; TLit TRat]
| S.KDate ->
Messages.raise_spanned_error pos
Message.raise_spanned_error pos
"This operator doesn't exist, dates can't be multiplied"
| S.KDuration -> [TLit TDuration; TLit TInt])
| S.Div k ->
@ -80,7 +80,7 @@ let translate_binop : Surface.Ast.binop -> Pos.t -> Ast.expr boxed =
| S.KDec -> [TLit TRat; TLit TRat]
| S.KMoney -> [TLit TMoney; TLit TMoney]
| S.KDate ->
Messages.raise_spanned_error pos
Message.raise_spanned_error pos
"This operator doesn't exist, dates can't be divided"
| S.KDuration -> [TLit TDuration; TLit TDuration])
| S.Lt k | S.Lte k | S.Gt k | S.Gte k ->
@ -116,7 +116,7 @@ let translate_unop (op : Surface.Ast.unop) pos : Ast.expr boxed =
| S.KDec -> TLit TRat
| S.KMoney -> TLit TMoney
| S.KDate ->
Messages.raise_spanned_error pos
Message.raise_spanned_error pos
"This operator doesn't exist, dates can't be negative"
| S.KDuration -> TLit TDuration)
@ -128,20 +128,20 @@ let disambiguate_constructor
match constructor with
| [c] -> Mark.remove c
| _ ->
Messages.raise_spanned_error pos
Message.raise_spanned_error pos
"The deep pattern matching syntactic sugar is not yet supported"
in
let possible_c_uids =
try IdentName.Map.find (Mark.remove constructor) ctxt.constructor_idmap
with Not_found ->
Messages.raise_spanned_error (Mark.get constructor)
Message.raise_spanned_error (Mark.get constructor)
"The name of this constructor has not been defined before, maybe it is \
a typo?"
in
match path with
| [] ->
if EnumName.Map.cardinal possible_c_uids > 1 then
Messages.raise_spanned_error (Mark.get constructor)
Message.raise_spanned_error (Mark.get constructor)
"This constructor name is ambiguous, it can belong to %a. Disambiguate \
it by prefixing it with the enum name."
(Format.pp_print_list
@ -158,13 +158,13 @@ let disambiguate_constructor
let c_uid = EnumName.Map.find e_uid possible_c_uids in
e_uid, c_uid
with Not_found ->
Messages.raise_spanned_error pos "Enum %s does not contain case %s"
Message.raise_spanned_error pos "Enum %s does not contain case %s"
(Mark.remove enum) (Mark.remove constructor)
with Not_found ->
Messages.raise_spanned_error (Mark.get enum)
Message.raise_spanned_error (Mark.get enum)
"Enum %s has not been defined before" (Mark.remove enum))
| _ ->
Messages.raise_spanned_error pos "Qualified paths are not supported yet"
Message.raise_spanned_error pos "Qualified paths are not supported yet"
let int100 = Runtime.integer_of_int 100
let rat100 = Runtime.decimal_of_integer int100
@ -179,7 +179,7 @@ let rec check_formula (op, pos_op) e =
(* Xor is mathematically associative, but without a useful semantics ([a
xor b xor c] is most likely an error since it's true for [a = b = c =
true]) *)
Messages.raise_multispanned_error
Message.raise_multispanned_error
[None, pos_op; None, pos_op1]
"Please add parentheses to explicit which of these operators should be \
applied first";
@ -281,21 +281,21 @@ let rec translate_expr
| LNumber ((Int i, _), Some (Day, _)) ->
LDuration (Runtime.duration_of_numbers 0 0 (int_of_string i))
| LNumber ((Dec (_, _), _), Some ((Year | Month | Day), _)) ->
Messages.raise_spanned_error pos
Message.raise_spanned_error pos
"Impossible to specify decimal amounts of days, months or years"
| LDate date ->
if date.literal_date_month > 12 then
Messages.raise_spanned_error pos
Message.raise_spanned_error pos
"There is an error in this date: the month number is bigger than 12";
if date.literal_date_day > 31 then
Messages.raise_spanned_error pos
Message.raise_spanned_error pos
"There is an error in this date: the day number is bigger than 31";
LDate
(try
Runtime.date_of_numbers date.literal_date_year
date.literal_date_month date.literal_date_day
with Runtime.ImpossibleDate ->
Messages.raise_spanned_error pos
Message.raise_spanned_error pos
"There is an error in this date, it does not correspond to a \
correct calendar day")
in
@ -329,7 +329,7 @@ let rec translate_expr
no state but variable has states"
| Some inside_def_state ->
if StateName.compare inside_def_state (List.hd states) = 0 then
Messages.raise_spanned_error pos
Message.raise_spanned_error pos
"It is impossible to refer to the variable you are \
defining when defining its first state."
else
@ -362,7 +362,7 @@ let rec translate_expr
Name_resolution.raise_unknown_identifier
"for a local, scope-wide or global variable" (x, pos))))
| Ident (_path, _x) ->
Messages.raise_spanned_error pos "Qualified paths are not supported yet"
Message.raise_spanned_error pos "Qualified paths are not supported yet"
| Dotted (e, ((path, x), _ppos)) -> (
match path, Mark.remove e with
| [], Ident ([], (y, _))
@ -390,10 +390,10 @@ let rec translate_expr
| [c] -> (
try Some (Name_resolution.get_struct ctxt c)
with Not_found ->
Messages.raise_spanned_error (Mark.get c)
Message.raise_spanned_error (Mark.get c)
"Structure %s was not declared" (Mark.remove c))
| _ ->
Messages.raise_spanned_error pos
Message.raise_spanned_error pos
"Qualified paths are not supported yet"
in
Expr.edstructaccess e (Mark.remove x) str emark)
@ -401,7 +401,7 @@ let rec translate_expr
Expr.eapp (rec_helper f) (List.map rec_helper args) emark
| ScopeCall ((([], sc_name), _), fields) ->
if scope = None then
Messages.raise_spanned_error pos
Message.raise_spanned_error pos
"Scope calls are not allowed outside of a scope";
let called_scope = Name_resolution.get_scope ctxt sc_name in
let scope_def = ScopeName.Map.find called_scope ctxt.scopes in
@ -414,7 +414,7 @@ let rec translate_expr
with
| Some (ScopeVar v) -> v
| Some (SubScope _) | None ->
Messages.raise_multispanned_error
Message.raise_multispanned_error
[
None, Mark.get fld_id;
( Some
@ -429,7 +429,7 @@ let rec translate_expr
(function
| None -> Some (rec_helper e)
| Some _ ->
Messages.raise_spanned_error (Mark.get fld_id)
Message.raise_spanned_error (Mark.get fld_id)
"Duplicate definition of scope input variable '%a'"
ScopeVar.format_t var)
acc)
@ -437,7 +437,7 @@ let rec translate_expr
in
Expr.escopecall called_scope in_struct emark
| ScopeCall (((_, _sc_name), _), _fields) ->
Messages.raise_spanned_error pos "Qualified paths are not supported yet"
Message.raise_spanned_error pos "Qualified paths are not supported yet"
| LetIn (x, e1, e2) ->
let ctxt, v = Name_resolution.add_def_local_var ctxt (Mark.remove x) in
let tau = TAny, Mark.get x in
@ -453,7 +453,7 @@ let rec translate_expr
match IdentName.Map.find_opt (Mark.remove s_name) ctxt.typedefs with
| Some (Name_resolution.TStruct s_uid) -> s_uid
| _ ->
Messages.raise_spanned_error (Mark.get s_name)
Message.raise_spanned_error (Mark.get s_name)
"This identifier should refer to a struct name"
in
@ -465,14 +465,14 @@ let rec translate_expr
StructName.Map.find s_uid
(IdentName.Map.find (Mark.remove f_name) ctxt.field_idmap)
with Not_found ->
Messages.raise_spanned_error (Mark.get f_name)
Message.raise_spanned_error (Mark.get f_name)
"This identifier should refer to a field of struct %s"
(Mark.remove s_name)
in
(match StructField.Map.find_opt f_uid s_fields with
| None -> ()
| Some e_field ->
Messages.raise_multispanned_error
Message.raise_multispanned_error
[None, Mark.get f_e; None, Expr.pos e_field]
"The field %a has been defined twice:" StructField.format_t f_uid);
let f_e = translate_expr scope inside_definition_of ctxt f_e in
@ -483,19 +483,19 @@ let rec translate_expr
StructField.Map.iter
(fun expected_f _ ->
if not (StructField.Map.mem expected_f s_fields) then
Messages.raise_spanned_error pos
Message.raise_spanned_error pos
"Missing field for structure %a: \"%a\"" StructName.format_t s_uid
StructField.format_t expected_f)
expected_s_fields;
Expr.estruct s_uid s_fields emark
| StructLit (((_, _s_name), _), _fields) ->
Messages.raise_spanned_error pos "Qualified paths are not supported yet"
Message.raise_spanned_error pos "Qualified paths are not supported yet"
| EnumInject (((path, (constructor, pos_constructor)), _), payload) -> (
let possible_c_uids =
try IdentName.Map.find constructor ctxt.constructor_idmap
with Not_found ->
Messages.raise_spanned_error pos_constructor
Message.raise_spanned_error pos_constructor
"The name of this constructor has not been defined before, maybe it \
is a typo?"
in
@ -507,7 +507,7 @@ let rec translate_expr
(* No constructor name was specified *)
EnumName.Map.cardinal possible_c_uids > 1
then
Messages.raise_spanned_error pos_constructor
Message.raise_spanned_error pos_constructor
"This constructor name is ambiguous, it can belong to %a. \
Desambiguate it by prefixing it with the enum name."
(Format.pp_print_list
@ -540,13 +540,13 @@ let rec translate_expr
| None -> Expr.elit LUnit mark_constructor)
c_uid e_uid emark
with Not_found ->
Messages.raise_spanned_error pos "Enum %s does not contain case %s"
Message.raise_spanned_error pos "Enum %s does not contain case %s"
(Mark.remove enum) constructor
with Not_found ->
Messages.raise_spanned_error (Mark.get enum)
Message.raise_spanned_error (Mark.get enum)
"Enum %s has not been defined before" (Mark.remove enum))
| _ ->
Messages.raise_spanned_error pos "Qualified paths are not supported yet")
Message.raise_spanned_error pos "Qualified paths are not supported yet")
| MatchWith (e1, (cases, _cases_pos)) ->
let e1 = translate_expr scope inside_definition_of ctxt e1 in
let cases_d, e_uid =
@ -558,7 +558,7 @@ let rec translate_expr
(match snd (Mark.remove pattern) with
| None -> ()
| Some binding ->
Messages.emit_spanned_warning (Mark.get binding)
Message.emit_spanned_warning (Mark.get binding)
"This binding will be ignored (remove it to suppress warning)");
let enum_uid, c_uid =
disambiguate_constructor ctxt
@ -696,7 +696,7 @@ let rec translate_expr
| S.Money -> LMoney (Runtime.money_of_cents_integer i0)
| S.Duration -> LDuration (Runtime.duration_of_numbers 0 0 0)
| t ->
Messages.raise_spanned_error pos
Message.raise_spanned_error pos
"It is impossible to sum values of type %a together"
SurfacePrint.format_primitive_typ t
in
@ -795,7 +795,7 @@ and disambiguate_match_and_build_expression
| Some e_uid ->
if e_uid = e_uid' then e_uid
else
Messages.raise_spanned_error
Message.raise_spanned_error
(Mark.get case.Surface.Ast.match_case_pattern)
"This case matches a constructor of enumeration %a but previous \
case were matching constructors of enumeration %a"
@ -804,7 +804,7 @@ and disambiguate_match_and_build_expression
(match EnumConstructor.Map.find_opt c_uid cases_d with
| None -> ()
| Some e_case ->
Messages.raise_multispanned_error
Message.raise_multispanned_error
[None, Mark.get case.match_case_expr; None, Expr.pos e_case]
"The constructor %a has been matched twice:" EnumConstructor.format_t
c_uid);
@ -821,7 +821,7 @@ and disambiguate_match_and_build_expression
| Surface.Ast.WildCard match_case_expr -> (
let nb_cases = List.length cases in
let raise_wildcard_not_last_case_err () =
Messages.raise_multispanned_error
Message.raise_multispanned_error
[
Some "Not ending wildcard:", case_pos;
( Some "Next reachable case:",
@ -832,7 +832,7 @@ and disambiguate_match_and_build_expression
match e_uid with
| None ->
if 1 = nb_cases then
Messages.raise_spanned_error case_pos
Message.raise_spanned_error case_pos
"Couldn't infer the enumeration name from lonely wildcard \
(wildcard cannot be used as single match case)"
else raise_wildcard_not_last_case_err ()
@ -846,7 +846,7 @@ and disambiguate_match_and_build_expression
| None -> Some c_uid)
in
if EnumConstructor.Map.is_empty missing_constructors then
Messages.emit_spanned_warning case_pos
Message.emit_spanned_warning case_pos
"Unreachable match case, all constructors of the enumeration %a \
are already specified"
EnumName.format_t e_uid;
@ -911,12 +911,12 @@ let rec arglist_eq_check pos_decl pos_def pdecl pdefs =
match pdecl, pdefs with
| [], [] -> ()
| [], (arg, apos) :: _ ->
Messages.raise_multispanned_error
Message.raise_multispanned_error
[Some "Declared here:", pos_decl; Some "Extra argument:", apos]
"This definition has an extra, undeclared argument '%a'" Print.lit_style
arg
| (arg, apos) :: _, [] ->
Messages.raise_multispanned_error
Message.raise_multispanned_error
[
Some "Argument declared here:", apos;
Some "Mismatching definition:", pos_def;
@ -925,7 +925,7 @@ let rec arglist_eq_check pos_decl pos_def pdecl pdefs =
| decl :: pdecl, def :: pdefs when Uid.MarkedString.equal decl def ->
arglist_eq_check pos_decl pos_def pdecl pdefs
| (decl_arg, decl_apos) :: _, (def_arg, def_apos) :: _ ->
Messages.raise_multispanned_error
Message.raise_multispanned_error
[
Some "Argument declared here:", decl_apos; Some "Defined here:", def_apos;
]
@ -944,14 +944,14 @@ let process_rule_parameters
match declared_params, def.S.definition_parameter with
| None, None -> ctxt, None
| None, Some (_, pos) ->
Messages.raise_multispanned_error
Message.raise_multispanned_error
[
Some "Declared here without arguments", decl_pos;
Some "Unexpected arguments appearing here", pos;
]
"Extra arguments in this definition of %a" Ast.ScopeDef.format_t decl_name
| Some (_, pos), None ->
Messages.raise_multispanned_error
Message.raise_multispanned_error
[
Some "Arguments declared here", pos;
( Some "Definition missing the arguments",
@ -1051,7 +1051,7 @@ let process_def
in
ExceptionToLabel (label_id, Mark.get label_str)
with Not_found ->
Messages.raise_spanned_error (Mark.get label_str)
Message.raise_spanned_error (Mark.get label_str)
"Unknown label for the scope variable %a: \"%s\""
Ast.ScopeDef.format_t def_key (Mark.remove label_str))
in
@ -1161,7 +1161,7 @@ let process_scope_use_item
scope.scope_options
with
| Some (_, old_pos) ->
Messages.raise_multispanned_error
Message.raise_multispanned_error
[None, old_pos; None, Mark.get item]
"You cannot set multiple date rounding modes"
| None ->
@ -1214,10 +1214,10 @@ let check_unlabeled_exception
| Surface.Ast.UnlabeledException -> (
match scope_def_ctxt.default_exception_rulename with
| None ->
Messages.raise_spanned_error (Mark.get item)
Message.raise_spanned_error (Mark.get item)
"This exception does not have a corresponding definition"
| Some (Ambiguous pos) ->
Messages.raise_multispanned_error
Message.raise_multispanned_error
([Some "Ambiguous exception", Mark.get item]
@ List.map (fun p -> Some "Candidate definition", p) pos)
"This exception can refer to several definitions. Try using labels \

14
compiler/desugared/linting.ml
View File

@ -33,7 +33,7 @@ let detect_empty_definitions (p : program) : unit =
| NoInput -> true
| _ -> false
then
Messages.emit_spanned_warning
Message.emit_spanned_warning
(ScopeDef.get_position scope_def_key)
"In scope @{<yellow>\"%a\"@}, the variable @{<yellow>\"%a\"@} is \
declared but never defined; did you forget something?"
@ -88,7 +88,7 @@ let detect_identical_rules (p : program) : unit =
RuleExpressionsMap.iter
(fun _ pos ->
if List.length pos > 1 then
Messages.emit_multispanned_warning pos
Message.emit_multispanned_warning pos
"These %s have identical justifications and consequences; is \
it a mistake?"
(if scope_def.scope_def_is_condition then "rules"
@ -142,7 +142,7 @@ let detect_unused_struct_fields (p : program) : unit =
&& not (StructField.Set.mem field scope_out_structs_fields))
fields
then
Messages.emit_spanned_warning
Message.emit_spanned_warning
(snd (StructName.get_info s_name))
"The structure @{<yellow>\"%a\"@} is never used; maybe it's \
unnecessary?"
@ -154,7 +154,7 @@ let detect_unused_struct_fields (p : program) : unit =
(not (StructField.Set.mem field struct_fields_used))
&& not (StructField.Set.mem field scope_out_structs_fields)
then
Messages.emit_spanned_warning
Message.emit_spanned_warning
(snd (StructField.get_info field))
"The field @{<yellow>\"%a\"@} of struct @{<yellow>\"%a\"@} is \
never used; maybe it's unnecessary?"
@ -195,7 +195,7 @@ let detect_unused_enum_constructors (p : program) : unit =
not (EnumConstructor.Set.mem cons enum_constructors_used))
constructors
then
Messages.emit_spanned_warning
Message.emit_spanned_warning
(snd (EnumName.get_info e_name))
"The enumeration @{<yellow>\"%a\"@} is never used; maybe it's \
unnecessary?"
@ -205,7 +205,7 @@ let detect_unused_enum_constructors (p : program) : unit =
(fun constructor _ ->
if not (EnumConstructor.Set.mem constructor enum_constructors_used)
then
Messages.emit_spanned_warning
Message.emit_spanned_warning
(snd (EnumConstructor.get_info constructor))
"The constructor @{<yellow>\"%a\"@} of enumeration \
@{<yellow>\"%a\"@} is never used; maybe it's unnecessary?"
@ -251,7 +251,7 @@ let detect_dead_code (p : program) : unit =
ScopeVar.Map.iter
(fun var states ->
let emit_unused_warning () =
Messages.emit_spanned_warning
Message.emit_spanned_warning
(Mark.get (ScopeVar.get_info var))
"This variable is dead code; it does not contribute to computing \
any of scope @{<yellow>\"%s\"@} outputs. Did you forget \

48
compiler/desugared/name_resolution.ml
View File

@ -95,12 +95,12 @@ type context = {
(** Temporary function raising an error message saying that a feature is not
supported yet *)
let raise_unsupported_feature (msg : string) (pos : Pos.t) =
Messages.raise_spanned_error pos "Unsupported feature: %s" msg
Message.raise_spanned_error pos "Unsupported feature: %s" msg
(** Function to call whenever an identifier used somewhere has not been declared
in the program previously *)
let raise_unknown_identifier (msg : string) (ident : IdentName.t Mark.pos) =
Messages.raise_spanned_error (Mark.get ident)
Message.raise_spanned_error (Mark.get ident)
"@{<yellow>\"%s\"@}: unknown identifier %s" (Mark.remove ident) msg
(** Gets the type associated to an uid *)
@ -187,56 +187,56 @@ let get_enum ctxt id =
match IdentName.Map.find (Mark.remove id) ctxt.typedefs with
| TEnum id -> id
| TStruct sid ->
Messages.raise_multispanned_error
Message.raise_multispanned_error
[
None, Mark.get id;
Some "Structure defined at", Mark.get (StructName.get_info sid);
]
"Expecting an enum, but found a structure"
| TScope (sid, _) ->
Messages.raise_multispanned_error
Message.raise_multispanned_error
[
None, Mark.get id;
Some "Scope defined at", Mark.get (ScopeName.get_info sid);
]
"Expecting an enum, but found a scope"
| exception Not_found ->
Messages.raise_spanned_error (Mark.get id) "No enum named %s found"
Message.raise_spanned_error (Mark.get id) "No enum named %s found"
(Mark.remove id)
let get_struct ctxt id =
match IdentName.Map.find (Mark.remove id) ctxt.typedefs with
| TStruct id | TScope (_, { out_struct_name = id; _ }) -> id
| TEnum eid ->
Messages.raise_multispanned_error
Message.raise_multispanned_error
[
None, Mark.get id;
Some "Enum defined at", Mark.get (EnumName.get_info eid);
]
"Expecting an struct, but found an enum"
| exception Not_found ->
Messages.raise_spanned_error (Mark.get id) "No struct named %s found"
Message.raise_spanned_error (Mark.get id) "No struct named %s found"
(Mark.remove id)
let get_scope ctxt id =
match IdentName.Map.find (Mark.remove id) ctxt.typedefs with
| TScope (id, _) -> id
| TEnum eid ->
Messages.raise_multispanned_error
Message.raise_multispanned_error
[
None, Mark.get id;
Some "Enum defined at", Mark.get (EnumName.get_info eid);
]
"Expecting an scope, but found an enum"
| TStruct sid ->
Messages.raise_multispanned_error
Message.raise_multispanned_error
[
None, Mark.get id;
Some "Structure defined at", Mark.get (StructName.get_info sid);
]
"Expecting an scope, but found a structure"
| exception Not_found ->
Messages.raise_spanned_error (Mark.get id) "No scope named %s found"
Message.raise_spanned_error (Mark.get id) "No scope named %s found"
(Mark.remove id)
(** {1 Declarations pass} *)
@ -256,7 +256,7 @@ let process_subscope_decl
| ScopeVar v -> ScopeVar.get_info v
| SubScope (ssc, _) -> SubScopeName.get_info ssc
in
Messages.raise_multispanned_error
Message.raise_multispanned_error
[Some "first use", Mark.get info; Some "second use", s_pos]
"Subscope name @{<yellow>\"%s\"@} already used" subscope
| None ->
@ -310,12 +310,12 @@ let rec process_base_typ
| Some (TScope (_, scope_str)) ->
TStruct scope_str.out_struct_name, typ_pos
| None ->
Messages.raise_spanned_error typ_pos
Message.raise_spanned_error typ_pos
"Unknown type @{<yellow>\"%s\"@}, not a struct or enum previously \
declared"
ident)
| Surface.Ast.Named (_path, (_ident, _pos)) ->
Messages.raise_spanned_error typ_pos
Message.raise_spanned_error typ_pos
"Qualified paths are not supported yet")
(** Process a type (function or not) *)
@ -344,7 +344,7 @@ let process_data_decl
| ScopeVar v -> ScopeVar.get_info v
| SubScope (ssc, _) -> SubScopeName.get_info ssc
in
Messages.raise_multispanned_error
Message.raise_multispanned_error
[Some "First use:", Mark.get info; Some "Second use:", pos]
"Variable name @{<yellow>\"%s\"@} already used" name
| None ->
@ -361,7 +361,7 @@ let process_data_decl
((states_idmap : StateName.t IdentName.Map.t), states_list) ->
let state_id_name = Mark.remove state_id in
if IdentName.Map.mem state_id_name states_idmap then
Messages.raise_multispanned_error_full
Message.raise_multispanned_error_full
[
( Some
(fun ppf ->
@ -424,7 +424,7 @@ let process_struct_decl (ctxt : context) (sdecl : Surface.Ast.struct_decl) :
context =
let s_uid = get_struct ctxt sdecl.struct_decl_name in
if sdecl.struct_decl_fields = [] then
Messages.raise_spanned_error
Message.raise_spanned_error
(Mark.get sdecl.struct_decl_name)
"The struct %s does not have any fields; give it some for Catala to be \
able to accept it."
@ -469,7 +469,7 @@ let process_enum_decl (ctxt : context) (edecl : Surface.Ast.enum_decl) : context
=
let e_uid = get_enum ctxt edecl.enum_decl_name in
if List.length edecl.enum_decl_cases = 0 then
Messages.raise_spanned_error
Message.raise_spanned_error
(Mark.get edecl.enum_decl_name)
"The enum %s does not have any cases; give it some for Catala to be able \
to accept it."
@ -602,7 +602,7 @@ let typedef_info = function
let process_name_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
context =
let raise_already_defined_error (use : Uid.MarkedString.info) name pos msg =
Messages.raise_multispanned_error_full
Message.raise_multispanned_error_full
[
( Some (fun ppf -> Format.pp_print_string ppf "First definition:"),
Mark.get use );
@ -734,7 +734,7 @@ let get_def_key
(IdentName.Map.find (Mark.remove state)
var_sig.var_sig_states_idmap)
with Not_found ->
Messages.raise_multispanned_error
Message.raise_multispanned_error
[
None, Mark.get state;
Some "Variable declaration:", Mark.get (ScopeVar.get_info x_uid);
@ -743,7 +743,7 @@ let get_def_key
ScopeVar.format_t x_uid)
| None ->
if not (IdentName.Map.is_empty var_sig.var_sig_states_idmap) then
Messages.raise_multispanned_error
Message.raise_multispanned_error
[
None, Mark.get x;
Some "Variable declaration:", Mark.get (ScopeVar.get_info x_uid);
@ -757,17 +757,17 @@ let get_def_key
match IdentName.Map.find_opt (Mark.remove y) scope_ctxt.var_idmap with
| Some (SubScope (v, u)) -> v, u
| Some _ ->
Messages.raise_spanned_error pos
Message.raise_spanned_error pos
"Invalid access to input variable, %a is not a subscope"
Print.lit_style (Mark.remove y)
| None ->
Messages.raise_spanned_error pos "No definition found for subscope %a"
Message.raise_spanned_error pos "No definition found for subscope %a"
Print.lit_style (Mark.remove y)
in
let x_uid = get_var_uid subscope_real_uid ctxt x in
Ast.ScopeDef.SubScopeVar (subscope_uid, x_uid, pos)
| _ ->
Messages.raise_spanned_error pos
Message.raise_spanned_error pos
"This line is defining a quantity that is neither a scope variable nor a \
subscope variable. In particular, it is not possible to define struct \
fields individually in Catala."
@ -891,7 +891,7 @@ let process_scope_use (ctxt : context) (suse : Surface.Ast.scope_use) : context
with
| Some (TScope (sn, _)) -> sn
| _ ->
Messages.raise_spanned_error
Message.raise_spanned_error
(Mark.get suse.Surface.Ast.scope_use_name)
"@{<yellow>\"%s\"@}: this scope has not been declared anywhere, is it \
a typo?"

6
compiler/desugared/print.ml
View File

@ -84,20 +84,20 @@ let print_exceptions_graph
(scope : ScopeName.t)
(var : Ast.ScopeDef.t)
(g : Dependency.ExceptionsDependencies.t) =
Messages.emit_result
Message.emit_result
"Printing the tree of exceptions for the definitions of variable \
@{<yellow>\"%a\"@} of scope @{<yellow>\"%a\"@}."
Ast.ScopeDef.format_t var ScopeName.format_t scope;
Dependency.ExceptionsDependencies.iter_vertex
(fun ex ->
Messages.emit_result
Message.emit_result
"@[<v>Definitions with label @{<yellow>\"%a\"@}:@,%a@]"
LabelName.format_t ex.Dependency.ExceptionVertex.label
(Format.pp_print_list (fun fmt (_, pos) -> Pos.format_loc_text fmt pos))
(RuleName.Map.bindings ex.Dependency.ExceptionVertex.rules))
g;
let tree = build_exception_tree g in
Messages.emit_result "The exception tree structure is as follows:\n\n%a"
Message.emit_result "The exception tree structure is as follows:\n\n%a"
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n")
(fun fmt tree -> format_exception_tree fmt tree))

128
compiler/driver.ml
View File

@ -27,7 +27,7 @@ let get_scope_uid
(ctxt : Desugared.Name_resolution.context) =
match options.ex_scope, backend with
| None, `Interpret ->
Messages.raise_error "No scope was provided for execution."
Message.raise_error "No scope was provided for execution."
| None, _ ->
let _, scope =
try
@ -38,14 +38,14 @@ let get_scope_uid
ctxt.typedefs
|> Shared_ast.IdentName.Map.choose
with Not_found ->
Messages.raise_error "There isn't any scope inside the program."
Message.raise_error "There isn't any scope inside the program."
in
scope
| Some name, _ -> (
match Shared_ast.IdentName.Map.find_opt name ctxt.typedefs with
| Some (Desugared.Name_resolution.TScope (uid, _)) -> uid
| _ ->
Messages.raise_error
Message.raise_error
"There is no scope @{<yellow>\"%s\"@} inside the program." name)
let get_variable_uid
@ -55,7 +55,7 @@ let get_variable_uid
(scope_uid : Shared_ast.ScopeName.t) =
match options.ex_variable, backend with
| None, `Exceptions ->
Messages.raise_error
Message.raise_error
"Please specify a variable with the -v option to print its exception \
tree."
| None, _ -> None
@ -79,7 +79,7 @@ let get_variable_uid
(Shared_ast.ScopeName.Map.find scope_uid ctxt.scopes).var_idmap
with
| None ->
Messages.raise_error
Message.raise_error
"Variable @{<yellow>\"%s\"@} not found inside scope @{<yellow>\"%a\"@}"
name Shared_ast.ScopeName.format_t scope_uid
| Some
@ -87,7 +87,7 @@ let get_variable_uid
-> (
match second_part with
| None ->
Messages.raise_error
Message.raise_error
"Subscope @{<yellow>\"%a\"@} of scope @{<yellow>\"%a\"@} cannot be \
selected by itself, please add \".<var>\" where <var> is a subscope \
variable."
@ -103,7 +103,7 @@ let get_variable_uid
(Desugared.Ast.ScopeDef.SubScopeVar
(subscope_var_name, v, Pos.no_pos))
| _ ->
Messages.raise_error
Message.raise_error
"Var @{<yellow>\"%s\"@} of subscope @{<yellow>\"%a\"@} in scope \
@{<yellow>\"%a\"@} does not exist, please check your command line \
arguments."
@ -122,7 +122,7 @@ let get_variable_uid
with
| Some state -> state
| None ->
Messages.raise_error
Message.raise_error
"State @{<yellow>\"%s\"@} is not found for variable \
@{<yellow>\"%s\"@} of scope @{<yellow>\"%a\"@}"
second_part first_part Shared_ast.ScopeName.format_t
@ -142,7 +142,7 @@ let driver source_file (options : Cli.options) : int =
options.plugins_dirs;
Cli.set_option_globals options;
if options.debug then Printexc.record_backtrace true;
Messages.emit_debug "Reading files...";
Message.emit_debug "Reading files...";
let filename = ref "" in
(match source_file with
| Pos.FileName f -> filename := f
@ -154,7 +154,7 @@ let driver source_file (options : Cli.options) : int =
(* Try to infer the language from the intput file extension. *)
let ext = Filename.extension !filename in
if ext = "" then
Messages.raise_error
Message.raise_error
"No file extension found for the file '%s'. (Try to add one or to \
specify the -l flag)"
!filename;
@ -163,7 +163,7 @@ let driver source_file (options : Cli.options) : int =
let language =
try List.assoc l Cli.languages
with Not_found ->
Messages.raise_error
Message.raise_error
"The selected language (%s) is not supported by Catala" l
in
Cli.locale_lang := language;
@ -174,7 +174,7 @@ let driver source_file (options : Cli.options) : int =
| `Plugin s -> (
try `Plugin (Plugin.find s)
with Not_found ->
Messages.raise_error
Message.raise_error
"The selected backend (%s) is not supported by Catala, nor was a \
plugin by this name found under %a"
backend
@ -203,11 +203,11 @@ let driver source_file (options : Cli.options) : int =
match source_file with
| FileName f -> f
| Contents _ ->
Messages.raise_error
Message.raise_error
"The Makefile backend does not work if the input is not a file"
in
let output_file, with_output = get_output ~ext:".d" () in
Messages.emit_debug "Writing list of dependencies to %s..."
Message.emit_debug "Writing list of dependencies to %s..."
(Option.value ~default:"stdout" output_file);
with_output
@@ fun oc ->
@ -220,7 +220,7 @@ let driver source_file (options : Cli.options) : int =
(String.concat "\\\n" prgm.program_source_files)
(String.concat "\\\n" prgm.program_source_files)
| (`Latex | `Html) as backend ->
Messages.emit_debug "Weaving literate program into %s"
Message.emit_debug "Weaving literate program into %s"
(match backend with `Latex -> "LaTeX" | `Html -> "HTML");
let output_file, with_output =
get_output_format ()
@ -236,7 +236,7 @@ let driver source_file (options : Cli.options) : int =
Literate.Html.ast_to_html language
~print_only_law:options.print_only_law
in
Messages.emit_debug "Writing to %s"
Message.emit_debug "Writing to %s"
(Option.value ~default:"stdout" output_file);
if options.wrap_weaved_output then
match backend with
@ -250,18 +250,18 @@ let driver source_file (options : Cli.options) : int =
| ( `Interpret | `Interpret_Lcalc | `Typecheck | `OCaml | `Python | `Scalc
| `Lcalc | `Dcalc | `Scopelang | `Exceptions | `Proof | `Plugin _ ) as
backend -> (
Messages.emit_debug "Name resolution...";
Message.emit_debug "Name resolution...";
let ctxt = Desugared.Name_resolution.form_context prgm in
let scope_uid = get_scope_uid options backend ctxt in
(* This uid is a Desugared identifier *)
let variable_uid = get_variable_uid options backend ctxt scope_uid in
Messages.emit_debug "Desugaring...";
Message.emit_debug "Desugaring...";
let prgm = Desugared.From_surface.translate_program ctxt prgm in
Messages.emit_debug "Disambiguating...";
Message.emit_debug "Disambiguating...";
let prgm = Desugared.Disambiguate.program prgm in
Messages.emit_debug "Linting...";
Message.emit_debug "Linting...";
Desugared.Linting.lint_program prgm;
Messages.emit_debug "Collecting rules...";
Message.emit_debug "Collecting rules...";
let exceptions_graphs =
Scopelang.From_desugared.build_exceptions_graph prgm
in
@ -274,7 +274,7 @@ let driver source_file (options : Cli.options) : int =
match variable_uid with
| Some variable_uid -> variable_uid
| None ->
Messages.raise_error
Message.raise_error
"Please provide a scope variable to analyze with the -v option."
in
Desugared.Print.print_exceptions_graph scope_uid variable_uid
@ -294,35 +294,35 @@ let driver source_file (options : Cli.options) : int =
prgm
| ( `Interpret | `Interpret_Lcalc | `Typecheck | `OCaml | `Python | `Scalc
| `Lcalc | `Dcalc | `Proof | `Plugin _ ) as backend -> (
Messages.emit_debug "Typechecking...";
Message.emit_debug "Typechecking...";
let type_ordering =
Scopelang.Dependency.check_type_cycles prgm.program_ctx.ctx_structs
prgm.program_ctx.ctx_enums
in
let prgm = Scopelang.Ast.type_program prgm in
Messages.emit_debug "Translating to default calculus...";
Message.emit_debug "Translating to default calculus...";
let prgm = Dcalc.From_scopelang.translate_program prgm in
let prgm =
if options.optimize then begin
Messages.emit_debug "Optimizing default calculus...";
Message.emit_debug "Optimizing default calculus...";
Shared_ast.Optimizations.optimize_program prgm
end
else prgm
in
(* Messages.emit_debug (Format.asprintf "Typechecking results :@\n%a"
(* Message.emit_debug (Format.asprintf "Typechecking results :@\n%a"
(Print.typ prgm.decl_ctx) typ); *)
match backend with
| `Typecheck ->
Messages.emit_debug "Typechecking again...";
Message.emit_debug "Typechecking again...";
let _ =
try Shared_ast.Typing.program prgm ~leave_unresolved:false
with Messages.CompilerError error_content ->
with Message.CompilerError error_content ->
raise
(Messages.CompilerError
(Messages.to_internal_error error_content))
(Message.CompilerError
(Message.to_internal_error error_content))
in
(* That's it! *)
Messages.emit_result "Typechecking successful!"
Message.emit_result "Typechecking successful!"
| `Dcalc ->
let _output_file, with_output = get_output_format () in
with_output
@ -349,20 +349,20 @@ let driver source_file (options : Cli.options) : int =
prgrm_dcalc_expr
| ( `Interpret | `OCaml | `Python | `Scalc | `Lcalc | `Proof | `Plugin _
| `Interpret_Lcalc ) as backend -> (
Messages.emit_debug "Typechecking again...";
Message.emit_debug "Typechecking again...";
let prgm =
try Shared_ast.Typing.program ~leave_unresolved:false prgm
with Messages.CompilerError error_content ->
with Message.CompilerError error_content ->
raise
(Messages.CompilerError
(Messages.to_internal_error error_content))
(Message.CompilerError
(Message.to_internal_error error_content))
in
if !Cli.check_invariants_flag then (
Messages.emit_debug "Checking invariants...";
Message.emit_debug "Checking invariants...";
let result = Dcalc.Invariants.check_all_invariants prgm in
if not result then
raise
(Messages.raise_internal_error
(Message.raise_internal_error
"Some Dcalc invariants are invalid"));
match backend with
| `Proof ->
@ -375,7 +375,7 @@ let driver source_file (options : Cli.options) : int =
Verification.Solver.solve_vc prgm.decl_ctx vcs
| `Interpret ->
Messages.emit_debug "Starting interpretation (dcalc)...";
Message.emit_debug "Starting interpretation (dcalc)...";
let results =
Shared_ast.Interpreter.interpret_program_dcalc prgm scope_uid
in
@ -384,18 +384,18 @@ let driver source_file (options : Cli.options) : int =
(fun ((v1, _), _) ((v2, _), _) -> String.compare v1 v2)
results
in
Messages.emit_debug "End of interpretation";
Messages.emit_result "Computation successful!%s"
Message.emit_debug "End of interpretation";
Message.emit_result "Computation successful!%s"
(if List.length results > 0 then " Results:" else "");
List.iter
(fun ((var, _), result) ->
Messages.emit_result "@[<hov 2>%s@ =@ %a@]" var
Message.emit_result "@[<hov 2>%s@ =@ %a@]" var
(Shared_ast.Print.expr ~debug:options.debug ())
result)
results
| `Plugin (Plugin.Dcalc p) ->
let output_file, _ = get_output_format ~ext:p.Plugin.extension () in
Messages.emit_debug "Compiling program through backend \"%s\"..."
Message.emit_debug "Compiling program through backend \"%s\"..."
p.Plugin.name;
p.Plugin.apply ~source_file ~output_file
~scope:
@ -406,10 +406,10 @@ let driver source_file (options : Cli.options) : int =
type_ordering
| (`OCaml | `Interpret_Lcalc | `Python | `Lcalc | `Scalc | `Plugin _)
as backend -> (
Messages.emit_debug "Compiling program into lambda calculus...";
Message.emit_debug "Compiling program into lambda calculus...";
let prgm =
if options.trace && options.avoid_exceptions then
Messages.raise_error
Message.raise_error
"Option --avoid_exceptions is not compatible with option \
--trace";
if options.avoid_exceptions then
@ -421,7 +421,7 @@ let driver source_file (options : Cli.options) : int =
in
let prgm =
if options.optimize then begin
Messages.emit_debug "Optimizing lambda calculus...";
Message.emit_debug "Optimizing lambda calculus...";
Shared_ast.Optimizations.optimize_program prgm
end
else Shared_ast.Program.untype prgm
@ -429,19 +429,19 @@ let driver source_file (options : Cli.options) : int =
let prgm =
if options.closure_conversion then (
if not options.avoid_exceptions then
Messages.raise_error
Message.raise_error
"Option --avoid_exceptions must be enabled for \
--closure_conversion";
Messages.emit_debug "Performing closure conversion...";
Message.emit_debug "Performing closure conversion...";
let prgm = Lcalc.Closure_conversion.closure_conversion prgm in
let prgm = Bindlib.unbox prgm in
let prgm =
if options.optimize then (
Messages.emit_debug "Optimizing lambda calculus...";
Message.emit_debug "Optimizing lambda calculus...";
Shared_ast.Optimizations.optimize_program prgm)
else prgm
in
Messages.emit_debug "Retyping lambda calculus...";
Message.emit_debug "Retyping lambda calculus...";
let prgm =
Shared_ast.Program.untype
(Shared_ast.Typing.program ~leave_unresolved:true prgm)
@ -463,7 +463,7 @@ let driver source_file (options : Cli.options) : int =
(Shared_ast.Print.program ~debug:options.debug)
prgm
| `Interpret_Lcalc ->
Messages.emit_debug "Starting interpretation (lcalc)...";
Message.emit_debug "Starting interpretation (lcalc)...";
let results =
Shared_ast.Interpreter.interpret_program_lcalc prgm scope_uid
in
@ -472,12 +472,12 @@ let driver source_file (options : Cli.options) : int =
(fun ((v1, _), _) ((v2, _), _) -> String.compare v1 v2)
results
in
Messages.emit_debug "End of interpretation";
Messages.emit_result "Computation successful!%s"
Message.emit_debug "End of interpretation";
Message.emit_result "Computation successful!%s"
(if List.length results > 0 then " Results:" else "");
List.iter
(fun ((var, _), result) ->
Messages.emit_result "@[<hov 2>%s@ =@ %a@]" var
Message.emit_result "@[<hov 2>%s@ =@ %a@]" var
(Shared_ast.Print.expr ~debug:options.debug ())
result)
results
@ -489,8 +489,8 @@ let driver source_file (options : Cli.options) : int =
in
with_output
@@ fun fmt ->
Messages.emit_debug "Compiling program into OCaml...";
Messages.emit_debug "Writing to %s..."
Message.emit_debug "Compiling program into OCaml...";
Message.emit_debug "Writing to %s..."
(Option.value ~default:"stdout" output_file);
Lcalc.To_ocaml.format_program fmt prgm type_ordering
| `Plugin (Plugin.Dcalc _) -> assert false
@ -498,7 +498,7 @@ let driver source_file (options : Cli.options) : int =
let output_file, _ =
get_output_format ~ext:p.Plugin.extension ()
in
Messages.emit_debug
Message.emit_debug
"Compiling program through backend \"%s\"..." p.Plugin.name;
p.Plugin.apply ~source_file ~output_file
~scope:
@ -528,8 +528,8 @@ let driver source_file (options : Cli.options) : int =
let output_file, with_output =
get_output_format ~ext:".py" ()
in
Messages.emit_debug "Compiling program into Python...";
Messages.emit_debug "Writing to %s..."
Message.emit_debug "Compiling program into Python...";
Message.emit_debug "Writing to %s..."
(Option.value ~default:"stdout" output_file);
with_output
@@ fun fmt ->
@ -537,9 +537,9 @@ let driver source_file (options : Cli.options) : int =
| `Plugin (Plugin.Dcalc _ | Plugin.Lcalc _) -> assert false
| `Plugin (Plugin.Scalc p) ->
let output_file, _ = get_output ~ext:p.Plugin.extension () in
Messages.emit_debug
Message.emit_debug
"Compiling program through backend \"%s\"..." p.Plugin.name;
Messages.emit_debug "Writing to %s..."
Message.emit_debug "Writing to %s..."
(Option.value ~default:"stdout" output_file);
p.Plugin.apply ~source_file ~output_file
~scope:
@ -549,15 +549,15 @@ let driver source_file (options : Cli.options) : int =
prgm type_ordering)))))));
0
with
| Messages.CompilerError content ->
| Message.CompilerError content ->
let bt = Printexc.get_raw_backtrace () in
Messages.emit_content content Error;
Message.emit_content content Error;
if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt;
-1
| Sys_error msg ->
let bt = Printexc.get_raw_backtrace () in
Messages.emit_content
(Messages.Content.of_string ("System error: " ^ msg))
Message.emit_content
(Message.Content.of_string ("System error: " ^ msg))
Error;
if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt;
-1

14
compiler/lcalc/compile_without_exceptions.ml
View File

@ -57,7 +57,7 @@ let rec trans_typ_keep (tau : typ) : typ =
| TStruct s -> TStruct s
| TEnum en -> TEnum en
| TOption _ ->
Messages.raise_internal_error
Message.raise_internal_error
"The type option should not appear before the dcalc -> lcalc \
translation step."
| TAny -> TAny
@ -101,7 +101,7 @@ let rec trans (ctx : typed ctx) (e : typed D.expr) : (lcalc, typed) boxed_gexpr
let m = Mark.get e in
let mark = m in
let pos = Expr.pos e in
(* Messages.emit_debug "%a" (Print.expr ~debug:true ()) e; *)
(* Message.emit_debug "%a" (Print.expr ~debug:true ()) e; *)
match Mark.remove e with
| EVar x ->
if (Var.Map.find x ctx.ctx_vars).info_pure then
@ -210,7 +210,7 @@ let rec trans (ctx : typed ctx) (e : typed D.expr) : (lcalc, typed) boxed_gexpr
in
Ast.OptionMonad.bind_var (trans ctx' body) var' (trans ctx arg) ~mark
| EApp { f = EApp { f = EOp { op = Op.Log _; _ }, _; args = _ }, _; _ } ->
Messages.raise_internal_error
Message.raise_internal_error
"Parameter trace is incompatible with parameter avoid_exceptions: some \
tracing logs were added while they are not supported."
(* Encoding of Fold, Filter, Map and Reduce is non trivial because we don't
@ -337,7 +337,7 @@ let rec trans (ctx : typed ctx) (e : typed D.expr) : (lcalc, typed) boxed_gexpr
| EApp { f = EOp { op = Op.Fold as op; _ }, _; _ }
| EApp { f = EOp { op = Op.Reduce as op; _ }, _; _ } ->
(* Cannot happend: list operator must be fully determined *)
Messages.raise_internal_error
Message.raise_internal_error
"List operator %a was not fully determined: some partial evaluation was \
found while compiling."
(Print.operator ~debug:false)
@ -436,12 +436,12 @@ let rec trans (ctx : typed ctx) (e : typed D.expr) : (lcalc, typed) boxed_gexpr
Ast.OptionMonad.return ~mark (Expr.eassert (Expr.evar e mark) mark))
(trans ctx e) ~mark
| EApp _ ->
Messages.raise_spanned_error (Expr.pos e)
Message.raise_spanned_error (Expr.pos e)
"Internal Error: found an EApp that does not satisfy the invariants when \
translating Dcalc to Lcalc without exceptions."
(* invalid invariant *)
| EOp _ ->
Messages.raise_spanned_error (Expr.pos e)
Message.raise_spanned_error (Expr.pos e)
"Internal Error: found an EOp that does not satisfy the invariants when \
translating Dcalc to Lcalc without exceptions."
| ELocation _ -> .
@ -568,7 +568,7 @@ let rec trans_scope_let (ctx : typed ctx) (s : typed D.expr scope_let) =
})
scope_let_expr scope_let_next
| { scope_let_kind = SubScopeVarDefinition; scope_let_pos = pos; _ } ->
Messages.raise_spanned_error pos
Message.raise_spanned_error pos
"Internal Error: found an SubScopeVarDefinition that does not satisfy \
the invariants when translating Dcalc to Lcalc without exceptions."
| {

4
compiler/lcalc/to_ocaml.ml
View File

@ -23,7 +23,7 @@ let find_struct (s : StructName.t) (ctx : decl_ctx) : typ StructField.Map.t =
try StructName.Map.find s ctx.ctx_structs
with Not_found ->
let s_name, pos = StructName.get_info s in
Messages.raise_spanned_error pos
Message.raise_spanned_error pos
"Internal Error: Structure %s was not found in the current environment."
s_name
@ -31,7 +31,7 @@ let find_enum (en : EnumName.t) (ctx : decl_ctx) : typ EnumConstructor.Map.t =
try EnumName.Map.find en ctx.ctx_enums
with Not_found ->
let en_name, pos = EnumName.get_info en in
Messages.raise_spanned_error pos
Message.raise_spanned_error pos
"Internal Error: Enumeration %s was not found in the current environment."
en_name

2
compiler/literate/html.ml
View File

@ -100,7 +100,7 @@ let wrap_html
(** Performs syntax highlighting on a piece of code by using Pygments and the
special Catala lexer. *)
let pygmentize_code (c : string Mark.pos) (lang : C.backend_lang) : string =
Messages.emit_debug "Pygmenting the code chunk %s"
Message.emit_debug "Pygmenting the code chunk %s"
(Pos.to_string (Mark.get c));
let output =
File.with_temp_file "catala_html_pygments" "in" ~contents:(Mark.remove c)

2
compiler/literate/latex.ml
View File

@ -306,5 +306,5 @@ let ast_to_latex
~pp_sep:(fun fmt () -> Format.fprintf fmt "\n\n")
(law_structure_to_latex language print_only_law)
fmt program.program_items;
Messages.emit_debug "Lines of Catala inside literate source code: %d"
Message.emit_debug "Lines of Catala inside literate source code: %d"
!lines_of_code

6
compiler/literate/literate_common.ml
View File

@ -64,7 +64,7 @@ let get_language_extension = function
| Pl -> "catala_pl"
let raise_failed_pandoc (command : string) (error_code : int) : 'a =
Messages.raise_error
Message.raise_error
"Weaving failed: pandoc command \"%s\" returned with error code %d" command
error_code
@ -112,7 +112,7 @@ let check_exceeding_lines
Uutf.String.fold_utf_8 (fun (acc : int) _ _ -> acc + 1) 0 s
in
if len_s > max_len then
Messages.emit_warning
Message.emit_warning
"@[<v>The line @{<bold;yellow>%d@} in @{<bold;magenta>%s@} is \
exceeding @{<bold;red}%d@} characters:@,\
%s@{<red>%s@}@]"
@ -134,7 +134,7 @@ let call_pygmentize ?lang args =
let cmd = "pygmentize" in
let check_exit n =
if n <> 0 then
Messages.raise_error
Message.raise_error
"Weaving failed: pygmentize command %S returned with error code %d"
(String.concat " " (cmd :: args))
n

4
compiler/plugin.ml
View File

@ -59,9 +59,9 @@ let find name = Hashtbl.find backend_plugins (String.lowercase_ascii name)
let load_file f =
try
Dynlink.loadfile f;
Messages.emit_debug "Plugin %S loaded" f
Message.emit_debug "Plugin %S loaded" f
with e ->
Messages.emit_warning "Could not load plugin %S: %s" f
Message.emit_warning "Could not load plugin %S: %s" f
(Printexc.to_string e)
let rec load_dir d =

8
compiler/plugins/api_web.ml
View File

@ -248,7 +248,7 @@ module To_jsoo = struct
(fun fmt (cname, typ) ->
match Mark.remove typ with
| TTuple _ ->
Messages.raise_spanned_error (Mark.get typ)
Message.raise_spanned_error (Mark.get typ)
"Tuples aren't supported yet in the conversion to JS"
| _ ->
Format.fprintf fmt
@ -273,7 +273,7 @@ module To_jsoo = struct
(fun fmt (cname, typ) ->
match Mark.remove typ with
| TTuple _ ->
Messages.raise_spanned_error (Mark.get typ)
Message.raise_spanned_error (Mark.get typ)
"Tuples aren't yet supported in the conversion to JS..."
| TLit TUnit ->
Format.fprintf fmt "@[<hv 2>| \"%a\" ->@ %a.%a ()@]"
@ -437,7 +437,7 @@ let apply
ignore scope;
File.with_formatter_of_opt_file output_file (fun fmt ->
Cli.trace_flag := true;
Messages.emit_debug "Writing OCaml code to %s..."
Message.emit_debug "Writing OCaml code to %s..."
(Option.value ~default:"stdout" output_file);
To_ocaml.format_program fmt prgm type_ordering);
@ -464,7 +464,7 @@ let apply
filename_without_ext
in
with_formatter (fun fmt ->
Messages.emit_debug "Writing JSOO API code to %s..."
Message.emit_debug "Writing JSOO API code to %s..."
(Option.value ~default:"stdout" jsoo_output_file);
To_jsoo.format_program fmt module_name prgm type_ordering)

4
compiler/plugins/json_schema.ml
View File

@ -223,13 +223,13 @@ let apply
match scope with
| Some s ->
File.with_formatter_of_opt_file output_file (fun fmt ->
Messages.emit_debug
Message.emit_debug
"Writing JSON schema corresponding to the scope '%a' to the file \
%s..."
ScopeName.format_t s
(Option.value ~default:"stdout" output_file);
To_json.format_program fmt s prgm)
| None ->
Messages.raise_error "A scope must be specified for the plugin: %s" name
Message.raise_error "A scope must be specified for the plugin: %s" name
let () = Driver.Plugin.register_lcalc ~name ~extension apply

6
compiler/plugins/lazy_interp.ml
View File

@ -20,7 +20,7 @@ open Shared_ast
(* -- Definition of the lazy interpreter -- *)
let log fmt = Format.ifprintf Format.err_formatter (fmt ^^ "@\n")
let error e = Messages.raise_spanned_error (Expr.pos e)
let error e = Message.raise_spanned_error (Expr.pos e)
let noassert = true
type laziness_level = {
@ -186,7 +186,7 @@ let rec lazy_eval :
log "@[<hov 5>EVAL %a@]" Expr.format e;
lazy_eval ctx env llevel e
| _ :: _ :: _ ->
Messages.raise_multispanned_error
Message.raise_multispanned_error
((None, Expr.mark_pos m)
:: List.map (fun (e, _) -> None, Expr.pos e) excs)
"Conflicting exceptions")
@ -257,7 +257,7 @@ let extension = ".out" (* unused *)
let apply ~source_file ~output_file ~scope prg _type_ordering =
let scope =
match scope with
| None -> Messages.raise_error "A scope must be specified"
| None -> Message.raise_error "A scope must be specified"
| Some s -> s
in
ignore source_file;

2
compiler/scalc/from_lcalc.ml
View File

@ -38,7 +38,7 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : A.block * A.expr =
with Not_found -> (
try A.EFunc (Var.Map.find v ctxt.func_dict)
with Not_found ->
Messages.raise_spanned_error (Expr.pos expr)
Message.raise_spanned_error (Expr.pos expr)
"Var not found in lambda→scalc: %a@\nknown: @[<hov>%a@]@\n"
Print.var_debug v
(Format.pp_print_list ~pp_sep:Format.pp_print_space

12
compiler/scopelang/dependency.ml
View File

@ -115,7 +115,7 @@ let build_program_dep_graph (prgm : 'm Ast.program) : SDependencies.t =
(fun glo_name (expr, _) g ->
let used_defs = expr_used_defs expr in
if VMap.mem (Topdef glo_name) used_defs then
Messages.raise_spanned_error
Message.raise_spanned_error
(Mark.get (TopdefName.get_info glo_name))
"The Topdef %a has a definition that refers to itself, which is \
forbidden since Catala does not provide recursion"
@ -133,7 +133,7 @@ let build_program_dep_graph (prgm : 'm Ast.program) : SDependencies.t =
(fun g rule ->
let used_defs = rule_used_defs rule in
if VMap.mem (Scope scope_name) used_defs then
Messages.raise_spanned_error
Message.raise_spanned_error
(Mark.get (ScopeName.get_info scope.Ast.scope_decl_name))
"The scope %a is calling into itself as a subscope, which is \
forbidden since Catala does not provide recursion"
@ -188,7 +188,7 @@ let check_for_cycle_in_defs (g : SDependencies.t) : unit =
cycle
(List.tl cycle @ [List.hd cycle])
in
Messages.raise_multispanned_error spans
Message.raise_multispanned_error spans
"@[<hov 2>Cyclic dependency detected between the following scopes:@ \
@[<hv>%a@]@]"
(Format.pp_print_list
@ -279,7 +279,7 @@ let build_type_graph (structs : struct_ctx) (enums : enum_ctx) : TDependencies.t
TVertexSet.fold
(fun used g ->
if TVertex.equal used def then
Messages.raise_spanned_error (Mark.get typ)
Message.raise_spanned_error (Mark.get typ)
"The type %a is defined using itself, which is forbidden \
since Catala does not provide recursive types"
TVertex.format_t used
@ -301,7 +301,7 @@ let build_type_graph (structs : struct_ctx) (enums : enum_ctx) : TDependencies.t
TVertexSet.fold
(fun used g ->
if TVertex.equal used def then
Messages.raise_spanned_error (Mark.get typ)
Message.raise_spanned_error (Mark.get typ)
"The type %a is defined using itself, which is forbidden \
since Catala does not provide recursive types"
TVertex.format_t used
@ -344,6 +344,6 @@ let check_type_cycles (structs : struct_ctx) (enums : enum_ctx) : TVertex.t list
])
scc)
in
Messages.raise_multispanned_error spans
Message.raise_multispanned_error spans
"Cyclic dependency detected between types!");
List.rev (TTopologicalTraversal.fold (fun v acc -> v :: acc) g [])

10
compiler/scopelang/from_desugared.ml
View File

@ -77,7 +77,7 @@ let rec translate_expr (ctx : ctx) (e : Desugared.Ast.expr) :
(* Note: this could only happen if disambiguation was disabled. If we want
to support it, we should still allow this case when the field has only
one possible matching structure *)
Messages.raise_spanned_error (Expr.mark_pos m)
Message.raise_spanned_error (Expr.mark_pos m)
"Ambiguous structure field access"
| EDStructAccess { e; field; name_opt = Some name } ->
let e' = translate_expr ctx e in
@ -87,7 +87,7 @@ let rec translate_expr (ctx : ctx) (e : Desugared.Ast.expr) :
(IdentName.Map.find field ctx.decl_ctx.ctx_struct_fields)
with Not_found ->
(* Should not happen after disambiguation *)
Messages.raise_spanned_error (Expr.mark_pos m)
Message.raise_spanned_error (Expr.mark_pos m)
"Field @{<yellow>\"%s\"@} does not belong to structure \
@{<yellow>\"%a\"@}"
field StructName.format_t name
@ -190,7 +190,7 @@ let rule_to_exception_graph (scope : Desugared.Ast.scope) = function
match Mark.remove scope_def.Desugared.Ast.scope_def_io.io_input with
| OnlyInput when not (RuleName.Map.is_empty var_def) ->
(* If the variable is tagged as input, then it shall not be redefined. *)
Messages.raise_multispanned_error
Message.raise_multispanned_error
((Some "Incriminated variable:", Mark.get (ScopeVar.get_info var))
:: List.map
(fun (rule, _) ->
@ -243,7 +243,7 @@ let rule_to_exception_graph (scope : Desugared.Ast.scope) = function
Mark.remove scope_def.Desugared.Ast.scope_def_io.io_input
with
| NoInput ->
Messages.raise_multispanned_error
Message.raise_multispanned_error
(( Some "Incriminated subscope:",
Mark.get (SubScopeName.get_info sscope) )
:: ( Some "Incriminated variable:",
@ -258,7 +258,7 @@ let rule_to_exception_graph (scope : Desugared.Ast.scope) = function
| OnlyInput when RuleName.Map.is_empty def && not is_cond ->
(* If the subscope variable is tagged as input, then it shall be
defined. *)
Messages.raise_multispanned_error
Message.raise_multispanned_error
[
( Some "Incriminated subscope:",
Mark.get (SubScopeName.get_info sscope) );

6
compiler/shared_ast/expr.ml
View File

@ -89,12 +89,12 @@ module Box = struct
match fv b with
| [] -> ()
| [h] ->
Messages.raise_internal_error
Message.raise_internal_error
"The boxed term is not closed the variable %s is free in the global \
context"
h
| l ->
Messages.raise_internal_error
Message.raise_internal_error
"The boxed term is not closed the variables %a is free in the global \
context"
(Format.pp_print_list
@ -792,7 +792,7 @@ let make_app e args pos =
tr
| TAny -> fty.ty
| _ ->
Messages.raise_internal_error
Message.raise_internal_error
"wrong type: found %a while expecting either an Arrow or Any"
Print.typ_debug fty.ty))
(List.map Mark.get (e :: args))

66
compiler/shared_ast/interpreter.ml
View File

@ -53,23 +53,23 @@ let print_log entry infos pos e =
if !Cli.trace_flag then
match entry with
| VarDef _ ->
Messages.emit_log "%s%a %a: @{<green>%s@}" !indent_str Print.log_entry
Message.emit_log "%s%a %a: @{<green>%s@}" !indent_str Print.log_entry
entry Print.uid_list infos
(Messages.unformat (fun ppf ->
(Message.unformat (fun ppf ->
Print.expr ~hide_function_body:true () ppf e))
| PosRecordIfTrueBool -> (
match pos <> Pos.no_pos, Mark.remove e with
| true, ELit (LBool true) ->
Messages.emit_log "%s@[<v>%a@{<green>Definition applied@}:@,%a@]"
Message.emit_log "%s@[<v>%a@{<green>Definition applied@}:@,%a@]"
!indent_str Print.log_entry entry Pos.format_loc_text pos
| _ -> ())
| BeginCall ->
Messages.emit_log "%s%a %a" !indent_str Print.log_entry entry
Message.emit_log "%s%a %a" !indent_str Print.log_entry entry
Print.uid_list infos;
indent_str := !indent_str ^ " "
| EndCall ->
indent_str := String.sub !indent_str 0 (String.length !indent_str - 2);
Messages.emit_log "%s%a %a" !indent_str Print.log_entry entry
Message.emit_log "%s%a %a" !indent_str Print.log_entry entry
Print.uid_list infos
exception CatalaException of except
@ -134,19 +134,19 @@ let rec evaluate_operator
in
try f x y with
| Division_by_zero ->
Messages.raise_multispanned_error
Message.raise_multispanned_error
[
Some "The division operator:", pos;
Some "The null denominator:", Expr.pos (List.nth args 1);
]
"division by zero at runtime"
| Runtime.UncomparableDurations ->
Messages.raise_multispanned_error (get_binop_args_pos args)
Message.raise_multispanned_error (get_binop_args_pos args)
"Cannot compare together durations that cannot be converted to a \
precise number of days"
in
let err () =
Messages.raise_multispanned_error
Message.raise_multispanned_error
([Some "Operator:", pos]
@ List.mapi
(fun i arg ->
@ -191,7 +191,7 @@ let rec evaluate_operator
match evaluate_expr (Mark.copy e' (EApp { f; args = [e'] })) with
| ELit (LBool b), _ -> b
| _ ->
Messages.raise_spanned_error
Message.raise_spanned_error
(Expr.pos (List.nth args 0))
"This predicate evaluated to something else than a boolean \
(should not happen if the term was well-typed)")
@ -384,7 +384,7 @@ let rec evaluate_expr :
let pos = Expr.mark_pos m in
match Mark.remove e with
| EVar _ ->
Messages.raise_spanned_error pos
Message.raise_spanned_error pos
"free variable found at evaluation (should not happen if term was \
well-typed)"
| EApp { f = e1; args } -> (
@ -398,13 +398,13 @@ let rec evaluate_expr :
evaluate_expr ctx
(Bindlib.msubst binder (Array.of_list (List.map Mark.remove args)))
else
Messages.raise_spanned_error pos
Message.raise_spanned_error pos
"wrong function call, expected %d arguments, got %d"
(Bindlib.mbinder_arity binder)
(List.length args)
| EOp { op; _ } -> evaluate_operator (evaluate_expr ctx) op m args
| _ ->
Messages.raise_spanned_error pos
Message.raise_spanned_error pos
"function has not been reduced to a lambda at evaluation (should not \
happen if the term was well-typed")
| (EAbs _ | ELit _ | EOp _) as e -> Mark.add m e (* these are values *)
@ -427,19 +427,19 @@ let rec evaluate_expr :
match Mark.remove e with
| EStruct { fields = es; name } -> (
if not (StructName.equal s name) then
Messages.raise_multispanned_error
Message.raise_multispanned_error
[None, pos; None, Expr.pos e]
"Error during struct access: not the same structs (should not happen \
if the term was well-typed)";
match StructField.Map.find_opt field es with
| Some e' -> e'
| None ->
Messages.raise_spanned_error (Expr.pos e)
Message.raise_spanned_error (Expr.pos e)
"Invalid field access %a in struct %a (should not happen if the term \
was well-typed)"
StructField.format_t field StructName.format_t s)
| _ ->
Messages.raise_spanned_error (Expr.pos e)
Message.raise_spanned_error (Expr.pos e)
"The expression %a should be a struct %a but is not (should not happen \
if the term was well-typed)"
(Print.expr ()) e StructName.format_t s)
@ -448,7 +448,7 @@ let rec evaluate_expr :
match evaluate_expr ctx e1 with
| ETuple es, _ when List.length es = size -> List.nth es index
| e ->
Messages.raise_spanned_error (Expr.pos e)
Message.raise_spanned_error (Expr.pos e)
"The expression %a was expected to be a tuple of size %d (should not \
happen if the term was well-typed)"
(Print.expr ()) e size)
@ -461,7 +461,7 @@ let rec evaluate_expr :
match Mark.remove e with
| EInj { e = e1; cons; name = name' } ->
if not (EnumName.equal name name') then
Messages.raise_multispanned_error
Message.raise_multispanned_error
[None, Expr.pos e; None, Expr.pos e1]
"Error during match: two different enums found (should not happen if \
the term was well-typed)";
@ -469,14 +469,14 @@ let rec evaluate_expr :
match EnumConstructor.Map.find_opt cons cases with
| Some es_n -> es_n
| None ->
Messages.raise_spanned_error (Expr.pos e)
Message.raise_spanned_error (Expr.pos e)
"sum type index error (should not happen if the term was \
well-typed)"
in
let new_e = Mark.add m (EApp { f = es_n; args = [e1] }) in
evaluate_expr ctx new_e
| _ ->
Messages.raise_spanned_error (Expr.pos e)
Message.raise_spanned_error (Expr.pos e)
"Expected a term having a sum type as an argument to a match (should \
not happen if the term was well-typed")
| EIfThenElse { cond; etrue; efalse } -> (
@ -486,7 +486,7 @@ let rec evaluate_expr :
| ELit (LBool true) -> evaluate_expr ctx etrue
| ELit (LBool false) -> evaluate_expr ctx efalse
| _ ->
Messages.raise_spanned_error (Expr.pos cond)
Message.raise_spanned_error (Expr.pos cond)
"Expected a boolean literal for the result of this condition (should \
not happen if the term was well-typed)")
| EArray es ->
@ -503,22 +503,22 @@ let rec evaluate_expr :
f = EOp { op; _ }, _;
args = [((ELit _, _) as e1); ((ELit _, _) as e2)];
} ->
Messages.raise_spanned_error (Expr.pos e')
Message.raise_spanned_error (Expr.pos e')
"Assertion failed: %a %a %a" (Print.expr ()) e1
(Print.operator ~debug:!Cli.debug_flag)
op (Print.expr ()) e2
| _ ->
Messages.emit_debug "%a" (Print.expr ()) e';
Messages.raise_spanned_error (Expr.mark_pos m) "Assertion failed")
Message.emit_debug "%a" (Print.expr ()) e';
Message.raise_spanned_error (Expr.mark_pos m) "Assertion failed")
| _ ->
Messages.raise_spanned_error (Expr.pos e')
Message.raise_spanned_error (Expr.pos e')
"Expected a boolean literal for the result of this assertion \
(should not happen if the term was well-typed)")
| EEmptyError -> Mark.copy e EEmptyError
| EErrorOnEmpty e' -> (
match evaluate_expr ctx e' with
| EEmptyError, _ ->
Messages.raise_spanned_error (Expr.pos e')
Message.raise_spanned_error (Expr.pos e')
"This variable evaluated to an empty term (no rule that defined it \
applied in this situation)"
| e -> e)
@ -533,12 +533,12 @@ let rec evaluate_expr :
| ELit (LBool true) -> evaluate_expr ctx cons
| ELit (LBool false) -> Mark.copy e EEmptyError
| _ ->
Messages.raise_spanned_error (Expr.pos e)
Message.raise_spanned_error (Expr.pos e)
"Default justification has not been reduced to a boolean at \
evaluation (should not happen if the term was well-typed")
| 1 -> List.find (fun sub -> not (is_empty_error sub)) excepts
| _ ->
Messages.raise_multispanned_error
Message.raise_multispanned_error
(List.map
(fun except ->
Some "This consequence has a valid justification:", Expr.pos except)
@ -573,7 +573,7 @@ let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
Expr.option_enum mark_e
: (_, _) boxed_gexpr)
| _ ->
Messages.raise_spanned_error (Mark.get ty)
Message.raise_spanned_error (Mark.get ty)
"This scope needs input arguments to be executed. But the Catala \
built-in interpreter does not have a way to retrieve input \
values from the command line, so it cannot execute this scope. \
@ -592,12 +592,12 @@ let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
(fun (fld, e) -> StructField.get_info fld, e)
(StructField.Map.bindings fields)
| _ ->
Messages.raise_spanned_error (Expr.pos e)
Message.raise_spanned_error (Expr.pos e)
"The interpretation of a program should always yield a struct \
corresponding to the scope variables"
end
| _ ->
Messages.raise_spanned_error (Expr.pos e)
Message.raise_spanned_error (Expr.pos e)
"The interpreter can only interpret terms starting with functions having \
thunked arguments"
@ -624,7 +624,7 @@ let interpret_program_dcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
(Bindlib.box EEmptyError, Expr.with_ty mark_e ty_out)
ty_in (Expr.mark_pos mark_e)
| _ ->
Messages.raise_spanned_error (Mark.get ty)
Message.raise_spanned_error (Mark.get ty)
"This scope needs input arguments to be executed. But the Catala \
built-in interpreter does not have a way to retrieve input \
values from the command line, so it cannot execute this scope. \
@ -643,11 +643,11 @@ let interpret_program_dcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
(fun (fld, e) -> StructField.get_info fld, e)
(StructField.Map.bindings fields)
| _ ->
Messages.raise_spanned_error (Expr.pos e)
Message.raise_spanned_error (Expr.pos e)
"The interpretation of a program should always yield a struct \
corresponding to the scope variables"
end
| _ ->
Messages.raise_spanned_error (Expr.pos e)
Message.raise_spanned_error (Expr.pos e)
"The interpreter can only interpret terms starting with functions having \
thunked arguments"

2
compiler/shared_ast/operator.ml
View File

@ -538,7 +538,7 @@ let resolve_overload ctx (op : overloaded t Mark.pos) (operands : typ list) :
in
resolve_overload_aux (Mark.remove op) operands
with Not_found ->
Messages.raise_multispanned_error
Message.raise_multispanned_error
((None, Mark.get op)
:: List.map
(fun ty ->

30
compiler/shared_ast/typing.ml
View File

@ -64,7 +64,7 @@ let rec typ_to_ast ~leave_unresolved (ty : unionfind_typ) : A.typ =
(* No polymorphism in Catala: type inference should return full types
without wildcards, and this function is used to recover the types after
typing. *)
Messages.raise_spanned_error pos
Message.raise_spanned_error pos
"Internal error: typing at this point could not be resolved"
let rec ast_to_typ (ty : A.typ) : unionfind_typ =
@ -138,7 +138,7 @@ let rec unify
(t1 : unionfind_typ)
(t2 : unionfind_typ) : unit =
let unify = unify ctx in
(* Messages.emit_debug "Unifying %a and %a" (format_typ ctx) t1 (format_typ
(* Message.emit_debug "Unifying %a and %a" (format_typ ctx) t1 (format_typ
ctx) t2; *)
let t1_repr = UnionFind.get (UnionFind.find t1) in
let t2_repr = UnionFind.get (UnionFind.find t2) in
@ -177,7 +177,7 @@ let handle_type_error ctx (A.AnyExpr e) t1 t2 =
let t2_repr = UnionFind.get (UnionFind.find t2) in
let t1_pos = Mark.get t1_repr in
let t2_pos = Mark.get t2_repr in
Messages.raise_multispanned_error_full
Message.raise_multispanned_error_full
[
( Some
(fun ppf ->
@ -348,7 +348,7 @@ and typecheck_expr_top_down :
(a, m) A.gexpr ->
(a, unionfind_typ A.custom) A.boxed_gexpr =
fun ~leave_unresolved ctx env tau e ->
(* Messages.emit_debug "Propagating type %a for naked_expr %a" (format_typ
(* Message.emit_debug "Propagating type %a for naked_expr %a" (format_typ
ctx) tau (Expr.format ctx) e; *)
let pos_e = Expr.pos e in
let () =
@ -381,7 +381,7 @@ and typecheck_expr_top_down :
match ty_opt with
| Some ty -> ty
| None ->
Messages.raise_spanned_error pos_e "Reference to %a not found"
Message.raise_spanned_error pos_e "Reference to %a not found"
(Print.expr ()) e
in
Expr.elocation loc (mark_with_tau_and_unify (ast_to_typ ty))
@ -416,7 +416,7 @@ and typecheck_expr_top_down :
(A.StructField.Map.bindings extra_fields)
in
if errs <> [] then
Messages.raise_multispanned_error errs
Message.raise_multispanned_error errs
"Mismatching field definitions for structure %a" A.StructName.format_t
name
in
@ -445,7 +445,7 @@ and typecheck_expr_top_down :
Printf.ksprintf failwith
"Disambiguation failed before reaching field %s" field
| _ ->
Messages.raise_spanned_error (Expr.pos e)
Message.raise_spanned_error (Expr.pos e)
"This is not a structure, cannot access field %s (%a)" field
(format_typ ctx) (ty e_struct')
in
@ -453,14 +453,14 @@ and typecheck_expr_top_down :
let str =
try A.StructName.Map.find name env.structs
with Not_found ->
Messages.raise_spanned_error pos_e "No structure %a found"
Message.raise_spanned_error pos_e "No structure %a found"
A.StructName.format_t name
in
let field =
let candidate_structs =
try A.IdentName.Map.find field ctx.ctx_struct_fields
with Not_found ->
Messages.raise_spanned_error
Message.raise_spanned_error
(Expr.mark_pos context_mark)
"Field @{<yellow>\"%s\"@} does not belong to structure \
@{<yellow>\"%a\"@} (no structure defines it)"
@ -468,7 +468,7 @@ and typecheck_expr_top_down :
in
try A.StructName.Map.find name candidate_structs
with Not_found ->
Messages.raise_spanned_error
Message.raise_spanned_error
(Expr.mark_pos context_mark)
"@[<hov>Field @{<yellow>\"%s\"@}@ does not belong to@ structure \
@{<yellow>\"%a\"@},@ but to %a@]"
@ -489,12 +489,12 @@ and typecheck_expr_top_down :
let str =
try A.StructName.Map.find name env.structs
with Not_found ->
Messages.raise_spanned_error pos_e "No structure %a found"
Message.raise_spanned_error pos_e "No structure %a found"
A.StructName.format_t name
in
try A.StructField.Map.find field str
with Not_found ->
Messages.raise_multispanned_error
Message.raise_multispanned_error
[
None, pos_e;
( Some "Structure %a declared here",
@ -606,7 +606,7 @@ and typecheck_expr_top_down :
match Env.get env v with
| Some t -> t
| None ->
Messages.raise_spanned_error pos_e
Message.raise_spanned_error pos_e
"Variable %s not found in the current context" (Bindlib.name_of v)
in
Expr.evar (Var.translate v) (mark_with_tau_and_unify tau')
@ -620,7 +620,7 @@ and typecheck_expr_top_down :
Expr.etuple es' mark
| A.ETupleAccess { e = e1; index; size } ->
if index >= size then
Messages.raise_spanned_error (Expr.pos e)
Message.raise_spanned_error (Expr.pos e)
"Tuple access out of bounds (%d/%d)" index size;
let tuple_ty =
TTuple
@ -635,7 +635,7 @@ and typecheck_expr_top_down :
Expr.etupleaccess e1' index size context_mark
| A.EAbs { binder; tys = t_args } ->
if Bindlib.mbinder_arity binder <> List.length t_args then
Messages.raise_spanned_error (Expr.pos e)
Message.raise_spanned_error (Expr.pos e)
"function has %d variables but was supplied %d types"
(Bindlib.mbinder_arity binder)
(List.length t_args)

2
compiler/surface/lexer_common.ml
View File

@ -60,7 +60,7 @@ let update_acc (lexbuf : lexbuf) : unit =
(** Error-generating helper *)
let raise_lexer_error (loc : Pos.t) (token : string) =
Messages.raise_spanned_error loc
Message.raise_spanned_error loc
"Parsing error after token \"%s\": what comes after is unknown" token
(** Associative list matching each punctuation string part of the Catala syntax

4
compiler/surface/parser.mly
View File

@ -130,7 +130,7 @@ let lident :=
| i = LIDENT ; {
match Localisation.lex_builtin i with
| Some _ ->
Messages.raise_spanned_error
Message.raise_spanned_error
(Pos.from_lpos $sloc)
"Reserved builtin name"
| None ->
@ -503,7 +503,7 @@ let scope_item :=
| Some Round ->
DateRounding(v), Mark.get v
| _ ->
Messages.raise_spanned_error
Message.raise_spanned_error
(Pos.from_lpos $loc(i))
"Expected the form 'date round increasing' or 'date round decreasing'"
}

6
compiler/surface/parser_driver.ml
View File

@ -111,7 +111,7 @@ let raise_parser_error
(last_good_loc : Pos.t option)
(token : string)
(msg : Format.formatter -> unit) : 'a =
Messages.raise_multispanned_error_full
Message.raise_multispanned_error_full
((Some (fun ppf -> Format.pp_print_string ppf "Error token:"), error_loc)
::
(match last_good_loc with
@ -271,7 +271,7 @@ let localised_parser : Cli.backend_lang -> lexbuf -> Ast.source_file = function
let rec parse_source_file
(source_file : Pos.input_file)
(language : Cli.backend_lang) : Ast.program =
Messages.emit_debug "Parsing %s"
Message.emit_debug "Parsing %s"
(match source_file with FileName s | Contents s -> s);
let lexbuf, input =
match source_file with
@ -279,7 +279,7 @@ let rec parse_source_file
try
let input = open_in source_file in
Sedlexing.Utf8.from_channel input, Some input
with Sys_error msg -> Messages.raise_error "System error: %s" msg)
with Sys_error msg -> Message.raise_error "System error: %s" msg)
| Contents contents -> Sedlexing.Utf8.from_string contents, None
in
let source_file_name =

6
compiler/verification/conditions.ml
View File

@ -135,7 +135,7 @@ let match_and_ignore_outer_reentrant_default (ctx : ctx) (e : typed expr) :
match Mark.remove body with
| EErrorOnEmpty e -> e
| _ ->
Messages.raise_spanned_error (Expr.pos e)
Message.raise_spanned_error (Expr.pos e)
"Internal error: this expression does not have the structure expected \
by the VC generator:\n\
%a"
@ -143,7 +143,7 @@ let match_and_ignore_outer_reentrant_default (ctx : ctx) (e : typed expr) :
| EErrorOnEmpty d ->
d (* input subscope variables and non-input scope variable *)
| _ ->
Messages.raise_spanned_error (Expr.pos e)
Message.raise_spanned_error (Expr.pos e)
"Internal error: this expression does not have the structure expected by \
the VC generator:\n\
%a"
@ -327,7 +327,7 @@ let rec generate_verification_conditions_scope_body_expr
let e = match_and_ignore_outer_reentrant_default ctx e in
ctx, [], [e]
| _ ->
Messages.raise_spanned_error (Expr.pos e)
Message.raise_spanned_error (Expr.pos e)
"Internal error: this assertion does not have the structure \
expected by the VC generator:\n\
%a"

10
compiler/verification/io.ml
View File

@ -144,9 +144,9 @@ module MakeBackendIO (B : Backend) = struct
(vc : Conditions.verification_condition * vc_encoding_result) : bool =
let vc, z3_vc = vc in
Messages.emit_debug "@[<v>For this variable:@,%a@,@]" Pos.format_loc_text
Message.emit_debug "@[<v>For this variable:@,%a@,@]" Pos.format_loc_text
(Expr.pos vc.Conditions.vc_guard);
Messages.emit_debug
Message.emit_debug
"@[<v>This verification condition was generated for @{<yellow>%s@}:@,\
%a@,\
with assertions:@,\
@ -159,16 +159,16 @@ module MakeBackendIO (B : Backend) = struct
match z3_vc with
| Success (encoding, backend_ctx) -> (
Messages.emit_debug "@[<v>The translation to Z3 is the following:@,%s@]"
Message.emit_debug "@[<v>The translation to Z3 is the following:@,%s@]"
(B.print_encoding encoding);
match B.solve_vc_encoding backend_ctx encoding with
| ProvenTrue -> true
| ProvenFalse model ->
Messages.emit_warning "%s" (print_negative_result vc backend_ctx model);
Message.emit_warning "%s" (print_negative_result vc backend_ctx model);
false
| Unknown -> failwith "The solver failed at proving or disproving the VC")
| Fail msg ->
Messages.emit_warning
Message.emit_warning
"@[<v>@{<yellow>[%a.%s]@} The translation to Z3 failed:@,%s@]"
ScopeName.format_t vc.vc_scope
(Bindlib.name_of (Mark.remove vc.vc_variable))

2
compiler/verification/solver.ml
View File

@ -49,4 +49,4 @@ let solve_vc
true z3_vcs
in
if all_proven then
Messages.emit_result "No errors found during the proof mode run."
Message.emit_result "No errors found during the proof mode run."

2
compiler/verification/z3backend.dummy.ml
View File

@ -18,7 +18,7 @@
without the expected backend. All functions print an error message and exit *)
let dummy () =
Catala_utils.Messages.raise_error
Catala_utils.Message.raise_error
"This instance of Catala was compiled without Z3 support."
module Io = struct

2
compiler/verification/z3backend.real.ml
View File

@ -825,7 +825,7 @@ module Backend = struct
add_z3constraint vc ctx
let init_backend () =
Messages.emit_debug "Running Z3 version %s" Version.to_string
Message.emit_debug "Running Z3 version %s" Version.to_string
let make_context (decl_ctx : decl_ctx) : backend_context =
let cfg =

20
french_law/catala_legifrance/api.ml
View File

@ -48,7 +48,7 @@ let get_token_aux (client_id : string) (client_secret : string) :
let get_token (client_id : string) (client_secret : string) : string Lwt.t =
let rec retry count =
if count = 0 then (
Messages.emit_debug "Too many retries, giving up\n";
Message.emit_debug "Too many retries, giving up\n";
exit 1)
else
let* resp, body = get_token_aux client_id client_secret in
@ -59,16 +59,16 @@ let get_token (client_id : string) (client_secret : string) : string Lwt.t =
|> Yojson.Basic.Util.member "access_token"
|> Yojson.Basic.Util.to_string
in
Messages.emit_debug "The LegiFrance API access token is %s" token;
Message.emit_debug "The LegiFrance API access token is %s" token;
Lwt.return token
end
else if Cohttp.Code.code_of_status resp = 400 then begin
Messages.emit_debug "The API access request returned code 400%s\n"
Message.emit_debug "The API access request returned code 400%s\n"
(if count > 1 then ", retrying..." else "");
retry (count - 1)
end
else begin
Messages.emit_debug
Message.emit_debug
"The API access token request went wrong ; status is %s and the body \
is\n\
%s"
@ -121,7 +121,7 @@ let run_request (request : unit -> (string * string) Lwt.t) :
if resp = "200 OK" then
try body |> Yojson.Basic.from_string with
| Yojson.Basic.Util.Type_error (msg, obj) ->
Messages.raise_error
Message.raise_error
"Error while parsing JSON answer from API: %s\n\
Specific JSON:\n\
%s\n\
@ -139,10 +139,10 @@ let run_request (request : unit -> (string * string) Lwt.t) :
with Failure _ ->
if n > 0 then (
Unix.sleep 2;
Messages.emit_debug "Retrying request...";
Message.emit_debug "Retrying request...";
try_n_times (n - 1))
else
Messages.raise_error
Message.raise_error
"The API request went wrong ; status is %s and the body is\n%s" resp
body
in
@ -163,7 +163,7 @@ let parse_id (id : string) : article_id =
else if Re.execp ceta_tex id then CETATEXT
else if Re.execp jorf_rex id then JORFARTI
else
Messages.raise_error
Message.raise_error
"LégiFrance ID \"%s\" does not correspond to an ID format recognized \
by the LégiFrance API"
id
@ -172,7 +172,7 @@ let parse_id (id : string) : article_id =
let retrieve_article (access_token : string) (obj : article_id) : article Lwt.t
=
Messages.emit_debug "Accessing article %s" obj.id;
Message.emit_debug "Accessing article %s" obj.id;
let* content =
run_request
(make_request access_token
@ -189,7 +189,7 @@ let raise_article_parsing_error
(json : Yojson.Basic.t)
(msg : string)
(obj : Yojson.Basic.t) =
Messages.raise_error
Message.raise_error
"Error while manipulating JSON answer from API: %s\n\
Specific JSON:\n\
%s\n\

18
french_law/catala_legifrance/catala_legifrance.ml
View File

@ -50,7 +50,7 @@ let check_article_expiration
Some new_version
else None
in
Messages.emit_warning
Message.emit_warning
"%s %s has expired! Its expiration date is %s according to \
LégiFrance.%s"
(Mark.remove law_heading.Surface.Ast.law_heading_name)
@ -113,7 +113,7 @@ let compare_to_versions
(law_article_text : law_article_text)
(access_token : Api.access_token) : unit Lwt.t =
let print_diff msg diff =
Messages.emit_warning "@[<v>%s@,%a@]" msg
Message.emit_warning "@[<v>%s@,%a@]" msg
(Format.pp_print_list (fun ppf chunk ->
match chunk with
| Diff.Equal words ->
@ -171,12 +171,12 @@ let include_legislative_text
let* article = Api.retrieve_article access_token id in
let text_to_return = Api.get_article_text article in
let to_insert = text_to_return in
Messages.emit_debug "Position: %s" (Pos.to_string_short pos);
Message.emit_debug "Position: %s" (Pos.to_string_short pos);
let file = Pos.get_file pos in
let include_line = Pos.get_start_line pos in
let ic = open_in file in
let new_file = file ^ ".new" in
Messages.emit_warning
Message.emit_warning
"LégiFrance inclusion detected, writing new contents to %s" new_file;
let oc = open_out new_file in
(* Pos.t lines start at 1 *)
@ -256,7 +256,7 @@ let driver_lwt
try
if debug then Cli.debug_flag := true;
if not (expiration || diff) then
Messages.raise_error
Message.raise_error
"You have to check at least something, see the list of options with \
--help";
let* access_token = Api.get_token client_id client_secret in
@ -281,9 +281,9 @@ let driver_lwt
in
prerr_endline "0";
Lwt.return 0
with Messages.CompilerError content ->
with Message.CompilerError content ->
let bt = Printexc.get_raw_backtrace () in
Messages.emit_content content Error;
Message.emit_content content Error;
if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt;
Lwt.return (-1)
@ -291,9 +291,9 @@ let driver file debug diff expiration custom_date client_id client_secret =
try
Lwt_main.run
(driver_lwt file debug diff expiration custom_date client_id client_secret)
with Messages.CompilerError content ->
with Message.CompilerError content ->
let bt = Printexc.get_raw_backtrace () in
Messages.emit_content content Error;
Message.emit_content content Error;
if Printexc.backtrace_status () then Printexc.print_raw_backtrace stderr bt;
-1

2
french_law/catala_legifrance/date.ml
View File

@ -55,7 +55,7 @@ let parse_expiration_date (date_format : date_format) (expiration_date : string)
Unix.tm_isdst = false;
})
with _ ->
Messages.raise_error "Error while parsing expiration date argument (%s)"
Message.raise_error "Error while parsing expiration date argument (%s)"
expiration_date
(** Prints an [Unix.tm] under the ISO formatting [YYYY-MM-DD] *)