diff --git a/changes/existential-type-names.polish.md b/changes/existential-type-names.polish.md new file mode 100644 index 0000000000..404d67ce55 --- /dev/null +++ b/changes/existential-type-names.polish.md @@ -0,0 +1 @@ +- Existential types of GADT constructors are shown as `$a` instead of `$Any_'a`, and an escaping one is explained by naming the constructor that binds it. diff --git a/compiler/ml/ctype.ml b/compiler/ml/ctype.ml index b1326f398a..0882f2c328 100644 --- a/compiler/ml/ctype.ml +++ b/compiler/ml/ctype.ml @@ -932,6 +932,16 @@ let new_declaration newtype manifest = type_inlined_types = []; } +(* The constructor binding each existential type created by + [instance_constructor], by the stamp of its identifier, for explaining an + escaping one. Names are not unique: their counter is reset per binding. *) +let existential_constructors_key = + Request_local.new_key (fun () -> Hashtbl.create 8) +let existential_constructor id = + Hashtbl.find_opt + (Domain.DLS.get existential_constructors_key) + (Ident.binding_time id) + let instance_constructor ?in_pattern cstr = with_copy_session (fun () -> (match in_pattern with @@ -939,12 +949,18 @@ let instance_constructor ?in_pattern cstr = | Some (env, newtype_lev) -> let process existential = let decl = new_declaration (Some (newtype_lev, newtype_lev)) None in + (* [$a] for the variable ['a], numbered when the name is taken, + so that distinct existentials print differently *) let name = match repr existential with - | {desc = Tvar (Some name)} -> "$" ^ cstr.cstr_name ^ "_'" ^ name + | {desc = Tvar (Some name)} -> "$" ^ name | _ -> "$" ^ cstr.cstr_name in - let path = Path.Pident (Ident.create (get_new_abstract_name name)) in + let id = Ident.create (get_new_abstract_name name) in + Hashtbl.replace + (Domain.DLS.get existential_constructors_key) + (Ident.binding_time id) cstr.cstr_name; + let path = Path.Pident id in let new_env = Env.add_local_type path decl !env in env := new_env; let to_unify = newty (Tconstr (path, [], ref Mnil)) in diff --git a/compiler/ml/ctype.mli b/compiler/ml/ctype.mli index 09bea4bbb9..98334b37dc 100644 --- a/compiler/ml/ctype.mli +++ b/compiler/ml/ctype.mli @@ -172,6 +172,10 @@ val instance_constructor : type_expr list * type_expr (* Same, for a constructor *) +val existential_constructor : Ident.t -> string option +(* The constructor that binds this existential type, created by + [instance_constructor] in the current request *) + val instance_parameterized_type : ?keep_names:bool -> type_expr list -> type_expr -> type_expr list * type_expr val instance_declaration : type_declaration -> type_declaration diff --git a/compiler/ml/printtyp.ml b/compiler/ml/printtyp.ml index 69e77c2d17..5e4e891cfb 100644 --- a/compiler/ml/printtyp.ml +++ b/compiler/ml/printtyp.ml @@ -1300,16 +1300,31 @@ let rec mismatch = function | [] -> None | _ -> assert false +let escape_explanation ppf p = + match p with + | Pident id -> ( + match Ctype.existential_constructor id with + | Some constructor -> + fprintf ppf + "@,\ + @[%s is an existential type bound by the constructor %s.@ It is only \ + known in the scope of the pattern that matches %s.@]" + (Ident.name id) constructor constructor + | None -> + fprintf ppf "@,@[The type constructor@;<1 2>%a@ would escape its scope@]" + path p) + | _ -> + fprintf ppf "@,@[The type constructor@;<1 2>%a@ would escape its scope@]" + path p + let explanation unif t3 t4 ppf = match (t3.desc, t4.desc) with | Ttuple [], Tvar _ | Tvar _, Ttuple [] -> fprintf ppf "@,Self type cannot escape its class" | Tconstr (p, _, _), Tvar _ when unif && t4.level < Path.binding_time p -> - fprintf ppf "@,@[The type constructor@;<1 2>%a@ would escape its scope@]" - path p + escape_explanation ppf p | Tvar _, Tconstr (p, _, _) when unif && t3.level < Path.binding_time p -> - fprintf ppf "@,@[The type constructor@;<1 2>%a@ would escape its scope@]" - path p + escape_explanation ppf p | Tvar _, Tunivar _ | Tunivar _, Tvar _ -> fprintf ppf "@,The universal variable %a would escape its scope" type_expr (if is_Tunivar t3 then t3 else t4) diff --git a/tests/analysis_tests/tests/src/HoverExistential.res b/tests/analysis_tests/tests/src/HoverExistential.res new file mode 100644 index 0000000000..6dc948f566 --- /dev/null +++ b/tests/analysis_tests/tests/src/HoverExistential.res @@ -0,0 +1,4 @@ +type rec any = Any(array<'a>, 'a => string): any + +let showAll = (Any(xs, f)) => xs->Array.map(f) +// ^hov diff --git a/tests/analysis_tests/tests/src/expected/HoverExistential.res.txt b/tests/analysis_tests/tests/src/expected/HoverExistential.res.txt new file mode 100644 index 0000000000..43bf2c3f90 --- /dev/null +++ b/tests/analysis_tests/tests/src/expected/HoverExistential.res.txt @@ -0,0 +1,5 @@ +Hover src/HoverExistential.res 2:19 +{ + "contents": { "kind": "markdown", "value": "```rescript\narray<$a>\n```" } +} + diff --git a/tests/build_tests/super_errors/expected/gadt_existential_escape.res.expected b/tests/build_tests/super_errors/expected/gadt_existential_escape.res.expected new file mode 100644 index 0000000000..3544ede550 --- /dev/null +++ b/tests/build_tests/super_errors/expected/gadt_existential_escape.res.expected @@ -0,0 +1,13 @@ + + We've found a bug for you! + /.../fixtures/gadt_existential_escape.res:3:23 + + 1 │ type rec any = Any('a): any + 2 │ + 3 │ let get = (Any(x)) => x + 4 │ + + This has type: $a + But it's expected to have type: 'a + $a is an existential type bound by the constructor Any. + It is only known in the scope of the pattern that matches Any. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/gadt_existential_nested_binding.res.expected b/tests/build_tests/super_errors/expected/gadt_existential_nested_binding.res.expected new file mode 100644 index 0000000000..57e1e2bee7 --- /dev/null +++ b/tests/build_tests/super_errors/expected/gadt_existential_nested_binding.res.expected @@ -0,0 +1,14 @@ + + We've found a bug for you! + /.../fixtures/gadt_existential_nested_binding.res:12:5 + + 10 ┆ } + 11 ┆ } + 12 ┆ x + 13 ┆ | Second(_) => assert(false) + 14 ┆ } + + This has type: $a + But it's expected to have type: 'a + $a is an existential type bound by the constructor First. + It is only known in the scope of the pattern that matches First. \ No newline at end of file diff --git a/tests/build_tests/super_errors/expected/gadt_existential_same_name.res.expected b/tests/build_tests/super_errors/expected/gadt_existential_same_name.res.expected new file mode 100644 index 0000000000..8fdf7ec2ea --- /dev/null +++ b/tests/build_tests/super_errors/expected/gadt_existential_same_name.res.expected @@ -0,0 +1,13 @@ + + We've found a bug for you! + /.../fixtures/gadt_existential_same_name.res:3:42 + + 1 │ type rec any = First('a): any | Second('a): any + 2 │ + 3 │ let same = (First(x), Second(y)) => x == y + 4 │ + + This has type: $a1 + But it's being compared to something of type: $a + + You can only compare things of the same type. \ No newline at end of file diff --git a/tests/build_tests/super_errors/fixtures/gadt_existential_escape.res b/tests/build_tests/super_errors/fixtures/gadt_existential_escape.res new file mode 100644 index 0000000000..528133f82a --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/gadt_existential_escape.res @@ -0,0 +1,3 @@ +type rec any = Any('a): any + +let get = (Any(x)) => x diff --git a/tests/build_tests/super_errors/fixtures/gadt_existential_nested_binding.res b/tests/build_tests/super_errors/fixtures/gadt_existential_nested_binding.res new file mode 100644 index 0000000000..159a4c84ee --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/gadt_existential_nested_binding.res @@ -0,0 +1,14 @@ +type rec any = First('a): any | Second('a): any + +let get = (v, w) => + switch v { + | First(x) => + module M = { + let inner = switch w { + | Second(y) => ignore(y) + | First(_) => () + } + } + x + | Second(_) => assert(false) + } diff --git a/tests/build_tests/super_errors/fixtures/gadt_existential_same_name.res b/tests/build_tests/super_errors/fixtures/gadt_existential_same_name.res new file mode 100644 index 0000000000..cb7f210c45 --- /dev/null +++ b/tests/build_tests/super_errors/fixtures/gadt_existential_same_name.res @@ -0,0 +1,3 @@ +type rec any = First('a): any | Second('a): any + +let same = (First(x), Second(y)) => x == y