CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-09-07 10:35:56 +03:00
Code Issues Projects Releases Wiki Activity

Rewriting message calls to use the new intf

Browse Source
This commit is contained in:
Louis Gesbert 2024-04-10 18:39:30 +02:00
parent 454667a47b
commit 98fc97a241
44 changed files with 630 additions and 594 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
build_system/clerk_driver.ml
View File

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

2
build_system/clerk_runtest.ml
View File

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

6
compiler/catala_utils/file.ml
View File

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

46
compiler/catala_utils/message.ml
View File

@ -140,10 +140,8 @@ module Content = struct
let add_suggestion (content : t) (suggestion : string list) =
content @ [Suggestion suggestion]
let add_position
(content : t)
?(message : message option)
(position : Pos.t) =
let add_position (content : t) ?(message : message option) (position : Pos.t)
=
content @ [Position { pos = position; pos_message = message }]
let of_string (s : string) : t =
@ -319,7 +317,6 @@ let emit_result format =
(fun message -> Content.emit [MainMessage message] Result)
format
(** New concise interface *)
type ('a, 'b) emitter =
@ -333,22 +330,40 @@ type ('a, 'b) emitter =
('a, Format.formatter, unit, 'b) format4 ->
'a
let make ?header ?(internal=false) ?pos ?pos_msg ?extra_pos ?fmt_pos ?suggestion ~cont ~level =
Format.kdprintf @@ fun message ->
let t = match level with Result -> of_result message | _ -> of_message message in
let make
?header
?(internal = false)
?pos
?pos_msg
?extra_pos
?fmt_pos
?suggestion
~cont
~level =
Format.kdprintf
@@ fun message ->
let t =
match level with Result -> of_result message | _ -> of_message message
in
let t = match header with Some h -> prepend_message t h | None -> t in
let t = if internal then to_internal_error t else t in
let t = match pos with Some p -> add_position t ?message:pos_msg p | None -> t in
let t = match extra_pos with
let t =
match pos with Some p -> add_position t ?message:pos_msg p | None -> t
in
let t =
match extra_pos with
| Some pl ->
List.fold_left (fun t (message, p) ->
let message = Option.map (fun m ppf -> Format.pp_print_text ppf m) message in
List.fold_left
(fun t (message, p) ->
let message =
Option.map (fun m ppf -> Format.pp_print_text ppf m) message
in
add_position t ?message p)
t
pl
t pl
| None -> t
in
let t = match fmt_pos with
let t =
match fmt_pos with
| Some pl ->
List.fold_left (fun t (message, p) -> add_position t ?message p) t pl
| None -> t
@ -361,4 +376,3 @@ let log = make ~level:Log ~cont:emit
let result = make ~level:Result ~cont:emit
let warning = make ~level:Warning ~cont:emit
let error = make ~level:Error ~cont:(fun m _ -> raise (CompilerError m))

10
compiler/catala_utils/message.mli
View File

@ -146,8 +146,8 @@ type ('a, 'b) emitter =
('a, Format.formatter, unit, 'b) format4 ->
'a
val log: ('a, unit) emitter
val debug: ('a, unit) emitter
val result: ('a, unit) emitter
val warning: ('a, unit) emitter
val error: ('a, 'b) emitter
val log : ('a, unit) emitter
val debug : ('a, unit) emitter
val result : ('a, unit) emitter
val warning : ('a, unit) emitter
val error : ('a, 'b) emitter

2
compiler/catala_web_interpreter.ml
View File

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

48
compiler/dcalc/from_scopelang.ml
View File

@ -224,7 +224,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm S.expr) : 'm Ast.expr boxed =
let case_e =
try EnumConstructor.Map.find constructor e_cases
with EnumConstructor.Map.Not_found _ ->
Message.raise_spanned_error (Expr.pos e)
Message.error ~pos:(Expr.pos e)
"The constructor %a of enum %a is missing from this pattern \
matching"
EnumConstructor.format constructor EnumName.format name
@ -236,7 +236,7 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm S.expr) : 'm Ast.expr boxed =
(EnumConstructor.Map.empty, e_cases)
in
if not (EnumConstructor.Map.is_empty remaining_e_cases) then
Message.raise_spanned_error (Expr.pos e)
Message.error ~pos:(Expr.pos e)
"Pattern matching is incomplete for enum %a: missing cases %a"
EnumName.format name
(EnumConstructor.Map.format_keys ~pp_sep:(fun fmt () ->
@ -272,28 +272,30 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm S.expr) : 'm Ast.expr boxed =
( var_ctx.scope_input_name,
thunk_scope_arg var_ctx (translate_expr ctx e) )
| Some var_ctx, None ->
Message.raise_multispanned_error
[
None, pos;
( Some "Declaration of the missing input variable",
Mark.get (StructField.get_info var_ctx.scope_input_name) );
]
Message.error
~extra_pos:
[
None, pos;
( Some "Declaration of the missing input variable",
Mark.get (StructField.get_info var_ctx.scope_input_name) );
]
"Definition of input variable '%a' missing in this scope call"
ScopeVar.format var_name
| None, Some e ->
Message.raise_multispanned_error_full
Message.error
~suggestion:
(List.map
(fun v -> Mark.remove (ScopeVar.get_info v))
(ScopeVar.Map.keys sc_sig.scope_sig_in_fields))
[
None, Expr.pos e;
( Some
(fun ppf ->
Format.fprintf ppf "Declaration of scope %a"
ScopeName.format scope),
Mark.get (ScopeName.get_info scope) );
]
~fmt_pos:
[
None, Expr.pos e;
( Some
(fun ppf ->
Format.fprintf ppf "Declaration of scope %a"
ScopeName.format scope),
Mark.get (ScopeName.get_info scope) );
]
"Unknown input variable '%a' in scope call of '%a'"
ScopeVar.format var_name ScopeName.format scope)
sc_sig.scope_sig_in_fields args
@ -511,13 +513,13 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm S.expr) : 'm Ast.expr boxed =
match Mark.remove typ with
| TArrow (_, (tout, _)) -> tout
| _ ->
Message.raise_spanned_error (Expr.pos e)
Message.error ~pos:(Expr.pos e)
"Application of non-function toplevel variable")
| _ -> TAny
in
(* Message.emit_debug "new_args %d, input_typs: %d, input_typs %a"
(List.length new_args) (List.length input_typs) (Format.pp_print_list
Print.typ_debug) (List.map (Mark.add Pos.no_pos) input_typs); *)
(* Message.debug "new_args %d, input_typs: %d, input_typs %a" (List.length
new_args) (List.length input_typs) (Format.pp_print_list Print.typ_debug)
(List.map (Mark.add Pos.no_pos) input_typs); *)
let new_args =
ListLabels.mapi (List.combine new_args input_typs)
~f:(fun i (new_arg, input_typ) ->
@ -760,8 +762,8 @@ let translate_scope_decl
(* Todo: are we sure this can't happen in normal code ? E.g. is calling a
scope which only defines input variables already an error at this stage
or not ? *)
Message.raise_spanned_error pos_sigma "Scope %a has no content"
ScopeName.format scope_name
Message.error ~pos:pos_sigma "Scope %a has no content" ScopeName.format
scope_name
| ( S.ScopeVarDefinition { e; _ }
| S.SubScopeVarDefinition { e; _ }
| S.Assertion e )

10
compiler/dcalc/invariants.ml
View File

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

27
compiler/desugared/dependency.ml
View File

@ -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
(( Some
"This definition contradicts other exception \
definitions:",
edge_pos )
:: List.map
(fun pos -> Some "Other exception definition:", pos)
edge.edge_positions)
Message.error
~extra_pos:
(( Some
"This definition contradicts other exception \
definitions:",
edge_pos )
:: List.map
(fun pos -> Some "Other exception definition:", pos)
edge.edge_positions)
"The definition of exceptions are inconsistent for variable \
%a."
Ast.ScopeDef.format def_info)
@ -498,7 +499,7 @@ let check_for_exception_cycle
scc
in
let v, _ = RuleName.Map.choose (List.hd scc).rules in
Message.raise_multispanned_error spans
Message.error ~extra_pos:spans
"Exception cycle detected when defining %a: each of these %d exceptions \
applies over the previous one, and the first applies over the last"
RuleName.format v (List.length scc)

205
compiler/desugared/from_surface.ml
View File

@ -77,7 +77,7 @@ let translate_binop :
| S.KDec -> [TLit TRat; TLit TRat]
| S.KMoney -> [TLit TMoney; TLit TRat]
| S.KDate ->
Message.raise_spanned_error op_pos
Message.error ~pos:op_pos
"This operator doesn't exist, dates can't be multiplied"
| S.KDuration -> [TLit TDuration; TLit TInt])
| S.Div k ->
@ -88,7 +88,7 @@ let translate_binop :
| S.KDec -> [TLit TRat; TLit TRat]
| S.KMoney -> [TLit TMoney; TLit TMoney]
| S.KDate ->
Message.raise_spanned_error op_pos
Message.error ~pos:op_pos
"This operator doesn't exist, dates can't be divided"
| S.KDuration -> [TLit TDuration; TLit TDuration])
| S.Lt k | S.Lte k | S.Gt k | S.Gte k ->
@ -126,7 +126,7 @@ let translate_unop ((op, op_pos) : S.unop Mark.pos) pos arg : Ast.expr boxed =
| S.KDec -> TLit TRat
| S.KMoney -> TLit TMoney
| S.KDate ->
Message.raise_spanned_error op_pos
Message.error ~pos:op_pos
"This operator doesn't exist, dates can't be negative"
| S.KDuration -> TLit TDuration)
@ -138,9 +138,9 @@ let raise_error_cons_not_found
Suggestions.suggestion_minimum_levenshtein_distance_association constructors
(Mark.remove constructor)
in
Message.raise_spanned_error
~span_msg:(fun ppf -> Format.fprintf ppf "Here is your code :")
~suggestion:closest_constructors (Mark.get constructor)
Message.error
~pos_msg:(fun ppf -> Format.fprintf ppf "Here is your code :")
~pos:(Mark.get constructor) ~suggestion:closest_constructors
"The name of this constructor has not been defined before@ (it's probably \
a typographical error)."
@ -152,7 +152,7 @@ let rec disambiguate_constructor
match constructor0 with
| [c] -> Mark.remove c
| _ ->
Message.raise_spanned_error pos
Message.error ~pos
"The deep pattern matching syntactic sugar is not yet supported"
in
let possible_c_uids =
@ -173,7 +173,7 @@ let rec disambiguate_constructor
match path with
| [] ->
if EnumName.Map.cardinal possible_c_uids > 1 then
Message.raise_spanned_error (Mark.get constructor)
Message.error ~pos:(Mark.get constructor)
"This constructor name is ambiguous, it can belong to %a. Disambiguate \
it by prefixing it with the enum name."
(EnumName.Map.format_keys ~pp_sep:(fun fmt () ->
@ -187,8 +187,8 @@ let rec disambiguate_constructor
let c_uid = EnumName.Map.find e_uid possible_c_uids in
e_uid, c_uid
with EnumName.Map.Not_found _ ->
Message.raise_spanned_error pos "Enum %s does not contain case %s"
(Mark.remove enum) (Mark.remove constructor))
Message.error ~pos "Enum %s does not contain case %s" (Mark.remove enum)
(Mark.remove constructor))
| mod_id :: path ->
let constructor =
List.map (Mark.map (fun (_, c) -> path, c)) constructor0
@ -210,8 +210,8 @@ let rec check_formula (op, pos_op) e =
(* Xor is mathematically associative, but without a useful semantics ([a
xor b xor c] is most likely an error since it's true for [a = b = c =
true]) *)
Message.raise_multispanned_error
[None, pos_op; None, pos_op1]
Message.error
~extra_pos:[None, pos_op; None, pos_op1]
"Please add parentheses to explicit which of these operators should be \
applied first";
check_formula (op1, pos_op1) e1;
@ -352,21 +352,21 @@ let rec translate_expr
| LNumber ((Int i, _), Some (Day, _)) ->
LDuration (Runtime.duration_of_numbers 0 0 (int_of_string i))
| LNumber ((Dec (_, _), _), Some ((Year | Month | Day), _)) ->
Message.raise_spanned_error pos
Message.error ~pos
"Impossible to specify decimal amounts of days, months or years"
| LDate date ->
if date.literal_date_month > 12 then
Message.raise_spanned_error pos
Message.error ~pos
"There is an error in this date: the month number is bigger than 12";
if date.literal_date_day > 31 then
Message.raise_spanned_error pos
Message.error ~pos
"There is an error in this date: the day number is bigger than 31";
LDate
(try
Runtime.date_of_numbers date.literal_date_year
date.literal_date_month date.literal_date_day
with Runtime.ImpossibleDate ->
Message.raise_spanned_error pos
Message.error ~pos
"There is an error in this date, it does not correspond to a \
correct calendar day")
in
@ -379,7 +379,7 @@ let rec translate_expr
Expr.make_var uid emark
(* the whole box thing is to accomodate for this case *)
| Some uid, Some state ->
Message.raise_spanned_error (Mark.get state)
Message.error ~pos:(Mark.get state)
"%a is a local variable, it has no states" Print.var uid
| None, state -> (
match Ident.Map.find_opt x scope_vars with
@ -393,14 +393,14 @@ let rec translate_expr
match state, x_sig.var_sig_states_list, inside_definition_of with
| None, [], _ -> None
| Some st, [], _ ->
Message.raise_spanned_error (Mark.get st)
Message.error ~pos:(Mark.get st)
"Variable %a does not define states" ScopeVar.format uid
| st, states, Some (((x'_uid, _), Ast.ScopeDef.Var sx'), _)
when ScopeVar.equal uid x'_uid -> (
if st <> None then
(* TODO *)
Message.raise_spanned_error
(Mark.get (Option.get st))
Message.error
~pos:(Mark.get (Option.get st))
"Referring to a previous state of the variable being defined \
is not supported at the moment.";
match sx' with
@ -410,7 +410,7 @@ let rec translate_expr
state but variable has states"
| Some inside_def_state ->
if StateName.compare inside_def_state (List.hd states) = 0 then
Message.raise_spanned_error pos
Message.error ~pos
"It is impossible to refer to the variable you are defining \
when defining its first state."
else
@ -428,12 +428,14 @@ let rec translate_expr
Ident.Map.find_opt (Mark.remove st) x_sig.var_sig_states_idmap
with
| None ->
Message.raise_multispanned_error
Message.error
~suggestion:(List.map StateName.to_string states)
[
None, Mark.get st;
Some "Variable defined here", Mark.get (ScopeVar.get_info uid);
]
~extra_pos:
[
None, Mark.get st;
( Some "Variable defined here",
Mark.get (ScopeVar.get_info uid) );
]
"Reference to unknown variable state"
| some -> some)
| _, states, _ ->
@ -451,7 +453,7 @@ let rec translate_expr
match Ident.Map.find_opt x ctxt.local.topdefs with
| Some v ->
if state <> None then
Message.raise_spanned_error pos
Message.error ~pos
"Access to intermediate states is only allowed for variables of \
the current scope";
Expr.elocation
@ -461,7 +463,7 @@ let rec translate_expr
Name_resolution.raise_unknown_identifier
"for a local, scope-wide or global variable" (x, pos))))
| Ident (_ :: _, (_, pos), Some _) ->
Message.raise_spanned_error pos
Message.error ~pos
"Access to intermediate states is only allowed for variables of the \
current scope"
| Ident (path, name, None) -> (
@ -499,14 +501,13 @@ let rec translate_expr
in
Expr.eappop ~op ~tys:[ty, pos] ~args:[rec_helper arg] emark
| S.Builtin _ ->
Message.raise_spanned_error pos "Invalid use of built-in: needs one operand"
Message.error ~pos "Invalid use of built-in: needs one operand"
| FunCall (f, args) ->
let args = List.map rec_helper args in
Expr.eapp ~f:(rec_helper f) ~args ~tys:[] emark
| ScopeCall (((path, id), _), fields) ->
if scope = None then
Message.raise_spanned_error pos
"Scope calls are not allowed outside of a scope";
Message.error ~pos "Scope calls are not allowed outside of a scope";
let called_scope, scope_def =
let ctxt = Name_resolution.module_ctx ctxt path in
let uid = Name_resolution.get_scope ctxt id in
@ -521,15 +522,16 @@ let rec translate_expr
with
| Some (ScopeVar v) -> v
| Some (SubScope _) | None ->
Message.raise_multispanned_error
Message.error
~suggestion:(Ident.Map.keys scope_def.var_idmap)
[
None, Mark.get fld_id;
( Some
(Format.asprintf "Scope %a declared here" ScopeName.format
called_scope),
Mark.get (ScopeName.get_info called_scope) );
]
~extra_pos:
[
None, Mark.get fld_id;
( Some
(Format.asprintf "Scope %a declared here"
ScopeName.format called_scope),
Mark.get (ScopeName.get_info called_scope) );
]
"Scope %a has no input variable %a" ScopeName.format
called_scope Print.lit_style (Mark.remove fld_id)
in
@ -537,7 +539,7 @@ let rec translate_expr
(function
| None -> Some (rec_helper e)
| Some _ ->
Message.raise_spanned_error (Mark.get fld_id)
Message.error ~pos:(Mark.get fld_id)
"Duplicate definition of scope input variable '%a'"
ScopeVar.format var)
acc)
@ -565,7 +567,7 @@ let rec translate_expr
| Some (Name_resolution.TScope (_, { out_struct_name = s_uid; _ })) ->
s_uid
| _ ->
Message.raise_spanned_error (Mark.get s_name)
Message.error ~pos:(Mark.get s_name)
"This identifier should refer to a struct name"
in
let s_fields =
@ -576,15 +578,15 @@ let rec translate_expr
StructName.Map.find s_uid
(Ident.Map.find (Mark.remove f_name) ctxt.local.field_idmap)
with StructName.Map.Not_found _ | Ident.Map.Not_found _ ->
Message.raise_spanned_error (Mark.get f_name)
Message.error ~pos:(Mark.get f_name)
"This identifier should refer to a field of struct %s"
(Mark.remove s_name)
in
(match StructField.Map.find_opt f_uid s_fields with
| None -> ()
| Some e_field ->
Message.raise_multispanned_error
[None, Mark.get f_e; None, Expr.pos e_field]
Message.error
~extra_pos:[None, Mark.get f_e; None, Expr.pos e_field]
"The field %a has been defined twice:" StructField.format f_uid);
let f_e = rec_helper f_e in
StructField.Map.add f_uid f_e s_fields)
@ -596,7 +598,7 @@ let rec translate_expr
(fun expected_f _ -> not (StructField.Map.mem expected_f s_fields))
expected_s_fields
then
Message.raise_spanned_error pos "Missing field(s) for structure %a:@\n%a"
Message.error ~pos "Missing field(s) for structure %a:@\n%a"
StructName.format s_uid
(Format.pp_print_list
~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ")
@ -634,7 +636,7 @@ let rec translate_expr
(* No enum name was specified *)
EnumName.Map.cardinal possible_c_uids > 1
then
Message.raise_spanned_error pos_constructor
Message.error ~pos:pos_constructor
"This constructor name is ambiguous, it can belong to %a. \
Desambiguate it by prefixing it with the enum name."
(EnumName.Map.format_keys ~pp_sep:(fun fmt () ->
@ -669,8 +671,8 @@ let rec translate_expr
| None -> Expr.elit LUnit mark_constructor)
~cons:c_uid ~name:e_uid emark
with EnumName.Map.Not_found _ ->
Message.raise_spanned_error pos "Enum %s does not contain case %s"
(Mark.remove enum) constructor))
Message.error ~pos "Enum %s does not contain case %s" (Mark.remove enum)
constructor))
| MatchWith (e1, (cases, _cases_pos)) ->
let e1 = rec_helper e1 in
let cases_d, e_uid =
@ -682,7 +684,7 @@ let rec translate_expr
(match snd (Mark.remove pattern) with
| None -> ()
| Some binding ->
Message.emit_spanned_warning (Mark.get binding)
Message.warning ~pos:(Mark.get binding)
"This binding will be ignored (remove it to suppress warning)");
let enum_uid, c_uid =
disambiguate_constructor ctxt
@ -872,8 +874,7 @@ let rec translate_expr
| S.Money -> LMoney (Runtime.money_of_cents_integer i0)
| S.Duration -> LDuration (Runtime.duration_of_numbers 0 0 0)
| t ->
Message.raise_spanned_error pos
"It is impossible to sum values of type %a together"
Message.error ~pos "It is impossible to sum values of type %a together"
SurfacePrint.format_primitive_typ t
in
let op_f =
@ -962,8 +963,8 @@ and disambiguate_match_and_build_expression
| Some e_uid ->
if e_uid = e_uid' then e_uid
else
Message.raise_spanned_error
(Mark.get case.S.match_case_pattern)
Message.error
~pos:(Mark.get case.S.match_case_pattern)
"This case matches a constructor of enumeration %a but previous \
case were matching constructors of enumeration %a"
EnumName.format e_uid EnumName.format e_uid'
@ -971,8 +972,9 @@ and disambiguate_match_and_build_expression
(match EnumConstructor.Map.find_opt c_uid cases_d with
| None -> ()
| Some e_case ->
Message.raise_multispanned_error
[None, Mark.get case.match_case_expr; None, Expr.pos e_case]
Message.error
~extra_pos:
[None, Mark.get case.match_case_expr; None, Expr.pos e_case]
"The constructor %a has been matched twice:" EnumConstructor.format
c_uid);
let local_vars, param_var =
@ -990,18 +992,19 @@ and disambiguate_match_and_build_expression
| S.WildCard match_case_expr -> (
let nb_cases = List.length cases in
let raise_wildcard_not_last_case_err () =
Message.raise_multispanned_error
[
Some "Not ending wildcard:", case_pos;
( Some "Next reachable case:",
curr_index + 1 |> List.nth cases |> Mark.get );
]
Message.error
~extra_pos:
[
Some "Not ending wildcard:", case_pos;
( Some "Next reachable case:",
curr_index + 1 |> List.nth cases |> Mark.get );
]
"Wildcard must be the last match case"
in
match e_uid with
| None ->
if 1 = nb_cases then
Message.raise_spanned_error case_pos
Message.error ~pos:case_pos
"Couldn't infer the enumeration name from lonely wildcard \
(wildcard cannot be used as single match case)"
else raise_wildcard_not_last_case_err ()
@ -1015,7 +1018,7 @@ and disambiguate_match_and_build_expression
| None -> Some c_uid)
in
if EnumConstructor.Map.is_empty missing_constructors then
Message.emit_spanned_warning case_pos
Message.warning ~pos:case_pos
"Unreachable match case, all constructors of the enumeration %a \
are already specified"
EnumName.format e_uid;
@ -1078,24 +1081,27 @@ let rec arglist_eq_check pos_decl pos_def pdecl pdefs =
match pdecl, pdefs with
| [], [] -> ()
| [], (arg, apos) :: _ ->
Message.raise_multispanned_error
[Some "Declared here:", pos_decl; Some "Extra argument:", apos]
Message.error
~extra_pos:[Some "Declared here:", pos_decl; Some "Extra argument:", apos]
"This definition has an extra, undeclared argument '%a'" Print.lit_style
arg
| (arg, apos) :: _, [] ->
Message.raise_multispanned_error
[
Some "Argument declared here:", apos;
Some "Mismatching definition:", pos_def;
]
Message.error
~extra_pos:
[
Some "Argument declared here:", apos;
Some "Mismatching definition:", pos_def;
]
"This definition is missing argument '%a'" Print.lit_style arg
| decl :: pdecl, def :: pdefs when Uid.MarkedString.equal decl def ->
arglist_eq_check pos_decl pos_def pdecl pdefs
| (decl_arg, decl_apos) :: _, (def_arg, def_apos) :: _ ->
Message.raise_multispanned_error
[
Some "Argument declared here:", decl_apos; Some "Defined here:", def_apos;
]
Message.error
~extra_pos:
[
Some "Argument declared here:", decl_apos;
Some "Defined here:", def_apos;
]
"Function argument name mismatch between declaration ('%a') and \
definition ('%a')"
Print.lit_style decl_arg Print.lit_style def_arg
@ -1111,18 +1117,21 @@ let process_rule_parameters
match declared_params, def.S.definition_parameter with
| None, None -> Ident.Map.empty, None
| None, Some (_, pos) ->
Message.raise_multispanned_error
[
Some "Declared here without arguments", decl_pos;
Some "Unexpected arguments appearing here", pos;
]
Message.error
~extra_pos:
[
Some "Declared here without arguments", decl_pos;
Some "Unexpected arguments appearing here", pos;
]
"Extra arguments in this definition of %a" Ast.ScopeDef.format decl_name
| Some (_, pos), None ->
Message.raise_multispanned_error
[
Some "Arguments declared here", pos;
Some "Definition missing the arguments", Mark.get def.S.definition_name;
]
Message.error
~extra_pos:
[
Some "Arguments declared here", pos;
( Some "Definition missing the arguments",
Mark.get def.S.definition_name );
]
"This definition for %a is missing the arguments" Ast.ScopeDef.format
decl_name
| Some (pdecl, pos_decl), Some (pdefs, pos_def) ->
@ -1222,7 +1231,7 @@ let process_def
in
ExceptionToLabel (label_id, Mark.get label_str)
with Ident.Map.Not_found _ ->
Message.raise_spanned_error (Mark.get label_str)
Message.error ~pos:(Mark.get label_str)
"Unknown label for the scope variable %a: \"%s\""
Ast.ScopeDef.format def_key (Mark.remove label_str))
in
@ -1337,8 +1346,8 @@ let process_scope_use_item
scope.scope_options
with
| Some (_, old_pos) ->
Message.raise_multispanned_error
[None, old_pos; None, Mark.get item]
Message.error
~extra_pos:[None, old_pos; None, Mark.get item]
"You cannot set multiple date rounding modes"
| None ->
{
@ -1390,12 +1399,13 @@ let check_unlabeled_exception
| S.UnlabeledException -> (
match scope_def_ctxt.default_exception_rulename with
| None ->
Message.raise_spanned_error (Mark.get item)
Message.error ~pos:(Mark.get item)
"This exception does not have a corresponding definition"
| Some (Ambiguous pos) ->
Message.raise_multispanned_error
([Some "Ambiguous exception", Mark.get item]
@ List.map (fun p -> Some "Candidate definition", p) pos)
Message.error
~extra_pos:
([Some "Ambiguous exception", Mark.get item]
@ List.map (fun p -> Some "Candidate definition", p) pos)
"This exception can refer to several definitions. Try using labels \
to disambiguate"
| Some (Unique _) -> ()))
@ -1451,7 +1461,7 @@ let process_topdef
let () =
match tys with
| [(Data (S.TTuple _), pos)] ->
Message.raise_spanned_error pos
Message.error ~pos
"Defining arguments of a function as a tuple is not supported, \
please name the individual arguments"
| _ -> ()
@ -1472,11 +1482,12 @@ let process_topdef
| None, eopt -> Some (eopt, typ)
| Some (eopt0, ty0), eopt -> (
let err msg =
Message.raise_multispanned_error
[
None, Mark.get (TopdefName.get_info id);
None, Mark.get def.S.topdef_name;
]
Message.error
~extra_pos:
[
None, Mark.get (TopdefName.get_info id);
None, Mark.get def.S.topdef_name;
]
(msg ^^ " for %a") TopdefName.format id
in
if not (Type.equal ty0 typ) then err "Conflicting type definitions"

26
compiler/desugared/linting.ml
View File

@ -37,8 +37,8 @@ let detect_empty_definitions (p : program) : unit =
| NoInput -> true
| _ -> false
then
Message.emit_spanned_warning
(ScopeDef.get_position scope_def_key)
Message.warning
~pos:(ScopeDef.get_position scope_def_key)
"In scope \"%a\", the variable \"%a\" is declared but never \
defined; did you forget something?"
ScopeName.format scope_name Ast.ScopeDef.format scope_def_key)
@ -94,7 +94,7 @@ let detect_identical_rules (p : program) : unit =
RuleExpressionsMap.iter
(fun _ pos ->
if List.length pos > 1 then
Message.emit_multispanned_warning pos
Message.warning ~extra_pos:pos
"These %s have identical justifications and consequences; is \
it a mistake?"
(if scope_def.scope_def_is_condition then "rules"
@ -153,8 +153,8 @@ let detect_unused_struct_fields (p : program) : unit =
&& not (StructField.Set.mem field scope_out_structs_fields))
fields
then
Message.emit_spanned_warning
(snd (StructName.get_info s_name))
Message.warning
~pos:(snd (StructName.get_info s_name))
"The structure \"%a\" is never used; maybe it's unnecessary?"
StructName.format s_name
else
@ -164,8 +164,8 @@ let detect_unused_struct_fields (p : program) : unit =
(not (StructField.Set.mem field struct_fields_used))
&& not (StructField.Set.mem field scope_out_structs_fields)
then
Message.emit_spanned_warning
(snd (StructField.get_info field))
Message.warning
~pos:(snd (StructField.get_info field))
"The field \"%a\" of struct @{<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
(snd (EnumName.get_info e_name))
Message.warning
~pos:(snd (EnumName.get_info e_name))
"The enumeration \"%a\" is never used; maybe it's unnecessary?"
EnumName.format e_name
else
@ -221,8 +221,8 @@ let detect_unused_enum_constructors (p : program) : unit =
if
not (EnumConstructor.Set.mem constructor enum_constructors_used)
then
Message.emit_spanned_warning
(snd (EnumConstructor.get_info constructor))
Message.warning
~pos:(snd (EnumConstructor.get_info constructor))
"The constructor \"%a\" of enumeration \"%a\" is never used; \
maybe it's unnecessary?"
EnumConstructor.format constructor EnumName.format e_name)
@ -266,8 +266,8 @@ let detect_dead_code (p : program) : unit =
in
let is_alive = Reachability.analyze is_alive scope_dependencies in
let emit_unused_warning vx =
Message.emit_spanned_warning
(Mark.get (Dependency.Vertex.info vx))
Message.warning
~pos:(Mark.get (Dependency.Vertex.info vx))
"Unused varible: %a does not contribute to computing any of scope %a \
outputs. Did you forget something?"
Dependency.Vertex.format vx ScopeName.format scope_name

