diff options
Diffstat (limited to 'typing')
| -rw-r--r-- | typing/ctype.ml | 12 | ||||
| -rw-r--r-- | typing/ctype.mli | 1 | ||||
| -rw-r--r-- | typing/typecore.ml | 10 |
3 files changed, 15 insertions, 8 deletions
diff --git a/typing/ctype.ml b/typing/ctype.ml index 5e27441ea..cbd9ec144 100644 --- a/typing/ctype.ml +++ b/typing/ctype.ml @@ -1176,9 +1176,15 @@ let rec copy_sep fixed free bound visited ty = t end -let instance_poly fixed univars sch = - let vars = List.map (fun _ -> newvar ()) univars in - let pairs = List.map2 (fun u v -> repr u, (v, [])) univars vars in +let instance_poly ?(keep_names=false) fixed univars sch = + let univars = List.map repr univars in + let copy_var ty = + match ty.desc with + Tunivar name -> if keep_names then newty (Tvar name) else newvar () + | _ -> assert false + in + let vars = List.map copy_var univars in + let pairs = List.map2 (fun u v -> u, (v, [])) univars vars in delayed_copy := []; let ty = copy_sep fixed (compute_univars sch) [] pairs sch in List.iter Lazy.force !delayed_copy; diff --git a/typing/ctype.mli b/typing/ctype.mli index 0c42edafd..c4d4ff13a 100644 --- a/typing/ctype.mli +++ b/typing/ctype.mli @@ -128,6 +128,7 @@ val instance_declaration: type_declaration -> type_declaration val instance_class: type_expr list -> class_type -> type_expr list * class_type val instance_poly: + ?keep_names:bool -> bool -> type_expr list -> type_expr -> type_expr list * type_expr (* Take an instance of a type scheme containing free univars *) val instance_label: diff --git a/typing/typecore.ml b/typing/typecore.ml index 263e86a07..299cd8809 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -521,7 +521,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = begin match ty.desc with | Tpoly (body, tyl) -> begin_def (); - let _, ty' = instance_poly false tyl body in + let _, ty' = instance_poly ~keep_names:true false tyl body in end_def (); generalize ty'; let id = enter_variable loc name ty' in @@ -2619,7 +2619,8 @@ and type_let env rec_flag spat_sexp_list scope allow = let pat = match pat.pat_type.desc with | Tpoly (ty, tl) -> - {pat with pat_type = snd (instance_poly false tl ty)} + {pat with pat_type = + snd (instance_poly ~keep_names:true false tl ty)} | _ -> pat in unify_pat env pat (type_approx env sexp)) pat_list spat_sexp_list; @@ -2653,7 +2654,7 @@ and type_let env rec_flag spat_sexp_list scope allow = | Tpoly (ty, tl) -> begin_def (); if !Clflags.principal then begin_def (); - let vars, ty' = instance_poly true tl ty in + let vars, ty' = instance_poly ~keep_names:true true tl ty in if !Clflags.principal then begin end_def (); generalize_structure ty' @@ -2674,8 +2675,7 @@ and type_let env rec_flag spat_sexp_list scope allow = iter_pattern (fun pat -> generalize_expansive env pat.pat_type) pat) pat_list exp_list; List.iter - (fun pat -> iter_pattern - (fun pat -> generalize pat.pat_type) pat) + (fun pat -> iter_pattern (fun pat -> generalize pat.pat_type) pat) pat_list; (List.combine pat_list exp_list, new_env, unpacks) |