summaryrefslogtreecommitdiff
path: root/typing
diff options
context:
space:
mode:
Diffstat (limited to 'typing')
-rw-r--r--typing/ctype.ml190
-rw-r--r--typing/ctype.mli12
-rw-r--r--typing/parmatch.ml43
-rw-r--r--typing/printtyp.ml6
-rw-r--r--typing/printtyp.mli1
-rw-r--r--typing/typeclass.ml26
-rw-r--r--typing/typeclass.mli6
-rw-r--r--typing/typecore.ml492
-rw-r--r--typing/typecore.mli7
-rw-r--r--typing/typedtree.mli2
-rw-r--r--typing/typemod.ml75
-rw-r--r--typing/typemod.mli5
-rw-r--r--typing/typetexp.ml6
-rw-r--r--typing/typetexp.mli1
14 files changed, 541 insertions, 331 deletions
diff --git a/typing/ctype.ml b/typing/ctype.ml
index 8cebcf1d68..bec19ae528 100644
--- a/typing/ctype.ml
+++ b/typing/ctype.ml
@@ -307,6 +307,11 @@ let can_assume_injective () =
| Expression | Subst -> false
| Pattern { assume_injective } -> assume_injective
+let in_counterexample () =
+ match !umode with
+ | Expression | Subst -> false
+ | Pattern { allow_recursive_equations } -> allow_recursive_equations
+
let allow_recursive_equations () =
!Clflags.recursive_types
|| match !umode with
@@ -1210,20 +1215,22 @@ let instance_list schl =
For_copy.with_scope (fun copy_scope ->
List.map (fun t -> copy copy_scope t) schl)
-let reified_var_counter = ref Vars.empty
-let reset_reified_var_counter () =
- reified_var_counter := Vars.empty
-
-(* names given to new type constructors.
- Used for existential types and
- local constraints *)
-let get_new_abstract_name s =
- let index =
- try Vars.find s !reified_var_counter + 1
- with Not_found -> 0 in
- reified_var_counter := Vars.add s index !reified_var_counter;
- if index = 0 && s <> "" && s.[String.length s - 1] <> '$' then s else
- Printf.sprintf "%s%d" s index
+(* Create unique names to new type constructors.
+ Used for existential types and local constraints. *)
+let get_new_abstract_name env s =
+ (* unique names are needed only for error messages *)
+ if in_counterexample () then s else
+ let name index =
+ if index = 0 && s <> "" && s.[String.length s - 1] <> '$' then s else
+ Printf.sprintf "%s%d" s index
+ in
+ let check index =
+ match Env.find_type_by_name (Longident.Lident (name index)) env with
+ | _ -> false
+ | exception Not_found -> true
+ in
+ let index = Misc.find_first_mono check in
+ name index
let new_local_type ?(loc = Location.none) ?manifest_and_scope () =
let manifest, expansion_scope =
@@ -1267,7 +1274,7 @@ let instance_constructor existential_treatment cstr =
let decl = new_local_type () in
let name = existential_name cstr existential in
let (id, new_env) =
- Env.enter_type (get_new_abstract_name name) decl !env
+ Env.enter_type (get_new_abstract_name !env name) decl !env
~scope:fresh_constr_scope in
env := new_env;
let to_unify = newty (Tconstr (Path.Pident id,[],ref Mnil)) in
@@ -2163,7 +2170,7 @@ let reify env t =
let name = match name with Some s -> "$'"^s | _ -> "$" in
let decl = new_local_type () in
let (id, new_env) =
- Env.enter_type (get_new_abstract_name name) decl !env
+ Env.enter_type (get_new_abstract_name !env name) decl !env
~scope:fresh_constr_scope in
let path = Path.Pident id in
let t = newty2 ~level:lev (Tconstr (path,[],ref Mnil)) in
@@ -5038,69 +5045,108 @@ let rec arity ty =
| _ -> 0
(* Check for non-generalizable type variables *)
-exception Nongen
-let visited = ref TypeSet.empty
-
-let rec nongen_schema_rec env ty =
- if TypeSet.mem ty !visited then () else begin
- visited := TypeSet.add ty !visited;
- match get_desc ty with
- Tvar _ when get_level ty <> generic_level ->
- raise Nongen
- | Tconstr _ ->
- let old = !visited in
- begin try iter_type_expr (nongen_schema_rec env) ty
- with Nongen -> try
- visited := old;
- nongen_schema_rec env (try_expand_head try_expand_safe env ty)
- with Cannot_expand ->
- raise Nongen
- end
- | Tfield(_, kind, t1, t2) ->
- if field_kind_repr kind = Fpublic then
- nongen_schema_rec env t1;
- nongen_schema_rec env t2
- | Tvariant row ->
- iter_row (nongen_schema_rec env) row;
- if not (static_row row) then nongen_schema_rec env (row_more row)
- | _ ->
- iter_type_expr (nongen_schema_rec env) ty
- end
+let add_nongen_vars_in_schema =
+ let rec loop env ((visited, weak_set) as acc) ty =
+ if TypeSet.mem ty visited
+ then acc
+ else begin
+ let visited = TypeSet.add ty visited in
+ match get_desc ty with
+ | Tvar _ when get_level ty <> generic_level ->
+ visited, TypeSet.add ty weak_set
+ | Tconstr _ ->
+ let (_, unexpanded_candidate) as unexpanded_candidate' =
+ fold_type_expr
+ (loop env)
+ (visited, weak_set)
+ ty
+ in
+ (* Using `==` is okay because `loop` will return the original set
+ when it does not change it. Similarly, `TypeSet.add` will return
+ the original set if the element is already present. *)
+ if unexpanded_candidate == weak_set
+ then (visited, weak_set)
+ else begin
+ match
+ loop env (visited, weak_set)
+ (try_expand_head try_expand_safe env ty)
+ with
+ | exception Cannot_expand -> unexpanded_candidate'
+ | expanded_result -> expanded_result
+ end
+ | Tfield(_, kind, t1, t2) ->
+ let visited, weak_set =
+ match field_kind_repr kind with
+ | Fpublic -> loop env (visited, weak_set) t1
+ | _ -> visited, weak_set
+ in
+ loop env (visited, weak_set) t2
+ | Tvariant row ->
+ let visited, weak_set =
+ fold_row (loop env) (visited, weak_set) row
+ in
+ if not (static_row row)
+ then loop env (visited, weak_set) (row_more row)
+ else (visited, weak_set)
+ | _ ->
+ fold_type_expr (loop env) (visited, weak_set) ty
+ end
+ in
+ fun env acc ty ->
+ let _, result = loop env (TypeSet.empty, acc) ty in
+ result
-(* Return whether all variables of type [ty] are generic. *)
-let nongen_schema env ty =
- visited := TypeSet.empty;
- try
- nongen_schema_rec env ty;
- visited := TypeSet.empty;
- false
- with Nongen ->
- visited := TypeSet.empty;
- true
+(* Return all non-generic variables of [ty]. *)
+let nongen_vars_in_schema env ty =
+ let result = add_nongen_vars_in_schema env TypeSet.empty ty in
+ if TypeSet.is_empty result
+ then None
+ else Some result
(* Check that all type variables are generalizable *)
(* Use Env.empty to prevent expansion of recursively defined object types;
cf. typing-poly/poly.ml *)
-let rec nongen_class_type = function
- | Cty_constr (_, params, _) ->
- List.exists (nongen_schema Env.empty) params
- | Cty_signature sign ->
- nongen_schema Env.empty sign.csig_self
- || nongen_schema Env.empty sign.csig_self_row
- || Meths.exists
- (fun _ (_, _, ty) -> nongen_schema Env.empty ty)
- sign.csig_meths
- || Vars.exists
- (fun _ (_, _, ty) -> nongen_schema Env.empty ty)
- sign.csig_vars
- | Cty_arrow (_, ty, cty) ->
- nongen_schema Env.empty ty
- || nongen_class_type cty
+let nongen_class_type =
+ let add_nongen_vars_in_schema' ty weak_set =
+ add_nongen_vars_in_schema Env.empty weak_set ty
+ in
+ let add_nongen_vars_in_schema_fold fold m weak_set =
+ let f _key (_,_,ty) weak_set =
+ add_nongen_vars_in_schema Env.empty weak_set ty
+ in
+ fold f m weak_set
+ in
+ let rec nongen_class_type cty weak_set =
+ match cty with
+ | Cty_constr (_, params, _) ->
+ List.fold_left
+ (add_nongen_vars_in_schema Env.empty)
+ weak_set
+ params
+ | Cty_signature sign ->
+ weak_set
+ |> add_nongen_vars_in_schema' sign.csig_self
+ |> add_nongen_vars_in_schema' sign.csig_self_row
+ |> add_nongen_vars_in_schema_fold Meths.fold sign.csig_meths
+ |> add_nongen_vars_in_schema_fold Vars.fold sign.csig_vars
+ | Cty_arrow (_, ty, cty) ->
+ add_nongen_vars_in_schema' ty weak_set
+ |> nongen_class_type cty
+ in
+ nongen_class_type
let nongen_class_declaration cty =
- List.exists (nongen_schema Env.empty) cty.cty_params
- || nongen_class_type cty.cty_type
-
+ List.fold_left
+ (add_nongen_vars_in_schema Env.empty)
+ TypeSet.empty
+ cty.cty_params
+ |> nongen_class_type cty.cty_type
+
+let nongen_vars_in_class_declaration cty =
+ let result = nongen_class_declaration cty in
+ if TypeSet.is_empty result
+ then None
+ else Some result
(* Normalize a type before printing, saving... *)
(* Cannot use mark_type because deep_occur uses it too *)
diff --git a/typing/ctype.mli b/typing/ctype.mli
index 0806250ebd..d252f8a622 100644
--- a/typing/ctype.mli
+++ b/typing/ctype.mli
@@ -414,13 +414,12 @@ val nondep_cltype_declaration:
val is_contractive: Env.t -> Path.t -> bool
val normalize_type: type_expr -> unit
-val nongen_schema: Env.t -> type_expr -> bool
- (* Check whether the given type scheme contains no non-generic
- type variables *)
+val nongen_vars_in_schema: Env.t -> type_expr -> Btype.TypeSet.t option
+ (* Return any non-generic variables in the type scheme *)
-val nongen_class_declaration: class_declaration -> bool
- (* Check whether the given class type contains no non-generic
- type variables. Uses the empty environment. *)
+val nongen_vars_in_class_declaration:class_declaration -> Btype.TypeSet.t option
+ (* Return any non-generic variables in the class type.
+ Uses the empty environment. *)
type variable_kind = Row_variable | Type_variable
type closed_class_failure = {
@@ -448,7 +447,6 @@ val collapse_conj_params: Env.t -> type_expr list -> unit
val get_current_level: unit -> int
val wrap_trace_gadt_instances: Env.t -> ('a -> 'b) -> 'a -> 'b
-val reset_reified_var_counter: unit -> unit
val immediacy : Env.t -> type_expr -> Type_immediacy.t
diff --git a/typing/parmatch.ml b/typing/parmatch.ml
index 138e9cea44..afb9f10777 100644
--- a/typing/parmatch.ml
+++ b/typing/parmatch.ml
@@ -2312,52 +2312,17 @@ let pattern_stable_vars ns p =
(* All identifier paths that appear in an expression that occurs
as a clause right hand side or guard.
-
- The function is rather complex due to the compilation of
- unpack patterns by introducing code in rhs expressions
- and **guards**.
-
- For pattern (module M:S) -> e the code is
- let module M_mod = unpack M .. in e
-
- Hence M is "free" in e iff M_mod is free in e.
-
- Not doing so will yield excessive warning in
- (module (M:S) } ...) when true -> ....
- as M is always present in
- let module M_mod = unpack M .. in true
*)
let all_rhs_idents exp =
let ids = ref Ident.Set.empty in
-(* Very hackish, detect unpack pattern compilation
- and perform "indirect check for them" *)
- let is_unpack exp =
- List.exists
- (fun attr -> attr.Parsetree.attr_name.txt = "#modulepat")
- exp.exp_attributes in
let open Tast_iterator in
let expr_iter iter exp =
- (match exp.exp_desc with
- | Texp_ident (path, _lid, _descr) ->
+ match exp.exp_desc with
+ | Texp_ident (path, _lid, _descr) ->
List.iter (fun id -> ids := Ident.Set.add id !ids) (Path.heads path)
- (* Use default iterator methods for rest of match.*)
- | _ -> Tast_iterator.default_iterator.expr iter exp);
-
- if is_unpack exp then begin match exp.exp_desc with
- | Texp_letmodule
- (id_mod,_,_,
- {mod_desc=
- Tmod_unpack ({exp_desc=Texp_ident (Path.Pident id_exp,_,_)},_)},
- _) ->
- assert (Ident.Set.mem id_exp !ids) ;
- begin match id_mod with
- | Some id_mod when not (Ident.Set.mem id_mod !ids) ->
- ids := Ident.Set.remove id_exp !ids
- | _ -> ()
- end
- | _ -> assert false
- end
+ (* Use default iterator methods for rest of match.*)
+ | _ -> Tast_iterator.default_iterator.expr iter exp
in
let iterator = {Tast_iterator.default_iterator with expr = expr_iter} in
iterator.expr iterator exp;
diff --git a/typing/printtyp.ml b/typing/printtyp.ml
index b14b4feab8..42b11a4d21 100644
--- a/typing/printtyp.ml
+++ b/typing/printtyp.ml
@@ -1123,7 +1123,7 @@ let rec tree_of_typexp mode ty =
let tpath = tree_of_best_type_path p p' in
Otyp_constr (tpath, tree_of_typlist mode tyl')
| Tvariant row ->
- let Row {fields; name; closed} = row_repr row in
+ let Row {fields; name; closed; _} = row_repr row in
let fields =
if closed then
List.filter (fun (_, f) -> row_field_repr f <> Rabsent)
@@ -1281,9 +1281,11 @@ let shared_type_scheme ppf ty =
prepare_type ty;
typexp Type_scheme ppf ty
+let prepared_type_scheme ppf ty = typexp Type_scheme ppf ty
+
let type_scheme ppf ty =
prepare_for_printing [ty];
- typexp Type_scheme ppf ty
+ prepared_type_scheme ppf ty
let type_path ppf p =
let (p', s) = best_type_path p in
diff --git a/typing/printtyp.mli b/typing/printtyp.mli
index eaa3599183..838a54f362 100644
--- a/typing/printtyp.mli
+++ b/typing/printtyp.mli
@@ -119,6 +119,7 @@ val prepared_type_expr: formatter -> type_expr -> unit
val constructor_arguments: formatter -> constructor_arguments -> unit
val tree_of_type_scheme: type_expr -> out_type
val type_scheme: formatter -> type_expr -> unit
+val prepared_type_scheme: formatter -> type_expr -> unit
val shared_type_scheme: formatter -> type_expr -> unit
(** [shared_type_scheme] is very similar to [type_scheme], but does not reset
the printing context first. This is intended to be used in cases where the
diff --git a/typing/typeclass.ml b/typing/typeclass.ml
index 3b4c354266..9450e14fde 100644
--- a/typing/typeclass.ml
+++ b/typing/typeclass.ml
@@ -94,7 +94,11 @@ type error =
| Class_match_failure of Ctype.class_match_failure list
| Unbound_val of string
| Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure
- | Non_generalizable_class of Ident.t * Types.class_declaration
+ | Non_generalizable_class of
+ { id : Ident.t
+ ; clty : Types.class_declaration
+ ; nongen_vars : type_expr list
+ }
| Cannot_coerce_self of type_expr
| Non_collapsable_conjunction of
Ident.t * Types.class_declaration * Errortrace.unification_error
@@ -1171,7 +1175,7 @@ and class_expr_aux cl_num val_env met_env virt self_scope scl =
in
let partial =
let dummy = type_exp val_env (Ast_helper.Exp.unreachable ()) in
- Typecore.check_partial val_env pat.pat_type pat.pat_loc
+ Typecore.check_partial Modules_rejected val_env pat.pat_type pat.pat_loc
[{c_lhs = pat; c_guard = None; c_rhs = dummy}]
in
let cl =
@@ -1716,8 +1720,12 @@ let final_decl env define_class
List.iter Ctype.generalize cl_abbr.type_params;
Option.iter Ctype.generalize cl_abbr.type_manifest;
- if Ctype.nongen_class_declaration clty then
- raise(Error(cl.pci_loc, env, Non_generalizable_class (id, clty)));
+ Ctype.nongen_vars_in_class_declaration clty
+ |> Option.iter (fun vars ->
+ let nongen_vars = Btype.TypeSet.elements vars in
+ raise(Error(cl.pci_loc, env
+ , Non_generalizable_class { id; clty; nongen_vars }));
+ );
begin match
Ctype.closed_class clty.cty_params
@@ -2100,11 +2108,17 @@ let report_error env ppf = function
"@[<v>@[Some type variables are unbound in this type:@;<1 2>%t@]@ \
@[%a@]@]"
printer print_reason reason
- | Non_generalizable_class (id, clty) ->
+ | Non_generalizable_class {id; clty; nongen_vars } ->
+ let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2] in
+ Printtyp.prepare_for_printing nongen_vars;
fprintf ppf
"@[The type of this class,@ %a,@ \
- contains type variables that cannot be generalized@]"
+ contains the non-generalizable type variable(s): %a.@ %a@]"
(Printtyp.class_declaration id) clty
+ (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ")
+ Printtyp.prepared_type_scheme) nongen_vars
+ Misc.print_see_manual manual_ref
+
| Cannot_coerce_self ty ->
fprintf ppf
"@[The type of self cannot be coerced to@ \
diff --git a/typing/typeclass.mli b/typing/typeclass.mli
index 4b6f734f8a..b83d56fc02 100644
--- a/typing/typeclass.mli
+++ b/typing/typeclass.mli
@@ -112,7 +112,11 @@ type error =
| Class_match_failure of Ctype.class_match_failure list
| Unbound_val of string
| Unbound_type_var of (formatter -> unit) * Ctype.closed_class_failure
- | Non_generalizable_class of Ident.t * Types.class_declaration
+ | Non_generalizable_class of
+ { id : Ident.t
+ ; clty : Types.class_declaration
+ ; nongen_vars : type_expr list
+ }
| Cannot_coerce_self of type_expr
| Non_collapsable_conjunction of
Ident.t * Types.class_declaration * Errortrace.unification_error
diff --git a/typing/typecore.ml b/typing/typecore.ml
index 220382a1d7..16085f54ea 100644
--- a/typing/typecore.ml
+++ b/typing/typecore.ml
@@ -40,12 +40,6 @@ type type_expected = {
explanation: type_forcing_context option;
}
-type to_unpack = {
- tu_name: string Location.loc;
- tu_loc: Location.t;
- tu_uid: Uid.t
-}
-
module Datatype_kind = struct
type t = Record | Variant
@@ -107,6 +101,7 @@ type error =
| Apply_non_function of {
funct : Typedtree.expression;
func_ty : type_expr;
+ res_ty : type_expr;
previous_arg_loc : Location.t;
extra_arg_loc : Location.t;
}
@@ -231,6 +226,15 @@ type recarg =
| Required
| Rejected
+(* Whether or not patterns of the form (module M) are accepted. (If they are,
+ the idents will be created at the provided scope.) When module patterns are
+ allowed, the caller should take care to check that the introduced module
+ bindings' types don't escape their scope; see the callsites in [type_let]
+ and [type_cases] for examples.
+*)
+type module_patterns_restriction =
+ | Modules_allowed of { scope : int }
+ | Modules_rejected
let mk_expected ?explanation ty = { ty; explanation; }
@@ -454,11 +458,16 @@ type pattern_variable =
}
type module_variable =
- string loc * Location.t
+ {
+ mv_id: Ident.t;
+ mv_name: string Location.loc;
+ mv_loc: Location.t;
+ mv_uid: Uid.t
+ }
let pattern_variables = ref ([] : pattern_variable list)
let pattern_force = ref ([] : (unit -> unit) list)
-let allow_modules = ref false
+let allow_modules = ref Modules_rejected
let module_variables = ref ([] : module_variable list)
let reset_pattern allow =
pattern_variables := [];
@@ -482,19 +491,33 @@ let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name ty
if List.exists (fun {pv_id; _} -> Ident.name pv_id = name.txt)
!pattern_variables
then raise(Error(loc, Env.empty, Multiply_bound_variable name.txt));
- let id = Ident.create_local name.txt in
+ let id =
+ if is_module then begin
+ (* Unpack patterns result in both a module declaration and a value
+ variable of the same name being entered into the environment. (The
+ module is via [module_variables], and the variable is via
+ [pattern_variables].) *)
+ match !allow_modules with
+ | Modules_rejected ->
+ raise (Error (loc, Env.empty, Modules_not_allowed));
+ | Modules_allowed { scope } ->
+ let id = Ident.create_scoped name.txt ~scope in
+ module_variables :=
+ { mv_id = id;
+ mv_name = name;
+ mv_loc = loc;
+ mv_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+ } :: !module_variables;
+ id
+ end else
+ Ident.create_local name.txt
+ in
pattern_variables :=
{pv_id = id;
pv_type = ty;
pv_loc = loc;
pv_as_var = is_as_variable;
pv_attributes = attrs} :: !pattern_variables;
- if is_module then begin
- (* Note: unpack patterns enter a variable of the same name *)
- if not !allow_modules then
- raise (Error (loc, Env.empty, Modules_not_allowed));
- module_variables := (name, loc) :: !module_variables
- end;
id
let sort_pattern_variables vs =
@@ -1348,7 +1371,7 @@ type 'case_pattern half_typed_case =
untyped_case: Parsetree.case;
branch_env: Env.t;
pat_vars: pattern_variable list;
- unpacks: module_variable list;
+ module_vars: module_variable list;
contains_gadt: bool; }
let rec has_literal_pattern p = match p.ppat_desc with
@@ -1502,6 +1525,9 @@ and type_pat_aux
pat_env = !env }
| Some s ->
let v = { name with txt = s } in
+ (* We're able to pass ~is_module:true here without an error because
+ [Ppat_unpack] is a case identified by [may_contain_modules]. See
+ the comment on [may_contain_modules]. *)
let id = enter_variable loc v t ~is_module:true sp.ppat_attributes in
rvp {
pat_desc = Tpat_var (id, v);
@@ -1840,18 +1866,50 @@ let add_pattern_variables ?check ?check_as env pv =
)
pv env
-let type_pattern category ~lev env spat expected_ty =
- reset_pattern true;
+let add_module_variables env module_variables =
+ List.fold_left (fun env { mv_id; mv_loc; mv_name; mv_uid } ->
+ Typetexp.TyVarEnv.with_local_scope begin fun () ->
+ (* This code is parallel to the typing of Pexp_letmodule. However we
+ omit the call to [Mtype.lower_nongen] as it's not necessary here.
+ For Pexp_letmodule, the call to [type_module] is done in a raised
+ level and so needs to be modified to have the correct, outer level.
+ Here, on the other hand, we're calling [type_module] outside the
+ raised level, so there's no extra step to take.
+ *)
+ let modl, md_shape =
+ !type_module env
+ Ast_helper.(
+ Mod.unpack ~loc:mv_loc
+ (Exp.ident ~loc:mv_name.loc
+ (mkloc (Longident.Lident mv_name.txt)
+ mv_name.loc)))
+ in
+ let pres =
+ match modl.mod_type with
+ | Mty_alias _ -> Mp_absent
+ | _ -> Mp_present
+ in
+ let md =
+ { md_type = modl.mod_type; md_attributes = [];
+ md_loc = mv_name.loc;
+ md_uid = mv_uid; }
+ in
+ Env.add_module_declaration ~shape:md_shape ~check:true mv_id pres md env
+ end
+ ) env module_variables
+
+let type_pattern category ~lev env spat expected_ty allow_modules =
+ reset_pattern allow_modules;
let new_env = ref env in
let pat = type_pat category ~lev new_env spat expected_ty in
let pvs = get_ref pattern_variables in
- let unpacks = get_ref module_variables in
- (pat, !new_env, get_ref pattern_force, pvs, unpacks)
+ let mvs = get_ref module_variables in
+ (pat, !new_env, get_ref pattern_force, pvs, mvs)
let type_pattern_list
- category no_existentials env spatl expected_tys allow
+ category no_existentials env spatl expected_tys allow_modules
=
- reset_pattern allow;
+ reset_pattern allow_modules;
let new_env = ref env in
let type_pat (attrs, pat) ty =
Builtin_attributes.warning_scope ~ppwarning:false attrs
@@ -1861,17 +1919,11 @@ let type_pattern_list
in
let patl = List.map2 type_pat spatl expected_tys in
let pvs = get_ref pattern_variables in
- let unpacks =
- List.map (fun (name, loc) ->
- {tu_name = name; tu_loc = loc;
- tu_uid = Uid.mk ~current_unit:(Env.get_unit_name ())}
- ) (get_ref module_variables)
- in
- let new_env = add_pattern_variables !new_env pvs in
- (patl, new_env, get_ref pattern_force, pvs, unpacks)
+ let mvs = get_ref module_variables in
+ (patl, !new_env, get_ref pattern_force, pvs, mvs)
let type_class_arg_pattern cl_num val_env met_env l spat =
- reset_pattern false;
+ reset_pattern Modules_rejected;
let nv = newvar () in
let pat =
type_pat Value ~no_existentials:In_class_args (ref val_env) spat nv in
@@ -1918,7 +1970,7 @@ let type_class_arg_pattern cl_num val_env met_env l spat =
let type_self_pattern env spat =
let open Ast_helper in
let spat = Pat.mk(Ppat_alias (spat, mknoloc "selfpat-*")) in
- reset_pattern false;
+ reset_pattern Modules_rejected;
let nv = newvar() in
let pat =
type_pat Value ~no_existentials:In_self_pattern (ref env) spat nv in
@@ -2222,7 +2274,8 @@ let check_counter_example_pat ~counter_example_args
(* this function is passed to Partial.parmatch
to type check gadt nonexhaustiveness *)
-let partial_pred ~lev ~splitting_mode ?(explode=0) env expected_ty p =
+let partial_pred ~lev ~allow_modules ~splitting_mode ?(explode=0)
+ env expected_ty p =
let env = ref env in
let state = save_state env in
let counter_example_args =
@@ -2231,7 +2284,7 @@ let partial_pred ~lev ~splitting_mode ?(explode=0) env expected_ty p =
explosion_fuel = explode;
} in
try
- reset_pattern true;
+ reset_pattern allow_modules;
let typed_p =
check_counter_example_pat ~lev ~counter_example_args env p expected_ty in
set_state state env;
@@ -2241,17 +2294,22 @@ let partial_pred ~lev ~splitting_mode ?(explode=0) env expected_ty p =
set_state state env;
None
-let check_partial ?(lev=get_current_level ()) env expected_ty loc cases =
+let check_partial
+ ?(lev=get_current_level ()) allow_modules env expected_ty loc cases
+ =
let explode = match cases with [_] -> 5 | _ -> 0 in
let splitting_mode = Refine_or {inside_nonsplit_or = false} in
Parmatch.check_partial
- (partial_pred ~lev ~splitting_mode ~explode env expected_ty) loc cases
+ (partial_pred ~lev ~allow_modules ~splitting_mode ~explode env expected_ty)
+ loc cases
-let check_unused ?(lev=get_current_level ()) env expected_ty cases =
+let check_unused
+ ?(lev=get_current_level ()) allow_modules env expected_ty cases
+ =
Parmatch.check_unused
(fun refute pat ->
match
- partial_pred ~lev ~splitting_mode:Backtrack_or ~explode:5
+ partial_pred ~lev ~allow_modules ~splitting_mode:Backtrack_or ~explode:5
env expected_ty pat
with
Some pat' when refute ->
@@ -2655,6 +2713,19 @@ let check_partial_application ~statement exp =
| _ ->
doit ()
+let pattern_needs_partial_application_check p =
+ let rec check : type a. a general_pattern -> bool = fun p ->
+ not (List.exists (function (Tpat_constraint _, _, _) -> true | _ -> false)
+ p.pat_extra) &&
+ match p.pat_desc with
+ | Tpat_any -> true
+ | Tpat_exception _ -> true
+ | Tpat_or (p1, p2, _) -> check p1 && check p2
+ | Tpat_value p -> check (p :> value general_pattern)
+ | _ -> false
+ in
+ check p
+
(* Check that a type is generalizable at some level *)
let generalizable level ty =
let rec check ty =
@@ -2738,6 +2809,22 @@ let may_contain_gadts p =
| _ -> false)
p
+(* There are various things that we need to do in presence of module patterns
+ that aren't required if there are none. Most notably, we need to ensure the
+ modules are entered at the appropriate scope. The caller should use
+ [may_contain_modules] as an indication to set up the proper scope handling
+ code (via [allow_modules]) to permit module patterns.
+ The class of patterns identified here should stay in sync with the patterns
+ whose typing involves [enter_variable ~is_module:true], as these calls
+ will error if the scope handling isn't set up.
+*)
+let may_contain_modules p =
+ exists_ppat
+ (function
+ | {ppat_desc = Ppat_unpack _} -> true
+ | _ -> false)
+ p
+
let check_absent_variant env =
iter_general_pattern { f = fun (type k) (pat : k general_pattern) ->
match pat.pat_desc with
@@ -2858,6 +2945,45 @@ let may_lower_contravariant_then_generalize env exp =
if maybe_expansive exp then lower_contravariant env exp.exp_type;
generalize exp.exp_type
+(* value binding elaboration *)
+
+let vb_exp_constraint {pvb_expr=expr; pvb_pat=pat; pvb_constraint=ct; _ } =
+ let open Ast_helper in
+ match ct with
+ | None -> expr
+ | Some {locally_abstract_univars=[]; typ } ->
+ begin match typ.ptyp_desc with
+ | Ptyp_poly _ -> expr
+ | _ ->
+ let loc = { expr.pexp_loc with Location.loc_ghost = true } in
+ Exp.constraint_ ~loc expr typ
+ end
+ | Some {locally_abstract_univars;typ} ->
+ let loc_start = pat.ppat_loc.Location.loc_start in
+ let loc = { expr.pexp_loc with loc_start; loc_ghost=true } in
+ let expr = Exp.constraint_ ~loc expr typ in
+ List.fold_right (Exp.newtype ~loc) locally_abstract_univars expr
+
+let vb_pat_constraint ({pvb_pat=pat; pvb_expr = exp; _ } as vb) =
+ vb.pvb_attributes,
+ let open Ast_helper in
+ match vb.pvb_constraint, pat.ppat_desc, exp.pexp_desc with
+ | Some {locally_abstract_univars=[]; typ }, _, _ ->
+ Pat.constraint_ ~loc:{pat.ppat_loc with Location.loc_ghost=true} pat typ
+ | Some {locally_abstract_univars; typ }, _, _ ->
+ let varified = Typ.varify_constructors locally_abstract_univars typ in
+ let t = Typ.poly ~loc:typ.ptyp_loc locally_abstract_univars varified in
+ let loc_end = typ.ptyp_loc.Location.loc_end in
+ let loc = { pat.ppat_loc with loc_end; loc_ghost=true } in
+ Pat.constraint_ ~loc pat t
+ | None, (Ppat_any | Ppat_constraint _), _ -> pat
+ | None, _, Pexp_coerce (_, _, sty)
+ | None, _, Pexp_constraint (_, sty) when !Clflags.principal ->
+ (* propagate type annotation to pattern,
+ to allow it to be generalized in -principal mode *)
+ Pat.constraint_ ~loc:{pat.ppat_loc with Location.loc_ghost=true} pat sty
+ | _ -> pat
+
let rec type_exp ?recarg env sexp =
(* We now delegate everything to type_expect *)
type_expect ?recarg env sexp (mk_expected (newvar ()))
@@ -2959,9 +3085,10 @@ and type_expect_
exp_attributes = sexp.pexp_attributes;
exp_env = env }
| Pexp_let(Nonrecursive,
- [{pvb_pat=spat; pvb_expr=sval; pvb_attributes=[]}], sbody)
+ [{pvb_pat=spat; pvb_attributes=[]; _ } as vb], sbody)
when may_contain_gadts spat ->
- (* TODO: allow non-empty attributes? *)
+ (* TODO: allow non-empty attributes? *)
+ let sval = vb_exp_constraint vb in
type_expect ?in_function env
{sexp with
pexp_desc = Pexp_match (sval, [Ast_helper.Exp.case spat sbody])}
@@ -2971,12 +3098,64 @@ and type_expect_
if rec_flag = Recursive then In_rec
else if List.compare_length_with spat_sexp_list 1 > 0 then In_group
else With_attributes in
- let (pat_exp_list, new_env, unpacks) =
- type_let existential_context env rec_flag spat_sexp_list true in
- let body = type_unpacks new_env unpacks sbody ty_expected_explained in
- let () =
- if rec_flag = Recursive then
- check_recursive_bindings env pat_exp_list
+ let may_contain_modules =
+ List.exists (fun pvb -> may_contain_modules pvb.pvb_pat) spat_sexp_list
+ in
+ let outer_level = get_current_level () in
+ let (pat_exp_list, body, _new_env) =
+ (* If the patterns contain module unpacks, there is a possibility that
+ the types of the let body or bound expressions mention types
+ introduced by those unpacks. The below code checks for scope escape
+ via both of these pathways (body, bound expressions).
+ *)
+ with_local_level_if may_contain_modules begin fun () ->
+ let allow_modules =
+ if may_contain_modules
+ then
+ let scope = create_scope () in
+ Modules_allowed { scope }
+ else Modules_rejected
+ in
+ let (pat_exp_list, new_env) =
+ type_let existential_context env rec_flag spat_sexp_list
+ allow_modules
+ in
+ let body = type_expect new_env sbody ty_expected_explained in
+ let () =
+ if rec_flag = Recursive then
+ check_recursive_bindings env pat_exp_list
+ in
+ (* The "bound expressions" component of the scope escape check.
+
+ This kind of scope escape is relevant only for recursive
+ module definitions.
+ *)
+ if rec_flag = Recursive && may_contain_modules then begin
+ List.iter
+ (fun vb ->
+ (* [type_let] already generalized bound expressions' types
+ in-place. We first take an instance before checking scope
+ escape at the outer level to avoid losing generality of
+ types added to [new_env].
+ *)
+ let bound_exp = vb.vb_expr in
+ generalize_structure_exp bound_exp;
+ let bound_exp_type = Ctype.instance bound_exp.exp_type in
+ let loc = proper_exp_loc bound_exp in
+ let outer_var = newvar2 outer_level in
+ (* Checking unification within an environment extended with the
+ module bindings allows us to correctly accept more programs.
+ This environment allows unification to identify more cases
+ where a type introduced by the module is equal to a type
+ introduced at an outer scope. *)
+ unify_exp_types loc new_env bound_exp_type outer_var)
+ pat_exp_list
+ end;
+ (pat_exp_list, body, new_env)
+ end
+ ~post:(fun (_pat_exp_list, body, new_env) ->
+ (* The "body" component of the scope escape check. *)
+ unify_exp new_env body (newvar ()))
in
re {
exp_desc = Texp_let(rec_flag, pat_exp_list, body);
@@ -2988,12 +3167,13 @@ and type_expect_
assert(is_optional l); (* default allowed only with optional argument *)
let open Ast_helper in
let default_loc = default.pexp_loc in
+ let default_ghost = {default.pexp_loc with loc_ghost = true} in
let scases = [
Exp.case
- (Pat.construct ~loc:default_loc
+ (Pat.construct ~loc:default_ghost
(mknoloc (Longident.(Ldot (Lident "*predef*", "Some"))))
- (Some ([], Pat.var ~loc:default_loc (mknoloc "*sth*"))))
- (Exp.ident ~loc:default_loc (mknoloc (Longident.Lident "*sth*")));
+ (Some ([], Pat.var ~loc:default_ghost (mknoloc "*sth*"))))
+ (Exp.ident ~loc:default_ghost (mknoloc (Longident.Lident "*sth*")));
Exp.case
(Pat.construct ~loc:default_loc
@@ -3083,6 +3263,10 @@ and type_expect_
let cases, partial =
type_cases Computation env
arg.exp_type ty_expected_explained true loc caselist in
+ if
+ List.for_all (fun c -> pattern_needs_partial_application_check c.c_lhs)
+ cases
+ then check_partial_application ~statement:false arg;
re {
exp_desc = Texp_match(arg, cases, partial);
exp_loc = loc; exp_extra = [];
@@ -4556,6 +4740,7 @@ and type_application env funct sargs =
raise(Error(funct.exp_loc, env, Apply_non_function {
funct;
func_ty = expand_head env funct.exp_type;
+ res_ty = expand_head env ty_res;
previous_arg_loc;
extra_arg_loc = sarg.pexp_loc; }))
in
@@ -4821,64 +5006,6 @@ and type_statement ?explanation env sexp =
exp
end
-and type_unpacks ?(in_function : (Location.t * type_expr) option)
- env (unpacks : to_unpack list) sbody expected_ty =
- let ty = newvar() (* remember original level *)
- and exp_loc = { sbody.pexp_loc with loc_ghost = true }
- and exp_attributes = [Ast_helper.Attr.mk (mknoloc "#modulepat") (PStr [])]
- in
- let rec fold_unpacks env = function
- | [] ->
- (* ideally, we should catch Expr_type_clash errors
- in type_expect triggered by escaping identifiers from the local
- module and refine them into Scoping_let_module errors
- *)
- type_expect ?in_function env sbody expected_ty
- | unpack :: rem ->
- with_local_level begin fun () ->
- let name, modl, pres, id, extended_env =
- Typetexp.TyVarEnv.with_local_scope begin fun () ->
- let name = unpack.tu_name in
- let modl, md_shape =
- !type_module env
- Ast_helper.(
- Mod.unpack ~loc:unpack.tu_loc
- (Exp.ident ~loc:name.loc
- (mkloc (Longident.Lident name.txt) name.loc)))
- in
- Mtype.lower_nongen (get_level ty) modl.mod_type;
- let pres =
- match modl.mod_type with
- | Mty_alias _ -> Mp_absent
- | _ -> Mp_present
- in
- let scope = create_scope () in
- let md =
- { md_type = modl.mod_type; md_attributes = [];
- md_loc = name.loc;
- md_uid = unpack.tu_uid; }
- in
- let (id, extended_env) =
- Env.enter_module_declaration ~scope ~shape:md_shape
- name.txt pres md env
- in
- name, modl, pres, id, extended_env
- end
- in
- let body = fold_unpacks extended_env rem in
- Ctype.unify_var extended_env ty body.exp_type;
- re {
- exp_desc = Texp_letmodule(Some id, { name with txt = Some name.txt },
- pres, modl, body);
- exp_loc;
- exp_attributes;
- exp_extra = [];
- exp_type = ty;
- exp_env = env }
- end
- in
- fold_unpacks env unpacks
-
(* Typing of match cases *)
and type_cases
: type k . k pattern_category ->
@@ -4892,6 +5019,8 @@ and type_cases
let contains_polyvars = List.exists contains_polymorphic_variant patterns in
let erase_either = contains_polyvars && contains_variant_either ty_arg in
let may_contain_gadts = List.exists may_contain_gadts patterns in
+ let may_contain_modules = List.exists may_contain_modules patterns in
+ let create_inner_level = may_contain_gadts || may_contain_modules in
let ty_arg =
if (may_contain_gadts || erase_either) && not !Clflags.principal
then correct_levels ty_arg else ty_arg
@@ -4908,8 +5037,18 @@ and type_cases
| _ -> true
in
let outer_level = get_current_level () in
- with_local_level_iter_if may_contain_gadts begin fun () ->
+ with_local_level_iter_if create_inner_level begin fun () ->
let lev = get_current_level () in
+ let allow_modules =
+ if may_contain_modules
+ then
+ (* The corresponding check for scope escape is done together with
+ the check for GADT-induced existentials by
+ [with_local_level_iter_if create_inner_level].
+ *)
+ Modules_allowed { scope = lev }
+ else Modules_rejected
+ in
let take_partial_instance =
if erase_either
then Some false else None
@@ -4930,8 +5069,8 @@ and type_cases
with_local_level ~post:generalize_structure
(fun () -> instance ?partial:take_partial_instance ty_arg)
in
- let (pat, ext_env, force, pvs, unpacks) =
- type_pattern category ~lev env pc_lhs ty_arg
+ let (pat, ext_env, force, pvs, mvs) =
+ type_pattern category ~lev env pc_lhs ty_arg allow_modules
in
pattern_force := force @ !pattern_force;
{ typed_pat = pat;
@@ -4939,7 +5078,7 @@ and type_cases
untyped_case = case;
branch_env = ext_env;
pat_vars = pvs;
- unpacks;
+ module_vars = mvs;
contains_gadt = contains_gadt (as_comp_pattern category pat); }
end
~post: begin fun htc ->
@@ -4998,7 +5137,8 @@ and type_cases
let ty_res' = instance ty_res in
let cases = with_local_level_if_principal ~post:ignore begin fun () ->
List.map
- (fun { typed_pat = pat; branch_env = ext_env; pat_vars = pvs; unpacks;
+ (fun { typed_pat = pat; branch_env = ext_env;
+ pat_vars = pvs; module_vars = mvs;
untyped_case = {pc_lhs = _; pc_guard; pc_rhs};
contains_gadt; _ } ->
let ext_env =
@@ -5012,12 +5152,7 @@ and type_cases
~check:(fun s -> Warnings.Unused_var_strict s)
~check_as:(fun s -> Warnings.Unused_var s)
in
- let unpacks =
- List.map (fun (name, loc) ->
- {tu_name = name; tu_loc = loc;
- tu_uid = Uid.mk ~current_unit:(Env.get_unit_name ())}
- ) unpacks
- in
+ let ext_env = add_module_variables ext_env mvs in
let ty_expected =
if contains_gadt && not !Clflags.principal then
(* Take a generic copy of [ty_res] again to allow propagation of
@@ -5029,12 +5164,12 @@ and type_cases
| None -> None
| Some scond ->
Some
- (type_unpacks ext_env unpacks scond
+ (type_expect ext_env scond
(mk_expected ~explanation:When_guard Predef.type_bool))
in
let exp =
- type_unpacks ?in_function ext_env
- unpacks pc_rhs (mk_expected ?explanation ty_expected)
+ type_expect ?in_function ext_env
+ pc_rhs (mk_expected ?explanation ty_expected)
in
{
c_lhs = pat;
@@ -5059,7 +5194,7 @@ and type_cases
raise (Error (loc, env, No_value_clauses));
let partial =
if partial_flag then
- check_partial ~lev env ty_arg_check loc val_cases
+ check_partial ~lev allow_modules env ty_arg_check loc val_cases
else
Partial
in
@@ -5068,8 +5203,8 @@ and type_cases
check_absent_variant branch_env (as_comp_pattern category typed_pat)
) half_typed_cases;
with_level_if delayed ~level:lev begin fun () ->
- check_unused ~lev env ty_arg_check val_cases ;
- check_unused ~lev env Predef.type_exn exn_cases ;
+ check_unused ~lev allow_modules env ty_arg_check val_cases ;
+ check_unused ~lev allow_modules env Predef.type_exn exn_cases ;
end;
Parmatch.check_ambiguous_bindings val_cases ;
Parmatch.check_ambiguous_bindings exn_cases
@@ -5087,34 +5222,20 @@ and type_cases
(* Typing of let bindings *)
and type_let ?check ?check_strict
- existential_context env rec_flag spat_sexp_list allow =
- let spatl =
- List.map
- (fun {pvb_pat=spat; pvb_expr=sexp; pvb_attributes=attrs} ->
- attrs,
- match spat.ppat_desc, sexp.pexp_desc with
- (Ppat_any | Ppat_constraint _), _ -> spat
- | _, Pexp_coerce (_, _, sty)
- | _, Pexp_constraint (_, sty) when !Clflags.principal ->
- (* propagate type annotation to pattern,
- to allow it to be generalized in -principal mode *)
- Ast_helper.Pat.constraint_
- ~loc:{spat.ppat_loc with Location.loc_ghost=true}
- spat
- sty
- | _ -> spat)
- spat_sexp_list in
+ existential_context env rec_flag spat_sexp_list allow_modules =
+ let spatl = List.map vb_pat_constraint spat_sexp_list in
let attrs_list = List.map fst spatl in
let is_recursive = (rec_flag = Recursive) in
- let (pat_list, exp_list, new_env, unpacks, _pvs) =
+ let (pat_list, exp_list, new_env, mvs, _pvs) =
with_local_level begin fun () ->
if existential_context = At_toplevel then Typetexp.TyVarEnv.reset ();
- let (pat_list, new_env, force, pvs, unpacks) =
+ let (pat_list, new_env, force, pvs, mvs) =
with_local_level_if_principal begin fun () ->
let nvs = List.map (fun _ -> newvar ()) spatl in
- let (pat_list, _new_env, _force, _pvs, _unpacks as res) =
- type_pattern_list Value existential_context env spatl nvs allow in
+ let (pat_list, _new_env, _force, _pvs, _mvs as res) =
+ type_pattern_list
+ Value existential_context env spatl nvs allow_modules in
(* If recursive, first unify with an approximation of the
expression *)
if is_recursive then
@@ -5144,6 +5265,17 @@ and type_let ?check ?check_strict
List.iter (fun pat -> generalize_structure pat.pat_type) pat_list
end
in
+ (* Note [add_module_variables after checking expressions]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ Don't call [add_module_variables] here, because its use of
+ [type_module] will fail until after we have type-checked the expression
+ of the let. Example: [let m : (module S) = ... in let (module M) = m in
+ ...] We learn the signature [S] from the type of [m] in the RHS of the
+ second let, and we need that knowledge for [type_module] to succeed. If
+ we type-checked expressions before patterns, then we could call
+ [add_module_variables] here.
+ *)
+ let new_env = add_pattern_variables new_env pvs in
let pat_list =
List.map
(fun pat -> {pat with pat_type = instance pat.pat_type})
@@ -5153,10 +5285,18 @@ and type_let ?check ?check_strict
List.iter (fun f -> f()) force;
let exp_list =
- let exp_env = if is_recursive then new_env else env in
+ (* See Note [add_module_variables after checking expressions]
+ We can't defer type-checking module variables with recursive
+ definitions, so things like [let rec (module M) = m in ...] always
+ fail, even if the type of [m] is known.
+ *)
+ let exp_env =
+ if is_recursive then add_module_variables new_env mvs else env
+ in
type_let_def_wrap_warnings ?check ?check_strict ~is_recursive
~exp_env ~new_env ~spat_sexp_list ~attrs_list ~pat_list ~pvs
- (fun exp_env {pvb_expr=sexp; pvb_attributes; _} pat ->
+ (fun exp_env ({pvb_attributes; _} as vb) pat ->
+ let sexp = vb_exp_constraint vb in
match get_desc pat.pat_type with
| Tpoly (ty, tl) ->
let vars, ty' =
@@ -5166,21 +5306,13 @@ and type_let ?check ?check_strict
in
let exp =
Builtin_attributes.warning_scope pvb_attributes (fun () ->
- if rec_flag = Recursive then
- type_unpacks exp_env unpacks sexp (mk_expected ty')
- else
- type_expect exp_env sexp (mk_expected ty')
- )
+ type_expect exp_env sexp (mk_expected ty'))
in
exp, Some vars
| _ ->
let exp =
Builtin_attributes.warning_scope pvb_attributes (fun () ->
- if rec_flag = Recursive then
- type_unpacks exp_env unpacks sexp
- (mk_expected pat.pat_type)
- else
- type_expect exp_env sexp (mk_expected pat.pat_type))
+ type_expect exp_env sexp (mk_expected pat.pat_type))
in
exp, None)
in
@@ -5188,13 +5320,13 @@ and type_let ?check ?check_strict
(fun pat (attrs, exp) ->
Builtin_attributes.warning_scope ~ppwarning:false attrs
(fun () ->
- ignore(check_partial env pat.pat_type pat.pat_loc
- [case pat exp])
+ ignore(check_partial allow_modules env pat.pat_type pat.pat_loc
+ [case pat exp] : Typedtree.partial)
)
)
pat_list
(List.map2 (fun (attrs, _) (e, _) -> attrs, e) spatl exp_list);
- (pat_list, exp_list, new_env, unpacks,
+ (pat_list, exp_list, new_env, mvs,
List.map (fun pv -> { pv with pv_type = instance pv.pv_type}) pvs)
end
~post: begin fun (pat_list, exp_list, _, _, pvs) ->
@@ -5241,13 +5373,13 @@ and type_let ?check ?check_strict
| Tpat_alias ({pat_desc=Tpat_any}, _, _) -> ()
| _ -> raise(Error(pat.pat_loc, env, Illegal_letrec_pat)))
l;
- List.iter (function
- | {vb_pat = {pat_desc = Tpat_any; pat_extra; _}; vb_expr; _} ->
- if not (List.exists (function (Tpat_constraint _, _, _) -> true
- | _ -> false) pat_extra) then
- check_partial_application ~statement:false vb_expr
- | _ -> ()) l;
- (l, new_env, unpacks)
+ List.iter (fun vb ->
+ if pattern_needs_partial_application_check vb.vb_pat then
+ check_partial_application ~statement:false vb.vb_expr
+ ) l;
+ (* See Note [add_module_variables after checking expressions] *)
+ let new_env = add_module_variables new_env mvs in
+ (l, new_env)
and type_let_def_wrap_warnings
?(check = fun s -> Warnings.Unused_var s)
@@ -5504,18 +5636,18 @@ and type_send env loc explanation e met =
(* Typing of toplevel bindings *)
let type_binding env rec_flag spat_sexp_list =
- let (pat_exp_list, new_env, _unpacks) =
+ let (pat_exp_list, new_env) =
type_let
~check:(fun s -> Warnings.Unused_value_declaration s)
~check_strict:(fun s -> Warnings.Unused_value_declaration s)
At_toplevel
- env rec_flag spat_sexp_list false
+ env rec_flag spat_sexp_list Modules_rejected
in
(pat_exp_list, new_env)
let type_let existential_ctx env rec_flag spat_sexp_list =
- let (pat_exp_list, new_env, _unpacks) =
- type_let existential_ctx env rec_flag spat_sexp_list false in
+ let (pat_exp_list, new_env) =
+ type_let existential_ctx env rec_flag spat_sexp_list Modules_rejected in
(pat_exp_list, new_env)
(* Typing of toplevel expressions *)
@@ -5655,7 +5787,7 @@ let report_this_function ppf funct =
else Format.fprintf ppf "This function"
let report_too_many_arg_error ~funct ~func_ty ~previous_arg_loc
- ~extra_arg_loc loc =
+ ~extra_arg_loc ~returns_unit loc =
let open Location in
let cnum_offset off (pos : Lexing.position) =
{ pos with pos_cnum = pos.pos_cnum + off }
@@ -5673,8 +5805,10 @@ let report_too_many_arg_error ~funct ~func_ty ~previous_arg_loc
loc_end = cnum_offset ~+1 arg_end;
loc_ghost = false }
in
- let sub = [
- msg ~loc:tail_loc "@{<hint>Hint@}: Did you forget a ';'?";
+ let hint_semicolon = if returns_unit then [
+ msg ~loc:tail_loc "@{<hint>Hint@}: Did you forget a ';'?";
+ ] else [] in
+ let sub = hint_semicolon @ [
msg ~loc:extra_arg_loc "This extra argument is not expected.";
] in
errorf ~loc:app_loc ~sub
@@ -5732,11 +5866,17 @@ let report_error ~loc env = function
fprintf ppf "This expression has type")
(function ppf ->
fprintf ppf "but an expression was expected of type");
- | Apply_non_function { funct; func_ty; previous_arg_loc; extra_arg_loc } ->
+ | Apply_non_function {
+ funct; func_ty; res_ty; previous_arg_loc; extra_arg_loc
+ } ->
begin match get_desc func_ty with
Tarrow _ ->
+ let returns_unit = match get_desc res_ty with
+ | Tconstr (p, _, _) -> Path.same p Predef.path_unit
+ | _ -> false
+ in
report_too_many_arg_error ~funct ~func_ty ~previous_arg_loc
- ~extra_arg_loc loc
+ ~extra_arg_loc ~returns_unit loc
| _ ->
Location.errorf ~loc "@[<v>@[<2>This expression has type@ %a@]@ %s@]"
Printtyp.type_expr func_ty
diff --git a/typing/typecore.mli b/typing/typecore.mli
index 916aecdec3..6c73b08b4f 100644
--- a/typing/typecore.mli
+++ b/typing/typecore.mli
@@ -98,6 +98,10 @@ type existential_restriction =
| In_class_def (** or in [class c = let ... in ...] *)
| In_self_pattern (** or in self pattern *)
+type module_patterns_restriction =
+ | Modules_allowed of { scope : int }
+ | Modules_rejected
+
val type_binding:
Env.t -> rec_flag ->
Parsetree.value_binding list ->
@@ -117,7 +121,7 @@ val type_self_pattern:
Env.t -> Parsetree.pattern ->
Typedtree.pattern * pattern_variable list
val check_partial:
- ?lev:int -> Env.t -> type_expr ->
+ ?lev:int -> module_patterns_restriction -> Env.t -> type_expr ->
Location.t -> Typedtree.value Typedtree.case list -> Typedtree.partial
val type_expect:
?in_function:(Location.t * type_expr) ->
@@ -158,6 +162,7 @@ type error =
| Apply_non_function of {
funct : Typedtree.expression;
func_ty : type_expr;
+ res_ty : type_expr;
previous_arg_loc : Location.t;
extra_arg_loc : Location.t;
}
diff --git a/typing/typedtree.mli b/typing/typedtree.mli
index 9ecf395602..985f7d8b25 100644
--- a/typing/typedtree.mli
+++ b/typing/typedtree.mli
@@ -69,6 +69,8 @@ and pat_extra =
| Tpat_unpack
(** (module P) { pat_desc = Tpat_var "P"
; pat_extra = (Tpat_unpack, _, _) :: ... }
+ (module _) { pat_desc = Tpat_any
+ ; pat_extra = (Tpat_unpack, _, _) :: ... }
*)
and 'k pattern_desc =
diff --git a/typing/typemod.ml b/typing/typemod.ml
index 1ba69f818d..b8badf2a99 100644
--- a/typing/typemod.ml
+++ b/typing/typemod.ml
@@ -57,8 +57,9 @@ type error =
| With_changes_module_alias of Longident.t * Ident.t * Path.t
| With_cannot_remove_constrained_type
| Repeated_name of Sig_component_kind.t * string
- | Non_generalizable of type_expr
- | Non_generalizable_module of module_type
+ | Non_generalizable of { vars : type_expr list; expression : type_expr }
+ | Non_generalizable_module of
+ { vars : type_expr list; item : value_description; mty : module_type }
| Implementation_is_required of string
| Interface_not_compiled of string
| Not_allowed_in_functor_body
@@ -1829,11 +1830,11 @@ let path_of_module mexp =
do not contain non-generalized type variable *)
let rec nongen_modtype env = function
- Mty_ident _ -> false
- | Mty_alias _ -> false
+ Mty_ident _ -> None
+ | Mty_alias _ -> None
| Mty_signature sg ->
let env = Env.add_signature sg env in
- List.exists (nongen_signature_item env) sg
+ List.find_map (nongen_signature_item env) sg
| Mty_functor(arg_opt, body) ->
let env =
match arg_opt with
@@ -1845,18 +1846,35 @@ let rec nongen_modtype env = function
nongen_modtype env body
and nongen_signature_item env = function
- Sig_value(_id, desc, _) -> Ctype.nongen_schema env desc.val_type
+ | Sig_value(_id, desc, _) ->
+ Ctype.nongen_vars_in_schema env desc.val_type
+ |> Option.map (fun vars -> (vars, desc))
| Sig_module(_id, _, md, _, _) -> nongen_modtype env md.md_type
- | _ -> false
+ | _ -> None
+
+let check_nongen_modtype env loc mty =
+ nongen_modtype env mty
+ |> Option.iter (fun (vars, item) ->
+ let vars = Btype.TypeSet.elements vars in
+ let error =
+ Non_generalizable_module { vars; item; mty }
+ in
+ raise(Error(loc, env, error))
+ )
let check_nongen_signature_item env sig_item =
match sig_item with
Sig_value(_id, vd, _) ->
- if Ctype.nongen_schema env vd.val_type then
- raise (Error (vd.val_loc, env, Non_generalizable vd.val_type))
+ Ctype.nongen_vars_in_schema env vd.val_type
+ |> Option.iter (fun vars ->
+ let vars = Btype.TypeSet.elements vars in
+ let error =
+ Non_generalizable { vars; expression = vd.val_type }
+ in
+ raise (Error (vd.val_loc, env, error))
+ )
| Sig_module (_id, _, md, _, _) ->
- if nongen_modtype env md.md_type then
- raise(Error(md.md_loc, env, Non_generalizable_module md.md_type))
+ check_nongen_modtype env md.md_loc md.md_type
| _ -> ()
let check_nongen_signature env sg =
@@ -2877,8 +2895,7 @@ let type_module_type_of env smod =
in
let mty = Mtype.scrape_for_type_of ~remove_aliases env tmty.mod_type in
(* PR#5036: must not contain non-generalized type variables *)
- if nongen_modtype env mty then
- raise(Error(smod.pmod_loc, env, Non_generalizable_module mty));
+ check_nongen_modtype env smod.pmod_loc mty;
tmty, mty
(* For Typecore *)
@@ -3281,14 +3298,36 @@ let report_error ~loc _env = function
"@[Multiple definition of the %s name %s.@ \
Names must be unique in a given structure or signature.@]"
(Sig_component_kind.to_string kind) name
- | Non_generalizable typ ->
+ | Non_generalizable { vars; expression } ->
+ let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2 ] in
+ prepare_for_printing vars;
+ add_type_to_preparation expression;
Location.errorf ~loc
"@[The type of this expression,@ %a,@ \
- contains type variables that cannot be generalized@]" type_scheme typ
- | Non_generalizable_module mty ->
- Location.errorf ~loc
+ contains the non-generalizable type variable(s): %a.@ %a@]"
+ prepared_type_scheme expression
+ (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ")
+ prepared_type_scheme) vars
+ Misc.print_see_manual manual_ref
+ | Non_generalizable_module { vars; mty; item } ->
+ let[@manual.ref "ss:valuerestriction"] manual_ref = [ 6; 1; 2 ] in
+ prepare_for_printing vars;
+ add_type_to_preparation item.val_type;
+ let sub =
+ [ Location.msg ~loc:item.val_loc
+ "The type of this value,@ %a,@ \
+ contains the non-generalizable type variable(s) %a."
+ prepared_type_scheme
+ item.val_type
+ (pp_print_list ~pp_sep:(fun f () -> fprintf f ",@ ")
+ prepared_type_scheme) vars
+ ]
+ in
+ Location.errorf ~loc ~sub
"@[The type of this module,@ %a,@ \
- contains type variables that cannot be generalized@]" modtype mty
+ contains non-generalizable type variable(s).@ %a@]"
+ modtype mty
+ Misc.print_see_manual manual_ref
| Implementation_is_required intf_name ->
Location.errorf ~loc
"@[The interface %a@ declares values, not just types.@ \
diff --git a/typing/typemod.mli b/typing/typemod.mli
index f0073a8c4c..859c2e9b3d 100644
--- a/typing/typemod.mli
+++ b/typing/typemod.mli
@@ -116,8 +116,9 @@ type error =
| With_changes_module_alias of Longident.t * Ident.t * Path.t
| With_cannot_remove_constrained_type
| Repeated_name of Sig_component_kind.t * string
- | Non_generalizable of type_expr
- | Non_generalizable_module of module_type
+ | Non_generalizable of { vars : type_expr list; expression : type_expr }
+ | Non_generalizable_module of
+ { vars : type_expr list; item : value_description; mty : module_type }
| Implementation_is_required of string
| Interface_not_compiled of string
| Not_allowed_in_functor_body
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
index 3b7b06e52f..ab20777e15 100644
--- a/typing/typetexp.ml
+++ b/typing/typetexp.ml
@@ -33,7 +33,6 @@ type error =
| Type_arity_mismatch of Longident.t * int * int
| Bound_type_variable of string
| Recursive_type
- | Unbound_row_variable of Longident.t
| Type_mismatch of Errortrace.unification_error
| Alias_type_mismatch of Errortrace.unification_error
| Present_has_conjunction of string
@@ -152,7 +151,6 @@ end = struct
let reset () =
reset_global_level ();
- Ctype.reset_reified_var_counter ();
type_variables := TyVarMap.empty
let is_in_scope name =
@@ -838,10 +836,6 @@ let report_error env ppf = function
fprintf ppf "Already bound type parameter %a" Pprintast.tyvar name
| Recursive_type ->
fprintf ppf "This type is recursive"
- | Unbound_row_variable lid ->
- (* we don't use "spellcheck" here: this error is not raised
- anywhere so it's unclear how it should be handled *)
- fprintf ppf "Unbound row variable in #%a" longident lid
| Type_mismatch trace ->
Printtyp.report_unification_error ppf Env.empty trace
(function ppf ->
diff --git a/typing/typetexp.mli b/typing/typetexp.mli
index ca058a5cf0..fb2eda068f 100644
--- a/typing/typetexp.mli
+++ b/typing/typetexp.mli
@@ -73,7 +73,6 @@ type error =
| Type_arity_mismatch of Longident.t * int * int
| Bound_type_variable of string
| Recursive_type
- | Unbound_row_variable of Longident.t
| Type_mismatch of Errortrace.unification_error
| Alias_type_mismatch of Errortrace.unification_error
| Present_has_conjunction of string
View Lorry Controller Status