mirror of
https://github.com/CatalaLang/catala.git
synced 2024-09-16 14:57:13 +03:00
Rewriting message calls to use the new intf
This commit is contained in:
parent
454667a47b
commit
98fc97a241
@ -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 =
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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))
|
||||
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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,7 +272,8 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm S.expr) : 'm Ast.expr boxed =
|
||||
( var_ctx.scope_input_name,
|
||||
thunk_scope_arg var_ctx (translate_expr ctx e) )
|
||||
| Some var_ctx, None ->
|
||||
Message.raise_multispanned_error
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
None, pos;
|
||||
( Some "Declaration of the missing input variable",
|
||||
@ -281,11 +282,12 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm S.expr) : 'm Ast.expr boxed =
|
||||
"Definition of input variable '%a' missing in this scope call"
|
||||
ScopeVar.format var_name
|
||||
| None, Some e ->
|
||||
Message.raise_multispanned_error_full
|
||||
Message.error
|
||||
~suggestion:
|
||||
(List.map
|
||||
(fun v -> Mark.remove (ScopeVar.get_info v))
|
||||
(ScopeVar.Map.keys sc_sig.scope_sig_in_fields))
|
||||
~fmt_pos:
|
||||
[
|
||||
None, Expr.pos e;
|
||||
( Some
|
||||
@ -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 )
|
||||
|
@ -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 =
|
||||
|
@ -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,12 +407,13 @@ let build_exceptions_graph
|
||||
in
|
||||
(* We check the consistency*)
|
||||
if LabelName.compare label_from label_to = 0 then
|
||||
Message.raise_spanned_error edge_pos
|
||||
Message.error ~pos:edge_pos
|
||||
"Cannot define rule as an exception to itself";
|
||||
List.iter
|
||||
(fun edge ->
|
||||
if LabelName.compare edge.label_to label_to <> 0 then
|
||||
Message.raise_multispanned_error
|
||||
Message.error
|
||||
~extra_pos:
|
||||
(( Some
|
||||
"This definition contradicts other exception \
|
||||
definitions:",
|
||||
@ -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)
|
||||
|
@ -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,11 +428,13 @@ let rec translate_expr
|
||||
Ident.Map.find_opt (Mark.remove st) x_sig.var_sig_states_idmap
|
||||
with
|
||||
| None ->
|
||||
Message.raise_multispanned_error
|
||||
Message.error
|
||||
~suggestion:(List.map StateName.to_string states)
|
||||
~extra_pos:
|
||||
[
|
||||
None, Mark.get st;
|
||||
Some "Variable defined here", Mark.get (ScopeVar.get_info uid);
|
||||
( Some "Variable defined here",
|
||||
Mark.get (ScopeVar.get_info uid) );
|
||||
]
|
||||
"Reference to unknown variable state"
|
||||
| some -> some)
|
||||
@ -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,13 +522,14 @@ let rec translate_expr
|
||||
with
|
||||
| Some (ScopeVar v) -> v
|
||||
| Some (SubScope _) | None ->
|
||||
Message.raise_multispanned_error
|
||||
Message.error
|
||||
~suggestion:(Ident.Map.keys scope_def.var_idmap)
|
||||
~extra_pos:
|
||||
[
|
||||
None, Mark.get fld_id;
|
||||
( Some
|
||||
(Format.asprintf "Scope %a declared here" ScopeName.format
|
||||
called_scope),
|
||||
(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
|
||||
@ -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,7 +972,8 @@ and disambiguate_match_and_build_expression
|
||||
(match EnumConstructor.Map.find_opt c_uid cases_d with
|
||||
| None -> ()
|
||||
| Some e_case ->
|
||||
Message.raise_multispanned_error
|
||||
Message.error
|
||||
~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);
|
||||
@ -990,7 +992,8 @@ and disambiguate_match_and_build_expression
|
||||
| S.WildCard match_case_expr -> (
|
||||
let nb_cases = List.length cases in
|
||||
let raise_wildcard_not_last_case_err () =
|
||||
Message.raise_multispanned_error
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
Some "Not ending wildcard:", case_pos;
|
||||
( Some "Next reachable case:",
|
||||
@ -1001,7 +1004,7 @@ and disambiguate_match_and_build_expression
|
||||
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,12 +1081,13 @@ 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
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
Some "Argument declared here:", apos;
|
||||
Some "Mismatching definition:", pos_def;
|
||||
@ -1092,9 +1096,11 @@ let rec arglist_eq_check pos_decl pos_def pdecl pdefs =
|
||||
| decl :: pdecl, def :: pdefs when Uid.MarkedString.equal decl def ->
|
||||
arglist_eq_check pos_decl pos_def pdecl pdefs
|
||||
| (decl_arg, decl_apos) :: _, (def_arg, def_apos) :: _ ->
|
||||
Message.raise_multispanned_error
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
Some "Argument declared here:", decl_apos; Some "Defined here:", def_apos;
|
||||
Some "Argument declared here:", decl_apos;
|
||||
Some "Defined here:", def_apos;
|
||||
]
|
||||
"Function argument name mismatch between declaration ('%a') and \
|
||||
definition ('%a')"
|
||||
@ -1111,17 +1117,20 @@ let process_rule_parameters
|
||||
match declared_params, def.S.definition_parameter with
|
||||
| None, None -> Ident.Map.empty, None
|
||||
| None, Some (_, pos) ->
|
||||
Message.raise_multispanned_error
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
Some "Declared here without arguments", decl_pos;
|
||||
Some "Unexpected arguments appearing here", pos;
|
||||
]
|
||||
"Extra arguments in this definition of %a" Ast.ScopeDef.format decl_name
|
||||
| Some (_, pos), None ->
|
||||
Message.raise_multispanned_error
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
Some "Arguments declared here", pos;
|
||||
Some "Definition missing the arguments", Mark.get def.S.definition_name;
|
||||
( Some "Definition missing the arguments",
|
||||
Mark.get def.S.definition_name );
|
||||
]
|
||||
"This definition for %a is missing the arguments" Ast.ScopeDef.format
|
||||
decl_name
|
||||
@ -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,10 +1399,11 @@ let check_unlabeled_exception
|
||||
| S.UnlabeledException -> (
|
||||
match scope_def_ctxt.default_exception_rulename with
|
||||
| None ->
|
||||
Message.raise_spanned_error (Mark.get item)
|
||||
Message.error ~pos:(Mark.get item)
|
||||
"This exception does not have a corresponding definition"
|
||||
| Some (Ambiguous pos) ->
|
||||
Message.raise_multispanned_error
|
||||
Message.error
|
||||
~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 \
|
||||
@ -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,7 +1482,8 @@ let process_topdef
|
||||
| None, eopt -> Some (eopt, typ)
|
||||
| Some (eopt0, ty0), eopt -> (
|
||||
let err msg =
|
||||
Message.raise_multispanned_error
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
None, Mark.get (TopdefName.get_info id);
|
||||
None, Mark.get def.S.topdef_name;
|
||||
|
@ -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
|
||||
|
@ -99,12 +99,12 @@ type context = {
|
||||
(** Temporary function raising an error message saying that a feature is not
|
||||
supported yet *)
|
||||
let raise_unsupported_feature (msg : string) (pos : Pos.t) =
|
||||
Message.raise_spanned_error pos "Unsupported feature: %s" msg
|
||||
Message.error ~pos "Unsupported feature: %s" msg
|
||||
|
||||
(** Function to call whenever an identifier used somewhere has not been declared
|
||||
in the program previously *)
|
||||
let raise_unknown_identifier (msg : string) (ident : Ident.t Mark.pos) =
|
||||
Message.raise_spanned_error (Mark.get ident)
|
||||
Message.error ~pos:(Mark.get ident)
|
||||
"@{<yellow>\"%s\"@}: unknown identifier %s" (Mark.remove ident) msg
|
||||
|
||||
(** Gets the type associated to an uid *)
|
||||
@ -181,62 +181,63 @@ let get_enum ctxt id =
|
||||
match Ident.Map.find (Mark.remove id) ctxt.local.typedefs with
|
||||
| TEnum id -> id
|
||||
| TStruct sid ->
|
||||
Message.raise_multispanned_error
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
None, Mark.get id;
|
||||
Some "Structure defined at", Mark.get (StructName.get_info sid);
|
||||
]
|
||||
"Expecting an enum, but found a structure"
|
||||
| TScope (sid, _) ->
|
||||
Message.raise_multispanned_error
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
None, Mark.get id;
|
||||
Some "Scope defined at", Mark.get (ScopeName.get_info sid);
|
||||
]
|
||||
"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
|
||||
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
|
||||
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
|
||||
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,7 +389,8 @@ let process_data_decl
|
||||
(fun state_id ((states_idmap : StateName.t Ident.Map.t), states_list) ->
|
||||
let state_id_name = Mark.remove state_id in
|
||||
if Ident.Map.mem state_id_name states_idmap then
|
||||
Message.raise_multispanned_error_full
|
||||
Message.error
|
||||
~fmt_pos:
|
||||
[
|
||||
( Some
|
||||
(fun ppf ->
|
||||
@ -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,7 +647,8 @@ let typedef_info = function
|
||||
let process_name_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
|
||||
context =
|
||||
let raise_already_defined_error (use : Uid.MarkedString.info) name pos msg =
|
||||
Message.raise_multispanned_error_full
|
||||
Message.error
|
||||
~fmt_pos:
|
||||
[
|
||||
( Some (fun ppf -> Format.pp_print_string ppf "First definition:"),
|
||||
Mark.get use );
|
||||
@ -779,19 +782,23 @@ let get_def_key
|
||||
Some
|
||||
(Ident.Map.find (Mark.remove state) var_sig.var_sig_states_idmap)
|
||||
with Ident.Map.Not_found _ ->
|
||||
Message.raise_multispanned_error
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
None, Mark.get state;
|
||||
Some "Variable declaration:", Mark.get (ScopeVar.get_info x_uid);
|
||||
( Some "Variable declaration:",
|
||||
Mark.get (ScopeVar.get_info x_uid) );
|
||||
]
|
||||
"This identifier is not a state declared for variable %a."
|
||||
ScopeVar.format x_uid)
|
||||
| None ->
|
||||
if not (Ident.Map.is_empty var_sig.var_sig_states_idmap) then
|
||||
Message.raise_multispanned_error
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
None, Mark.get x;
|
||||
Some "Variable declaration:", Mark.get (ScopeVar.get_info x_uid);
|
||||
( Some "Variable declaration:",
|
||||
Mark.get (ScopeVar.get_info x_uid) );
|
||||
]
|
||||
"This definition does not indicate which state has to be \
|
||||
considered for variable %a."
|
||||
@ -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)
|
||||
|
@ -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))
|
||||
|
@ -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,7 +81,8 @@ let load_module_interfaces
|
||||
(Mark.remove use.Surface.Ast.mod_use_alias)
|
||||
modname use_map )
|
||||
| Some None ->
|
||||
Message.raise_multispanned_error
|
||||
Message.error
|
||||
~extra_pos:
|
||||
(err_req_pos (Mark.get use.Surface.Ast.mod_use_name :: req_chain))
|
||||
"Circular module dependency"
|
||||
| None ->
|
||||
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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 ->
|
||||
|
@ -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
|
||||
|
@ -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,7 +113,8 @@ let check_exceeding_lines
|
||||
Uutf.String.fold_utf_8 (fun (acc : int) _ _ -> acc + 1) 0 s
|
||||
in
|
||||
if len_s > max_len then
|
||||
Message.emit_spanned_warning
|
||||
Message.warning
|
||||
~pos:
|
||||
(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)
|
||||
@ -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
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -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,7 +366,8 @@ let rec lazy_eval : decl_ctx -> Env.t -> laziness_level -> expr -> expr * Env.t
|
||||
log "@[<hov 5>EVAL %a@]" Expr.format e;
|
||||
lazy_eval ctx env llevel e
|
||||
| _ :: _ :: _ ->
|
||||
Message.raise_multispanned_error
|
||||
Message.error
|
||||
~extra_pos:
|
||||
((None, Expr.mark_pos m)
|
||||
:: List.map (fun (e, _) -> None, Expr.pos e) excs)
|
||||
"Conflicting exceptions")
|
||||
@ -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))
|
||||
|
@ -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);
|
||||
|
@ -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,7 +197,8 @@ let rec lazy_eval :
|
||||
log "@[<hov 5>EVAL %a@]" Expr.format e;
|
||||
lazy_eval ctx env llevel e
|
||||
| _ :: _ :: _ ->
|
||||
Message.raise_multispanned_error
|
||||
Message.error
|
||||
~extra_pos:
|
||||
((None, Expr.mark_pos m)
|
||||
:: List.map (fun (e, _) -> None, Expr.pos e) excs)
|
||||
"Conflicting exceptions")
|
||||
|
@ -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 =
|
||||
|
@ -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 ->
|
||||
|
@ -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@];"
|
||||
|
@ -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
|
||||
|
@ -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 [])
|
||||
|
@ -214,7 +214,8 @@ let rule_to_exception_graph (scope : D.scope) = function
|
||||
let () =
|
||||
match Mark.remove scope_def.D.scope_def_io.io_input with
|
||||
| NoInput ->
|
||||
Message.raise_multispanned_error
|
||||
Message.error
|
||||
~extra_pos:
|
||||
(( Some "Incriminated subscope:",
|
||||
Mark.get (ScopeVar.get_info (Mark.remove sscope)) )
|
||||
:: ( Some "Incriminated variable:",
|
||||
@ -229,7 +230,8 @@ let rule_to_exception_graph (scope : D.scope) = function
|
||||
| OnlyInput when RuleName.Map.is_empty def && not is_cond ->
|
||||
(* If the subscope variable is tagged as input, then it shall be
|
||||
defined. *)
|
||||
Message.raise_multispanned_error
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
( Some "Incriminated subscope:",
|
||||
Mark.get (ScopeVar.get_info (Mark.remove sscope)) );
|
||||
@ -251,7 +253,8 @@ let rule_to_exception_graph (scope : D.scope) = function
|
||||
match Mark.remove scope_def.D.scope_def_io.io_input with
|
||||
| OnlyInput when not (RuleName.Map.is_empty var_def) ->
|
||||
(* If the variable is tagged as input, then it shall not be redefined. *)
|
||||
Message.raise_multispanned_error
|
||||
Message.error
|
||||
~extra_pos:
|
||||
((Some "Incriminated variable:", Mark.get (ScopeVar.get_info var))
|
||||
:: List.map
|
||||
(fun rule ->
|
||||
@ -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 =
|
||||
|
@ -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)
|
||||
|
@ -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,19 +130,21 @@ let rec evaluate_operator
|
||||
in
|
||||
try f x y with
|
||||
| Division_by_zero ->
|
||||
Message.raise_multispanned_error
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
Some "The division operator:", pos;
|
||||
Some "The null denominator:", Expr.pos (List.nth args 1);
|
||||
]
|
||||
"division by zero at runtime"
|
||||
| Runtime.UncomparableDurations ->
|
||||
Message.raise_multispanned_error (get_binop_args_pos args)
|
||||
Message.error ~extra_pos:(get_binop_args_pos args)
|
||||
"Cannot compare together durations that cannot be converted to a \
|
||||
precise number of days"
|
||||
in
|
||||
let err () =
|
||||
Message.raise_multispanned_error
|
||||
Message.error
|
||||
~extra_pos:
|
||||
([
|
||||
( Some
|
||||
(Format.asprintf "Operator (value %a):"
|
||||
@ -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,11 +914,12 @@ let delcustom e =
|
||||
|
||||
let interp_failure_message ~pos = function
|
||||
| NoValueProvided ->
|
||||
Message.raise_spanned_error pos
|
||||
Message.error ~pos
|
||||
"This variable evaluated to an empty term (no rule that defined it \
|
||||
applied in this situation)"
|
||||
| ConflictError cpos ->
|
||||
Message.raise_multispanned_error
|
||||
Message.error
|
||||
~extra_pos:
|
||||
(List.map
|
||||
(fun pos -> Some "This consequence has a valid justification:", pos)
|
||||
cpos)
|
||||
@ -925,9 +927,9 @@ let interp_failure_message ~pos = function
|
||||
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
|
||||
|
@ -548,7 +548,8 @@ let resolve_overload ctx (op : overloaded t Mark.pos) (operands : typ list) :
|
||||
in
|
||||
resolve_overload_aux (Mark.remove op) operands
|
||||
with Not_found ->
|
||||
Message.raise_multispanned_error
|
||||
Message.error
|
||||
~extra_pos:
|
||||
((None, Mark.get op)
|
||||
:: List.map
|
||||
(fun ty ->
|
||||
|
@ -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,7 +586,8 @@ and typecheck_expr_top_down :
|
||||
ctx.ctx_scopes
|
||||
with
|
||||
| Some (scope_out, _) ->
|
||||
Message.raise_multispanned_error_full
|
||||
Message.error
|
||||
~fmt_pos:
|
||||
[
|
||||
( Some
|
||||
(fun ppf ->
|
||||
@ -605,7 +605,8 @@ and typecheck_expr_top_down :
|
||||
~suggestion:
|
||||
(List.map A.StructField.to_string (A.StructField.Map.keys str))
|
||||
| None ->
|
||||
Message.raise_multispanned_error
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
None, Expr.mark_pos context_mark;
|
||||
( Some "Structure definition",
|
||||
@ -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,12 +639,13 @@ 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
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
None, pos_e;
|
||||
( Some "Structure %a declared here",
|
||||
@ -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.")
|
||||
|
@ -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))
|
||||
|
@ -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
|
||||
|
@ -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
|
||||
|
@ -72,7 +72,8 @@ let raise_parser_error
|
||||
(last_good_loc : Pos.t option)
|
||||
(token : string)
|
||||
(msg : Format.formatter -> unit) : 'a =
|
||||
Message.raise_multispanned_error_full ?suggestion
|
||||
Message.error ?suggestion
|
||||
~fmt_pos:
|
||||
((Some (fun ppf -> Format.pp_print_string ppf "Error token:"), error_loc)
|
||||
::
|
||||
(match last_good_loc with
|
||||
@ -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,7 +296,8 @@ and expand_includes (source_file : string) (commands : Ast.law_structure list) :
|
||||
includ_program.Ast.program_module_name
|
||||
|> Option.iter
|
||||
@@ fun id ->
|
||||
Message.raise_multispanned_error
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
Some "File include", Mark.get inc_file;
|
||||
Some "Module declaration", Mark.get id;
|
||||
@ -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
|
||||
|
@ -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"
|
||||
|
@ -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))
|
||||
|
@ -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."
|
||||
|
@ -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
|
||||
|
@ -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 =
|
||||
|
Loading…
Reference in New Issue
Block a user