From 98fc97a24139caf25e69d77811d719ed47dd7dea Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Wed, 10 Apr 2024 18:39:30 +0200 Subject: [PATCH] Rewriting message calls to use the new intf --- build_system/clerk_driver.ml | 17 +- build_system/clerk_runtest.ml | 2 +- compiler/catala_utils/file.ml | 6 +- compiler/catala_utils/message.ml | 46 +++-- compiler/catala_utils/message.mli | 10 +- compiler/catala_web_interpreter.ml | 2 +- compiler/dcalc/from_scopelang.ml | 48 ++--- compiler/dcalc/invariants.ml | 10 +- compiler/desugared/dependency.ml | 27 +-- compiler/desugared/from_surface.ml | 205 ++++++++++--------- compiler/desugared/linting.ml | 26 +-- compiler/desugared/name_resolution.ml | 178 ++++++++-------- compiler/desugared/print.ml | 6 +- compiler/driver.ml | 128 ++++++------ compiler/lcalc/compile_with_exceptions.ml | 4 +- compiler/lcalc/compile_without_exceptions.ml | 4 +- compiler/lcalc/to_ocaml.ml | 8 +- compiler/literate/html.ml | 2 +- compiler/literate/latex.ml | 3 +- compiler/literate/literate_common.ml | 11 +- compiler/plugin.ml | 13 +- compiler/plugins/api_web.ml | 4 +- compiler/plugins/explain.ml | 11 +- compiler/plugins/json_schema.ml | 2 +- compiler/plugins/lazy_interp.ml | 9 +- compiler/plugins/python.ml | 5 +- compiler/scalc/from_lcalc.ml | 2 +- compiler/scalc/to_c.ml | 6 +- compiler/scalc/to_r.ml | 2 +- compiler/scopelang/dependency.ml | 17 +- compiler/scopelang/from_desugared.ml | 52 ++--- compiler/shared_ast/expr.ml | 12 +- compiler/shared_ast/interpreter.ml | 147 ++++++------- compiler/shared_ast/operator.ml | 19 +- compiler/shared_ast/typing.ml | 100 ++++----- compiler/surface/lexer.cppo.ml | 2 +- compiler/surface/lexer_common.ml | 2 +- compiler/surface/parser.mly | 12 +- compiler/surface/parser_driver.ml | 42 ++-- compiler/verification/conditions.ml | 4 +- compiler/verification/io.ml | 10 +- compiler/verification/solver.ml | 3 +- compiler/verification/z3backend.dummy.ml | 2 +- compiler/verification/z3backend.real.ml | 3 +- 44 files changed, 630 insertions(+), 594 deletions(-) diff --git a/build_system/clerk_driver.ml b/build_system/clerk_driver.ml index c6653e64..52024aef 100644 --- a/build_system/clerk_driver.ml +++ b/build_system/clerk_driver.ml @@ -318,7 +318,7 @@ module Poll = struct match File.(check_directory (exec_dir /../ "lib")) with | Some d -> d | None -> - Message.raise_error + Message.error "Could not locate the OCaml library directory, make sure OCaml \ or opam is installed"))) @@ -348,11 +348,10 @@ module Poll = struct in match File.check_directory d with | Some dir -> - Message.emit_debug "Catala runtime libraries found at @{%s@}." - dir; + Message.debug "Catala runtime libraries found at @{%s@}." dir; dir | None -> - Message.raise_error + Message.error "@[Could not locate the Catala runtime library at %s.@ Make \ sure that either catala is correctly installed,@ or you are \ running from the root of a compiled source tree.@]" @@ -366,7 +365,7 @@ module Poll = struct (fun lib -> match File.(check_directory (Lazy.force ocaml_libdir / lib)) with | None -> - Message.raise_error + Message.error "Required OCaml library not found at %a.@ Try `opam install \ %s'" File.format @@ -903,7 +902,7 @@ let ninja_init | None -> File.with_temp_file "clerk_build_" ".ninja" k in fun ~extra ~test_flags k -> - Message.emit_debug "building ninja rules..."; + Message.debug "building ninja rules..."; with_ninja_output @@ fun nin_file -> File.with_formatter_of_file nin_file (fun nin_ppf -> @@ -946,7 +945,7 @@ let build_cmd = targets in let ninja_cmd = ninja_cmdline ninja_flags nin_file targets in - Message.emit_debug "executing '%s'..." ninja_cmd; + Message.debug "executing '%s'..." ninja_cmd; Sys.command ninja_cmd in let doc = @@ -986,7 +985,7 @@ let test_cmd = ninja_init ~extra ~test_flags @@ fun nin_file -> let ninja_cmd = ninja_cmdline ninja_flags nin_file targets in - Message.emit_debug "executing '%s'..." ninja_cmd; + Message.debug "executing '%s'..." ninja_cmd; Sys.command ninja_cmd in let doc = @@ -1020,7 +1019,7 @@ let run_cmd = ninja_init ~extra ~test_flags:[] @@ fun nin_file -> let ninja_cmd = ninja_cmdline ninja_flags nin_file [] in - Message.emit_debug "executing '%s'..." ninja_cmd; + Message.debug "executing '%s'..." ninja_cmd; Sys.command ninja_cmd in let doc = diff --git a/build_system/clerk_runtest.ml b/build_system/clerk_runtest.ml index 437d3069..cefc8d37 100644 --- a/build_system/clerk_runtest.ml +++ b/build_system/clerk_runtest.ml @@ -77,7 +77,7 @@ let run_inline_tests catala_exe catala_opts test_flags filename = match Clerk_scan.get_lang filename with | Some l -> l | None -> - Message.raise_error "Can't infer catala dialect from file extension of %a" + Message.error "Can't infer catala dialect from file extension of %a" File.format filename in let lines = Surface.Parser_driver.lines filename lang in diff --git a/compiler/catala_utils/file.ml b/compiler/catala_utils/file.ml index 58cee8b6..6c9d7985 100644 --- a/compiler/catala_utils/file.ml +++ b/compiler/catala_utils/file.ml @@ -70,7 +70,7 @@ let rec ensure_dir dir = match Sys.is_directory dir with | true -> () | false -> - Message.raise_error "Directory %a exists but is not a directory" format dir + Message.error "Directory %a exists but is not a directory" format dir | exception Sys_error _ -> let pdir = parent dir in if pdir <> dir then ensure_dir pdir; @@ -200,7 +200,7 @@ let get_command t = let check_exec t = try if String.contains t dir_sep_char then Unix.realpath t else get_command t with Unix.Unix_error _ | Sys_error _ -> - Message.raise_error + Message.error "Could not find the @{%s@} program, please fix your installation" (Filename.quote t) @@ -238,7 +238,7 @@ let scan_tree f t = let is_dir t = try Sys.is_directory t with Sys_error _ -> - Message.emit_debug "Cannot read %s, skipping" t; + Message.debug "Cannot read %s, skipping" t; false in let not_hidden t = match t.[0] with '.' | '_' -> false | _ -> true in diff --git a/compiler/catala_utils/message.ml b/compiler/catala_utils/message.ml index 9e6f245c..5886a446 100644 --- a/compiler/catala_utils/message.ml +++ b/compiler/catala_utils/message.ml @@ -140,10 +140,8 @@ module Content = struct let add_suggestion (content : t) (suggestion : string list) = content @ [Suggestion suggestion] - let add_position - (content : t) - ?(message : message option) - (position : Pos.t) = + let add_position (content : t) ?(message : message option) (position : Pos.t) + = content @ [Position { pos = position; pos_message = message }] let of_string (s : string) : t = @@ -319,7 +317,6 @@ let emit_result format = (fun message -> Content.emit [MainMessage message] Result) format - (** New concise interface *) type ('a, 'b) emitter = @@ -333,22 +330,40 @@ type ('a, 'b) emitter = ('a, Format.formatter, unit, 'b) format4 -> 'a -let make ?header ?(internal=false) ?pos ?pos_msg ?extra_pos ?fmt_pos ?suggestion ~cont ~level = - Format.kdprintf @@ fun message -> - let t = match level with Result -> of_result message | _ -> of_message message in +let make + ?header + ?(internal = false) + ?pos + ?pos_msg + ?extra_pos + ?fmt_pos + ?suggestion + ~cont + ~level = + Format.kdprintf + @@ fun message -> + let t = + match level with Result -> of_result message | _ -> of_message message + in let t = match header with Some h -> prepend_message t h | None -> t in let t = if internal then to_internal_error t else t in - let t = match pos with Some p -> add_position t ?message:pos_msg p | None -> t in - let t = match extra_pos with + let t = + match pos with Some p -> add_position t ?message:pos_msg p | None -> t + in + let t = + match extra_pos with | Some pl -> - List.fold_left (fun t (message, p) -> - let message = Option.map (fun m ppf -> Format.pp_print_text ppf m) message in + List.fold_left + (fun t (message, p) -> + let message = + Option.map (fun m ppf -> Format.pp_print_text ppf m) message + in add_position t ?message p) - t - pl + t pl | None -> t in - let t = match fmt_pos with + let t = + match fmt_pos with | Some pl -> List.fold_left (fun t (message, p) -> add_position t ?message p) t pl | None -> t @@ -361,4 +376,3 @@ let log = make ~level:Log ~cont:emit let result = make ~level:Result ~cont:emit let warning = make ~level:Warning ~cont:emit let error = make ~level:Error ~cont:(fun m _ -> raise (CompilerError m)) - diff --git a/compiler/catala_utils/message.mli b/compiler/catala_utils/message.mli index ad428fb5..bcef9d12 100644 --- a/compiler/catala_utils/message.mli +++ b/compiler/catala_utils/message.mli @@ -146,8 +146,8 @@ type ('a, 'b) emitter = ('a, Format.formatter, unit, 'b) format4 -> 'a -val log: ('a, unit) emitter -val debug: ('a, unit) emitter -val result: ('a, unit) emitter -val warning: ('a, unit) emitter -val error: ('a, 'b) emitter +val log : ('a, unit) emitter +val debug : ('a, unit) emitter +val result : ('a, unit) emitter +val warning : ('a, unit) emitter +val error : ('a, 'b) emitter diff --git a/compiler/catala_web_interpreter.ml b/compiler/catala_web_interpreter.ml index 6c2289e1..471af383 100644 --- a/compiler/catala_web_interpreter.ml +++ b/compiler/catala_web_interpreter.ml @@ -16,7 +16,7 @@ let () = let language = try List.assoc (String.lowercase_ascii language) Cli.languages with Not_found -> - Message.raise_error "Unrecognised input locale %S" language + Message.error "Unrecognised input locale %S" language in let options = Global.enforce_options diff --git a/compiler/dcalc/from_scopelang.ml b/compiler/dcalc/from_scopelang.ml index a720c69d..56d14f16 100644 --- a/compiler/dcalc/from_scopelang.ml +++ b/compiler/dcalc/from_scopelang.ml @@ -224,7 +224,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm S.expr) : 'm Ast.expr boxed = let case_e = try EnumConstructor.Map.find constructor e_cases with EnumConstructor.Map.Not_found _ -> - Message.raise_spanned_error (Expr.pos e) + Message.error ~pos:(Expr.pos e) "The constructor %a of enum %a is missing from this pattern \ matching" EnumConstructor.format constructor EnumName.format name @@ -236,7 +236,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm S.expr) : 'm Ast.expr boxed = (EnumConstructor.Map.empty, e_cases) in if not (EnumConstructor.Map.is_empty remaining_e_cases) then - Message.raise_spanned_error (Expr.pos e) + Message.error ~pos:(Expr.pos e) "Pattern matching is incomplete for enum %a: missing cases %a" EnumName.format name (EnumConstructor.Map.format_keys ~pp_sep:(fun fmt () -> @@ -272,28 +272,30 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm S.expr) : 'm Ast.expr boxed = ( var_ctx.scope_input_name, thunk_scope_arg var_ctx (translate_expr ctx e) ) | Some var_ctx, None -> - Message.raise_multispanned_error - [ - None, pos; - ( Some "Declaration of the missing input variable", - Mark.get (StructField.get_info var_ctx.scope_input_name) ); - ] + Message.error + ~extra_pos: + [ + None, pos; + ( Some "Declaration of the missing input variable", + Mark.get (StructField.get_info var_ctx.scope_input_name) ); + ] "Definition of input variable '%a' missing in this scope call" ScopeVar.format var_name | None, Some e -> - Message.raise_multispanned_error_full + Message.error ~suggestion: (List.map (fun v -> Mark.remove (ScopeVar.get_info v)) (ScopeVar.Map.keys sc_sig.scope_sig_in_fields)) - [ - None, Expr.pos e; - ( Some - (fun ppf -> - Format.fprintf ppf "Declaration of scope %a" - ScopeName.format scope), - Mark.get (ScopeName.get_info scope) ); - ] + ~fmt_pos: + [ + None, Expr.pos e; + ( Some + (fun ppf -> + Format.fprintf ppf "Declaration of scope %a" + ScopeName.format scope), + Mark.get (ScopeName.get_info scope) ); + ] "Unknown input variable '%a' in scope call of '%a'" ScopeVar.format var_name ScopeName.format scope) sc_sig.scope_sig_in_fields args @@ -511,13 +513,13 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm S.expr) : 'm Ast.expr boxed = match Mark.remove typ with | TArrow (_, (tout, _)) -> tout | _ -> - Message.raise_spanned_error (Expr.pos e) + Message.error ~pos:(Expr.pos e) "Application of non-function toplevel variable") | _ -> TAny in - (* 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); *) + (* Message.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 = ListLabels.mapi (List.combine new_args input_typs) ~f:(fun i (new_arg, input_typ) -> @@ -760,8 +762,8 @@ let translate_scope_decl (* Todo: are we sure this can't happen in normal code ? E.g. is calling a scope which only defines input variables already an error at this stage or not ? *) - Message.raise_spanned_error pos_sigma "Scope %a has no content" - ScopeName.format scope_name + Message.error ~pos:pos_sigma "Scope %a has no content" ScopeName.format + scope_name | ( S.ScopeVarDefinition { e; _ } | S.SubScopeVarDefinition { e; _ } | S.Assertion e ) diff --git a/compiler/dcalc/invariants.ml b/compiler/dcalc/invariants.ml index 38f6ad18..f38a3703 100644 --- a/compiler/dcalc/invariants.ml +++ b/compiler/dcalc/invariants.ml @@ -31,14 +31,14 @@ let check_invariant (inv : string * invariant_expr) (p : typed program) : bool = match inv p.decl_ctx e with | Ignore -> result, total, ok | Fail -> - Message.raise_spanned_error (Expr.pos e) + Message.error ~pos:(Expr.pos e) "@[Invariant @{%s@} failed.@,%a@]" name (Print.expr ()) e | Pass -> result, total + 1, ok + 1 in f e acc) in - Message.emit_debug "Invariant %s checked.@ result: [%d/%d]" name ok total; + Message.debug "Invariant %s checked.@ result: [%d/%d]" name ok total; result (* Structural invariant: no default can have as type A -> B *) @@ -143,11 +143,11 @@ let rec check_typ_no_default ctx ty = | TArray ty -> check_typ_no_default ctx ty | TDefault _t -> false | TAny -> - Message.raise_internal_error + Message.error ~internal:true "Some Dcalc invariants are invalid: TAny was found whereas it should be \ fully resolved." | TClosureEnv -> - Message.raise_internal_error + Message.error ~internal:true "Some Dcalc invariants are invalid: TClosureEnv was found whereas it \ should only appear later in the compilation process." @@ -192,7 +192,7 @@ let invariant_typing_defaults () : string * invariant_expr = fun ctx e -> if check_type_root ctx (Expr.ty e) then Pass else ( - Message.emit_warning "typing error %a@." (Print.typ ctx) (Expr.ty e); + Message.warning "typing error %a@." (Print.typ ctx) (Expr.ty e); Fail) ) let check_all_invariants prgm = diff --git a/compiler/desugared/dependency.ml b/compiler/desugared/dependency.ml index d22ddc1a..461ff671 100644 --- a/compiler/desugared/dependency.ml +++ b/compiler/desugared/dependency.ml @@ -141,7 +141,7 @@ let check_for_cycle (scope : Ast.scope) (g : ScopeDependencies.t) : unit = cycle (List.tl cycle @ [List.hd cycle]) in - Message.raise_multispanned_error spans + Message.error ~extra_pos:spans "@[Cyclic dependency detected between the following variables of \ scope %a:@ @[%a@]@]" ScopeName.format scope.scope_uid @@ -196,12 +196,12 @@ let build_scope_dependencies (scope : Ast.scope) : ScopeDependencies.t = if Vertex.equal v_used v_defined then match def_key with | _, Ast.ScopeDef.Var _ -> - Message.raise_spanned_error fv_def_pos + Message.error ~pos:fv_def_pos "The variable %a is used in one of its definitions, but \ recursion is forbidden in Catala" Ast.ScopeDef.format def_key | v, Ast.ScopeDef.SubScopeInput _ -> - Message.raise_spanned_error fv_def_pos + Message.error ~pos:fv_def_pos "The subscope %a is used in the definition of its own \ input %a, but recursion is forbidden in Catala" ScopeVar.format (Mark.remove v) Ast.ScopeDef.format def_key @@ -407,19 +407,20 @@ let build_exceptions_graph in (* We check the consistency*) if LabelName.compare label_from label_to = 0 then - Message.raise_spanned_error edge_pos + Message.error ~pos:edge_pos "Cannot define rule as an exception to itself"; List.iter (fun edge -> if LabelName.compare edge.label_to label_to <> 0 then - Message.raise_multispanned_error - (( Some - "This definition contradicts other exception \ - definitions:", - edge_pos ) - :: List.map - (fun pos -> Some "Other exception definition:", pos) - edge.edge_positions) + Message.error + ~extra_pos: + (( Some + "This definition contradicts other exception \ + definitions:", + edge_pos ) + :: List.map + (fun pos -> Some "Other exception definition:", pos) + edge.edge_positions) "The definition of exceptions are inconsistent for variable \ %a." Ast.ScopeDef.format def_info) @@ -498,7 +499,7 @@ let check_for_exception_cycle scc in let v, _ = RuleName.Map.choose (List.hd scc).rules in - Message.raise_multispanned_error spans + Message.error ~extra_pos: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 v (List.length scc) diff --git a/compiler/desugared/from_surface.ml b/compiler/desugared/from_surface.ml index b7d58c0e..47e9057c 100644 --- a/compiler/desugared/from_surface.ml +++ b/compiler/desugared/from_surface.ml @@ -77,7 +77,7 @@ let translate_binop : | S.KDec -> [TLit TRat; TLit TRat] | S.KMoney -> [TLit TMoney; TLit TRat] | S.KDate -> - Message.raise_spanned_error op_pos + Message.error ~pos:op_pos "This operator doesn't exist, dates can't be multiplied" | S.KDuration -> [TLit TDuration; TLit TInt]) | S.Div k -> @@ -88,7 +88,7 @@ let translate_binop : | S.KDec -> [TLit TRat; TLit TRat] | S.KMoney -> [TLit TMoney; TLit TMoney] | S.KDate -> - Message.raise_spanned_error op_pos + Message.error ~pos:op_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 -> @@ -126,7 +126,7 @@ let translate_unop ((op, op_pos) : S.unop Mark.pos) pos arg : Ast.expr boxed = | S.KDec -> TLit TRat | S.KMoney -> TLit TMoney | S.KDate -> - Message.raise_spanned_error op_pos + Message.error ~pos:op_pos "This operator doesn't exist, dates can't be negative" | S.KDuration -> TLit TDuration) @@ -138,9 +138,9 @@ let raise_error_cons_not_found Suggestions.suggestion_minimum_levenshtein_distance_association constructors (Mark.remove constructor) in - Message.raise_spanned_error - ~span_msg:(fun ppf -> Format.fprintf ppf "Here is your code :") - ~suggestion:closest_constructors (Mark.get constructor) + Message.error + ~pos_msg:(fun ppf -> Format.fprintf ppf "Here is your code :") + ~pos:(Mark.get constructor) ~suggestion:closest_constructors "The name of this constructor has not been defined before@ (it's probably \ a typographical error)." @@ -152,7 +152,7 @@ let rec disambiguate_constructor match constructor0 with | [c] -> Mark.remove c | _ -> - Message.raise_spanned_error pos + Message.error ~pos "The deep pattern matching syntactic sugar is not yet supported" in let possible_c_uids = @@ -173,7 +173,7 @@ let rec disambiguate_constructor match path with | [] -> if EnumName.Map.cardinal possible_c_uids > 1 then - Message.raise_spanned_error (Mark.get constructor) + Message.error ~pos:(Mark.get constructor) "This constructor name is ambiguous, it can belong to %a. Disambiguate \ it by prefixing it with the enum name." (EnumName.Map.format_keys ~pp_sep:(fun fmt () -> @@ -187,8 +187,8 @@ let rec disambiguate_constructor let c_uid = EnumName.Map.find e_uid possible_c_uids in e_uid, c_uid with EnumName.Map.Not_found _ -> - Message.raise_spanned_error pos "Enum %s does not contain case %s" - (Mark.remove enum) (Mark.remove constructor)) + Message.error ~pos "Enum %s does not contain case %s" (Mark.remove enum) + (Mark.remove constructor)) | mod_id :: path -> let constructor = List.map (Mark.map (fun (_, c) -> path, c)) constructor0 @@ -210,8 +210,8 @@ 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]) *) - Message.raise_multispanned_error - [None, pos_op; None, pos_op1] + Message.error + ~extra_pos:[None, pos_op; None, pos_op1] "Please add parentheses to explicit which of these operators should be \ applied first"; check_formula (op1, pos_op1) e1; @@ -352,21 +352,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), _)) -> - Message.raise_spanned_error pos + Message.error ~pos "Impossible to specify decimal amounts of days, months or years" | LDate date -> if date.literal_date_month > 12 then - Message.raise_spanned_error pos + Message.error ~pos "There is an error in this date: the month number is bigger than 12"; if date.literal_date_day > 31 then - Message.raise_spanned_error pos + Message.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 -> - Message.raise_spanned_error pos + Message.error ~pos "There is an error in this date, it does not correspond to a \ correct calendar day") in @@ -379,7 +379,7 @@ let rec translate_expr Expr.make_var uid emark (* the whole box thing is to accomodate for this case *) | Some uid, Some state -> - Message.raise_spanned_error (Mark.get state) + Message.error ~pos:(Mark.get state) "%a is a local variable, it has no states" Print.var uid | None, state -> ( match Ident.Map.find_opt x scope_vars with @@ -393,14 +393,14 @@ let rec translate_expr match state, x_sig.var_sig_states_list, inside_definition_of with | None, [], _ -> None | Some st, [], _ -> - Message.raise_spanned_error (Mark.get st) + Message.error ~pos:(Mark.get st) "Variable %a does not define states" ScopeVar.format uid | st, states, Some (((x'_uid, _), Ast.ScopeDef.Var sx'), _) when ScopeVar.equal uid x'_uid -> ( if st <> None then (* TODO *) - Message.raise_spanned_error - (Mark.get (Option.get st)) + Message.error + ~pos:(Mark.get (Option.get st)) "Referring to a previous state of the variable being defined \ is not supported at the moment."; match sx' with @@ -410,7 +410,7 @@ let rec translate_expr state but variable has states" | Some inside_def_state -> if StateName.compare inside_def_state (List.hd states) = 0 then - Message.raise_spanned_error pos + Message.error ~pos "It is impossible to refer to the variable you are defining \ when defining its first state." else @@ -428,12 +428,14 @@ let rec translate_expr Ident.Map.find_opt (Mark.remove st) x_sig.var_sig_states_idmap with | None -> - Message.raise_multispanned_error + Message.error ~suggestion:(List.map StateName.to_string states) - [ - None, Mark.get st; - Some "Variable defined here", Mark.get (ScopeVar.get_info uid); - ] + ~extra_pos: + [ + None, Mark.get st; + ( Some "Variable defined here", + Mark.get (ScopeVar.get_info uid) ); + ] "Reference to unknown variable state" | some -> some) | _, states, _ -> @@ -451,7 +453,7 @@ let rec translate_expr match Ident.Map.find_opt x ctxt.local.topdefs with | Some v -> if state <> None then - Message.raise_spanned_error pos + Message.error ~pos "Access to intermediate states is only allowed for variables of \ the current scope"; Expr.elocation @@ -461,7 +463,7 @@ let rec translate_expr Name_resolution.raise_unknown_identifier "for a local, scope-wide or global variable" (x, pos)))) | Ident (_ :: _, (_, pos), Some _) -> - Message.raise_spanned_error pos + Message.error ~pos "Access to intermediate states is only allowed for variables of the \ current scope" | Ident (path, name, None) -> ( @@ -499,14 +501,13 @@ let rec translate_expr in Expr.eappop ~op ~tys:[ty, pos] ~args:[rec_helper arg] emark | S.Builtin _ -> - Message.raise_spanned_error pos "Invalid use of built-in: needs one operand" + Message.error ~pos "Invalid use of built-in: needs one operand" | FunCall (f, args) -> let args = List.map rec_helper args in Expr.eapp ~f:(rec_helper f) ~args ~tys:[] emark | ScopeCall (((path, id), _), fields) -> if scope = None then - Message.raise_spanned_error pos - "Scope calls are not allowed outside of a scope"; + Message.error ~pos "Scope calls are not allowed outside of a scope"; let called_scope, scope_def = let ctxt = Name_resolution.module_ctx ctxt path in let uid = Name_resolution.get_scope ctxt id in @@ -521,15 +522,16 @@ let rec translate_expr with | Some (ScopeVar v) -> v | Some (SubScope _) | None -> - Message.raise_multispanned_error + Message.error ~suggestion:(Ident.Map.keys scope_def.var_idmap) - [ - None, Mark.get fld_id; - ( Some - (Format.asprintf "Scope %a declared here" ScopeName.format - called_scope), - Mark.get (ScopeName.get_info called_scope) ); - ] + ~extra_pos: + [ + None, Mark.get fld_id; + ( Some + (Format.asprintf "Scope %a declared here" + ScopeName.format called_scope), + Mark.get (ScopeName.get_info called_scope) ); + ] "Scope %a has no input variable %a" ScopeName.format called_scope Print.lit_style (Mark.remove fld_id) in @@ -537,7 +539,7 @@ let rec translate_expr (function | None -> Some (rec_helper e) | Some _ -> - Message.raise_spanned_error (Mark.get fld_id) + Message.error ~pos:(Mark.get fld_id) "Duplicate definition of scope input variable '%a'" ScopeVar.format var) acc) @@ -565,7 +567,7 @@ let rec translate_expr | Some (Name_resolution.TScope (_, { out_struct_name = s_uid; _ })) -> s_uid | _ -> - Message.raise_spanned_error (Mark.get s_name) + Message.error ~pos:(Mark.get s_name) "This identifier should refer to a struct name" in let s_fields = @@ -576,15 +578,15 @@ let rec translate_expr StructName.Map.find s_uid (Ident.Map.find (Mark.remove f_name) ctxt.local.field_idmap) with StructName.Map.Not_found _ | Ident.Map.Not_found _ -> - Message.raise_spanned_error (Mark.get f_name) + Message.error ~pos:(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 -> - Message.raise_multispanned_error - [None, Mark.get f_e; None, Expr.pos e_field] + Message.error + ~extra_pos:[None, Mark.get f_e; None, Expr.pos e_field] "The field %a has been defined twice:" StructField.format f_uid); let f_e = rec_helper f_e in StructField.Map.add f_uid f_e s_fields) @@ -596,7 +598,7 @@ let rec translate_expr (fun expected_f _ -> not (StructField.Map.mem expected_f s_fields)) expected_s_fields then - Message.raise_spanned_error pos "Missing field(s) for structure %a:@\n%a" + Message.error ~pos "Missing field(s) for structure %a:@\n%a" StructName.format s_uid (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") @@ -634,7 +636,7 @@ let rec translate_expr (* No enum name was specified *) EnumName.Map.cardinal possible_c_uids > 1 then - Message.raise_spanned_error pos_constructor + Message.error ~pos:pos_constructor "This constructor name is ambiguous, it can belong to %a. \ Desambiguate it by prefixing it with the enum name." (EnumName.Map.format_keys ~pp_sep:(fun fmt () -> @@ -669,8 +671,8 @@ let rec translate_expr | None -> Expr.elit LUnit mark_constructor) ~cons:c_uid ~name:e_uid emark with EnumName.Map.Not_found _ -> - Message.raise_spanned_error pos "Enum %s does not contain case %s" - (Mark.remove enum) constructor)) + Message.error ~pos "Enum %s does not contain case %s" (Mark.remove enum) + constructor)) | MatchWith (e1, (cases, _cases_pos)) -> let e1 = rec_helper e1 in let cases_d, e_uid = @@ -682,7 +684,7 @@ let rec translate_expr (match snd (Mark.remove pattern) with | None -> () | Some binding -> - Message.emit_spanned_warning (Mark.get binding) + Message.warning ~pos:(Mark.get binding) "This binding will be ignored (remove it to suppress warning)"); let enum_uid, c_uid = disambiguate_constructor ctxt @@ -872,8 +874,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 -> - Message.raise_spanned_error pos - "It is impossible to sum values of type %a together" + Message.error ~pos "It is impossible to sum values of type %a together" SurfacePrint.format_primitive_typ t in let op_f = @@ -962,8 +963,8 @@ and disambiguate_match_and_build_expression | Some e_uid -> if e_uid = e_uid' then e_uid else - Message.raise_spanned_error - (Mark.get case.S.match_case_pattern) + Message.error + ~pos:(Mark.get case.S.match_case_pattern) "This case matches a constructor of enumeration %a but previous \ case were matching constructors of enumeration %a" EnumName.format e_uid EnumName.format e_uid' @@ -971,8 +972,9 @@ and disambiguate_match_and_build_expression (match EnumConstructor.Map.find_opt c_uid cases_d with | None -> () | Some e_case -> - Message.raise_multispanned_error - [None, Mark.get case.match_case_expr; None, Expr.pos e_case] + Message.error + ~extra_pos: + [None, Mark.get case.match_case_expr; None, Expr.pos e_case] "The constructor %a has been matched twice:" EnumConstructor.format c_uid); let local_vars, param_var = @@ -990,18 +992,19 @@ and disambiguate_match_and_build_expression | S.WildCard match_case_expr -> ( let nb_cases = List.length cases in let raise_wildcard_not_last_case_err () = - Message.raise_multispanned_error - [ - Some "Not ending wildcard:", case_pos; - ( Some "Next reachable case:", - curr_index + 1 |> List.nth cases |> Mark.get ); - ] + Message.error + ~extra_pos: + [ + Some "Not ending wildcard:", case_pos; + ( Some "Next reachable case:", + curr_index + 1 |> List.nth cases |> Mark.get ); + ] "Wildcard must be the last match case" in match e_uid with | None -> if 1 = nb_cases then - Message.raise_spanned_error case_pos + Message.error ~pos: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 () @@ -1015,7 +1018,7 @@ and disambiguate_match_and_build_expression | None -> Some c_uid) in if EnumConstructor.Map.is_empty missing_constructors then - Message.emit_spanned_warning case_pos + Message.warning ~pos:case_pos "Unreachable match case, all constructors of the enumeration %a \ are already specified" EnumName.format e_uid; @@ -1078,24 +1081,27 @@ let rec arglist_eq_check pos_decl pos_def pdecl pdefs = match pdecl, pdefs with | [], [] -> () | [], (arg, apos) :: _ -> - Message.raise_multispanned_error - [Some "Declared here:", pos_decl; Some "Extra argument:", apos] + Message.error + ~extra_pos:[Some "Declared here:", pos_decl; Some "Extra argument:", apos] "This definition has an extra, undeclared argument '%a'" Print.lit_style arg | (arg, apos) :: _, [] -> - Message.raise_multispanned_error - [ - Some "Argument declared here:", apos; - Some "Mismatching definition:", pos_def; - ] + Message.error + ~extra_pos: + [ + Some "Argument declared here:", apos; + Some "Mismatching definition:", pos_def; + ] "This definition is missing argument '%a'" Print.lit_style arg | 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) :: _ -> - Message.raise_multispanned_error - [ - Some "Argument declared here:", decl_apos; Some "Defined here:", def_apos; - ] + Message.error + ~extra_pos: + [ + Some "Argument declared here:", decl_apos; + Some "Defined here:", def_apos; + ] "Function argument name mismatch between declaration ('%a') and \ definition ('%a')" Print.lit_style decl_arg Print.lit_style def_arg @@ -1111,18 +1117,21 @@ let process_rule_parameters match declared_params, def.S.definition_parameter with | None, None -> Ident.Map.empty, None | None, Some (_, pos) -> - Message.raise_multispanned_error - [ - Some "Declared here without arguments", decl_pos; - Some "Unexpected arguments appearing here", pos; - ] + Message.error + ~extra_pos: + [ + Some "Declared here without arguments", decl_pos; + Some "Unexpected arguments appearing here", pos; + ] "Extra arguments in this definition of %a" Ast.ScopeDef.format decl_name | Some (_, pos), None -> - Message.raise_multispanned_error - [ - Some "Arguments declared here", pos; - Some "Definition missing the arguments", Mark.get def.S.definition_name; - ] + Message.error + ~extra_pos: + [ + Some "Arguments declared here", pos; + ( Some "Definition missing the arguments", + Mark.get def.S.definition_name ); + ] "This definition for %a is missing the arguments" Ast.ScopeDef.format decl_name | Some (pdecl, pos_decl), Some (pdefs, pos_def) -> @@ -1222,7 +1231,7 @@ let process_def in ExceptionToLabel (label_id, Mark.get label_str) with Ident.Map.Not_found _ -> - Message.raise_spanned_error (Mark.get label_str) + Message.error ~pos:(Mark.get label_str) "Unknown label for the scope variable %a: \"%s\"" Ast.ScopeDef.format def_key (Mark.remove label_str)) in @@ -1337,8 +1346,8 @@ let process_scope_use_item scope.scope_options with | Some (_, old_pos) -> - Message.raise_multispanned_error - [None, old_pos; None, Mark.get item] + Message.error + ~extra_pos:[None, old_pos; None, Mark.get item] "You cannot set multiple date rounding modes" | None -> { @@ -1390,12 +1399,13 @@ let check_unlabeled_exception | S.UnlabeledException -> ( match scope_def_ctxt.default_exception_rulename with | None -> - Message.raise_spanned_error (Mark.get item) + Message.error ~pos:(Mark.get item) "This exception does not have a corresponding definition" | Some (Ambiguous pos) -> - Message.raise_multispanned_error - ([Some "Ambiguous exception", Mark.get item] - @ List.map (fun p -> Some "Candidate definition", p) pos) + Message.error + ~extra_pos: + ([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 \ to disambiguate" | Some (Unique _) -> ())) @@ -1451,7 +1461,7 @@ let process_topdef let () = match tys with | [(Data (S.TTuple _), pos)] -> - Message.raise_spanned_error pos + Message.error ~pos "Defining arguments of a function as a tuple is not supported, \ please name the individual arguments" | _ -> () @@ -1472,11 +1482,12 @@ let process_topdef | None, eopt -> Some (eopt, typ) | Some (eopt0, ty0), eopt -> ( let err msg = - Message.raise_multispanned_error - [ - None, Mark.get (TopdefName.get_info id); - None, Mark.get def.S.topdef_name; - ] + Message.error + ~extra_pos: + [ + None, Mark.get (TopdefName.get_info id); + None, Mark.get def.S.topdef_name; + ] (msg ^^ " for %a") TopdefName.format id in if not (Type.equal ty0 typ) then err "Conflicting type definitions" diff --git a/compiler/desugared/linting.ml b/compiler/desugared/linting.ml index fd589eb5..057d638f 100644 --- a/compiler/desugared/linting.ml +++ b/compiler/desugared/linting.ml @@ -37,8 +37,8 @@ let detect_empty_definitions (p : program) : unit = | NoInput -> true | _ -> false then - Message.emit_spanned_warning - (ScopeDef.get_position scope_def_key) + Message.warning + ~pos:(ScopeDef.get_position scope_def_key) "In scope \"%a\", the variable \"%a\" is declared but never \ defined; did you forget something?" ScopeName.format scope_name Ast.ScopeDef.format scope_def_key) @@ -94,7 +94,7 @@ let detect_identical_rules (p : program) : unit = RuleExpressionsMap.iter (fun _ pos -> if List.length pos > 1 then - Message.emit_multispanned_warning pos + Message.warning ~extra_pos:pos "These %s have identical justifications and consequences; is \ it a mistake?" (if scope_def.scope_def_is_condition then "rules" @@ -153,8 +153,8 @@ let detect_unused_struct_fields (p : program) : unit = && not (StructField.Set.mem field scope_out_structs_fields)) fields then - Message.emit_spanned_warning - (snd (StructName.get_info s_name)) + Message.warning + ~pos:(snd (StructName.get_info s_name)) "The structure \"%a\" is never used; maybe it's unnecessary?" StructName.format s_name else @@ -164,8 +164,8 @@ 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 - Message.emit_spanned_warning - (snd (StructField.get_info field)) + Message.warning + ~pos:(snd (StructField.get_info field)) "The field \"%a\" of struct @{\"%a\"@} is never \ used; maybe it's unnecessary?" StructField.format field StructName.format s_name) @@ -211,8 +211,8 @@ let detect_unused_enum_constructors (p : program) : unit = not (EnumConstructor.Set.mem cons enum_constructors_used)) constructors then - Message.emit_spanned_warning - (snd (EnumName.get_info e_name)) + Message.warning + ~pos:(snd (EnumName.get_info e_name)) "The enumeration \"%a\" is never used; maybe it's unnecessary?" EnumName.format e_name else @@ -221,8 +221,8 @@ let detect_unused_enum_constructors (p : program) : unit = if not (EnumConstructor.Set.mem constructor enum_constructors_used) then - Message.emit_spanned_warning - (snd (EnumConstructor.get_info constructor)) + Message.warning + ~pos:(snd (EnumConstructor.get_info constructor)) "The constructor \"%a\" of enumeration \"%a\" is never used; \ maybe it's unnecessary?" EnumConstructor.format constructor EnumName.format e_name) @@ -266,8 +266,8 @@ let detect_dead_code (p : program) : unit = in let is_alive = Reachability.analyze is_alive scope_dependencies in let emit_unused_warning vx = - Message.emit_spanned_warning - (Mark.get (Dependency.Vertex.info vx)) + Message.warning + ~pos:(Mark.get (Dependency.Vertex.info vx)) "Unused varible: %a does not contribute to computing any of scope %a \ outputs. Did you forget something?" Dependency.Vertex.format vx ScopeName.format scope_name diff --git a/compiler/desugared/name_resolution.ml b/compiler/desugared/name_resolution.ml index f6a5900d..c3674d9b 100644 --- a/compiler/desugared/name_resolution.ml +++ b/compiler/desugared/name_resolution.ml @@ -99,12 +99,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) = - Message.raise_spanned_error pos "Unsupported feature: %s" msg + Message.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 : Ident.t Mark.pos) = - Message.raise_spanned_error (Mark.get ident) + Message.error ~pos:(Mark.get ident) "@{\"%s\"@}: unknown identifier %s" (Mark.remove ident) msg (** Gets the type associated to an uid *) @@ -181,62 +181,63 @@ let get_enum ctxt id = match Ident.Map.find (Mark.remove id) ctxt.local.typedefs with | TEnum id -> id | TStruct sid -> - Message.raise_multispanned_error - [ - None, Mark.get id; - Some "Structure defined at", Mark.get (StructName.get_info sid); - ] + Message.error + ~extra_pos: + [ + None, Mark.get id; + Some "Structure defined at", Mark.get (StructName.get_info sid); + ] "Expecting an enum, but found a structure" | TScope (sid, _) -> - Message.raise_multispanned_error - [ - None, Mark.get id; - Some "Scope defined at", Mark.get (ScopeName.get_info sid); - ] + Message.error + ~extra_pos: + [ + None, Mark.get id; + Some "Scope defined at", Mark.get (ScopeName.get_info sid); + ] "Expecting an enum, but found a scope" | exception Ident.Map.Not_found _ -> - Message.raise_spanned_error (Mark.get id) "No enum named %s found" - (Mark.remove id) + Message.error ~pos:(Mark.get id) "No enum named %s found" (Mark.remove id) let get_struct ctxt id = match Ident.Map.find (Mark.remove id) ctxt.local.typedefs with | TStruct id | TScope (_, { out_struct_name = id; _ }) -> id | TEnum eid -> - Message.raise_multispanned_error - [ - None, Mark.get id; - Some "Enum defined at", Mark.get (EnumName.get_info eid); - ] + Message.error + ~extra_pos: + [ + None, Mark.get id; + Some "Enum defined at", Mark.get (EnumName.get_info eid); + ] "Expecting a struct, but found an enum" | exception Ident.Map.Not_found _ -> - Message.raise_spanned_error (Mark.get id) "No struct named %s found" - (Mark.remove id) + Message.error ~pos:(Mark.get id) "No struct named %s found" (Mark.remove id) let get_scope ctxt id = match Ident.Map.find (Mark.remove id) ctxt.local.typedefs with | TScope (id, _) -> id | TEnum eid -> - Message.raise_multispanned_error - [ - None, Mark.get id; - Some "Enum defined at", Mark.get (EnumName.get_info eid); - ] + Message.error + ~extra_pos: + [ + None, Mark.get id; + Some "Enum defined at", Mark.get (EnumName.get_info eid); + ] "Expecting an scope, but found an enum" | TStruct sid -> - Message.raise_multispanned_error - [ - None, Mark.get id; - Some "Structure defined at", Mark.get (StructName.get_info sid); - ] + Message.error + ~extra_pos: + [ + None, Mark.get id; + Some "Structure defined at", Mark.get (StructName.get_info sid); + ] "Expecting an scope, but found a structure" | exception Ident.Map.Not_found _ -> - Message.raise_spanned_error (Mark.get id) "No scope named %s found" - (Mark.remove id) + Message.error ~pos:(Mark.get id) "No scope named %s found" (Mark.remove id) let get_modname ctxt (id, pos) = match Ident.Map.find_opt id ctxt.local.used_modules with - | None -> - Message.raise_spanned_error pos "Module \"@{%s@}\" not found" id + | None -> Message.error ~pos "Module \"@{%s@}\" not found" id | Some modname -> modname let get_module_ctx ctxt id = @@ -269,8 +270,8 @@ let process_subscope_decl | ScopeVar v -> ScopeVar.get_info v | SubScope (ssc, _, _) -> ScopeVar.get_info ssc in - Message.raise_multispanned_error - [Some "first use", Mark.get info; Some "second use", s_pos] + Message.error + ~extra_pos:[Some "first use", Mark.get info; Some "second use", s_pos] "Subscope name @{\"%s\"@} already used" (Mark.remove subscope) | None -> let sub_scope_uid = ScopeVar.fresh (name, name_pos) in @@ -331,14 +332,14 @@ let rec process_base_typ | Some (TScope (_, scope_str)) -> TStruct scope_str.out_struct_name, typ_pos | None -> - Message.raise_spanned_error typ_pos + Message.error ~pos:typ_pos "Unknown type @{\"%s\"@}, not a struct or enum previously \ declared" ident) | Surface.Ast.Named ((modul, mpos) :: path, id) -> ( match Ident.Map.find_opt modul ctxt.local.used_modules with | None -> - Message.raise_spanned_error mpos + Message.error ~pos:mpos "This refers to module @{%s@}, which was not found" modul | Some mname -> let mod_ctxt = ModuleName.Map.find mname ctxt.modules in @@ -372,8 +373,8 @@ let process_data_decl | ScopeVar v -> ScopeVar.get_info v | SubScope (ssc, _, _) -> ScopeVar.get_info ssc in - Message.raise_multispanned_error - [Some "First use:", Mark.get info; Some "Second use:", pos] + Message.error + ~extra_pos:[Some "First use:", Mark.get info; Some "Second use:", pos] "Variable name @{\"%s\"@} already used" name | None -> let uid = ScopeVar.fresh (name, pos) in @@ -388,23 +389,24 @@ let process_data_decl (fun state_id ((states_idmap : StateName.t Ident.Map.t), states_list) -> let state_id_name = Mark.remove state_id in if Ident.Map.mem state_id_name states_idmap then - Message.raise_multispanned_error_full - [ - ( Some - (fun ppf -> - Format.fprintf ppf - "First instance of state @{\"%s\"@}:" - state_id_name), - Mark.get state_id ); - ( Some - (fun ppf -> - Format.fprintf ppf - "Second instance of state @{\"%s\"@}:" - state_id_name), - Mark.get - (Ident.Map.find state_id_name states_idmap - |> StateName.get_info) ); - ] + Message.error + ~fmt_pos: + [ + ( Some + (fun ppf -> + Format.fprintf ppf + "First instance of state @{\"%s\"@}:" + state_id_name), + Mark.get state_id ); + ( Some + (fun ppf -> + Format.fprintf ppf + "Second instance of state @{\"%s\"@}:" + state_id_name), + Mark.get + (Ident.Map.find state_id_name states_idmap + |> StateName.get_info) ); + ] "There are two states with the same name for the same variable: \ this is ambiguous. Please change the name of either states."; let state_uid = StateName.fresh state_id in @@ -438,8 +440,8 @@ 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 - Message.raise_spanned_error - (Mark.get sdecl.struct_decl_name) + Message.error + ~pos:(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." (Mark.remove sdecl.struct_decl_name); @@ -483,8 +485,8 @@ 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 - Message.raise_spanned_error - (Mark.get edecl.enum_decl_name) + Message.error + ~pos:(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." (Mark.remove edecl.enum_decl_name); @@ -645,12 +647,13 @@ 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 = - Message.raise_multispanned_error_full - [ - ( Some (fun ppf -> Format.pp_print_string ppf "First definition:"), - Mark.get use ); - Some (fun ppf -> Format.pp_print_string ppf "Second definition:"), pos; - ] + Message.error + ~fmt_pos: + [ + ( Some (fun ppf -> Format.pp_print_string ppf "First definition:"), + Mark.get use ); + Some (fun ppf -> Format.pp_print_string ppf "Second definition:"), pos; + ] "%s name @{\"%s\"@} already defined" msg name in match Mark.remove item with @@ -779,20 +782,24 @@ let get_def_key Some (Ident.Map.find (Mark.remove state) var_sig.var_sig_states_idmap) with Ident.Map.Not_found _ -> - Message.raise_multispanned_error - [ - None, Mark.get state; - Some "Variable declaration:", Mark.get (ScopeVar.get_info x_uid); - ] + Message.error + ~extra_pos: + [ + None, Mark.get state; + ( Some "Variable declaration:", + Mark.get (ScopeVar.get_info x_uid) ); + ] "This identifier is not a state declared for variable %a." ScopeVar.format x_uid) | None -> if not (Ident.Map.is_empty var_sig.var_sig_states_idmap) then - Message.raise_multispanned_error - [ - None, Mark.get x; - Some "Variable declaration:", Mark.get (ScopeVar.get_info x_uid); - ] + Message.error + ~extra_pos: + [ + None, Mark.get x; + ( Some "Variable declaration:", + Mark.get (ScopeVar.get_info x_uid) ); + ] "This definition does not indicate which state has to be \ considered for variable %a." ScopeVar.format x_uid @@ -802,18 +809,17 @@ let get_def_key match Ident.Map.find_opt (Mark.remove y) scope_ctxt.var_idmap with | Some (SubScope (v, u, _)) -> v, u | Some _ -> - Message.raise_spanned_error pos - "Invalid definition, %a is not a subscope" Print.lit_style - (Mark.remove y) - | None -> - Message.raise_spanned_error pos "No definition found for subscope %a" + Message.error ~pos "Invalid definition, %a is not a subscope" Print.lit_style (Mark.remove y) + | None -> + Message.error ~pos "No definition found for subscope %a" Print.lit_style + (Mark.remove y) in let var_within_origin_scope = get_var_uid name ctxt x in ( (subscope_var, pos), Ast.ScopeDef.SubScopeInput { name; var_within_origin_scope } ) | _ -> - Message.raise_spanned_error pos + Message.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." @@ -937,8 +943,8 @@ let process_scope_use (ctxt : context) (suse : Surface.Ast.scope_use) : context with | Some (TScope (sn, _)) -> sn | _ -> - Message.raise_spanned_error - (Mark.get suse.Surface.Ast.scope_use_name) + Message.error + ~pos:(Mark.get suse.Surface.Ast.scope_use_name) "@{\"%s\"@}: this scope has not been declared anywhere, is it \ a typo?" (Mark.remove suse.Surface.Ast.scope_use_name) diff --git a/compiler/desugared/print.ml b/compiler/desugared/print.ml index 208a9a0a..50902d9f 100644 --- a/compiler/desugared/print.ml +++ b/compiler/desugared/print.ml @@ -86,19 +86,19 @@ let print_exceptions_graph (scope : ScopeName.t) (var : Ast.ScopeDef.t) (g : Dependency.ExceptionsDependencies.t) = - Message.emit_result + Message.result "Printing the tree of exceptions for the definitions of variable \"%a\" of \ scope \"%a\"." Ast.ScopeDef.format var ScopeName.format scope; Dependency.ExceptionsDependencies.iter_vertex (fun ex -> - Message.emit_result "@[Definitions with label \"%a\":@,%a@]" + Message.result "@[Definitions with label \"%a\":@,%a@]" LabelName.format ex.Dependency.ExceptionVertex.label (RuleName.Map.format_values Pos.format_loc_text) ex.Dependency.ExceptionVertex.rules) g; let tree = build_exception_tree g in - Message.emit_result "@[The exception tree structure is as follows:@,@,%a@]" + Message.result "@[The exception tree structure is as follows:@,@,%a@]" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt "@,@,") (fun fmt tree -> format_exception_tree fmt tree)) diff --git a/compiler/driver.ml b/compiler/driver.ml index afb519fb..10fb1f31 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -35,7 +35,7 @@ let load_module_interfaces (* Recurse into program modules, looking up files in [using] and loading them *) if program.Surface.Ast.program_used_modules <> [] then - Message.emit_debug "Loading module interfaces..."; + Message.debug "Loading module interfaces..."; let includes = List.map options.Global.path_rewrite includes @ more_includes |> List.map File.Tree.build @@ -56,13 +56,13 @@ let load_module_interfaces extensions with | [] -> - Message.raise_multispanned_error - (err_req_pos (mpos :: req_chain)) + Message.error + ~extra_pos:(err_req_pos (mpos :: req_chain)) "Required module not found: @{%s@}" mname | [f] -> f | ms -> - Message.raise_multispanned_error - (err_req_pos (mpos :: req_chain)) + Message.error + ~extra_pos:(err_req_pos (mpos :: req_chain)) "Required module @{%s@} matches multiple files:@;<1 2>%a" mname (Format.pp_print_list ~pp_sep:Format.pp_print_space File.format) ms @@ -81,8 +81,9 @@ let load_module_interfaces (Mark.remove use.Surface.Ast.mod_use_alias) modname use_map ) | Some None -> - Message.raise_multispanned_error - (err_req_pos (Mark.get use.Surface.Ast.mod_use_name :: req_chain)) + Message.error + ~extra_pos: + (err_req_pos (Mark.get use.Surface.Ast.mod_use_name :: req_chain)) "Circular module dependency" | None -> let default_module_name = @@ -131,7 +132,7 @@ module Passes = struct (forwarding their options as needed) *) let debug_pass_name s = - Message.emit_debug "@{=@} @{%s@} @{=@}" + Message.debug "@{=@} @{%s@} @{=@}" (String.uppercase_ascii s) let surface options : Surface.Ast.program = @@ -146,13 +147,13 @@ module Passes = struct let prg = surface options in let mod_uses, modules = load_module_interfaces options includes prg in debug_pass_name "desugared"; - Message.emit_debug "Name resolution..."; + Message.debug "Name resolution..."; let ctx = Desugared.Name_resolution.form_context (prg, mod_uses) modules in - Message.emit_debug "Desugaring..."; + Message.debug "Desugaring..."; let prg = Desugared.From_surface.translate_program ctx prg in - Message.emit_debug "Disambiguating..."; + Message.debug "Disambiguating..."; let prg = Desugared.Disambiguate.program prg in - Message.emit_debug "Linting..."; + Message.debug "Linting..."; Desugared.Linting.lint_program prg; prg, ctx @@ -185,16 +186,16 @@ module Passes = struct let (prg : ty Scopelang.Ast.program) = match typed with | Typed _ -> - Message.emit_debug "Typechecking..."; + Message.debug "Typechecking..."; Scopelang.Ast.type_program prg | Untyped _ -> prg | Custom _ -> invalid_arg "Driver.Passes.dcalc" in - Message.emit_debug "Translating to default calculus..."; + Message.debug "Translating to default calculus..."; let prg = Dcalc.From_scopelang.translate_program prg in let prg = if optimize then begin - Message.emit_debug "Optimizing default calculus..."; + Message.debug "Optimizing default calculus..."; Optimizations.optimize_program prg end else prg @@ -202,7 +203,7 @@ module Passes = struct let (prg : ty Dcalc.Ast.program) = match typed with | Typed _ -> ( - Message.emit_debug "Typechecking again..."; + Message.debug "Typechecking again..."; try Typing.program prg with Message.CompilerError error_content -> let bt = Printexc.get_raw_backtrace () in @@ -214,16 +215,15 @@ module Passes = struct | Custom _ -> assert false in if check_invariants then ( - Message.emit_debug "Checking invariants..."; + Message.debug "Checking invariants..."; match typed with | Typed _ -> if Dcalc.Invariants.check_all_invariants prg then - Message.emit_result "All invariant checks passed" + Message.result "All invariant checks passed" else raise - (Message.raise_internal_error "Some Dcalc invariants are invalid") - | _ -> - Message.raise_error "--check-invariants cannot be used with --no-typing"); + (Message.error ~internal:true "Some Dcalc invariants are invalid") + | _ -> Message.error "--check-invariants cannot be used with --no-typing"); prg, type_ordering let lcalc @@ -246,7 +246,7 @@ module Passes = struct let prg = match avoid_exceptions, options.trace, typed with | true, true, _ -> - Message.raise_error + Message.error "Option --avoid-exceptions is not compatible with option --trace" | true, _, Untyped _ -> Lcalc.From_dcalc.translate_program_without_exceptions prg @@ -260,32 +260,32 @@ module Passes = struct in let prg = if optimize then begin - Message.emit_debug "Optimizing lambda calculus..."; + Message.debug "Optimizing lambda calculus..."; Optimizations.optimize_program prg end else prg in let prg = if not closure_conversion then ( - Message.emit_debug "Retyping lambda calculus..."; + Message.debug "Retyping lambda calculus..."; Typing.program ~fail_on_any:false prg) else ( - Message.emit_debug "Performing closure conversion..."; + Message.debug "Performing closure conversion..."; let prg = Lcalc.Closure_conversion.closure_conversion prg in let prg = if optimize then ( - Message.emit_debug "Optimizing lambda calculus..."; + Message.debug "Optimizing lambda calculus..."; Optimizations.optimize_program prg) else prg in - Message.emit_debug "Retyping lambda calculus..."; + Message.debug "Retyping lambda calculus..."; Typing.program ~fail_on_any:false prg) in let prg, type_ordering = if monomorphize_types then ( - Message.emit_debug "Monomorphizing types..."; + Message.debug "Monomorphizing types..."; let prg, type_ordering = Lcalc.Monomorphize.program prg in - Message.emit_debug "Retyping lambda calculus..."; + Message.debug "Retyping lambda calculus..."; let prg = Typing.program ~fail_on_any:false ~assume_op_types:true prg in prg, type_ordering) else prg, type_ordering @@ -320,21 +320,21 @@ module Commands = struct let get_scope_uid (ctx : decl_ctx) (scope : string) : ScopeName.t = if String.contains scope '.' then - Message.raise_error + Message.error "Bad scope argument @{%s@}: only references to the top-level \ module are allowed" scope; try Ident.Map.find scope ctx.ctx_scope_index with Ident.Map.Not_found _ -> - Message.raise_error - "There is no scope \"@{%s@}\" inside the program." scope + Message.error "There is no scope \"@{%s@}\" inside the program." + scope (* TODO: this is very weird but I'm trying to maintain the current behaviour for now *) let get_random_scope_uid (ctx : decl_ctx) : ScopeName.t = match Ident.Map.choose_opt ctx.ctx_scope_index with | Some (_, name) -> name - | None -> Message.raise_error "There isn't any scope inside the program." + | None -> Message.error "There isn't any scope inside the program." let get_variable_uid (ctxt : Desugared.Name_resolution.context) @@ -353,7 +353,7 @@ module Commands = struct (ScopeName.Map.find scope_uid ctxt.scopes).var_idmap with | None -> - Message.raise_error + Message.error "Variable @{\"%s\"@} not found inside scope @{\"%a\"@}" variable ScopeName.format scope_uid | Some (ScopeVar v | SubScope (v, _, _)) -> @@ -365,7 +365,7 @@ module Commands = struct match Ident.Map.find_opt id var_sig.var_sig_states_idmap with | Some state -> state | None -> - Message.raise_error + Message.error "State @{\"%s\"@} is not found for variable \ @{\"%s\"@} of scope @{\"%a\"@}" id first_part ScopeName.format scope_uid @@ -387,7 +387,7 @@ module Commands = struct let backend_extensions_list = [".tex"] in let source_file = Global.input_src_file options.Global.input_src in let output_file, with_output = get_output options ~ext:".d" output in - Message.emit_debug "Writing list of dependencies to %s..." + Message.debug "Writing list of dependencies to %s..." (Option.value ~default:"stdout" output_file); with_output @@ fun oc -> @@ -410,7 +410,7 @@ module Commands = struct let html options output print_only_law wrap_weaved_output = let prg = Passes.surface options in - Message.emit_debug "Weaving literate program into HTML"; + Message.debug "Weaving literate program into HTML"; let output_file, with_output = get_output_format options ~ext:".html" output in @@ -420,8 +420,7 @@ module Commands = struct Cli.file_lang (Global.input_src_file options.Global.input_src) in let weave_output = Literate.Html.ast_to_html language ~print_only_law in - Message.emit_debug "Writing to %s" - (Option.value ~default:"stdout" output_file); + Message.debug "Writing to %s" (Option.value ~default:"stdout" output_file); if wrap_weaved_output then Literate.Html.wrap_html prg.Surface.Ast.program_source_files language fmt (fun fmt -> weave_output fmt prg) @@ -448,7 +447,7 @@ module Commands = struct |> Surface.Fill_positions.fill_pos_with_legislative_info) extra_files in - Message.emit_debug "Weaving literate program into LaTeX"; + Message.debug "Weaving literate program into LaTeX"; let output_file, with_output = get_output_format options ~ext:".tex" output in @@ -458,8 +457,7 @@ module Commands = struct Cli.file_lang (Global.input_src_file options.Global.input_src) in let weave_output = Literate.Latex.ast_to_latex language ~print_only_law in - Message.emit_debug "Writing to %s" - (Option.value ~default:"stdout" output_file); + Message.debug "Writing to %s" (Option.value ~default:"stdout" output_file); let weave fmt = weave_output fmt prg; List.iter @@ -548,13 +546,13 @@ module Commands = struct let typecheck options check_invariants includes = let prg = Passes.scopelang options ~includes in - Message.emit_debug "Typechecking..."; + Message.debug "Typechecking..."; let _type_ordering = Scopelang.Dependency.check_type_cycles prg.program_ctx.ctx_structs prg.program_ctx.ctx_enums in let prg = Scopelang.Ast.type_program prg in - Message.emit_debug "Translating to default calculus..."; + Message.debug "Translating to default calculus..."; (* Strictly type-checking could stop here, but we also want this pass to check full name-resolution and cycle detection. These are checked during translation to dcalc so we run it here and drop the result. *) @@ -563,12 +561,12 @@ module Commands = struct (* Additionally, we might want to check the invariants. *) if check_invariants then ( let prg = Shared_ast.Typing.program prg in - Message.emit_debug "Checking invariants..."; + Message.debug "Checking invariants..."; if Dcalc.Invariants.check_all_invariants prg then - Message.emit_result "All invariant checks passed" + Message.result "All invariant checks passed" else - raise (Message.raise_internal_error "Some Dcalc invariants are invalid")); - Message.emit_result "Typechecking successful!" + raise (Message.error ~internal:true "Some Dcalc invariants are invalid")); + Message.result "Typechecking successful!" let typecheck_cmd = Cmd.v @@ -662,20 +660,20 @@ module Commands = struct $ Cli.Flags.disable_counterexamples) let print_interpretation_results options interpreter prg scope_uid = - Message.emit_debug "Starting interpretation..."; + Message.debug "Starting interpretation..."; let results = interpreter prg scope_uid in - Message.emit_debug "End of interpretation"; + Message.debug "End of interpretation"; let results = List.sort (fun ((v1, _), _) ((v2, _), _) -> String.compare v1 v2) results in - Message.emit_result "Computation successful!%s" + Message.result "Computation successful!%s" (if List.length results > 0 then " Results:" else ""); let language = Cli.file_lang (Global.input_src_file options.Global.input_src) in List.iter (fun ((var, _), result) -> - Message.emit_result "@[%s@ =@ %a@]" var + Message.result "@[%s@ =@ %a@]" var (if options.Global.debug then Print.expr ~debug:false () else Print.UserFacing.value language) result) @@ -764,7 +762,7 @@ module Commands = struct = if not lcalc then if avoid_exceptions || closure_conversion || monomorphize_types then - Message.raise_error + Message.error "The flags @{--avoid-exceptions@}, \ @{--closure-conversion@} and @{--monomorphize-types@} \ only make sense with the @{--lcalc@} option" @@ -814,8 +812,8 @@ module Commands = struct in with_output @@ fun fmt -> - Message.emit_debug "Compiling program into OCaml..."; - Message.emit_debug "Writing to %s..." + Message.debug "Compiling program into OCaml..."; + Message.debug "Writing to %s..." (Option.value ~default:"stdout" output_file); let exec_scope = Option.map (get_scope_uid prg.decl_ctx) ex_scope_opt in Lcalc.To_ocaml.format_program fmt prg ?exec_scope type_ordering @@ -908,8 +906,8 @@ module Commands = struct let output_file, with_output = get_output_format options ~ext:".py" output in - Message.emit_debug "Compiling program into Python..."; - Message.emit_debug "Writing to %s..." + Message.debug "Compiling program into Python..."; + Message.debug "Writing to %s..." (Option.value ~default:"stdout" output_file); with_output @@ fun fmt -> Scalc.To_python.format_program fmt prg type_ordering @@ -937,8 +935,8 @@ module Commands = struct in let output_file, with_output = get_output_format options ~ext:".r" output in - Message.emit_debug "Compiling program into R..."; - Message.emit_debug "Writing to %s..." + Message.debug "Compiling program into R..."; + Message.debug "Writing to %s..." (Option.value ~default:"stdout" output_file); with_output @@ fun fmt -> Scalc.To_r.format_program fmt prg type_ordering @@ -962,8 +960,8 @@ module Commands = struct ~monomorphize_types:true in let output_file, with_output = get_output_format options ~ext:".c" output in - Message.emit_debug "Compiling program into C..."; - Message.emit_debug "Writing to %s..." + Message.debug "Compiling program into C..."; + Message.debug "Writing to %s..." (Option.value ~default:"stdout" output_file); with_output @@ fun fmt -> Scalc.To_c.format_program fmt prg type_ordering @@ -1019,7 +1017,7 @@ module Commands = struct | None -> f | Some pfx -> if not (Filename.is_relative f) then ( - Message.emit_warning + Message.warning "Not adding prefix to %s, which is an absolute path" f; f) else File.(pfx / f) @@ -1090,7 +1088,7 @@ end let raise_help cmdname cmds = let plugins = Plugin.names () in let cmds = List.filter (fun name -> not (List.mem name plugins)) cmds in - Message.raise_error + Message.error "One of the following commands was expected:@;\ <1 4>@[@{%a@}@]%a@\n\ Run `@{%s --help@}' or `@{%s COMMAND --help@}' for details." @@ -1140,9 +1138,9 @@ let main () = else match Sys.is_directory d with | true -> Plugin.load_dir d - | false -> Message.emit_debug "Could not read plugin directory %s" d + | false -> Message.debug "Could not read plugin directory %s" d | exception Sys_error _ -> - Message.emit_debug "Could not read plugin directory %s" d) + Message.debug "Could not read plugin directory %s" d) plugins_dirs; Dynlink.allow_only ["Runtime_ocaml__Runtime"]; (* We may use dynlink again, but only for runtime modules: no plugin diff --git a/compiler/lcalc/compile_with_exceptions.ml b/compiler/lcalc/compile_with_exceptions.ml index b8f76363..d7fccb8a 100644 --- a/compiler/lcalc/compile_with_exceptions.ml +++ b/compiler/lcalc/compile_with_exceptions.ml @@ -28,11 +28,11 @@ let rec translate_typ (tau : typ) : typ = | TStruct s -> TStruct s | TEnum en -> TEnum en | TOption _ -> - Message.raise_internal_error + Message.error ~internal:true "The types option should not appear before the dcalc -> lcalc \ translation step." | TClosureEnv -> - Message.raise_internal_error + Message.error ~internal:true "The types closure_env should not appear before the dcalc -> lcalc \ translation step." | TAny -> TAny diff --git a/compiler/lcalc/compile_without_exceptions.ml b/compiler/lcalc/compile_without_exceptions.ml index 1779fd3a..8779fd50 100644 --- a/compiler/lcalc/compile_without_exceptions.ml +++ b/compiler/lcalc/compile_without_exceptions.ml @@ -38,11 +38,11 @@ let rec translate_typ (tau : typ) : typ = | TStruct s -> TStruct s | TEnum en -> TEnum en | TOption _ -> - Message.raise_internal_error + Message.error ~internal:true "The types option should not appear before the dcalc -> lcalc \ translation step." | TClosureEnv -> - Message.raise_internal_error + Message.error ~internal:true "The types closure_env should not appear before the dcalc -> lcalc \ translation step." | TAny -> TAny diff --git a/compiler/lcalc/to_ocaml.ml b/compiler/lcalc/to_ocaml.ml index 7f4fae77..2b99f283 100644 --- a/compiler/lcalc/to_ocaml.ml +++ b/compiler/lcalc/to_ocaml.ml @@ -654,7 +654,7 @@ let format_scope_exec StructName.Map.find scope_body.scope_body_input_struct ctx.ctx_structs in if not (StructField.Map.is_empty scope_input) then - Message.raise_error + Message.error "The scope @{%s@} defines input variables.@ This is not supported \ for a main scope at the moment." scope_name_str; @@ -688,10 +688,10 @@ let format_scope_exec_args |> List.rev in if scopes_with_no_input = [] then - Message.raise_error + Message.error "No scopes that don't require input were found, executable can't be \ generated"; - Message.emit_debug "@[Generating entry points for scopes:@ %a@]@." + Message.debug "@[Generating entry points for scopes:@ %a@]@." (Format.pp_print_list ~pp_sep:Format.pp_print_space (fun ppf (_, s, _) -> ScopeName.format ppf s)) scopes_with_no_input; @@ -793,7 +793,7 @@ let format_program format_scope_exec p.decl_ctx fmt bnd scope_name scope_body | None, None -> if exec_args then format_scope_exec_args p.decl_ctx fmt bnd | Some _, Some _ -> - Message.raise_error + Message.error "OCaml generation: both module registration and top-level scope \ execution where required at the same time." in diff --git a/compiler/literate/html.ml b/compiler/literate/html.ml index 8850e2dd..f42cdcf9 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 = - Message.emit_debug "Pygmenting the code chunk %s" (Pos.to_string (Mark.get c)); + Message.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) @@ fun temp_file_in -> diff --git a/compiler/literate/latex.ml b/compiler/literate/latex.ml index e4add7c4..707d84c3 100644 --- a/compiler/literate/latex.ml +++ b/compiler/literate/latex.ml @@ -339,5 +339,4 @@ let ast_to_latex Format.pp_print_cut fmt ()) program.program_items; Format.pp_close_box fmt (); - Message.emit_debug "Lines of Catala inside literate source code: %d" - !lines_of_code + Message.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 b5c1f41b..9877cccb 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 = - Message.raise_error + Message.error "Weaving failed: pandoc command \"%s\" returned with error code %d" command error_code @@ -113,9 +113,10 @@ let check_exceeding_lines Uutf.String.fold_utf_8 (fun (acc : int) _ _ -> acc + 1) 0 s in if len_s > max_len then - Message.emit_spanned_warning - (Pos.from_info filename (start_line + i) (max_len + 1) - (start_line + i) (len_s + 1)) + Message.warning + ~pos: + (Pos.from_info filename (start_line + i) (max_len + 1) + (start_line + i) (len_s + 1)) "This line is exceeding @{%d@} characters" max_len) let with_pygmentize_lexer lang f = @@ -132,7 +133,7 @@ let call_pygmentize ?lang args = let cmd = "pygmentize" in let check_exit n = if n <> 0 then - Message.raise_error + Message.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 e125fab1..91ad352b 100644 --- a/compiler/plugin.ml +++ b/compiler/plugin.ml @@ -32,26 +32,25 @@ let load_failures = Hashtbl.create 17 let print_failures () = if Hashtbl.length load_failures > 0 then - Message.emit_warning "Some plugins could not be loaded:@,%a" + Message.warning "Some plugins could not be loaded:@,%a" (Format.pp_print_seq (fun ppf -> Format.fprintf ppf " - %s")) (Hashtbl.to_seq_values load_failures) let load_file f = try Dynlink.loadfile f; - Message.emit_debug "Plugin %S loaded" f + Message.debug "Plugin %S loaded" f with | Dynlink.Error (Dynlink.Module_already_loaded s) -> - Message.emit_debug "Plugin %S (%s) was already loaded, skipping" f s + Message.debug "Plugin %S (%s) was already loaded, skipping" f s | Dynlink.Error err -> let msg = Dynlink.error_message err in - Message.emit_debug "Could not load plugin %S: %s" f msg; + Message.debug "Could not load plugin %S: %s" f msg; Hashtbl.add load_failures f msg - | e -> - Message.emit_warning "Could not load plugin %S: %s" f (Printexc.to_string e) + | e -> Message.warning "Could not load plugin %S: %s" f (Printexc.to_string e) let load_dir d = - Message.emit_debug "Loading plugins from %s" d; + Message.debug "Loading plugins from %s" d; let dynlink_exts = if Dynlink.is_native then [".cmxs"] else [".cmo"; ".cma"] in diff --git a/compiler/plugins/api_web.ml b/compiler/plugins/api_web.ml index bd585ac6..b080a83c 100644 --- a/compiler/plugins/api_web.ml +++ b/compiler/plugins/api_web.ml @@ -308,7 +308,7 @@ module To_jsoo = struct (fun fmt (cname, typ) -> match Mark.remove typ with | TTuple _ -> - Message.raise_spanned_error (Mark.get typ) + Message.error ~pos:(Mark.get typ) "Tuples aren't yet supported in the conversion to JS..." | TLit TUnit -> Format.fprintf fmt "@[| \"%a\" ->@ %a.%a ()@]" @@ -485,7 +485,7 @@ let run Driver.Commands.get_output_format options ~ext:"_api_web.ml" output in with_formatter (fun fmt -> - Message.emit_debug "Writing JSOO API code to %s..." + Message.debug "Writing JSOO API code to %s..." (Option.value ~default:"stdout" jsoo_output_file); let modname = match prg.module_name with diff --git a/compiler/plugins/explain.ml b/compiler/plugins/explain.ml index 18b381dd..285145c0 100644 --- a/compiler/plugins/explain.ml +++ b/compiler/plugins/explain.ml @@ -30,7 +30,7 @@ type flags = { (* -- Definition of the lazy interpreter -- *) let log fmt = Format.ifprintf Format.err_formatter (fmt ^^ "@\n") -let error e = Message.raise_spanned_error (Expr.pos e) +let error e = Message.error ~pos:(Expr.pos e) let noassert = true module Env = struct @@ -366,9 +366,10 @@ let rec lazy_eval : decl_ctx -> Env.t -> laziness_level -> expr -> expr * Env.t log "@[EVAL %a@]" Expr.format e; lazy_eval ctx env llevel e | _ :: _ :: _ -> - Message.raise_multispanned_error - ((None, Expr.mark_pos m) - :: List.map (fun (e, _) -> None, Expr.pos e) excs) + Message.error + ~extra_pos: + ((None, Expr.mark_pos m) + :: List.map (fun (e, _) -> None, Expr.pos e) excs) "Conflicting exceptions") | EPureDefault e, _ -> lazy_eval ctx env llevel e | EIfThenElse { cond; etrue; efalse }, _ -> ( @@ -693,7 +694,7 @@ let program_to_graph in (G.add_edge g v child_v, var_vertices, env), v with Var.Map.Not_found _ -> - Message.emit_warning "VAR NOT FOUND: %a" Print.var var; + Message.warning "VAR NOT FOUND: %a" Print.var var; let v = G.V.create e in let g = G.add_vertex g v in (g, var_vertices, env), v)) diff --git a/compiler/plugins/json_schema.ml b/compiler/plugins/json_schema.ml index 358ba8ab..70779512 100644 --- a/compiler/plugins/json_schema.ml +++ b/compiler/plugins/json_schema.ml @@ -226,7 +226,7 @@ let run with_output @@ fun fmt -> let scope_uid = Driver.Commands.get_scope_uid prg.decl_ctx ex_scope in - Message.emit_debug + Message.debug "Writing JSON schema corresponding to the scope '%a' to the file %s..." ScopeName.format scope_uid (Option.value ~default:"stdout" output_file); diff --git a/compiler/plugins/lazy_interp.ml b/compiler/plugins/lazy_interp.ml index 009c4ff7..c94df352 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 = Message.raise_spanned_error (Expr.pos e) +let error e = Message.error ~pos:(Expr.pos e) let noassert = true type laziness_level = { @@ -197,9 +197,10 @@ let rec lazy_eval : log "@[EVAL %a@]" Expr.format e; lazy_eval ctx env llevel e | _ :: _ :: _ -> - Message.raise_multispanned_error - ((None, Expr.mark_pos m) - :: List.map (fun (e, _) -> None, Expr.pos e) excs) + Message.error + ~extra_pos: + ((None, Expr.mark_pos m) + :: List.map (fun (e, _) -> None, Expr.pos e) excs) "Conflicting exceptions") | EPureDefault e, _ -> lazy_eval ctx env llevel e | EIfThenElse { cond; etrue; efalse }, _ -> ( diff --git a/compiler/plugins/python.ml b/compiler/plugins/python.ml index 6c33511d..3ec2c558 100644 --- a/compiler/plugins/python.ml +++ b/compiler/plugins/python.ml @@ -39,9 +39,8 @@ let run in let output_file, with_output = get_output_format options ~ext:".py" output in - Message.emit_debug "Compiling program into Python..."; - Message.emit_debug "Writing to %s..." - (Option.value ~default:"stdout" output_file); + Message.debug "Compiling program into Python..."; + Message.debug "Writing to %s..." (Option.value ~default:"stdout" output_file); with_output @@ fun fmt -> Scalc.To_python.format_program fmt prg type_ordering let term = diff --git a/compiler/scalc/from_lcalc.ml b/compiler/scalc/from_lcalc.ml index 82202763..b67e7f05 100644 --- a/compiler/scalc/from_lcalc.ml +++ b/compiler/scalc/from_lcalc.ml @@ -58,7 +58,7 @@ let rec translate_expr (ctxt : 'm ctxt) (expr : 'm L.expr) : A.block * A.expr = with Var.Map.Not_found _ -> ( try A.EFunc (Var.Map.find v ctxt.func_dict) with Var.Map.Not_found _ -> - Message.raise_spanned_error (Expr.pos expr) + Message.error ~pos:(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 (fun ppf v -> diff --git a/compiler/scalc/to_c.ml b/compiler/scalc/to_c.ml index 9dd90170..83a53429 100644 --- a/compiler/scalc/to_c.ml +++ b/compiler/scalc/to_c.ml @@ -158,7 +158,7 @@ let rec format_typ (List.mapi (fun x y -> y, x) ts) | TStruct s -> Format.fprintf fmt "%a %t" format_struct_name s element_name | TOption _ -> - Message.raise_internal_error + Message.error ~internal:true "All option types should have been monomorphized before compilation to C." | TDefault t -> format_typ decl_ctx element_name fmt t | TEnum e -> Format.fprintf fmt "%a %t" format_enum_name e element_name @@ -384,7 +384,7 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) : (format_expression ctx)) args | ETuple _ | ETupleAccess _ -> - Message.raise_internal_error "Tuple compilation to C unimplemented!" + Message.error ~internal:true "Tuple compilation to C unimplemented!" | EExternal _ -> failwith "TODO" let typ_is_array (ctx : decl_ctx) (typ : typ) = @@ -402,7 +402,7 @@ let rec format_statement (s : stmt Mark.pos) : unit = match Mark.remove s with | SInnerFuncDef _ -> - Message.raise_spanned_error (Mark.get s) + Message.error ~pos:(Mark.get s) "Internal error: this inner functions should have been hoisted in Scalc" | SLocalDecl { name = v; typ = ty } -> Format.fprintf fmt "@[%a@];" diff --git a/compiler/scalc/to_r.ml b/compiler/scalc/to_r.ml index af679d62..1b13f883 100644 --- a/compiler/scalc/to_r.ml +++ b/compiler/scalc/to_r.ml @@ -339,7 +339,7 @@ let rec format_expression (ctx : decl_ctx) (fmt : Format.formatter) (e : expr) : Format.fprintf fmt "%a(%a)" format_op (op, Pos.no_pos) (format_expression ctx) arg1 | EAppOp { op = HandleDefaultOpt; _ } -> - Message.raise_internal_error + Message.error ~internal:true "R compilation does not currently support the avoiding of exceptions" | EAppOp { op = HandleDefault as op; args; _ } -> let pos = Mark.get e in diff --git a/compiler/scopelang/dependency.ml b/compiler/scopelang/dependency.ml index 8644ae0d..94f476b1 100644 --- a/compiler/scopelang/dependency.ml +++ b/compiler/scopelang/dependency.ml @@ -118,8 +118,8 @@ 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 - Message.raise_spanned_error - (Mark.get (TopdefName.get_info glo_name)) + Message.error + ~pos:(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" TopdefName.format glo_name; @@ -136,8 +136,8 @@ 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 - Message.raise_spanned_error - (Mark.get (ScopeName.get_info scope.Ast.scope_decl_name)) + Message.error + ~pos:(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" ScopeName.format scope.Ast.scope_decl_name; @@ -191,7 +191,7 @@ let check_for_cycle_in_defs (g : SDependencies.t) : unit = cycle (List.tl cycle @ [List.hd cycle]) in - Message.raise_multispanned_error spans + Message.error ~extra_pos:spans "@[Cyclic dependency detected between the following scopes:@ \ @[%a@]@]" (Format.pp_print_list @@ -282,7 +282,7 @@ let build_type_graph (structs : struct_ctx) (enums : enum_ctx) : TDependencies.t TVertexSet.fold (fun used g -> if TVertex.equal used def then - Message.raise_spanned_error (Mark.get typ) + Message.error ~pos:(Mark.get typ) "The type %a is defined using itself, which is forbidden \ since Catala does not provide recursive types" TVertex.format used @@ -304,7 +304,7 @@ let build_type_graph (structs : struct_ctx) (enums : enum_ctx) : TDependencies.t TVertexSet.fold (fun used g -> if TVertex.equal used def then - Message.raise_spanned_error (Mark.get typ) + Message.error ~pos:(Mark.get typ) "The type %a is defined using itself, which is forbidden \ since Catala does not provide recursive types" TVertex.format used @@ -347,6 +347,5 @@ let check_type_cycles (structs : struct_ctx) (enums : enum_ctx) : TVertex.t list ]) scc) in - Message.raise_multispanned_error spans - "Cyclic dependency detected between types!"); + Message.error ~extra_pos: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 a27cf337..cdc4e76b 100644 --- a/compiler/scopelang/from_desugared.ml +++ b/compiler/scopelang/from_desugared.ml @@ -214,27 +214,29 @@ let rule_to_exception_graph (scope : D.scope) = function let () = match Mark.remove scope_def.D.scope_def_io.io_input with | NoInput -> - Message.raise_multispanned_error - (( Some "Incriminated subscope:", - Mark.get (ScopeVar.get_info (Mark.remove sscope)) ) - :: ( Some "Incriminated variable:", - Mark.get (ScopeVar.get_info var_within_origin_scope) ) - :: List.map - (fun rule -> - ( Some "Incriminated subscope variable definition:", - Mark.get (RuleName.get_info rule) )) - (RuleName.Map.keys def)) + Message.error + ~extra_pos: + (( Some "Incriminated subscope:", + Mark.get (ScopeVar.get_info (Mark.remove sscope)) ) + :: ( Some "Incriminated variable:", + Mark.get (ScopeVar.get_info var_within_origin_scope) ) + :: List.map + (fun rule -> + ( Some "Incriminated subscope variable definition:", + Mark.get (RuleName.get_info rule) )) + (RuleName.Map.keys def)) "Invalid assignment to a subscope variable that is not tagged \ as input or context." | OnlyInput when RuleName.Map.is_empty def && not is_cond -> (* If the subscope variable is tagged as input, then it shall be defined. *) - Message.raise_multispanned_error - [ - ( Some "Incriminated subscope:", - Mark.get (ScopeVar.get_info (Mark.remove sscope)) ); - Some "Incriminated variable:", Mark.get sscope; - ] + Message.error + ~extra_pos: + [ + ( Some "Incriminated subscope:", + Mark.get (ScopeVar.get_info (Mark.remove sscope)) ); + Some "Incriminated variable:", Mark.get sscope; + ] "This subscope variable is a mandatory input but no definition \ was provided." | _ -> () @@ -251,13 +253,14 @@ let rule_to_exception_graph (scope : D.scope) = function match Mark.remove scope_def.D.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. *) - Message.raise_multispanned_error - ((Some "Incriminated variable:", Mark.get (ScopeVar.get_info var)) - :: List.map - (fun rule -> - ( Some "Incriminated variable definition:", - Mark.get (RuleName.get_info rule) )) - (RuleName.Map.keys var_def)) + Message.error + ~extra_pos: + ((Some "Incriminated variable:", Mark.get (ScopeVar.get_info var)) + :: List.map + (fun rule -> + ( Some "Incriminated variable definition:", + Mark.get (RuleName.get_info rule) )) + (RuleName.Map.keys var_def)) "It is impossible to give a definition to a scope variable tagged as \ input." | OnlyInput -> D.ScopeDef.Map.empty @@ -909,8 +912,7 @@ let translate_program (fun id -> function | Some e, ty -> Expr.unbox (translate_expr ctx e), ty | None, (_, pos) -> - Message.raise_spanned_error pos "No definition found for %a" - TopdefName.format id) + Message.error ~pos "No definition found for %a" TopdefName.format id) desugared.program_root.module_topdefs in let program_scopes = diff --git a/compiler/shared_ast/expr.ml b/compiler/shared_ast/expr.ml index d59f2108..6f9c3979 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] -> - Message.raise_internal_error + Message.error ~internal:true "The boxed term is not closed the variable %s is free in the global \ context" h | l -> - Message.raise_internal_error + Message.error ~internal:true "The boxed term is not closed the variables %a is free in the global \ context" (Format.pp_print_list @@ -935,10 +935,10 @@ let make_tupleaccess e index size pos = | TTuple tl, _ -> ( try List.nth tl index with Failure _ -> - Message.raise_internal_error "Trying to build invalid tuple access") + Message.error ~internal:true "Trying to build invalid tuple access") | TAny, pos -> TAny, pos | ty -> - Message.raise_internal_error "Unexpected non-tuple type annotation %a" + Message.error ~internal:true "Unexpected non-tuple type annotation %a" Print.typ_debug ty) (Mark.get e) in @@ -957,7 +957,7 @@ let make_app f args tys pos = tr | TAny -> fty.ty | _ -> - Message.raise_internal_error + Message.error ~internal:true "wrong type: found %a while expecting either an Arrow or Any" Print.typ_debug fty.ty)) (List.map Mark.get (f :: args)) @@ -972,7 +972,7 @@ let make_erroronempty e = | TDefault ty, _ -> ty | TAny, pos -> TAny, pos | ty -> - Message.raise_internal_error + Message.error ~internal:true "wrong type: found %a while expecting a TDefault on@;<1 2>%a" Print.typ_debug ty format (unbox e)) (Mark.get e) diff --git a/compiler/shared_ast/interpreter.ml b/compiler/shared_ast/interpreter.ml index 61e66c1a..323c0e45 100644 --- a/compiler/shared_ast/interpreter.ml +++ b/compiler/shared_ast/interpreter.ml @@ -38,8 +38,8 @@ let print_log lang entry infos pos e = if Global.options.trace then match entry with | VarDef _ -> - Message.emit_log "%s%a %a: @{%s@}" !indent_str Print.log_entry - entry Print.uid_list infos + Message.log "%s%a %a: @{%s@}" !indent_str Print.log_entry entry + Print.uid_list infos (Message.unformat (fun ppf -> (if Global.options.debug then Print.expr ~debug:true () else Print.UserFacing.expr lang) @@ -47,17 +47,17 @@ let print_log lang entry infos pos e = | PosRecordIfTrueBool -> ( match pos <> Pos.no_pos, Mark.remove e with | true, ELit (LBool true) -> - Message.emit_log "%s@[%a@{Definition applied@}:@,%a@]" - !indent_str Print.log_entry entry Pos.format_loc_text pos + Message.log "%s@[%a@{Definition applied@}:@,%a@]" !indent_str + Print.log_entry entry Pos.format_loc_text pos | _ -> ()) | BeginCall -> - Message.emit_log "%s%a %a" !indent_str Print.log_entry entry - Print.uid_list infos; + Message.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); - Message.emit_log "%s%a %a" !indent_str Print.log_entry entry - Print.uid_list infos + Message.log "%s%a %a" !indent_str Print.log_entry entry Print.uid_list + infos exception CatalaException of except * Pos.t @@ -130,34 +130,36 @@ let rec evaluate_operator in try f x y with | Division_by_zero -> - Message.raise_multispanned_error - [ - Some "The division operator:", pos; - Some "The null denominator:", Expr.pos (List.nth args 1); - ] + Message.error + ~extra_pos: + [ + Some "The division operator:", pos; + Some "The null denominator:", Expr.pos (List.nth args 1); + ] "division by zero at runtime" | Runtime.UncomparableDurations -> - Message.raise_multispanned_error (get_binop_args_pos args) + Message.error ~extra_pos:(get_binop_args_pos args) "Cannot compare together durations that cannot be converted to a \ precise number of days" in let err () = - Message.raise_multispanned_error - ([ - ( Some - (Format.asprintf "Operator (value %a):" - (Print.operator ~debug:true) - op), - pos ); - ] - @ List.mapi - (fun i arg -> - ( Some - (Format.asprintf "Argument n°%d, value %a" (i + 1) - (Print.UserFacing.expr lang) - arg), - Expr.pos arg )) - args) + Message.error + ~extra_pos: + ([ + ( Some + (Format.asprintf "Operator (value %a):" + (Print.operator ~debug:true) + op), + pos ); + ] + @ List.mapi + (fun i arg -> + ( Some + (Format.asprintf "Argument n°%d, value %a" (i + 1) + (Print.UserFacing.expr lang) + arg), + Expr.pos arg )) + args) "Operator %a applied to the wrong arguments\n\ (should not happen if the term was well-typed)%a" (Print.operator ~debug:true) @@ -234,8 +236,8 @@ let rec evaluate_operator with | ELit (LBool b), _ -> b | _ -> - Message.raise_spanned_error - (Expr.pos (List.nth args 0)) + Message.error + ~pos:(Expr.pos (List.nth args 0)) "This predicate evaluated to something else than a boolean \ (should not happen if the term was well-typed)") es) @@ -391,7 +393,7 @@ let rec evaluate_operator (evaluate_expr (Expr.unthunk_term_nobox cons (Mark.get cons))) | ELit (LBool false) -> raise (CatalaException (EmptyError, pos)) | _ -> - Message.raise_spanned_error pos + Message.error ~pos "Default justification has not been reduced to a boolean at \ evaluation (should not happen if the term was well-typed@\n\ %a@." @@ -602,7 +604,7 @@ and val_to_runtime : curry [] targs | TDefault ty, _ -> val_to_runtime eval_expr ctx ty v | _ -> - Message.raise_internal_error + Message.error ~internal:true "Could not convert value of type %a to runtime: %a" (Print.typ ctx) ty Expr.format v @@ -617,7 +619,7 @@ let rec evaluate_expr : let pos = Expr.mark_pos m in match Mark.remove e with | EVar _ -> - Message.raise_spanned_error pos + Message.error ~pos "free variable found at evaluation (should not happen if term was \ well-typed)" | EExternal { name } -> @@ -637,7 +639,7 @@ let rec evaluate_expr : (TStruct scope_info.out_struct_name, pos) ), pos ) with TopdefName.Map.Not_found _ | ScopeName.Map.Not_found _ -> - Message.raise_spanned_error pos "Reference to %a could not be resolved" + Message.error ~pos "Reference to %a could not be resolved" Print.external_ref name in let runtime_path = @@ -659,8 +661,7 @@ let rec evaluate_expr : evaluate_expr ctx lang (Bindlib.msubst binder (Array.of_list (List.map Mark.remove args))) else - Message.raise_spanned_error pos - "wrong function call, expected %d arguments, got %d" + Message.error ~pos "wrong function call, expected %d arguments, got %d" (Bindlib.mbinder_arity binder) (List.length args) | ECustom { obj; targs; tret } -> @@ -674,7 +675,7 @@ let rec evaluate_expr : |> fun o -> runtime_to_val (fun ctx -> evaluate_expr ctx lang) ctx m tret o | _ -> - Message.raise_spanned_error pos + Message.error ~pos "function has not been reduced to a lambda at evaluation (should not \ happen if the term was well-typed") | EAppOp { op; args; _ } -> @@ -697,19 +698,19 @@ let rec evaluate_expr : match Mark.remove e with | EStruct { fields = es; name } -> ( if not (StructName.equal s name) then - Message.raise_multispanned_error - [None, pos; None, Expr.pos e] + Message.error + ~extra_pos:[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 -> - Message.raise_spanned_error (Expr.pos e) + Message.error ~pos:(Expr.pos e) "Invalid field access %a in struct %a (should not happen if the term \ was well-typed)" StructField.format field StructName.format s) | _ -> - Message.raise_spanned_error (Expr.pos e) + Message.error ~pos:(Expr.pos e) "The expression %a should be a struct %a but is not (should not happen \ if the term was well-typed)" (Print.UserFacing.expr lang) @@ -719,7 +720,7 @@ let rec evaluate_expr : match evaluate_expr ctx lang e1 with | ETuple es, _ when List.length es = size -> List.nth es index | e -> - Message.raise_spanned_error (Expr.pos e) + Message.error ~pos:(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.UserFacing.expr lang) @@ -732,15 +733,15 @@ let rec evaluate_expr : match Mark.remove e with | EInj { e = e1; cons; name = name' } -> if not (EnumName.equal name name') then - Message.raise_multispanned_error - [None, Expr.pos e; None, Expr.pos e1] + Message.error + ~extra_pos:[None, Expr.pos e; None, Expr.pos e1] "Error during match: two different enums found (should not happen if \ the term was well-typed)"; let es_n = match EnumConstructor.Map.find_opt cons cases with | Some es_n -> es_n | None -> - Message.raise_spanned_error (Expr.pos e) + Message.error ~pos:(Expr.pos e) "sum type index error (should not happen if the term was \ well-typed)" in @@ -750,7 +751,7 @@ let rec evaluate_expr : let new_e = Mark.add m (EApp { f = es_n; args = [e1]; tys = [ty] }) in evaluate_expr ctx lang new_e | _ -> - Message.raise_spanned_error (Expr.pos e) + Message.error ~pos:(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 } -> ( @@ -759,7 +760,7 @@ let rec evaluate_expr : | ELit (LBool true) -> evaluate_expr ctx lang etrue | ELit (LBool false) -> evaluate_expr ctx lang efalse | _ -> - Message.raise_spanned_error (Expr.pos cond) + Message.error ~pos:(Expr.pos cond) "Expected a boolean literal for the result of this condition (should \ not happen if the term was well-typed)") | EArray es -> @@ -770,18 +771,18 @@ let rec evaluate_expr : match Mark.remove e with | ELit (LBool true) -> Mark.add m (ELit LUnit) | ELit (LBool false) -> - Message.raise_spanned_error (Expr.pos e') "Assertion failed:@\n%a" + Message.error ~pos:(Expr.pos e') "Assertion failed:@\n%a" (Print.UserFacing.expr lang) (partially_evaluate_expr_for_assertion_failure_message ctx lang (Expr.skip_wrappers e')) | _ -> - Message.raise_spanned_error (Expr.pos e') + Message.error ~pos:(Expr.pos e') "Expected a boolean literal for the result of this assertion (should \ not happen if the term was well-typed)") | EErrorOnEmpty e' -> ( match evaluate_expr ctx lang e' with | EEmptyError, _ -> - Message.raise_spanned_error (Expr.pos e') + Message.error ~pos:(Expr.pos e') "This variable evaluated to an empty term (no rule that defined it \ applied in this situation)" | e -> e) @@ -795,7 +796,7 @@ let rec evaluate_expr : | ELit (LBool true) -> evaluate_expr ctx lang cons | ELit (LBool false) -> Mark.copy e EEmptyError | _ -> - Message.raise_spanned_error (Expr.pos e) + Message.error ~pos:(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 @@ -913,21 +914,22 @@ let delcustom e = let interp_failure_message ~pos = function | NoValueProvided -> - Message.raise_spanned_error pos + Message.error ~pos "This variable evaluated to an empty term (no rule that defined it \ applied in this situation)" | ConflictError cpos -> - Message.raise_multispanned_error - (List.map - (fun pos -> Some "This consequence has a valid justification:", pos) - cpos) + Message.error + ~extra_pos: + (List.map + (fun pos -> Some "This consequence has a valid justification:", pos) + cpos) "There is a conflict between multiple valid consequences for assigning \ the same variable." | Crash -> (* This constructor seems to be never used *) - Message.raise_spanned_error pos "Internal error, the interpreter crashed" + Message.error ~pos "Internal error, the interpreter crashed" | EmptyError -> - Message.raise_spanned_error pos + Message.error ~pos "Internal error, a variable without valid definition escaped" let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list @@ -980,7 +982,7 @@ let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list ] mark_e | _ -> - Message.raise_spanned_error (Mark.get ty) + Message.error ~pos:(Mark.get ty) "This scope needs an input argument of type %a 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 \ @@ -1006,12 +1008,12 @@ let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list | exception CatalaException (except, pos) -> interp_failure_message ~pos except | _ -> - Message.raise_spanned_error (Expr.pos e) + Message.error ~pos:(Expr.pos e) "The interpretation of a program should always yield a struct \ corresponding to the scope variables" end | _ -> - Message.raise_spanned_error (Expr.pos e) + Message.error ~pos:(Expr.pos e) "The interpreter can only interpret terms starting with functions having \ thunked arguments" @@ -1038,7 +1040,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) | _ -> - Message.raise_spanned_error (Mark.get ty) + Message.error ~pos:(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. \ @@ -1063,12 +1065,12 @@ let interpret_program_dcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list | exception CatalaException (except, pos) -> interp_failure_message ~pos except | _ -> - Message.raise_spanned_error (Expr.pos e) + Message.error ~pos:(Expr.pos e) "The interpretation of a program should always yield a struct \ corresponding to the scope variables" end | _ -> - Message.raise_spanned_error (Expr.pos e) + Message.error ~pos:(Expr.pos e) "The interpreter can only interpret terms starting with functions having \ thunked arguments" @@ -1088,23 +1090,22 @@ let load_runtime_modules prg = ^ ".cmo") in if not (Sys.file_exists obj_file) then - Message.raise_spanned_error - ~span_msg:(fun ppf -> Format.pp_print_string ppf "Module defined here") - (Mark.get (ModuleName.get_info m)) + Message.error + ~pos_msg:(fun ppf -> Format.pp_print_string ppf "Module defined here") + ~pos:(Mark.get (ModuleName.get_info m)) "Compiled OCaml object %a not found. Make sure it has been suitably \ compiled." File.format obj_file else try Dynlink.loadfile obj_file with Dynlink.Error dl_err -> - Message.raise_error - "Error loading compiled module from %a:@;<1 2>@[%a@]" File.format - obj_file Format.pp_print_text + Message.error "Error loading compiled module from %a:@;<1 2>@[%a@]" + File.format obj_file Format.pp_print_text (Dynlink.error_message dl_err) in let modules_list_topo = Program.modules_to_list prg.decl_ctx.ctx_modules in if modules_list_topo <> [] then - Message.emit_debug "Loading shared modules... %a" + Message.debug "Loading shared modules... %a" (Format.pp_print_list ~pp_sep:Format.pp_print_space ModuleName.format) modules_list_topo; List.iter load modules_list_topo diff --git a/compiler/shared_ast/operator.ml b/compiler/shared_ast/operator.ml index 23f36f0c..0750ff66 100644 --- a/compiler/shared_ast/operator.ml +++ b/compiler/shared_ast/operator.ml @@ -548,15 +548,16 @@ let resolve_overload ctx (op : overloaded t Mark.pos) (operands : typ list) : in resolve_overload_aux (Mark.remove op) operands with Not_found -> - Message.raise_multispanned_error - ((None, Mark.get op) - :: List.map - (fun ty -> - ( Some - (Format.asprintf "Type %a coming from expression:" - (Print.typ ctx) ty), - Mark.get ty )) - operands) + Message.error + ~extra_pos: + ((None, Mark.get op) + :: List.map + (fun ty -> + ( Some + (Format.asprintf "Type %a coming from expression:" + (Print.typ ctx) ty), + Mark.get ty )) + operands) "I don't know how to apply operator %a on types %a" (Print.operator ~debug:true) (Mark.remove op) diff --git a/compiler/shared_ast/typing.ml b/compiler/shared_ast/typing.ml index 9b88cf51..3ff5cf03 100644 --- a/compiler/shared_ast/typing.ml +++ b/compiler/shared_ast/typing.ml @@ -71,7 +71,7 @@ let rec typ_to_ast ~(flags : flags) (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. *) - Message.raise_spanned_error pos + Message.error ~pos "Internal error: typing at this point could not be resolved" else A.TAny, pos | TClosureEnv -> TClosureEnv, pos @@ -186,8 +186,8 @@ let rec unify (t1 : unionfind_typ) (t2 : unionfind_typ) : unit = let unify = unify ctx in - (* Message.emit_debug "Unifying %a and %a" (format_typ ctx) t1 (format_typ - ctx) t2; *) + (* Message.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 let raise_type_error () = raise (Type_error (A.AnyExpr e, t1, t2)) in @@ -263,8 +263,8 @@ let handle_type_error ctx (A.AnyExpr e) t1 t2 = t2_pos ); ] in - Message.raise_multispanned_error_full - (List.map (fun (a, b) -> Some a, b) pos_msgs) + Message.error + ~fmt_pos:(List.map (fun (a, b) -> Some a, b) pos_msgs) "@[Error during typechecking, incompatible types:@,\ @[@{@<3>%s@} @[%a@]@,\ @{@<3>%s@} @[%a@]@]@]" "┌─⯈" (format_typ ctx) t1 "└─⯈" @@ -350,7 +350,7 @@ let polymorphic_op_return_type | (HandleDefault | HandleDefaultOpt), [_; _; tf] -> return_type tf 1 | ToClosureEnv, _ -> uf TClosureEnv | FromClosureEnv, _ -> any () - | _ -> Message.raise_spanned_error pos "Mismatched operator arguments" + | _ -> Message.error ~pos "Mismatched operator arguments" let resolve_overload_ret_type ~flags @@ -472,7 +472,7 @@ and typecheck_expr_top_down : (a, m) A.gexpr -> (a, unionfind_typ A.custom) A.boxed_gexpr = fun ctx env tau e -> - (* Message.emit_debug "Propagating type %a for naked_expr :@.@[%a@]" + (* Message.debug "Propagating type %a for naked_expr :@.@[%a@]" (format_typ ctx) tau Expr.format e; *) let pos_e = Expr.pos e in let flags = env.flags in @@ -504,8 +504,7 @@ and typecheck_expr_top_down : match ty_opt with | Some ty -> ty | None -> - Message.raise_spanned_error pos_e "Reference to %a not found" - (Print.expr ()) e + Message.error ~pos:pos_e "Reference to %a not found" (Print.expr ()) e in Expr.elocation loc (mark_with_tau_and_unify (ast_to_typ ty)) | A.EStruct { name; fields } -> @@ -539,7 +538,7 @@ and typecheck_expr_top_down : (A.StructField.Map.bindings extra_fields) in if errs <> [] then - Message.raise_multispanned_error errs + Message.error ~extra_pos:errs "Mismatching field definitions for structure %a" A.StructName.format name in @@ -565,15 +564,15 @@ and typecheck_expr_top_down : Printf.ksprintf failwith "Disambiguation failed before reaching field %s" field | _ -> - Message.raise_spanned_error (Expr.pos e) + Message.error ~pos:(Expr.pos e) "This is not a structure, cannot access field %s (found type: %a)" field (format_typ ctx) (ty e_struct') in let str = try A.StructName.Map.find name env.structs with A.StructName.Map.Not_found _ -> - Message.raise_spanned_error pos_e "No structure %a found" - A.StructName.format name + Message.error ~pos:pos_e "No structure %a found" A.StructName.format + name in let field = let candidate_structs = @@ -587,30 +586,32 @@ and typecheck_expr_top_down : ctx.ctx_scopes with | Some (scope_out, _) -> - Message.raise_multispanned_error_full - [ - ( Some - (fun ppf -> - Format.fprintf ppf - "@{%s@} is used here as an output" field), - Expr.mark_pos context_mark ); - ( Some - (fun ppf -> - Format.fprintf ppf "Scope %a is declared here" - A.ScopeName.format scope_out), - Mark.get (A.StructName.get_info name) ); - ] + Message.error + ~fmt_pos: + [ + ( Some + (fun ppf -> + Format.fprintf ppf + "@{%s@} is used here as an output" field), + Expr.mark_pos context_mark ); + ( Some + (fun ppf -> + Format.fprintf ppf "Scope %a is declared here" + A.ScopeName.format scope_out), + Mark.get (A.StructName.get_info name) ); + ] "Variable @{%s@} is not a declared output of scope %a." field A.ScopeName.format scope_out ~suggestion: (List.map A.StructField.to_string (A.StructField.Map.keys str)) | None -> - Message.raise_multispanned_error - [ - None, Expr.mark_pos context_mark; - ( Some "Structure definition", - Mark.get (A.StructName.get_info name) ); - ] + Message.error + ~extra_pos: + [ + None, Expr.mark_pos context_mark; + ( Some "Structure definition", + Mark.get (A.StructName.get_info name) ); + ] "Field @{\"%s\"@} does not belong to structure \ @{\"%a\"@}." field A.StructName.format name @@ -618,8 +619,8 @@ and typecheck_expr_top_down : in try A.StructName.Map.find name candidate_structs with A.StructName.Map.Not_found _ -> - Message.raise_spanned_error - (Expr.mark_pos context_mark) + Message.error + ~pos:(Expr.mark_pos context_mark) "@[Field @{\"%s\"@}@ does not belong to@ structure \ @{\"%a\"@}@ (however, structure %a defines it)@]" field A.StructName.format name @@ -638,17 +639,18 @@ and typecheck_expr_top_down : let str = try A.StructName.Map.find name env.structs with A.StructName.Map.Not_found _ -> - Message.raise_spanned_error pos_e "No structure %a found" - A.StructName.format name + Message.error ~pos:pos_e "No structure %a found" A.StructName.format + name in try A.StructField.Map.find field str with A.StructField.Map.Not_found _ -> - Message.raise_multispanned_error - [ - None, pos_e; - ( Some "Structure %a declared here", - Mark.get (A.StructName.get_info name) ); - ] + Message.error + ~extra_pos: + [ + None, pos_e; + ( Some "Structure %a declared here", + Mark.get (A.StructName.get_info name) ); + ] "Structure %a doesn't define a field %a" A.StructName.format name A.StructField.format field in @@ -747,14 +749,14 @@ and typecheck_expr_top_down : match Env.get env v with | Some t -> t | None -> - Message.raise_spanned_error pos_e - "Variable %s not found in the current context" (Bindlib.name_of v) + Message.error ~pos: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') | A.EExternal { name } -> let ty = let not_found pr x = - Message.raise_spanned_error pos_e + Message.error ~pos:pos_e "Could not resolve the reference to %a.@ Make sure the corresponding \ module was properly loaded?" pr x @@ -783,8 +785,8 @@ and typecheck_expr_top_down : Expr.etuple es' mark | A.ETupleAccess { e = e1; index; size } -> if index >= size then - Message.raise_spanned_error (Expr.pos e) - "Tuple access out of bounds (%d/%d)" index size; + Message.error ~pos:(Expr.pos e) "Tuple access out of bounds (%d/%d)" index + size; let tuple_ty = TTuple (List.init size (fun n -> @@ -794,7 +796,7 @@ and typecheck_expr_top_down : Expr.etupleaccess ~e:e1' ~index ~size context_mark | A.EAbs { binder; tys = t_args } -> if Bindlib.mbinder_arity binder <> List.length t_args then - Message.raise_spanned_error (Expr.pos e) + Message.error ~pos:(Expr.pos e) "function has %d variables but was supplied %d types\n%a" (Bindlib.mbinder_arity binder) (List.length t_args) Expr.format e @@ -833,7 +835,7 @@ and typecheck_expr_top_down : match UnionFind.get t with TTuple tys, _ -> tys | _ -> t_args) | _ -> if List.length t_args <> List.length args' then - Message.raise_spanned_error (Expr.pos e) + Message.error ~pos:(Expr.pos e) (match e1 with | EAbs _, _ -> "This binds %d variables, but %d were provided." | _ -> "This function application has %d arguments, but expects %d.") diff --git a/compiler/surface/lexer.cppo.ml b/compiler/surface/lexer.cppo.ml index fa2bbab0..f152f2d8 100644 --- a/compiler/surface/lexer.cppo.ml +++ b/compiler/surface/lexer.cppo.ml @@ -845,7 +845,7 @@ let lex_line (lexbuf : lexbuf) : (string * L.line_token) option = let id = Re.Group.get (Re.exec line_test_id_re str) 1 in Some (str, LINE_TEST id) with Not_found -> - Message.emit_spanned_warning (Pos.from_lpos (lexing_positions lexbuf)) + Message.warning ~pos:(Pos.from_lpos (lexing_positions lexbuf)) "Ignored invalid test section, must have an explicit \ `{ id = \"name\" }` specification"; Some (str, LINE_ANY)) diff --git a/compiler/surface/lexer_common.ml b/compiler/surface/lexer_common.ml index 91de6f0e..57281e93 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) = - Message.raise_spanned_error loc + Message.error ~pos: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 cdbc585b..981a06a0 100644 --- a/compiler/surface/parser.mly +++ b/compiler/surface/parser.mly @@ -136,7 +136,7 @@ let lident := | i = LIDENT ; { match Localisation.lex_builtin i with | Some _ -> - Message.raise_spanned_error + Message.error ~pos: (Pos.from_lpos $sloc) "Reserved builtin name" | None -> @@ -173,7 +173,7 @@ let naked_expression == match Localisation.lex_builtin (Mark.remove id), state with | Some b, None -> Builtin b | Some _, Some _ -> - Message.raise_spanned_error + Message.error ~pos: (Pos.from_lpos $loc(id)) "Invalid use of built-in @{%s@}" (Mark.remove id) | None, state -> Ident ([], id, state) @@ -524,7 +524,7 @@ let scope_item := | Some Round -> DateRounding(v), Mark.get v | _ -> - Message.raise_spanned_error + Message.error ~pos: (Pos.from_lpos $loc(i)) "Expected the form 'date round increasing' or 'date round decreasing'" } @@ -563,7 +563,7 @@ let scope_decl_item_attribute == i = lident ; { match input, output with | (Some Internal, _), (true, pos) -> - Message.raise_spanned_error pos + Message.error ~pos "A variable cannot be declared both 'internal' and 'output'." | input, output -> input, output, i } @@ -573,7 +573,7 @@ let scope_decl_item_attribute_mandatory == let in_attr_opt, out_attr, i = attr in let in_attr = match in_attr_opt, out_attr with | (None, _), (false, _) -> - Message.raise_spanned_error (Pos.from_lpos $loc(attr)) + Message.error ~pos:(Pos.from_lpos $loc(attr)) "Variable declaration requires input qualification ('internal', \ 'input' or 'context')" | (None, pos), (true, _) -> Internal, pos @@ -612,7 +612,7 @@ let scope_decl_item := scope_decl_context_io_output = out; }; | (Some _, pos), _ -> - Message.raise_spanned_error pos + Message.error ~pos "Scope declaration does not support input qualifiers ('internal', \ 'input' or 'context')" in diff --git a/compiler/surface/parser_driver.ml b/compiler/surface/parser_driver.ml index 6319fc9a..49e57fff 100644 --- a/compiler/surface/parser_driver.ml +++ b/compiler/surface/parser_driver.ml @@ -72,16 +72,17 @@ let raise_parser_error (last_good_loc : Pos.t option) (token : string) (msg : Format.formatter -> unit) : 'a = - Message.raise_multispanned_error_full ?suggestion - ((Some (fun ppf -> Format.pp_print_string ppf "Error token:"), error_loc) - :: - (match last_good_loc with - | None -> [] - | Some last_good_loc -> - [ - ( Some (fun ppf -> Format.pp_print_string ppf "Last good token:"), - last_good_loc ); - ])) + Message.error ?suggestion + ~fmt_pos: + ((Some (fun ppf -> Format.pp_print_string ppf "Error token:"), error_loc) + :: + (match last_good_loc with + | None -> [] + | Some last_good_loc -> + [ + ( Some (fun ppf -> Format.pp_print_string ppf "Last good token:"), + last_good_loc ); + ])) "@[Syntax error at token %a@,%t@]" (fun ppf string -> Format.fprintf ppf "@{\"%s\"@}" string) token msg @@ -244,7 +245,7 @@ let with_sedlex_file file f = (** Parses a single source file *) let rec parse_source (lexbuf : Sedlexing.lexbuf) : Ast.program = let source_file_name = lexbuf_file lexbuf in - Message.emit_debug "Parsing %a" File.format source_file_name; + Message.debug "Parsing %a" File.format source_file_name; let language = Cli.file_lang source_file_name in let commands = localised_parser language lexbuf in let program = expand_includes source_file_name commands in @@ -266,8 +267,8 @@ and expand_includes (source_file : string) (commands : Ast.law_structure list) : match acc.Ast.program_module_name, name_opt with | opt, None | None, opt -> opt | Some id1, Some id2 -> - Message.raise_multispanned_error - [None, Mark.get id1; None, Mark.get id2] + Message.error + ~extra_pos:[None, Mark.get id1; None, Mark.get id2] "Multiple definitions of the module name" in match command with @@ -295,11 +296,12 @@ and expand_includes (source_file : string) (commands : Ast.law_structure list) : includ_program.Ast.program_module_name |> Option.iter @@ fun id -> - Message.raise_multispanned_error - [ - Some "File include", Mark.get inc_file; - Some "Module declaration", Mark.get id; - ] + Message.error + ~extra_pos: + [ + Some "File include", Mark.get inc_file; + Some "Module declaration", Mark.get id; + ] "A file that declares a module cannot be used through the raw \ '@{> Include@}' directive. You should use it as a \ module with '@{> Use @{%s@}@}' instead." @@ -403,7 +405,7 @@ let check_modname program source_file = | ( Some (mname, pos), (Global.FileName file | Global.Contents (_, file) | Global.Stdin file) ) when not File.(equal mname Filename.(remove_extension (basename file))) -> - Message.raise_spanned_error pos + Message.error ~pos "@[Module declared as@ @{%s@},@ which@ does@ not@ match@ the@ \ file@ name@ %a.@ Rename the module to@ @{%s@}@ or@ the@ file@ to@ \ %a.@]" @@ -422,7 +424,7 @@ let load_interface ?default_module_name source_file = | None, Some n -> n, Pos.from_info (Global.input_src_file source_file) 0 0 0 0 | None, None -> - Message.raise_error + Message.error "%a doesn't define a module name. It should contain a '@{> \ Module %s@}' directive." File.format diff --git a/compiler/verification/conditions.ml b/compiler/verification/conditions.ml index dd0b4d6f..7f8390f9 100644 --- a/compiler/verification/conditions.ml +++ b/compiler/verification/conditions.ml @@ -115,7 +115,7 @@ let match_and_ignore_outer_reentrant_default (ctx : ctx) (e : typed expr) : match Mark.remove body with | EErrorOnEmpty e -> e | _ -> - Message.raise_spanned_error (Expr.pos e) + Message.error ~pos:(Expr.pos e) "Internal error: this expression does not have the structure expected \ by the VC generator:\n\ %a" @@ -300,7 +300,7 @@ let rec generate_verification_conditions_scope_body_expr let e = match_and_ignore_outer_reentrant_default ctx e in ctx, [], [e] | _ -> - Message.raise_spanned_error (Expr.pos e) + Message.error ~pos:(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 1ddb2d9c..59c6de0d 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 - Message.emit_debug "@[For this variable:@,%a@,@]" Pos.format_loc_text + Message.debug "@[For this variable:@,%a@,@]" Pos.format_loc_text (Expr.pos vc.Conditions.vc_guard); - Message.emit_debug + Message.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) -> ( - Message.emit_debug "@[The translation to Z3 is the following:@,%s@]" + Message.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 -> - Message.emit_warning "%s" (print_negative_result vc backend_ctx model); + Message.warning "%s" (print_negative_result vc backend_ctx model); false | Unknown -> failwith "The solver failed at proving or disproving the VC") | Fail msg -> - Message.emit_warning + Message.warning "@[@{[%a.%s]@} The translation to Z3 failed:@,%s@]" ScopeName.format vc.vc_scope (Bindlib.name_of (Mark.remove vc.vc_variable)) diff --git a/compiler/verification/solver.ml b/compiler/verification/solver.ml index d31791f7..d0e2e957 100644 --- a/compiler/verification/solver.ml +++ b/compiler/verification/solver.ml @@ -48,5 +48,4 @@ let solve_vc else false) true z3_vcs in - if all_proven then - Message.emit_result "No errors found during the proof mode run." + if all_proven then Message.result "No errors found during the proof mode run." diff --git a/compiler/verification/z3backend.dummy.ml b/compiler/verification/z3backend.dummy.ml index 7388fb75..dad9fd43 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.Message.raise_error + Catala_utils.Message.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 bae794cd..80c07afd 100644 --- a/compiler/verification/z3backend.real.ml +++ b/compiler/verification/z3backend.real.ml @@ -804,8 +804,7 @@ module Backend = struct let ctx, vc = translate_expr ctx e in add_z3constraint vc ctx - let init_backend () = - Message.emit_debug "Running Z3 version %s" Version.to_string + let init_backend () = Message.debug "Running Z3 version %s" Version.to_string let make_context (decl_ctx : decl_ctx) : backend_context = let cfg =