2012-11-08 06:30:38 -08:00
|
|
|
(***********************************************************************)
|
|
|
|
(* *)
|
|
|
|
(* OCaml *)
|
|
|
|
(* *)
|
|
|
|
(* Alain Frisch, LexiFi *)
|
|
|
|
(* *)
|
|
|
|
(* Copyright 2012 Institut National de Recherche en Informatique et *)
|
|
|
|
(* en Automatique. All rights reserved. This file is distributed *)
|
|
|
|
(* under the terms of the Q Public License version 1.0. *)
|
|
|
|
(* *)
|
|
|
|
(***********************************************************************)
|
|
|
|
|
|
|
|
(* A generic Parsetree mapping class *)
|
|
|
|
|
2012-06-29 02:36:32 -07:00
|
|
|
open Location
|
|
|
|
open Config
|
|
|
|
open Parsetree
|
|
|
|
open Asttypes
|
2013-03-08 06:59:45 -08:00
|
|
|
open Ast_helper
|
2012-06-29 02:36:32 -07:00
|
|
|
|
2013-04-02 08:33:35 -07:00
|
|
|
let map_fst f (x, y) = (f x, y)
|
2012-06-29 03:04:17 -07:00
|
|
|
let map_snd f (x, y) = (x, f y)
|
2012-07-24 01:40:50 -07:00
|
|
|
let map_tuple f1 f2 (x, y) = (f1 x, f2 y)
|
2013-03-04 09:39:07 -08:00
|
|
|
let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z)
|
2012-07-24 01:40:50 -07:00
|
|
|
let map_opt f = function None -> None | Some x -> Some (f x)
|
2012-06-29 02:36:32 -07:00
|
|
|
|
2013-01-07 06:13:01 -08:00
|
|
|
let map_loc sub {loc; txt} = {loc = sub # location loc; txt}
|
|
|
|
|
2012-09-18 08:55:30 -07:00
|
|
|
module T = struct
|
|
|
|
(* Type expressions for the core language *)
|
|
|
|
|
|
|
|
let row_field sub = function
|
|
|
|
| Rtag (l, b, tl) -> Rtag (l, b, List.map (sub # typ) tl)
|
|
|
|
| Rinherit t -> Rinherit (sub # typ t)
|
|
|
|
|
2013-03-08 06:59:45 -08:00
|
|
|
let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_attributes = attrs} =
|
|
|
|
let open Typ in
|
2013-01-07 06:13:01 -08:00
|
|
|
let loc = sub # location loc in
|
2013-03-08 06:59:45 -08:00
|
|
|
let attrs = sub # attributes attrs in
|
2012-09-18 08:55:30 -07:00
|
|
|
match desc with
|
2013-03-08 06:59:45 -08:00
|
|
|
| Ptyp_any -> any ~loc ~attrs ()
|
|
|
|
| Ptyp_var s -> var ~loc ~attrs s
|
|
|
|
| Ptyp_arrow (lab, t1, t2) -> arrow ~loc ~attrs lab (sub # typ t1) (sub # typ t2)
|
|
|
|
| Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub # typ) tyl)
|
|
|
|
| Ptyp_constr (lid, tl) -> constr ~loc ~attrs (map_loc sub lid) (List.map (sub # typ) tl)
|
2013-04-09 06:29:00 -07:00
|
|
|
| Ptyp_object (l, o) -> object_ ~loc ~attrs (List.map (map_snd (sub # typ)) l) o
|
2013-03-08 06:59:45 -08:00
|
|
|
| Ptyp_class (lid, tl, ll) -> class_ ~loc ~attrs (map_loc sub lid) (List.map (sub # typ) tl) ll
|
|
|
|
| Ptyp_alias (t, s) -> alias ~loc ~attrs (sub # typ 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 (sub # typ t)
|
|
|
|
| Ptyp_package (lid, l) -> package ~loc ~attrs (map_loc sub lid) (List.map (map_tuple (map_loc sub) (sub # typ)) l)
|
|
|
|
| Ptyp_extension x -> extension ~loc ~attrs (sub # extension x)
|
2012-09-18 08:55:30 -07:00
|
|
|
|
2013-03-06 03:47:59 -08:00
|
|
|
let map_type_declaration sub
|
|
|
|
{ptype_name; ptype_params; ptype_cstrs;
|
|
|
|
ptype_kind;
|
|
|
|
ptype_private;
|
|
|
|
ptype_manifest;
|
|
|
|
ptype_attributes;
|
|
|
|
ptype_loc} =
|
2013-03-08 06:59:45 -08:00
|
|
|
Type.mk (map_loc sub ptype_name)
|
2013-04-02 08:33:35 -07:00
|
|
|
~params:(List.map (map_fst (map_opt (map_loc sub))) ptype_params)
|
2013-03-08 06:59:45 -08:00
|
|
|
~priv:ptype_private
|
|
|
|
~cstrs:(List.map (map_tuple3 (sub # typ) (sub # typ) (sub # location)) ptype_cstrs)
|
|
|
|
~kind:(sub # type_kind ptype_kind)
|
|
|
|
?manifest:(map_opt (sub # typ) ptype_manifest)
|
|
|
|
~loc:(sub # location ptype_loc)
|
|
|
|
~attrs:(sub # attributes ptype_attributes)
|
2013-03-04 07:35:47 -08:00
|
|
|
|
2012-09-18 08:55:30 -07:00
|
|
|
let map_type_kind sub = function
|
|
|
|
| Ptype_abstract -> Ptype_abstract
|
2013-03-06 05:51:18 -08:00
|
|
|
| Ptype_variant l -> Ptype_variant (List.map (sub # constructor_declaration) l)
|
|
|
|
| Ptype_record l -> Ptype_record (List.map (sub # label_declaration) l)
|
2012-09-18 08:55:30 -07:00
|
|
|
end
|
|
|
|
|
|
|
|
module CT = struct
|
|
|
|
(* Type expressions for the class language *)
|
|
|
|
|
|
|
|
let map sub {pcty_loc = loc; pcty_desc = desc} =
|
2013-03-08 06:59:45 -08:00
|
|
|
let open Cty in
|
2013-01-07 06:13:01 -08:00
|
|
|
let loc = sub # location loc in
|
2012-09-18 08:55:30 -07:00
|
|
|
match desc with
|
2013-01-07 06:13:01 -08:00
|
|
|
| Pcty_constr (lid, tys) -> constr ~loc (map_loc sub lid) (List.map (sub # typ) tys)
|
2012-09-18 08:55:30 -07:00
|
|
|
| Pcty_signature x -> signature ~loc (sub # class_signature x)
|
|
|
|
| Pcty_fun (lab, t, ct) ->
|
|
|
|
fun_ ~loc lab
|
|
|
|
(sub # typ t)
|
|
|
|
(sub # class_type ct)
|
|
|
|
|
|
|
|
let map_field sub {pctf_desc = desc; pctf_loc = loc} =
|
2013-03-08 06:59:45 -08:00
|
|
|
let open Ctf in
|
2013-01-07 06:13:01 -08:00
|
|
|
let loc = sub # location loc in
|
2012-09-18 08:55:30 -07:00
|
|
|
match desc with
|
|
|
|
| Pctf_inher ct -> inher ~loc (sub # class_type ct)
|
|
|
|
| Pctf_val (s, m, v, t) -> val_ ~loc s m v (sub # typ t)
|
|
|
|
| Pctf_virt (s, p, t) -> virt ~loc s p (sub # typ t)
|
|
|
|
| Pctf_meth (s, p, t) -> meth ~loc s p (sub # typ t)
|
|
|
|
| Pctf_cstr (t1, t2) -> cstr ~loc (sub # typ t1) (sub # typ t2)
|
|
|
|
|
|
|
|
let map_signature sub {pcsig_self; pcsig_fields; pcsig_loc} =
|
2013-03-08 06:59:45 -08:00
|
|
|
Csig.mk
|
|
|
|
(sub # typ pcsig_self)
|
|
|
|
(List.map (sub # class_type_field) pcsig_fields)
|
|
|
|
~loc:(sub # location pcsig_loc)
|
2012-09-18 08:55:30 -07:00
|
|
|
end
|
|
|
|
|
|
|
|
module MT = struct
|
|
|
|
(* Type expressions for the module language *)
|
|
|
|
|
2013-03-08 06:59:45 -08:00
|
|
|
let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} =
|
|
|
|
let open Mty in
|
2013-01-07 06:13:01 -08:00
|
|
|
let loc = sub # location loc in
|
2013-03-08 06:59:45 -08:00
|
|
|
let attrs = sub # attributes attrs in
|
2012-09-18 08:55:30 -07:00
|
|
|
match desc with
|
2013-03-08 06:59:45 -08:00
|
|
|
| Pmty_ident s -> ident ~loc ~attrs (map_loc sub s)
|
|
|
|
| Pmty_signature sg -> signature ~loc ~attrs (sub # signature sg)
|
|
|
|
| Pmty_functor (s, mt1, mt2) -> functor_ ~loc ~attrs (map_loc sub s) (sub # module_type mt1) (sub # module_type mt2)
|
|
|
|
| Pmty_with (mt, l) -> with_ ~loc ~attrs (sub # module_type mt) (List.map (map_tuple (map_loc sub) (sub # with_constraint)) l)
|
|
|
|
| Pmty_typeof me -> typeof_ ~loc ~attrs (sub # module_expr me)
|
|
|
|
| Pmty_extension x -> extension ~loc ~attrs (sub # extension x)
|
2012-09-18 08:55:30 -07:00
|
|
|
|
|
|
|
let map_with_constraint sub = function
|
|
|
|
| Pwith_type d -> Pwith_type (sub # type_declaration d)
|
2013-01-07 06:13:01 -08:00
|
|
|
| Pwith_module s -> Pwith_module (map_loc sub s)
|
2012-09-18 08:55:30 -07:00
|
|
|
| Pwith_typesubst d -> Pwith_typesubst (sub # type_declaration d)
|
2013-01-07 06:13:01 -08:00
|
|
|
| Pwith_modsubst s -> Pwith_modsubst (map_loc sub s)
|
2012-09-18 08:55:30 -07:00
|
|
|
|
|
|
|
let map_signature_item sub {psig_desc = desc; psig_loc = loc} =
|
2013-03-08 06:59:45 -08:00
|
|
|
let open Sig in
|
2013-01-07 06:13:01 -08:00
|
|
|
let loc = sub # location loc in
|
2012-09-18 08:55:30 -07:00
|
|
|
match desc with
|
2013-03-06 04:00:18 -08:00
|
|
|
| Psig_value vd -> value ~loc (sub # value_description vd)
|
2013-03-06 03:47:59 -08:00
|
|
|
| Psig_type l -> type_ ~loc (List.map (sub # type_declaration) l)
|
2013-03-25 08:49:10 -07:00
|
|
|
| Psig_exception ed -> exception_ ~loc (sub # constructor_declaration ed)
|
2013-03-04 09:39:07 -08:00
|
|
|
| Psig_module x -> module_ ~loc (sub # module_declaration x)
|
|
|
|
| Psig_recmodule l -> rec_module ~loc (List.map (sub # module_declaration) l)
|
2013-03-06 04:14:02 -08:00
|
|
|
| Psig_modtype x -> modtype ~loc (sub # module_type_declaration x)
|
2013-03-08 06:59:45 -08:00
|
|
|
| Psig_open (lid, attrs) -> open_ ~loc ~attrs:(sub # attributes attrs) (map_loc sub lid)
|
|
|
|
| Psig_include (mt, attrs) -> include_ ~loc (sub # module_type mt) ~attrs:(sub # attributes attrs)
|
2012-09-18 08:55:30 -07:00
|
|
|
| Psig_class l -> class_ ~loc (List.map (sub # class_description) l)
|
|
|
|
| Psig_class_type l -> class_type ~loc (List.map (sub # class_type_declaration) l)
|
2013-03-08 06:59:45 -08:00
|
|
|
| Psig_extension (x, attrs) -> extension ~loc (sub # extension x) ~attrs:(sub # attributes attrs)
|
2013-03-06 04:27:32 -08:00
|
|
|
| Psig_attribute x -> attribute ~loc (sub # attribute x)
|
2012-09-18 08:55:30 -07:00
|
|
|
end
|
|
|
|
|
|
|
|
|
|
|
|
module M = struct
|
|
|
|
(* Value expressions for the module language *)
|
|
|
|
|
2013-03-08 06:59:45 -08:00
|
|
|
let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} =
|
|
|
|
let open Mod in
|
2013-01-07 06:13:01 -08:00
|
|
|
let loc = sub # location loc in
|
2013-03-08 06:59:45 -08:00
|
|
|
let attrs = sub # attributes attrs in
|
2012-09-18 08:55:30 -07:00
|
|
|
match desc with
|
2013-03-08 06:59:45 -08:00
|
|
|
| Pmod_ident x -> ident ~loc ~attrs (map_loc sub x)
|
|
|
|
| Pmod_structure str -> structure ~loc ~attrs (sub # structure str)
|
|
|
|
| Pmod_functor (arg, arg_ty, body) -> functor_ ~loc ~attrs (map_loc sub arg) (sub # module_type arg_ty) (sub # module_expr body)
|
|
|
|
| Pmod_apply (m1, m2) -> apply ~loc ~attrs (sub # module_expr m1) (sub # module_expr m2)
|
|
|
|
| Pmod_constraint (m, mty) -> constraint_ ~loc ~attrs (sub # module_expr m) (sub # module_type mty)
|
|
|
|
| Pmod_unpack e -> unpack ~loc ~attrs (sub # expr e)
|
|
|
|
| Pmod_extension x -> extension ~loc ~attrs (sub # extension x)
|
2012-09-18 08:55:30 -07:00
|
|
|
|
2013-03-01 04:44:04 -08:00
|
|
|
let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} =
|
2013-03-08 06:59:45 -08:00
|
|
|
let open Str in
|
2013-01-07 06:13:01 -08:00
|
|
|
let loc = sub # location loc in
|
2012-07-24 01:40:50 -07:00
|
|
|
match desc with
|
|
|
|
| Pstr_eval x -> eval ~loc (sub # expr x)
|
|
|
|
| Pstr_value (r, pel) -> value ~loc r (List.map (map_tuple (sub # pat) (sub # expr)) pel)
|
2013-03-06 04:00:18 -08:00
|
|
|
| Pstr_primitive vd -> primitive ~loc (sub # value_description vd)
|
2013-03-06 03:47:59 -08:00
|
|
|
| Pstr_type l -> type_ ~loc (List.map (sub # type_declaration) l)
|
2013-03-25 08:49:10 -07:00
|
|
|
| Pstr_exception ed -> exception_ ~loc (sub # constructor_declaration ed)
|
2013-03-08 06:59:45 -08:00
|
|
|
| Pstr_exn_rebind (s, lid, attrs) -> exn_rebind ~loc (map_loc sub s) (map_loc sub lid) ~attrs:(sub # attributes attrs)
|
2013-03-05 08:50:05 -08:00
|
|
|
| Pstr_module x -> module_ ~loc (sub # module_binding x)
|
|
|
|
| Pstr_recmodule l -> rec_module ~loc (List.map (sub # module_binding) l)
|
2013-03-06 02:49:44 -08:00
|
|
|
| Pstr_modtype x -> modtype ~loc (sub # module_type_binding x)
|
2013-03-08 06:59:45 -08:00
|
|
|
| Pstr_open (lid, attrs) -> open_ ~loc ~attrs:(sub # attributes attrs) (map_loc sub lid)
|
2012-07-24 01:40:50 -07:00
|
|
|
| Pstr_class l -> class_ ~loc (List.map (sub # class_declaration) l)
|
|
|
|
| Pstr_class_type l -> class_type ~loc (List.map (sub # class_type_declaration) l)
|
2013-03-08 06:59:45 -08:00
|
|
|
| Pstr_include (e, attrs) -> include_ ~loc (sub # module_expr e) ~attrs:(sub # attributes attrs)
|
|
|
|
| Pstr_extension (x, attrs) -> extension ~loc (sub # extension x) ~attrs:(sub # attributes attrs)
|
2013-03-06 04:27:32 -08:00
|
|
|
| Pstr_attribute x -> attribute ~loc (sub # attribute x)
|
2012-06-29 02:36:32 -07:00
|
|
|
end
|
|
|
|
|
|
|
|
module E = struct
|
2012-09-18 08:55:30 -07:00
|
|
|
(* Value expressions for the core language *)
|
2012-06-29 02:36:32 -07:00
|
|
|
|
2013-03-08 06:59:45 -08:00
|
|
|
let lid ?(loc = Location.none) ?attrs lid = Exp.ident ~loc ?attrs (mkloc (Longident.parse lid) loc)
|
|
|
|
let apply_nolabs ?loc ?attrs f el = Exp.apply ?loc ?attrs f (List.map (fun e -> ("", e)) el)
|
2013-03-26 04:17:17 -07:00
|
|
|
let strconst ?loc ?attrs x = Exp.constant ?loc ?attrs (Const_string (x, None))
|
2013-03-08 06:59:45 -08:00
|
|
|
|
|
|
|
let map sub {pexp_loc = loc; pexp_desc = desc; pexp_attributes = attrs} =
|
|
|
|
let open Exp in
|
2013-01-07 06:13:01 -08:00
|
|
|
let loc = sub # location loc in
|
2013-03-08 06:59:45 -08:00
|
|
|
let attrs = sub # attributes attrs in
|
2012-07-24 01:40:50 -07:00
|
|
|
match desc with
|
2013-03-08 06:59:45 -08:00
|
|
|
| Pexp_ident x -> ident ~loc ~attrs (map_loc sub x)
|
|
|
|
| Pexp_constant x -> constant ~loc ~attrs x
|
|
|
|
| Pexp_let (r, pel, e) -> let_ ~loc ~attrs r (List.map (map_tuple (sub # pat) (sub # expr)) pel) (sub # expr e)
|
|
|
|
| Pexp_function (lab, def, pel) -> function_ ~loc ~attrs lab (map_opt (sub # expr) def) (List.map (map_tuple (sub # pat) (sub # expr)) pel)
|
|
|
|
| Pexp_apply (e, l) -> apply ~loc ~attrs (sub # expr e) (List.map (map_snd (sub # expr)) l)
|
|
|
|
| Pexp_match (e, l) -> match_ ~loc ~attrs (sub # expr e) (List.map (map_tuple (sub # pat) (sub # expr)) l)
|
|
|
|
| Pexp_try (e, l) -> try_ ~loc ~attrs (sub # expr e) (List.map (map_tuple (sub # pat) (sub # expr)) l)
|
|
|
|
| Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub # expr) el)
|
|
|
|
| Pexp_construct (lid, arg, b) -> construct ~loc ~attrs (map_loc sub lid) (map_opt (sub # expr) arg) b
|
|
|
|
| Pexp_variant (lab, eo) -> variant ~loc ~attrs lab (map_opt (sub # expr) eo)
|
|
|
|
| Pexp_record (l, eo) -> record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub # expr)) l) (map_opt (sub # expr) eo)
|
|
|
|
| Pexp_field (e, lid) -> field ~loc ~attrs (sub # expr e) (map_loc sub lid)
|
|
|
|
| Pexp_setfield (e1, lid, e2) -> setfield ~loc ~attrs (sub # expr e1) (map_loc sub lid) (sub # expr e2)
|
|
|
|
| Pexp_array el -> array ~loc ~attrs (List.map (sub # expr) el)
|
|
|
|
| Pexp_ifthenelse (e1, e2, e3) -> ifthenelse ~loc ~attrs (sub # expr e1) (sub # expr e2) (map_opt (sub # expr) e3)
|
|
|
|
| Pexp_sequence (e1, e2) -> sequence ~loc ~attrs (sub # expr e1) (sub # expr e2)
|
|
|
|
| Pexp_while (e1, e2) -> while_ ~loc ~attrs (sub # expr e1) (sub # expr e2)
|
|
|
|
| Pexp_for (id, e1, e2, d, e3) -> for_ ~loc ~attrs (map_loc sub id) (sub # expr e1) (sub # expr e2) d (sub # expr e3)
|
|
|
|
| Pexp_constraint (e, t1, t2) -> constraint_ ~loc ~attrs (sub # expr e) (map_opt (sub # typ) t1) (map_opt (sub # typ) t2)
|
|
|
|
| Pexp_when (e1, e2) -> when_ ~loc ~attrs (sub # expr e1) (sub # expr e2)
|
|
|
|
| Pexp_send (e, s) -> send ~loc ~attrs (sub # expr e) s
|
|
|
|
| Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid)
|
|
|
|
| Pexp_setinstvar (s, e) -> setinstvar ~loc ~attrs (map_loc sub s) (sub # expr e)
|
|
|
|
| Pexp_override sel -> override ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub # expr)) sel)
|
|
|
|
| Pexp_letmodule (s, me, e) -> letmodule ~loc ~attrs (map_loc sub s) (sub # module_expr me) (sub # expr e)
|
|
|
|
| Pexp_assert e -> assert_ ~loc ~attrs (sub # expr e)
|
|
|
|
| Pexp_assertfalse -> assertfalse ~loc ~attrs ()
|
|
|
|
| Pexp_lazy e -> lazy_ ~loc ~attrs (sub # expr e)
|
|
|
|
| Pexp_poly (e, t) -> poly ~loc ~attrs (sub # expr e) (map_opt (sub # typ) t)
|
|
|
|
| Pexp_object cls -> object_ ~loc ~attrs (sub # class_structure cls)
|
|
|
|
| Pexp_newtype (s, e) -> newtype ~loc ~attrs s (sub # expr e)
|
|
|
|
| Pexp_pack me -> pack ~loc ~attrs (sub # module_expr me)
|
|
|
|
| Pexp_open (lid, e) -> open_ ~loc ~attrs (map_loc sub lid) (sub # expr e)
|
|
|
|
| Pexp_extension x -> extension ~loc ~attrs (sub # extension x)
|
2012-06-29 02:36:32 -07:00
|
|
|
end
|
|
|
|
|
2012-07-24 05:48:39 -07:00
|
|
|
module P = struct
|
|
|
|
(* Patterns *)
|
|
|
|
|
2013-03-08 06:59:45 -08:00
|
|
|
let map sub {ppat_desc = desc; ppat_loc = loc; ppat_attributes = attrs} =
|
|
|
|
let open Pat in
|
2013-01-07 06:13:01 -08:00
|
|
|
let loc = sub # location loc in
|
2013-03-08 06:59:45 -08:00
|
|
|
let attrs = sub # attributes attrs in
|
2012-07-24 01:40:50 -07:00
|
|
|
match desc with
|
2013-03-08 06:59:45 -08:00
|
|
|
| Ppat_any -> any ~loc ~attrs ()
|
|
|
|
| Ppat_var s -> var ~loc ~attrs (map_loc sub s)
|
|
|
|
| Ppat_alias (p, s) -> alias ~loc ~attrs (sub # pat p) (map_loc sub s)
|
|
|
|
| Ppat_constant c -> constant ~loc ~attrs c
|
|
|
|
| Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub # pat) pl)
|
|
|
|
| Ppat_construct (l, p, b) -> construct ~loc ~attrs (map_loc sub l) (map_opt (sub # pat) p) b
|
|
|
|
| Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub # pat) p)
|
2012-09-18 08:55:30 -07:00
|
|
|
| Ppat_record (lpl, cf) ->
|
2013-03-08 06:59:45 -08:00
|
|
|
record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub # pat)) lpl) cf
|
|
|
|
| Ppat_array pl -> array ~loc ~attrs (List.map (sub # pat) pl)
|
|
|
|
| Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub # pat p1) (sub # pat p2)
|
|
|
|
| Ppat_constraint (p, t) -> constraint_ ~loc ~attrs (sub # pat p) (sub # typ t)
|
|
|
|
| Ppat_type s -> type_ ~loc ~attrs (map_loc sub s)
|
|
|
|
| Ppat_lazy p -> lazy_ ~loc ~attrs (sub # pat p)
|
|
|
|
| Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s)
|
|
|
|
| Ppat_extension x -> extension ~loc ~attrs (sub # extension x)
|
2012-06-29 02:36:32 -07:00
|
|
|
end
|
|
|
|
|
2012-09-18 08:55:30 -07:00
|
|
|
module CE = struct
|
|
|
|
(* Value expressions for the class language *)
|
2012-06-29 02:36:32 -07:00
|
|
|
|
2012-09-18 08:55:30 -07:00
|
|
|
let map sub {pcl_loc = loc; pcl_desc = desc} =
|
2013-03-08 06:59:45 -08:00
|
|
|
let open Cl in
|
2013-01-07 06:13:01 -08:00
|
|
|
let loc = sub # location loc in
|
2012-09-18 08:55:30 -07:00
|
|
|
match desc with
|
2013-01-07 06:13:01 -08:00
|
|
|
| Pcl_constr (lid, tys) -> constr ~loc (map_loc sub lid) (List.map (sub # typ) tys)
|
2012-09-18 08:55:30 -07:00
|
|
|
| Pcl_structure s ->
|
|
|
|
structure ~loc (sub # class_structure s)
|
|
|
|
| Pcl_fun (lab, e, p, ce) ->
|
|
|
|
fun_ ~loc lab
|
|
|
|
(map_opt (sub # expr) e)
|
|
|
|
(sub # pat p)
|
|
|
|
(sub # class_expr ce)
|
|
|
|
| Pcl_apply (ce, l) ->
|
|
|
|
apply ~loc (sub # class_expr ce) (List.map (map_snd (sub # expr)) l)
|
|
|
|
| Pcl_let (r, pel, ce) ->
|
|
|
|
let_ ~loc r
|
|
|
|
(List.map (map_tuple (sub # pat) (sub # expr)) pel)
|
|
|
|
(sub # class_expr ce)
|
|
|
|
| Pcl_constraint (ce, ct) ->
|
|
|
|
constraint_ ~loc (sub # class_expr ce) (sub # class_type ct)
|
|
|
|
|
|
|
|
|
|
|
|
let map_field sub {pcf_desc = desc; pcf_loc = loc} =
|
2013-03-08 06:59:45 -08:00
|
|
|
let open Cf in
|
2013-01-07 06:13:01 -08:00
|
|
|
let loc = sub # location loc in
|
2012-09-18 08:55:30 -07:00
|
|
|
match desc with
|
|
|
|
| Pcf_inher (o, ce, s) -> inher ~loc o (sub # class_expr ce) s
|
2013-01-07 06:13:01 -08:00
|
|
|
| Pcf_valvirt (s, m, t) -> valvirt ~loc (map_loc sub s) m (sub # typ t)
|
|
|
|
| Pcf_val (s, m, o, e) -> val_ ~loc (map_loc sub s) m o (sub # expr e)
|
|
|
|
| Pcf_virt (s, p, t) -> virt ~loc (map_loc sub s) p (sub # typ t)
|
|
|
|
| Pcf_meth (s, p, o, e) -> meth ~loc (map_loc sub s) p o (sub # expr e)
|
2012-09-18 08:55:30 -07:00
|
|
|
| Pcf_constr (t1, t2) -> constr ~loc (sub # typ t1) (sub # typ t2)
|
|
|
|
| Pcf_init e -> init ~loc (sub # expr e)
|
|
|
|
|
|
|
|
let map_structure sub {pcstr_pat; pcstr_fields} =
|
|
|
|
{
|
|
|
|
pcstr_pat = sub # pat pcstr_pat;
|
|
|
|
pcstr_fields = List.map (sub # class_field) pcstr_fields;
|
|
|
|
}
|
2013-01-07 06:13:01 -08:00
|
|
|
|
2013-04-02 08:33:35 -07:00
|
|
|
let class_infos sub f {pci_virt; pci_params = (pl, ploc); pci_name; pci_expr; pci_loc; pci_attributes} =
|
2013-03-08 06:59:45 -08:00
|
|
|
Ci.mk
|
|
|
|
~virt:pci_virt
|
2013-04-02 08:33:35 -07:00
|
|
|
~params:(List.map (map_fst (map_loc sub)) pl, sub # location ploc)
|
2013-03-08 06:59:45 -08:00
|
|
|
(map_loc sub pci_name)
|
|
|
|
(f pci_expr)
|
|
|
|
~loc:(sub # location pci_loc)
|
|
|
|
~attrs:(sub # attributes pci_attributes)
|
2012-09-18 08:55:30 -07:00
|
|
|
end
|
2012-07-24 01:40:50 -07:00
|
|
|
|
2012-06-29 02:36:32 -07:00
|
|
|
(* Now, a generic AST mapper class, to be extended to cover all kinds
|
|
|
|
and cases of the OCaml grammar. The default behavior of the mapper
|
|
|
|
is the identity. *)
|
|
|
|
|
2013-01-16 08:10:29 -08:00
|
|
|
class mapper =
|
2012-06-29 02:36:32 -07:00
|
|
|
object(this)
|
2012-07-24 01:40:50 -07:00
|
|
|
method implementation (input_name : string) ast = (input_name, this # structure ast)
|
|
|
|
method interface (input_name: string) ast = (input_name, this # signature ast)
|
2013-03-01 04:44:04 -08:00
|
|
|
method structure l = List.map (this # structure_item) l
|
|
|
|
method structure_item si = M.map_structure_item this si
|
2012-07-24 01:40:50 -07:00
|
|
|
method module_expr = M.map this
|
|
|
|
|
2013-03-01 04:44:04 -08:00
|
|
|
method signature l = List.map (this # signature_item) l
|
|
|
|
method signature_item si = MT.map_signature_item this si
|
2012-09-18 08:55:30 -07:00
|
|
|
method module_type = MT.map this
|
|
|
|
method with_constraint c = MT.map_with_constraint this c
|
|
|
|
|
2013-01-07 06:13:01 -08:00
|
|
|
method class_declaration = CE.class_infos this (this # class_expr)
|
2012-09-18 08:55:30 -07:00
|
|
|
method class_expr = CE.map this
|
|
|
|
method class_field = CE.map_field this
|
|
|
|
method class_structure = CE.map_structure this
|
|
|
|
|
|
|
|
method class_type = CT.map this
|
|
|
|
method class_type_field = CT.map_field this
|
|
|
|
method class_signature = CT.map_signature this
|
|
|
|
|
2013-01-07 06:13:01 -08:00
|
|
|
method class_type_declaration = CE.class_infos this (this # class_type)
|
|
|
|
method class_description = CE.class_infos this (this # class_type)
|
2012-09-18 08:55:30 -07:00
|
|
|
|
|
|
|
method type_declaration = T.map_type_declaration this
|
|
|
|
method type_kind = T.map_type_kind this
|
2012-07-24 01:40:50 -07:00
|
|
|
method typ = T.map this
|
|
|
|
|
2013-03-06 04:00:18 -08:00
|
|
|
method value_description {pval_name; pval_type; pval_prim; pval_loc; pval_attributes} =
|
2013-03-08 06:59:45 -08:00
|
|
|
Val.mk
|
|
|
|
(map_loc this pval_name)
|
|
|
|
(this # typ pval_type)
|
|
|
|
~attrs:(this # attributes pval_attributes)
|
|
|
|
~loc:(this # location pval_loc)
|
|
|
|
~prim:pval_prim
|
|
|
|
|
2012-09-18 08:55:30 -07:00
|
|
|
method pat = P.map this
|
2012-07-24 01:40:50 -07:00
|
|
|
method expr = E.map this
|
2012-09-18 08:55:30 -07:00
|
|
|
|
2013-03-08 06:59:45 -08:00
|
|
|
method module_declaration {pmd_name; pmd_type; pmd_attributes} =
|
|
|
|
Md.mk
|
|
|
|
(map_loc this pmd_name)
|
|
|
|
(this # module_type pmd_type)
|
|
|
|
~attrs:(this # attributes pmd_attributes)
|
|
|
|
|
2013-03-06 04:14:02 -08:00
|
|
|
method module_type_declaration {pmtd_name; pmtd_type; pmtd_attributes} =
|
|
|
|
{
|
|
|
|
pmtd_name = map_loc this pmtd_name;
|
|
|
|
pmtd_type = map_opt (this # module_type) pmtd_type;
|
2013-03-08 06:59:45 -08:00
|
|
|
pmtd_attributes = this # attributes pmtd_attributes;
|
2013-03-06 02:49:44 -08:00
|
|
|
}
|
2013-01-07 06:13:01 -08:00
|
|
|
|
2013-03-08 06:59:45 -08:00
|
|
|
method module_binding {pmb_name; pmb_expr; pmb_attributes} =
|
|
|
|
Mb.mk (map_loc this pmb_name) (this # module_expr pmb_expr)
|
|
|
|
~attrs:(this # attributes pmb_attributes)
|
|
|
|
|
|
|
|
method module_type_binding {pmtb_name; pmtb_type; pmtb_attributes} =
|
|
|
|
Mtb.mk (map_loc this pmtb_name) (this # module_type pmtb_type)
|
|
|
|
~attrs:(this # attributes pmtb_attributes)
|
|
|
|
|
2013-03-06 05:51:18 -08:00
|
|
|
method constructor_declaration {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} =
|
2013-03-08 06:59:45 -08:00
|
|
|
Cd.mk
|
2013-03-06 05:51:18 -08:00
|
|
|
(map_loc this pcd_name)
|
2013-03-08 06:59:45 -08:00
|
|
|
~args:(List.map (this # typ) pcd_args)
|
2013-03-06 05:51:18 -08:00
|
|
|
?res:(map_opt (this # typ) pcd_res)
|
|
|
|
~loc:(this # location pcd_loc)
|
2013-03-08 06:59:45 -08:00
|
|
|
~attrs:(this # attributes pcd_attributes)
|
2013-03-06 05:51:18 -08:00
|
|
|
|
|
|
|
method label_declaration {pld_name; pld_type; pld_loc; pld_mutable; pld_attributes} =
|
2013-03-08 06:59:45 -08:00
|
|
|
Ld.mk
|
2013-03-06 05:51:18 -08:00
|
|
|
(map_loc this pld_name)
|
|
|
|
(this # typ pld_type)
|
|
|
|
~mut:pld_mutable
|
|
|
|
~loc:(this # location pld_loc)
|
2013-03-08 06:59:45 -08:00
|
|
|
~attrs:(this # attributes pld_attributes)
|
2013-03-06 05:51:18 -08:00
|
|
|
|
|
|
|
|
2013-01-07 06:13:01 -08:00
|
|
|
method location l = l
|
2013-03-01 04:44:04 -08:00
|
|
|
|
|
|
|
method extension (s, e) = (s, this # expr e)
|
|
|
|
method attribute (s, e) = (s, this # expr e)
|
2013-03-08 06:59:45 -08:00
|
|
|
method attributes l = List.map (this # attribute) l
|
2012-06-29 02:36:32 -07:00
|
|
|
end
|
2012-07-24 05:48:39 -07:00
|
|
|
|
2013-01-23 01:15:41 -08:00
|
|
|
class type main_entry_points =
|
|
|
|
object
|
|
|
|
method implementation: string -> structure -> string * structure
|
|
|
|
method interface: string -> signature -> string * signature
|
|
|
|
end
|
2012-07-24 05:48:39 -07:00
|
|
|
|
2013-01-16 08:10:29 -08:00
|
|
|
let apply ~source ~target mapper =
|
|
|
|
let ic = open_in_bin source in
|
|
|
|
let magic = String.create (String.length ast_impl_magic_number) in
|
|
|
|
really_input ic magic 0 (String.length magic);
|
|
|
|
if magic <> ast_impl_magic_number && magic <> ast_intf_magic_number then
|
|
|
|
failwith "Bad magic";
|
|
|
|
let input_name = input_value ic in
|
|
|
|
let ast = input_value ic in
|
|
|
|
close_in ic;
|
|
|
|
|
|
|
|
let (input_name, ast) =
|
|
|
|
if magic = ast_impl_magic_number
|
|
|
|
then Obj.magic (mapper # implementation input_name (Obj.magic ast))
|
|
|
|
else Obj.magic (mapper # interface input_name (Obj.magic ast))
|
|
|
|
in
|
|
|
|
let oc = open_out_bin target in
|
|
|
|
output_string oc magic;
|
|
|
|
output_value oc input_name;
|
|
|
|
output_value oc ast;
|
|
|
|
close_out oc
|
|
|
|
|
2013-01-23 01:15:41 -08:00
|
|
|
let run_main mapper =
|
2013-01-16 08:10:29 -08:00
|
|
|
try
|
2013-01-23 01:15:41 -08:00
|
|
|
let a = Sys.argv in
|
|
|
|
let n = Array.length a in
|
2013-01-23 00:37:01 -08:00
|
|
|
if n > 2 then
|
2013-01-23 01:15:41 -08:00
|
|
|
apply ~source:a.(n - 2) ~target:a.(n - 1) (mapper (Array.to_list (Array.sub a 1 (n - 3))))
|
2013-01-16 08:10:29 -08:00
|
|
|
else begin
|
2013-01-23 02:15:45 -08:00
|
|
|
Printf.eprintf "Usage: %s [extra_args] <infile> <outfile>\n%!" Sys.executable_name;
|
2013-01-16 08:10:29 -08:00
|
|
|
exit 1
|
|
|
|
end
|
|
|
|
with exn ->
|
|
|
|
prerr_endline (Printexc.to_string exn);
|
|
|
|
exit 2
|
2012-07-24 05:48:39 -07:00
|
|
|
|
2013-01-23 01:15:41 -08:00
|
|
|
let main mapper = run_main (fun _ -> mapper)
|
|
|
|
|
2013-01-23 02:15:45 -08:00
|
|
|
let register_function = ref (fun _name f -> run_main f)
|
|
|
|
let register name f = !register_function name (f :> string list -> mapper)
|