178
compiler/desugared/name_resolution.ml
View File

@ -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
[
None, Mark.get id;
Some "Structure defined at", Mark.get (StructName.get_info sid);
]
Message.error
~extra_pos:
[
None, Mark.get id;
Some "Structure defined at", Mark.get (StructName.get_info sid);
]
"Expecting an enum, but found a structure"
| TScope (sid, _) ->
Message.raise_multispanned_error
[
None, Mark.get id;
Some "Scope defined at", Mark.get (ScopeName.get_info sid);
]
Message.error
~extra_pos:
[
None, Mark.get id;
Some "Scope defined at", Mark.get (ScopeName.get_info sid);
]
"Expecting an enum, but found a scope"
| exception Ident.Map.Not_found _ ->
Message.raise_spanned_error (Mark.get id) "No enum named %s found"
(Mark.remove id)
Message.error ~pos:(Mark.get id) "No enum named %s found" (Mark.remove id)
let get_struct ctxt id =
match Ident.Map.find (Mark.remove id) ctxt.local.typedefs with
| TStruct id | TScope (_, { out_struct_name = id; _ }) -> id
| TEnum eid ->
Message.raise_multispanned_error
[
None, Mark.get id;
Some "Enum defined at", Mark.get (EnumName.get_info eid);
]
Message.error
~extra_pos:
[
None, Mark.get id;
Some "Enum defined at", Mark.get (EnumName.get_info eid);
]
"Expecting a struct, but found an enum"
| exception Ident.Map.Not_found _ ->
Message.raise_spanned_error (Mark.get id) "No struct named %s found"
(Mark.remove id)
Message.error ~pos:(Mark.get id) "No struct named %s found" (Mark.remove id)
let get_scope ctxt id =
match Ident.Map.find (Mark.remove id) ctxt.local.typedefs with
| TScope (id, _) -> id
| TEnum eid ->
Message.raise_multispanned_error
[
None, Mark.get id;
Some "Enum defined at", Mark.get (EnumName.get_info eid);
]
Message.error
~extra_pos:
[
None, Mark.get id;
Some "Enum defined at", Mark.get (EnumName.get_info eid);
]
"Expecting an scope, but found an enum"
| TStruct sid ->
Message.raise_multispanned_error
[
None, Mark.get id;
Some "Structure defined at", Mark.get (StructName.get_info sid);
]
Message.error
~extra_pos:
[
None, Mark.get id;
Some "Structure defined at", Mark.get (StructName.get_info sid);
]
"Expecting an scope, but found a structure"
| exception Ident.Map.Not_found _ ->
Message.raise_spanned_error (Mark.get id) "No scope named %s found"
(Mark.remove id)
Message.error ~pos:(Mark.get id) "No scope named %s found" (Mark.remove id)
let get_modname ctxt (id, pos) =
match Ident.Map.find_opt id ctxt.local.used_modules with
| None ->
Message.raise_spanned_error pos "Module \"@{<blue>%s@}\" not found" id
| None -> Message.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
[Some "first use", Mark.get info; Some "second use", s_pos]
Message.error
~extra_pos:[Some "first use", Mark.get info; Some "second use", s_pos]
"Subscope name @{<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
[Some "First use:", Mark.get info; Some "Second use:", pos]
Message.error
~extra_pos:[Some "First use:", Mark.get info; Some "Second use:", pos]
"Variable name @{<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
[
( Some
(fun ppf ->
Format.fprintf ppf
"First instance of state @{<yellow>\"%s\"@}:"
state_id_name),
Mark.get state_id );
( Some
(fun ppf ->
Format.fprintf ppf
"Second instance of state @{<yellow>\"%s\"@}:"
state_id_name),
Mark.get
(Ident.Map.find state_id_name states_idmap
|> StateName.get_info) );
]
Message.error
~fmt_pos:
[
( Some
(fun ppf ->
Format.fprintf ppf
"First instance of state @{<yellow>\"%s\"@}:"
state_id_name),
Mark.get state_id );
( Some
(fun ppf ->
Format.fprintf ppf
"Second instance of state @{<yellow>\"%s\"@}:"
state_id_name),
Mark.get
(Ident.Map.find state_id_name states_idmap
|> StateName.get_info) );
]
"There are two states with the same name for the same variable: \
this is ambiguous. Please change the name of either states.";
let state_uid = StateName.fresh state_id in
@ -438,8 +440,8 @@ let process_struct_decl (ctxt : context) (sdecl : Surface.Ast.struct_decl) :
context =
let s_uid = get_struct ctxt sdecl.struct_decl_name in
if sdecl.struct_decl_fields = [] then
Message.raise_spanned_error
(Mark.get sdecl.struct_decl_name)
Message.error
~pos:(Mark.get sdecl.struct_decl_name)
"The struct %s does not have any fields; give it some for Catala to be \
able to accept it."
(Mark.remove sdecl.struct_decl_name);
@ -483,8 +485,8 @@ let process_enum_decl (ctxt : context) (edecl : Surface.Ast.enum_decl) : context
=
let e_uid = get_enum ctxt edecl.enum_decl_name in
if List.length edecl.enum_decl_cases = 0 then
Message.raise_spanned_error
(Mark.get edecl.enum_decl_name)
Message.error
~pos:(Mark.get edecl.enum_decl_name)
"The enum %s does not have any cases; give it some for Catala to be able \
to accept it."
(Mark.remove edecl.enum_decl_name);
@ -645,12 +647,13 @@ let typedef_info = function
let process_name_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
context =
let raise_already_defined_error (use : Uid.MarkedString.info) name pos msg =
Message.raise_multispanned_error_full
[
( Some (fun ppf -> Format.pp_print_string ppf "First definition:"),
Mark.get use );
Some (fun ppf -> Format.pp_print_string ppf "Second definition:"), pos;
]
Message.error
~fmt_pos:
[
( Some (fun ppf -> Format.pp_print_string ppf "First definition:"),
Mark.get use );
Some (fun ppf -> Format.pp_print_string ppf "Second definition:"), pos;
]
"%s name @{<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
[
None, Mark.get state;
Some "Variable declaration:", Mark.get (ScopeVar.get_info x_uid);
]
Message.error
~extra_pos:
[
None, Mark.get state;
( Some "Variable declaration:",
Mark.get (ScopeVar.get_info x_uid) );
]
"This identifier is not a state declared for variable %a."
ScopeVar.format x_uid)
| None ->
if not (Ident.Map.is_empty var_sig.var_sig_states_idmap) then
Message.raise_multispanned_error
[
None, Mark.get x;
Some "Variable declaration:", Mark.get (ScopeVar.get_info x_uid);
]
Message.error
~extra_pos:
[
None, Mark.get x;
( Some "Variable declaration:",
Mark.get (ScopeVar.get_info x_uid) );
]
"This definition does not indicate which state has to be \
considered for variable %a."
ScopeVar.format x_uid
@ -802,18 +809,17 @@ let get_def_key
match Ident.Map.find_opt (Mark.remove y) scope_ctxt.var_idmap with
| Some (SubScope (v, u, _)) -> v, u
| Some _ ->
Message.raise_spanned_error pos
"Invalid definition, %a is not a subscope" Print.lit_style
(Mark.remove y)
| None ->
Message.raise_spanned_error pos "No definition found for subscope %a"
Message.error ~pos "Invalid definition, %a is not a subscope"
Print.lit_style (Mark.remove y)
| None ->
Message.error ~pos "No definition found for subscope %a" Print.lit_style
(Mark.remove y)
in
let var_within_origin_scope = get_var_uid name ctxt x in
( (subscope_var, pos),
Ast.ScopeDef.SubScopeInput { name; var_within_origin_scope } )
| _ ->
Message.raise_spanned_error pos
Message.error ~pos
"This line is defining a quantity that is neither a scope variable nor a \
subscope variable. In particular, it is not possible to define struct \
fields individually in Catala."
@ -937,8 +943,8 @@ let process_scope_use (ctxt : context) (suse : Surface.Ast.scope_use) : context
with
| Some (TScope (sn, _)) -> sn
| _ ->
Message.raise_spanned_error
(Mark.get suse.Surface.Ast.scope_use_name)
Message.error
~pos:(Mark.get suse.Surface.Ast.scope_use_name)
"@{<yellow>\"%s\"@}: this scope has not been declared anywhere, is it \
a typo?"
(Mark.remove suse.Surface.Ast.scope_use_name)

