Browse files

Stop keeping a Path.t to refer to labels and constructors in the Type…

…dtree AST. This is not used internally and it is not a robust way to identify these objects unambiguously anyway

(especially when we will add more powerful disambiguation strategies).  The correct way to identify an item is through the pair (type,name), which can be deduced from the
label_description/constructor_description stored in the Typedtree.



git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@13043 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
  • Loading branch information...
1 parent dc0776f commit 0b37b273568cc9d64816494b882ee71098baf97d @alainfrisch alainfrisch committed Oct 24, 2012
View
BIN boot/ocamlc
Binary file not shown.
View
BIN boot/ocamldep
Binary file not shown.
View
BIN boot/ocamllex
Binary file not shown.
View
34 bytecomp/matching.ml
@@ -160,9 +160,9 @@ let make_default matcher env =
let ctx_matcher p =
let p = normalize_pat p in
match p.pat_desc with
- | Tpat_construct (_, _, cstr,omegas,_) ->
+ | Tpat_construct (_, cstr,omegas,_) ->
(fun q rem -> match q.pat_desc with
- | Tpat_construct (_, _, cstr',args,_) when cstr.cstr_tag=cstr'.cstr_tag ->
+ | Tpat_construct (_, cstr',args,_) when cstr.cstr_tag=cstr'.cstr_tag ->
p,args @ rem
| Tpat_any -> p,omegas @ rem
| _ -> raise NoMatch)
@@ -199,8 +199,8 @@ let ctx_matcher p =
(fun q rem -> match q.pat_desc with
| Tpat_record (l',_) ->
let l' = all_record_args l' in
- p, List.fold_right (fun (_, _, _,p) r -> p::r) l' rem
- | _ -> p,List.fold_right (fun (_, _, _,p) r -> p::r) l rem)
+ p, List.fold_right (fun (_, _,p) r -> p::r) l' rem
+ | _ -> p,List.fold_right (fun (_, _,p) r -> p::r) l rem)
| Tpat_lazy omega ->
(fun q rem -> match q.pat_desc with
| Tpat_lazy arg -> p, (arg::rem)
@@ -612,9 +612,9 @@ let rec extract_vars r p = match p.pat_desc with
List.fold_left extract_vars r pats
| Tpat_record (lpats,_) ->
List.fold_left
- (fun r (_, _, _, p) -> extract_vars r p)
+ (fun r (_, _, p) -> extract_vars r p)
r lpats
-| Tpat_construct (_, _, _, pats,_) ->
+| Tpat_construct (_, _, pats,_) ->
List.fold_left extract_vars r pats
| Tpat_array pats ->
List.fold_left extract_vars r pats
@@ -664,7 +664,7 @@ let group_constant = function
| _ -> false
and group_constructor = function
- | {pat_desc = Tpat_construct (_, _, _, _,_)} -> true
+ | {pat_desc = Tpat_construct _} -> true
| _ -> false
and group_variant = function
@@ -694,7 +694,7 @@ and group_lazy = function
let get_group p = match p.pat_desc with
| Tpat_any -> group_var
| Tpat_constant _ -> group_constant
-| Tpat_construct (_, _, _, _, _) -> group_constructor
+| Tpat_construct _ -> group_constructor
| Tpat_tuple _ -> group_tuple
| Tpat_record _ -> group_record
| Tpat_array _ -> group_array
@@ -1129,15 +1129,15 @@ let make_field_args binding_kind arg first_pos last_pos argl =
in make_args first_pos
let get_key_constr = function
- | {pat_desc=Tpat_construct (_, _, cstr,_,_)} -> cstr.cstr_tag
+ | {pat_desc=Tpat_construct (_, cstr,_,_)} -> cstr.cstr_tag
| _ -> assert false
let get_args_constr p rem = match p with
-| {pat_desc=Tpat_construct (_, _, _, args, _)} -> args @ rem
+| {pat_desc=Tpat_construct (_, _, args, _)} -> args @ rem
| _ -> assert false
let pat_as_constr = function
- | {pat_desc=Tpat_construct (_, _, cstr,_,_)} -> cstr
+ | {pat_desc=Tpat_construct (_, cstr,_,_)} -> cstr
| _ -> fatal_error "Matching.pat_as_constr"
@@ -1151,7 +1151,7 @@ let matcher_constr cstr = match cstr.cstr_arity with
with
| NoMatch -> matcher_rec p2 rem
end
- | Tpat_construct (_, _, cstr1, [],_) when cstr.cstr_tag = cstr1.cstr_tag ->
+ | Tpat_construct (_, cstr1, [],_) when cstr.cstr_tag = cstr1.cstr_tag ->
rem
| Tpat_any -> rem
| _ -> raise NoMatch in
@@ -1172,15 +1172,15 @@ let matcher_constr cstr = match cstr.cstr_arity with
rem
| _, _ -> assert false
end
- | Tpat_construct (_, _, cstr1, [arg],_)
+ | Tpat_construct (_, cstr1, [arg],_)
when cstr.cstr_tag = cstr1.cstr_tag -> arg::rem
| Tpat_any -> omega::rem
| _ -> raise NoMatch in
matcher_rec
| _ ->
fun q rem -> match q.pat_desc with
| Tpat_or (_,_,_) -> raise OrPat
- | Tpat_construct (_, _, cstr1, args,_)
+ | Tpat_construct (_, cstr1, args,_)
when cstr.cstr_tag = cstr1.cstr_tag -> args @ rem
| Tpat_any -> Parmatch.omegas cstr.cstr_arity @ rem
| _ -> raise NoMatch
@@ -1446,7 +1446,7 @@ let divide_tuple arity p ctx pm =
let record_matching_line num_fields lbl_pat_list =
let patv = Array.create num_fields omega in
- List.iter (fun (_, _, lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list;
+ List.iter (fun (_, lbl, pat) -> patv.(lbl.lbl_pos) <- pat) lbl_pat_list;
Array.to_list patv
let get_args_record num_fields p rem = match p with
@@ -2433,7 +2433,7 @@ and do_compile_matching repr partial ctx arg pmh = match pmh with
compile_no_test
(divide_tuple (List.length patl) (normalize_pat pat)) ctx_combine
repr partial ctx pm
- | Tpat_record ((_, _, lbl,_)::_,_) ->
+ | Tpat_record ((_, lbl,_)::_,_) ->
compile_no_test
(divide_record lbl.lbl_all (normalize_pat pat))
ctx_combine repr partial ctx pm
@@ -2443,7 +2443,7 @@ and do_compile_matching repr partial ctx arg pmh = match pmh with
divide_constant
(combine_constant arg cst partial)
ctx pm
- | Tpat_construct (_, _, cstr, _, _) ->
+ | Tpat_construct (_, cstr, _, _) ->
compile_test
(compile_match repr partial) partial
divide_constructor (combine_constructor arg pat cstr partial)
View
20 bytecomp/translcore.ml
@@ -297,10 +297,10 @@ let transl_prim loc prim args =
simplify_constant_constructor) =
Hashtbl.find comparisons_table prim_name in
begin match args with
- [arg1; {exp_desc = Texp_construct(_, _, {cstr_tag = Cstr_constant _}, _, _)}]
+ [arg1; {exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _, _)}]
when simplify_constant_constructor ->
intcomp
- | [{exp_desc = Texp_construct(_, _, {cstr_tag = Cstr_constant _}, _, _)}; arg2]
+ | [{exp_desc = Texp_construct(_, {cstr_tag = Cstr_constant _}, _, _)}; arg2]
when simplify_constant_constructor ->
intcomp
| [arg1; {exp_desc = Texp_variant(_, None)}]
@@ -657,7 +657,7 @@ and transl_exp0 e =
with Not_constant ->
Lprim(Pmakeblock(0, Immutable), ll)
end
- | Texp_construct(_, _, cstr, args, _) ->
+ | Texp_construct(_, cstr, args, _) ->
let ll = transl_list args in
begin match cstr.cstr_tag with
Cstr_constant n ->
@@ -684,17 +684,17 @@ and transl_exp0 e =
Lprim(Pmakeblock(0, Immutable),
[Lconst(Const_base(Const_int tag)); lam])
end
- | Texp_record ((_, _, lbl1, _) :: _ as lbl_expr_list, opt_init_expr) ->
+ | Texp_record ((_, lbl1, _) :: _ as lbl_expr_list, opt_init_expr) ->
transl_record lbl1.lbl_all lbl1.lbl_repres lbl_expr_list opt_init_expr
| Texp_record ([], _) ->
fatal_error "Translcore.transl_exp: bad Texp_record"
- | Texp_field(arg, _, _, lbl) ->
+ | Texp_field(arg, _, lbl) ->
let access =
match lbl.lbl_repres with
Record_regular -> Pfield lbl.lbl_pos
| Record_float -> Pfloatfield lbl.lbl_pos in
Lprim(access, [transl_exp arg])
- | Texp_setfield(arg, _, _, lbl, newval) ->
+ | Texp_setfield(arg, _, lbl, newval) ->
let access =
match lbl.lbl_repres with
Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer newval)
@@ -785,7 +785,7 @@ and transl_exp0 e =
( Const_int _ | Const_char _ | Const_string _
| Const_int32 _ | Const_int64 _ | Const_nativeint _ )
| Texp_function(_, _, _)
- | Texp_construct (_, _, {cstr_arity = 0}, _, _)
+ | Texp_construct (_, {cstr_arity = 0}, _, _)
-> transl_exp e
| Texp_constant(Const_float _) ->
Lprim(Pmakeblock(Obj.forward_tag, Immutable), [transl_exp e])
@@ -976,11 +976,11 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr =
done
end;
List.iter
- (fun (_, _, lbl, expr) -> lv.(lbl.lbl_pos) <- transl_exp expr)
+ (fun (_, lbl, expr) -> lv.(lbl.lbl_pos) <- transl_exp expr)
lbl_expr_list;
let ll = Array.to_list lv in
let mut =
- if List.exists (fun (_, _, lbl, expr) -> lbl.lbl_mut = Mutable) lbl_expr_list
+ if List.exists (fun (_, lbl, expr) -> lbl.lbl_mut = Mutable) lbl_expr_list
then Mutable
else Immutable in
let lam =
@@ -1005,7 +1005,7 @@ and transl_record all_labels repres lbl_expr_list opt_init_expr =
(* If you change anything here, you will likely have to change
[check_recursive_recordwith] in this file. *)
let copy_id = Ident.create "newrecord" in
- let update_field (_, _, lbl, expr) cont =
+ let update_field (_, lbl, expr) cont =
let upd =
match lbl.lbl_repres with
Record_regular -> Psetfield(lbl.lbl_pos, maybe_pointer expr)
View
2 ocamldoc/odoc_ast.ml
@@ -265,7 +265,7 @@ module Analyser =
(List.map iter_pattern patlist,
Odoc_env.subst_type env pat.pat_type)
- | Typedtree.Tpat_construct (_, _, cons_desc, _, _) when
+ | Typedtree.Tpat_construct (_, cons_desc, _, _) when
(* we give a name to the parameter only if it unit *)
(match cons_desc.cstr_res.desc with
Tconstr (p, _, _) ->
View
12 otherlibs/labltk/browser/searchpos.ml
@@ -765,14 +765,14 @@ and search_pos_expr ~pos exp =
search_pos_expr exp ~pos
end
| Texp_tuple l -> List.iter l ~f:(search_pos_expr ~pos)
- | Texp_construct (_, _, _, l,_) -> List.iter l ~f:(search_pos_expr ~pos)
+ | Texp_construct (_, _, l,_) -> List.iter l ~f:(search_pos_expr ~pos)
| Texp_variant (_, None) -> ()
| Texp_variant (_, Some exp) -> search_pos_expr exp ~pos
| Texp_record (l, opt) ->
- List.iter l ~f:(fun (_, _, _, exp) -> search_pos_expr exp ~pos);
+ List.iter l ~f:(fun (_, _, exp) -> search_pos_expr exp ~pos);
(match opt with None -> () | Some exp -> search_pos_expr exp ~pos)
- | Texp_field (exp, _, _, _) -> search_pos_expr exp ~pos
- | Texp_setfield (a, _, _, _, b) ->
+ | Texp_field (exp, _, _) -> search_pos_expr exp ~pos
+ | Texp_setfield (a, _, _, b) ->
search_pos_expr a ~pos; search_pos_expr b ~pos
| Texp_array l -> List.iter l ~f:(search_pos_expr ~pos)
| Texp_ifthenelse (a, b, c) ->
@@ -830,12 +830,12 @@ and search_pos_pat ~pos ~env pat =
add_found_str (`Exp(`Const, pat.pat_type)) ~env ~loc:pat.pat_loc
| Tpat_tuple l ->
List.iter l ~f:(search_pos_pat ~pos ~env)
- | Tpat_construct (_, _, _, l, _) ->
+ | Tpat_construct (_, _, l, _) ->
List.iter l ~f:(search_pos_pat ~pos ~env)
| Tpat_variant (_, None, _) -> ()
| Tpat_variant (_, Some pat, _) -> search_pos_pat pat ~pos ~env
| Tpat_record (l, _) ->
- List.iter l ~f:(fun (_, _, _, pat) -> search_pos_pat pat ~pos ~env)
+ List.iter l ~f:(fun (_, _, pat) -> search_pos_pat pat ~pos ~env)
| Tpat_array l ->
List.iter l ~f:(search_pos_pat ~pos ~env)
| Tpat_or (a, b, None) ->
View
4 otherlibs/labltk/browser/viewer.ml
@@ -63,13 +63,13 @@ let view_symbol ~kind ~env ?path id =
let path, vd = lookup_value id env in
view_signature_item ~path ~env [Sig_value (Ident.create name, vd)]
| Ptype -> view_type_id id ~env
- | Plabel -> let _,ld = lookup_label id env in
+ | Plabel -> let ld = lookup_label id env in
begin match ld.lbl_res.desc with
Tconstr (path, _, _) -> view_type_decl path ~env
| _ -> ()
end
| Pconstructor ->
- let _,cd = lookup_constructor id env in
+ let cd = lookup_constructor id env in
begin match cd.cstr_res.desc with
Tconstr (cpath, _, _) ->
if Path.same cpath Predef.path_exn then
View
12 tools/untypeast.ml
@@ -150,7 +150,7 @@ and untype_pattern pat =
| Tpat_constant cst -> Ppat_constant cst
| Tpat_tuple list ->
Ppat_tuple (List.map untype_pattern list)
- | Tpat_construct (path, lid, _, args, explicit_arity) ->
+ | Tpat_construct (lid, _, args, explicit_arity) ->
Ppat_construct (lid,
(match args with
[] -> None
@@ -163,7 +163,7 @@ and untype_pattern pat =
None -> None
| Some pat -> Some (untype_pattern pat))
| Tpat_record (list, closed) ->
- Ppat_record (List.map (fun (path, lid, _, pat) ->
+ Ppat_record (List.map (fun (lid, _, pat) ->
lid, untype_pattern pat) list, closed)
| Tpat_array list -> Ppat_array (List.map untype_pattern list)
| Tpat_or (p1, p2, _) -> Ppat_or (untype_pattern p1, untype_pattern p2)
@@ -221,7 +221,7 @@ and untype_expression exp =
untype_pattern pat, untype_expression exp) list)
| Texp_tuple list ->
Pexp_tuple (List.map untype_expression list)
- | Texp_construct (path, lid, _, args, explicit_arity) ->
+ | Texp_construct (lid, _, args, explicit_arity) ->
Pexp_construct (lid,
(match args with
[] -> None
@@ -235,15 +235,15 @@ and untype_expression exp =
None -> None
| Some exp -> Some (untype_expression exp))
| Texp_record (list, expo) ->
- Pexp_record (List.map (fun (path, lid, _, exp) ->
+ Pexp_record (List.map (fun (lid, _, exp) ->
lid, untype_expression exp
) list,
match expo with
None -> None
| Some exp -> Some (untype_expression exp))
- | Texp_field (exp, path, lid, label) ->
+ | Texp_field (exp, lid, label) ->
Pexp_field (untype_expression exp, lid)
- | Texp_setfield (exp1, path, lid, label, exp2) ->
+ | Texp_setfield (exp1, lid, label, exp2) ->
Pexp_setfield (untype_expression exp1, lid,
untype_expression exp2)
| Texp_array list ->
View
6 toplevel/genprintval.ml
@@ -154,10 +154,10 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
let tree_of_constr =
tree_of_qualified
- (fun lid env -> (snd (Env.lookup_constructor lid env)).cstr_res)
+ (fun lid env -> (Env.lookup_constructor lid env).cstr_res)
and tree_of_label =
- tree_of_qualified (fun lid env -> (snd (Env.lookup_label lid env)).lbl_res)
+ tree_of_qualified (fun lid env -> (Env.lookup_label lid env).lbl_res)
(* An abstract type *)
@@ -354,7 +354,7 @@ module Make(O : OBJ)(EVP : EVALPATH with type valu = O.t) = struct
try
(* Attempt to recover the constructor description for the exn
from its name *)
- let cstr = snd (Env.lookup_constructor lid env) in
+ let cstr = Env.lookup_constructor lid env in
let path =
match cstr.cstr_tag with
Cstr_exception (p, _) -> p | _ -> raise Not_found in
View
16 typing/datarepr.ml
@@ -48,7 +48,7 @@ let constructor_descrs ty_res cstrs priv =
cstrs;
let rec describe_constructors idx_const idx_nonconst = function
[] -> []
- | (name, ty_args, ty_res_opt) :: rem ->
+ | (id, ty_args, ty_res_opt) :: rem ->
let ty_res =
match ty_res_opt with
| Some ty_res' -> ty_res'
@@ -69,7 +69,8 @@ let constructor_descrs ty_res cstrs priv =
TypeSet.elements (TypeSet.diff arg_vars res_vars)
in
let cstr =
- { cstr_res = ty_res;
+ { cstr_name = Ident.name id;
+ cstr_res = ty_res;
cstr_existentials = existentials;
cstr_args = ty_args;
cstr_arity = List.length ty_args;
@@ -80,11 +81,12 @@ let constructor_descrs ty_res cstrs priv =
cstr_private = priv;
cstr_generalized = ty_res_opt <> None
} in
- (name, cstr) :: descr_rem in
+ (id, cstr) :: descr_rem in
describe_constructors 0 0 cstrs
let exception_descr path_exc decl =
- { cstr_res = Predef.type_exn;
+ { cstr_name = Path.last path_exc;
+ cstr_res = Predef.type_exn;
cstr_existentials = [];
cstr_args = decl.exn_args;
cstr_arity = List.length decl.exn_args;
@@ -106,9 +108,9 @@ let label_descrs ty_res lbls repres priv =
let all_labels = Array.create (List.length lbls) dummy_label in
let rec describe_labels num = function
[] -> []
- | (name, mut_flag, ty_arg) :: rest ->
+ | (id, mut_flag, ty_arg) :: rest ->
let lbl =
- { lbl_name = Ident.name name;
+ { lbl_name = Ident.name id;
lbl_res = ty_res;
lbl_arg = ty_arg;
lbl_mut = mut_flag;
@@ -117,7 +119,7 @@ let label_descrs ty_res lbls repres priv =
lbl_repres = repres;
lbl_private = priv } in
all_labels.(num) <- lbl;
- (name, lbl) :: describe_labels (num+1) rest in
+ (id, lbl) :: describe_labels (num+1) rest in
describe_labels 0 lbls
exception Constr_not_found
View
72 typing/env.ml
@@ -146,8 +146,8 @@ module EnvTbl =
type t = {
values: (Path.t * value_description) EnvTbl.t;
annotations: (Path.t * Annot.ident) EnvTbl.t;
- constrs: (Path.t * constructor_description) EnvTbl.t;
- labels: (Path.t * label_description) EnvTbl.t;
+ constrs: constructor_description EnvTbl.t;
+ labels: label_description EnvTbl.t;
constrs_by_path: (Path.t * (constructor_description list)) EnvTbl.t;
types: (Path.t * type_declaration) EnvTbl.t;
modules: (Path.t * module_type) EnvTbl.t;
@@ -223,9 +223,13 @@ let is_ident = function
let is_local (p, _) = is_ident p
+let is_local_exn = function
+ | {cstr_tag = Cstr_exception (p, _)} -> is_ident p
+ | _ -> false
+
let diff env1 env2 =
diff_keys is_local env1.values env2.values @
- diff_keys is_local env1.constrs env2.constrs @
+ diff_keys is_local_exn env1.constrs env2.constrs @
diff_keys is_local env1.modules env2.modules @
diff_keys is_local env1.classes env2.classes
@@ -572,9 +576,9 @@ let lookup_value =
let lookup_annot id e =
lookup (fun env -> env.annotations) (fun sc -> sc.comp_annotations) id e
and lookup_constructor =
- lookup (fun env -> env.constrs) (fun sc -> sc.comp_constrs)
+ lookup_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs)
and lookup_label =
- lookup (fun env -> env.labels) (fun sc -> sc.comp_labels)
+ lookup_simple (fun env -> env.labels) (fun sc -> sc.comp_labels)
and lookup_type =
lookup (fun env -> env.types) (fun sc -> sc.comp_types)
and lookup_modtype =
@@ -644,9 +648,9 @@ let ty_path = function
| _ -> assert false
let lookup_constructor lid env =
- let (_,desc) as c = lookup_constructor lid env in
+ let desc = lookup_constructor lid env in
mark_type_path env (ty_path desc.cstr_res);
- c
+ desc
let mark_constructor usage env name desc =
match desc.cstr_tag with
@@ -662,9 +666,9 @@ let mark_constructor usage env name desc =
mark_constructor_used usage ty_name ty_decl name
let lookup_label lid env =
- let (_,desc) as c = lookup_label lid env in
+ let desc = lookup_label lid env in
mark_type_path env (ty_path desc.lbl_res);
- c
+ desc
let lookup_class lid env =
let (_, desc) as r = lookup_class lid env in
@@ -835,21 +839,21 @@ and components_of_module_maker (env, sub, path, mty) =
let decl' = Subst.type_declaration sub decl in
c.comp_types <-
Tbl.add (Ident.name id) (decl', nopos) c.comp_types;
- let constructors = constructors_of_type path decl' in
+ let constructors = List.map snd (constructors_of_type path decl') in
c.comp_constrs_by_path <-
Tbl.add (Ident.name id)
- (List.map snd constructors, nopos) c.comp_constrs_by_path;
+ (constructors, nopos) c.comp_constrs_by_path;
List.iter
- (fun (name, descr) ->
+ (fun descr ->
c.comp_constrs <-
- Tbl.add (Ident.name name) (descr, nopos) c.comp_constrs)
+ Tbl.add descr.cstr_name (descr, nopos) c.comp_constrs)
constructors;
let labels = labels_of_type path decl' in
List.iter
- (fun (name, descr) ->
+ (fun (_, descr) ->
c.comp_labels <-
- Tbl.add (Ident.name name) (descr, nopos) c.comp_labels)
- (labels);
+ Tbl.add 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
@@ -942,8 +946,7 @@ and store_type id path info env =
then begin
let ty = Ident.name id in
List.iter
- begin fun (c, _) ->
- let c = Ident.name c in
+ begin fun (_, {cstr_name = c; _}) ->
let k = (ty, loc, c) in
if not (Hashtbl.mem used_constructors k) then
let used = constructor_usages () in
@@ -961,18 +964,15 @@ and store_type id path info env =
{ env with
constrs =
List.fold_right
- (fun (name, descr) constrs ->
- EnvTbl.add name (path_subst_last path name, descr) constrs)
+ (fun (id, descr) constrs -> EnvTbl.add id descr constrs)
constructors
env.constrs;
constrs_by_path =
- EnvTbl.add id
- (path,List.map snd constructors) env.constrs_by_path;
+ EnvTbl.add id (path, List.map snd constructors) env.constrs_by_path;
labels =
List.fold_right
- (fun (name, descr) labels ->
- EnvTbl.add name (path_subst_last path name, descr) labels)
+ (fun (id, descr) labels -> EnvTbl.add id descr labels)
labels
env.labels;
types = EnvTbl.add id (path, info) env.types;
@@ -1010,8 +1010,7 @@ and store_exception id path decl env =
end;
end;
{ env with
- constrs = EnvTbl.add id (path_subst_last path id,
- Datarepr.exception_descr path decl) env.constrs;
+ constrs = EnvTbl.add id (Datarepr.exception_descr path decl) env.constrs;
summary = Env_exception(env.summary, id, decl) }
and store_module id path mty env =
@@ -1258,6 +1257,23 @@ let find_all proj1 proj2 f lid env acc =
raise Not_found
end
+let find_all_simple proj1 proj2 f lid env acc =
+ match lid with
+ | None ->
+ ident_tbl_fold
+ (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)
+ (proj2 c) acc
+ | Functor_comps _ ->
+ raise Not_found
+ end
+
let fold_modules f lid env acc =
match lid with
| None ->
@@ -1293,9 +1309,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 (fun env -> env.constrs) (fun sc -> sc.comp_constrs) f
+ find_all_simple (fun env -> env.constrs) (fun sc -> sc.comp_constrs) f
and fold_labels f =
- find_all (fun env -> env.labels) (fun sc -> sc.comp_labels) f
+ find_all_simple (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 =
View
8 typing/env.mli
@@ -60,8 +60,8 @@ 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 -> Path.t * constructor_description
-val lookup_label: Longident.t -> t -> Path.t * label_description
+val lookup_constructor: Longident.t -> t -> constructor_description
+val lookup_label: Longident.t -> t -> label_description
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
@@ -195,10 +195,10 @@ val fold_types:
(string -> Path.t -> Types.type_declaration -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
val fold_constructors:
- (string -> Path.t -> Types.constructor_description -> 'a -> 'a) ->
+ (Types.constructor_description -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
val fold_labels:
- (string -> Path.t -> Types.label_description -> 'a -> 'a) ->
+ (Types.label_description -> 'a -> 'a) ->
Longident.t option -> t -> 'a -> 'a
(** Persistent structures are only traversed if they are already loaded. *)
View
134 typing/parmatch.ml
@@ -61,9 +61,9 @@ let records_args l1 l2 =
(* Invariant: fields are already sorted by Typecore.type_label_a_list *)
let rec combine r1 r2 l1 l2 = match l1,l2 with
| [],[] -> List.rev r1, List.rev r2
- | [],(_,_,_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2
- | (_,_,_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 []
- | (_,_,lbl1,p1)::rem1, (_, _,lbl2,p2)::rem2 ->
+ | [],(_,_,p2)::rem2 -> combine (omega::r1) (p2::r2) [] rem2
+ | (_,_,p1)::rem1,[] -> combine (p1::r1) (omega::r2) rem1 []
+ | (_,lbl1,p1)::rem1, ( _,lbl2,p2)::rem2 ->
if lbl1.lbl_pos < lbl2.lbl_pos then
combine (p1::r1) (omega::r2) rem1 l2
else if lbl1.lbl_pos > lbl2.lbl_pos then
@@ -84,7 +84,7 @@ let rec compat p q =
| Tpat_constant c1, Tpat_constant c2 -> const_compare c1 c2 = 0
| Tpat_tuple ps, Tpat_tuple qs -> compats ps qs
| Tpat_lazy p, Tpat_lazy q -> compat p q
- | Tpat_construct (_, _, c1,ps1, _), Tpat_construct (_, _, c2,ps2, _) ->
+ | Tpat_construct (_, c1,ps1, _), Tpat_construct (_, c2,ps2, _) ->
c1.cstr_tag = c2.cstr_tag && compats ps1 ps2
| Tpat_variant(l1,Some p1, r1), Tpat_variant(l2,Some p2,_) ->
l1=l2 && compat p1 p2
@@ -197,13 +197,13 @@ let rec pretty_val ppf v =
| Tpat_constant c -> fprintf ppf "%s" (pretty_const c)
| Tpat_tuple vs ->
fprintf ppf "@[(%a)@]" (pretty_vals ",") vs
- | Tpat_construct (_, _, {cstr_tag=tag},[], _) ->
+ | Tpat_construct (_, {cstr_tag=tag},[], _) ->
let name = get_constr_name tag v.pat_type v.pat_env in
fprintf ppf "%s" name
- | Tpat_construct (_, _, {cstr_tag=tag},[w], _) ->
+ | Tpat_construct (_, {cstr_tag=tag},[w], _) ->
let name = get_constr_name tag v.pat_type v.pat_env in
fprintf ppf "@[<2>%s@ %a@]" name pretty_arg w
- | Tpat_construct (_, _, {cstr_tag=tag},vs, _) ->
+ | Tpat_construct (_, {cstr_tag=tag},vs, _) ->
let name = get_constr_name tag v.pat_type v.pat_env in
begin match (name, vs) with
("::", [v1;v2]) ->
@@ -220,7 +220,7 @@ let rec pretty_val ppf v =
(pretty_lvals (get_record_labels v.pat_type v.pat_env))
(List.filter
(function
- | (_,_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *)
+ | (_,_,{pat_desc=Tpat_any}) -> false (* do not show lbl=_ *)
| _ -> true) lvs)
| Tpat_array vs ->
fprintf ppf "@[[| %a |]@]" (pretty_vals " ;") vs
@@ -232,19 +232,19 @@ let rec pretty_val ppf v =
fprintf ppf "@[(%a|@,%a)@]" pretty_or v pretty_or w
and pretty_car ppf v = match v.pat_desc with
-| Tpat_construct (_,_,{cstr_tag=tag}, [_ ; _], _)
+| Tpat_construct (_,{cstr_tag=tag}, [_ ; _], _)
when is_cons tag v ->
fprintf ppf "(%a)" pretty_val v
| _ -> pretty_val ppf v
and pretty_cdr ppf v = match v.pat_desc with
-| Tpat_construct (_,_,{cstr_tag=tag}, [v1 ; v2], _)
+| Tpat_construct (_,{cstr_tag=tag}, [v1 ; v2], _)
when is_cons tag v ->
fprintf ppf "%a::@,%a" pretty_car v1 pretty_cdr v2
| _ -> pretty_val ppf v
and pretty_arg ppf v = match v.pat_desc with
-| Tpat_construct (_,_,_,_::_, _) -> fprintf ppf "(%a)" pretty_val v
+| Tpat_construct (_,_,_::_, _) -> fprintf ppf "(%a)" pretty_val v
| _ -> pretty_val ppf v
and pretty_or ppf v = match v.pat_desc with
@@ -260,10 +260,10 @@ and pretty_vals sep ppf = function
and pretty_lvals lbls ppf = function
| [] -> ()
- | [_, _,lbl,v] ->
+ | [_,lbl,v] ->
let name = find_label lbl lbls in
fprintf ppf "%s=%a" (Ident.name name) pretty_val v
- | (_, _, lbl,v)::rest ->
+ | (_, lbl,v)::rest ->
let name = find_label lbl lbls in
fprintf ppf "%s=%a;@ %a"
(Ident.name name) pretty_val v (pretty_lvals lbls) rest
@@ -284,7 +284,7 @@ let prerr_pat v =
(* Check top matching *)
let simple_match p1 p2 =
match p1.pat_desc, p2.pat_desc with
- | Tpat_construct(_, _, c1, _, _), Tpat_construct(_,_, c2, _, _) ->
+ | Tpat_construct(_, c1, _, _), Tpat_construct(_, c2, _, _) ->
c1.cstr_tag = c2.cstr_tag
| Tpat_variant(l1, _, _), Tpat_variant(l2, _, _) ->
l1 = l2
@@ -308,26 +308,25 @@ let record_arg p = match p.pat_desc with
(* Raise Not_found when pos is not present in arg *)
let get_field pos arg =
- let _,_,_, p = List.find (fun (_,_,lbl,_) -> pos = lbl.lbl_pos) arg in
+ let _,_, p = List.find (fun (_,lbl,_) -> pos = lbl.lbl_pos) arg in
p
let extract_fields omegas arg =
List.map
- (fun (_,_,lbl,_) ->
+ (fun (_,lbl,_) ->
try
get_field lbl.lbl_pos arg
with Not_found -> omega)
omegas
let all_record_args lbls = match lbls with
-| (_,_,{lbl_all=lbl_all},_)::_ ->
+| (_,{lbl_all=lbl_all},_)::_ ->
let t =
Array.map
- (fun lbl -> Path.Pident (Ident.create "?temp?"),
- mknoloc (Longident.Lident "?temp?"), lbl,omega)
+ (fun lbl -> mknoloc (Longident.Lident "?temp?"), lbl,omega)
lbl_all in
List.iter
- (fun ((_,_, lbl,_) as x) -> t.(lbl.lbl_pos) <- x)
+ (fun ((_, lbl,_) as x) -> t.(lbl.lbl_pos) <- x)
lbls ;
Array.to_list t
| _ -> fatal_error "Parmatch.all_record_args"
@@ -336,15 +335,15 @@ let all_record_args lbls = match lbls with
(* Build argument list when p2 >= p1, where p1 is a simple pattern *)
let rec simple_match_args p1 p2 = match p2.pat_desc with
| Tpat_alias (p2,_,_) -> simple_match_args p1 p2
-| Tpat_construct(_,_, cstr, args, _) -> args
+| Tpat_construct(_, cstr, args, _) -> args
| Tpat_variant(lab, Some arg, _) -> [arg]
| Tpat_tuple(args) -> args
| Tpat_record(args,_) -> extract_fields (record_arg p1) args
| Tpat_array(args) -> args
| Tpat_lazy arg -> [arg]
| (Tpat_any | Tpat_var(_)) ->
begin match p1.pat_desc with
- Tpat_construct(_,_, _,args, _) -> omega_list args
+ Tpat_construct(_, _,args, _) -> omega_list args
| Tpat_variant(_, Some _, _) -> [omega]
| Tpat_tuple(args) -> omega_list args
| Tpat_record(args,_) -> omega_list args
@@ -365,9 +364,9 @@ let rec normalize_pat q = match q.pat_desc with
| Tpat_alias (p,_,_) -> normalize_pat p
| Tpat_tuple (args) ->
make_pat (Tpat_tuple (omega_list args)) q.pat_type q.pat_env
- | Tpat_construct (lid, lid_loc, c,args,explicit_arity) ->
+ | Tpat_construct (lid, c,args,explicit_arity) ->
make_pat
- (Tpat_construct (lid, lid_loc, c,omega_list args, explicit_arity))
+ (Tpat_construct (lid, c,omega_list args, explicit_arity))
q.pat_type q.pat_env
| Tpat_variant (l, arg, row) ->
make_pat (Tpat_variant (l, may_map (fun _ -> omega) arg, row))
@@ -376,8 +375,8 @@ let rec normalize_pat q = match q.pat_desc with
make_pat (Tpat_array (omega_list args)) q.pat_type q.pat_env
| Tpat_record (largs, closed) ->
make_pat
- (Tpat_record (List.map (fun (lid,lid_loc,lbl,_) ->
- lid, lid_loc, lbl,omega) largs, closed))
+ (Tpat_record (List.map (fun (lid,lbl,_) ->
+ lid, lbl,omega) largs, closed))
q.pat_type q.pat_env
| Tpat_lazy _ ->
make_pat (Tpat_lazy omega) q.pat_type q.pat_env
@@ -402,12 +401,12 @@ let discr_pat q pss =
| (({pat_desc = Tpat_record (largs,closed)} as p)::_)::pss ->
let new_omegas =
List.fold_right
- (fun (lid, lid_loc, lbl,_) r ->
+ (fun (lid, lbl,_) r ->
try
let _ = get_field lbl.lbl_pos r in
r
with Not_found ->
- (lid, lid_loc, lbl,omega)::r)
+ (lid, lbl,omega)::r)
largs (record_arg acc)
in
acc_pat
@@ -440,22 +439,22 @@ let do_set_args erase_mutable q r = match q with
let args,rest = read_args omegas r in
make_pat
(Tpat_record
- (List.map2 (fun (lid, lid_loc, lbl,_) arg ->
+ (List.map2 (fun (lid, lbl,_) arg ->
if
erase_mutable &&
(match lbl.lbl_mut with
| Mutable -> true | Immutable -> false)
then
- lid, lid_loc, lbl, omega
+ lid, lbl, omega
else
- lid, lid_loc, lbl, arg)
+ lid, lbl, arg)
omegas args, closed))
q.pat_type q.pat_env::
rest
-| {pat_desc = Tpat_construct (lid, lid_loc, c,omegas, explicit_arity)} ->
+| {pat_desc = Tpat_construct (lid, c,omegas, explicit_arity)} ->
let args,rest = read_args omegas r in
make_pat
- (Tpat_construct (lid, lid_loc, c,args, explicit_arity))
+ (Tpat_construct (lid, c,args, explicit_arity))
q.pat_type q.pat_env::
rest
| {pat_desc = Tpat_variant (l, omega, row)} ->
@@ -624,7 +623,7 @@ let row_of_pat pat =
let generalized_constructor x =
match x with
- ({pat_desc = Tpat_construct(_,_,c,_, _);pat_env=env},_) ->
+ ({pat_desc = Tpat_construct(_,c,_, _);pat_env=env},_) ->
c.cstr_generalized
| _ -> assert false
@@ -638,9 +637,9 @@ let clean_env env =
loop env
let full_match ignore_generalized closing env = match env with
-| ({pat_desc = Tpat_construct (_,_,{cstr_tag=Cstr_exception _},_,_)},_)::_ ->
+| ({pat_desc = Tpat_construct (_,{cstr_tag=Cstr_exception _},_,_)},_)::_ ->
false
-| ({pat_desc = Tpat_construct(_,_,c,_,_);pat_type=typ},_) :: _ ->
+| ({pat_desc = Tpat_construct(_,c,_,_);pat_type=typ},_) :: _ ->
if ignore_generalized then
(* remove generalized constructors;
those cases will be handled separately *)
@@ -683,12 +682,12 @@ let full_match ignore_generalized closing env = match env with
| _ -> fatal_error "Parmatch.full_match"
let full_match_gadt env = match env with
- | ({pat_desc = Tpat_construct(_,_,c,_,_);pat_type=typ},_) :: _ ->
+ | ({pat_desc = Tpat_construct(_,c,_,_);pat_type=typ},_) :: _ ->
List.length env = c.cstr_consts + c.cstr_nonconsts
| _ -> true
let extendable_match env = match env with
-| ({pat_desc=Tpat_construct(_,_,{cstr_tag=(Cstr_constant _|Cstr_block _)},_,_)}
+| ({pat_desc=Tpat_construct(_,{cstr_tag=(Cstr_constant _|Cstr_block _)},_,_)}
as p,_) :: _ ->
let path = get_type_path p.pat_type p.pat_env in
not
@@ -702,7 +701,7 @@ let should_extend ext env = match ext with
| None -> false
| Some ext -> match env with
| ({pat_desc =
- Tpat_construct(_, _, {cstr_tag=(Cstr_constant _|Cstr_block _)},_,_)}
+ Tpat_construct(_, {cstr_tag=(Cstr_constant _|Cstr_block _)},_,_)}
as p, _) :: _ ->
let path = get_type_path p.pat_type p.pat_env in
Path.same path ext
@@ -732,8 +731,7 @@ let complete_tags nconsts nconstrs tags =
(* build a pattern from a constructor list *)
let pat_of_constr ex_pat cstr =
{ex_pat with pat_desc =
- Tpat_construct (Path.Pident (Ident.create "?pat_of_constr?"),
- mknoloc (Longident.Lident "?pat_of_constr?"),
+ Tpat_construct (mknoloc (Longident.Lident "?pat_of_constr?"),
cstr,omegas cstr.cstr_arity,false)}
let rec pat_of_constrs ex_pat = function
@@ -771,7 +769,7 @@ let rec map_filter f =
(* Sends back a pattern that complements constructor tags all_tag *)
let complete_constrs p all_tags =
match p.pat_desc with
- | Tpat_construct (_,_,c,_,_) ->
+ | Tpat_construct (_,c,_,_) ->
begin try
let not_tags = complete_tags c.cstr_consts c.cstr_nonconsts all_tags in
let constrs =
@@ -804,22 +802,22 @@ let build_other_constant proj make first next p env =
let build_other ext env = match env with
| ({pat_desc =
- Tpat_construct (lid, lid_loc, ({cstr_tag=Cstr_exception _} as c),_,_)},_)
+ Tpat_construct (lid, ({cstr_tag=Cstr_exception _} as c),_,_)},_)
::_ ->
make_pat
(Tpat_construct
- (lid, lid_loc, {c with
+ (lid, {c with
cstr_tag=(Cstr_exception
(Path.Pident (Ident.create "*exception*"), Location.none))},
[], false))
Ctype.none Env.empty
-| ({pat_desc = Tpat_construct (_,_, _,_,_)} as p,_) :: _ ->
+| ({pat_desc = Tpat_construct (_, _,_,_)} as p,_) :: _ ->
begin match ext with
| Some ext when Path.same ext (get_type_path p.pat_type p.pat_env) ->
extra_pat
| _ ->
let get_tag = function
- | {pat_desc = Tpat_construct (_,_,c,_,_)} -> c.cstr_tag
+ | {pat_desc = Tpat_construct (_,c,_,_)} -> c.cstr_tag
| _ -> fatal_error "Parmatch.get_tag" in
let all_tags = List.map (fun (p,_) -> get_tag p) env in
pat_of_constrs p (complete_constrs p all_tags)
@@ -936,7 +934,7 @@ let build_other_gadt ext env =
match env with
| ({pat_desc = Tpat_construct _} as p,_) :: _ ->
let get_tag = function
- | {pat_desc = Tpat_construct (_,_,c,_,_)} -> c.cstr_tag
+ | {pat_desc = Tpat_construct (_,c,_,_)} -> c.cstr_tag
| _ -> fatal_error "Parmatch.get_tag" in
let all_tags = List.map (fun (p,_) -> get_tag p) env in
let cnstrs = complete_constrs p all_tags in
@@ -960,9 +958,9 @@ let rec has_instance p = match p.pat_desc with
| Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_,None,_) -> true
| Tpat_alias (p,_,_) | Tpat_variant (_,Some p,_) -> has_instance p
| Tpat_or (p1,p2,_) -> has_instance p1 || has_instance p2
- | Tpat_construct (_, _,_,ps,_) | Tpat_tuple ps | Tpat_array ps ->
+ | Tpat_construct (_,_,ps,_) | Tpat_tuple ps | Tpat_array ps ->
has_instances ps
- | Tpat_record (lps,_) -> has_instances (List.map (fun (_,_,_,x) -> x) lps)
+ | Tpat_record (lps,_) -> has_instances (List.map (fun (_,_,x) -> x) lps)
| Tpat_lazy p
-> has_instance p
@@ -1528,7 +1526,7 @@ let rec le_pat p q =
| Tpat_alias(p,_,_), _ -> le_pat p q
| _, Tpat_alias(q,_,_) -> le_pat p q
| Tpat_constant(c1), Tpat_constant(c2) -> const_compare c1 c2 = 0
- | Tpat_construct(_,_,c1,ps,_), Tpat_construct(_,_,c2,qs,_) ->
+ | Tpat_construct(_,c1,ps,_), Tpat_construct(_,c2,qs,_) ->
c1.cstr_tag = c2.cstr_tag && le_pats ps qs
| Tpat_variant(l1,Some p1,_), Tpat_variant(l2,Some p2,_) ->
(l1 = l2 && le_pat p1 p2)
@@ -1578,10 +1576,10 @@ let rec lub p q = match p.pat_desc,q.pat_desc with
| Tpat_lazy p, Tpat_lazy q ->
let r = lub p q in
make_pat (Tpat_lazy r) p.pat_type p.pat_env
-| Tpat_construct (lid, lid_loc, c1,ps1,_), Tpat_construct (_, _,c2,ps2,_)
+| Tpat_construct (lid, c1,ps1,_), Tpat_construct (_,c2,ps2,_)
when c1.cstr_tag = c2.cstr_tag ->
let rs = lubs ps1 ps2 in
- make_pat (Tpat_construct (lid, lid_loc, c1,rs, false))
+ make_pat (Tpat_construct (lid, c1,rs, false))
p.pat_type p.pat_env
| Tpat_variant(l1,Some p1,row), Tpat_variant(l2,Some p2,_)
when l1=l2 ->
@@ -1613,13 +1611,13 @@ and record_lubs l1 l2 =
let rec lub_rec l1 l2 = match l1,l2 with
| [],_ -> l2
| _,[] -> l1
- | (lid1, lid1_loc, lbl1,p1)::rem1, (lid2, lid2_loc, lbl2,p2)::rem2 ->
+ | (lid1, lbl1,p1)::rem1, (lid2, lbl2,p2)::rem2 ->
if lbl1.lbl_pos < lbl2.lbl_pos then
- (lid1, lid1_loc, lbl1,p1)::lub_rec rem1 l2
+ (lid1, lbl1,p1)::lub_rec rem1 l2
else if lbl2.lbl_pos < lbl1.lbl_pos then
- (lid2, lid2_loc, lbl2,p2)::lub_rec l1 rem2
+ (lid2, lbl2,p2)::lub_rec l1 rem2
else
- (lid1, lid1_loc, lbl1,lub p1 p2)::lub_rec rem1 rem2 in
+ (lid1, lbl1,lub p1 p2)::lub_rec rem1 rem2 in
lub_rec l1 l2
and lubs ps qs = match ps,qs with
@@ -1767,8 +1765,8 @@ module Conv = struct
let conv (typed: Typedtree.pattern) :
Parsetree.pattern list *
- (string,Path.t * Types.constructor_description) Hashtbl.t *
- (string,Path.t * Types.label_description) Hashtbl.t
+ (string, Types.constructor_description) Hashtbl.t *
+ (string, Types.label_description) Hashtbl.t
=
let constrs = Hashtbl.create 0 in
let labels = Hashtbl.create 0 in
@@ -1784,10 +1782,10 @@ module Conv = struct
List.map
(fun lst -> mkpat (Ppat_tuple lst))
results
- | Tpat_construct (cstr_path, cstr_lid, cstr,lst,_) ->
+ | Tpat_construct (cstr_lid, cstr,lst,_) ->
let id = fresh () in
let lid = { cstr_lid with txt = Longident.Lident id } in
- Hashtbl.add constrs id (cstr_path,cstr);
+ Hashtbl.add constrs id cstr;
let results = select (List.map loop lst) in
begin match lst with
[] ->
@@ -1818,13 +1816,13 @@ module Conv = struct
| Tpat_record (subpatterns, _closed_flag) ->
let pats =
select
- (List.map (fun (_,_,_,x) -> (loop x)) subpatterns)
+ (List.map (fun (_,_,x) -> loop x) subpatterns)
in
let label_idents =
List.map
- (fun (lbl_path,_,lbl,_) ->
+ (fun (_,lbl,_) ->
let id = fresh () in
- Hashtbl.add labels id (lbl_path, lbl);
+ Hashtbl.add labels id lbl;
Longident.Lident id)
subpatterns
in
@@ -1932,19 +1930,19 @@ let extendable_path path =
Path.same path Predef.path_option)
let rec collect_paths_from_pat r p = match p.pat_desc with
-| Tpat_construct(_, _, {cstr_tag=(Cstr_constant _|Cstr_block _)},ps,_) ->
+| Tpat_construct(_, {cstr_tag=(Cstr_constant _|Cstr_block _)},ps,_) ->
let path = get_type_path p.pat_type p.pat_env in
List.fold_left
collect_paths_from_pat
(if extendable_path path then add_path path r else r)
ps
| Tpat_any|Tpat_var _|Tpat_constant _| Tpat_variant (_,None,_) -> r
| Tpat_tuple ps | Tpat_array ps
-| Tpat_construct (_, _, {cstr_tag=Cstr_exception _}, ps,_)->
+| Tpat_construct (_, {cstr_tag=Cstr_exception _}, ps,_)->
List.fold_left collect_paths_from_pat r ps
| Tpat_record (lps,_) ->
List.fold_left
- (fun r (_, _, _, p) -> collect_paths_from_pat r p)
+ (fun r (_, _, p) -> collect_paths_from_pat r p)
r lps
| Tpat_variant (_, Some p, _) | Tpat_alias (p,_,_) -> collect_paths_from_pat r p
| Tpat_or (p1,p2,_) ->
@@ -2034,12 +2032,12 @@ let rec inactive pat = match pat with
false
| Tpat_any | Tpat_var _ | Tpat_constant _ | Tpat_variant (_, None, _) ->
true
-| Tpat_tuple ps | Tpat_construct (_, _, _, ps,_) | Tpat_array ps ->
+| Tpat_tuple ps | Tpat_construct (_, _, ps,_) | Tpat_array ps ->
List.for_all (fun p -> inactive p.pat_desc) ps
| Tpat_alias (p,_,_) | Tpat_variant (_, Some p, _) ->
inactive p.pat_desc
| Tpat_record (ldps,_) ->
- List.exists (fun (_, _, _, p) -> inactive p.pat_desc) ldps
+ List.exists (fun (_, _, p) -> inactive p.pat_desc) ldps
| Tpat_or (p,q,_) ->
inactive p.pat_desc && inactive q.pat_desc
View
8 typing/parmatch.mli
@@ -26,8 +26,8 @@ val omegas : int -> pattern list
val omega_list : 'a list -> pattern list
val normalize_pat : pattern -> pattern
val all_record_args :
- (Path.t * Longident.t loc * label_description * pattern) list ->
- (Path.t * Longident.t loc * label_description * pattern) list
+ (Longident.t loc * label_description * pattern) list ->
+ (Longident.t loc * label_description * pattern) list
val const_compare : constant -> constant -> int
val le_pat : pattern -> pattern -> bool
@@ -55,8 +55,8 @@ val complete_constrs :
val pressure_variants: Env.t -> pattern list -> unit
val check_partial: Location.t -> (pattern * expression) list -> partial
val check_partial_gadt:
- ((string,Path.t * constructor_description) Hashtbl.t ->
- (string,Path.t * label_description) Hashtbl.t ->
+ ((string, constructor_description) Hashtbl.t ->
+ (string, label_description) Hashtbl.t ->
Parsetree.pattern -> pattern option) ->
Location.t -> (pattern * expression) list -> partial
val check_unused: Env.t -> (pattern * expression) list -> unit
View
24 typing/printtyped.ml
@@ -207,8 +207,8 @@ and pattern i ppf x =
| Tpat_tuple (l) ->
line i ppf "Ppat_tuple\n";
list i pattern ppf l;
- | Tpat_construct (li, _, _, po, explicity_arity) ->
- line i ppf "Ppat_construct %a\n" fmt_path li;
+ | Tpat_construct (li, _, po, explicity_arity) ->
+ line i ppf "Ppat_construct %a\n" fmt_longident li;
list i pattern ppf po;
bool i ppf explicity_arity;
| Tpat_variant (l, po, _) ->
@@ -275,8 +275,8 @@ and expression i ppf x =
| Texp_tuple (l) ->
line i ppf "Pexp_tuple\n";
list i expression ppf l;
- | Texp_construct (li, _, _, eo, b) ->
- line i ppf "Pexp_construct %a\n" fmt_path li;
+ | Texp_construct (li, _, eo, b) ->
+ line i ppf "Pexp_construct %a\n" fmt_longident li;
list i expression ppf eo;
bool i ppf b;
| Texp_variant (l, eo) ->
@@ -286,14 +286,14 @@ and expression i ppf x =
line i ppf "Pexp_record\n";
list i longident_x_expression ppf l;
option i expression ppf eo;
- | Texp_field (e, li, _, _) ->
+ | Texp_field (e, li, _) ->
line i ppf "Pexp_field\n";
expression i ppf e;
- path i ppf li;
- | Texp_setfield (e1, li, _, _, e2) ->
+ longident i ppf li;
+ | Texp_setfield (e1, li, _, e2) ->
line i ppf "Pexp_setfield\n";
expression i ppf e1;
- path i ppf li;
+ longident i ppf li;
expression i ppf e2;
| Texp_array (l) ->
line i ppf "Pexp_array\n";
@@ -714,8 +714,8 @@ and string_list_x_location i ppf (l, loc) =
line i ppf "<params> %a\n" fmt_location loc;
list (i+1) string_loc ppf l;
-and longident_x_pattern i ppf (li, _, _, p) =
- line i ppf "%a\n" fmt_path li;
+and longident_x_pattern i ppf (li, _, p) =
+ line i ppf "%a\n" fmt_longident li;
pattern (i+1) ppf p;
and pattern_x_expression_case i ppf (p, e) =
@@ -732,8 +732,8 @@ and string_x_expression i ppf (s, _, e) =
line i ppf "<override> \"%a\"\n" fmt_path s;
expression (i+1) ppf e;
-and longident_x_expression i ppf (li, _, _, e) =
- line i ppf "%a\n" fmt_path li;
+and longident_x_expression i ppf (li, _, e) =
+ line i ppf "%a\n" fmt_longident li;
expression (i+1) ppf e;
and label_x_expression i ppf (l, e, _) =
View
75 typing/typecore.ml
@@ -103,7 +103,6 @@ let rp node =
let snd3 (_,x,_) = x
-let thd4 (_,_, x,_) = x
(* Upper approximation of free identifiers on the parse tree *)
@@ -227,14 +226,14 @@ let mkexp exp_desc exp_type exp_loc exp_env =
let option_none ty loc =
let lid = Longident.Lident "None" in
- let (path, cnone) = Env.lookup_constructor lid Env.initial in
- mkexp (Texp_construct( path, mknoloc lid, cnone, [], false))
+ let cnone = Env.lookup_constructor lid Env.initial in
+ mkexp (Texp_construct(mknoloc lid, cnone, [], false))
ty loc Env.initial
let option_some texp =
let lid = Longident.Lident "Some" in
- let (path, csome) = Env.lookup_constructor lid Env.initial in
- mkexp ( Texp_construct(path, mknoloc lid , csome, [texp],false) )
+ let csome = Env.lookup_constructor lid Env.initial in
+ mkexp ( Texp_construct(mknoloc lid , csome, [texp],false) )
(type_option texp.exp_type) texp.exp_loc texp.exp_env
let extract_option_type env ty =
@@ -424,7 +423,7 @@ let rec build_as_type env p =
| Tpat_tuple pl ->
let tyl = List.map (build_as_type env) pl in
newty (Ttuple tyl)
- | Tpat_construct(_, _, cstr, pl,_) ->
+ | Tpat_construct(_, cstr, pl,_) ->
let keep = cstr.cstr_private = Private || cstr.cstr_existentials <> [] in
if keep then p.pat_type else
let tyl = List.map (build_as_type env) pl in
@@ -438,10 +437,10 @@ let rec build_as_type env p =
row_bound=(); row_name=None;
row_fixed=false; row_closed=false})
| Tpat_record (lpl,_) ->
- let lbl = thd4 (List.hd lpl) in
+ let lbl = snd3 (List.hd lpl) in
if lbl.lbl_private = Private then p.pat_type else
let ty = newvar () in
- let ppl = List.map (fun (_, _, l, p) -> l.lbl_pos, p) lpl in
+ let ppl = List.map (fun (_, l, p) -> l.lbl_pos, p) lpl in
let do_label lbl =
let _, ty_arg, ty_res = instance_label false lbl in
unify_pat env {p with pat_type = ty} ty_res;
@@ -529,20 +528,20 @@ let type_label_a_list ?labels env type_lbl_a lid_a_list =
let lbl_a_list =
List.map
(fun (lid, a) ->
- let path, label =
+ let label =
match lid.txt, labels, record_qual with
Longident.Lident s, Some labels, _ when Hashtbl.mem labels s ->
- (Hashtbl.find labels s : Path.t * Types.label_description)
+ (Hashtbl.find labels s : Types.label_description)
| Longident.Lident s, _, Some modname ->
Typetexp.find_label env lid.loc (Longident.Ldot (modname, s))
| _ ->
Typetexp.find_label env lid.loc lid.txt
- in (path, lid, label, a)
+ in (lid, label, a)
) 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
@@ -560,10 +559,10 @@ let lid_of_label label =
let check_recordpat_labels loc lbl_pat_list closed =
match lbl_pat_list with
| [] -> () (* should not happen *)
- | (_, _, label1, _) :: _ ->
+ | (_, label1, _) :: _ ->
let all = label1.lbl_all in
let defined = Array.make (Array.length all) false in
- let check_defined (_, _, label, _) =
+ let check_defined (_, label, _) =
if defined.(label.lbl_pos)
then raise(Error(loc, Label_multiply_defined
(Longident.Lident label.lbl_name)))
@@ -682,7 +681,7 @@ 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_path, constr) =
+ let constr =
match lid.txt, constrs with
Longident.Lident s, Some constrs when Hashtbl.mem constrs s ->
Hashtbl.find constrs s
@@ -718,7 +717,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
unify_pat_types loc !env ty_res expected_ty;
let args = List.map2 (fun p t -> type_pat p t) sargs ty_args in
rp {
- pat_desc=Tpat_construct(constr_path, lid, constr, args,explicit_arity);
+ pat_desc=Tpat_construct(lid, constr, args,explicit_arity);
pat_loc = loc; pat_extra=[];
pat_type = expected_ty;
pat_env = !env }
@@ -739,7 +738,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
pat_type = expected_ty;
pat_env = !env }
| Ppat_record(lid_sp_list, closed) ->
- let type_label_pat (label_path, label_lid, label, sarg) =
+ let type_label_pat (label_lid, label, sarg) =
begin_def ();
let (vars, ty_arg, ty_res) = instance_label false label in
if vars = [] then end_def ();
@@ -759,7 +758,7 @@ let rec type_pat ~constrs ~labels ~no_existentials ~mode ~env sp expected_ty =
if List.exists instantiated vars then
raise (Error(loc, Polymorphic_label (lid_of_label label)))
end;
- (label_path, label_lid, label, arg)
+ (label_lid, label, arg)
in
let lbl_pat_list =
type_label_a_list ?labels !env type_label_pat lid_sp_list in
@@ -1010,15 +1009,15 @@ let rec is_nonexpansive exp =
is_nonexpansive e && List.for_all is_nonexpansive_opt (List.map snd3 el)
| Texp_tuple el ->
List.for_all is_nonexpansive el
- | Texp_construct(_, _, _, el,_) ->
+ | Texp_construct( _, _, el,_) ->
List.for_all is_nonexpansive el
| Texp_variant(_, arg) -> is_nonexpansive_opt arg
| Texp_record(lbl_exp_list, opt_init_exp) ->
List.for_all
- (fun (_, _, lbl, exp) -> lbl.lbl_mut = Immutable && is_nonexpansive exp)
+ (fun (_, lbl, exp) -> lbl.lbl_mut = Immutable && is_nonexpansive exp)
lbl_exp_list
&& is_nonexpansive_opt opt_init_exp
- | Texp_field(exp, _, lbl, _) -> is_nonexpansive exp
+ | Texp_field(exp, lbl, _) -> is_nonexpansive exp
| Texp_array [] -> true
| Texp_ifthenelse(cond, ifso, ifnot) ->
is_nonexpansive ifso && is_nonexpansive_opt ifnot
@@ -1437,7 +1436,7 @@ let contains_gadt env p =
match p.ppat_desc with
Ppat_construct (lid, _, _) ->
begin try
- let (_path, cstr) = Env.lookup_constructor lid.txt env in
+ let cstr = Env.lookup_constructor lid.txt env in
if cstr.cstr_generalized then raise Exit
with Not_found -> ()
end; iter_ppat loop p
@@ -1762,7 +1761,7 @@ and type_expect ?in_function env sexp ty_expected =
lid_sexp_list in
let rec check_duplicates seen_pos lid_sexp lbl_exp =
match (lid_sexp, lbl_exp) with
- ((lid, _) :: rem1, (_, _, lbl, _) :: rem2) ->
+ ((lid, _) :: rem1, (_, lbl, _) :: rem2) ->
if List.mem lbl.lbl_pos seen_pos
then raise(Error(loc, Label_multiply_defined lid.txt))
else check_duplicates (lbl.lbl_pos :: seen_pos) rem1 rem2
@@ -1771,12 +1770,12 @@ and type_expect ?in_function env sexp ty_expected =
let opt_exp =
match opt_sexp, lbl_exp_list with
None, _ -> None
- | Some sexp, (_, _, lbl, _) :: _ ->
+ | Some sexp, (_, lbl, _) :: _ ->
if !Clflags.principal then begin_def ();
let ty_exp = newvar () in
let unify_kept lbl =
if List.for_all
- (fun (_, _, lbl',_) -> lbl'.lbl_pos <> lbl.lbl_pos)
+ (fun (_, lbl',_) -> lbl'.lbl_pos <> lbl.lbl_pos)
lbl_exp_list
then begin
let _, ty_arg1, ty_res1 = instance_label false lbl
@@ -1795,10 +1794,10 @@ and type_expect ?in_function env sexp ty_expected =
in
let num_fields =
match lbl_exp_list with [] -> assert false
- | (_,_, lbl,_)::_ -> Array.length lbl.lbl_all in
+ | (_, lbl,_)::_ -> Array.length lbl.lbl_all in
if opt_sexp = None && List.length lid_sexp_list <> num_fields then begin
let present_indices =
- List.map (fun (_,_, lbl, _) -> lbl.lbl_pos) lbl_exp_list in
+ List.map (fun (_, lbl, _) -> lbl.lbl_pos) lbl_exp_list in
let label_names = extract_label_names sexp env ty_expected in
let rec missing_labels n = function
[] -> []
@@ -1818,24 +1817,24 @@ and type_expect ?in_function env sexp ty_expected =
exp_env = env }
| Pexp_field(sarg, lid) ->
let arg = type_exp env sarg in
- let (label_path,label) = Typetexp.find_label env loc lid.txt in
+ let label = Typetexp.find_label env loc lid.txt in
let (_, ty_arg, ty_res) = instance_label false label in
unify_exp env arg ty_res;
rue {
- exp_desc = Texp_field(arg, label_path, lid, label);
+ exp_desc = Texp_field(arg, lid, label);
exp_loc = loc; exp_extra = [];
exp_type = ty_arg;
exp_env = env }
| Pexp_setfield(srecord, lid, snewval) ->
let record = type_exp env srecord in
- let (label_path, label) = Typetexp.find_label env loc lid.txt in
- let (label_path, label_loc, label, newval) =
+ let label = Typetexp.find_label env loc lid.txt in
+ let (label_loc, label, newval) =
type_label_exp false env loc record.exp_type
- (label_path, lid, label, snewval) in
+ (lid, label, snewval) in
if label.lbl_mut = Immutable then
raise(Error(loc, Label_not_mutable lid.txt));
rue {
- exp_desc = Texp_setfield(record, label_path, label_loc, label, newval);
+ exp_desc = Texp_setfield(record, label_loc, label, newval);
exp_loc = loc; exp_extra = [];
exp_type = instance_def Predef.type_unit;
exp_env = env }
@@ -2348,7 +2347,7 @@ and type_expect ?in_function env sexp ty_expected =
}
and type_label_exp create env loc ty_expected
- (label_path, lid, label, sarg) =
+ (lid, label, sarg) =
(* Here also ty_expected may be at generic_level *)
begin_def ();
let separate = !Clflags.principal || Env.has_local_constraints env in
@@ -2397,7 +2396,7 @@ and type_label_exp create env loc ty_expected
with Error (_, Less_general _) as e -> raise e
| _ -> raise exn (* In case of failure return the first error *)
in
- (label_path, lid, label, {arg with exp_type = instance env arg.exp_type})
+ (lid, label, {arg with exp_type = instance env arg.exp_type})
and type_argument env sarg ty_expected' ty_expected =
(* ty_expected' may be generic *)
@@ -2657,7 +2656,7 @@ 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 (path,constr) = Typetexp.find_constructor env loc lid.txt in
+ let constr = Typetexp.find_constructor env loc lid.txt in
Env.mark_constructor Env.Positive env (Longident.last lid.txt) constr;
let sargs =
match sarg with
@@ -2673,7 +2672,7 @@ and type_construct env loc lid sarg explicit_arity ty_expected =
let (ty_args, ty_res) = instance_constructor constr in
let texp =
re {
- exp_desc = Texp_construct(path, lid, constr, [],explicit_arity);
+ exp_desc = Texp_construct(lid, constr, [],explicit_arity);
exp_loc = loc; exp_extra = [];
exp_type = ty_res;
exp_env = env } in
@@ -2698,7 +2697,7 @@ and type_construct env loc lid sarg explicit_arity ty_expected =
if constr.cstr_private = Private then
raise(Error(loc, Private_type ty_res));
{ texp with
- exp_desc = Texp_construct(path, lid, constr, args, explicit_arity) }
+ exp_desc = Texp_construct(lid, constr, args, explicit_arity) }
(* Typing of statements (expressions whose values are discarded) *)
View
2 typing/typedecl.ml
@@ -891,7 +891,7 @@ let transl_exception env loc excdecl =
(* Translate an exception rebinding *)
let transl_exn_rebind env loc lid =
- let (path, cdescr) =
+ let cdescr =
try
Env.lookup_constructor lid env
with Not_found ->
View
23 typing/typedtree.ml
@@ -40,10 +40,10 @@ and pattern_desc =
| Tpat_constant of constant
| Tpat_tuple of pattern list
| Tpat_construct of
- Path.t * Longident.t loc * constructor_description * pattern list * bool
+ Longident.t loc * constructor_description * pattern list * bool
| Tpat_variant of label * pattern option * row_desc ref
| Tpat_record of
- (Path.t * Longident.t loc * label_description * pattern) list *
+ (Longident.t loc * label_description * pattern) list *
closed_flag
| Tpat_array of pattern list
| Tpat_or of pattern * pattern * row_desc option
@@ -72,15 +72,15 @@ and expression_desc =
| Texp_try of expression * (pattern * expression) list
| Texp_tuple of expression list
| Texp_construct of
- Path.t * Longident.t loc * constructor_description * expression list *
+ Longident.t loc * constructor_description * expression list *
bool
| Texp_variant of label * expression option
| Texp_record of
- (Path.t * Longident.t loc * label_description * expression) list *
+ (Longident.t loc * label_description * expression) list *
expression option
- | Texp_field of expression * Path.t * Longident.t loc * label_description
+ | Texp_field of expression * Longident.t loc * label_description
| Texp_setfield of
- expression * Path.t * Longident.t loc * label_description * expression
+ expression * Longident.t loc * label_description * expression
| Texp_array of expression list
| Texp_ifthenelse of expression * expression * expression option
| Texp_sequence of expression * expression
@@ -381,10 +381,10 @@ and 'a class_infos =
let iter_pattern_desc f = function
| Tpat_alias(p, _, _) -> f p
| Tpat_tuple patl -> List.iter f patl
- | Tpat_construct(_, _, cstr, patl, _) -> List.iter f patl
+ | Tpat_construct(_, cstr, patl, _) -> List.iter f patl
| Tpat_variant(_, pat, _) -> may f pat
| Tpat_record (lbl_pat_list, _) ->
- List.iter (fun (_, _, lbl, pat) -> f pat) lbl_pat_list
+ List.iter (fun (_, lbl, pat) -> f pat) lbl_pat_list
| Tpat_array patl -> List.iter f patl
| Tpat_or(p1, p2, _) -> f p1; f p2
| Tpat_lazy p -> f p
@@ -399,10 +399,9 @@ let map_pattern_desc f d =
| Tpat_tuple pats ->
Tpat_tuple (List.map f pats)
| Tpat_record (lpats, closed) ->
- Tpat_record (List.map (fun ( lid, lid_loc, l,p) -> lid, lid_loc, l, f p)
- lpats, closed)
- | Tpat_construct (lid, lid_loc, c,pats, arity) ->
- Tpat_construct (lid, lid_loc, c, List.map f pats, arity)
+ Tpat_record (List.map (fun (lid, l,p) -> lid, l, f p) lpats, closed)
+ | Tpat_construct (lid, c,pats, arity) ->
+ Tpat_construct (lid, c, List.map f pats, arity)
| Tpat_array pats ->
Tpat_array (List.map f pats)
| Tpat_lazy p1 -> Tpat_lazy (f p1)
View
12 typing/typedtree.mli
@@ -39,10 +39,10 @@ and pattern_desc =
| Tpat_constant of constant
| Tpat_tuple of pattern list
| Tpat_construct of
- Path.t * Longident.t loc * constructor_description * pattern list * bool
+ Longident.t loc * constructor_description * pattern list * bool
| Tpat_variant of label * pattern option * row_desc ref
| Tpat_record of
- (Path.t * Longident.t loc * label_description * pattern) list *
+ (Longident.t loc * label_description * pattern) list *
closed_flag
| Tpat_array of pattern list
| Tpat_or of pattern * pattern * row_desc option
@@ -71,15 +71,15 @@ and expression_desc =
| Texp_try of expression * (pattern * expression) list
| Texp_tuple of expression list
| Texp_construct of
- Path.t * Longident.t loc * constructor_description * expression list *
+ Longident.t loc * constructor_description * expression list *
bool
| Texp_variant of label * expression option
| Texp_record of
- (Path.t * Longident.t loc * label_description * expression) list *
+ (Longident.t loc * label_description * expression) list *
expression option
- | Texp_field of expression * Path.t * Longident.t loc * label_description
+ | Texp_field of expression * Longident.t loc * label_description
| Texp_setfield of
- expression * Path.t * Longident.t loc * label_description * expression
+ expression * Longident.t loc * label_description * expression
| Texp_array of expression list
| Texp_ifthenelse of expression * expression * expression option
| Texp_sequence of expression * expression
View
14 typing/typedtreeIter.ml
@@ -206,15 +206,15 @@ module MakeIterator(Iter : IteratorArgument) : sig
| Tpat_constant cst -> ()
| Tpat_tuple list ->
List.iter iter_pattern list
- | Tpat_construct (path, _, _, args, _) ->
+ | Tpat_construct (_, _, args, _) ->
List.iter iter_pattern args
| Tpat_variant (label, pato, _) ->
begin match pato with
None -> ()
| Some pat -> iter_pattern pat
end
| Tpat_record (list, closed) ->
- List.iter (fun (path, _, _, pat) -> iter_pattern pat) list
+ List.iter (fun (_, _, pat) -> iter_pattern pat) list
| Tpat_array list -> List.iter iter_pattern list
| Tpat_or (p1, p2, _) -> iter_pattern p1; iter_pattern p2
| Tpat_lazy p -> iter_pattern p
@@ -257,24 +257,22 @@ module MakeIterator(Iter : IteratorArgument) : sig
iter_bindings Nonrecursive list
| Texp_tuple list ->
List.iter iter_expression list
- | Texp_construct (path, _, _, args, _) ->
+ | Texp_construct (_, _, args, _) ->
List.iter iter_expression args
| Texp_variant (label, expo) ->
begin match expo with
None -> ()
| Some exp -> iter_expression exp
end
| Texp_record (list, expo) ->
- List.iter (fun (path, _, _, exp) ->
- iter_expression exp
- ) list;
+ List.iter (fun (_, _, exp) -> iter_expression exp) list;
begin match expo with
None -> ()
| Some exp -> iter_expression exp
end
- | Texp_field (exp, path, _, label) ->
+ | Texp_field (exp, _, label) ->
iter_expression exp
- | Texp_setfield (exp1, path, _ , label, exp2) ->
+ | Texp_setfield (exp1, _, label, exp2) ->
iter_expression exp1;
iter_expression exp2
| Texp_array list ->
View
24 typing/typedtreeMap.ml
@@ -194,8 +194,8 @@ module MakeMap(Map : MapArgument) = struct
let pat1 = map_pattern pat1 in
Tpat_alias (pat1, p, text)
| Tpat_tuple list -> Tpat_tuple (List.map map_pattern list)
- | Tpat_construct (path, lid, cstr_decl, args, arity) ->
- Tpat_construct (path, lid, cstr_decl,
+ | Tpat_construct (lid, cstr_decl, args, arity) ->
+ Tpat_construct (lid, cstr_decl,
List.map map_pattern args, arity)
| Tpat_variant (label, pato, rowo) ->
let pato = match pato with
@@ -204,8 +204,8 @@ module MakeMap(Map : MapArgument) = struct
in
Tpat_variant (label, pato, rowo)
| Tpat_record (list, closed) ->
- Tpat_record (List.map (fun (path, lid, lab_desc, pat) ->
- (path, lid, lab_desc, map_pattern pat) ) list, closed)
+ Tpat_record (List.map (fun (lid, lab_desc, pat) ->
+ (lid, lab_desc, map_pattern pat) ) list, closed)
| Tpat_array list -> Tpat_array (List.map map_pattern list)
| Tpat_or (p1, p2, rowo) ->
Tpat_or (map_pattern p1, map_pattern p2, rowo)
@@ -258,8 +258,8 @@ module MakeMap(Map : MapArgument) = struct
)
| Texp_tuple list ->
Texp_tuple (List.map map_expression list)
- | Texp_construct (path, lid, cstr_desc, args, arity) ->
- Texp_construct (path, lid, cstr_desc,
+ | Texp_construct (lid, cstr_desc, args, arity) ->
+ Texp_construct (lid, cstr_desc,
List.map map_expression args, arity )
| Texp_variant (label, expo) ->
let expo =match expo with
@@ -269,20 +269,20 @@ module MakeMap(Map : MapArgument) = struct
Texp_variant (label, expo)
| Texp_record (list, expo) ->
let list =
- List.map (fun (path, lid, lab_desc, exp) ->
- (path, lid, lab_desc, map_expression exp)
+ List.map (fun (lid, lab_desc, exp) ->
+ (lid, lab_desc, map_expression exp)
) list in
let expo = match expo with
None -> expo
| Some exp -> Some (map_expression exp)
in
Texp_record (list, expo)
- | Texp_field (exp, path, lid, label) ->
- Texp_field (map_expression exp, path, lid, label)
- | Texp_setfield (exp1, path, lid, label, exp2) ->
+ | Texp_field (exp, lid, label) ->
+ Texp_field (map_expression exp, lid, label)
+ | Texp_setfield (exp1, lid, label, exp2) ->
Texp_setfield (
map_expression exp1,
- path, lid,
+ lid,
label,
map_expression exp2)
| Texp_array list ->
View
3 typing/types.ml
@@ -104,7 +104,8 @@ and value_kind =
(* Constructor descriptions *)
type constructor_description =
- { cstr_res: type_expr; (* Type of the result *)
+ { cstr_name: string; (* Constructor name *)
+ cstr_res: type_expr; (* Type of the result *)
cstr_existentials: type_expr list; (* list of existentials *)
cstr_args: type_expr list; (* Type of the arguments *)
cstr_arity: int; (* Number of arguments *)
View
3 typing/types.mli
@@ -102,7 +102,8 @@ and value_kind =
(* Constructor descriptions *)
type constructor_description =
- { cstr_res: type_expr; (* Type of the result *)
+ { cstr_name: string; (* Constructor name *)
+ cstr_res: type_expr; (* Type of the result *)
cstr_existentials: type_expr list; (* list of existentials *)
cstr_args: type_expr list; (* Type of the arguments *)
cstr_arity: int; (* Number of arguments *)
View
12 typing/typetexp.ml
@@ -680,7 +680,7 @@ let spellcheck ppf fold env lid =
| 5 | 6 -> 2
| _ -> 3
in
- let compare target head _path _descr acc =
+ let compare target head acc =
let (best_choice, best_dist) = acc in
match Misc.edit_distance target head cutoff with
| None -> (best_choice, best_dist)
@@ -713,6 +713,12 @@ let spellcheck ppf fold env lid =
| Longident.Ldot (r, s) ->
handle (fold (compare s) (Some r) env init)
+let spellcheck_simple ppf fold extr =
+ spellcheck ppf (fun f -> fold (fun decl x -> f (extr decl) x))
+
+let spellcheck ppf fold =
+ spellcheck ppf (fun f -> fold (fun s _ _ x -> f s x))
+
let report_error ppf = function
| Unbound_type_variable name ->
fprintf ppf "Unbound type parameter %s@." name
@@ -790,10 +796,10 @@ let report_error ppf = function
spellcheck ppf Env.fold_modules env lid;
| Unbound_constructor (env, lid) ->
fprintf ppf "Unbound constructor %a" longident lid;
- spellcheck ppf Env.fold_constructors env lid;
+ spellcheck_simple ppf Env.fold_constructors (fun d -> d.cstr_name) env lid;
| Unbound_label (env, lid) ->
fprintf ppf "Unbound record field label %a" longident lid;
- spellcheck ppf Env.fold_labels env lid;
+ spellcheck_simple ppf Env.fold_labels (fun d -> d.lbl_name) env lid;
| Unbound_class (env, lid) ->
fprintf ppf "Unbound class %a" longident lid;
spellcheck ppf Env.fold_classs env lid;
View
4 typing/typetexp.mli
@@ -79,9 +79,9 @@ val create_package_mty:
val find_type:
Env.t -> Location.t -> Longident.t -> Path.t * Types.type_declaration
val find_constructor:
- Env