From d9a695873c596855b5cbcbfe303b4b03d211519a Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Wed, 8 Jan 2025 15:07:59 +0100 Subject: [PATCH 1/2] Improve error message on failed disambiguation of field access --- compiler/shared_ast/typing.ml | 165 ++++++++++++++++++++-------------- 1 file changed, 99 insertions(+), 66 deletions(-) diff --git a/compiler/shared_ast/typing.ml b/compiler/shared_ast/typing.ml index 1c5f39edc..4a68b223b 100644 --- a/compiler/shared_ast/typing.ml +++ b/compiler/shared_ast/typing.ml @@ -578,84 +578,117 @@ and typecheck_expr_top_down : | None -> unionfind (TAny (Any.fresh ())) in let e_struct' = typecheck_expr_top_down ctx env t_struct e_struct in - let name = + let name_opt = match UnionFind.get (ty e_struct') with - | TStruct name, _ -> name - | TAny _, _ -> - Message.error ~pos:(Expr.pos e) - "Ambiguous field access @{%s@}: the parent structure could not \ - be resolved" - field + | TStruct name, _ -> Some name + | TAny _, _ -> None | _ -> Message.error ~pos:(Expr.pos e) - "This is not a structure, cannot access field %s (found type: %a)" + "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.error ~pos:pos_e "No structure %a found" A.StructName.format - name - in - let field = + let name, field = let candidate_structs = try A.Ident.Map.find field ctx.ctx_struct_fields with A.Ident.Map.Not_found _ -> ( - match - A.ScopeName.Map.choose_opt - @@ A.ScopeName.Map.filter - (fun _ { A.out_struct_name; _ } -> - A.StructName.equal out_struct_name name) - ctx.ctx_scopes - with - | Some (scope_out, _) -> - Message.error - ~fmt_pos: - [ - ( (fun ppf -> - Format.fprintf ppf - "@{%s@} is used here as an output" field), - Expr.mark_pos context_mark ); - ( (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." - field A.ScopeName.format scope_out - ~suggestion: - (Suggestions.sorted_candidates - (List.map A.StructField.to_string - (A.StructField.Map.keys str)) - field) + match name_opt with | None -> Message.error - ~extra_pos: - [ - "", Expr.mark_pos context_mark; - "Structure definition", Mark.get (A.StructName.get_info name); - ] - "Field@ @{\"%s\"@}@ does@ not@ belong@ to@ structure@ \ - @{\"%a\"@}." - field A.StructName.format name - ~suggestion: - (Suggestions.sorted_candidates - (A.Ident.Map.keys ctx.ctx_struct_fields) - field)) + ~pos:(Expr.mark_pos context_mark) + "Field@ @{%s@}@ does@ not@ belong@ to@ any@ known@ \ + structure" + field A.StructName.format + (* Since we were unable to disambiguate, we can't get any hints at + this point (but explaining the situation in more detail would + probably not be helpful) *) + | Some name -> ( + match + A.ScopeName.Map.choose_opt + @@ A.ScopeName.Map.filter + (fun _ { A.out_struct_name; _ } -> + A.StructName.equal out_struct_name name) + ctx.ctx_scopes + with + | Some (scope_out, _) -> + let str = + try A.StructName.Map.find name env.structs + with A.StructName.Map.Not_found _ -> + Message.error ~pos:pos_e "No structure %a found" + A.StructName.format name + in + Message.error + ~fmt_pos: + [ + ( (fun ppf -> + Format.fprintf ppf + "@{%s@} is used here as an output" field), + Expr.mark_pos context_mark ); + ( (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." + field A.ScopeName.format scope_out + ~suggestion: + (Suggestions.sorted_candidates + (List.map A.StructField.to_string + (A.StructField.Map.keys str)) + field) + | None -> + Message.error + ~extra_pos: + [ + "", Expr.mark_pos context_mark; + ( "Structure definition", + Mark.get (A.StructName.get_info name) ); + ] + "Field@ @{\"%s\"@}@ does@ not@ belong@ to@ structure@ \ + @{\"%a\"@}." + field A.StructName.format name + ~suggestion: + (Suggestions.sorted_candidates + (A.Ident.Map.keys ctx.ctx_struct_fields) + field))) in - try A.StructName.Map.find name candidate_structs + match name_opt with + | None -> + if A.StructName.Map.cardinal candidate_structs = 1 then + A.StructName.Map.choose candidate_structs + else + Message.error + ~pos:(Expr.mark_pos context_mark) + "@[@[Ambiguous field access @{%s@}:@ the@ parent@ \ + structure@ could@ not@ be@ determined@ at@ this@ point.@ The@ \ + following@ structures@ have@ a@ field@ by@ this@ name:@]@,\ + @[%a@]@,\ + @[@{Hint@}: explicit the structure the field belongs to \ + using@ x.@{StructName@}.@{%s@}@ (or@ \ + x.@{ModuleName@}.@{StructName@}.@{%s@})@]@]" + field + (Format.pp_print_list (fun fmt s_name -> + Format.fprintf fmt "- %a" A.StructName.format s_name)) + (A.StructName.Map.keys candidate_structs) + field field + | Some name -> ( + try name, A.StructName.Map.find name candidate_structs + with A.StructName.Map.Not_found _ -> + Message.error + ~pos:(Expr.mark_pos context_mark) + "Field@ @{%s@}@ does@ not@ belong@ to@ structure@ %a@ \ + (however, structure@ %a@ defines@ it).@]" + field A.StructName.format name + (Format.pp_print_list + ~pp_sep:(fun ppf () -> Format.fprintf ppf "@ or@ ") + A.StructName.format) + (A.StructName.Map.keys candidate_structs)) + in + let str = + try A.StructName.Map.find name env.structs with A.StructName.Map.Not_found _ -> - Message.error - ~pos:(Expr.mark_pos context_mark) - "Field@ @{\"%s\"@}@ does@ not@ belong@ to@ structure@ \ - @{\"%a\"@}@ (however, structure@ %a@ defines@ it).@]" - field A.StructName.format name - (Format.pp_print_list - ~pp_sep:(fun ppf () -> Format.fprintf ppf "@ or@ ") - (fun fmt s_name -> - Format.fprintf fmt "@{\"%a\"@}" A.StructName.format - s_name)) - (A.StructName.Map.keys candidate_structs) + Message.error ~pos:pos_e "No structure %a found" A.StructName.format + name in let fld_ty = A.StructField.Map.find field str in let mark = mark_with_tau_and_unify fld_ty in From 68d3a81523720af5c77cae8b20460048892ce6d9 Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Wed, 8 Jan 2025 16:27:12 +0100 Subject: [PATCH 2/2] Delayed errors: keep on non-delayed error When a non-delayed error happens after delayed errors, these should take precedence and be raised rather than ignored. Indeed, it's often a consequence of delayed errors. This happened in the disambiguation phase where a type inconsistency would be skipped, leading to a failure to disambiguate, and only the latter was printed resulting in a puzzling error. --- compiler/catala_utils/message.ml | 33 +++---- compiler/shared_ast/typing.ml | 32 +++---- .../array/bad/type_error_in_filter.catala_en | 90 +++++++++++++++++++ tests/array/good/broken-message.catala_en | 33 ++++--- .../bad/wrong_qualified_field.catala_en | 4 +- 5 files changed, 145 insertions(+), 47 deletions(-) create mode 100644 tests/array/bad/type_error_in_filter.catala_en diff --git a/compiler/catala_utils/message.ml b/compiler/catala_utils/message.ml index e7b00ccdf..eb7ef9734 100644 --- a/compiler/catala_utils/message.ml +++ b/compiler/catala_utils/message.ml @@ -531,19 +531,22 @@ let with_delayed_errors "delayed error called outside scope: encapsulate using \ 'with_delayed_errors' first"); global_errors.stop_on_error <- stop_on_error; - try - let r = f () in - match global_errors.errors with - | None -> error ~internal:true "intertwined delayed error scope" - | Some [] -> - global_errors.errors <- None; - r - | Some [err] -> - global_errors.errors <- None; - raise (CompilerError err) - | Some errs -> - global_errors.errors <- None; - raise (CompilerErrors (List.rev errs)) - with e -> + let result = + match f () with + | r -> fun () -> r + | exception (CompilerError _ as e) -> + let bt = Printexc.get_raw_backtrace () in + fun () -> Printexc.raise_with_backtrace e bt + | exception e -> raise e + in + match global_errors.errors with + | None -> error ~internal:true "intertwined delayed error scope" + | Some [] -> + global_errors.errors <- None; + result () + | Some [err] -> + global_errors.errors <- None; + raise (CompilerError err) + | Some errs -> global_errors.errors <- None; - raise e + raise (CompilerErrors (List.rev errs)) diff --git a/compiler/shared_ast/typing.ml b/compiler/shared_ast/typing.ml index 4a68b223b..fb21503da 100644 --- a/compiler/shared_ast/typing.ml +++ b/compiler/shared_ast/typing.ml @@ -876,22 +876,21 @@ and typecheck_expr_top_down : 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 - else - let tau_args = List.map ast_to_typ t_args in - let t_ret = unionfind (TAny (Any.fresh ())) in - let t_func = unionfind (TArrow (tau_args, t_ret)) in - let mark = mark_with_tau_and_unify t_func in - let xs, body = Bindlib.unmbind binder in - let xs' = Array.map Var.translate xs in - let env = - List.fold_left2 - (fun env x tau_arg -> Env.add x tau_arg env) - env (Array.to_list xs) tau_args - in - let body' = typecheck_expr_top_down ctx env t_ret body in - let binder' = Bindlib.bind_mvar xs' (Expr.Box.lift body') in - Expr.eabs binder' pos (List.map (typ_to_ast ~flags) tau_args) mark + (List.length t_args) Expr.format e; + let tau_args = List.map ast_to_typ t_args in + let t_ret = unionfind (TAny (Any.fresh ())) in + let t_func = unionfind (TArrow (tau_args, t_ret)) in + let mark = mark_with_tau_and_unify t_func in + let xs, body = Bindlib.unmbind binder in + let xs' = Array.map Var.translate xs in + let env = + List.fold_left2 + (fun env x tau_arg -> Env.add x tau_arg env) + env (Array.to_list xs) tau_args + in + let body' = typecheck_expr_top_down ctx env t_ret body in + let binder' = Bindlib.bind_mvar xs' (Expr.Box.lift body') in + Expr.eabs binder' pos (List.map (typ_to_ast ~flags) tau_args) mark | A.EApp { f = e1; args; tys } -> (* Here we type the arguments first (in order), to ensure we know the types of the arguments if [f] is [EAbs] before disambiguation. This is also the @@ -939,6 +938,7 @@ and typecheck_expr_top_down : operators are required to allow the resolution of all type variables this way *) unify ctx e (polymorphic_op_type op) t_func; + (* List.rev_map(2) applies the side effects in order *) List.rev_map2 (typecheck_expr_top_down ctx env) (List.rev t_args) (List.rev args))) diff --git a/tests/array/bad/type_error_in_filter.catala_en b/tests/array/bad/type_error_in_filter.catala_en new file mode 100644 index 000000000..8d12eb453 --- /dev/null +++ b/tests/array/bad/type_error_in_filter.catala_en @@ -0,0 +1,90 @@ + +```catala +declaration structure St: + data x content integer + +declaration scope S: + input ll content list of St + output out content list of St + +scope S: + definition out equals + combine acc initially [] + with (acc ++ list of x among in_n such that x.x > 2) + # acc ++ filter (x -> x.x > 2) in_n + for in_n among ll + +declaration scope Test: + output s scope S + +declaration st content St + depends on x content integer + equals St { -- x: x } + +scope Test: + definition s.ll equals [ + [st of 1; st of 2; st of 3]; + [st of 2; st of 3; st of 4]; + [st of 3; st of 4; st of 5] + ] +``` + + +```catala-test-inline +$ catala dcalc +┌─[ERROR]─ +│ +│ Error during typechecking, incompatible types: +│ ─➤ St +│ ─➤ list of any +│ +│ While typechecking the following expression: +├─➤ tests/array/bad/type_error_in_filter.catala_en:13.34-13.38: +│ │ +│ 13 │ with (acc ++ list of x among in_n such that x.x > 2) +│ │ ‾‾‾‾ +│ +│ Type St is coming from: +├─➤ tests/array/bad/type_error_in_filter.catala_en:7.28-7.30: +│ │ +│ 7 │ input ll content list of St +│ │ ‾‾ +│ +│ Type list of any is coming from: +├─➤ tests/array/bad/type_error_in_filter.catala_en:13.18-13.56: +│ │ +│ 13 │ with (acc ++ list of x among in_n such that x.x > 2) +│ │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ +└─ +#return code 123# +``` + + +```catala-test-inline +$ catala test-scope Test +┌─[ERROR]─ +│ +│ Error during typechecking, incompatible types: +│ ─➤ St +│ ─➤ list of any +│ +│ While typechecking the following expression: +├─➤ tests/array/bad/type_error_in_filter.catala_en:13.34-13.38: +│ │ +│ 13 │ with (acc ++ list of x among in_n such that x.x > 2) +│ │ ‾‾‾‾ +│ +│ Type St is coming from: +├─➤ tests/array/bad/type_error_in_filter.catala_en:7.28-7.30: +│ │ +│ 7 │ input ll content list of St +│ │ ‾‾ +│ +│ Type list of any is coming from: +├─➤ tests/array/bad/type_error_in_filter.catala_en:13.18-13.56: +│ │ +│ 13 │ with (acc ++ list of x among in_n such that x.x > 2) +│ │ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ +└─ +#return code 123# +``` diff --git a/tests/array/good/broken-message.catala_en b/tests/array/good/broken-message.catala_en index 18826df6f..eff5ddb7d 100644 --- a/tests/array/good/broken-message.catala_en +++ b/tests/array/good/broken-message.catala_en @@ -26,33 +26,38 @@ scope B: (acc1 ++ [x + acc2], acc2 + x) for x among a.x ``` -The positions in this error message are completely wrong and misleading. -Investigation needed... +There was an error -- now fixed -- where the issue was pointed on `x+acc2` with +a confusing message. + +This was diagnosed to be due to delayed error messages that got skipped. ```catala-test-inline $ catala Typecheck --check-invariants ┌─[ERROR]─ │ -│ I don't know how to apply operator + on types list of money and money +│ Error during typechecking, incompatible types: +│ ─➤ money +│ ─➤ list of money │ -├─➤ tests/array/good/broken-message.catala_en:26.17-26.25: +│ While typechecking the following expression: +├─➤ tests/array/good/broken-message.catala_en:21.8-21.9: │ │ -│ 26 │ (acc1 ++ [x + acc2], acc2 + x) for x among a.x -│ │ ‾‾‾‾‾‾‾‾ +│ 21 │ (x ++ acc) for x among a.x +│ │ ‾ +├─ Article +│ +│ Type money is coming from: +├─➤ tests/array/good/broken-message.catala_en:5.28-5.33: +│ │ +│ 5 │ output x content list of money +│ │ ‾‾‾‾‾ ├─ Article │ -│ Type list of money coming from expression: +│ Type list of money is coming from: ├─➤ tests/array/good/broken-message.catala_en:21.10-21.12: │ │ │ 21 │ (x ++ acc) for x among a.x │ │ ‾‾ -├─ Article -│ -│ Type money coming from expression: -├─➤ tests/array/good/broken-message.catala_en:25.41-25.43: -│ │ -│ 25 │ combine (acc1, acc2) initially ([], $1) with -│ │ ‾‾ └─ Article #return code 123# ``` diff --git a/tests/struct/bad/wrong_qualified_field.catala_en b/tests/struct/bad/wrong_qualified_field.catala_en index 34cfc67b5..5d7c08f86 100644 --- a/tests/struct/bad/wrong_qualified_field.catala_en +++ b/tests/struct/bad/wrong_qualified_field.catala_en @@ -21,8 +21,8 @@ scope A: $ catala test-scope A ┌─[ERROR]─ │ -│ Field "g" does not belong to structure "Foo" (however, structure "Bar" -│ defines it). +│ Field g does not belong to structure Foo (however, structure Bar defines +│ it). ├─➤ tests/struct/bad/wrong_qualified_field.catala_en:17.23-17.30: │ │ │17 │ definition y equals x.Foo.g