Skip to content

Commit

Permalink
Fix confusing disambiguation errors appearing instead of type errors (#…
Browse files Browse the repository at this point in the history 
…768)
  • Loading branch information
@AltGr
AltGr authored Jan 9, 2025
2 parents bdb2e8f + 68d3a81 commit 66c5df5
Show file tree
Hide file tree
Showing 5 changed files with 244 additions and 113 deletions.
33 changes: 18 additions & 15 deletions compiler/catala_utils/message.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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))
197 changes: 115 additions & 82 deletions compiler/shared_ast/typing.ml
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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 @{<cyan>%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 @{<magenta>%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
"@{<yellow>%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 @{<yellow>%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@ @{<yellow>\"%s\"@}@ does@ not@ belong@ to@ structure@ \
@{<yellow>\"%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@ @{<magenta>%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
"@{<magenta>%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 @{<magenta>%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@ @{<yellow>\"%s\"@}@ does@ not@ belong@ to@ structure@ \
@{<yellow>\"%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)
"@[<v>@[<hov>Ambiguous field access @{<cyan>%s@}:@ the@ parent@ \
structure@ could@ not@ be@ determined@ at@ this@ point.@ The@ \
following@ structures@ have@ a@ field@ by@ this@ name:@]@,\
@[<v>%a@]@,\
@[<hov>@{<b>Hint@}: explicit the structure the field belongs to \
using@ x.@{<cyan>StructName@}.@{<magenta>%s@}@ (or@ \
x.@{<blue>ModuleName@}.@{<cyan>StructName@}.@{<magenta>%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@ @{<magenta>%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@ @{<yellow>\"%s\"@}@ does@ not@ belong@ to@ structure@ \
@{<yellow>\"%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 "@{<yellow>\"%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
Expand Down Expand Up @@ -843,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
Expand Down Expand Up @@ -906,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)))
Expand Down
90 changes: 90 additions & 0 deletions tests/array/bad/type_error_in_filter.catala_en
View file
Original file line number Diff line number Diff line change
@@ -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#
```
Loading

0 comments on commit 66c5df5

Please sign in to comment.