6
compiler/desugared/print.ml
View File

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

128
compiler/driver.ml
View File

@ -35,7 +35,7 @@ let load_module_interfaces
(* Recurse into program modules, looking up files in [using] and loading
them *)
if program.Surface.Ast.program_used_modules <> [] then
Message.emit_debug "Loading module interfaces...";
Message.debug "Loading module interfaces...";
let includes =
List.map options.Global.path_rewrite includes @ more_includes
|> List.map File.Tree.build
@ -56,13 +56,13 @@ let load_module_interfaces
extensions
with
| [] ->
Message.raise_multispanned_error
(err_req_pos (mpos :: req_chain))
Message.error
~extra_pos:(err_req_pos (mpos :: req_chain))
"Required module not found: @{<blue>%s@}" mname
| [f] -> f
| ms ->
Message.raise_multispanned_error
(err_req_pos (mpos :: req_chain))
Message.error
~extra_pos:(err_req_pos (mpos :: req_chain))
"Required module @{<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
(err_req_pos (Mark.get use.Surface.Ast.mod_use_name :: req_chain))
Message.error
~extra_pos:
(err_req_pos (Mark.get use.Surface.Ast.mod_use_name :: req_chain))
"Circular module dependency"
| None ->
let default_module_name =
@ -131,7 +132,7 @@ module Passes = struct
(forwarding their options as needed) *)
let debug_pass_name s =
Message.emit_debug "@{<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.raise_error "--check-invariants cannot be used with --no-typing");
(Message.error ~internal:true "Some Dcalc invariants are invalid")
| _ -> Message.error "--check-invariants cannot be used with --no-typing");
prg, type_ordering
let lcalc
@ -246,7 +246,7 @@ module Passes = struct
let prg =
match avoid_exceptions, options.trace, typed with
| true, true, _ ->
Message.raise_error
Message.error
"Option --avoid-exceptions is not compatible with option --trace"
| true, _, Untyped _ ->
Lcalc.From_dcalc.translate_program_without_exceptions prg
@ -260,32 +260,32 @@ module Passes = struct
in
let prg =
if optimize then begin
Message.emit_debug "Optimizing lambda calculus...";
Message.debug "Optimizing lambda calculus...";
Optimizations.optimize_program prg
end
else prg
in
let prg =
if not closure_conversion then (
Message.emit_debug "Retyping lambda calculus...";
Message.debug "Retyping lambda calculus...";
Typing.program ~fail_on_any:false prg)
else (
Message.emit_debug "Performing closure conversion...";
Message.debug "Performing closure conversion...";
let prg = Lcalc.Closure_conversion.closure_conversion prg in
let prg =
if optimize then (
Message.emit_debug "Optimizing lambda calculus...";
Message.debug "Optimizing lambda calculus...";
Optimizations.optimize_program prg)
else prg
in
Message.emit_debug "Retyping lambda calculus...";
Message.debug "Retyping lambda calculus...";
Typing.program ~fail_on_any:false prg)
in
let prg, type_ordering =
if monomorphize_types then (
Message.emit_debug "Monomorphizing types...";
Message.debug "Monomorphizing types...";
let prg, type_ordering = Lcalc.Monomorphize.program prg in
Message.emit_debug "Retyping lambda calculus...";
Message.debug "Retyping lambda calculus...";
let prg = Typing.program ~fail_on_any:false ~assume_op_types:true prg in
prg, type_ordering)
else prg, type_ordering
@ -320,21 +320,21 @@ module Commands = struct
let get_scope_uid (ctx : decl_ctx) (scope : string) : ScopeName.t =
if String.contains scope '.' then
Message.raise_error
Message.error
"Bad scope argument @{<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
"There is no scope \"@{<yellow>%s@}\" inside the program." scope
Message.error "There is no scope \"@{<yellow>%s@}\" inside the program."
scope
(* TODO: this is very weird but I'm trying to maintain the current behaviour
for now *)
let get_random_scope_uid (ctx : decl_ctx) : ScopeName.t =
match Ident.Map.choose_opt ctx.ctx_scope_index with
| Some (_, name) -> name
| None -> Message.raise_error "There isn't any scope inside the program."
| None -> Message.error "There isn't any scope inside the program."
let get_variable_uid
(ctxt : Desugared.Name_resolution.context)
@ -353,7 +353,7 @@ module Commands = struct
(ScopeName.Map.find scope_uid ctxt.scopes).var_idmap
with
| None ->
Message.raise_error
Message.error
"Variable @{<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"
(Option.value ~default:"stdout" output_file);
Message.debug "Writing to %s" (Option.value ~default:"stdout" output_file);
if wrap_weaved_output then
Literate.Html.wrap_html prg.Surface.Ast.program_source_files language fmt
(fun fmt -> weave_output fmt prg)
@ -448,7 +447,7 @@ module Commands = struct
|> Surface.Fill_positions.fill_pos_with_legislative_info)
extra_files
in
Message.emit_debug "Weaving literate program into LaTeX";
Message.debug "Weaving literate program into LaTeX";
let output_file, with_output =
get_output_format options ~ext:".tex" output
in
@ -458,8 +457,7 @@ module Commands = struct
Cli.file_lang (Global.input_src_file options.Global.input_src)
in
let weave_output = Literate.Latex.ast_to_latex language ~print_only_law in
Message.emit_debug "Writing to %s"
(Option.value ~default:"stdout" output_file);
Message.debug "Writing to %s" (Option.value ~default:"stdout" output_file);
let weave fmt =
weave_output fmt prg;
List.iter
@ -548,13 +546,13 @@ module Commands = struct
let typecheck options check_invariants includes =
let prg = Passes.scopelang options ~includes in
Message.emit_debug "Typechecking...";
Message.debug "Typechecking...";
let _type_ordering =
Scopelang.Dependency.check_type_cycles prg.program_ctx.ctx_structs
prg.program_ctx.ctx_enums
in
let prg = Scopelang.Ast.type_program prg in
Message.emit_debug "Translating to default calculus...";
Message.debug "Translating to default calculus...";
(* Strictly type-checking could stop here, but we also want this pass to
check full name-resolution and cycle detection. These are checked during
translation to dcalc so we run it here and drop the result. *)
@ -563,12 +561,12 @@ module Commands = struct
(* Additionally, we might want to check the invariants. *)
if check_invariants then (
let prg = Shared_ast.Typing.program prg in
Message.emit_debug "Checking invariants...";
Message.debug "Checking invariants...";
if Dcalc.Invariants.check_all_invariants prg then
Message.emit_result "All invariant checks passed"
Message.result "All invariant checks passed"
else
raise (Message.raise_internal_error "Some Dcalc invariants are invalid"));
Message.emit_result "Typechecking successful!"
raise (Message.error ~internal:true "Some Dcalc invariants are invalid"));
Message.result "Typechecking successful!"
let typecheck_cmd =
Cmd.v
@ -662,20 +660,20 @@ module Commands = struct
$ Cli.Flags.disable_counterexamples)
let print_interpretation_results options interpreter prg scope_uid =
Message.emit_debug "Starting interpretation...";
Message.debug "Starting interpretation...";
let results = interpreter prg scope_uid in
Message.emit_debug "End of interpretation";
Message.debug "End of interpretation";
let results =
List.sort (fun ((v1, _), _) ((v2, _), _) -> String.compare v1 v2) results
in
Message.emit_result "Computation successful!%s"
Message.result "Computation successful!%s"
(if List.length results > 0 then " Results:" else "");
let language =
Cli.file_lang (Global.input_src_file options.Global.input_src)
in
List.iter
(fun ((var, _), result) ->
Message.emit_result "@[<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.emit_debug "Writing to %s..."
Message.debug "Compiling program into OCaml...";
Message.debug "Writing to %s..."
(Option.value ~default:"stdout" output_file);
let exec_scope = Option.map (get_scope_uid prg.decl_ctx) ex_scope_opt in
Lcalc.To_ocaml.format_program fmt prg ?exec_scope type_ordering
@ -908,8 +906,8 @@ module Commands = struct
let output_file, with_output =
get_output_format options ~ext:".py" output
in
Message.emit_debug "Compiling program into Python...";
Message.emit_debug "Writing to %s..."
Message.debug "Compiling program into Python...";
Message.debug "Writing to %s..."
(Option.value ~default:"stdout" output_file);
with_output
@@ fun fmt -> Scalc.To_python.format_program fmt prg type_ordering
@ -937,8 +935,8 @@ module Commands = struct
in
let output_file, with_output = get_output_format options ~ext:".r" output in
Message.emit_debug "Compiling program into R...";
Message.emit_debug "Writing to %s..."
Message.debug "Compiling program into R...";
Message.debug "Writing to %s..."
(Option.value ~default:"stdout" output_file);
with_output @@ fun fmt -> Scalc.To_r.format_program fmt prg type_ordering
@ -962,8 +960,8 @@ module Commands = struct
~monomorphize_types:true
in
let output_file, with_output = get_output_format options ~ext:".c" output in
Message.emit_debug "Compiling program into C...";
Message.emit_debug "Writing to %s..."
Message.debug "Compiling program into C...";
Message.debug "Writing to %s..."
(Option.value ~default:"stdout" output_file);
with_output @@ fun fmt -> Scalc.To_c.format_program fmt prg type_ordering
@ -1019,7 +1017,7 @@ module Commands = struct
| None -> f
| Some pfx ->
if not (Filename.is_relative f) then (
Message.emit_warning
Message.warning
"Not adding prefix to %s, which is an absolute path" f;
f)
else File.(pfx / f)
@ -1090,7 +1088,7 @@ end
let raise_help cmdname cmds =
let plugins = Plugin.names () in
let cmds = List.filter (fun name -> not (List.mem name plugins)) cmds in
Message.raise_error
Message.error
"One of the following commands was expected:@;\
<1 4>@[<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

4
compiler/lcalc/compile_with_exceptions.ml
View File

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

4
compiler/lcalc/compile_without_exceptions.ml
View File

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

8
compiler/lcalc/to_ocaml.ml
View File

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

2
compiler/literate/html.ml
View File

@ -100,7 +100,7 @@ let wrap_html
(** Performs syntax highlighting on a piece of code by using Pygments and the
special Catala lexer. *)
let pygmentize_code (c : string Mark.pos) (lang : C.backend_lang) : string =
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 ->

3
compiler/literate/latex.ml
View File

@ -339,5 +339,4 @@ let ast_to_latex
Format.pp_print_cut fmt ())
program.program_items;
Format.pp_close_box fmt ();
Message.emit_debug "Lines of Catala inside literate source code: %d"
!lines_of_code
Message.debug "Lines of Catala inside literate source code: %d" !lines_of_code

