diff options
author | Alain Frisch <alain@frisch.fr> | 2013-09-26 08:49:46 +0000 |
---|---|---|
committer | Alain Frisch <alain@frisch.fr> | 2013-09-26 08:49:46 +0000 |
commit | e1b2a8b193e34b694b8a9ba976d36c088b1d664b (patch) | |
tree | 671379a607629d9187ace1bc09e352672e2641c3 | |
parent | 13dd4d972d4c081199c1e5a11ce5e923ecf61584 (diff) | |
download | ocaml-e1b2a8b193e34b694b8a9ba976d36c088b1d664b.tar.gz |
Get rid of recursion closing functions, being more explicit on the recursion does not hurt.
git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14186 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
-rw-r--r-- | experimental/frisch/js_syntax.ml | 12 | ||||
-rw-r--r-- | experimental/frisch/ppx_builder.ml | 2 | ||||
-rw-r--r-- | experimental/frisch/ppx_matches.ml | 24 | ||||
-rw-r--r-- | parsing/ast_mapper.ml | 292 | ||||
-rw-r--r-- | parsing/ast_mapper.mli | 40 |
5 files changed, 169 insertions, 201 deletions
diff --git a/experimental/frisch/js_syntax.ml b/experimental/frisch/js_syntax.ml index 4e78bf6392..fe11cb65ad 100644 --- a/experimental/frisch/js_syntax.ml +++ b/experimental/frisch/js_syntax.ml @@ -76,28 +76,28 @@ let mapper _args = let open Ast_mapper in let rec mk ~js = let super = default_mapper in - let my_expr this e = + let expr this e = let loc = e.pexp_loc in match e.pexp_desc with | Pexp_extension({txt="js";_}, PStr [{pstr_desc=Pstr_eval (e, _);_}]) -> - expr (mk ~js:true) e + let this = mk ~js:true in this.expr this e | Pexp_field (o, {txt = Lident meth; loc = _}) when js -> - let o = expr this o in + let o = this.expr this o in let prop_type = fresh_type () in let meth_type = tconstr "Js.gen_prop" [oobject ["get", prop_type]] in access_object loc o meth meth_type (fun x -> annot (apply_ "Js.Unsafe.get" [x; method_literal meth]) prop_type) | Pexp_setfield (o, {txt = Lident meth; loc = _}, e) when js -> - let o = expr this o and e = expr this e in + let o = this.expr this o and e = this.expr this e in let prop_type = fresh_type () in let meth_type = tconstr "Js.gen_prop" [oobject ["set", Typ.arrow "" prop_type (tconstr "unit" [])]] in access_object loc o meth meth_type (fun x -> apply_ "Js.Unsafe.set" [x; method_literal meth; annot e prop_type]) | Pexp_apply ({pexp_desc = Pexp_send (o, meth); pexp_loc = loc; _}, args) when js -> - method_call loc o meth (List.map (expr this) (List.map snd args)) + method_call loc o meth (List.map (this.expr this) (List.map snd args)) | Pexp_send (o, meth) when js -> method_call loc o meth [] @@ -105,7 +105,7 @@ let mapper _args = | _ -> super.expr this e in - {super with expr = my_expr} + {super with expr} in mk ~js:false diff --git a/experimental/frisch/ppx_builder.ml b/experimental/frisch/ppx_builder.ml index 32d3edd9e3..cb866df8e2 100644 --- a/experimental/frisch/ppx_builder.ml +++ b/experimental/frisch/ppx_builder.ml @@ -90,7 +90,7 @@ module Main : sig end = struct (function | {pstr_desc = Pstr_type tdecls; _} as i -> i :: (List.flatten (List.map gen_builder tdecls)) - | i -> [structure_item this i] + | i -> [this.structure_item this i] ) l ) ) diff --git a/experimental/frisch/ppx_matches.ml b/experimental/frisch/ppx_matches.ml index 52ac722d70..f6d9534717 100644 --- a/experimental/frisch/ppx_matches.ml +++ b/experimental/frisch/ppx_matches.ml @@ -10,18 +10,20 @@ open Ast_helper let mapper _args = let open Ast_mapper in let super = default_mapper in - let my_expr this e = - match e.pexp_desc with - | Pexp_extension({txt="matches";_}, PPat (p, guard)) -> - let p = pat this p in - let guard = Ast_mapper.map_opt (expr this) guard in - Exp.function_ ~loc:e.pexp_loc - [ + {super with + expr = + (fun this e -> + match e.pexp_desc with + | Pexp_extension({txt="matches";_}, PPat (p, guard)) -> + let p = this.pat this p in + let guard = Ast_mapper.map_opt (this.expr this) guard in + Exp.function_ ~loc:e.pexp_loc + [ Exp.case p ?guard (Convenience.constr "true" []); Exp.case (Pat.any ()) (Convenience.constr "false" []); - ] - | _ -> super.expr this e - in - {super with expr = my_expr} + ] + | _ -> super.expr this e + ) + } let () = Ast_mapper.run_main mapper diff --git a/parsing/ast_mapper.ml b/parsing/ast_mapper.ml index 00622cc6a3..64cc0be06b 100644 --- a/parsing/ast_mapper.ml +++ b/parsing/ast_mapper.ml @@ -56,6 +56,7 @@ type mapper = { } +(* let attribute this = this.attribute this let attributes this = this.attributes this let case this = this.case this @@ -91,6 +92,7 @@ let type_kind this = this.type_kind this let value_binding this = this.value_binding this let value_description this = this.value_description this let with_constraint this = this.with_constraint this +*) let map_fst f (x, y) = (f x, y) let map_snd f (x, y) = (x, f y) @@ -104,32 +106,32 @@ module T = struct (* Type expressions for the core language *) let row_field sub = function - | Rtag (l, b, tl) -> Rtag (l, b, List.map (typ sub) tl) - | Rinherit t -> Rinherit (typ sub t) + | Rtag (l, b, tl) -> Rtag (l, b, List.map (sub.typ sub) tl) + | Rinherit t -> Rinherit (sub.typ sub t) let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} = let open Typ in - let loc = location sub loc in - let attrs = attributes sub attrs in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in match desc with | Ptyp_any -> any ~loc ~attrs () | Ptyp_var s -> var ~loc ~attrs s | Ptyp_arrow (lab, t1, t2) -> - arrow ~loc ~attrs lab (typ sub t1) (typ sub t2) - | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (typ sub) tyl) + arrow ~loc ~attrs lab (sub.typ sub t1) (sub.typ sub t2) + | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub.typ sub) tyl) | Ptyp_constr (lid, tl) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (typ sub) tl) + constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) | Ptyp_object (l, o) -> - object_ ~loc ~attrs (List.map (map_snd (typ sub)) l) o + object_ ~loc ~attrs (List.map (map_snd (sub.typ sub)) l) o | Ptyp_class (lid, tl) -> - class_ ~loc ~attrs (map_loc sub lid) (List.map (typ sub) tl) - | Ptyp_alias (t, s) -> alias ~loc ~attrs (typ sub t) s + class_ ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tl) + | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub.typ sub t) s | Ptyp_variant (rl, b, ll) -> variant ~loc ~attrs (List.map (row_field sub) rl) b ll - | Ptyp_poly (sl, t) -> poly ~loc ~attrs sl (typ sub t) + | Ptyp_poly (sl, t) -> poly ~loc ~attrs sl (sub.typ sub t) | Ptyp_package (lid, l) -> package ~loc ~attrs (map_loc sub lid) - (List.map (map_tuple (map_loc sub) (typ sub)) l) + (List.map (map_tuple (map_loc sub) (sub.typ sub)) l) | Ptyp_extension x -> extension ~loc ~attrs (sub.extension sub x) let map_type_declaration sub @@ -142,18 +144,18 @@ module T = struct Type.mk (map_loc sub ptype_name) ~params:(List.map (map_fst (map_opt (map_loc sub))) ptype_params) ~priv:ptype_private - ~cstrs:(List.map (map_tuple3 (typ sub) (typ sub) (location sub)) + ~cstrs:(List.map (map_tuple3 (sub.typ sub) (sub.typ sub) (sub.location sub)) ptype_cstrs) - ~kind:(type_kind sub ptype_kind) - ?manifest:(map_opt (typ sub) ptype_manifest) - ~loc:(location sub ptype_loc) - ~attrs:(attributes sub ptype_attributes) + ~kind:(sub.type_kind sub ptype_kind) + ?manifest:(map_opt (sub.typ sub) ptype_manifest) + ~loc:(sub.location sub ptype_loc) + ~attrs:(sub.attributes sub ptype_attributes) let map_type_kind sub = function | Ptype_abstract -> Ptype_abstract | Ptype_variant l -> - Ptype_variant (List.map (constructor_declaration sub) l) - | Ptype_record l -> Ptype_record (List.map (label_declaration sub) l) + Ptype_variant (List.map (sub.constructor_declaration sub) l) + | Ptype_record l -> Ptype_record (List.map (sub.label_declaration sub) l) end module CT = struct @@ -161,31 +163,31 @@ module CT = struct let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = let open Cty in - let loc = location sub loc in + let loc = sub.location sub loc in match desc with | Pcty_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (typ sub) tys) - | Pcty_signature x -> signature ~loc ~attrs (class_signature sub x) + constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) + | Pcty_signature x -> signature ~loc ~attrs (sub.class_signature sub x) | Pcty_arrow (lab, t, ct) -> - arrow ~loc ~attrs lab (typ sub t) (class_type sub ct) + arrow ~loc ~attrs lab (sub.typ sub t) (sub.class_type sub ct) | Pcty_extension x -> extension ~loc ~attrs (sub.extension sub x) let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} = let open Ctf in - let loc = location sub loc in + let loc = sub.location sub loc in match desc with - | Pctf_inherit ct -> inherit_ ~loc ~attrs (class_type sub ct) - | Pctf_val (s, m, v, t) -> val_ ~loc ~attrs s m v (typ sub t) - | Pctf_method (s, p, v, t) -> method_ ~loc ~attrs s p v (typ sub t) + | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub.class_type sub ct) + | Pctf_val (s, m, v, t) -> val_ ~loc ~attrs s m v (sub.typ sub t) + | Pctf_method (s, p, v, t) -> method_ ~loc ~attrs s p v (sub.typ sub t) | Pctf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (typ sub t1) (typ sub t2) + constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) | Pctf_extension x -> extension ~loc ~attrs (sub.extension sub x) let map_signature sub {pcsig_self; pcsig_fields} = Csig.mk - (typ sub pcsig_self) - (List.map (class_type_field sub) pcsig_fields) + (sub.typ sub pcsig_self) + (List.map (sub.class_type_field sub) pcsig_fields) end module MT = struct @@ -193,49 +195,49 @@ module MT = struct let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = let open Mty in - let loc = location sub loc in - let attrs = attributes sub attrs in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in match desc with | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) | Pmty_signature sg -> signature ~loc ~attrs (sub.signature sub sg) | Pmty_functor (s, mt1, mt2) -> - functor_ ~loc ~attrs (map_loc sub s) (module_type sub mt1) - (module_type sub mt2) + functor_ ~loc ~attrs (map_loc sub s) (sub.module_type sub mt1) + (sub.module_type sub mt2) | Pmty_with (mt, l) -> - with_ ~loc ~attrs (module_type sub mt) - (List.map (with_constraint sub) l) - | Pmty_typeof me -> typeof_ ~loc ~attrs (module_expr sub me) + with_ ~loc ~attrs (sub.module_type sub mt) + (List.map (sub.with_constraint sub) l) + | Pmty_typeof me -> typeof_ ~loc ~attrs (sub.module_expr sub me) | Pmty_extension x -> extension ~loc ~attrs (sub.extension sub x) let map_with_constraint sub = function | Pwith_type (lid, d) -> - Pwith_type (map_loc sub lid, type_declaration sub d) + Pwith_type (map_loc sub lid, sub.type_declaration sub d) | Pwith_module (lid, lid2) -> Pwith_module (map_loc sub lid, map_loc sub lid2) - | Pwith_typesubst d -> Pwith_typesubst (type_declaration sub d) + | Pwith_typesubst d -> Pwith_typesubst (sub.type_declaration sub d) | Pwith_modsubst (s, lid) -> Pwith_modsubst (map_loc sub s, map_loc sub lid) let map_signature_item sub {psig_desc = desc; psig_loc = loc} = let open Sig in - let loc = location sub loc in + let loc = sub.location sub loc in match desc with - | Psig_value vd -> value ~loc (value_description sub vd) - | Psig_type l -> type_ ~loc (List.map (type_declaration sub) l) - | Psig_exception ed -> exception_ ~loc (constructor_declaration sub ed) - | Psig_module x -> module_ ~loc (module_declaration sub x) + | Psig_value vd -> value ~loc (sub.value_description sub vd) + | Psig_type l -> type_ ~loc (List.map (sub.type_declaration sub) l) + | Psig_exception ed -> exception_ ~loc (sub.constructor_declaration sub ed) + | Psig_module x -> module_ ~loc (sub.module_declaration sub x) | Psig_recmodule l -> - rec_module ~loc (List.map (module_declaration sub) l) - | Psig_modtype x -> modtype ~loc (module_type_declaration sub x) + rec_module ~loc (List.map (sub.module_declaration sub) l) + | Psig_modtype x -> modtype ~loc (sub.module_type_declaration sub x) | Psig_open (ovf, lid, attrs) -> - open_ ~loc ~attrs:(attributes sub attrs) ovf (map_loc sub lid) + open_ ~loc ~attrs:(sub.attributes sub attrs) ovf (map_loc sub lid) | Psig_include (mt, attrs) -> - include_ ~loc (module_type sub mt) ~attrs:(attributes sub attrs) - | Psig_class l -> class_ ~loc (List.map (class_description sub) l) + include_ ~loc (sub.module_type sub mt) ~attrs:(sub.attributes sub attrs) + | Psig_class l -> class_ ~loc (List.map (sub.class_description sub) l) | Psig_class_type l -> - class_type ~loc (List.map (class_type_declaration sub) l) + class_type ~loc (List.map (sub.class_type_declaration sub) l) | Psig_extension (x, attrs) -> - extension ~loc (sub.extension sub x) ~attrs:(attributes sub attrs) + extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) | Psig_attribute x -> attribute ~loc (sub.attribute sub x) end @@ -245,46 +247,46 @@ module M = struct let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = let open Mod in - let loc = location sub loc in - let attrs = attributes sub attrs in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in match desc with | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) | Pmod_structure str -> structure ~loc ~attrs (sub.structure sub str) | Pmod_functor (arg, arg_ty, body) -> - functor_ ~loc ~attrs (map_loc sub arg) (module_type sub arg_ty) - (module_expr sub body) + functor_ ~loc ~attrs (map_loc sub arg) (sub.module_type sub arg_ty) + (sub.module_expr sub body) | Pmod_apply (m1, m2) -> - apply ~loc ~attrs (module_expr sub m1) (module_expr sub m2) + apply ~loc ~attrs (sub.module_expr sub m1) (sub.module_expr sub m2) | Pmod_constraint (m, mty) -> - constraint_ ~loc ~attrs (module_expr sub m) (module_type sub mty) - | Pmod_unpack e -> unpack ~loc ~attrs (expr sub e) + constraint_ ~loc ~attrs (sub.module_expr sub m) (sub.module_type sub mty) + | Pmod_unpack e -> unpack ~loc ~attrs (sub.expr sub e) | Pmod_extension x -> extension ~loc ~attrs (sub.extension sub x) let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = let open Str in - let loc = location sub loc in + let loc = sub.location sub loc in match desc with | Pstr_eval (x, attrs) -> - eval ~loc ~attrs:(attributes sub attrs) (expr sub x) - | Pstr_value (r, vbs) -> value ~loc r (List.map (value_binding sub) vbs) - | Pstr_primitive vd -> primitive ~loc (value_description sub vd) - | Pstr_type l -> type_ ~loc (List.map (type_declaration sub) l) - | Pstr_exception ed -> exception_ ~loc (constructor_declaration sub ed) + eval ~loc ~attrs:(sub.attributes sub attrs) (sub.expr sub x) + | Pstr_value (r, vbs) -> value ~loc r (List.map (sub.value_binding sub) vbs) + | Pstr_primitive vd -> primitive ~loc (sub.value_description sub vd) + | Pstr_type l -> type_ ~loc (List.map (sub.type_declaration sub) l) + | Pstr_exception ed -> exception_ ~loc (sub.constructor_declaration sub ed) | Pstr_exn_rebind (s, lid, attrs) -> exn_rebind ~loc (map_loc sub s) (map_loc sub lid) - ~attrs:(attributes sub attrs) - | Pstr_module x -> module_ ~loc (module_binding sub x) - | Pstr_recmodule l -> rec_module ~loc (List.map (module_binding sub) l) - | Pstr_modtype x -> modtype ~loc (module_type_declaration sub x) + ~attrs:(sub.attributes sub attrs) + | Pstr_module x -> module_ ~loc (sub.module_binding sub x) + | Pstr_recmodule l -> rec_module ~loc (List.map (sub.module_binding sub) l) + | Pstr_modtype x -> modtype ~loc (sub.module_type_declaration sub x) | Pstr_open (ovf, lid, attrs) -> - open_ ~loc ~attrs:(attributes sub attrs) ovf (map_loc sub lid) - | Pstr_class l -> class_ ~loc (List.map (class_declaration sub) l) + open_ ~loc ~attrs:(sub.attributes sub attrs) ovf (map_loc sub lid) + | Pstr_class l -> class_ ~loc (List.map (sub.class_declaration sub) l) | Pstr_class_type l -> - class_type ~loc (List.map (class_type_declaration sub) l) + class_type ~loc (List.map (sub.class_type_declaration sub) l) | Pstr_include (e, attrs) -> - include_ ~loc (module_expr sub e) ~attrs:(attributes sub attrs) + include_ ~loc (sub.module_expr sub e) ~attrs:(sub.attributes sub attrs) | Pstr_extension (x, attrs) -> - extension ~loc (sub.extension sub x) ~attrs:(attributes sub attrs) + extension ~loc (sub.extension sub x) ~attrs:(sub.attributes sub attrs) | Pstr_attribute x -> attribute ~loc (sub.attribute sub x) end @@ -299,66 +301,70 @@ module E = struct let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} = let open Exp in - let loc = location sub loc in - let attrs = attributes sub attrs in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in match desc with | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) | Pexp_constant x -> constant ~loc ~attrs x | Pexp_let (r, vbs, e) -> - let_ ~loc ~attrs r (List.map (value_binding sub) vbs) (expr sub e) + let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) + (sub.expr sub e) | Pexp_fun (lab, def, p, e) -> - fun_ ~loc ~attrs lab (map_opt (expr sub) def) (pat sub p) - (expr sub e) - | Pexp_function pel -> function_ ~loc ~attrs (cases sub pel) + fun_ ~loc ~attrs lab (map_opt (sub.expr sub) def) (sub.pat sub p) + (sub.expr sub e) + | Pexp_function pel -> function_ ~loc ~attrs (sub.cases sub pel) | Pexp_apply (e, l) -> - apply ~loc ~attrs (expr sub e) (List.map (map_snd (expr sub)) l) - | Pexp_match (e, pel) -> match_ ~loc ~attrs (expr sub e) (cases sub pel) - | Pexp_try (e, pel) -> try_ ~loc ~attrs (expr sub e) (cases sub pel) - | Pexp_tuple el -> tuple ~loc ~attrs (List.map (expr sub) el) + apply ~loc ~attrs (sub.expr sub e) (List.map (map_snd (sub.expr sub)) l) + | Pexp_match (e, pel) -> + match_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) + | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub.expr sub e) (sub.cases sub pel) + | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub.expr sub) el) | Pexp_construct (lid, arg) -> - construct ~loc ~attrs (map_loc sub lid) (map_opt (expr sub) arg) + construct ~loc ~attrs (map_loc sub lid) (map_opt (sub.expr sub) arg) | Pexp_variant (lab, eo) -> - variant ~loc ~attrs lab (map_opt (expr sub) eo) + variant ~loc ~attrs lab (map_opt (sub.expr sub) eo) | Pexp_record (l, eo) -> - record ~loc ~attrs (List.map (map_tuple (map_loc sub) (expr sub)) l) - (map_opt (expr sub) eo) - | Pexp_field (e, lid) -> field ~loc ~attrs (expr sub e) (map_loc sub lid) + record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.expr sub)) l) + (map_opt (sub.expr sub) eo) + | Pexp_field (e, lid) -> + field ~loc ~attrs (sub.expr sub e) (map_loc sub lid) | Pexp_setfield (e1, lid, e2) -> - setfield ~loc ~attrs (expr sub e1) (map_loc sub lid) (expr sub e2) - | Pexp_array el -> array ~loc ~attrs (List.map (expr sub) el) + setfield ~loc ~attrs (sub.expr sub e1) (map_loc sub lid) + (sub.expr sub e2) + | Pexp_array el -> array ~loc ~attrs (List.map (sub.expr sub) el) | Pexp_ifthenelse (e1, e2, e3) -> - ifthenelse ~loc ~attrs (expr sub e1) (expr sub e2) - (map_opt (expr sub) e3) + ifthenelse ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) + (map_opt (sub.expr sub) e3) | Pexp_sequence (e1, e2) -> - sequence ~loc ~attrs (expr sub e1) (expr sub e2) - | Pexp_while (e1, e2) -> while_ ~loc ~attrs (expr sub e1) (expr sub e2) + sequence ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) + | Pexp_while (e1, e2) -> while_ ~loc ~attrs (sub.expr sub e1) (sub.expr sub e2) | Pexp_for (id, e1, e2, d, e3) -> - for_ ~loc ~attrs (map_loc sub id) (expr sub e1) (expr sub e2) d - (expr sub e3) + for_ ~loc ~attrs (map_loc sub id) (sub.expr sub e1) (sub.expr sub e2) d + (sub.expr sub e3) | Pexp_coerce (e, t1, t2) -> - coerce ~loc ~attrs (expr sub e) (map_opt (typ sub) t1) - (typ sub t2) + coerce ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t1) + (sub.typ sub t2) | Pexp_constraint (e, t) -> - constraint_ ~loc ~attrs (expr sub e) (typ sub t) - | Pexp_send (e, s) -> send ~loc ~attrs (expr sub e) s + constraint_ ~loc ~attrs (sub.expr sub e) (sub.typ sub t) + | Pexp_send (e, s) -> send ~loc ~attrs (sub.expr sub e) s | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid) | Pexp_setinstvar (s, e) -> - setinstvar ~loc ~attrs (map_loc sub s) (expr sub e) + setinstvar ~loc ~attrs (map_loc sub s) (sub.expr sub e) | Pexp_override sel -> override ~loc ~attrs - (List.map (map_tuple (map_loc sub) (expr sub)) sel) + (List.map (map_tuple (map_loc sub) (sub.expr sub)) sel) | Pexp_letmodule (s, me, e) -> - letmodule ~loc ~attrs (map_loc sub s) (module_expr sub me) - (expr sub e) - | Pexp_assert e -> assert_ ~loc ~attrs (expr sub e) - | Pexp_lazy e -> lazy_ ~loc ~attrs (expr sub e) + letmodule ~loc ~attrs (map_loc sub s) (sub.module_expr sub me) + (sub.expr sub e) + | Pexp_assert e -> assert_ ~loc ~attrs (sub.expr sub e) + | Pexp_lazy e -> lazy_ ~loc ~attrs (sub.expr sub e) | Pexp_poly (e, t) -> - poly ~loc ~attrs (expr sub e) (map_opt (typ sub) t) - | Pexp_object cls -> object_ ~loc ~attrs (class_structure sub cls) - | Pexp_newtype (s, e) -> newtype ~loc ~attrs s (expr sub e) - | Pexp_pack me -> pack ~loc ~attrs (module_expr sub me) + poly ~loc ~attrs (sub.expr sub e) (map_opt (sub.typ sub) t) + | Pexp_object cls -> object_ ~loc ~attrs (sub.class_structure sub cls) + | Pexp_newtype (s, e) -> newtype ~loc ~attrs s (sub.expr sub e) + | Pexp_pack me -> pack ~loc ~attrs (sub.module_expr sub me) | Pexp_open (ovf, lid, e) -> - open_ ~loc ~attrs ovf (map_loc sub lid) (expr sub e) + open_ ~loc ~attrs ovf (map_loc sub lid) (sub.expr sub e) | Pexp_extension x -> extension ~loc ~attrs (sub.extension sub x) end @@ -367,27 +373,27 @@ module P = struct let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} = let open Pat in - let loc = location sub loc in - let attrs = attributes sub attrs in + let loc = sub.location sub loc in + let attrs = sub.attributes sub attrs in match desc with | Ppat_any -> any ~loc ~attrs () | Ppat_var s -> var ~loc ~attrs (map_loc sub s) - | Ppat_alias (p, s) -> alias ~loc ~attrs (pat sub p) (map_loc sub s) + | Ppat_alias (p, s) -> alias ~loc ~attrs (sub.pat sub p) (map_loc sub s) | Ppat_constant c -> constant ~loc ~attrs c | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2 - | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (pat sub) pl) + | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub.pat sub) pl) | Ppat_construct (l, p) -> - construct ~loc ~attrs (map_loc sub l) (map_opt (pat sub) p) - | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (pat sub) p) + construct ~loc ~attrs (map_loc sub l) (map_opt (sub.pat sub) p) + | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub.pat sub) p) | Ppat_record (lpl, cf) -> - record ~loc ~attrs (List.map (map_tuple (map_loc sub) (pat sub)) lpl) + record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub.pat sub)) lpl) cf - | Ppat_array pl -> array ~loc ~attrs (List.map (pat sub) pl) - | Ppat_or (p1, p2) -> or_ ~loc ~attrs (pat sub p1) (pat sub p2) + | Ppat_array pl -> array ~loc ~attrs (List.map (sub.pat sub) pl) + | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub.pat sub p1) (sub.pat sub p2) | Ppat_constraint (p, t) -> - constraint_ ~loc ~attrs (pat sub p) (typ sub t) + constraint_ ~loc ~attrs (sub.pat sub p) (sub.typ sub t) | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) - | Ppat_lazy p -> lazy_ ~loc ~attrs (pat sub p) + | Ppat_lazy p -> lazy_ ~loc ~attrs (sub.pat sub p) | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) | Ppat_extension x -> extension ~loc ~attrs (sub.extension sub x) end @@ -397,48 +403,48 @@ module CE = struct let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = let open Cl in - let loc = location sub loc in + let loc = sub.location sub loc in match desc with | Pcl_constr (lid, tys) -> - constr ~loc ~attrs (map_loc sub lid) (List.map (typ sub) tys) + constr ~loc ~attrs (map_loc sub lid) (List.map (sub.typ sub) tys) | Pcl_structure s -> - structure ~loc ~attrs (class_structure sub s) + structure ~loc ~attrs (sub.class_structure sub s) | Pcl_fun (lab, e, p, ce) -> fun_ ~loc ~attrs lab - (map_opt (expr sub) e) - (pat sub p) - (class_expr sub ce) + (map_opt (sub.expr sub) e) + (sub.pat sub p) + (sub.class_expr sub ce) | Pcl_apply (ce, l) -> - apply ~loc ~attrs (class_expr sub ce) - (List.map (map_snd (expr sub)) l) + apply ~loc ~attrs (sub.class_expr sub ce) + (List.map (map_snd (sub.expr sub)) l) | Pcl_let (r, vbs, ce) -> - let_ ~loc ~attrs r (List.map (value_binding sub) vbs) - (class_expr sub ce) + let_ ~loc ~attrs r (List.map (sub.value_binding sub) vbs) + (sub.class_expr sub ce) | Pcl_constraint (ce, ct) -> - constraint_ ~loc ~attrs (class_expr sub ce) (class_type sub ct) + constraint_ ~loc ~attrs (sub.class_expr sub ce) (sub.class_type sub ct) | Pcl_extension x -> extension ~loc ~attrs (sub.extension sub x) let map_kind sub = function - | Cfk_concrete (o, e) -> Cfk_concrete (o, expr sub e) - | Cfk_virtual t -> Cfk_virtual (typ sub t) + | Cfk_concrete (o, e) -> Cfk_concrete (o, sub.expr sub e) + | Cfk_virtual t -> Cfk_virtual (sub.typ sub t) let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = let open Cf in - let loc = location sub loc in + let loc = sub.location sub loc in match desc with - | Pcf_inherit (o, ce, s) -> inherit_ ~loc ~attrs o (class_expr sub ce) s + | Pcf_inherit (o, ce, s) -> inherit_ ~loc ~attrs o (sub.class_expr sub ce) s | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k) | Pcf_method (s, p, k) -> method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k) | Pcf_constraint (t1, t2) -> - constraint_ ~loc ~attrs (typ sub t1) (typ sub t2) - | Pcf_initializer e -> initializer_ ~loc ~attrs (expr sub e) + constraint_ ~loc ~attrs (sub.typ sub t1) (sub.typ sub t2) + | Pcf_initializer e -> initializer_ ~loc ~attrs (sub.expr sub e) | Pcf_extension x -> extension ~loc ~attrs (sub.extension sub x) let map_structure sub {pcstr_self; pcstr_fields} = { - pcstr_self = pat sub pcstr_self; - pcstr_fields = List.map (class_field sub) pcstr_fields; + pcstr_self = sub.pat sub pcstr_self; + pcstr_fields = List.map (sub.class_field sub) pcstr_fields; } let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; @@ -448,8 +454,8 @@ module CE = struct ~params:(List.map (map_fst (map_loc sub)) pl) (map_loc sub pci_name) (f pci_expr) - ~loc:(location sub pci_loc) - ~attrs:(attributes sub pci_attributes) + ~loc:(sub.location sub pci_loc) + ~attrs:(sub.attributes sub pci_attributes) end (* Now, a generic AST mapper, to be extended to cover all kinds and diff --git a/parsing/ast_mapper.mli b/parsing/ast_mapper.mli index 30f2368686..c71db50a7d 100644 --- a/parsing/ast_mapper.mli +++ b/parsing/ast_mapper.mli @@ -61,46 +61,6 @@ type mapper = { val default_mapper: mapper (** A default mapper, which implements a "deep identity" mapping. *) -(** {2 Applying a mapper to a specific syntactic category} *) - -val attribute: mapper -> attribute -> attribute - (** [attribute this x] is equivalent to [this.attribute this x]. *) - -val attributes: mapper -> attribute list -> attribute list -val case: mapper -> case -> case -val cases: mapper -> case list -> case list -val class_declaration: mapper -> class_declaration -> class_declaration -val class_description: mapper -> class_description -> class_description -val class_expr: mapper -> class_expr -> class_expr -val class_field: mapper -> class_field -> class_field -val class_signature: mapper -> class_signature -> class_signature -val class_structure: mapper -> class_structure -> class_structure -val class_type: mapper -> class_type -> class_type -val class_type_declaration: mapper -> class_type_declaration -> class_type_declaration -val class_type_field: mapper -> class_type_field -> class_type_field -val constructor_declaration: mapper -> constructor_declaration -> constructor_declaration -val expr: mapper -> expression -> expression -val extension: mapper -> extension -> extension -val label_declaration: mapper -> label_declaration -> label_declaration -val location: mapper -> Location.t -> Location.t -val module_binding: mapper -> module_binding -> module_binding -val module_declaration: mapper -> module_declaration -> module_declaration -val module_expr: mapper -> module_expr -> module_expr -val module_type: mapper -> module_type -> module_type -val module_type_declaration: mapper -> module_type_declaration -> module_type_declaration -val pat: mapper -> pattern -> pattern -val payload: mapper -> payload -> payload -val signature: mapper -> signature -> signature -val signature_item: mapper -> signature_item -> signature_item -val structure: mapper -> structure -> structure -val structure_item: mapper -> structure_item -> structure_item -val typ: mapper -> core_type -> core_type -val type_declaration: mapper -> type_declaration -> type_declaration -val type_kind: mapper -> type_kind -> type_kind -val value_binding: mapper -> value_binding -> value_binding -val value_description: mapper -> value_description -> value_description -val with_constraint: mapper -> with_constraint -> with_constraint - (** {2 Apply mappers to compilation units} *) val apply: source:string -> target:string -> mapper -> unit |