mirror of
https://github.com/CatalaLang/catala.git
synced 2024-11-08 07:51:43 +03:00
Message: further simplification
This commit is contained in:
parent
9524e5d3f8
commit
def10e7f98
@ -232,8 +232,8 @@ type ('a, 'b) emitter =
|
||||
?internal:bool ->
|
||||
?pos:Pos.t ->
|
||||
?pos_msg:Content.message ->
|
||||
?extra_pos:(string option * Pos.t) list ->
|
||||
?fmt_pos:(Content.message option * Pos.t) list ->
|
||||
?extra_pos:(string * Pos.t) list ->
|
||||
?fmt_pos:(Content.message * Pos.t) list ->
|
||||
?suggestion:string list ->
|
||||
('a, Format.formatter, unit, 'b) format4 ->
|
||||
'a
|
||||
@ -264,7 +264,8 @@ let make
|
||||
List.fold_left
|
||||
(fun t (message, p) ->
|
||||
let message =
|
||||
Option.map (fun m ppf -> Format.pp_print_text ppf m) message
|
||||
if message = "" then None
|
||||
else Some (fun ppf -> Format.pp_print_text ppf message)
|
||||
in
|
||||
add_position t ?message p)
|
||||
t pl
|
||||
@ -273,7 +274,11 @@ let make
|
||||
let t =
|
||||
match fmt_pos with
|
||||
| Some pl ->
|
||||
List.fold_left (fun t (message, p) -> add_position t ?message p) t pl
|
||||
List.fold_left
|
||||
(fun t (message, p) ->
|
||||
let message = if message == ignore then None else Some message in
|
||||
add_position t ?message p)
|
||||
t pl
|
||||
| None -> t
|
||||
in
|
||||
let t = match suggestion with Some s -> add_suggestion t s | None -> t in
|
||||
|
@ -86,8 +86,8 @@ type ('a, 'b) emitter =
|
||||
?internal:bool ->
|
||||
?pos:Pos.t ->
|
||||
?pos_msg:Content.message ->
|
||||
?extra_pos:(string option * Pos.t) list ->
|
||||
?fmt_pos:(Content.message option * Pos.t) list ->
|
||||
?extra_pos:(string * Pos.t) list ->
|
||||
?fmt_pos:(Content.message * Pos.t) list ->
|
||||
?suggestion:string list ->
|
||||
('a, Format.formatter, unit, 'b) format4 ->
|
||||
'a
|
||||
|
@ -275,8 +275,8 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm S.expr) : 'm Ast.expr boxed =
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
None, pos;
|
||||
( Some "Declaration of the missing input variable",
|
||||
"", pos;
|
||||
( "Declaration of the missing input variable",
|
||||
Mark.get (StructField.get_info var_ctx.scope_input_name) );
|
||||
]
|
||||
"Definition of input variable '%a' missing in this scope call"
|
||||
@ -289,11 +289,10 @@ let rec translate_expr (ctx : 'm ctx) (e : 'm S.expr) : 'm Ast.expr boxed =
|
||||
(ScopeVar.Map.keys sc_sig.scope_sig_in_fields))
|
||||
~fmt_pos:
|
||||
[
|
||||
None, Expr.pos e;
|
||||
( Some
|
||||
(fun ppf ->
|
||||
Format.fprintf ppf "Declaration of scope %a"
|
||||
ScopeName.format scope),
|
||||
ignore, Expr.pos e;
|
||||
( (fun ppf ->
|
||||
Format.fprintf ppf "Declaration of scope %a"
|
||||
ScopeName.format scope),
|
||||
Mark.get (ScopeName.get_info scope) );
|
||||
]
|
||||
"Unknown input variable '%a' in scope call of '%a'"
|
||||
|
@ -129,7 +129,7 @@ let check_for_cycle (scope : Ast.scope) (g : ScopeDependencies.t) : unit =
|
||||
(List.find (fun succ -> VSet.mem succ scc) succ)
|
||||
in
|
||||
let cycle = get_cycle [] VSet.empty v0 in
|
||||
let spans =
|
||||
let extra_pos =
|
||||
List.map2
|
||||
(fun v1 v2 ->
|
||||
let msg =
|
||||
@ -137,11 +137,11 @@ let check_for_cycle (scope : Ast.scope) (g : ScopeDependencies.t) : unit =
|
||||
Vertex.format v1 Vertex.format v2
|
||||
in
|
||||
let _, edge_pos, _ = ScopeDependencies.find_edge g v1 v2 in
|
||||
Some msg, edge_pos)
|
||||
msg, edge_pos)
|
||||
cycle
|
||||
(List.tl cycle @ [List.hd cycle])
|
||||
in
|
||||
Message.error ~extra_pos:spans
|
||||
Message.error ~extra_pos
|
||||
"@[<hov 2>Cyclic dependency detected between the following variables of \
|
||||
scope %a:@ @[<hv>%a@]@]"
|
||||
ScopeName.format scope.scope_uid
|
||||
@ -412,15 +412,14 @@ let build_exceptions_graph
|
||||
List.iter
|
||||
(fun edge ->
|
||||
if LabelName.compare edge.label_to label_to <> 0 then
|
||||
Message.error
|
||||
Message.error ~pos:edge_pos
|
||||
~pos_msg:(fun ppf ->
|
||||
Format.pp_print_text ppf
|
||||
"This definition contradicts other exception definitions:")
|
||||
~extra_pos:
|
||||
(( Some
|
||||
"This definition contradicts other exception \
|
||||
definitions:",
|
||||
edge_pos )
|
||||
:: List.map
|
||||
(fun pos -> Some "Other exception definition:", pos)
|
||||
edge.edge_positions)
|
||||
(List.map
|
||||
(fun pos -> "Other exception definition:", pos)
|
||||
edge.edge_positions)
|
||||
"The definition of exceptions are inconsistent for variable \
|
||||
%a."
|
||||
Ast.ScopeDef.format def_info)
|
||||
@ -495,7 +494,7 @@ let check_for_exception_cycle
|
||||
let v, _ = RuleName.Map.choose vs.rules in
|
||||
let rule = RuleName.Map.find v def in
|
||||
let pos = Mark.get (RuleName.get_info rule.Ast.rule_id) in
|
||||
None, pos)
|
||||
"", pos)
|
||||
scc
|
||||
in
|
||||
let v, _ = RuleName.Map.choose (List.hd scc).rules in
|
||||
|
@ -211,7 +211,7 @@ let rec check_formula (op, pos_op) e =
|
||||
xor b xor c] is most likely an error since it's true for [a = b = c =
|
||||
true]) *)
|
||||
Message.error
|
||||
~extra_pos:[None, pos_op; None, pos_op1]
|
||||
~extra_pos:["", pos_op; "", pos_op1]
|
||||
"Please add parentheses to explicit which of these operators should be \
|
||||
applied first";
|
||||
check_formula (op1, pos_op1) e1;
|
||||
@ -432,9 +432,8 @@ let rec translate_expr
|
||||
~suggestion:(List.map StateName.to_string states)
|
||||
~extra_pos:
|
||||
[
|
||||
None, Mark.get st;
|
||||
( Some "Variable defined here",
|
||||
Mark.get (ScopeVar.get_info uid) );
|
||||
"", Mark.get st;
|
||||
"Variable defined here", Mark.get (ScopeVar.get_info uid);
|
||||
]
|
||||
"Reference to unknown variable state"
|
||||
| some -> some)
|
||||
@ -526,10 +525,9 @@ let rec translate_expr
|
||||
~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),
|
||||
"", Mark.get fld_id;
|
||||
( 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
|
||||
@ -586,7 +584,7 @@ let rec translate_expr
|
||||
| None -> ()
|
||||
| Some e_field ->
|
||||
Message.error
|
||||
~extra_pos:[None, Mark.get f_e; None, Expr.pos e_field]
|
||||
~extra_pos:["", Mark.get f_e; "", 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)
|
||||
@ -973,8 +971,7 @@ and disambiguate_match_and_build_expression
|
||||
| None -> ()
|
||||
| Some e_case ->
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[None, Mark.get case.match_case_expr; None, Expr.pos e_case]
|
||||
~extra_pos:["", Mark.get case.match_case_expr; "", Expr.pos e_case]
|
||||
"The constructor %a has been matched twice:" EnumConstructor.format
|
||||
c_uid);
|
||||
let local_vars, param_var =
|
||||
@ -995,8 +992,8 @@ and disambiguate_match_and_build_expression
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
Some "Not ending wildcard:", case_pos;
|
||||
( Some "Next reachable case:",
|
||||
"Not ending wildcard:", case_pos;
|
||||
( "Next reachable case:",
|
||||
curr_index + 1 |> List.nth cases |> Mark.get );
|
||||
]
|
||||
"Wildcard must be the last match case"
|
||||
@ -1082,26 +1079,20 @@ let rec arglist_eq_check pos_decl pos_def pdecl pdefs =
|
||||
| [], [] -> ()
|
||||
| [], (arg, apos) :: _ ->
|
||||
Message.error
|
||||
~extra_pos:[Some "Declared here:", pos_decl; Some "Extra argument:", apos]
|
||||
~extra_pos:["Declared here:", pos_decl; "Extra argument:", apos]
|
||||
"This definition has an extra, undeclared argument '%a'" Print.lit_style
|
||||
arg
|
||||
| (arg, apos) :: _, [] ->
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
Some "Argument declared here:", apos;
|
||||
Some "Mismatching definition:", pos_def;
|
||||
]
|
||||
["Argument declared here:", apos; "Mismatching definition:", pos_def]
|
||||
"This definition is missing argument '%a'" Print.lit_style arg
|
||||
| decl :: pdecl, def :: pdefs when Uid.MarkedString.equal decl def ->
|
||||
arglist_eq_check pos_decl pos_def pdecl pdefs
|
||||
| (decl_arg, decl_apos) :: _, (def_arg, def_apos) :: _ ->
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
Some "Argument declared here:", decl_apos;
|
||||
Some "Defined here:", def_apos;
|
||||
]
|
||||
["Argument declared here:", decl_apos; "Defined here:", def_apos]
|
||||
"Function argument name mismatch between declaration ('%a') and \
|
||||
definition ('%a')"
|
||||
Print.lit_style decl_arg Print.lit_style def_arg
|
||||
@ -1120,17 +1111,16 @@ let process_rule_parameters
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
Some "Declared here without arguments", decl_pos;
|
||||
Some "Unexpected arguments appearing here", pos;
|
||||
"Declared here without arguments", decl_pos;
|
||||
"Unexpected arguments appearing here", pos;
|
||||
]
|
||||
"Extra arguments in this definition of %a" Ast.ScopeDef.format decl_name
|
||||
| Some (_, pos), None ->
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
Some "Arguments declared here", pos;
|
||||
( Some "Definition missing the arguments",
|
||||
Mark.get def.S.definition_name );
|
||||
"Arguments declared here", pos;
|
||||
"Definition missing the arguments", Mark.get def.S.definition_name;
|
||||
]
|
||||
"This definition for %a is missing the arguments" Ast.ScopeDef.format
|
||||
decl_name
|
||||
@ -1347,7 +1337,7 @@ let process_scope_use_item
|
||||
with
|
||||
| Some (_, old_pos) ->
|
||||
Message.error
|
||||
~extra_pos:[None, old_pos; None, Mark.get item]
|
||||
~extra_pos:["", old_pos; "", Mark.get item]
|
||||
"You cannot set multiple date rounding modes"
|
||||
| None ->
|
||||
{
|
||||
@ -1402,10 +1392,9 @@ let check_unlabeled_exception
|
||||
Message.error ~pos:(Mark.get item)
|
||||
"This exception does not have a corresponding definition"
|
||||
| Some (Ambiguous pos) ->
|
||||
Message.error
|
||||
~extra_pos:
|
||||
([Some "Ambiguous exception", Mark.get item]
|
||||
@ List.map (fun p -> Some "Candidate definition", p) pos)
|
||||
Message.error ~pos:(Mark.get item)
|
||||
~pos_msg:(fun ppf -> Format.pp_print_text ppf "Ambiguous exception")
|
||||
~extra_pos:(List.map (fun p -> "Candidate definition", p) pos)
|
||||
"This exception can refer to several definitions. Try using labels \
|
||||
to disambiguate"
|
||||
| Some (Unique _) -> ()))
|
||||
@ -1485,8 +1474,8 @@ let process_topdef
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
None, Mark.get (TopdefName.get_info id);
|
||||
None, Mark.get def.S.topdef_name;
|
||||
"", Mark.get (TopdefName.get_info id);
|
||||
"", Mark.get def.S.topdef_name;
|
||||
]
|
||||
(msg ^^ " for %a") TopdefName.format id
|
||||
in
|
||||
|
@ -82,7 +82,7 @@ let detect_identical_rules (p : program) : unit =
|
||||
RuleExpressionsMap.update rule
|
||||
(fun l ->
|
||||
let x =
|
||||
( None,
|
||||
( "",
|
||||
Pos.overwrite_law_info
|
||||
(snd (RuleName.get_info rule.rule_id))
|
||||
(Pos.get_law_info (Expr.pos rule.rule_just)) )
|
||||
|
@ -184,17 +184,14 @@ let get_enum ctxt id =
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
None, Mark.get id;
|
||||
Some "Structure defined at", Mark.get (StructName.get_info sid);
|
||||
"", Mark.get id;
|
||||
"Structure defined at", Mark.get (StructName.get_info sid);
|
||||
]
|
||||
"Expecting an enum, but found a structure"
|
||||
| TScope (sid, _) ->
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
None, Mark.get id;
|
||||
Some "Scope defined at", Mark.get (ScopeName.get_info sid);
|
||||
]
|
||||
["", Mark.get id; "Scope defined at", Mark.get (ScopeName.get_info sid)]
|
||||
"Expecting an enum, but found a scope"
|
||||
| exception Ident.Map.Not_found _ ->
|
||||
Message.error ~pos:(Mark.get id) "No enum named %s found" (Mark.remove id)
|
||||
@ -205,10 +202,7 @@ let get_struct ctxt id =
|
||||
| TEnum eid ->
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
None, Mark.get id;
|
||||
Some "Enum defined at", Mark.get (EnumName.get_info eid);
|
||||
]
|
||||
["", Mark.get id; "Enum defined at", Mark.get (EnumName.get_info eid)]
|
||||
"Expecting a struct, but found an enum"
|
||||
| exception Ident.Map.Not_found _ ->
|
||||
Message.error ~pos:(Mark.get id) "No struct named %s found" (Mark.remove id)
|
||||
@ -219,17 +213,14 @@ let get_scope ctxt id =
|
||||
| TEnum eid ->
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
None, Mark.get id;
|
||||
Some "Enum defined at", Mark.get (EnumName.get_info eid);
|
||||
]
|
||||
["", Mark.get id; "Enum defined at", Mark.get (EnumName.get_info eid)]
|
||||
"Expecting an scope, but found an enum"
|
||||
| TStruct sid ->
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
None, Mark.get id;
|
||||
Some "Structure defined at", Mark.get (StructName.get_info sid);
|
||||
"", Mark.get id;
|
||||
"Structure defined at", Mark.get (StructName.get_info sid);
|
||||
]
|
||||
"Expecting an scope, but found a structure"
|
||||
| exception Ident.Map.Not_found _ ->
|
||||
@ -271,7 +262,7 @@ let process_subscope_decl
|
||||
| SubScope (ssc, _, _) -> ScopeVar.get_info ssc
|
||||
in
|
||||
Message.error
|
||||
~extra_pos:[Some "first use", Mark.get info; Some "second use", s_pos]
|
||||
~extra_pos:["first use", Mark.get info; "second use", s_pos]
|
||||
"Subscope name @{<yellow>\"%s\"@} already used" (Mark.remove subscope)
|
||||
| None ->
|
||||
let sub_scope_uid = ScopeVar.fresh (name, name_pos) in
|
||||
@ -374,7 +365,7 @@ let process_data_decl
|
||||
| SubScope (ssc, _, _) -> ScopeVar.get_info ssc
|
||||
in
|
||||
Message.error
|
||||
~extra_pos:[Some "First use:", Mark.get info; Some "Second use:", pos]
|
||||
~extra_pos:["First use:", Mark.get info; "Second use:", pos]
|
||||
"Variable name @{<yellow>\"%s\"@} already used" name
|
||||
| None ->
|
||||
let uid = ScopeVar.fresh (name, pos) in
|
||||
@ -392,17 +383,15 @@ let process_data_decl
|
||||
Message.error
|
||||
~fmt_pos:
|
||||
[
|
||||
( Some
|
||||
(fun ppf ->
|
||||
Format.fprintf ppf
|
||||
"First instance of state @{<yellow>\"%s\"@}:"
|
||||
state_id_name),
|
||||
( (fun ppf ->
|
||||
Format.fprintf ppf
|
||||
"First instance of state @{<yellow>\"%s\"@}:"
|
||||
state_id_name),
|
||||
Mark.get state_id );
|
||||
( Some
|
||||
(fun ppf ->
|
||||
Format.fprintf ppf
|
||||
"Second instance of state @{<yellow>\"%s\"@}:"
|
||||
state_id_name),
|
||||
( (fun ppf ->
|
||||
Format.fprintf ppf
|
||||
"Second instance of state @{<yellow>\"%s\"@}:"
|
||||
state_id_name),
|
||||
Mark.get
|
||||
(Ident.Map.find state_id_name states_idmap
|
||||
|> StateName.get_info) );
|
||||
@ -650,9 +639,9 @@ let process_name_item (ctxt : context) (item : Surface.Ast.code_item Mark.pos) :
|
||||
Message.error
|
||||
~fmt_pos:
|
||||
[
|
||||
( Some (fun ppf -> Format.pp_print_string ppf "First definition:"),
|
||||
( (fun ppf -> Format.pp_print_string ppf "First definition:"),
|
||||
Mark.get use );
|
||||
Some (fun ppf -> Format.pp_print_string ppf "Second definition:"), pos;
|
||||
(fun ppf -> Format.pp_print_string ppf "Second definition:"), pos;
|
||||
]
|
||||
"%s name @{<yellow>\"%s\"@} already defined" msg name
|
||||
in
|
||||
@ -785,9 +774,8 @@ let get_def_key
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
None, Mark.get state;
|
||||
( Some "Variable declaration:",
|
||||
Mark.get (ScopeVar.get_info x_uid) );
|
||||
"", Mark.get state;
|
||||
"Variable declaration:", Mark.get (ScopeVar.get_info x_uid);
|
||||
]
|
||||
"This identifier is not a state declared for variable %a."
|
||||
ScopeVar.format x_uid)
|
||||
@ -796,9 +784,8 @@ let get_def_key
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
None, Mark.get x;
|
||||
( Some "Variable declaration:",
|
||||
Mark.get (ScopeVar.get_info x_uid) );
|
||||
"", Mark.get x;
|
||||
"Variable declaration:", Mark.get (ScopeVar.get_info x_uid);
|
||||
]
|
||||
"This definition does not indicate which state has to be \
|
||||
considered for variable %a."
|
||||
|
@ -42,7 +42,7 @@ let load_module_interfaces
|
||||
|> List.fold_left File.Tree.union File.Tree.empty
|
||||
in
|
||||
let err_req_pos chain =
|
||||
List.map (fun mpos -> Some "Module required from", mpos) chain
|
||||
List.map (fun mpos -> "Module required from", mpos) chain
|
||||
in
|
||||
let find_module req_chain (mname, mpos) =
|
||||
let required_from_file = Pos.get_file mpos in
|
||||
|
@ -366,10 +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.error
|
||||
~extra_pos:
|
||||
((None, Expr.mark_pos m)
|
||||
:: List.map (fun (e, _) -> None, Expr.pos e) excs)
|
||||
Message.error ~pos:(Expr.mark_pos m)
|
||||
~extra_pos:(List.map (fun (e, _) -> "", Expr.pos e) excs)
|
||||
"Conflicting exceptions")
|
||||
| EPureDefault e, _ -> lazy_eval ctx env llevel e
|
||||
| EIfThenElse { cond; etrue; efalse }, _ -> (
|
||||
|
@ -197,10 +197,8 @@ let rec lazy_eval :
|
||||
log "@[<hov 5>EVAL %a@]" Expr.format e;
|
||||
lazy_eval ctx env llevel e
|
||||
| _ :: _ :: _ ->
|
||||
Message.error
|
||||
~extra_pos:
|
||||
((None, Expr.mark_pos m)
|
||||
:: List.map (fun (e, _) -> None, Expr.pos e) excs)
|
||||
Message.error ~pos:(Expr.mark_pos m)
|
||||
~extra_pos:(List.map (fun (e, _) -> "", Expr.pos e) excs)
|
||||
"Conflicting exceptions")
|
||||
| EPureDefault e, _ -> lazy_eval ctx env llevel e
|
||||
| EIfThenElse { cond; etrue; efalse }, _ -> (
|
||||
|
@ -187,7 +187,7 @@ let check_for_cycle_in_defs (g : SDependencies.t) : unit =
|
||||
SVertex.format v1 SVertex.format v2
|
||||
in
|
||||
let _, edge_pos, _ = SDependencies.find_edge g v1 v2 in
|
||||
Some msg, edge_pos)
|
||||
msg, edge_pos)
|
||||
cycle
|
||||
(List.tl cycle @ [List.hd cycle])
|
||||
in
|
||||
@ -338,11 +338,10 @@ let check_type_cycles (structs : struct_ctx) (enums : enum_ctx) : TVertex.t list
|
||||
in
|
||||
let succ_str = Format.asprintf "%a" TVertex.format succ in
|
||||
[
|
||||
Some ("Cycle type " ^ var_str ^ ", declared:"), Mark.get var_info;
|
||||
( Some
|
||||
("Used here in the definition of another cycle type "
|
||||
^ succ_str
|
||||
^ ":"),
|
||||
"Cycle type " ^ var_str ^ ", declared:", Mark.get var_info;
|
||||
( "Used here in the definition of another cycle type "
|
||||
^ succ_str
|
||||
^ ":",
|
||||
edge_pos );
|
||||
])
|
||||
scc)
|
||||
|
@ -216,13 +216,13 @@ let rule_to_exception_graph (scope : D.scope) = function
|
||||
| NoInput ->
|
||||
Message.error
|
||||
~extra_pos:
|
||||
(( Some "Incriminated subscope:",
|
||||
(( "Incriminated subscope:",
|
||||
Mark.get (ScopeVar.get_info (Mark.remove sscope)) )
|
||||
:: ( Some "Incriminated variable:",
|
||||
:: ( "Incriminated variable:",
|
||||
Mark.get (ScopeVar.get_info var_within_origin_scope) )
|
||||
:: List.map
|
||||
(fun rule ->
|
||||
( Some "Incriminated subscope variable definition:",
|
||||
( "Incriminated subscope variable definition:",
|
||||
Mark.get (RuleName.get_info rule) ))
|
||||
(RuleName.Map.keys def))
|
||||
"Invalid assignment to a subscope variable that is not tagged \
|
||||
@ -233,9 +233,9 @@ let rule_to_exception_graph (scope : D.scope) = function
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
( Some "Incriminated subscope:",
|
||||
( "Incriminated subscope:",
|
||||
Mark.get (ScopeVar.get_info (Mark.remove sscope)) );
|
||||
Some "Incriminated variable:", Mark.get sscope;
|
||||
"Incriminated variable:", Mark.get sscope;
|
||||
]
|
||||
"This subscope variable is a mandatory input but no definition \
|
||||
was provided."
|
||||
@ -255,10 +255,10 @@ let rule_to_exception_graph (scope : D.scope) = function
|
||||
(* If the variable is tagged as input, then it shall not be redefined. *)
|
||||
Message.error
|
||||
~extra_pos:
|
||||
((Some "Incriminated variable:", Mark.get (ScopeVar.get_info var))
|
||||
(("Incriminated variable:", Mark.get (ScopeVar.get_info var))
|
||||
:: List.map
|
||||
(fun rule ->
|
||||
( Some "Incriminated variable definition:",
|
||||
( "Incriminated variable definition:",
|
||||
Mark.get (RuleName.get_info rule) ))
|
||||
(RuleName.Map.keys var_def))
|
||||
"It is impossible to give a definition to a scope variable tagged as \
|
||||
|
@ -125,7 +125,7 @@ let rec evaluate_operator
|
||||
let protect f x y =
|
||||
let get_binop_args_pos = function
|
||||
| (arg0 :: arg1 :: _ : ('t, 'm) gexpr list) ->
|
||||
[None, Expr.pos arg0; None, Expr.pos arg1]
|
||||
["", Expr.pos arg0; "", Expr.pos arg1]
|
||||
| _ -> assert false
|
||||
in
|
||||
try f x y with
|
||||
@ -133,8 +133,8 @@ let rec evaluate_operator
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
Some "The division operator:", pos;
|
||||
Some "The null denominator:", Expr.pos (List.nth args 1);
|
||||
"The division operator:", pos;
|
||||
"The null denominator:", Expr.pos (List.nth args 1);
|
||||
]
|
||||
"division by zero at runtime"
|
||||
| Runtime.UncomparableDurations ->
|
||||
@ -146,18 +146,16 @@ let rec evaluate_operator
|
||||
Message.error
|
||||
~extra_pos:
|
||||
([
|
||||
( Some
|
||||
(Format.asprintf "Operator (value %a):"
|
||||
(Print.operator ~debug:true)
|
||||
op),
|
||||
( Format.asprintf "Operator (value %a):"
|
||||
(Print.operator ~debug:true)
|
||||
op,
|
||||
pos );
|
||||
]
|
||||
@ List.mapi
|
||||
(fun i arg ->
|
||||
( Some
|
||||
(Format.asprintf "Argument n°%d, value %a" (i + 1)
|
||||
(Print.UserFacing.expr lang)
|
||||
arg),
|
||||
( Format.asprintf "Argument n°%d, value %a" (i + 1)
|
||||
(Print.UserFacing.expr lang)
|
||||
arg,
|
||||
Expr.pos arg ))
|
||||
args)
|
||||
"Operator %a applied to the wrong arguments\n\
|
||||
@ -699,7 +697,7 @@ let rec evaluate_expr :
|
||||
| EStruct { fields = es; name } -> (
|
||||
if not (StructName.equal s name) then
|
||||
Message.error
|
||||
~extra_pos:[None, pos; None, Expr.pos e]
|
||||
~extra_pos:["", pos; "", 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
|
||||
@ -734,7 +732,7 @@ let rec evaluate_expr :
|
||||
| EInj { e = e1; cons; name = name' } ->
|
||||
if not (EnumName.equal name name') then
|
||||
Message.error
|
||||
~extra_pos:[None, Expr.pos e; None, Expr.pos e1]
|
||||
~extra_pos:["", Expr.pos e; "", Expr.pos e1]
|
||||
"Error during match: two different enums found (should not happen if \
|
||||
the term was well-typed)";
|
||||
let es_n =
|
||||
@ -921,7 +919,7 @@ let interp_failure_message ~pos = function
|
||||
Message.error
|
||||
~extra_pos:
|
||||
(List.map
|
||||
(fun pos -> Some "This consequence has a valid justification:", pos)
|
||||
(fun pos -> "This consequence has a valid justification:", pos)
|
||||
cpos)
|
||||
"There is a conflict between multiple valid consequences for assigning \
|
||||
the same variable."
|
||||
|
@ -550,12 +550,11 @@ let resolve_overload ctx (op : overloaded t Mark.pos) (operands : typ list) :
|
||||
with Not_found ->
|
||||
Message.error
|
||||
~extra_pos:
|
||||
((None, Mark.get op)
|
||||
(("", Mark.get op)
|
||||
:: List.map
|
||||
(fun ty ->
|
||||
( Some
|
||||
(Format.asprintf "Type %a coming from expression:"
|
||||
(Print.typ ctx) ty),
|
||||
( Format.asprintf "Type %a coming from expression:"
|
||||
(Print.typ ctx) ty,
|
||||
Mark.get ty ))
|
||||
operands)
|
||||
"I don't know how to apply operator %a on types %a"
|
||||
|
@ -228,7 +228,7 @@ let handle_type_error ctx (A.AnyExpr e) t1 t2 =
|
||||
let e_pos = Expr.pos e in
|
||||
let t1_pos = Mark.get t1_repr in
|
||||
let t2_pos = Mark.get t2_repr in
|
||||
let pos_msgs =
|
||||
let fmt_pos =
|
||||
if e_pos = t1_pos then
|
||||
[
|
||||
( (fun ppf ->
|
||||
@ -263,8 +263,7 @@ let handle_type_error ctx (A.AnyExpr e) t1 t2 =
|
||||
t2_pos );
|
||||
]
|
||||
in
|
||||
Message.error
|
||||
~fmt_pos:(List.map (fun (a, b) -> Some a, b) pos_msgs)
|
||||
Message.error ~fmt_pos
|
||||
"@[<v>Error during typechecking, incompatible types:@,\
|
||||
@[<v>@{<bold;blue>@<3>%s@} @[<hov>%a@]@,\
|
||||
@{<bold;blue>@<3>%s@} @[<hov>%a@]@]@]" "┌─⯈" (format_typ ctx) t1 "└─⯈"
|
||||
@ -524,16 +523,15 @@ and typecheck_expr_top_down :
|
||||
let errs =
|
||||
List.map
|
||||
(fun (f, ty) ->
|
||||
( Some (Format.asprintf "Missing field %a" A.StructField.format f),
|
||||
( Format.asprintf "Missing field %a" A.StructField.format f,
|
||||
Mark.get ty ))
|
||||
(A.StructField.Map.bindings missing_fields)
|
||||
@ List.map
|
||||
(fun (f, ef) ->
|
||||
let dup = A.StructField.Map.mem f str in
|
||||
( Some
|
||||
(Format.asprintf "%s field %a"
|
||||
(if dup then "Duplicate" else "Unknown")
|
||||
A.StructField.format f),
|
||||
( Format.asprintf "%s field %a"
|
||||
(if dup then "Duplicate" else "Unknown")
|
||||
A.StructField.format f,
|
||||
Expr.pos ef ))
|
||||
(A.StructField.Map.bindings extra_fields)
|
||||
in
|
||||
@ -589,15 +587,13 @@ and typecheck_expr_top_down :
|
||||
Message.error
|
||||
~fmt_pos:
|
||||
[
|
||||
( Some
|
||||
(fun ppf ->
|
||||
Format.fprintf ppf
|
||||
"@{<yellow>%s@} is used here as an output" field),
|
||||
( (fun ppf ->
|
||||
Format.fprintf ppf
|
||||
"@{<yellow>%s@} is used here as an output" field),
|
||||
Expr.mark_pos context_mark );
|
||||
( Some
|
||||
(fun ppf ->
|
||||
Format.fprintf ppf "Scope %a is declared here"
|
||||
A.ScopeName.format scope_out),
|
||||
( (fun ppf ->
|
||||
Format.fprintf ppf "Scope %a is declared here"
|
||||
A.ScopeName.format scope_out),
|
||||
Mark.get (A.StructName.get_info name) );
|
||||
]
|
||||
"Variable @{<yellow>%s@} is not a declared output of scope %a."
|
||||
@ -608,9 +604,8 @@ and typecheck_expr_top_down :
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
None, Expr.mark_pos context_mark;
|
||||
( Some "Structure definition",
|
||||
Mark.get (A.StructName.get_info name) );
|
||||
"", Expr.mark_pos context_mark;
|
||||
"Structure definition", Mark.get (A.StructName.get_info name);
|
||||
]
|
||||
"Field @{<yellow>\"%s\"@} does not belong to structure \
|
||||
@{<yellow>\"%a\"@}."
|
||||
@ -644,11 +639,12 @@ and typecheck_expr_top_down :
|
||||
in
|
||||
try A.StructField.Map.find field str
|
||||
with A.StructField.Map.Not_found _ ->
|
||||
Message.error
|
||||
~extra_pos:
|
||||
Message.error ~pos:pos_e
|
||||
~fmt_pos:
|
||||
[
|
||||
None, pos_e;
|
||||
( Some "Structure %a declared here",
|
||||
( (fun ppf ->
|
||||
Format.fprintf ppf "Structure %a declared here"
|
||||
A.StructName.format name),
|
||||
Mark.get (A.StructName.get_info name) );
|
||||
]
|
||||
"Structure %a doesn't define a field %a" A.StructName.format name
|
||||
|
@ -74,13 +74,13 @@ let raise_parser_error
|
||||
(msg : Format.formatter -> unit) : 'a =
|
||||
Message.error ?suggestion
|
||||
~fmt_pos:
|
||||
((Some (fun ppf -> Format.pp_print_string ppf "Error token:"), error_loc)
|
||||
(((fun ppf -> Format.pp_print_string ppf "Error token:"), error_loc)
|
||||
::
|
||||
(match last_good_loc with
|
||||
| None -> []
|
||||
| Some last_good_loc ->
|
||||
[
|
||||
( Some (fun ppf -> Format.pp_print_string ppf "Last good token:"),
|
||||
( (fun ppf -> Format.pp_print_string ppf "Last good token:"),
|
||||
last_good_loc );
|
||||
]))
|
||||
"@[<v>Syntax error at token %a@,%t@]"
|
||||
@ -268,7 +268,7 @@ and expand_includes (source_file : string) (commands : Ast.law_structure list) :
|
||||
| opt, None | None, opt -> opt
|
||||
| Some id1, Some id2 ->
|
||||
Message.error
|
||||
~extra_pos:[None, Mark.get id1; None, Mark.get id2]
|
||||
~extra_pos:["", Mark.get id1; "", Mark.get id2]
|
||||
"Multiple definitions of the module name"
|
||||
in
|
||||
match command with
|
||||
@ -299,8 +299,8 @@ and expand_includes (source_file : string) (commands : Ast.law_structure list) :
|
||||
Message.error
|
||||
~extra_pos:
|
||||
[
|
||||
Some "File include", Mark.get inc_file;
|
||||
Some "Module declaration", Mark.get id;
|
||||
"File include", Mark.get inc_file;
|
||||
"Module declaration", Mark.get id;
|
||||
]
|
||||
"A file that declares a module cannot be used through the raw \
|
||||
'@{<yellow>> Include@}' directive. You should use it as a \
|
||||
|
Loading…
Reference in New Issue
Block a user