11
compiler/literate/literate_common.ml
View File

@ -64,7 +64,7 @@ let get_language_extension = function
| Pl -> "catala_pl"
let raise_failed_pandoc (command : string) (error_code : int) : 'a =
Message.raise_error
Message.error
"Weaving failed: pandoc command \"%s\" returned with error code %d" command
error_code
@ -113,9 +113,10 @@ let check_exceeding_lines
Uutf.String.fold_utf_8 (fun (acc : int) _ _ -> acc + 1) 0 s
in
if len_s > max_len then
Message.emit_spanned_warning
(Pos.from_info filename (start_line + i) (max_len + 1)
(start_line + i) (len_s + 1))
Message.warning
~pos:
(Pos.from_info filename (start_line + i) (max_len + 1)
(start_line + i) (len_s + 1))
"This line is exceeding @{<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

13
compiler/plugin.ml
View File

@ -32,26 +32,25 @@ let load_failures = Hashtbl.create 17
let print_failures () =
if Hashtbl.length load_failures > 0 then
Message.emit_warning "Some plugins could not be loaded:@,%a"
Message.warning "Some plugins could not be loaded:@,%a"
(Format.pp_print_seq (fun ppf -> Format.fprintf ppf " - %s"))
(Hashtbl.to_seq_values load_failures)
let load_file f =
try
Dynlink.loadfile f;
Message.emit_debug "Plugin %S loaded" f
Message.debug "Plugin %S loaded" f
with
| Dynlink.Error (Dynlink.Module_already_loaded s) ->
Message.emit_debug "Plugin %S (%s) was already loaded, skipping" f s
Message.debug "Plugin %S (%s) was already loaded, skipping" f s
| Dynlink.Error err ->
let msg = Dynlink.error_message err in
Message.emit_debug "Could not load plugin %S: %s" f msg;
Message.debug "Could not load plugin %S: %s" f msg;
Hashtbl.add load_failures f msg
| e ->
Message.emit_warning "Could not load plugin %S: %s" f (Printexc.to_string e)
| e -> Message.warning "Could not load plugin %S: %s" f (Printexc.to_string e)
let load_dir d =
Message.emit_debug "Loading plugins from %s" d;
Message.debug "Loading plugins from %s" d;
let dynlink_exts =
if Dynlink.is_native then [".cmxs"] else [".cmo"; ".cma"]
in

