diff options
Diffstat (limited to 'typing')
| -rw-r--r-- | typing/env.ml | 136 | ||||
| -rw-r--r-- | typing/env.mli | 8 | ||||
| -rw-r--r-- | typing/ident.ml | 32 | ||||
| -rw-r--r-- | typing/ident.mli | 4 | ||||
| -rw-r--r-- | typing/typecore.ml | 376 | ||||
| -rw-r--r-- | typing/typecore.mli | 1 | ||||
| -rw-r--r-- | typing/typetexp.ml | 14 | ||||
| -rw-r--r-- | typing/typetexp.mli | 9 |
8 files changed, 424 insertions, 156 deletions
diff --git a/typing/env.ml b/typing/env.ml index 5a13086244..a5017f741d 100644 --- a/typing/env.ml +++ b/typing/env.ml @@ -132,6 +132,10 @@ module EnvTbl = slot := true; x + let find_all s tbl = + let xs = Ident.find_all s tbl in + List.map (fun (x, slot) -> (x, (fun () -> slot := true))) xs + let with_slot slot f x = let old_slot = !current_slot in current_slot := slot; @@ -139,8 +143,8 @@ module EnvTbl = (fun () -> f x) (fun () -> current_slot := old_slot) - let keys tbl = - Ident.keys tbl + let fold_name f = Ident.fold_name (fun k (d,_) -> f k d) + let keys tbl = Ident.fold_all (fun k _ accu -> k::accu) tbl [] end type type_descriptions = @@ -173,8 +177,8 @@ and module_components_repr = and structure_components = { mutable comp_values: (string, (value_description * int)) Tbl.t; mutable comp_annotations: (string, (Annot.ident * int)) Tbl.t; - mutable comp_constrs: (string, (constructor_description * int)) Tbl.t; - mutable comp_labels: (string, (label_description * int)) Tbl.t; + mutable comp_constrs: (string, (constructor_description * int) list) Tbl.t; + mutable comp_labels: (string, (label_description * int) list) Tbl.t; mutable comp_types: (string, ((type_declaration * type_descriptions) * int)) Tbl.t; mutable comp_modules: @@ -572,16 +576,53 @@ let lookup_simple proj1 proj2 lid env = | Lapply(l1, l2) -> raise Not_found +let lookup_all_simple proj1 proj2 shadow lid env = + match lid with + Lident s -> + let xl = EnvTbl.find_all s (proj1 env) in + let rec do_shadow = + function + | [] -> [] + | ((x, f) :: xs) -> + (x, f) :: + (do_shadow (List.filter (fun (y, g) -> not (shadow x y)) xs)) + in + do_shadow xl + | Ldot(l, s) -> + let (p, desc) = lookup_module_descr l env in + begin match EnvLazy.force !components_of_module_maker' desc with + Structure_comps c -> + let comps = + try Tbl.find s (proj2 c) with Not_found -> [] + in + List.map + (fun (data, pos) -> (data, (fun () -> ()))) + comps + | Functor_comps f -> + raise Not_found + end + | Lapply(l1, l2) -> + raise Not_found + let has_local_constraints env = env.local_constraints +let cstr_shadow cstr1 cstr2 = + match cstr1.cstr_tag, cstr2.cstr_tag with + Cstr_exception _, Cstr_exception _ -> true + | _ -> false + +let lbl_shadow lbl1 lbl2 = false + let lookup_value = lookup (fun env -> env.values) (fun sc -> sc.comp_values) let lookup_annot id e = lookup (fun env -> env.annotations) (fun sc -> sc.comp_annotations) id e -and lookup_constructor = - lookup_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs) -and lookup_label = - lookup_simple (fun env -> env.labels) (fun sc -> sc.comp_labels) +and lookup_all_constructors = + lookup_all_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs) + cstr_shadow +and lookup_all_labels = + lookup_all_simple (fun env -> env.labels) (fun sc -> sc.comp_labels) + lbl_shadow and lookup_type = lookup (fun env -> env.types) (fun sc -> sc.comp_types) and lookup_modtype = @@ -652,9 +693,22 @@ let ty_path t = | t -> assert false let lookup_constructor lid env = - let desc = lookup_constructor lid env in - mark_type_path env (ty_path desc.cstr_res); - desc + match lookup_all_constructors lid env with + [] -> raise Not_found + | (desc, use) :: _ -> + mark_type_path env (ty_path desc.cstr_res); + use (); + desc + +let lookup_all_constructors lid env = + try + let cstrs = lookup_all_constructors lid env in + let wrap_use desc use () = + mark_type_path env (ty_path desc.cstr_res); + use () + in + List.map (fun (cstr, use) -> (cstr, wrap_use cstr use)) cstrs + with Not_found -> [] let mark_constructor usage env name desc = match desc.cstr_tag with @@ -670,9 +724,22 @@ let mark_constructor usage env name desc = mark_constructor_used usage ty_name ty_decl name let lookup_label lid env = - let desc = lookup_label lid env in - mark_type_path env (ty_path desc.lbl_res); - desc + match lookup_all_labels lid env with + [] -> raise Not_found + | (desc, use) :: _ -> + mark_type_path env (ty_path desc.lbl_res); + use (); + desc + +let lookup_all_label lid env = + try + let lbls = lookup_all_labels lid env in + let wrap_use desc use () = + mark_type_path env (ty_path desc.lbl_res); + use () + in + List.map (fun (lbl, use) -> (lbl, wrap_use lbl use)) lbls + with Not_found -> [] let lookup_class lid env = let (_, desc) as r = lookup_class lid env in @@ -808,6 +875,11 @@ let rec prefix_idents root pos sub = function (* Compute structure descriptions *) +let add_to_tbl id decl tbl = + let decls = + try Tbl.find id tbl with Not_found -> [] in + Tbl.add id (decl :: decls) tbl + let rec components_of_module env sub path mty = EnvLazy.create (env, sub, path, mty) @@ -843,23 +915,26 @@ and components_of_module_maker (env, sub, path, mty) = let constructors = List.map snd (constructors_of_type path decl') in let labels = List.map snd (labels_of_type path decl') in c.comp_types <- - Tbl.add (Ident.name id) ((decl', (constructors, labels)), nopos) c.comp_types; + Tbl.add (Ident.name id) + ((decl', (constructors, labels)), nopos) + c.comp_types; List.iter (fun descr -> c.comp_constrs <- - Tbl.add descr.cstr_name (descr, nopos) c.comp_constrs) + add_to_tbl descr.cstr_name (descr, nopos) c.comp_constrs) constructors; List.iter (fun descr -> c.comp_labels <- - Tbl.add descr.lbl_name (descr, nopos) c.comp_labels) + add_to_tbl descr.lbl_name (descr, nopos) c.comp_labels) labels; env := store_type_infos id path decl !env | Sig_exception(id, decl) -> let decl' = Subst.exception_declaration sub decl in let cstr = Datarepr.exception_descr path decl' in + let s = Ident.name id in c.comp_constrs <- - Tbl.add (Ident.name id) (cstr, !pos) c.comp_constrs; + add_to_tbl s (cstr, !pos) c.comp_constrs; incr pos | Sig_module(id, mty, _) -> let mty' = EnvLazy.create (sub, mty) in @@ -1232,16 +1307,11 @@ let save_signature sg modname filename = save_signature_with_imports sg modname filename (imported_units()) (* Folding on environments *) -let ident_tbl_fold f t acc = - List.fold_right - (fun key acc -> f key (EnvTbl.find_same_not_using key t) acc) - (EnvTbl.keys t) - acc let find_all proj1 proj2 f lid env acc = match lid with | None -> - ident_tbl_fold + EnvTbl.fold_name (fun id (p, data) acc -> f (Ident.name id) p data acc) (proj1 env) acc | Some l -> @@ -1255,18 +1325,22 @@ let find_all proj1 proj2 f lid env acc = raise Not_found end -let find_all_simple proj1 proj2 f lid env acc = +let find_all_simple_list proj1 proj2 f lid env acc = match lid with | None -> - ident_tbl_fold - (fun _id data acc -> f data acc) + EnvTbl.fold_name + (fun id data acc -> f data acc) (proj1 env) acc | Some l -> let p, desc = lookup_module_descr l env in begin match EnvLazy.force components_of_module_maker desc with Structure_comps c -> Tbl.fold - (fun s (data, pos) acc -> f data acc) + (fun s comps acc -> + match comps with + [] -> acc + | (data, pos) :: _ -> + f data acc) (proj2 c) acc | Functor_comps _ -> raise Not_found @@ -1276,7 +1350,7 @@ let fold_modules f lid env acc = match lid with | None -> let acc = - ident_tbl_fold + EnvTbl.fold_name (fun id (p, data) acc -> f (Ident.name id) p data acc) env.modules acc @@ -1307,9 +1381,9 @@ let fold_modules f lid env acc = let fold_values f = find_all (fun env -> env.values) (fun sc -> sc.comp_values) f and fold_constructors f = - find_all_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs) f + find_all_simple_list (fun env -> env.constrs) (fun sc -> sc.comp_constrs) f and fold_labels f = - find_all_simple (fun env -> env.labels) (fun sc -> sc.comp_labels) f + find_all_simple_list (fun env -> env.labels) (fun sc -> sc.comp_labels) f and fold_types f = find_all (fun env -> env.types) (fun sc -> sc.comp_types) f and fold_modtypes f = diff --git a/typing/env.mli b/typing/env.mli index 8ee0ef8ec3..413d174e93 100644 --- a/typing/env.mli +++ b/typing/env.mli @@ -64,7 +64,11 @@ val add_gadt_instance_chain: t -> int -> type_expr -> unit val lookup_value: Longident.t -> t -> Path.t * value_description val lookup_annot: Longident.t -> t -> Path.t * Annot.ident val lookup_constructor: Longident.t -> t -> constructor_description +val lookup_all_constructors: + Longident.t -> t -> (constructor_description * (unit -> unit)) list val lookup_label: Longident.t -> t -> label_description +val lookup_all_labels: + Longident.t -> t -> (label_description * (unit -> unit)) list val lookup_type: Longident.t -> t -> Path.t * type_declaration val lookup_module: Longident.t -> t -> Path.t * module_type val lookup_modtype: Longident.t -> t -> Path.t * modtype_declaration @@ -198,10 +202,10 @@ val fold_types: (string -> Path.t -> type_declaration * type_descriptions -> 'a -> 'a) -> Longident.t option -> t -> 'a -> 'a val fold_constructors: - (Types.constructor_description -> 'a -> 'a) -> + (constructor_description -> 'a -> 'a) -> Longident.t option -> t -> 'a -> 'a val fold_labels: - (Types.label_description -> 'a -> 'a) -> + (label_description -> 'a -> 'a) -> Longident.t option -> t -> 'a -> 'a (** Persistent structures are only traversed if they are already loaded. *) diff --git a/typing/ident.ml b/typing/ident.ml index d1e7083669..c448f42505 100644 --- a/typing/ident.ml +++ b/typing/ident.ml @@ -170,13 +170,37 @@ let rec find_name name = function else find_name name (if c < 0 then l else r) -let rec keys_aux stack accu = function +let rec get_all = function + | None -> [] + | Some k -> k.data :: get_all k.previous + +let rec find_all name = function + Empty -> + [] + | Node(l, k, r, _) -> + let c = compare name k.ident.name in + if c = 0 then + k.data :: get_all k.previous + else + find_all name (if c < 0 then l else r) + +let rec fold_aux f stack accu = function Empty -> begin match stack with [] -> accu - | a :: l -> keys_aux l accu a + | a :: l -> fold_aux f l accu a end | Node(l, k, r, _) -> - keys_aux (l :: stack) (k.ident :: accu) r + fold_aux f (l :: stack) (f k accu) r + +let fold_name f tbl accu = fold_aux (fun k -> f k.ident k.data) [] accu tbl + +let rec fold_data f d accu = + match d with + None -> accu + | Some k -> f k.ident k.data (fold_data f k.previous accu) + +let fold_all f tbl accu = + fold_aux (fun k -> fold_data f (Some k)) [] accu tbl -let keys tbl = keys_aux [] [] tbl +(* let keys tbl = fold_name (fun k _ accu -> k::accu) tbl [] *) diff --git a/typing/ident.mli b/typing/ident.mli index 7095cde7ea..05a675d66e 100644 --- a/typing/ident.mli +++ b/typing/ident.mli @@ -54,4 +54,6 @@ val empty: 'a tbl val add: t -> 'a -> 'a tbl -> 'a tbl val find_same: t -> 'a tbl -> 'a val find_name: string -> 'a tbl -> 'a -val keys: 'a tbl -> t list +val find_all: string -> 'a tbl -> 'a list +val fold_name: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b +val fold_all: (t -> 'a -> 'b -> 'b) -> 'a tbl -> 'b -> 'b diff --git a/typing/typecore.ml b/typing/typecore.ml index e8dc934d71..a076aa6b22 100644 --- a/typing/typecore.ml +++ b/typing/typecore.ml @@ -24,7 +24,6 @@ type error = Polymorphic_label of Longident.t | Constructor_arity_mismatch of Longident.t * int * int | Label_mismatch of Longident.t * (type_expr * type_expr) list - | Extra_label of label * type_expr | Pattern_type_clash of (type_expr * type_expr) list | Multiply_bound_variable of string | Orpat_vars of Ident.t @@ -513,12 +512,7 @@ let build_or_pat env loc lid = pat pats in (path, rp { r with pat_loc = loc },ty) -(* Records *) - -let rec find_record_qual = function - | [] -> None - | ({ txt = Longident.Ldot _ } as lid, _) :: _ -> Some lid - | _ :: rest -> find_record_qual rest +(* Type paths *) let rec expand_path env p = let decl = @@ -532,72 +526,199 @@ let rec expand_path env p = end | _ -> p -let type_label_a_list ?labels env type_lbl_a opath lid_a_list = - (* Priority order for selecting record type - 1) use first qualified label - 2) use first label when compatible with expected type - 3) use expected type (eventually warning if not principal) - Then type each unqualified field according to the selected - record type. - *) - let labels' = - match find_record_qual lid_a_list with - Some lid -> - let label = Typetexp.find_label env lid.loc lid.txt in - begin match label.lbl_res.desc with - Tconstr (p, _, _) -> snd (Env.find_type_descrs p env) - | _ -> assert false - end - | None -> - let lid = fst (List.hd lid_a_list) in - match lid.txt, labels with - Longident.Lident s, Some labels when Hashtbl.mem labels s -> - [] - | _ -> - let lbl_path () = - match Typetexp.find_label env lid.loc lid.txt with - | {lbl_res={desc=Tconstr(p, _, _)}} -> p - | _ -> assert false - in - let path = - match opath with - Some (p1,pr) -> - begin try - if not pr && not (Path.same (expand_path env p1) - (expand_path env (lbl_path ()))) - then raise Exit - with Exit | Typetexp.Error _ -> - Location.prerr_warning lid.loc - (Warnings.Not_principal "this type-based record selection") - end; - p1 - | None -> lbl_path () - in - snd (Env.find_type_descrs path env) +let get_label_type_path env lbl = + match lbl.lbl_res.desc with + | Tconstr(p, _, _) -> p + | _ -> assert false + +let get_constructor_type_path env cstr = + match cstr.cstr_res.desc with + | Tconstr(p, _, _) -> p + | _ -> assert false + +let compare_type_path env tpath1 tpath2 = + Path.same (expand_path env tpath1) (expand_path env tpath2) + +(* Records *) + +let lookup_label_from_type env tpath lid = + let (_, labels) = Env.find_type_descrs tpath env in + Env.mark_type_used (Path.last tpath) (Env.find_type tpath env); + match lid with + Longident.Lident s -> + List.find (fun lbl -> lbl.lbl_name = s) labels + | _ -> raise Not_found + +module NameChoice(Name : sig + type t + val get_type_path: Env.t -> t -> Path.t + val lookup_from_type: Env.t -> Path.t -> Longident.t -> t + val unbound_name_error: Env.t -> Longident.t loc -> unit +end) = struct + open Name + + let is_ambiguous env lbl others = + let tpath = get_type_path env lbl in + let different_tpath (lbl, _) = + let lbl_tpath = get_type_path env lbl in + not (compare_type_path env tpath lbl_tpath) + in + let others = + List.filter different_tpath others + in + others <> [] + + let disambiguate_by_type env tpath lbls = + let check_type (lbl, _) = + let lbl_tpath = get_type_path env lbl in + compare_type_path env tpath lbl_tpath + in + List.find check_type lbls + + let disambiguate ?(warn=Location.prerr_warning) lid env opath lbls = + try match opath with + None -> raise Not_found + | Some(tpath, pr) -> + try + let lbl, use = disambiguate_by_type env tpath lbls in + use (); + Env.mark_type_used (Path.last tpath) (Env.find_type tpath env); + if not pr then begin + (* Check if non-principal type is affecting result *) + match lbls with + [] -> assert false + | (lbl', use') :: rest -> + let lbl_tpath = get_type_path env lbl' in + if not (compare_type_path env tpath lbl_tpath) then + warn lid.loc + (Warnings.Not_principal + "this type-based field disambiguation") + else + if is_ambiguous env lbl' rest then + warn lid.loc + (Warnings.Ambiguous_name + ([Longident.last lid.txt], false)) + end; + lbl + with Not_found -> + let lbl = lookup_from_type env tpath lid.txt in + warn lid.loc + (Warnings.Name_out_of_scope + ([Longident.last lid.txt], false)); + if not pr then + warn lid.loc + (Warnings.Not_principal "this type-based field disambiguation"); + lbl + with Not_found -> + match lbls with + [] -> unbound_name_error env lid; assert false + | (lbl, use) :: rest -> + use (); + if is_ambiguous env lbl rest then + warn lid.loc + (Warnings.Ambiguous_name + ([Longident.last lid.txt], false)); + lbl +end + +module Label = NameChoice (struct + type t = label_description + let get_type_path = get_label_type_path + let lookup_from_type = lookup_label_from_type + let unbound_name_error = Typetexp.unbound_label_error +end) + +let disambiguate_label_by_ids keep env closed ids labels = + let check_ids (lbl, _) = + let lbls = Hashtbl.create 8 in + Array.iter (fun lbl -> Hashtbl.add lbls lbl.lbl_name ()) lbl.lbl_all; + List.for_all (Hashtbl.mem lbls) ids + and check_closed (lbl, _) = + (not closed || List.length ids = Array.length lbl.lbl_all) in - let lbl_a_list = + let labels' = List.filter check_ids labels in + if keep && labels' = [] then labels else + let labels'' = List.filter check_closed labels' in + if keep & labels'' = [] then labels' else labels'' + +(* Only issue warnings once per record constructor/pattern *) +let disambiguate_labels_a_list loc closed env opath lid_a_list = + let ids = List.map (fun (lid, _) -> Longident.last lid.txt) lid_a_list in + let labels_by_id = List.map - (fun (lid, a) -> - let label : Types.label_description = - match lid.txt, labels with - Longident.Lident s, Some labels when Hashtbl.mem labels s -> - Hashtbl.find labels s - | Longident.Lident s, None -> - begin try - List.find (fun descr -> descr.lbl_name = s) labels' - with Not_found -> - try Env.lookup_label lid.txt env with Not_found -> - raise (Error (lid.loc, Extra_label - (s, (List.hd labels').lbl_res))) - end - | _ -> (* qualified *) - Typetexp.find_label env lid.loc lid.txt - in (lid, label, a) - ) lid_a_list in + (fun (lid,_) -> + let labels = Typetexp.find_all_labels env lid.loc lid.txt in + if opath = None && labels = [] then + Typetexp.unbound_label_error env lid; + labels) + lid_a_list + in + let labels = + disambiguate_label_by_ids (opath=None) env closed ids + (List.hd labels_by_id) in + let records = + List.map (fun (lbl,use) -> Array.to_list lbl.lbl_all, use) labels in + let labels_by_id = + List.map2 + (fun s labels -> List.map + (fun (lbls,use) -> + try List.find (fun lbl -> lbl.lbl_name = s) lbls, use + with Not_found -> List.hd labels) + records) + ids labels_by_id + in + let w_pr = ref true and w_amb = ref true and w_scope = ref true in + let warn loc msg = + let flag = + let open Warnings in + match msg with + | Not_principal _ -> w_pr + | Ambiguous_name _ -> w_amb + | Name_out_of_scope _ -> w_scope + | _ -> ref true + in + if !flag then begin + flag := false; + Location.prerr_warning loc msg + end + in + List.map2 + (fun (lid, a) lbls -> lid, Label.disambiguate lid env opath lbls ~warn, a) + lid_a_list labels_by_id + +let rec find_record_qual = function + | [] -> None + | ({ txt = Longident.Ldot (modname, _) }, _) :: _ -> Some modname + | _ :: rest -> find_record_qual rest + +let type_label_a_list ?labels loc closed env type_lbl_a opath lid_a_list = + let lbl_a_list = + match lid_a_list, labels with + ({txt=Longident.Lident s}, _)::_, Some labels when Hashtbl.mem labels s -> + (* Special case for rebuilt syntax trees *) + List.map + (function lid, a -> match lid.txt with + Longident.Lident s -> lid, Hashtbl.find labels s, a + | _ -> assert false) + lid_a_list + | _ -> + let lid_a_list = + match find_record_qual lid_a_list with + None -> lid_a_list + | Some modname -> + List.map + (fun (lid, a as lid_a) -> + match lid.txt with Longident.Lident s -> + {lid with txt=Longident.Ldot (modname, s)}, a + | _ -> lid_a) + lid_a_list + in + disambiguate_labels_a_list loc closed env opath lid_a_list + in (* Invariant: records are sorted in the typed tree *) let lbl_a_list = List.sort - (fun (_, lbl1,_) (_, lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos) + (fun (_,lbl1,_) (_,lbl2,_) -> compare lbl1.lbl_pos lbl2.lbl_pos) lbl_a_list in List.map type_lbl_a lbl_a_list @@ -609,7 +730,23 @@ let lid_of_label label = Longident.Ldot(lid_of_path mpath, label.lbl_name) | _ -> Longident.Lident label.lbl_name -(* Checks over the labels mentioned in a record pattern: +(* Constructors *) + +let lookup_constructor_from_type env tpath lid = + let (constructors, _) = Env.find_type_descrs tpath env in + match lid with + Longident.Lident s -> + List.find (fun cstr -> cstr.cstr_name = s) constructors + | _ -> raise Not_found + +module Constructor = NameChoice (struct + type t = constructor_description + let get_type_path = get_constructor_type_path + let lookup_from_type = lookup_constructor_from_type + let unbound_name_error = Typetexp.unbound_constructor_error +end) + +(* Checks over the constructors mentioned in a record pattern: no duplicate definitions (error); properly closed (warning) *) let check_recordpat_labels loc lbl_pat_list closed = @@ -737,12 +874,19 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = pat_type = expected_ty; pat_env = !env } | Ppat_construct(lid, sarg, explicit_arity) -> - let constr = + let opath = + try + let (p,_) = extract_concrete_typedecl !env expected_ty in + Some (p, true) + with Not_found -> None + in + let constrs = match lid.txt, constrs with Longident.Lident s, Some constrs when Hashtbl.mem constrs s -> - Hashtbl.find constrs s - | _ -> Typetexp.find_constructor !env loc lid.txt + [Hashtbl.find constrs s, (fun () -> ())] + | _ -> Typetexp.find_all_constructors !env lid.loc lid.txt in + let constr = Constructor.disambiguate lid !env opath constrs in Env.mark_constructor Env.Pattern !env (Longident.last lid.txt) constr; if no_existentials && constr.cstr_existentials <> [] then raise (Error (loc, Unexpected_existential)); @@ -823,7 +967,8 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty = with Not_found -> None in let lbl_pat_list = - type_label_a_list ?labels !env type_label_pat opath lid_sp_list in + type_label_a_list ?labels loc false !env type_label_pat opath + lid_sp_list in check_recordpat_labels loc lbl_pat_list closed; rp { pat_desc = Tpat_record (lbl_pat_list, closed); @@ -1845,8 +1990,9 @@ and type_expect ?in_function env sexp ty_expected = | Some exp -> get_path exp.exp_type) | op -> op in + let closed = (opt_sexp = None) in let lbl_exp_list = - type_label_a_list env (type_label_exp true env loc ty_expected) + type_label_a_list loc closed env (type_label_exp true env loc ty_expected) opath lid_sexp_list in let rec check_duplicates seen_pos lid_sexp lbl_exp = match (lid_sexp, lbl_exp) with @@ -1911,8 +2057,21 @@ and type_expect ?in_function env sexp ty_expected = exp_type = ty_arg; exp_env = env } | Pexp_setfield(srecord, lid, snewval) -> - let (record, label) = - type_label_access env loc srecord lid in + if !Clflags.principal then begin_def (); + let record = type_exp env srecord in + if !Clflags.principal then begin + end_def (); + generalize_structure record.exp_type + end; + let ty_exp = record.exp_type in + let opath = + try + let (p,_) = extract_concrete_typedecl env ty_exp in + Some(p, ty_exp.level = generic_level || not !Clflags.principal) + with Not_found -> None + in + let labels = Typetexp.find_all_labels env lid.loc lid.txt in + let label = Label.disambiguate lid env opath labels in let (label_loc, label, newval) = type_label_exp false env loc record.exp_type (lid, label, snewval) in @@ -2431,40 +2590,22 @@ and type_expect ?in_function env sexp ty_expected = } and type_label_access env loc srecord lid = - match lid.txt with Longident.Lident lab -> - if !Clflags.principal then begin_def (); - let record = type_exp env srecord in - if !Clflags.principal then begin - end_def (); - generalize_structure record.exp_type - end; - let ty_exp = record.exp_type in - let record = {record with exp_type = instance env record.exp_type} in - begin try - let label = Env.lookup_label lid.txt env in - let ty_res = instance Env.empty label.lbl_res in - match (expand_head env ty_exp).desc, (expand_head env ty_res).desc with - Tconstr(p1,_,_), Tconstr(p2,_,_) when not (Path.same p1 p2) -> - raise Exit - | _ -> (record, label) - with exn -> - let labels = - try - let (p,_) = extract_concrete_typedecl env ty_exp in - snd (Env.find_type_descrs p env) - with Not_found -> [] - in - try - let label = List.find (fun descr -> descr.lbl_name = lab) labels in - if !Clflags.principal && ty_exp.level <> generic_level then - Location.prerr_warning loc - (Warnings.Not_principal "this type-based field selection"); - (record, label) - with Not_found -> - raise (Error (loc, Extra_label (lab, record.exp_type))) - end - | _ -> - (type_exp env srecord, Typetexp.find_label env lid.loc lid.txt) + if !Clflags.principal then begin_def (); + let record = type_exp env srecord in + if !Clflags.principal then begin + end_def (); + generalize_structure record.exp_type + end; + let ty_exp = record.exp_type in + let opath = + try + let (p,_) = extract_concrete_typedecl env ty_exp in + Some(p, ty_exp.level = generic_level || not !Clflags.principal) + with Not_found -> None + in + let labels = Typetexp.find_all_labels env lid.loc lid.txt in + let label = Label.disambiguate lid env opath labels in + (record, label) and type_label_exp create env loc ty_expected (lid, label, sarg) = @@ -2776,7 +2917,14 @@ and type_application env funct sargs = type_args [] [] ty (instance env ty) ty sargs [] and type_construct env loc lid sarg explicit_arity ty_expected = - let constr = Typetexp.find_constructor env loc lid.txt in + let opath = + try + let (p,_) = extract_concrete_typedecl env ty_expected in + Some(p, ty_expected.level = generic_level || not !Clflags.principal) + with Not_found -> None + in + let constrs = Typetexp.find_all_constructors env lid.loc lid.txt in + let constr = Constructor.disambiguate lid env opath constrs in Env.mark_constructor Env.Positive env (Longident.last lid.txt) constr; let sargs = match sarg with @@ -3180,12 +3328,6 @@ let report_error ppf = function longident lid) (function ppf -> fprintf ppf "but is mixed here with labels of type") - | Extra_label (l, ty) -> - reset_and_mark_loops ty; - fprintf ppf - "@[<v>@[<2>This record has type@ %a@]@ \ - which does not include the label %s@]" - type_expr ty l | Pattern_type_clash trace -> report_unification_error ppf trace (function ppf -> diff --git a/typing/typecore.mli b/typing/typecore.mli index 2a1ce588ec..b7a1d667ae 100644 --- a/typing/typecore.mli +++ b/typing/typecore.mli @@ -66,7 +66,6 @@ type error = Polymorphic_label of Longident.t | Constructor_arity_mismatch of Longident.t * int * int | Label_mismatch of Longident.t * (type_expr * type_expr) list - | Extra_label of label * type_expr | Pattern_type_clash of (type_expr * type_expr) list | Multiply_bound_variable of string | Orpat_vars of Ident.t diff --git a/typing/typetexp.ml b/typing/typetexp.ml index b892d44f9f..4a3916294d 100644 --- a/typing/typetexp.ml +++ b/typing/typetexp.ml @@ -96,9 +96,15 @@ let find_type = let find_constructor = find_component Env.lookup_constructor (fun env lid -> Unbound_constructor (env, lid)) +let find_all_constructors = + find_component Env.lookup_all_constructors + (fun env lid -> Unbound_constructor (env, lid)) let find_label = find_component Env.lookup_label (fun env lid -> Unbound_label (env, lid)) +let find_all_labels = + find_component Env.lookup_all_labels + (fun env lid -> Unbound_label (env, lid)) let find_class = find_component Env.lookup_class (fun env lid -> Unbound_class (env, lid)) @@ -115,6 +121,14 @@ let find_class_type = find_component Env.lookup_cltype (fun env lid -> Unbound_cltype (env, lid)) +let unbound_constructor_error env lid = + narrow_unbound_lid_error env lid.loc lid.txt + (fun env lid -> Unbound_constructor (env, lid)) + +let unbound_label_error env lid = + narrow_unbound_lid_error env lid.loc lid.txt + (fun env lid -> Unbound_label (env, lid)) + (* Support for first-class modules. *) let transl_modtype_longident = ref (fun _ -> assert false) diff --git a/typing/typetexp.mli b/typing/typetexp.mli index ec16034f86..2d0e9a1a85 100644 --- a/typing/typetexp.mli +++ b/typing/typetexp.mli @@ -80,8 +80,14 @@ val find_type: Env.t -> Location.t -> Longident.t -> Path.t * Types.type_declaration val find_constructor: Env.t -> Location.t -> Longident.t -> Types.constructor_description +val find_all_constructors: + Env.t -> Location.t -> Longident.t -> + (Types.constructor_description * (unit -> unit)) list val find_label: Env.t -> Location.t -> Longident.t -> Types.label_description +val find_all_labels: + Env.t -> Location.t -> Longident.t -> + (Types.label_description * (unit -> unit)) list val find_value: Env.t -> Location.t -> Longident.t -> Path.t * Types.value_description val find_class: @@ -92,3 +98,6 @@ val find_modtype: Env.t -> Location.t -> Longident.t -> Path.t * Types.modtype_declaration val find_class_type: Env.t -> Location.t -> Longident.t -> Path.t * Types.class_type_declaration + +val unbound_constructor_error: Env.t -> Longident.t Location.loc -> unit +val unbound_label_error: Env.t -> Longident.t Location.loc -> unit |