From 10d147a8b16a72c406d6a4783e132fcbe24618db Mon Sep 17 00:00:00 2001 From: Aminata-Dev Date: Tue, 13 Jun 2023 11:27:45 +0200 Subject: [PATCH] Messages renamed to Message (lighter syntax) --- build_system/clerk_driver.ml | 32 ++--- compiler/catala_utils/file.ml | 2 +- compiler/dcalc/from_scopelang.ml | 14 +- compiler/dcalc/invariants.ml | 4 +- compiler/desugared/dependency.ml | 12 +- compiler/desugared/from_surface.ml | 96 ++++++------- compiler/desugared/linting.ml | 14 +- compiler/desugared/name_resolution.ml | 48 +++---- compiler/desugared/print.ml | 6 +- compiler/driver.ml | 128 +++++++++--------- compiler/lcalc/compile_without_exceptions.ml | 14 +- compiler/lcalc/to_ocaml.ml | 4 +- compiler/literate/html.ml | 2 +- compiler/literate/latex.ml | 2 +- compiler/literate/literate_common.ml | 6 +- compiler/plugin.ml | 4 +- compiler/plugins/api_web.ml | 8 +- compiler/plugins/json_schema.ml | 4 +- compiler/plugins/lazy_interp.ml | 6 +- compiler/scalc/from_lcalc.ml | 2 +- compiler/scopelang/dependency.ml | 12 +- compiler/scopelang/from_desugared.ml | 10 +- compiler/shared_ast/expr.ml | 6 +- compiler/shared_ast/interpreter.ml | 66 ++++----- compiler/shared_ast/operator.ml | 2 +- compiler/shared_ast/typing.ml | 30 ++-- compiler/surface/lexer_common.ml | 2 +- compiler/surface/parser.mly | 4 +- compiler/surface/parser_driver.ml | 6 +- compiler/verification/conditions.ml | 6 +- compiler/verification/io.ml | 10 +- compiler/verification/solver.ml | 2 +- compiler/verification/z3backend.dummy.ml | 2 +- compiler/verification/z3backend.real.ml | 2 +- french_law/catala_legifrance/api.ml | 20 +-- .../catala_legifrance/catala_legifrance.ml | 18 +-- french_law/catala_legifrance/date.ml | 2 +- 37 files changed, 304 insertions(+), 304 deletions(-) diff --git a/build_system/clerk_driver.ml b/build_system/clerk_driver.ml index 6cf2c529..4d192a96 100644 --- a/build_system/clerk_driver.ml +++ b/build_system/clerk_driver.ml @@ -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 @{%s@}") + (Message.emit_warning "No test case found for @{%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 diff --git a/compiler/catala_utils/file.ml b/compiler/catala_utils/file.ml index ee31a3ab..0aadad13 100644 --- a/compiler/catala_utils/file.ml +++ b/compiler/catala_utils/file.ml @@ -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 = diff --git a/compiler/dcalc/from_scopelang.ml b/compiler/dcalc/from_scopelang.ml index a413d406..89893829 100644 --- a/compiler/dcalc/from_scopelang.ml +++ b/compiler/dcalc/from_scopelang.ml @@ -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:", diff --git a/compiler/dcalc/invariants.ml b/compiler/dcalc/invariants.ml index def87e23..459497ac 100644 --- a/compiler/dcalc/invariants.ml +++ b/compiler/dcalc/invariants.ml @@ -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 diff --git a/compiler/desugared/dependency.ml b/compiler/desugared/dependency.ml index 6f9684be..67243b93 100644 --- a/compiler/desugared/dependency.ml +++ b/compiler/desugared/dependency.ml @@ -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 "@[Cyclic dependency detected between the following variables of \ scope %a:@ @[%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) diff --git a/compiler/desugared/from_surface.ml b/compiler/desugared/from_surface.ml index 406c26f3..7d39f467 100644 --- a/compiler/desugared/from_surface.ml +++ b/compiler/desugared/from_surface.ml @@ -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 \ diff --git a/compiler/desugared/linting.ml b/compiler/desugared/linting.ml index 6dbe4309..2ab9d75f 100644 --- a/compiler/desugared/linting.ml +++ b/compiler/desugared/linting.ml @@ -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 @{\"%a\"@}, the variable @{\"%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 @{\"%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 @{\"%a\"@} of struct @{\"%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 @{\"%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 @{\"%a\"@} of enumeration \ @{\"%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 @{\"%s\"@} outputs. Did you forget \ diff --git a/compiler/desugared/name_resolution.ml b/compiler/desugared/name_resolution.ml index 151b6519..de8e1c77 100644 --- a/compiler/desugared/name_resolution.ml +++ b/compiler/desugared/name_resolution.ml @@ -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) "@{\"%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 @{\"%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 @{\"%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 @{\"%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) "@{\"%s\"@}: this scope has not been declared anywhere, is it \ a typo?" diff --git a/compiler/desugared/print.ml b/compiler/desugared/print.ml index 8e2c1dc8..6f608b39 100644 --- a/compiler/desugared/print.ml +++ b/compiler/desugared/print.ml @@ -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 \ @{\"%a\"@} of scope @{\"%a\"@}." Ast.ScopeDef.format_t var ScopeName.format_t scope; Dependency.ExceptionsDependencies.iter_vertex (fun ex -> - Messages.emit_result + Message.emit_result "@[Definitions with label @{\"%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)) diff --git a/compiler/driver.ml b/compiler/driver.ml index e58416ba..056d4990 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -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 @{\"%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 @{\"%s\"@} not found inside scope @{\"%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 @{\"%a\"@} of scope @{\"%a\"@} cannot be \ selected by itself, please add \".\" where 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 @{\"%s\"@} of subscope @{\"%a\"@} in scope \ @{\"%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 @{\"%s\"@} is not found for variable \ @{\"%s\"@} of scope @{\"%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 "@[%s@ =@ %a@]" var + Message.emit_result "@[%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 "@[%s@ =@ %a@]" var + Message.emit_result "@[%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 diff --git a/compiler/lcalc/compile_without_exceptions.ml b/compiler/lcalc/compile_without_exceptions.ml index 7929bf54..36433604 100644 --- a/compiler/lcalc/compile_without_exceptions.ml +++ b/compiler/lcalc/compile_without_exceptions.ml @@ -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." | { diff --git a/compiler/lcalc/to_ocaml.ml b/compiler/lcalc/to_ocaml.ml index 0169ca3d..076c1886 100644 --- a/compiler/lcalc/to_ocaml.ml +++ b/compiler/lcalc/to_ocaml.ml @@ -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 diff --git a/compiler/literate/html.ml b/compiler/literate/html.ml index 1b0558e2..03ac9160 100644 --- a/compiler/literate/html.ml +++ b/compiler/literate/html.ml @@ -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) diff --git a/compiler/literate/latex.ml b/compiler/literate/latex.ml index ae16bf6c..60212509 100644 --- a/compiler/literate/latex.ml +++ b/compiler/literate/latex.ml @@ -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 diff --git a/compiler/literate/literate_common.ml b/compiler/literate/literate_common.ml index ef68561d..31a41420 100644 --- a/compiler/literate/literate_common.ml +++ b/compiler/literate/literate_common.ml @@ -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 "@[The line @{%d@} in @{%s@} is \ exceeding @{%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 diff --git a/compiler/plugin.ml b/compiler/plugin.ml index 5b1d7223..6bb57d60 100644 --- a/compiler/plugin.ml +++ b/compiler/plugin.ml @@ -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 = diff --git a/compiler/plugins/api_web.ml b/compiler/plugins/api_web.ml index 3431a739..883e2d03 100644 --- a/compiler/plugins/api_web.ml +++ b/compiler/plugins/api_web.ml @@ -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 "@[| \"%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) diff --git a/compiler/plugins/json_schema.ml b/compiler/plugins/json_schema.ml index 66dba11d..edcc0fcf 100644 --- a/compiler/plugins/json_schema.ml +++ b/compiler/plugins/json_schema.ml @@ -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 diff --git a/compiler/plugins/lazy_interp.ml b/compiler/plugins/lazy_interp.ml index acb05ca7..f5910078 100644 --- a/compiler/plugins/lazy_interp.ml +++ b/compiler/plugins/lazy_interp.ml @@ -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 "@[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; diff --git a/compiler/scalc/from_lcalc.ml b/compiler/scalc/from_lcalc.ml index 9f934826..f5c000c6 100644 --- a/compiler/scalc/from_lcalc.ml +++ b/compiler/scalc/from_lcalc.ml @@ -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: @[%a@]@\n" Print.var_debug v (Format.pp_print_list ~pp_sep:Format.pp_print_space diff --git a/compiler/scopelang/dependency.ml b/compiler/scopelang/dependency.ml index 653d8cea..6f108841 100644 --- a/compiler/scopelang/dependency.ml +++ b/compiler/scopelang/dependency.ml @@ -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 "@[Cyclic dependency detected between the following scopes:@ \ @[%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 []) diff --git a/compiler/scopelang/from_desugared.ml b/compiler/scopelang/from_desugared.ml index 0cb2ac02..f525f1ea 100644 --- a/compiler/scopelang/from_desugared.ml +++ b/compiler/scopelang/from_desugared.ml @@ -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 @{\"%s\"@} does not belong to structure \ @{\"%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) ); diff --git a/compiler/shared_ast/expr.ml b/compiler/shared_ast/expr.ml index f55f6940..12f172b1 100644 --- a/compiler/shared_ast/expr.ml +++ b/compiler/shared_ast/expr.ml @@ -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)) diff --git a/compiler/shared_ast/interpreter.ml b/compiler/shared_ast/interpreter.ml index 4aec7537..68455cd8 100644 --- a/compiler/shared_ast/interpreter.ml +++ b/compiler/shared_ast/interpreter.ml @@ -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: @{%s@}" !indent_str Print.log_entry + Message.emit_log "%s%a %a: @{%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@[%a@{Definition applied@}:@,%a@]" + Message.emit_log "%s@[%a@{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" diff --git a/compiler/shared_ast/operator.ml b/compiler/shared_ast/operator.ml index 5a7a2533..d24821f6 100644 --- a/compiler/shared_ast/operator.ml +++ b/compiler/shared_ast/operator.ml @@ -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 -> diff --git a/compiler/shared_ast/typing.ml b/compiler/shared_ast/typing.ml index 08c69c42..77d6fe2b 100644 --- a/compiler/shared_ast/typing.ml +++ b/compiler/shared_ast/typing.ml @@ -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 @{\"%s\"@} does not belong to structure \ @{\"%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) "@[Field @{\"%s\"@}@ does not belong to@ structure \ @{\"%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) diff --git a/compiler/surface/lexer_common.ml b/compiler/surface/lexer_common.ml index 5d48838c..40748ef7 100644 --- a/compiler/surface/lexer_common.ml +++ b/compiler/surface/lexer_common.ml @@ -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 diff --git a/compiler/surface/parser.mly b/compiler/surface/parser.mly index e326de99..a3e18981 100644 --- a/compiler/surface/parser.mly +++ b/compiler/surface/parser.mly @@ -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'" } diff --git a/compiler/surface/parser_driver.ml b/compiler/surface/parser_driver.ml index d501abda..39804cd1 100644 --- a/compiler/surface/parser_driver.ml +++ b/compiler/surface/parser_driver.ml @@ -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 = diff --git a/compiler/verification/conditions.ml b/compiler/verification/conditions.ml index 27d9552f..5687e44a 100644 --- a/compiler/verification/conditions.ml +++ b/compiler/verification/conditions.ml @@ -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" diff --git a/compiler/verification/io.ml b/compiler/verification/io.ml index 143782ee..69705e83 100644 --- a/compiler/verification/io.ml +++ b/compiler/verification/io.ml @@ -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 "@[For this variable:@,%a@,@]" Pos.format_loc_text + Message.emit_debug "@[For this variable:@,%a@,@]" Pos.format_loc_text (Expr.pos vc.Conditions.vc_guard); - Messages.emit_debug + Message.emit_debug "@[This verification condition was generated for @{%s@}:@,\ %a@,\ with assertions:@,\ @@ -159,16 +159,16 @@ module MakeBackendIO (B : Backend) = struct match z3_vc with | Success (encoding, backend_ctx) -> ( - Messages.emit_debug "@[The translation to Z3 is the following:@,%s@]" + Message.emit_debug "@[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 "@[@{[%a.%s]@} The translation to Z3 failed:@,%s@]" ScopeName.format_t vc.vc_scope (Bindlib.name_of (Mark.remove vc.vc_variable)) diff --git a/compiler/verification/solver.ml b/compiler/verification/solver.ml index fa9a180b..d31791f7 100644 --- a/compiler/verification/solver.ml +++ b/compiler/verification/solver.ml @@ -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." diff --git a/compiler/verification/z3backend.dummy.ml b/compiler/verification/z3backend.dummy.ml index 8e673652..7388fb75 100644 --- a/compiler/verification/z3backend.dummy.ml +++ b/compiler/verification/z3backend.dummy.ml @@ -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 diff --git a/compiler/verification/z3backend.real.ml b/compiler/verification/z3backend.real.ml index d1a3a31e..d21623bf 100644 --- a/compiler/verification/z3backend.real.ml +++ b/compiler/verification/z3backend.real.ml @@ -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 = diff --git a/french_law/catala_legifrance/api.ml b/french_law/catala_legifrance/api.ml index bb15a6fe..ff475cce 100644 --- a/french_law/catala_legifrance/api.ml +++ b/french_law/catala_legifrance/api.ml @@ -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\ diff --git a/french_law/catala_legifrance/catala_legifrance.ml b/french_law/catala_legifrance/catala_legifrance.ml index a0070fe0..3c87c0d8 100644 --- a/french_law/catala_legifrance/catala_legifrance.ml +++ b/french_law/catala_legifrance/catala_legifrance.ml @@ -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 "@[%s@,%a@]" msg + Message.emit_warning "@[%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 diff --git a/french_law/catala_legifrance/date.ml b/french_law/catala_legifrance/date.ml index 97ba363c..7007d834 100644 --- a/french_law/catala_legifrance/date.ml +++ b/french_law/catala_legifrance/date.ml @@ -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] *)