CatalaLang/catala
1
1
Fork 0
mirror of https://github.com/CatalaLang/catala.git synced 2024-11-08 07:51:43 +03:00
Code Issues Projects Releases Wiki Activity

Message: further simplification

Browse Source
This commit is contained in:
Louis Gesbert 2024-04-09 19:08:29 +02:00
parent 9524e5d3f8
commit def10e7f98
16 changed files with 131 additions and 164 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

13
compiler/catala_utils/message.ml
View File

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

4
compiler/catala_utils/message.mli
View File

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

13
compiler/dcalc/from_scopelang.ml
View File

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

23
compiler/desugared/dependency.ml
View File

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

57
compiler/desugared/from_surface.ml
View File

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

2
compiler/desugared/linting.ml
View File

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

59
compiler/desugared/name_resolution.ml
View File

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

2
compiler/driver.ml
View File

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

6
compiler/plugins/explain.ml
View File

@ -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 }, _ -> (

6
compiler/plugins/lazy_interp.ml
View File

@ -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 }, _ -> (

11
compiler/scopelang/dependency.ml
View File

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

14
compiler/scopelang/from_desugared.ml
View File

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

26
compiler/shared_ast/interpreter.ml
View File

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

7
compiler/shared_ast/operator.ml
View File

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

42
compiler/shared_ast/typing.ml
View File

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

10
compiler/surface/parser_driver.ml
View File

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