From def10e7f98bfb8de8adc38a5a997c4630ffd58cb Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Tue, 9 Apr 2024 19:08:29 +0200 Subject: [PATCH] Message: further simplification --- compiler/catala_utils/message.ml | 13 ++++-- compiler/catala_utils/message.mli | 4 +- compiler/dcalc/from_scopelang.ml | 13 +++--- compiler/desugared/dependency.ml | 23 +++++------ compiler/desugared/from_surface.ml | 57 +++++++++++--------------- compiler/desugared/linting.ml | 2 +- compiler/desugared/name_resolution.ml | 59 +++++++++++---------------- compiler/driver.ml | 2 +- compiler/plugins/explain.ml | 6 +-- compiler/plugins/lazy_interp.ml | 6 +-- compiler/scopelang/dependency.ml | 11 +++-- compiler/scopelang/from_desugared.ml | 14 +++---- compiler/shared_ast/interpreter.ml | 26 ++++++------ compiler/shared_ast/operator.ml | 7 ++-- compiler/shared_ast/typing.ml | 42 +++++++++---------- compiler/surface/parser_driver.ml | 10 ++--- 16 files changed, 131 insertions(+), 164 deletions(-) diff --git a/compiler/catala_utils/message.ml b/compiler/catala_utils/message.ml index 460ae4ff..48d9f3c5 100644 --- a/compiler/catala_utils/message.ml +++ b/compiler/catala_utils/message.ml @@ -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 diff --git a/compiler/catala_utils/message.mli b/compiler/catala_utils/message.mli index cb16d658..b4b9581e 100644 --- a/compiler/catala_utils/message.mli +++ b/compiler/catala_utils/message.mli @@ -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 diff --git a/compiler/dcalc/from_scopelang.ml b/compiler/dcalc/from_scopelang.ml index 56d14f16..18ce0c17 100644 --- a/compiler/dcalc/from_scopelang.ml +++ b/compiler/dcalc/from_scopelang.ml @@ -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'" diff --git a/compiler/desugared/dependency.ml b/compiler/desugared/dependency.ml index 461ff671..1630f938 100644 --- a/compiler/desugared/dependency.ml +++ b/compiler/desugared/dependency.ml @@ -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 "@[Cyclic dependency detected between the following variables of \ scope %a:@ @[%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 diff --git a/compiler/desugared/from_surface.ml b/compiler/desugared/from_surface.ml index 47e9057c..228a1390 100644 --- a/compiler/desugared/from_surface.ml +++ b/compiler/desugared/from_surface.ml @@ -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 diff --git a/compiler/desugared/linting.ml b/compiler/desugared/linting.ml index 057d638f..cbb314a4 100644 --- a/compiler/desugared/linting.ml +++ b/compiler/desugared/linting.ml @@ -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)) ) diff --git a/compiler/desugared/name_resolution.ml b/compiler/desugared/name_resolution.ml index c3674d9b..57724dae 100644 --- a/compiler/desugared/name_resolution.ml +++ b/compiler/desugared/name_resolution.ml @@ -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 @{\"%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 @{\"%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 @{\"%s\"@}:" - state_id_name), + ( (fun ppf -> + Format.fprintf ppf + "First instance of state @{\"%s\"@}:" + state_id_name), Mark.get state_id ); - ( Some - (fun ppf -> - Format.fprintf ppf - "Second instance of state @{\"%s\"@}:" - state_id_name), + ( (fun ppf -> + Format.fprintf ppf + "Second instance of state @{\"%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 @{\"%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." diff --git a/compiler/driver.ml b/compiler/driver.ml index 10fb1f31..a38a48e4 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -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 diff --git a/compiler/plugins/explain.ml b/compiler/plugins/explain.ml index 285145c0..9cb4ba76 100644 --- a/compiler/plugins/explain.ml +++ b/compiler/plugins/explain.ml @@ -366,10 +366,8 @@ let rec lazy_eval : decl_ctx -> Env.t -> laziness_level -> expr -> expr * Env.t log "@[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 }, _ -> ( diff --git a/compiler/plugins/lazy_interp.ml b/compiler/plugins/lazy_interp.ml index c94df352..a0b22e66 100644 --- a/compiler/plugins/lazy_interp.ml +++ b/compiler/plugins/lazy_interp.ml @@ -197,10 +197,8 @@ let rec lazy_eval : log "@[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 }, _ -> ( diff --git a/compiler/scopelang/dependency.ml b/compiler/scopelang/dependency.ml index 94f476b1..34bb774d 100644 --- a/compiler/scopelang/dependency.ml +++ b/compiler/scopelang/dependency.ml @@ -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) diff --git a/compiler/scopelang/from_desugared.ml b/compiler/scopelang/from_desugared.ml index cdc4e76b..79cb1bdd 100644 --- a/compiler/scopelang/from_desugared.ml +++ b/compiler/scopelang/from_desugared.ml @@ -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 \ diff --git a/compiler/shared_ast/interpreter.ml b/compiler/shared_ast/interpreter.ml index 323c0e45..433aedb8 100644 --- a/compiler/shared_ast/interpreter.ml +++ b/compiler/shared_ast/interpreter.ml @@ -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." diff --git a/compiler/shared_ast/operator.ml b/compiler/shared_ast/operator.ml index 0750ff66..5fa1d5b8 100644 --- a/compiler/shared_ast/operator.ml +++ b/compiler/shared_ast/operator.ml @@ -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" diff --git a/compiler/shared_ast/typing.ml b/compiler/shared_ast/typing.ml index 3ff5cf03..492cde0c 100644 --- a/compiler/shared_ast/typing.ml +++ b/compiler/shared_ast/typing.ml @@ -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 "@[Error during typechecking, incompatible types:@,\ @[@{@<3>%s@} @[%a@]@,\ @{@<3>%s@} @[%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 - "@{%s@} is used here as an output" field), + ( (fun ppf -> + Format.fprintf ppf + "@{%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 @{%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 @{\"%s\"@} does not belong to structure \ @{\"%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 diff --git a/compiler/surface/parser_driver.ml b/compiler/surface/parser_driver.ml index 49e57fff..f77a12d0 100644 --- a/compiler/surface/parser_driver.ml +++ b/compiler/surface/parser_driver.ml @@ -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 ); ])) "@[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 \ '@{> Include@}' directive. You should use it as a \