Rewriting message calls to use the new intf

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 @{<bold>%s@}."
+         Message.debug "Catala runtime libraries found at @{<bold>%s@}." dir;
-           dir;
          dir
        | None ->
-         Message.raise_error
+         Message.error
            "@[<hov>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 =

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

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 @{<yellow>%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

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
+  let add_position (content : t) ?(message : message option) (position : Pos.t)
-      (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 =
+let make
-  Format.kdprintf @@ fun message ->
+    ?header
-  let t = match level with Result -> of_result message | _ -> of_message message in
+    ?(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 =
-  let t = match extra_pos with
+    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) ->
+      List.fold_left
-          let message = Option.map (fun m ppf -> Format.pp_print_text ppf m) message in
+        (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
+        t pl
-        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))
-

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 log : ('a, unit) emitter
-val debug: ('a, unit) emitter
+val debug : ('a, unit) emitter
-val result: ('a, unit) emitter
+val result : ('a, unit) emitter
-val warning: ('a, unit) emitter
+val warning : ('a, unit) emitter
-val error: ('a, 'b) emitter
+val error : ('a, 'b) emitter

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

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
+            Message.error
-              [
+              ~extra_pos:
-                None, pos;
+                [
-                ( Some "Declaration of the missing input variable",
+                  None, pos;
-                  Mark.get (StructField.get_info var_ctx.scope_input_name) );
+                  ( 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))
-              [
+              ~fmt_pos:
-                None, Expr.pos e;
+                [
-                ( Some
+                  None, Expr.pos e;
-                    (fun ppf ->
+                  ( Some
-                      Format.fprintf ppf "Declaration of scope %a"
+                      (fun ppf ->
-                        ScopeName.format scope),
+                        Format.fprintf ppf "Declaration of scope %a"
-                  Mark.get (ScopeName.get_info scope) );
+                          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"
+    (* Message.debug "new_args %d, input_typs: %d, input_typs %a" (List.length
-       (List.length new_args) (List.length input_typs) (Format.pp_print_list
+       new_args) (List.length input_typs) (Format.pp_print_list Print.typ_debug)
-       Print.typ_debug) (List.map (Mark.add Pos.no_pos) input_typs); *)
+       (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"
+      Message.error ~pos:pos_sigma "Scope %a has no content" ScopeName.format
-        ScopeName.format scope_name
+        scope_name
     | ( S.ScopeVarDefinition { e; _ }
       | S.SubScopeVarDefinition { e; _ }
       | S.Assertion e )

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)
               "@[<v 2>Invariant @{<magenta>%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 =

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
       "@[<hov 2>Cyclic dependency detected between the following variables of \
        scope %a:@ @[<hv>%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
+                Message.error
-                  (( Some
+                  ~extra_pos:
-                       "This definition contradicts other exception \
+                    (( Some
-                        definitions:",
+                         "This definition contradicts other exception \
-                     edge_pos )
+                          definitions:",
-                  :: List.map
+                       edge_pos )
-                       (fun pos -> Some "Other exception definition:", pos)
+                    :: List.map
-                       edge.edge_positions)
+                         (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)

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
+  Message.error
-    ~span_msg:(fun ppf -> Format.fprintf ppf "Here is your code :")
+    ~pos_msg:(fun ppf -> Format.fprintf ppf "Here is your code :")
-    ~suggestion:closest_constructors (Mark.get constructor)
+    ~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"
+      Message.error ~pos "Enum %s does not contain case %s" (Mark.remove enum)
-        (Mark.remove enum) (Mark.remove constructor))
+        (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
+      Message.error
-        [None, pos_op; None, pos_op1]
+        ~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
+              Message.error
-                (Mark.get (Option.get st))
+                ~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)
-                [
+                ~extra_pos:
-                  None, Mark.get st;
+                  [
-                  Some "Variable defined here", Mark.get (ScopeVar.get_info uid);
+                    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
+      Message.error ~pos "Scope calls are not allowed outside of a scope";
-        "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)
-                [
+                ~extra_pos:
-                  None, Mark.get fld_id;
+                  [
-                  ( Some
+                    None, Mark.get fld_id;
-                      (Format.asprintf "Scope %a declared here" ScopeName.format
+                    ( Some
-                         called_scope),
+                        (Format.asprintf "Scope %a declared here"
-                    Mark.get (ScopeName.get_info called_scope) );
+                           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
+            Message.error
-              [None, Mark.get f_e; None, Expr.pos e_field]
+              ~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"
+        Message.error ~pos "Enum %s does not contain case %s" (Mark.remove enum)
-          (Mark.remove enum) constructor))
+          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
+        Message.error ~pos "It is impossible to sum values of type %a together"
-          "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
+            Message.error
-              (Mark.get case.S.match_case_pattern)
+              ~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
+        Message.error
-          [None, Mark.get case.match_case_expr; None, Expr.pos e_case]
+          ~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
+        Message.error
-          [
+          ~extra_pos:
-            Some "Not ending wildcard:", case_pos;
+            [
-            ( Some "Next reachable case:",
+              Some "Not ending wildcard:", case_pos;
-              curr_index + 1 |> List.nth cases |> Mark.get );
+              ( 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
+    Message.error
-      [Some "Declared here:", pos_decl; Some "Extra argument:", apos]
+      ~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
+    Message.error
-      [
+      ~extra_pos:
-        Some "Argument declared here:", apos;
+        [
-        Some "Mismatching definition:", pos_def;
+          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
+    Message.error
-      [
+      ~extra_pos:
-        Some "Argument declared here:", decl_apos; Some "Defined here:", def_apos;
+        [
-      ]
+          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
+    Message.error
-      [
+      ~extra_pos:
-        Some "Declared here without arguments", decl_pos;
+        [
-        Some "Unexpected arguments appearing here", 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
+    Message.error
-      [
+      ~extra_pos:
-        Some "Arguments declared here", pos;
+        [
-        Some "Definition missing the arguments", Mark.get def.S.definition_name;
+          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
+        Message.error
-          [None, old_pos; None, Mark.get item]
+          ~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
+        Message.error
-          ([Some "Ambiguous exception", Mark.get item]
+          ~extra_pos:
-          @ List.map (fun p -> Some "Candidate definition", p) 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
+            Message.error
-              [
+              ~extra_pos:
-                None, Mark.get (TopdefName.get_info id);
+                [
-                None, Mark.get def.S.topdef_name;
+                  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"

compiler/desugared/linting.ml

@@ -37,8 +37,8 @@ let detect_empty_definitions (p : program) : unit =
             | NoInput -> true
             | _ -> false
           then
-            Message.emit_spanned_warning
+            Message.warning
-              (ScopeDef.get_position scope_def_key)
+              ~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
+          Message.warning
-            (snd (StructName.get_info s_name))
+            ~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
+                Message.warning
-                  (snd (StructField.get_info field))
+                  ~pos:(snd (StructField.get_info field))
                   "The field \"%a\" of struct @{<yellow>\"%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
+          Message.warning
-            (snd (EnumName.get_info e_name))
+            ~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
+                Message.warning
-                  (snd (EnumConstructor.get_info constructor))
+                  ~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
+        Message.warning
-          (Mark.get (Dependency.Vertex.info vx))
+          ~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

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)
     "@{<yellow>\"%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
+    Message.error
-      [
+      ~extra_pos:
-        None, Mark.get id;
+        [
-        Some "Structure defined at", Mark.get (StructName.get_info sid);
+          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
+    Message.error
-      [
+      ~extra_pos:
-        None, Mark.get id;
+        [
-        Some "Scope defined at", Mark.get (ScopeName.get_info sid);
+          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"
+    Message.error ~pos:(Mark.get id) "No enum named %s found" (Mark.remove id)
-      (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
+    Message.error
-      [
+      ~extra_pos:
-        None, Mark.get id;
+        [
-        Some "Enum defined at", Mark.get (EnumName.get_info eid);
+          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"
+    Message.error ~pos:(Mark.get id) "No struct named %s found" (Mark.remove id)
-      (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
+    Message.error
-      [
+      ~extra_pos:
-        None, Mark.get id;
+        [
-        Some "Enum defined at", Mark.get (EnumName.get_info eid);
+          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
+    Message.error
-      [
+      ~extra_pos:
-        None, Mark.get id;
+        [
-        Some "Structure defined at", Mark.get (StructName.get_info sid);
+          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"
+    Message.error ~pos:(Mark.get id) "No scope named %s found" (Mark.remove id)
-      (Mark.remove id)
 
 let get_modname ctxt (id, pos) =
   match Ident.Map.find_opt id ctxt.local.used_modules with
-  | None ->
+  | None -> Message.error ~pos "Module \"@{<blue>%s@}\" not found" id
-    Message.raise_spanned_error pos "Module \"@{<blue>%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
+    Message.error
-      [Some "first use", Mark.get info; Some "second use", s_pos]
+      ~extra_pos:[Some "first use", Mark.get info; Some "second use", s_pos]
       "Subscope name @{<yellow>\"%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 @{<yellow>\"%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 @{<blue>%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
+    Message.error
-      [Some "First use:", Mark.get info; Some "Second use:", pos]
+      ~extra_pos:[Some "First use:", Mark.get info; Some "Second use:", pos]
       "Variable name @{<yellow>\"%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
+            Message.error
-              [
+              ~fmt_pos:
-                ( Some
+                [
-                    (fun ppf ->
+                  ( Some
-                      Format.fprintf ppf
+                      (fun ppf ->
-                        "First instance of state @{<yellow>\"%s\"@}:"
+                        Format.fprintf ppf
-                        state_id_name),
+                          "First instance of state @{<yellow>\"%s\"@}:"
-                  Mark.get state_id );
+                          state_id_name),
-                ( Some
+                    Mark.get state_id );
-                    (fun ppf ->
+                  ( Some
-                      Format.fprintf ppf
+                      (fun ppf ->
-                        "Second instance of state @{<yellow>\"%s\"@}:"
+                        Format.fprintf ppf
-                        state_id_name),
+                          "Second instance of state @{<yellow>\"%s\"@}:"
-                  Mark.get
+                          state_id_name),
-                    (Ident.Map.find state_id_name states_idmap
+                    Mark.get
-                    |> StateName.get_info) );
+                      (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
+    Message.error
-      (Mark.get sdecl.struct_decl_name)
+      ~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
+    Message.error
-      (Mark.get edecl.enum_decl_name)
+      ~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
+    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 "First definition:"),
-        Some (fun ppf -> Format.pp_print_string ppf "Second definition:"), pos;
+            Mark.get use );
-      ]
+          Some (fun ppf -> Format.pp_print_string ppf "Second definition:"), pos;
+        ]
       "%s name @{<yellow>\"%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
+            Message.error
-              [
+              ~extra_pos:
-                None, Mark.get state;
+                [
-                Some "Variable declaration:", Mark.get (ScopeVar.get_info x_uid);
+                  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
+            Message.error
-              [
+              ~extra_pos:
-                None, Mark.get x;
+                [
-                Some "Variable declaration:", Mark.get (ScopeVar.get_info x_uid);
+                  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
+        Message.error ~pos "Invalid definition, %a is not a subscope"
-          "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"
           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
+      Message.error
-        (Mark.get suse.Surface.Ast.scope_use_name)
+        ~pos:(Mark.get suse.Surface.Ast.scope_use_name)
         "@{<yellow>\"%s\"@}: this scope has not been declared anywhere, is it \
          a typo?"
         (Mark.remove suse.Surface.Ast.scope_use_name)

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 "@[<v>Definitions with label \"%a\":@,%a@]"
+      Message.result "@[<v>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 "@[<v>The exception tree structure is as follows:@,@,%a@]"
+  Message.result "@[<v>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))

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
+      Message.error
-        (err_req_pos (mpos :: req_chain))
+        ~extra_pos:(err_req_pos (mpos :: req_chain))
         "Required module not found: @{<blue>%s@}" mname
     | [f] -> f
     | ms ->
-      Message.raise_multispanned_error
+      Message.error
-        (err_req_pos (mpos :: req_chain))
+        ~extra_pos:(err_req_pos (mpos :: req_chain))
         "Required module @{<blue>%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
+          Message.error
-            (err_req_pos (Mark.get use.Surface.Ast.mod_use_name :: req_chain))
+            ~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 "@{<bold;magenta>=@} @{<bold>%s@} @{<bold;magenta>=@}"
+    Message.debug "@{<bold;magenta>=@} @{<bold>%s@} @{<bold;magenta>=@}"
       (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.error ~internal:true "Some Dcalc invariants are invalid")
-      | _ ->
+      | _ -> Message.error "--check-invariants cannot be used with --no-typing");
-        Message.raise_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 @{<yellow>%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
+      Message.error "There is no scope \"@{<yellow>%s@}\" inside the program."
-        "There is no scope \"@{<yellow>%s@}\" inside the program." scope
+        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 @{<yellow>\"%s\"@} not found inside scope @{<yellow>\"%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 @{<yellow>\"%s\"@} is not found for variable \
                 @{<yellow>\"%s\"@} of scope @{<yellow>\"%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"
+    Message.debug "Writing to %s" (Option.value ~default:"stdout" output_file);
-      (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"
+    Message.debug "Writing to %s" (Option.value ~default:"stdout" output_file);
-      (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"));
+        raise (Message.error ~internal:true "Some Dcalc invariants are invalid"));
-    Message.emit_result "Typechecking successful!"
+    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 "@[<hov 2>%s@ =@ %a@]" var
+        Message.result "@[<hov 2>%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 @{<bold>--avoid-exceptions@}, \
              @{<bold>--closure-conversion@} and @{<bold>--monomorphize-types@} \
              only make sense with the @{<bold>--lcalc@} option"
@@ -814,8 +812,8 @@ module Commands = struct
     in
     with_output
     @@ fun fmt ->
-    Message.emit_debug "Compiling program into OCaml...";
+    Message.debug "Compiling program into OCaml...";
-    Message.emit_debug "Writing to %s..."
+    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.debug "Compiling program into Python...";
-    Message.emit_debug "Writing to %s..."
+    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.debug "Compiling program into R...";
-    Message.emit_debug "Writing to %s..."
+    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.debug "Compiling program into C...";
-    Message.emit_debug "Writing to %s..."
+    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>@[<v>@{<bold;blue>%a@}@]%a@\n\
      Run `@{<bold>%s --help@}' or `@{<bold>%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

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

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

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 @{<bold>%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 "@[<hov 2>Generating entry points for scopes:@ %a@]@."
+  Message.debug "@[<hov 2>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

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 ->

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"
+  Message.debug "Lines of Catala inside literate source code: %d" !lines_of_code
-    !lines_of_code

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
+           Message.warning
-             (Pos.from_info filename (start_line + i) (max_len + 1)
+             ~pos:
-                (start_line + i) (len_s + 1))
+               (Pos.from_info filename (start_line + i) (max_len + 1)
+                  (start_line + i) (len_s + 1))
              "This line is exceeding @{<bold;red>%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

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 ->
+  | e -> Message.warning "Could not load plugin %S: %s" f (Printexc.to_string e)
-    Message.emit_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

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 "@[<hv 2>| \"%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

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 "@[<hov 5>EVAL %a@]" Expr.format e;
       lazy_eval ctx env llevel e
     | _ :: _ :: _ ->
-      Message.raise_multispanned_error
+      Message.error
-        ((None, Expr.mark_pos m)
+        ~extra_pos:
-        :: List.map (fun (e, _) -> None, Expr.pos e) excs)
+          ((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))

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);

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 "@[<hov 5>EVAL %a@]" Expr.format e;
       lazy_eval ctx env llevel e
     | _ :: _ :: _ ->
-      Message.raise_multispanned_error
+      Message.error
-        ((None, Expr.mark_pos m)
+        ~extra_pos:
-        :: List.map (fun (e, _) -> None, Expr.pos e) excs)
+          ((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 }, _ -> (

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.debug "Compiling program into Python...";
-  Message.emit_debug "Writing to %s..."
+  Message.debug "Writing to %s..." (Option.value ~default:"stdout" output_file);
-    (Option.value ~default:"stdout" output_file);
   with_output @@ fun fmt -> Scalc.To_python.format_program fmt prg type_ordering
 
 let term =

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: @[<hov>%a@]@\n"
               Print.var_debug v
               (Format.pp_print_list ~pp_sep:Format.pp_print_space (fun ppf v ->

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 "@[<hov 2>%a@];"

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

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
+          Message.error
-            (Mark.get (TopdefName.get_info glo_name))
+            ~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
+            Message.error
-              (Mark.get (ScopeName.get_info scope.Ast.scope_decl_name))
+              ~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
       "@[<hov 2>Cyclic dependency detected between the following scopes:@ \
        @[<hv>%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
+     Message.error ~extra_pos:spans "Cyclic dependency detected between types!");
-       "Cyclic dependency detected between types!");
   List.rev (TTopologicalTraversal.fold (fun v acc -> v :: acc) g [])

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
+              Message.error
-                (( Some "Incriminated subscope:",
+                ~extra_pos:
-                   Mark.get (ScopeVar.get_info (Mark.remove sscope)) )
+                  (( Some "Incriminated subscope:",
-                :: ( Some "Incriminated variable:",
+                     Mark.get (ScopeVar.get_info (Mark.remove sscope)) )
-                     Mark.get (ScopeVar.get_info var_within_origin_scope) )
+                  :: ( Some "Incriminated variable:",
-                :: List.map
+                       Mark.get (ScopeVar.get_info var_within_origin_scope) )
-                     (fun rule ->
+                  :: List.map
-                       ( Some "Incriminated subscope variable definition:",
+                       (fun rule ->
-                         Mark.get (RuleName.get_info rule) ))
+                         ( Some "Incriminated subscope variable definition:",
-                     (RuleName.Map.keys def))
+                           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
+              Message.error
-                [
+                ~extra_pos:
-                  ( Some "Incriminated subscope:",
+                  [
-                    Mark.get (ScopeVar.get_info (Mark.remove sscope)) );
+                    ( Some "Incriminated subscope:",
-                  Some "Incriminated variable:", Mark.get sscope;
+                      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
+      Message.error
-        ((Some "Incriminated variable:", Mark.get (ScopeVar.get_info var))
+        ~extra_pos:
-        :: List.map
+          ((Some "Incriminated variable:", Mark.get (ScopeVar.get_info var))
-             (fun rule ->
+          :: List.map
-               ( Some "Incriminated variable definition:",
+               (fun rule ->
-                 Mark.get (RuleName.get_info rule) ))
+                 ( Some "Incriminated variable definition:",
-             (RuleName.Map.keys var_def))
+                   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"
+          Message.error ~pos "No definition found for %a" TopdefName.format id)
-            TopdefName.format id)
       desugared.program_root.module_topdefs
   in
   let program_scopes =

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)

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: @{<green>%s@}" !indent_str Print.log_entry
+      Message.log "%s%a %a: @{<green>%s@}" !indent_str Print.log_entry entry
-        entry Print.uid_list infos
+        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@[<v>%a@{<green>Definition applied@}:@,%a@]"
+        Message.log "%s@[<v>%a@{<green>Definition applied@}:@,%a@]" !indent_str
-          !indent_str Print.log_entry entry Pos.format_loc_text pos
+          Print.log_entry entry Pos.format_loc_text pos
       | _ -> ())
     | BeginCall ->
-      Message.emit_log "%s%a %a" !indent_str Print.log_entry entry
+      Message.log "%s%a %a" !indent_str Print.log_entry entry Print.uid_list
-        Print.uid_list infos;
+        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
+      Message.log "%s%a %a" !indent_str Print.log_entry entry Print.uid_list
-        Print.uid_list infos
+        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
+      Message.error
-        [
+        ~extra_pos:
-          Some "The division operator:", pos;
+          [
-          Some "The null denominator:", Expr.pos (List.nth args 1);
+            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
+    Message.error
-      ([
+      ~extra_pos:
-         ( Some
+        ([
-             (Format.asprintf "Operator (value %a):"
+           ( Some
-                (Print.operator ~debug:true)
+               (Format.asprintf "Operator (value %a):"
-                op),
+                  (Print.operator ~debug:true)
-           pos );
+                  op),
-       ]
+             pos );
-      @ List.mapi
+         ]
-          (fun i arg ->
+        @ List.mapi
-            ( Some
+            (fun i arg ->
-                (Format.asprintf "Argument n°%d, value %a" (i + 1)
+              ( Some
-                   (Print.UserFacing.expr lang)
+                  (Format.asprintf "Argument n°%d, value %a" (i + 1)
-                   arg),
+                     (Print.UserFacing.expr lang)
-              Expr.pos arg ))
+                     arg),
-          args)
+                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
+             Message.error
-               (Expr.pos (List.nth args 0))
+               ~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
+        Message.error ~pos "wrong function call, expected %d arguments, got %d"
-          "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
+        Message.error
-          [None, pos; None, Expr.pos e]
+          ~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
+        Message.error
-          [None, Expr.pos e; None, Expr.pos e1]
+          ~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
+    Message.error
-      (List.map
+      ~extra_pos:
-         (fun pos -> Some "This consequence has a valid justification:", pos)
+        (List.map
-         cpos)
+           (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
+      Message.error
-        ~span_msg:(fun ppf -> Format.pp_print_string ppf "Module defined here")
+        ~pos_msg:(fun ppf -> Format.pp_print_string ppf "Module defined here")
-        (Mark.get (ModuleName.get_info m))
+        ~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
+        Message.error "Error loading compiled module from %a:@;<1 2>@[<hov>%a@]"
-          "Error loading compiled module from %a:@;<1 2>@[<hov>%a@]" File.format
+          File.format obj_file Format.pp_print_text
-          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

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
+    Message.error
-      ((None, Mark.get op)
+      ~extra_pos:
-      :: List.map
+        ((None, Mark.get op)
-           (fun ty ->
+        :: List.map
-             ( Some
+             (fun ty ->
-                 (Format.asprintf "Type %a coming from expression:"
+               ( Some
-                    (Print.typ ctx) ty),
+                   (Format.asprintf "Type %a coming from expression:"
-               Mark.get ty ))
+                      (Print.typ ctx) ty),
-           operands)
+                 Mark.get ty ))
+             operands)
       "I don't know how to apply operator %a on types %a"
       (Print.operator ~debug:true)
       (Mark.remove op)

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
+  (* Message.debug "Unifying %a and %a" (format_typ ctx) t1 (format_typ ctx)
-     ctx) t2; *)
+     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
+  Message.error
-    (List.map (fun (a, b) -> Some a, b) pos_msgs)
+    ~fmt_pos:(List.map (fun (a, b) -> Some a, b) pos_msgs)
     "@[<v>Error during typechecking, incompatible types:@,\
      @[<v>@{<bold;blue>@<3>%s@} @[<hov>%a@]@,\
      @{<bold;blue>@<3>%s@} @[<hov>%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 :@.@[<hov 2>%a@]"
+  (* Message.debug "Propagating type %a for naked_expr :@.@[<hov 2>%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"
+        Message.error ~pos:pos_e "Reference to %a not found" (Print.expr ()) e
-          (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"
+        Message.error ~pos:pos_e "No structure %a found" A.StructName.format
-          A.StructName.format name
+          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
+            Message.error
-              [
+              ~fmt_pos:
-                ( Some
+                [
-                    (fun ppf ->
+                  ( Some
-                      Format.fprintf ppf
+                      (fun ppf ->
-                        "@{<yellow>%s@} is used here as an output" field),
+                        Format.fprintf ppf
-                  Expr.mark_pos context_mark );
+                          "@{<yellow>%s@} is used here as an output" field),
-                ( Some
+                    Expr.mark_pos context_mark );
-                    (fun ppf ->
+                  ( Some
-                      Format.fprintf ppf "Scope %a is declared here"
+                      (fun ppf ->
-                        A.ScopeName.format scope_out),
+                        Format.fprintf ppf "Scope %a is declared here"
-                  Mark.get (A.StructName.get_info name) );
+                          A.ScopeName.format scope_out),
-              ]
+                    Mark.get (A.StructName.get_info name) );
+                ]
               "Variable @{<yellow>%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
+            Message.error
-              [
+              ~extra_pos:
-                None, Expr.mark_pos context_mark;
+                [
-                ( Some "Structure definition",
+                  None, Expr.mark_pos context_mark;
-                  Mark.get (A.StructName.get_info name) );
+                  ( Some "Structure definition",
-              ]
+                    Mark.get (A.StructName.get_info name) );
+                ]
               "Field @{<yellow>\"%s\"@} does not belong to structure \
                @{<yellow>\"%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
+        Message.error
-          (Expr.mark_pos context_mark)
+          ~pos:(Expr.mark_pos context_mark)
           "@[<hov>Field @{<yellow>\"%s\"@}@ does not belong to@ structure \
            @{<yellow>\"%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"
+          Message.error ~pos:pos_e "No structure %a found" A.StructName.format
-            A.StructName.format name
+            name
       in
       try A.StructField.Map.find field str
       with A.StructField.Map.Not_found _ ->
-        Message.raise_multispanned_error
+        Message.error
-          [
+          ~extra_pos:
-            None, pos_e;
+            [
-            ( Some "Structure %a declared here",
+              None, pos_e;
-              Mark.get (A.StructName.get_info name) );
+              ( 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
+        Message.error ~pos:pos_e "Variable %s not found in the current context"
-          "Variable %s not found in the current context" (Bindlib.name_of v)
+          (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)
+      Message.error ~pos:(Expr.pos e) "Tuple access out of bounds (%d/%d)" index
-        "Tuple access out of bounds (%d/%d)" index size;
+        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.")

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))

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

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 @{<bold>%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

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
+  Message.error ?suggestion
-    ((Some (fun ppf -> Format.pp_print_string ppf "Error token:"), error_loc)
+    ~fmt_pos:
-    ::
+      ((Some (fun ppf -> Format.pp_print_string ppf "Error token:"), error_loc)
-    (match last_good_loc with
+      ::
-    | None -> []
+      (match last_good_loc with
-    | Some last_good_loc ->
+      | None -> []
-      [
+      | Some last_good_loc ->
-        ( Some (fun ppf -> Format.pp_print_string ppf "Last good token:"),
+        [
-          last_good_loc );
+          ( Some (fun ppf -> Format.pp_print_string ppf "Last good token:"),
-      ]))
+            last_good_loc );
+        ]))
     "@[<v>Syntax error at token %a@,%t@]"
     (fun ppf string -> Format.fprintf ppf "@{<yellow>\"%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
+            Message.error
-              [None, Mark.get id1; None, Mark.get id2]
+              ~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
+               Message.error
-                 [
+                 ~extra_pos:
-                   Some "File include", Mark.get inc_file;
+                   [
-                   Some "Module declaration", Mark.get id;
+                     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 \
                   '@{<yellow>> Include@}' directive. You should use it as a \
                   module with '@{<yellow>> Use @{<blue>%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
       "@[<hov>Module declared as@ @{<blue>%s@},@ which@ does@ not@ match@ the@ \
        file@ name@ %a.@ Rename the module to@ @{<blue>%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 '@{<cyan>> \
          Module %s@}' directive."
         File.format

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"

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 "@[<v>For this variable:@,%a@,@]" Pos.format_loc_text
+    Message.debug "@[<v>For this variable:@,%a@,@]" Pos.format_loc_text
       (Expr.pos vc.Conditions.vc_guard);
-    Message.emit_debug
+    Message.debug
       "@[<v>This verification condition was generated for @{<yellow>%s@}:@,\
        %a@,\
        with assertions:@,\
@@ -159,16 +159,16 @@ module MakeBackendIO (B : Backend) = struct
 
     match z3_vc with
     | Success (encoding, backend_ctx) -> (
-      Message.emit_debug "@[<v>The translation to Z3 is the following:@,%s@]"
+      Message.debug "@[<v>The translation to Z3 is the following:@,%s@]"
         (B.print_encoding encoding);
       match B.solve_vc_encoding backend_ctx encoding with
       | ProvenTrue -> true
       | ProvenFalse model ->
-        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
         "@[<v>@{<yellow>[%a.%s]@} The translation to Z3 failed:@,%s@]"
         ScopeName.format vc.vc_scope
         (Bindlib.name_of (Mark.remove vc.vc_variable))

compiler/verification/solver.ml

@@ -48,5 +48,4 @@ let solve_vc
         else false)
       true z3_vcs
   in
-  if all_proven then
+  if all_proven then Message.result "No errors found during the proof mode run."
-    Message.emit_result "No errors found during the proof mode run."

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

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 () =
+  let init_backend () = Message.debug "Running Z3 version %s" Version.to_string
-    Message.emit_debug "Running Z3 version %s" Version.to_string
 
   let make_context (decl_ctx : decl_ctx) : backend_context =
     let cfg =