From ad85a8c1df6a8199d840c8c467411a38dc658366 Mon Sep 17 00:00:00 2001 From: Gabriel Scherer Date: Sun, 8 Mar 2015 10:22:35 +0000 Subject: [PATCH] use open recursion in untypeast.ml This allows library user to override the untyping behavior of specific typedtree nodes. git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@15888 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 --- Changes | 2 + typing/untypeast.ml | 844 +++++++++++++++++++++++++------------------ typing/untypeast.mli | 65 +++- 3 files changed, 548 insertions(+), 363 deletions(-) diff --git a/Changes b/Changes index 087e874af..2d6570ae5 100644 --- a/Changes +++ b/Changes @@ -99,6 +99,8 @@ Features wishes: - PR#6691: install .cmt[i] files for stdlib and compiler-libs (David Sheets, request by Gabriel Radanne) - PR#6742: remove duplicate virtual_flag information from Tstr_class +- GPR#137: add untypeast.ml (in open recursion style) to compiler-libs + (Gabriel Radanne) - GPR#142: add a CAMLdrop macro for undoing CAMLparam*/CAMLlocal* OCaml 4.02.2: diff --git a/typing/untypeast.ml b/typing/untypeast.ml index dffe262d8..64fb02407 100644 --- a/typing/untypeast.ml +++ b/typing/untypeast.ml @@ -10,11 +10,64 @@ (* *) (**************************************************************************) +open Longident open Asttypes -open Typedtree open Parsetree open Ast_helper +module T = Typedtree + +type mapper = { + attribute: mapper -> T.attribute -> attribute; + attributes: mapper -> T.attribute list -> attribute list; + case: mapper -> T.case -> case; + cases: mapper -> T.case list -> case list; + class_declaration: mapper -> T.class_declaration -> class_declaration; + class_description: mapper -> T.class_description -> class_description; + class_expr: mapper -> T.class_expr -> class_expr; + class_field: mapper -> T.class_field -> class_field; + class_signature: mapper -> T.class_signature -> class_signature; + class_structure: mapper -> T.class_structure -> class_structure; + class_type: mapper -> T.class_type -> class_type; + class_type_declaration: mapper -> T.class_type_declaration + -> class_type_declaration; + class_type_field: mapper -> T.class_type_field -> class_type_field; + constructor_declaration: mapper -> T.constructor_declaration + -> constructor_declaration; + expr: mapper -> T.expression -> expression; + extension_constructor: mapper -> T.extension_constructor + -> extension_constructor; + include_declaration: mapper -> T.include_declaration -> include_declaration; + include_description: mapper -> T.include_description -> include_description; + label_declaration: mapper -> T.label_declaration -> label_declaration; + location: mapper -> Location.t -> Location.t; + module_binding: mapper -> T.module_binding -> module_binding; + module_declaration: mapper -> T.module_declaration -> module_declaration; + module_expr: mapper -> T.module_expr -> module_expr; + module_type: mapper -> T.module_type -> module_type; + module_type_declaration: + mapper -> T.module_type_declaration -> module_type_declaration; + package_type: mapper -> T.package_type -> package_type; + open_description: mapper -> T.open_description -> open_description; + pat: mapper -> T.pattern -> pattern; + row_field: mapper -> T.row_field -> row_field; + signature: mapper -> T.signature -> signature; + signature_item: mapper -> T.signature_item -> signature_item; + structure: mapper -> T.structure -> structure; + structure_item: mapper -> T.structure_item -> structure_item; + typ: mapper -> T.core_type -> core_type; + type_declaration: mapper -> T.type_declaration -> type_declaration; + type_extension: mapper -> T.type_extension -> type_extension; + type_kind: mapper -> T.type_kind -> type_kind; + value_binding: mapper -> T.value_binding -> value_binding; + value_description: mapper -> T.value_description -> value_description; + with_constraint: + mapper -> (Path.t * Longident.t Location.loc * T.with_constraint) + -> with_constraint; +} + +open T + (* Some notes: @@ -26,168 +79,185 @@ Some notes: * For Pexp_apply, it is unclear whether arguments are reordered, especially when there are optional arguments. - * TODO: check Ttype_variant -> Ptype_variant (stub None) - *) + +(** Utility functions. *) + let string_is_prefix sub str = let sublen = String.length sub in String.length str >= sublen && String.sub str 0 sublen = sub -let option f = function None -> None | Some e -> Some (f e) +let map_opt 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) - | Path.Pdot (p, s, _) -> Longident.Ldot (lident_of_path p, s) - | Path.Papply (p1, p2) -> - Longident.Lapply (lident_of_path p1, lident_of_path p2) +let rec lident_of_path = function + | Path.Pident id -> Longident.Lident (Ident.name id) + | Path.Pdot (p, s, _) -> Longident.Ldot (lident_of_path p, s) + | Path.Papply (p1, p2) -> + Longident.Lapply (lident_of_path p1, lident_of_path p2) -let rec untype_structure str = - List.map untype_structure_item str.str_items +let map_loc sub {loc; txt} = {loc = sub.location sub loc; txt} -and untype_structure_item item = +(** Try a name [$name$0], check if it's free, if not, increment and repeat. *) +let fresh_name s env = + let rec aux i = + let name = s ^ string_of_int i in + try + let _ = Env.lookup_value (Lident name) env in + name + with + | Not_found -> aux (i+1) + in + aux 0 + +(** Mapping functions. *) + +let attribute sub (s, p) = (map_loc sub s, p) +let attributes sub l = List.map (sub.attribute sub) l + +let structure sub str = + List.map (sub.structure_item sub) str.str_items + +let open_description sub od = + let loc = sub.location sub od.open_loc in + let attrs = sub.attributes sub od.open_attributes in + Opn.mk ~loc ~attrs + ~override:od.open_override + (map_loc sub od.open_txt) + +let structure_item sub item = + let loc = sub.location sub item.str_loc in let desc = match item.str_desc with - Tstr_eval (exp, attrs) -> Pstr_eval (untype_expression exp, attrs) + Tstr_eval (exp, attrs) -> Pstr_eval (sub.expr sub exp, attrs) | Tstr_value (rec_flag, list) -> - Pstr_value (rec_flag, List.map untype_binding list) + Pstr_value (rec_flag, List.map (sub.value_binding sub) list) | Tstr_primitive vd -> - Pstr_primitive (untype_value_description vd) + Pstr_primitive (sub.value_description sub vd) | Tstr_type list -> - Pstr_type (List.map untype_type_declaration list) + Pstr_type (List.map (sub.type_declaration sub) list) | Tstr_typext tyext -> - Pstr_typext (untype_type_extension tyext) + Pstr_typext (sub.type_extension sub tyext) | Tstr_exception ext -> - Pstr_exception (untype_extension_constructor ext) + Pstr_exception (sub.extension_constructor sub ext) | Tstr_module mb -> - Pstr_module (untype_module_binding mb) + Pstr_module (sub.module_binding sub mb) | Tstr_recmodule list -> - Pstr_recmodule (List.map untype_module_binding list) + Pstr_recmodule (List.map (sub.module_binding sub) list) | Tstr_modtype mtd -> - Pstr_modtype {pmtd_name=mtd.mtd_name; - pmtd_type=option untype_module_type mtd.mtd_type; - pmtd_loc=mtd.mtd_loc;pmtd_attributes=mtd.mtd_attributes;} + Pstr_modtype (sub.module_type_declaration sub mtd) | Tstr_open od -> - Pstr_open {popen_lid = od.open_txt; popen_override = od.open_override; - popen_attributes = od.open_attributes; - popen_loc = od.open_loc; - } + Pstr_open (sub.open_description sub od) | Tstr_class list -> Pstr_class (List.map - (fun (ci, _) -> untype_class_declaration ci) + (fun (ci, _) -> sub.class_declaration sub ci) list) | Tstr_class_type list -> Pstr_class_type (List.map - (fun (_id, _name, ct) -> untype_class_type_declaration ct) + (fun (_id, _name, ct) -> sub.class_type_declaration sub ct) list) | Tstr_include incl -> - Pstr_include {pincl_mod = untype_module_expr incl.incl_mod; - pincl_attributes = incl.incl_attributes; - pincl_loc = incl.incl_loc; - } + Pstr_include (sub.include_declaration sub incl) | Tstr_attribute x -> Pstr_attribute x in - { pstr_desc = desc; pstr_loc = item.str_loc; } + Str.mk ~loc desc -and untype_value_description v = - { - pval_name = v.val_name; - pval_prim = v.val_prim; - pval_type = untype_core_type v.val_desc; - pval_loc = v.val_loc; - pval_attributes = v.val_attributes; - } +let value_description sub v = + let loc = sub.location sub v.val_loc in + let attrs = sub.attributes sub v.val_attributes in + Val.mk ~loc ~attrs + ~prim:v.val_prim + (map_loc sub v.val_name) + (sub.typ sub v.val_desc) -and untype_module_binding mb = - { - pmb_name = mb.mb_name; - pmb_expr = untype_module_expr mb.mb_expr; - pmb_attributes = mb.mb_attributes; - pmb_loc = mb.mb_loc; - } +let module_binding sub mb = + let loc = sub.location sub mb.mb_loc; in + let attrs = sub.attributes sub mb.mb_attributes in + Mb.mk ~loc ~attrs + (map_loc sub mb.mb_name) + (sub.module_expr sub mb.mb_expr) -and untype_type_declaration decl = - { - ptype_name = decl.typ_name; - ptype_params = List.map untype_type_parameter decl.typ_params; - ptype_cstrs = List.map (fun (ct1, ct2, loc) -> - (untype_core_type ct1, - untype_core_type ct2, loc) - ) decl.typ_cstrs; - ptype_kind = (match decl.typ_kind with - Ttype_abstract -> Ptype_abstract - | Ttype_variant list -> - Ptype_variant (List.map untype_constructor_declaration list) - | Ttype_record list -> - Ptype_record (List.map untype_label_declaration list) - | Ttype_open -> Ptype_open - ); - ptype_private = decl.typ_private; - ptype_manifest = option untype_core_type decl.typ_manifest; - ptype_attributes = decl.typ_attributes; - ptype_loc = decl.typ_loc; - } +let type_parameter sub (ct, v) = (sub.typ sub ct, v) -and untype_type_parameter (ct, v) = (untype_core_type ct, v) +let type_declaration sub decl = + let loc = sub.location sub decl.typ_loc; in + let attrs = sub.attributes sub decl.typ_attributes in + Type.mk ~loc ~attrs + ~params:(List.map (type_parameter sub) decl.typ_params) + ~cstrs:( + List.map + (fun (ct1, ct2, loc) -> + (sub.typ sub ct1, sub.typ sub ct2, sub.location sub loc)) + decl.typ_cstrs) + ~kind:(sub.type_kind sub decl.typ_kind) + ~priv:decl.typ_private + ?manifest:(map_opt (sub.typ sub) decl.typ_manifest) + (map_loc sub decl.typ_name) -and untype_constructor_arguments = function - | Cstr_tuple l -> Pcstr_tuple (List.map untype_core_type l) - | Cstr_record l -> Pcstr_record (List.map untype_label_declaration l) +let type_kind sub tk = match tk with + | Ttype_abstract -> Ptype_abstract + | Ttype_variant list -> + Ptype_variant (List.map (sub.constructor_declaration sub) list) + | Ttype_record list -> + Ptype_record (List.map (sub.label_declaration sub) list) + | Ttype_open -> Ptype_open -and untype_constructor_declaration cd = - { - pcd_name = cd.cd_name; - pcd_args = untype_constructor_arguments cd.cd_args; - pcd_res = option untype_core_type cd.cd_res; - pcd_loc = cd.cd_loc; - pcd_attributes = cd.cd_attributes; - } +let constructor_arguments sub = function + | Cstr_tuple l -> Pcstr_tuple (List.map (sub.typ sub) l) + | Cstr_record l -> Pcstr_record (List.map (sub.label_declaration sub) l) -and untype_label_declaration 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 - } +let constructor_declaration sub cd = + let loc = sub.location sub cd.cd_loc; in + let attrs = sub.attributes sub cd.cd_attributes in + Type.constructor ~loc ~attrs + ~args:(constructor_arguments sub cd.cd_args) + ?res:(map_opt (sub.typ sub) cd.cd_res) + (map_loc sub cd.cd_name) -and untype_type_extension tyext = - { - ptyext_path = tyext.tyext_txt; - ptyext_params = List.map untype_type_parameter tyext.tyext_params; - ptyext_constructors = - List.map untype_extension_constructor tyext.tyext_constructors; - ptyext_private = tyext.tyext_private; - ptyext_attributes = tyext.tyext_attributes; - } +let label_declaration sub ld = + let loc = sub.location sub ld.ld_loc; in + let attrs = sub.attributes sub ld.ld_attributes in + Type.field ~loc ~attrs + ~mut:ld.ld_mutable + (map_loc sub ld.ld_name) + (sub.typ sub ld.ld_type) -and untype_extension_constructor ext = - { - pext_name = ext.ext_name; - pext_kind = (match ext.ext_kind with - Text_decl (args, ret) -> - Pext_decl (untype_constructor_arguments args, - option untype_core_type ret) - | Text_rebind (_p, lid) -> Pext_rebind lid - ); - pext_loc = ext.ext_loc; - pext_attributes = ext.ext_attributes; - } +let type_extension sub tyext = + let attrs = sub.attributes sub tyext.tyext_attributes in + Te.mk ~attrs + ~params:(List.map (type_parameter sub) tyext.tyext_params) + ~priv:tyext.tyext_private + (map_loc sub tyext.tyext_txt) + (List.map (sub.extension_constructor sub) tyext.tyext_constructors) -and untype_pattern pat = +let extension_constructor sub ext = + let loc = sub.location sub ext.ext_loc; in + let attrs = sub.attributes sub ext.ext_attributes in + Te.constructor ~loc ~attrs + (map_loc sub ext.ext_name) + (match ext.ext_kind with + | Text_decl (args, ret) -> + Pext_decl (constructor_arguments sub args, + map_opt (sub.typ sub) ret) + | Text_rebind (_p, lid) -> Pext_rebind (map_loc sub lid) + ) + +let pattern sub pat = + let loc = sub.location sub pat.pat_loc; in + (* todo: fix attributes on extras *) + let attrs = sub.attributes sub pat.pat_attributes in let desc = match pat with { pat_extra=[Tpat_unpack, _, _attrs]; pat_desc = Tpat_var (_,name); _ } -> Ppat_unpack name - | { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } -> Ppat_type lid + | { pat_extra=[Tpat_type (_path, lid), _, _attrs]; _ } -> + Ppat_type (map_loc sub lid) | { pat_extra= (Tpat_constraint ct, _, _attrs) :: rem; _ } -> - Ppat_constraint (untype_pattern { pat with pat_extra=rem }, - untype_core_type ct) + Ppat_constraint (sub.pat sub { pat with pat_extra=rem }, + sub.typ sub ct) | _ -> match pat.pat_desc with Tpat_any -> Ppat_any @@ -200,427 +270,435 @@ and untype_pattern pat = Ppat_var name end | Tpat_alias (pat, _id, name) -> - Ppat_alias (untype_pattern pat, name) + Ppat_alias (sub.pat sub pat, name) | Tpat_constant cst -> Ppat_constant cst | Tpat_tuple list -> - Ppat_tuple (List.map untype_pattern list) + Ppat_tuple (List.map (sub.pat sub) list) | Tpat_construct (lid, _, args) -> - Ppat_construct (lid, + Ppat_construct (map_loc sub lid, (match args with [] -> None - | [arg] -> Some (untype_pattern arg) + | [arg] -> Some (sub.pat sub arg) | args -> Some - (Pat.tuple ~loc:pat.pat_loc - (List.map untype_pattern args) + (Pat.tuple ~loc + (List.map (sub.pat sub) args) ) )) | Tpat_variant (label, pato, _) -> - Ppat_variant (label, option untype_pattern pato) + Ppat_variant (label, map_opt (sub.pat sub) pato) | Tpat_record (list, closed) -> 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) - | Tpat_lazy p -> Ppat_lazy (untype_pattern p) + map_loc sub lid, sub.pat sub pat) list, closed) + | Tpat_array list -> Ppat_array (List.map (sub.pat sub) list) + | Tpat_or (p1, p2, _) -> Ppat_or (sub.pat sub p1, sub.pat sub p2) + | Tpat_lazy p -> Ppat_lazy (sub.pat sub p) in - Pat.mk ~loc:pat.pat_loc ~attrs:pat.pat_attributes desc - (* todo: fix attributes on extras *) + Pat.mk ~loc ~attrs desc -and untype_extra (extra, loc, attrs) sexp = +let exp_extra sub (extra, loc, attrs) sexp = + let loc = sub.location sub loc; in + let attrs = sub.attributes sub attrs in let desc = match extra with Texp_coerce (cty1, cty2) -> Pexp_coerce (sexp, - option untype_core_type cty1, - untype_core_type cty2) + map_opt (sub.typ sub) cty1, + sub.typ sub cty2) | Texp_constraint cty -> - Pexp_constraint (sexp, untype_core_type cty) - | Texp_open (ovf, _path, lid, _) -> Pexp_open (ovf, lid, sexp) - | Texp_poly cto -> Pexp_poly (sexp, option untype_core_type cto) + Pexp_constraint (sexp, sub.typ sub cty) + | Texp_open (ovf, _path, lid, _) -> + Pexp_open (ovf, map_loc sub lid, sexp) + | Texp_poly cto -> Pexp_poly (sexp, map_opt (sub.typ sub) cto) | Texp_newtype s -> Pexp_newtype (s, sexp) in Exp.mk ~loc ~attrs desc -and untype_cases l = List.map untype_case l +let cases sub l = List.map (sub.case sub) l -and untype_case {c_lhs; c_guard; c_rhs} = +let case sub {c_lhs; c_guard; c_rhs} = { - pc_lhs = untype_pattern c_lhs; - pc_guard = option untype_expression c_guard; - pc_rhs = untype_expression c_rhs; + pc_lhs = sub.pat sub c_lhs; + pc_guard = map_opt (sub.expr sub) c_guard; + pc_rhs = sub.expr sub c_rhs; } -and untype_binding {vb_pat; vb_expr; vb_attributes; vb_loc} = - { - pvb_pat = untype_pattern vb_pat; - pvb_expr = untype_expression vb_expr; - pvb_attributes = vb_attributes; - pvb_loc = vb_loc; - } +let value_binding sub vb = + let loc = sub.location sub vb.vb_loc; in + let attrs = sub.attributes sub vb.vb_attributes in + Vb.mk ~loc ~attrs + (sub.pat sub vb.vb_pat) + (sub.expr sub vb.vb_expr) -and untype_expression exp = +let expression sub exp = + let loc = sub.location sub exp.exp_loc; in + let attrs = sub.attributes sub exp.exp_attributes in let desc = match exp.exp_desc with - Texp_ident (_path, lid, _) -> Pexp_ident (lid) + Texp_ident (_path, lid, _) -> Pexp_ident (map_loc sub lid) | Texp_constant cst -> Pexp_constant cst | Texp_let (rec_flag, list, exp) -> Pexp_let (rec_flag, - List.map untype_binding list, - untype_expression exp) + List.map (sub.value_binding sub) list, + sub.expr sub exp) + + (** Pexp_function can't have a label, so we split in 3 cases. *) + (** One case, no guard: It's a fun. *) | Texp_function (label, [{c_lhs=p; c_guard=None; c_rhs=e}], _) -> - Pexp_fun (label, None, untype_pattern p, untype_expression e) + Pexp_fun (label, None, sub.pat sub p, sub.expr sub e) + (** No label: it's a function. *) | Texp_function (Nolabel, cases, _) -> - Pexp_function (untype_cases cases) - | Texp_function _ -> - assert false + Pexp_function (sub.cases sub cases) + (** Mix of both, we generate `fun ~label:$name$ -> match $name$ with ...` *) + | Texp_function (Labelled s | Optional s as label, cases, _) -> + let name = fresh_name s exp.exp_env in + Pexp_fun (label, None, Pat.var ~loc {loc;txt = name }, + Exp.match_ ~loc (Exp.ident ~loc {loc;txt= Lident name}) + (sub.cases sub cases)) | Texp_apply (exp, list) -> - Pexp_apply (untype_expression exp, + Pexp_apply (sub.expr sub exp, List.fold_right (fun (label, expo, _) list -> match expo with None -> list - | Some exp -> (label, untype_expression exp) :: list + | Some exp -> (label, sub.expr sub exp) :: list ) list []) | Texp_match (exp, cases, exn_cases, _) -> - let merged_cases = untype_cases cases + let merged_cases = sub.cases sub cases @ List.map (fun c -> - let uc = untype_case c in + let uc = sub.case sub c in let pat = { uc.pc_lhs with ppat_desc = Ppat_exception uc.pc_lhs } in { uc with pc_lhs = pat }) exn_cases in - Pexp_match (untype_expression exp, merged_cases) + Pexp_match (sub.expr sub exp, merged_cases) | Texp_try (exp, cases) -> - Pexp_try (untype_expression exp, untype_cases cases) + Pexp_try (sub.expr sub exp, sub.cases sub cases) | Texp_tuple list -> - Pexp_tuple (List.map untype_expression list) + Pexp_tuple (List.map (sub.expr sub) list) | Texp_construct (lid, _, args) -> - Pexp_construct (lid, + Pexp_construct (map_loc sub lid, (match args with [] -> None - | [ arg ] -> Some (untype_expression arg) + | [ arg ] -> Some (sub.expr sub arg) | args -> Some - (Exp.tuple ~loc:exp.exp_loc (List.map untype_expression args)) + (Exp.tuple ~loc (List.map (sub.expr sub) args)) )) | Texp_variant (label, expo) -> - Pexp_variant (label, option untype_expression expo) + Pexp_variant (label, map_opt (sub.expr sub) expo) | Texp_record (list, expo) -> Pexp_record (List.map (fun (lid, _, exp) -> - lid, untype_expression exp + (map_loc sub lid, sub.expr sub exp) ) list, - option untype_expression expo) + map_opt (sub.expr sub) expo) | Texp_field (exp, lid, _label) -> - Pexp_field (untype_expression exp, lid) + Pexp_field (sub.expr sub exp, map_loc sub lid) | Texp_setfield (exp1, lid, _label, exp2) -> - Pexp_setfield (untype_expression exp1, lid, - untype_expression exp2) + Pexp_setfield (sub.expr sub exp1, map_loc sub lid, + sub.expr sub exp2) | Texp_array list -> - Pexp_array (List.map untype_expression list) + Pexp_array (List.map (sub.expr sub) list) | Texp_ifthenelse (exp1, exp2, expo) -> - Pexp_ifthenelse (untype_expression exp1, - untype_expression exp2, - option untype_expression expo) + Pexp_ifthenelse (sub.expr sub exp1, + sub.expr sub exp2, + map_opt (sub.expr sub) expo) | Texp_sequence (exp1, exp2) -> - Pexp_sequence (untype_expression exp1, untype_expression exp2) + Pexp_sequence (sub.expr sub exp1, sub.expr sub exp2) | Texp_while (exp1, exp2) -> - Pexp_while (untype_expression exp1, untype_expression exp2) + Pexp_while (sub.expr sub exp1, sub.expr sub exp2) | Texp_for (_id, name, exp1, exp2, dir, exp3) -> Pexp_for (name, - untype_expression exp1, untype_expression exp2, - dir, untype_expression exp3) + sub.expr sub exp1, sub.expr sub exp2, + dir, sub.expr sub exp3) | Texp_send (exp, meth, _) -> - Pexp_send (untype_expression exp, match meth with + Pexp_send (sub.expr sub exp, match meth with Tmeth_name name -> name | Tmeth_val id -> Ident.name id) - | Texp_new (_path, lid, _) -> Pexp_new (lid) + | Texp_new (_path, lid, _) -> Pexp_new (map_loc sub lid) | Texp_instvar (_, path, name) -> - Pexp_ident ({name with txt = lident_of_path path}) + Pexp_ident ({loc = sub.location sub name.loc ; txt = lident_of_path path}) | Texp_setinstvar (_, _path, lid, exp) -> - Pexp_setinstvar (lid, untype_expression exp) + Pexp_setinstvar (map_loc sub lid, sub.expr sub exp) | Texp_override (_, list) -> Pexp_override (List.map (fun (_path, lid, exp) -> - lid, untype_expression exp + (map_loc sub lid, sub.expr sub exp) ) list) | Texp_letmodule (_id, name, mexpr, exp) -> - Pexp_letmodule (name, untype_module_expr mexpr, - untype_expression exp) - | Texp_assert exp -> Pexp_assert (untype_expression exp) - | Texp_lazy exp -> Pexp_lazy (untype_expression exp) + Pexp_letmodule (name, sub.module_expr sub mexpr, + sub.expr sub exp) + | Texp_assert exp -> Pexp_assert (sub.expr sub exp) + | Texp_lazy exp -> Pexp_lazy (sub.expr sub exp) | Texp_object (cl, _) -> - Pexp_object (untype_class_structure cl) + Pexp_object (sub.class_structure sub cl) | Texp_pack (mexpr) -> - Pexp_pack (untype_module_expr mexpr) + Pexp_pack (sub.module_expr sub mexpr) in - List.fold_right untype_extra exp.exp_extra - (Exp.mk ~loc:exp.exp_loc ~attrs:exp.exp_attributes desc) + List.fold_right (exp_extra sub) exp.exp_extra + (Exp.mk ~loc ~attrs desc) -and untype_package_type pack = - (pack.pack_txt, +let package_type sub pack = + (map_loc sub pack.pack_txt, List.map (fun (s, ct) -> - (s, untype_core_type ct)) pack.pack_fields) + (s, sub.typ sub ct)) pack.pack_fields) -and untype_signature sg = - List.map untype_signature_item sg.sig_items +let module_type_declaration sub mtd = + let loc = sub.location sub mtd.mtd_loc; in + let attrs = sub.attributes sub mtd.mtd_attributes in + Mtd.mk ~loc ~attrs + ?typ:(map_opt (sub.module_type sub) mtd.mtd_type) + (map_loc sub mtd.mtd_name) -and untype_signature_item item = +let signature sub sg = + List.map (sub.signature_item sub) sg.sig_items + +let signature_item sub item = + let loc = sub.location sub item.sig_loc; in let desc = match item.sig_desc with Tsig_value v -> - Psig_value (untype_value_description v) + Psig_value (sub.value_description sub v) | Tsig_type list -> - Psig_type (List.map untype_type_declaration list) + Psig_type (List.map (sub.type_declaration sub) list) | Tsig_typext tyext -> - Psig_typext (untype_type_extension tyext) + Psig_typext (sub.type_extension sub tyext) | Tsig_exception ext -> - Psig_exception (untype_extension_constructor ext) + Psig_exception (sub.extension_constructor sub ext) | Tsig_module md -> - Psig_module {pmd_name = md.md_name; - pmd_type = untype_module_type md.md_type; - pmd_attributes = md.md_attributes; pmd_loc = md.md_loc; - } + Psig_module (sub.module_declaration sub md) | Tsig_recmodule list -> - Psig_recmodule (List.map (fun md -> - {pmd_name = md.md_name; pmd_type = untype_module_type md.md_type; - pmd_attributes = md.md_attributes; pmd_loc = md.md_loc}) list) + Psig_recmodule (List.map (sub.module_declaration sub) list) | Tsig_modtype mtd -> - Psig_modtype {pmtd_name=mtd.mtd_name; - pmtd_type=option untype_module_type mtd.mtd_type; - pmtd_attributes=mtd.mtd_attributes; pmtd_loc=mtd.mtd_loc} + Psig_modtype (sub.module_type_declaration sub mtd) | Tsig_open od -> - Psig_open {popen_lid = od.open_txt; - popen_override = od.open_override; - popen_attributes = od.open_attributes; - popen_loc = od.open_loc; - } + Psig_open (sub.open_description sub od) | Tsig_include incl -> - Psig_include {pincl_mod = untype_module_type incl.incl_mod; - pincl_attributes = incl.incl_attributes; - pincl_loc = incl.incl_loc; - } + Psig_include (sub.include_description sub incl) | Tsig_class list -> - Psig_class (List.map untype_class_description list) + Psig_class (List.map (sub.class_description sub) list) | Tsig_class_type list -> - Psig_class_type (List.map untype_class_type_declaration list) + Psig_class_type (List.map (sub.class_type_declaration sub) list) | Tsig_attribute x -> Psig_attribute x in - { psig_desc = desc; - psig_loc = item.sig_loc; - } + Sig.mk ~loc desc -and untype_class_declaration cd = - { - pci_virt = cd.ci_virt; - pci_params = List.map untype_type_parameter cd.ci_params; - pci_name = cd.ci_id_name; - pci_expr = untype_class_expr cd.ci_expr; - pci_loc = cd.ci_loc; - pci_attributes = cd.ci_attributes; - } +let module_declaration sub md = + let loc = sub.location sub md.md_loc; in + let attrs = sub.attributes sub md.md_attributes in + Md.mk ~loc ~attrs + (map_loc sub md.md_name) + (sub.module_type sub md.md_type) -and untype_class_description cd = - { - pci_virt = cd.ci_virt; - pci_params = List.map untype_type_parameter cd.ci_params; - pci_name = cd.ci_id_name; - pci_expr = untype_class_type cd.ci_expr; - pci_loc = cd.ci_loc; - pci_attributes = cd.ci_attributes; - } +let include_infos f sub incl = + let loc = sub.location sub incl.incl_loc; in + let attrs = sub.attributes sub incl.incl_attributes in + Incl.mk ~loc ~attrs + (f sub incl.incl_mod) -and untype_class_type_declaration cd = - { - pci_virt = cd.ci_virt; - pci_params = List.map untype_type_parameter cd.ci_params; - pci_name = cd.ci_id_name; - pci_expr = untype_class_type cd.ci_expr; - pci_loc = cd.ci_loc; - pci_attributes = cd.ci_attributes; - } +let include_declaration sub = include_infos sub.module_expr sub +let include_description sub = include_infos sub.module_type sub -and untype_module_type mty = +let class_infos f sub ci = + let loc = sub.location sub ci.ci_loc; in + let attrs = sub.attributes sub ci.ci_attributes in + Ci.mk ~loc ~attrs + ~virt:ci.ci_virt + ~params:(List.map (type_parameter sub) ci.ci_params) + (map_loc sub ci.ci_id_name) + (f sub ci.ci_expr) + +let class_declaration sub = class_infos sub.class_expr sub +let class_description sub = class_infos sub.class_type sub +let class_type_declaration sub = class_infos sub.class_type sub + +let module_type sub mty = + let loc = sub.location sub mty.mty_loc; in + let attrs = sub.attributes sub mty.mty_attributes in let desc = match mty.mty_desc with - Tmty_ident (_path, lid) -> Pmty_ident (lid) - | Tmty_alias (_path, lid) -> Pmty_alias (lid) - | Tmty_signature sg -> Pmty_signature (untype_signature sg) + Tmty_ident (_path, lid) -> Pmty_ident (map_loc sub lid) + | Tmty_alias (_path, lid) -> Pmty_alias (map_loc sub lid) + | Tmty_signature sg -> Pmty_signature (sub.signature sub sg) | Tmty_functor (_id, name, mtype1, mtype2) -> - Pmty_functor (name, Misc.may_map untype_module_type mtype1, - untype_module_type mtype2) + Pmty_functor (name, map_opt (sub.module_type sub) mtype1, + sub.module_type sub mtype2) | Tmty_with (mtype, list) -> - Pmty_with (untype_module_type mtype, - List.map (fun (_path, lid, withc) -> - untype_with_constraint lid withc - ) list) + Pmty_with (sub.module_type sub mtype, + List.map (sub.with_constraint sub) list) | Tmty_typeof mexpr -> - Pmty_typeof (untype_module_expr mexpr) + Pmty_typeof (sub.module_expr sub mexpr) in - Mty.mk ~loc:mty.mty_loc desc + Mty.mk ~loc ~attrs desc -and untype_with_constraint lid cstr = +let with_constraint sub (_path, lid, cstr) = match cstr with - Twith_type decl -> Pwith_type (lid, untype_type_declaration decl) - | Twith_module (_path, lid2) -> Pwith_module (lid, lid2) - | Twith_typesubst decl -> Pwith_typesubst (untype_type_declaration decl) + | Twith_type decl -> + Pwith_type (map_loc sub lid, sub.type_declaration sub decl) + | Twith_module (_path, lid2) -> + Pwith_module (map_loc sub lid, map_loc sub lid2) + | Twith_typesubst decl -> Pwith_typesubst (sub.type_declaration sub decl) | Twith_modsubst (_path, lid2) -> - Pwith_modsubst ({loc = lid.loc; txt=Longident.last lid.txt}, lid2) + Pwith_modsubst + ({loc = sub.location sub lid.loc; txt=Longident.last lid.txt}, + map_loc sub lid2) -and untype_module_expr mexpr = +let module_expr sub mexpr = + let loc = sub.location sub mexpr.mod_loc; in + let attrs = sub.attributes sub mexpr.mod_attributes in match mexpr.mod_desc with - Tmod_constraint (m, _, Tmodtype_implicit, _ ) -> - untype_module_expr m - | _ -> - let desc = match mexpr.mod_desc with - Tmod_ident (_p, lid) -> Pmod_ident (lid) - | Tmod_structure st -> Pmod_structure (untype_structure st) - | Tmod_functor (_id, name, mtype, mexpr) -> - Pmod_functor (name, Misc.may_map untype_module_type mtype, - untype_module_expr mexpr) - | Tmod_apply (mexp1, mexp2, _) -> - Pmod_apply (untype_module_expr mexp1, untype_module_expr mexp2) - | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> - Pmod_constraint (untype_module_expr mexpr, - untype_module_type mtype) - | Tmod_constraint (_mexpr, _, Tmodtype_implicit, _) -> - assert false - | Tmod_unpack (exp, _pack) -> - Pmod_unpack (untype_expression exp) - (* TODO , untype_package_type pack) *) + Tmod_constraint (m, _, Tmodtype_implicit, _ ) -> + sub.module_expr sub m + | _ -> + let desc = match mexpr.mod_desc with + Tmod_ident (_p, lid) -> Pmod_ident (map_loc sub lid) + | Tmod_structure st -> Pmod_structure (sub.structure sub st) + | Tmod_functor (_id, name, mtype, mexpr) -> + Pmod_functor (name, Misc.may_map (sub.module_type sub) mtype, + sub.module_expr sub mexpr) + | Tmod_apply (mexp1, mexp2, _) -> + Pmod_apply (sub.module_expr sub mexp1, sub.module_expr sub mexp2) + | Tmod_constraint (mexpr, _, Tmodtype_explicit mtype, _) -> + Pmod_constraint (sub.module_expr sub mexpr, + sub.module_type sub mtype) + | Tmod_constraint (_mexpr, _, Tmodtype_implicit, _) -> + assert false + | Tmod_unpack (exp, _pack) -> + Pmod_unpack (sub.expr sub exp) + (* TODO , sub.package_type sub pack) *) + in + Mod.mk ~loc ~attrs desc - in - Mod.mk ~loc:mexpr.mod_loc desc - -and untype_class_expr cexpr = +let class_expr sub cexpr = + let loc = sub.location sub cexpr.cl_loc; in + let attrs = sub.attributes sub cexpr.cl_attributes in let desc = match cexpr.cl_desc with | Tcl_constraint ( { cl_desc = Tcl_ident (_path, lid, tyl); _ }, None, _, _, _ ) -> - Pcl_constr (lid, - List.map untype_core_type tyl) - | Tcl_structure clstr -> Pcl_structure (untype_class_structure clstr) + Pcl_constr (map_loc sub lid, + List.map (sub.typ sub) tyl) + | Tcl_structure clstr -> Pcl_structure (sub.class_structure sub clstr) | Tcl_fun (label, pat, _pv, cl, _partial) -> - Pcl_fun (label, None, untype_pattern pat, untype_class_expr cl) + Pcl_fun (label, None, sub.pat sub pat, sub.class_expr sub cl) | Tcl_apply (cl, args) -> - Pcl_apply (untype_class_expr cl, + Pcl_apply (sub.class_expr sub cl, List.fold_right (fun (label, expo, _) list -> match expo with None -> list - | Some exp -> (label, untype_expression exp) :: list + | Some exp -> (label, sub.expr sub exp) :: list ) args []) | Tcl_let (rec_flat, bindings, _ivars, cl) -> Pcl_let (rec_flat, - List.map untype_binding bindings, - untype_class_expr cl) + List.map (sub.value_binding sub) bindings, + sub.class_expr sub cl) | Tcl_constraint (cl, Some clty, _vals, _meths, _concrs) -> - Pcl_constraint (untype_class_expr cl, untype_class_type clty) + Pcl_constraint (sub.class_expr sub cl, sub.class_type sub clty) | Tcl_ident _ -> assert false | Tcl_constraint (_, None, _, _, _) -> assert false in - { pcl_desc = desc; - pcl_loc = cexpr.cl_loc; - pcl_attributes = cexpr.cl_attributes; - } + Cl.mk ~loc ~attrs desc -and untype_class_type ct = +let class_type sub ct = + let loc = sub.location sub ct.cltyp_loc; in + let attrs = sub.attributes sub ct.cltyp_attributes in let desc = match ct.cltyp_desc with - Tcty_signature csg -> Pcty_signature (untype_class_signature csg) + Tcty_signature csg -> Pcty_signature (sub.class_signature sub csg) | Tcty_constr (_path, lid, list) -> - Pcty_constr (lid, List.map untype_core_type list) + Pcty_constr (map_loc sub lid, List.map (sub.typ sub) list) | Tcty_arrow (label, ct, cl) -> - Pcty_arrow (label, untype_core_type ct, untype_class_type cl) + Pcty_arrow (label, sub.typ sub ct, sub.class_type sub cl) in - { pcty_desc = desc; - pcty_loc = ct.cltyp_loc; - pcty_attributes = ct.cltyp_attributes; - } + Cty.mk ~loc ~attrs desc -and untype_class_signature cs = +let class_signature sub cs = { - pcsig_self = untype_core_type cs.csig_self; - pcsig_fields = List.map untype_class_type_field cs.csig_fields; + pcsig_self = sub.typ sub cs.csig_self; + pcsig_fields = List.map (sub.class_type_field sub) cs.csig_fields; } -and untype_class_type_field ctf = +let class_type_field sub ctf = + let loc = sub.location sub ctf.ctf_loc; in + let attrs = sub.attributes sub ctf.ctf_attributes in let desc = match ctf.ctf_desc with - Tctf_inherit ct -> Pctf_inherit (untype_class_type ct) + Tctf_inherit ct -> Pctf_inherit (sub.class_type sub ct) | Tctf_val (s, mut, virt, ct) -> - Pctf_val (s, mut, virt, untype_core_type ct) + Pctf_val (s, mut, virt, sub.typ sub ct) | Tctf_method (s, priv, virt, ct) -> - Pctf_method (s, priv, virt, untype_core_type ct) + Pctf_method (s, priv, virt, sub.typ sub ct) | Tctf_constraint (ct1, ct2) -> - Pctf_constraint (untype_core_type ct1, untype_core_type ct2) + Pctf_constraint (sub.typ sub ct1, sub.typ sub ct2) | Tctf_attribute x -> Pctf_attribute x in - { - pctf_desc = desc; - pctf_loc = ctf.ctf_loc; - pctf_attributes = ctf.ctf_attributes; - } + Ctf.mk ~loc ~attrs desc -and untype_core_type ct = +let core_type sub ct = + let loc = sub.location sub ct.ctyp_loc; in + let attrs = sub.attributes sub ct.ctyp_attributes in let desc = match ct.ctyp_desc with Ttyp_any -> Ptyp_any | Ttyp_var s -> Ptyp_var s | Ttyp_arrow (label, ct1, ct2) -> - Ptyp_arrow (label, untype_core_type ct1, untype_core_type ct2) - | Ttyp_tuple list -> Ptyp_tuple (List.map untype_core_type list) + Ptyp_arrow (label, sub.typ sub ct1, sub.typ sub ct2) + | Ttyp_tuple list -> Ptyp_tuple (List.map (sub.typ sub) list) | Ttyp_constr (_path, lid, list) -> - Ptyp_constr (lid, - List.map untype_core_type list) + Ptyp_constr (map_loc sub lid, + List.map (sub.typ sub) list) | Ttyp_object (list, o) -> Ptyp_object - (List.map (fun (s, a, t) -> (s, a, untype_core_type t)) list, o) + (List.map (fun (s, a, t) -> (s, a, sub.typ sub t)) list, o) | Ttyp_class (_path, lid, list) -> - Ptyp_class (lid, List.map untype_core_type list) + Ptyp_class (map_loc sub lid, List.map (sub.typ sub) list) | Ttyp_alias (ct, s) -> - Ptyp_alias (untype_core_type ct, s) + Ptyp_alias (sub.typ sub ct, s) | Ttyp_variant (list, bool, labels) -> - Ptyp_variant (List.map untype_row_field list, bool, labels) - | Ttyp_poly (list, ct) -> Ptyp_poly (list, untype_core_type ct) - | Ttyp_package pack -> Ptyp_package (untype_package_type pack) + Ptyp_variant (List.map (sub.row_field sub) list, bool, labels) + | Ttyp_poly (list, ct) -> Ptyp_poly (list, sub.typ sub ct) + | Ttyp_package pack -> Ptyp_package (sub.package_type sub pack) in - Typ.mk ~loc:ct.ctyp_loc desc + Typ.mk ~loc ~attrs desc -and untype_class_structure cs = +let class_structure sub cs = let rec remove_self = function - | { pat_desc = Tpat_alias (p, id, _s) } when string_is_prefix "selfpat-" id.Ident.name -> + | { pat_desc = Tpat_alias (p, id, _s) } + when string_is_prefix "selfpat-" id.Ident.name -> remove_self p | p -> p in - { pcstr_self = untype_pattern (remove_self cs.cstr_self); - pcstr_fields = List.map untype_class_field cs.cstr_fields; + { pcstr_self = sub.pat sub (remove_self cs.cstr_self); + pcstr_fields = List.map (sub.class_field sub) cs.cstr_fields; } -and untype_row_field rf = +let row_field sub rf = match rf with Ttag (label, attrs, bool, list) -> - Rtag (label, attrs, bool, List.map untype_core_type list) - | Tinherit ct -> Rinherit (untype_core_type ct) + Rtag (label, sub.attributes sub attrs, bool, List.map (sub.typ sub) list) + | Tinherit ct -> Rinherit (sub.typ sub ct) and is_self_pat = function | { pat_desc = Tpat_alias(_pat, id, _) } -> string_is_prefix "self-" (Ident.name id) | _ -> false -and untype_class_field cf = +let class_field sub cf = + let loc = sub.location sub cf.cf_loc; in + let attrs = sub.attributes sub cf.cf_attributes in let desc = match cf.cf_desc with Tcf_inherit (ovf, cl, super, _vals, _meths) -> - Pcf_inherit (ovf, untype_class_expr cl, super) + Pcf_inherit (ovf, sub.class_expr sub cl, super) | Tcf_constraint (cty, cty') -> - Pcf_constraint (untype_core_type cty, untype_core_type cty') + Pcf_constraint (sub.typ sub cty, sub.typ sub cty') | Tcf_val (lab, mut, _, Tcfk_virtual cty, _) -> - Pcf_val (lab, mut, Cfk_virtual (untype_core_type cty)) + Pcf_val (lab, mut, Cfk_virtual (sub.typ sub cty)) | Tcf_val (lab, mut, _, Tcfk_concrete (o, exp), _) -> - Pcf_val (lab, mut, Cfk_concrete (o, untype_expression exp)) + Pcf_val (lab, mut, Cfk_concrete (o, sub.expr sub exp)) | Tcf_method (lab, priv, Tcfk_virtual cty) -> - Pcf_method (lab, priv, Cfk_virtual (untype_core_type cty)) + Pcf_method (lab, priv, Cfk_virtual (sub.typ sub cty)) | Tcf_method (lab, priv, Tcfk_concrete (o, exp)) -> let remove_fun_self = function | { exp_desc = Texp_function(Nolabel, [case], _) } @@ -628,15 +706,67 @@ and untype_class_field cf = | e -> e in let exp = remove_fun_self exp in - Pcf_method (lab, priv, Cfk_concrete (o, untype_expression exp)) - | Tcf_initializer exp -> + Pcf_method (lab, priv, Cfk_concrete (o, sub.expr sub exp)) + | Tcf_initializer exp -> let remove_fun_self = function | { exp_desc = Texp_function(Nolabel, [case], _) } when is_self_pat case.c_lhs && case.c_guard = None -> case.c_rhs | e -> e in let exp = remove_fun_self exp in - Pcf_initializer (untype_expression exp) + Pcf_initializer (sub.expr sub exp) | Tcf_attribute x -> Pcf_attribute x in - { pcf_desc = desc; pcf_loc = cf.cf_loc; pcf_attributes = cf.cf_attributes } + Cf.mk ~loc ~attrs desc + +let location sub l = l + +let default_mapper = + { + attribute = attribute ; + attributes = attributes ; + structure = structure; + structure_item = structure_item; + module_expr = module_expr; + signature = signature; + signature_item = signature_item; + module_type = module_type; + with_constraint = with_constraint; + class_declaration = class_declaration; + class_expr = class_expr; + class_field = class_field; + class_structure = class_structure; + class_type = class_type; + class_type_field = class_type_field; + class_signature = class_signature; + class_type_declaration = class_type_declaration; + class_description = class_description; + type_declaration = type_declaration; + type_kind = type_kind; + typ = core_type; + type_extension = type_extension; + extension_constructor = extension_constructor; + value_description = value_description; + pat = pattern; + expr = expression; + module_declaration = module_declaration; + module_type_declaration = module_type_declaration; + module_binding = module_binding; + package_type = package_type ; + open_description = open_description; + include_description = include_description; + include_declaration = include_declaration; + value_binding = value_binding; + constructor_declaration = constructor_declaration; + label_declaration = label_declaration; + cases = cases; + case = case; + location = location; + row_field = row_field ; + } + +let untype_structure ?(mapper=default_mapper) structure = + mapper.structure mapper structure + +let untype_signature ?(mapper=default_mapper) signature = + mapper.signature mapper signature diff --git a/typing/untypeast.mli b/typing/untypeast.mli index efd0a031d..702fe0cd7 100644 --- a/typing/untypeast.mli +++ b/typing/untypeast.mli @@ -10,11 +10,64 @@ (* *) (**************************************************************************) -val untype_structure : Typedtree.structure -> Parsetree.structure -val untype_signature : Typedtree.signature -> Parsetree.signature -val untype_expression : Typedtree.expression -> Parsetree.expression -val untype_type_declaration : - Typedtree.type_declaration -> Parsetree.type_declaration -val untype_module_type : Typedtree.module_type -> Parsetree.module_type +open Parsetree val lident_of_path : Path.t -> Longident.t + +type mapper = { + attribute: mapper -> Typedtree.attribute -> attribute; + attributes: mapper -> Typedtree.attribute list -> attribute list; + case: mapper -> Typedtree.case -> case; + cases: mapper -> Typedtree.case list -> case list; + class_declaration: mapper -> Typedtree.class_declaration -> class_declaration; + class_description: mapper -> Typedtree.class_description -> class_description; + class_expr: mapper -> Typedtree.class_expr -> class_expr; + class_field: mapper -> Typedtree.class_field -> class_field; + class_signature: mapper -> Typedtree.class_signature -> class_signature; + class_structure: mapper -> Typedtree.class_structure -> class_structure; + class_type: mapper -> Typedtree.class_type -> class_type; + class_type_declaration: mapper -> Typedtree.class_type_declaration + -> class_type_declaration; + class_type_field: mapper -> Typedtree.class_type_field -> class_type_field; + constructor_declaration: mapper -> Typedtree.constructor_declaration + -> constructor_declaration; + expr: mapper -> Typedtree.expression -> expression; + extension_constructor: mapper -> Typedtree.extension_constructor + -> extension_constructor; + include_declaration: + mapper -> Typedtree.include_declaration -> include_declaration; + include_description: + mapper -> Typedtree.include_description -> include_description; + label_declaration: + mapper -> Typedtree.label_declaration -> label_declaration; + location: mapper -> Location.t -> Location.t; + module_binding: mapper -> Typedtree.module_binding -> module_binding; + module_declaration: + mapper -> Typedtree.module_declaration -> module_declaration; + module_expr: mapper -> Typedtree.module_expr -> module_expr; + module_type: mapper -> Typedtree.module_type -> module_type; + module_type_declaration: + mapper -> Typedtree.module_type_declaration -> module_type_declaration; + package_type: mapper -> Typedtree.package_type -> package_type; + open_description: mapper -> Typedtree.open_description -> open_description; + pat: mapper -> Typedtree.pattern -> pattern; + row_field: mapper -> Typedtree.row_field -> row_field; + signature: mapper -> Typedtree.signature -> signature; + signature_item: mapper -> Typedtree.signature_item -> signature_item; + structure: mapper -> Typedtree.structure -> structure; + structure_item: mapper -> Typedtree.structure_item -> structure_item; + typ: mapper -> Typedtree.core_type -> core_type; + type_declaration: mapper -> Typedtree.type_declaration -> type_declaration; + type_extension: mapper -> Typedtree.type_extension -> type_extension; + type_kind: mapper -> Typedtree.type_kind -> type_kind; + value_binding: mapper -> Typedtree.value_binding -> value_binding; + value_description: mapper -> Typedtree.value_description -> value_description; + with_constraint: + mapper -> (Path.t * Longident.t Location.loc * Typedtree.with_constraint) + -> with_constraint; +} + +val default_mapper : mapper + +val untype_structure : ?mapper:mapper -> Typedtree.structure -> structure +val untype_signature : ?mapper:mapper -> Typedtree.signature -> signature