Represent label and constructor declarations as records in the typedtree. Also keep return type for GADT constructors.
git-svn-id: http://caml.inria.fr/svn/ocaml/branches/extension_points@13441 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02master
parent
5c98dd91fe
commit
dd61fb5e55
|
@ -446,6 +446,7 @@ and class_type_field i ppf x =
|
|||
|
||||
and class_description i ppf x =
|
||||
line i ppf "class_description %a\n" fmt_location x.pci_loc;
|
||||
attributes i ppf x.pci_attributes;
|
||||
let i = i+1 in
|
||||
line i ppf "pci_virt = %a\n" fmt_virtual_flag x.pci_virt;
|
||||
line i ppf "pci_params =\n";
|
||||
|
|
|
@ -54,9 +54,9 @@ let type_declaration sub decl =
|
|||
begin match decl.typ_kind with
|
||||
| Ttype_abstract -> ()
|
||||
| Ttype_variant list ->
|
||||
List.iter (fun (_s, _, cts, _loc) -> List.iter (sub # core_type) cts) list
|
||||
List.iter (fun cd -> List.iter (sub # core_type) cd.cd_args; opt (sub # core_type) cd.cd_res) list
|
||||
| Ttype_record list ->
|
||||
List.iter (fun (_s, _, _mut, ct, _loc) -> sub # core_type ct) list
|
||||
List.iter (fun ld -> sub # core_type ld.ld_type) list
|
||||
end;
|
||||
opt (sub # core_type) decl.typ_manifest
|
||||
|
||||
|
|
|
@ -31,6 +31,8 @@ Some notes:
|
|||
*)
|
||||
|
||||
|
||||
let option f = function None -> None | Some e -> Some (f e)
|
||||
|
||||
let rec lident_of_path path =
|
||||
match path with
|
||||
Path.Pident id -> Longident.Lident (Ident.name id)
|
||||
|
@ -124,21 +126,19 @@ and untype_type_declaration name decl =
|
|||
ptype_kind = (match decl.typ_kind with
|
||||
Ttype_abstract -> Ptype_abstract
|
||||
| Ttype_variant list ->
|
||||
Ptype_variant (List.map (fun (_s, name, cts, loc) ->
|
||||
{pcd_name = name; pcd_args = List.map untype_core_type cts; pcd_res = None; pcd_loc = loc; pcd_attributes = []}) list)
|
||||
Ptype_variant (List.map (fun cd ->
|
||||
{pcd_name = cd.cd_name; pcd_args = List.map untype_core_type cd.cd_args; pcd_res = option untype_core_type cd.cd_res; pcd_loc = cd.cd_loc; pcd_attributes = cd.cd_attributes}) list)
|
||||
| Ttype_record list ->
|
||||
Ptype_record (List.map (fun (_s, name, mut, ct, loc) ->
|
||||
{pld_name=name;
|
||||
pld_mutable=mut;
|
||||
pld_type=untype_core_type ct;
|
||||
pld_loc=loc;
|
||||
pld_attributes=[]}
|
||||
Ptype_record (List.map (fun ld ->
|
||||
{pld_name=ld.ld_name;
|
||||
pld_mutable=ld.ld_mutable;
|
||||
pld_type=untype_core_type ld.ld_type;
|
||||
pld_loc=ld.ld_loc;
|
||||
pld_attributes=ld.ld_attributes}
|
||||
) list)
|
||||
);
|
||||
ptype_private = decl.typ_private;
|
||||
ptype_manifest = (match decl.typ_manifest with
|
||||
None -> None
|
||||
| Some ct -> Some (untype_core_type ct));
|
||||
ptype_manifest = option untype_core_type decl.typ_manifest;
|
||||
ptype_variance = decl.typ_variance;
|
||||
ptype_attributes = decl.typ_attributes;
|
||||
ptype_loc = decl.typ_loc;
|
||||
|
@ -185,9 +185,7 @@ and untype_pattern pat =
|
|||
)
|
||||
), explicit_arity)
|
||||
| Tpat_variant (label, pato, _) ->
|
||||
Ppat_variant (label, match pato with
|
||||
None -> None
|
||||
| Some pat -> Some (untype_pattern pat))
|
||||
Ppat_variant (label, option untype_pattern pato)
|
||||
| Tpat_record (list, closed) ->
|
||||
Ppat_record (List.map (fun (lid, _, pat) ->
|
||||
lid, untype_pattern pat) list, closed)
|
||||
|
@ -197,8 +195,6 @@ and untype_pattern pat =
|
|||
in
|
||||
Pat.mk ~loc:pat.pat_loc ~attrs:pat.pat_attributes desc (* todo: fix attributes on extras *)
|
||||
|
||||
and option f x = match x with None -> None | Some e -> Some (f e)
|
||||
|
||||
and untype_extra (extra, loc, attrs) sexp =
|
||||
let desc =
|
||||
match extra with
|
||||
|
@ -253,16 +249,12 @@ and untype_expression exp =
|
|||
(Exp.tuple ~loc:exp.exp_loc (List.map untype_expression args))
|
||||
), explicit_arity)
|
||||
| Texp_variant (label, expo) ->
|
||||
Pexp_variant (label, match expo with
|
||||
None -> None
|
||||
| Some exp -> Some (untype_expression exp))
|
||||
Pexp_variant (label, option untype_expression expo)
|
||||
| Texp_record (list, expo) ->
|
||||
Pexp_record (List.map (fun (lid, _, exp) ->
|
||||
lid, untype_expression exp
|
||||
) list,
|
||||
match expo with
|
||||
None -> None
|
||||
| Some exp -> Some (untype_expression exp))
|
||||
option untype_expression expo)
|
||||
| Texp_field (exp, lid, _label) ->
|
||||
Pexp_field (untype_expression exp, lid)
|
||||
| Texp_setfield (exp1, lid, _label, exp2) ->
|
||||
|
@ -273,9 +265,7 @@ and untype_expression exp =
|
|||
| Texp_ifthenelse (exp1, exp2, expo) ->
|
||||
Pexp_ifthenelse (untype_expression exp1,
|
||||
untype_expression exp2,
|
||||
match expo with
|
||||
None -> None
|
||||
| Some exp -> Some (untype_expression exp))
|
||||
option untype_expression expo)
|
||||
| Texp_sequence (exp1, exp2) ->
|
||||
Pexp_sequence (untype_expression exp1, untype_expression exp2)
|
||||
| Texp_while (exp1, exp2) ->
|
||||
|
|
|
@ -141,6 +141,7 @@ let attributes i ppf l =
|
|||
|
||||
let rec core_type i ppf x =
|
||||
line i ppf "core_type %a\n" fmt_location x.ctyp_loc;
|
||||
attributes i ppf x.ctyp_attributes;
|
||||
let i = i+1 in
|
||||
match x.ctyp_desc with
|
||||
| Ttyp_any -> line i ppf "Ptyp_any\n";
|
||||
|
@ -374,6 +375,7 @@ and expression i ppf x =
|
|||
|
||||
and value_description i ppf x =
|
||||
line i ppf "value_description\n";
|
||||
attributes i ppf x.val_attributes;
|
||||
core_type (i+1) ppf x.val_desc;
|
||||
list (i+1) string ppf x.val_prim;
|
||||
|
||||
|
@ -386,6 +388,7 @@ and string_option_underscore i ppf =
|
|||
|
||||
and type_declaration i ppf x =
|
||||
line i ppf "type_declaration %a\n" fmt_location x.typ_loc;
|
||||
attributes i ppf x.typ_attributes;
|
||||
let i = i+1 in
|
||||
line i ppf "ptype_params =\n";
|
||||
list (i+1) string_option_underscore ppf x.typ_params;
|
||||
|
@ -403,12 +406,15 @@ and type_kind i ppf x =
|
|||
line i ppf "Ptype_abstract\n"
|
||||
| Ttype_variant l ->
|
||||
line i ppf "Ptype_variant\n";
|
||||
list (i+1) string_x_core_type_list_x_location ppf l;
|
||||
list (i+1) constructor_decl ppf l;
|
||||
| Ttype_record l ->
|
||||
line i ppf "Ptype_record\n";
|
||||
list (i+1) string_x_mutable_flag_x_core_type_x_location ppf l;
|
||||
list (i+1) label_decl ppf l;
|
||||
|
||||
and exception_declaration i ppf x = list i core_type ppf x
|
||||
and exception_declaration i ppf x =
|
||||
(* string_loc i ppf x.ped_name; *)
|
||||
attributes i ppf x.exn_attributes;
|
||||
list i core_type ppf x.exn_params
|
||||
|
||||
and class_type i ppf x =
|
||||
line i ppf "class_type %a\n" fmt_location x.cltyp_loc;
|
||||
|
@ -456,6 +462,7 @@ and class_type_field i ppf x =
|
|||
|
||||
and class_description i ppf x =
|
||||
line i ppf "class_description %a\n" fmt_location x.ci_loc;
|
||||
attributes i ppf x.ci_attributes;
|
||||
let i = i+1 in
|
||||
line i ppf "pci_virt = %a\n" fmt_virtual_flag x.ci_virt;
|
||||
line i ppf "pci_params =\n";
|
||||
|
@ -555,6 +562,7 @@ and class_declaration i ppf x =
|
|||
|
||||
and module_type i ppf x =
|
||||
line i ppf "module_type %a\n" fmt_location x.mty_loc;
|
||||
attributes i ppf x.mty_attributes;
|
||||
let i = i+1 in
|
||||
match x.mty_desc with
|
||||
| Tmty_ident (li,_) -> line i ppf "Pmty_ident %a\n" fmt_path li;
|
||||
|
@ -587,7 +595,7 @@ and signature_item i ppf x =
|
|||
list i string_x_type_declaration ppf l;
|
||||
| Tsig_exception (s, _, ed) ->
|
||||
line i ppf "Psig_exception \"%a\"\n" fmt_ident s;
|
||||
exception_declaration i ppf ed.exn_params;
|
||||
exception_declaration i ppf ed;
|
||||
| Tsig_module (s, _, mt) ->
|
||||
line i ppf "Psig_module \"%a\"\n" fmt_ident s;
|
||||
module_type i ppf mt;
|
||||
|
@ -602,8 +610,8 @@ and signature_item i ppf x =
|
|||
attributes i ppf attrs
|
||||
| Tsig_include (mt, _, attrs) ->
|
||||
line i ppf "Psig_include\n";
|
||||
module_type i ppf mt;
|
||||
attributes i ppf attrs
|
||||
attributes i ppf attrs;
|
||||
module_type i ppf mt
|
||||
| Tsig_class (l) ->
|
||||
line i ppf "Psig_class\n";
|
||||
list i class_description ppf l;
|
||||
|
@ -680,7 +688,7 @@ and structure_item i ppf x =
|
|||
list i string_x_type_declaration ppf l;
|
||||
| Tstr_exception (s, _, ed) ->
|
||||
line i ppf "Pstr_exception \"%a\"\n" fmt_ident s;
|
||||
exception_declaration i ppf ed.exn_params;
|
||||
exception_declaration i ppf ed;
|
||||
| Tstr_exn_rebind (s, _, li, _, attrs) ->
|
||||
line i ppf "Pstr_exn_rebind \"%a\" %a\n" fmt_ident s fmt_path li;
|
||||
attributes i ppf attrs
|
||||
|
@ -704,8 +712,8 @@ and structure_item i ppf x =
|
|||
list i class_type_declaration ppf (List.map (fun (_, _, cl) -> cl) l);
|
||||
| Tstr_include (me, _, attrs) ->
|
||||
line i ppf "Pstr_include";
|
||||
attributes i ppf attrs;
|
||||
module_expr i ppf me;
|
||||
attributes i ppf attrs
|
||||
| Tstr_attribute (s, arg) ->
|
||||
line i ppf "Pstr_attribute \"%s\"\n" s;
|
||||
Printast.expression i ppf arg
|
||||
|
@ -732,14 +740,19 @@ and core_type_x_core_type_x_location i ppf (ct1, ct2, l) =
|
|||
core_type (i+1) ppf ct1;
|
||||
core_type (i+1) ppf ct2;
|
||||
|
||||
and string_x_core_type_list_x_location i ppf (s, _, l, r_opt) =
|
||||
line i ppf "\"%a\"\n" fmt_ident s;
|
||||
list (i+1) core_type ppf l;
|
||||
(* option (i+1) core_type ppf r_opt; *)
|
||||
and constructor_decl i ppf {cd_id; cd_name = _; cd_args; cd_res; cd_loc; cd_attributes} =
|
||||
line i ppf "%a\n" fmt_location cd_loc;
|
||||
attributes i ppf cd_attributes;
|
||||
line (i+1) ppf "%a\n" fmt_ident cd_id;
|
||||
list (i+1) core_type ppf cd_args;
|
||||
option (i+1) core_type ppf cd_res
|
||||
|
||||
and string_x_mutable_flag_x_core_type_x_location i ppf (s, _, mf, ct, loc) =
|
||||
line i ppf "\"%a\" %a %a\n" fmt_ident s fmt_mutable_flag mf fmt_location loc;
|
||||
core_type (i+1) ppf ct;
|
||||
and label_decl i ppf {ld_id; ld_name = _; ld_mutable; ld_type; ld_loc; ld_attributes} =
|
||||
line i ppf "%a\n" fmt_location ld_loc;
|
||||
attributes i ppf ld_attributes;
|
||||
line (i+1) ppf "%a\n" fmt_mutable_flag ld_mutable;
|
||||
line (i+1) ppf "%a" fmt_ident ld_id;
|
||||
core_type (i+1) ppf ld_type
|
||||
|
||||
and string_list_x_location i ppf (l, loc) =
|
||||
line i ppf "<params> %a\n" fmt_location loc;
|
||||
|
|
|
@ -159,19 +159,19 @@ let transl_declaration env sdecl id =
|
|||
(List.filter (fun cd -> cd.pcd_args <> []) cstrs)
|
||||
> (Config.max_tag + 1) then
|
||||
raise(Error(sdecl.ptype_loc, Too_many_constructors));
|
||||
let make_cstr {pcd_name = lid; pcd_args = args; pcd_res = ret_type; pcd_loc = loc} =
|
||||
let make_cstr {pcd_name = lid; pcd_args = args; pcd_res = ret_type; pcd_loc = loc; pcd_attributes = attrs} =
|
||||
let name = Ident.create lid.txt in
|
||||
match ret_type with
|
||||
| None ->
|
||||
(name, lid, List.map (transl_simple_type env true) args, None, loc)
|
||||
(name, lid, List.map (transl_simple_type env true) args, None, None, loc, attrs)
|
||||
| Some sty ->
|
||||
(* if it's a generalized constructor we must first narrow and
|
||||
then widen so as to not introduce any new constraints *)
|
||||
let z = narrow () in
|
||||
reset_type_variables ();
|
||||
let args = List.map (transl_simple_type env false) args in
|
||||
let cty = transl_simple_type env false sty in
|
||||
let ret_type =
|
||||
let cty = transl_simple_type env false sty in
|
||||
let ty = cty.ctyp_type in
|
||||
let p = Path.Pident id in
|
||||
match (Ctype.repr ty).desc with
|
||||
|
@ -181,13 +181,14 @@ let transl_declaration env sdecl id =
|
|||
(ty, Ctype.newconstr p params)))
|
||||
in
|
||||
widen z;
|
||||
(name, lid, args, Some ret_type, loc)
|
||||
(name, lid, args, Some cty, Some ret_type, loc, attrs)
|
||||
in
|
||||
let cstrs = List.map make_cstr cstrs in
|
||||
Ttype_variant (List.map (fun (name, lid, ctys, _, loc) ->
|
||||
name, lid, ctys, loc
|
||||
Ttype_variant (List.map (fun (name, lid, ctys, res, _, loc, attrs) ->
|
||||
{cd_id = name; cd_name = lid; cd_args = ctys; cd_res = res;
|
||||
cd_loc = loc; cd_attributes = attrs}
|
||||
) cstrs),
|
||||
Type_variant (List.map (fun (name, name_loc, ctys, option, loc) ->
|
||||
Type_variant (List.map (fun (name, name_loc, ctys, _, option, loc, _attrs) ->
|
||||
name, List.map (fun cty -> cty.ctyp_type) ctys, option) cstrs)
|
||||
|
||||
| Ptype_record lbls ->
|
||||
|
@ -198,15 +199,16 @@ let transl_declaration env sdecl id =
|
|||
raise(Error(sdecl.ptype_loc, Duplicate_label name));
|
||||
all_labels := StringSet.add name !all_labels)
|
||||
lbls;
|
||||
let lbls = List.map (fun {pld_name=name;pld_mutable=mut;pld_type=arg;pld_loc=loc} ->
|
||||
let lbls = List.map (fun {pld_name=name;pld_mutable=mut;pld_type=arg;pld_loc=loc;pld_attributes=attrs} ->
|
||||
let cty = transl_simple_type env true arg in
|
||||
(Ident.create name.txt, name, mut, cty, loc)
|
||||
) lbls in
|
||||
{ld_id = Ident.create name.txt; ld_name = name; ld_mutable = mut; ld_type = cty;
|
||||
ld_loc = loc; ld_attributes = attrs}
|
||||
) lbls in
|
||||
let lbls' =
|
||||
List.map
|
||||
(fun (name, name_loc, mut, cty, loc) ->
|
||||
let ty = cty.ctyp_type in
|
||||
name, mut, match ty.desc with Tpoly(t,[]) -> t | _ -> ty)
|
||||
(fun ld ->
|
||||
let ty = ld.ld_type.ctyp_type in
|
||||
ld.ld_id, ld.ld_mutable, match ty.desc with Tpoly(t,[]) -> t | _ -> ty)
|
||||
lbls in
|
||||
let rep =
|
||||
if List.for_all (fun (name, mut, arg) -> is_float env arg) lbls'
|
||||
|
|
|
@ -329,9 +329,28 @@ and type_declaration =
|
|||
|
||||
and type_kind =
|
||||
Ttype_abstract
|
||||
| Ttype_variant of (Ident.t * string loc * core_type list * Location.t) list
|
||||
| Ttype_record of
|
||||
(Ident.t * string loc * mutable_flag * core_type * Location.t) list
|
||||
| Ttype_variant of constructor_declaration list
|
||||
| Ttype_record of label_declaration list
|
||||
|
||||
and label_declaration =
|
||||
{
|
||||
ld_id: Ident.t;
|
||||
ld_name: string loc;
|
||||
ld_mutable: mutable_flag;
|
||||
ld_type: core_type;
|
||||
ld_loc: Location.t;
|
||||
ld_attributes: attribute list;
|
||||
}
|
||||
|
||||
and constructor_declaration =
|
||||
{
|
||||
cd_id: Ident.t;
|
||||
cd_name: string loc;
|
||||
cd_args: core_type list;
|
||||
cd_res: core_type option;
|
||||
cd_loc: Location.t;
|
||||
cd_attributes: attribute list;
|
||||
}
|
||||
|
||||
and exception_declaration =
|
||||
{ exn_params : core_type list;
|
||||
|
|
|
@ -328,9 +328,28 @@ and type_declaration =
|
|||
|
||||
and type_kind =
|
||||
Ttype_abstract
|
||||
| Ttype_variant of (Ident.t * string loc * core_type list * Location.t) list
|
||||
| Ttype_record of
|
||||
(Ident.t * string loc * mutable_flag * core_type * Location.t) list
|
||||
| Ttype_variant of constructor_declaration list
|
||||
| Ttype_record of label_declaration list
|
||||
|
||||
and label_declaration =
|
||||
{
|
||||
ld_id: Ident.t;
|
||||
ld_name: string loc;
|
||||
ld_mutable: mutable_flag;
|
||||
ld_type: core_type;
|
||||
ld_loc: Location.t;
|
||||
ld_attributes: attribute list;
|
||||
}
|
||||
|
||||
and constructor_declaration =
|
||||
{
|
||||
cd_id: Ident.t;
|
||||
cd_name: string loc;
|
||||
cd_args: core_type list;
|
||||
cd_res: core_type option;
|
||||
cd_loc: Location.t;
|
||||
cd_attributes: attribute list;
|
||||
}
|
||||
|
||||
and exception_declaration =
|
||||
{ exn_params : core_type list;
|
||||
|
|
|
@ -175,12 +175,15 @@ module MakeIterator(Iter : IteratorArgument) : sig
|
|||
begin match decl.typ_kind with
|
||||
Ttype_abstract -> ()
|
||||
| Ttype_variant list ->
|
||||
List.iter (fun (s, _, cts, loc) ->
|
||||
List.iter iter_core_type cts
|
||||
) list
|
||||
List.iter
|
||||
(fun cd ->
|
||||
List.iter iter_core_type cd.cd_args;
|
||||
option iter_core_type cd.cd_res;
|
||||
) list
|
||||
| Ttype_record list ->
|
||||
List.iter (fun (s, _, mut, ct, loc) ->
|
||||
iter_core_type ct
|
||||
List.iter
|
||||
(fun ld ->
|
||||
iter_core_type ld.ld_type
|
||||
) list
|
||||
end;
|
||||
begin match decl.typ_manifest with
|
||||
|
|
|
@ -160,15 +160,22 @@ module MakeMap(Map : MapArgument) = struct
|
|||
let typ_kind = match decl.typ_kind with
|
||||
Ttype_abstract -> Ttype_abstract
|
||||
| Ttype_variant list ->
|
||||
let list = List.map (fun (s, name, cts, loc) ->
|
||||
(s, name, List.map map_core_type cts, loc)
|
||||
) list in
|
||||
Ttype_variant list
|
||||
let list =
|
||||
List.map
|
||||
(fun cd ->
|
||||
{cd with cd_args = List.map map_core_type cd.cd_args;
|
||||
cd_res = may_map map_core_type cd.cd_res
|
||||
}
|
||||
) list
|
||||
in
|
||||
Ttype_variant list
|
||||
| Ttype_record list ->
|
||||
let list =
|
||||
List.map (fun (s, name, mut, ct, loc) ->
|
||||
(s, name, mut, map_core_type ct, loc)
|
||||
) list in
|
||||
List.map
|
||||
(fun ld ->
|
||||
{ld with ld_type = map_core_type ld.ld_type}
|
||||
) list
|
||||
in
|
||||
Ttype_record list
|
||||
in
|
||||
let typ_manifest =
|
||||
|
|
Loading…
Reference in New Issue