4
compiler/plugins/api_web.ml
View File

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

11
compiler/plugins/explain.ml
View File

@ -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
((None, Expr.mark_pos m)
:: List.map (fun (e, _) -> None, Expr.pos e) excs)
Message.error
~extra_pos:
((None, Expr.mark_pos m)
:: List.map (fun (e, _) -> None, Expr.pos e) excs)
"Conflicting exceptions")
| EPureDefault e, _ -> lazy_eval ctx env llevel e
| EIfThenElse { cond; etrue; efalse }, _ -> (
@ -693,7 +694,7 @@ let program_to_graph
in
(G.add_edge g v child_v, var_vertices, env), v
with Var.Map.Not_found _ ->
Message.emit_warning "VAR NOT FOUND: %a" Print.var var;
Message.warning "VAR NOT FOUND: %a" Print.var var;
let v = G.V.create e in
let g = G.add_vertex g v in
(g, var_vertices, env), v))

2
compiler/plugins/json_schema.ml
View File

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

9
compiler/plugins/lazy_interp.ml
View File

@ -20,7 +20,7 @@ open Shared_ast
(* -- Definition of the lazy interpreter -- *)
let log fmt = Format.ifprintf Format.err_formatter (fmt ^^ "@\n")
let error e = 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
((None, Expr.mark_pos m)
:: List.map (fun (e, _) -> None, Expr.pos e) excs)
Message.error
~extra_pos:
((None, Expr.mark_pos m)
:: List.map (fun (e, _) -> None, Expr.pos e) excs)
"Conflicting exceptions")
| EPureDefault e, _ -> lazy_eval ctx env llevel e
| EIfThenElse { cond; etrue; efalse }, _ -> (

5
compiler/plugins/python.ml
View File

@ -39,9 +39,8 @@ let run
in
let output_file, with_output = get_output_format options ~ext:".py" output in
Message.emit_debug "Compiling program into Python...";
Message.emit_debug "Writing to %s..."
(Option.value ~default:"stdout" output_file);
Message.debug "Compiling program into Python...";
Message.debug "Writing to %s..." (Option.value ~default:"stdout" output_file);
with_output @@ fun fmt -> Scalc.To_python.format_program fmt prg type_ordering
let term =

2
compiler/scalc/from_lcalc.ml
View File

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

6
compiler/scalc/to_c.ml
View File

@ -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@];"

