diff options
| -rw-r--r-- | typing/ctype.ml | 20 | ||||
| -rw-r--r-- | typing/ctype.mli | 2 | ||||
| -rw-r--r-- | typing/parmatch.ml | 2 | ||||
| -rw-r--r-- | typing/typeclass.ml | 5 | ||||
| -rw-r--r-- | typing/typedecl.ml | 19 | ||||
| -rw-r--r-- | typing/typetexp.ml | 2 |
6 files changed, 31 insertions, 19 deletions
diff --git a/typing/ctype.ml b/typing/ctype.ml index 51801debd..8c0e13f51 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -864,12 +864,7 @@ let expand_abbrev env ty = try Env.find_type_expansion path env with Not_found -> raise Cannot_expand in -(* begin try *) subst env level abbrev (Some ty) params args body -(* with Unify _ -> - raise Cannot_expand - end -*) end | _ -> assert false @@ -895,6 +890,17 @@ let _ = try_expand_head' := try_expand_head let rec expand_head env ty = try try_expand_head env ty with Cannot_expand -> repr ty +(* Make sure that the type parameters of the type constructor [ty] + respect the type constraints *) +let enforce_constraints env ty = + match ty with + {desc = Tconstr (path, args, abbrev); level = level} -> + let decl = Env.find_type path env in + ignore + (subst env level (ref Mnil) None decl.type_params args (newvar2 level)) + | _ -> + assert false + (* Recursively expand the head of a type. Also expand #-types. *) let rec full_expand env ty = @@ -965,8 +971,8 @@ let rec occur_rec env visited ty0 ty = iter_type_expr (occur_rec env (ty::visited) ty0) ty with Occur -> try let ty' = try_expand_head env ty in - if List.memq ty' visited then raise Occur; - occur_rec env (ty'::visited) ty0 ty' + if ty == ty0 || List.memq ty' visited then raise Occur; + iter_type_expr (occur_rec env (ty'::visited) ty0) ty' with Cannot_expand -> raise Occur end diff --git a/typing/ctype.mli b/typing/ctype.mli index 52549d53c..cb4b8b648 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -106,6 +106,8 @@ val apply: val expand_head: Env.t -> type_expr -> type_expr val full_expand: Env.t -> type_expr -> type_expr +val enforce_constraints: Env.t -> type_expr -> unit + val unify: Env.t -> type_expr -> type_expr -> unit (* Unify the two types given. Raise [Unify] if not possible. *) val filter_arrow: Env.t -> type_expr -> type_expr * type_expr diff --git a/typing/parmatch.ml b/typing/parmatch.ml index afd080d5e..bc6ce82ae 100644 --- a/typing/parmatch.ml +++ b/typing/parmatch.ml @@ -696,7 +696,7 @@ and pretty_lvals lbls ppf = function fprintf ppf "%s=%a;@ %a" name pretty_val v (pretty_lvals lbls) rest let top_pretty ppf v = - fprintf ppf "@[%a@]@." pretty_val v + fprintf ppf "@[%a@]@?" pretty_val v (******************************) diff --git a/typing/typeclass.ml b/typing/typeclass.ml index 33888a5e4..939abaa57 100644 --- a/typing/typeclass.ml +++ b/typing/typeclass.ml @@ -394,7 +394,10 @@ let rec class_field cl_num self_type meths vars | Pcf_val (lab, mut, sexp, loc) -> if StringSet.mem lab inh_vals then Location.print_warning loc (Warnings.Hide_instance_variable lab); - let exp = type_exp val_env sexp in + let exp = + try type_exp val_env sexp with Ctype.Unify [(ty, _)] -> + raise(Error(loc, Make_nongen_seltype ty)) + in let (id, val_env, met_env, par_env) = enter_val cl_num vars lab mut exp.exp_type val_env met_env par_env in diff --git a/typing/typedecl.ml b/typing/typedecl.ml index 6cf224fc0..2e4d25bfd 100644 --- a/typing/typedecl.ml +++ b/typing/typedecl.ml @@ -73,15 +73,6 @@ let transl_declaration env (name, sdecl) (id, decl) = raise(Error(sdecl.ptype_loc, Repeated_parameter)) end; - List.iter - (function (sty, sty', loc) -> - try - Ctype.unify env (transl_simple_type env false sty) - (transl_simple_type env false sty') - with Ctype.Unify _ -> - raise(Error(loc, Unconsistent_constraint))) - sdecl.ptype_cstrs; - begin match sdecl.ptype_manifest with None -> () @@ -95,6 +86,16 @@ let transl_declaration env (name, sdecl) (id, decl) = raise(Error(sdecl.ptype_loc, Type_clash trace)) end end; + + List.iter + (function (sty, sty', loc) -> + try + Ctype.unify env (transl_simple_type env false sty) + (transl_simple_type env false sty') + with Ctype.Unify _ -> + raise(Error(loc, Unconsistent_constraint))) + sdecl.ptype_cstrs; + (id, decl) (* Second pass: representation *) diff --git a/typing/typetexp.ml b/typing/typetexp.ml index f9ee2a86b..05f741d76 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -131,7 +131,7 @@ let rec transl_type env policy styp = let params = List.map (fun _ -> Ctype.newvar ()) args in let cstr = newty (Tconstr(path, params, ref Mnil)) in begin try - ignore(Ctype.expand_head env cstr) + Ctype.enforce_constraints env cstr with Unify trace -> raise (Error(styp.ptyp_loc, Type_mismatch trace)) end; |