2
compiler/scalc/to_r.ml
View File

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

17
compiler/scopelang/dependency.ml
View File

@ -118,8 +118,8 @@ let build_program_dep_graph (prgm : 'm Ast.program) : SDependencies.t =
(fun glo_name (expr, _) g ->
let used_defs = expr_used_defs expr in
if VMap.mem (Topdef glo_name) used_defs then
Message.raise_spanned_error
(Mark.get (TopdefName.get_info glo_name))
Message.error
~pos:(Mark.get (TopdefName.get_info glo_name))
"The Topdef %a has a definition that refers to itself, which is \
forbidden since Catala does not provide recursion"
TopdefName.format glo_name;
@ -136,8 +136,8 @@ let build_program_dep_graph (prgm : 'm Ast.program) : SDependencies.t =
(fun g rule ->
let used_defs = rule_used_defs rule in
if VMap.mem (Scope scope_name) used_defs then
Message.raise_spanned_error
(Mark.get (ScopeName.get_info scope.Ast.scope_decl_name))
Message.error
~pos:(Mark.get (ScopeName.get_info scope.Ast.scope_decl_name))
"The scope %a is calling into itself as a subscope, which is \
forbidden since Catala does not provide recursion"
ScopeName.format scope.Ast.scope_decl_name;
@ -191,7 +191,7 @@ let check_for_cycle_in_defs (g : SDependencies.t) : unit =
cycle
(List.tl cycle @ [List.hd cycle])
in
Message.raise_multispanned_error spans
Message.error ~extra_pos:spans
"@[<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
"Cyclic dependency detected between types!");
Message.error ~extra_pos:spans "Cyclic dependency detected between types!");
List.rev (TTopologicalTraversal.fold (fun v acc -> v :: acc) g [])

52
compiler/scopelang/from_desugared.ml
View File

@ -214,27 +214,29 @@ let rule_to_exception_graph (scope : D.scope) = function
let () =
match Mark.remove scope_def.D.scope_def_io.io_input with
| NoInput ->
Message.raise_multispanned_error
(( Some "Incriminated subscope:",
Mark.get (ScopeVar.get_info (Mark.remove sscope)) )
:: ( Some "Incriminated variable:",
Mark.get (ScopeVar.get_info var_within_origin_scope) )
:: List.map
(fun rule ->
( Some "Incriminated subscope variable definition:",
Mark.get (RuleName.get_info rule) ))
(RuleName.Map.keys def))
Message.error
~extra_pos:
(( Some "Incriminated subscope:",
Mark.get (ScopeVar.get_info (Mark.remove sscope)) )
:: ( Some "Incriminated variable:",
Mark.get (ScopeVar.get_info var_within_origin_scope) )
:: List.map
(fun rule ->
( Some "Incriminated subscope variable definition:",
Mark.get (RuleName.get_info rule) ))
(RuleName.Map.keys def))
"Invalid assignment to a subscope variable that is not tagged \
as input or context."
| OnlyInput when RuleName.Map.is_empty def && not is_cond ->
(* If the subscope variable is tagged as input, then it shall be
defined. *)
Message.raise_multispanned_error
[
( Some "Incriminated subscope:",
Mark.get (ScopeVar.get_info (Mark.remove sscope)) );
Some "Incriminated variable:", Mark.get sscope;
]
Message.error
~extra_pos:
[
( Some "Incriminated subscope:",
Mark.get (ScopeVar.get_info (Mark.remove sscope)) );
Some "Incriminated variable:", Mark.get sscope;
]
"This subscope variable is a mandatory input but no definition \
was provided."
| _ -> ()
@ -251,13 +253,14 @@ let rule_to_exception_graph (scope : D.scope) = function
match Mark.remove scope_def.D.scope_def_io.io_input with
| OnlyInput when not (RuleName.Map.is_empty var_def) ->
(* If the variable is tagged as input, then it shall not be redefined. *)
Message.raise_multispanned_error
((Some "Incriminated variable:", Mark.get (ScopeVar.get_info var))
:: List.map
(fun rule ->
( Some "Incriminated variable definition:",
Mark.get (RuleName.get_info rule) ))
(RuleName.Map.keys var_def))
Message.error
~extra_pos:
((Some "Incriminated variable:", Mark.get (ScopeVar.get_info var))
:: List.map
(fun rule ->
( Some "Incriminated variable definition:",
Mark.get (RuleName.get_info rule) ))
(RuleName.Map.keys var_def))
"It is impossible to give a definition to a scope variable tagged as \
input."
| OnlyInput -> D.ScopeDef.Map.empty
@ -909,8 +912,7 @@ let translate_program
(fun id -> function
| Some e, ty -> Expr.unbox (translate_expr ctx e), ty
| None, (_, pos) ->
Message.raise_spanned_error pos "No definition found for %a"
TopdefName.format id)
Message.error ~pos "No definition found for %a" TopdefName.format id)
desugared.program_root.module_topdefs
in
let program_scopes =

12
compiler/shared_ast/expr.ml
View File

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

147
compiler/shared_ast/interpreter.ml
View File

@ -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
entry Print.uid_list infos
Message.log "%s%a %a: @{<green>%s@}" !indent_str Print.log_entry entry
Print.uid_list infos
(Message.unformat (fun ppf ->
(if Global.options.debug then Print.expr ~debug:true ()
else Print.UserFacing.expr lang)
@ -47,17 +47,17 @@ let print_log lang entry infos pos e =
| PosRecordIfTrueBool -> (
match pos <> Pos.no_pos, Mark.remove e with
| true, ELit (LBool true) ->
Message.emit_log "%s@[<v>%a@{<green>Definition applied@}:@,%a@]"
!indent_str Print.log_entry entry Pos.format_loc_text pos
Message.log "%s@[<v>%a@{<green>Definition applied@}:@,%a@]" !indent_str
Print.log_entry entry Pos.format_loc_text pos
| _ -> ())
| BeginCall ->
Message.emit_log "%s%a %a" !indent_str Print.log_entry entry
Print.uid_list infos;
Message.log "%s%a %a" !indent_str Print.log_entry entry Print.uid_list
infos;
indent_str := !indent_str ^ " "
| EndCall ->
indent_str := String.sub !indent_str 0 (String.length !indent_str - 2);
Message.emit_log "%s%a %a" !indent_str Print.log_entry entry
Print.uid_list infos
Message.log "%s%a %a" !indent_str Print.log_entry entry Print.uid_list
infos
exception CatalaException of except * Pos.t
@ -130,34 +130,36 @@ let rec evaluate_operator
in
try f x y with
| Division_by_zero ->
Message.raise_multispanned_error
[
Some "The division operator:", pos;
Some "The null denominator:", Expr.pos (List.nth args 1);
]
Message.error
~extra_pos:
[
Some "The division operator:", pos;
Some "The null denominator:", Expr.pos (List.nth args 1);
]
"division by zero at runtime"
| Runtime.UncomparableDurations ->
Message.raise_multispanned_error (get_binop_args_pos args)
Message.error ~extra_pos:(get_binop_args_pos args)
"Cannot compare together durations that cannot be converted to a \
precise number of days"
in
let err () =
Message.raise_multispanned_error
([
( Some
(Format.asprintf "Operator (value %a):"
(Print.operator ~debug:true)
op),
pos );
]
@ List.mapi
(fun i arg ->
( Some
(Format.asprintf "Argument n°%d, value %a" (i + 1)
(Print.UserFacing.expr lang)
arg),
Expr.pos arg ))
args)
Message.error
~extra_pos:
([
( Some
(Format.asprintf "Operator (value %a):"
(Print.operator ~debug:true)
op),
pos );
]
@ List.mapi
(fun i arg ->
( Some
(Format.asprintf "Argument n°%d, value %a" (i + 1)
(Print.UserFacing.expr lang)
arg),
Expr.pos arg ))
args)
"Operator %a applied to the wrong arguments\n\
(should not happen if the term was well-typed)%a"
(Print.operator ~debug:true)
@ -234,8 +236,8 @@ let rec evaluate_operator
with
| ELit (LBool b), _ -> b
| _ ->
Message.raise_spanned_error
(Expr.pos (List.nth args 0))
Message.error
~pos:(Expr.pos (List.nth args 0))
"This predicate evaluated to something else than a boolean \
(should not happen if the term was well-typed)")
es)
@ -391,7 +393,7 @@ let rec evaluate_operator
(evaluate_expr (Expr.unthunk_term_nobox cons (Mark.get cons)))
| ELit (LBool false) -> raise (CatalaException (EmptyError, pos))
| _ ->
Message.raise_spanned_error pos
Message.error ~pos
"Default justification has not been reduced to a boolean at \
evaluation (should not happen if the term was well-typed@\n\
%a@."
@ -602,7 +604,7 @@ and val_to_runtime :
curry [] targs
| TDefault ty, _ -> val_to_runtime eval_expr ctx ty v
| _ ->
Message.raise_internal_error
Message.error ~internal:true
"Could not convert value of type %a to runtime: %a" (Print.typ ctx) ty
Expr.format v
@ -617,7 +619,7 @@ let rec evaluate_expr :
let pos = Expr.mark_pos m in
match Mark.remove e with
| EVar _ ->
Message.raise_spanned_error pos
Message.error ~pos
"free variable found at evaluation (should not happen if term was \
well-typed)"
| EExternal { name } ->
@ -637,7 +639,7 @@ let rec evaluate_expr :
(TStruct scope_info.out_struct_name, pos) ),
pos )
with TopdefName.Map.Not_found _ | ScopeName.Map.Not_found _ ->
Message.raise_spanned_error pos "Reference to %a could not be resolved"
Message.error ~pos "Reference to %a could not be resolved"
Print.external_ref name
in
let runtime_path =
@ -659,8 +661,7 @@ let rec evaluate_expr :
evaluate_expr ctx lang
(Bindlib.msubst binder (Array.of_list (List.map Mark.remove args)))
else
Message.raise_spanned_error pos
"wrong function call, expected %d arguments, got %d"
Message.error ~pos "wrong function call, expected %d arguments, got %d"
(Bindlib.mbinder_arity binder)
(List.length args)
| ECustom { obj; targs; tret } ->
@ -674,7 +675,7 @@ let rec evaluate_expr :
|> fun o ->
runtime_to_val (fun ctx -> evaluate_expr ctx lang) ctx m tret o
| _ ->
Message.raise_spanned_error pos
Message.error ~pos
"function has not been reduced to a lambda at evaluation (should not \
happen if the term was well-typed")
| EAppOp { op; args; _ } ->
@ -697,19 +698,19 @@ let rec evaluate_expr :
match Mark.remove e with
| EStruct { fields = es; name } -> (
if not (StructName.equal s name) then
Message.raise_multispanned_error
[None, pos; None, Expr.pos e]
Message.error
~extra_pos:[None, pos; None, Expr.pos e]
"Error during struct access: not the same structs (should not happen \
if the term was well-typed)";
match StructField.Map.find_opt field es with
| Some e' -> e'
| None ->
Message.raise_spanned_error (Expr.pos e)
Message.error ~pos:(Expr.pos e)
"Invalid field access %a in struct %a (should not happen if the term \
was well-typed)"
StructField.format field StructName.format s)
| _ ->
Message.raise_spanned_error (Expr.pos e)
Message.error ~pos:(Expr.pos e)
"The expression %a should be a struct %a but is not (should not happen \
if the term was well-typed)"
(Print.UserFacing.expr lang)
@ -719,7 +720,7 @@ let rec evaluate_expr :
match evaluate_expr ctx lang e1 with
| ETuple es, _ when List.length es = size -> List.nth es index
| e ->
Message.raise_spanned_error (Expr.pos e)
Message.error ~pos:(Expr.pos e)
"The expression %a was expected to be a tuple of size %d (should not \
happen if the term was well-typed)"
(Print.UserFacing.expr lang)
@ -732,15 +733,15 @@ let rec evaluate_expr :
match Mark.remove e with
| EInj { e = e1; cons; name = name' } ->
if not (EnumName.equal name name') then
Message.raise_multispanned_error
[None, Expr.pos e; None, Expr.pos e1]
Message.error
~extra_pos:[None, Expr.pos e; None, Expr.pos e1]
"Error during match: two different enums found (should not happen if \
the term was well-typed)";
let es_n =
match EnumConstructor.Map.find_opt cons cases with
| Some es_n -> es_n
| None ->
Message.raise_spanned_error (Expr.pos e)
Message.error ~pos:(Expr.pos e)
"sum type index error (should not happen if the term was \
well-typed)"
in
@ -750,7 +751,7 @@ let rec evaluate_expr :
let new_e = Mark.add m (EApp { f = es_n; args = [e1]; tys = [ty] }) in
evaluate_expr ctx lang new_e
| _ ->
Message.raise_spanned_error (Expr.pos e)
Message.error ~pos:(Expr.pos e)
"Expected a term having a sum type as an argument to a match (should \
not happen if the term was well-typed")
| EIfThenElse { cond; etrue; efalse } -> (
@ -759,7 +760,7 @@ let rec evaluate_expr :
| ELit (LBool true) -> evaluate_expr ctx lang etrue
| ELit (LBool false) -> evaluate_expr ctx lang efalse
| _ ->
Message.raise_spanned_error (Expr.pos cond)
Message.error ~pos:(Expr.pos cond)
"Expected a boolean literal for the result of this condition (should \
not happen if the term was well-typed)")
| EArray es ->
@ -770,18 +771,18 @@ let rec evaluate_expr :
match Mark.remove e with
| ELit (LBool true) -> Mark.add m (ELit LUnit)
| ELit (LBool false) ->
Message.raise_spanned_error (Expr.pos e') "Assertion failed:@\n%a"
Message.error ~pos:(Expr.pos e') "Assertion failed:@\n%a"
(Print.UserFacing.expr lang)
(partially_evaluate_expr_for_assertion_failure_message ctx lang
(Expr.skip_wrappers e'))
| _ ->
Message.raise_spanned_error (Expr.pos e')
Message.error ~pos:(Expr.pos e')
"Expected a boolean literal for the result of this assertion (should \
not happen if the term was well-typed)")
| EErrorOnEmpty e' -> (
match evaluate_expr ctx lang e' with
| EEmptyError, _ ->
Message.raise_spanned_error (Expr.pos e')
Message.error ~pos:(Expr.pos e')
"This variable evaluated to an empty term (no rule that defined it \
applied in this situation)"
| e -> e)
@ -795,7 +796,7 @@ let rec evaluate_expr :
| ELit (LBool true) -> evaluate_expr ctx lang cons
| ELit (LBool false) -> Mark.copy e EEmptyError
| _ ->
Message.raise_spanned_error (Expr.pos e)
Message.error ~pos:(Expr.pos e)
"Default justification has not been reduced to a boolean at \
evaluation (should not happen if the term was well-typed")
| 1 -> List.find (fun sub -> not (is_empty_error sub)) excepts
@ -913,21 +914,22 @@ let delcustom e =
let interp_failure_message ~pos = function
| NoValueProvided ->
Message.raise_spanned_error pos
Message.error ~pos
"This variable evaluated to an empty term (no rule that defined it \
applied in this situation)"
| ConflictError cpos ->
Message.raise_multispanned_error
(List.map
(fun pos -> Some "This consequence has a valid justification:", pos)
cpos)
Message.error
~extra_pos:
(List.map
(fun pos -> Some "This consequence has a valid justification:", pos)
cpos)
"There is a conflict between multiple valid consequences for assigning \
the same variable."
| Crash ->
(* This constructor seems to be never used *)
Message.raise_spanned_error pos "Internal error, the interpreter crashed"
Message.error ~pos "Internal error, the interpreter crashed"
| EmptyError ->
Message.raise_spanned_error pos
Message.error ~pos
"Internal error, a variable without valid definition escaped"
let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
@ -980,7 +982,7 @@ let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
]
mark_e
| _ ->
Message.raise_spanned_error (Mark.get ty)
Message.error ~pos:(Mark.get ty)
"This scope needs an input argument of type %a to be executed. \
But the Catala built-in interpreter does not have a way to \
retrieve input values from the command line, so it cannot \
@ -1006,12 +1008,12 @@ let interpret_program_lcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
| exception CatalaException (except, pos) ->
interp_failure_message ~pos except
| _ ->
Message.raise_spanned_error (Expr.pos e)
Message.error ~pos:(Expr.pos e)
"The interpretation of a program should always yield a struct \
corresponding to the scope variables"
end
| _ ->
Message.raise_spanned_error (Expr.pos e)
Message.error ~pos:(Expr.pos e)
"The interpreter can only interpret terms starting with functions having \
thunked arguments"
@ -1038,7 +1040,7 @@ let interpret_program_dcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
(Bindlib.box EEmptyError, Expr.with_ty mark_e ty_out)
ty_in (Expr.mark_pos mark_e)
| _ ->
Message.raise_spanned_error (Mark.get ty)
Message.error ~pos:(Mark.get ty)
"This scope needs input arguments to be executed. But the Catala \
built-in interpreter does not have a way to retrieve input \
values from the command line, so it cannot execute this scope. \
@ -1063,12 +1065,12 @@ let interpret_program_dcalc p s : (Uid.MarkedString.info * ('a, 'm) gexpr) list
| exception CatalaException (except, pos) ->
interp_failure_message ~pos except
| _ ->
Message.raise_spanned_error (Expr.pos e)
Message.error ~pos:(Expr.pos e)
"The interpretation of a program should always yield a struct \
corresponding to the scope variables"
end
| _ ->
Message.raise_spanned_error (Expr.pos e)
Message.error ~pos:(Expr.pos e)
"The interpreter can only interpret terms starting with functions having \
thunked arguments"
@ -1088,23 +1090,22 @@ let load_runtime_modules prg =
^ ".cmo")
in
if not (Sys.file_exists obj_file) then
Message.raise_spanned_error
~span_msg:(fun ppf -> Format.pp_print_string ppf "Module defined here")
(Mark.get (ModuleName.get_info m))
Message.error
~pos_msg:(fun ppf -> Format.pp_print_string ppf "Module defined here")
~pos:(Mark.get (ModuleName.get_info m))
"Compiled OCaml object %a not found. Make sure it has been suitably \
compiled."
File.format obj_file
else
try Dynlink.loadfile obj_file
with Dynlink.Error dl_err ->
Message.raise_error
"Error loading compiled module from %a:@;<1 2>@[<hov>%a@]" File.format
obj_file Format.pp_print_text
Message.error "Error loading compiled module from %a:@;<1 2>@[<hov>%a@]"
File.format obj_file Format.pp_print_text
(Dynlink.error_message dl_err)
in
let modules_list_topo = Program.modules_to_list prg.decl_ctx.ctx_modules in
if modules_list_topo <> [] then
Message.emit_debug "Loading shared modules... %a"
Message.debug "Loading shared modules... %a"
(Format.pp_print_list ~pp_sep:Format.pp_print_space ModuleName.format)
modules_list_topo;
List.iter load modules_list_topo

19
compiler/shared_ast/operator.ml
View File

@ -548,15 +548,16 @@ let resolve_overload ctx (op : overloaded t Mark.pos) (operands : typ list) :
in
resolve_overload_aux (Mark.remove op) operands
with Not_found ->
Message.raise_multispanned_error
((None, Mark.get op)
:: List.map
(fun ty ->
( Some
(Format.asprintf "Type %a coming from expression:"
(Print.typ ctx) ty),
Mark.get ty ))
operands)
Message.error
~extra_pos:
((None, Mark.get op)
:: List.map
(fun ty ->
( Some
(Format.asprintf "Type %a coming from expression:"
(Print.typ ctx) ty),
Mark.get ty ))
operands)
"I don't know how to apply operator %a on types %a"
(Print.operator ~debug:true)
(Mark.remove op)

100
compiler/shared_ast/typing.ml
View File

@ -71,7 +71,7 @@ let rec typ_to_ast ~(flags : flags) (ty : unionfind_typ) : A.typ =
(* No polymorphism in Catala: type inference should return full types
without wildcards, and this function is used to recover the types after
typing. *)
Message.raise_spanned_error pos
Message.error ~pos
"Internal error: typing at this point could not be resolved"
else A.TAny, pos
| TClosureEnv -> TClosureEnv, pos
@ -186,8 +186,8 @@ let rec unify
(t1 : unionfind_typ)
(t2 : unionfind_typ) : unit =
let unify = unify ctx in
(* Message.emit_debug "Unifying %a and %a" (format_typ ctx) t1 (format_typ
ctx) t2; *)
(* Message.debug "Unifying %a and %a" (format_typ ctx) t1 (format_typ ctx)
t2; *)
let t1_repr = UnionFind.get (UnionFind.find t1) in
let t2_repr = UnionFind.get (UnionFind.find t2) in
let raise_type_error () = raise (Type_error (A.AnyExpr e, t1, t2)) in
@ -263,8 +263,8 @@ let handle_type_error ctx (A.AnyExpr e) t1 t2 =
t2_pos );
]
in
Message.raise_multispanned_error_full
(List.map (fun (a, b) -> Some a, b) pos_msgs)
Message.error
~fmt_pos:(List.map (fun (a, b) -> Some a, b) pos_msgs)
"@[<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"
(Print.expr ()) e
Message.error ~pos:pos_e "Reference to %a not found" (Print.expr ()) e
in
Expr.elocation loc (mark_with_tau_and_unify (ast_to_typ ty))
| A.EStruct { name; fields } ->
@ -539,7 +538,7 @@ and typecheck_expr_top_down :
(A.StructField.Map.bindings extra_fields)
in
if errs <> [] then
Message.raise_multispanned_error errs
Message.error ~extra_pos:errs
"Mismatching field definitions for structure %a" A.StructName.format
name
in
@ -565,15 +564,15 @@ and typecheck_expr_top_down :
Printf.ksprintf failwith
"Disambiguation failed before reaching field %s" field
| _ ->
Message.raise_spanned_error (Expr.pos e)
Message.error ~pos:(Expr.pos e)
"This is not a structure, cannot access field %s (found type: %a)"
field (format_typ ctx) (ty e_struct')
in
let str =
try A.StructName.Map.find name env.structs
with A.StructName.Map.Not_found _ ->
Message.raise_spanned_error pos_e "No structure %a found"
A.StructName.format name
Message.error ~pos:pos_e "No structure %a found" A.StructName.format
name
in
let field =
let candidate_structs =
@ -587,30 +586,32 @@ and typecheck_expr_top_down :
ctx.ctx_scopes
with
| Some (scope_out, _) ->
Message.raise_multispanned_error_full
[
( Some
(fun ppf ->
Format.fprintf ppf
"@{<yellow>%s@} is used here as an output" field),
Expr.mark_pos context_mark );
( Some
(fun ppf ->
Format.fprintf ppf "Scope %a is declared here"
A.ScopeName.format scope_out),
Mark.get (A.StructName.get_info name) );
]
Message.error
~fmt_pos:
[
( Some
(fun ppf ->
Format.fprintf ppf
"@{<yellow>%s@} is used here as an output" field),
Expr.mark_pos context_mark );
( Some
(fun ppf ->
Format.fprintf ppf "Scope %a is declared here"
A.ScopeName.format scope_out),
Mark.get (A.StructName.get_info name) );
]
"Variable @{<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
[
None, Expr.mark_pos context_mark;
( Some "Structure definition",
Mark.get (A.StructName.get_info name) );
]
Message.error
~extra_pos:
[
None, Expr.mark_pos context_mark;
( Some "Structure definition",
Mark.get (A.StructName.get_info name) );
]
"Field @{<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
(Expr.mark_pos context_mark)
Message.error
~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"
A.StructName.format name
Message.error ~pos:pos_e "No structure %a found" A.StructName.format
name
in
try A.StructField.Map.find field str
with A.StructField.Map.Not_found _ ->
Message.raise_multispanned_error
[
None, pos_e;
( Some "Structure %a declared here",
Mark.get (A.StructName.get_info name) );
]
Message.error
~extra_pos:
[
None, pos_e;
( Some "Structure %a declared here",
Mark.get (A.StructName.get_info name) );
]
"Structure %a doesn't define a field %a" A.StructName.format name
A.StructField.format field
in
@ -747,14 +749,14 @@ and typecheck_expr_top_down :
match Env.get env v with
| Some t -> t
| None ->
Message.raise_spanned_error pos_e
"Variable %s not found in the current context" (Bindlib.name_of v)
Message.error ~pos:pos_e "Variable %s not found in the current context"
(Bindlib.name_of v)
in
Expr.evar (Var.translate v) (mark_with_tau_and_unify tau')
| A.EExternal { name } ->
let ty =
let not_found pr x =
Message.raise_spanned_error pos_e
Message.error ~pos:pos_e
"Could not resolve the reference to %a.@ Make sure the corresponding \
module was properly loaded?"
pr x
@ -783,8 +785,8 @@ and typecheck_expr_top_down :
Expr.etuple es' mark
| A.ETupleAccess { e = e1; index; size } ->
if index >= size then
Message.raise_spanned_error (Expr.pos e)
"Tuple access out of bounds (%d/%d)" index size;
Message.error ~pos:(Expr.pos e) "Tuple access out of bounds (%d/%d)" index
size;
let tuple_ty =
TTuple
(List.init size (fun n ->
@ -794,7 +796,7 @@ and typecheck_expr_top_down :
Expr.etupleaccess ~e:e1' ~index ~size context_mark
| A.EAbs { binder; tys = t_args } ->
if Bindlib.mbinder_arity binder <> List.length t_args then
Message.raise_spanned_error (Expr.pos e)
Message.error ~pos:(Expr.pos e)
"function has %d variables but was supplied %d types\n%a"
(Bindlib.mbinder_arity binder)
(List.length t_args) Expr.format e
@ -833,7 +835,7 @@ and typecheck_expr_top_down :
match UnionFind.get t with TTuple tys, _ -> tys | _ -> t_args)
| _ ->
if List.length t_args <> List.length args' then
Message.raise_spanned_error (Expr.pos e)
Message.error ~pos:(Expr.pos e)
(match e1 with
| EAbs _, _ -> "This binds %d variables, but %d were provided."
| _ -> "This function application has %d arguments, but expects %d.")

2
compiler/surface/lexer.cppo.ml
View File

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

2
compiler/surface/lexer_common.ml
View File

@ -60,7 +60,7 @@ let update_acc (lexbuf : lexbuf) : unit =
(** Error-generating helper *)
let raise_lexer_error (loc : Pos.t) (token : string) =
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

12
compiler/surface/parser.mly
View File

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

42
compiler/surface/parser_driver.ml
View File

@ -72,16 +72,17 @@ let raise_parser_error
(last_good_loc : Pos.t option)
(token : string)
(msg : Format.formatter -> unit) : 'a =
Message.raise_multispanned_error_full ?suggestion
((Some (fun ppf -> Format.pp_print_string ppf "Error token:"), error_loc)
::
(match last_good_loc with
| None -> []
| Some last_good_loc ->
[
( Some (fun ppf -> Format.pp_print_string ppf "Last good token:"),
last_good_loc );
]))
Message.error ?suggestion
~fmt_pos:
((Some (fun ppf -> Format.pp_print_string ppf "Error token:"), error_loc)
::
(match last_good_loc with
| None -> []
| Some last_good_loc ->
[
( Some (fun ppf -> Format.pp_print_string ppf "Last good token:"),
last_good_loc );
]))
"@[<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
[None, Mark.get id1; None, Mark.get id2]
Message.error
~extra_pos:[None, Mark.get id1; None, Mark.get id2]
"Multiple definitions of the module name"
in
match command with
@ -295,11 +296,12 @@ and expand_includes (source_file : string) (commands : Ast.law_structure list) :
includ_program.Ast.program_module_name
|> Option.iter
@@ fun id ->
Message.raise_multispanned_error
[
Some "File include", Mark.get inc_file;
Some "Module declaration", Mark.get id;
]
Message.error
~extra_pos:
[
Some "File include", Mark.get inc_file;
Some "Module declaration", Mark.get id;
]
"A file that declares a module cannot be used through the raw \
'@{<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

4
compiler/verification/conditions.ml
View File

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

10
compiler/verification/io.ml
View File

@ -144,9 +144,9 @@ module MakeBackendIO (B : Backend) = struct
(vc : Conditions.verification_condition * vc_encoding_result) : bool =
let vc, z3_vc = vc in
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))

3
compiler/verification/solver.ml
View File

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

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

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

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

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