From 2a1e4acd43ebe54389d9e3b9a032a5691fcfc519 Mon Sep 17 00:00:00 2001 From: Anil Madhavapeddy Date: Sat, 6 Jun 2020 11:36:54 +0100 Subject: [PATCH 1/2] build under OCaml 4.08, 4.09, 4.10 and 4.11 from one repo This switches the repository to be buildable using multiple versions of OCaml, in a manner similar to that used by Merlin and other compiler-dependent tools. As a result, we can release a single ppx_tools package for multiple compiler versions. This in turn makes it much easier to use ppx_tools in dune monorepos, which makes life easier for benchmarking systems such as Sandmark used in multicore OCaml. --- .travis.yml | 5 +- 408/ast_convenience.ml | 122 ++++ 408/ast_convenience.mli | 110 +++ 408/ast_mapper_class.ml | 652 +++++++++++++++++ 408/ast_mapper_class.mli | 60 ++ dumpast.ml => 408/dumpast.ml | 0 408/genlifter.ml | 234 +++++++ 408/ppx_metaquot.ml | 288 ++++++++ .../ppx_metaquot_main.ml | 0 rewriter.ml => 408/rewriter.ml | 0 410/ast_convenience.ml | 122 ++++ 410/ast_convenience.mli | 110 +++ 410/ast_mapper_class.ml | 656 ++++++++++++++++++ 410/ast_mapper_class.mli | 60 ++ 410/dumpast.ml | 121 ++++ 410/genlifter.ml | 234 +++++++ 410/ppx_metaquot.ml | 288 ++++++++ 410/ppx_metaquot_main.ml | 1 + 410/rewriter.ml | 106 +++ ast_convenience.ml => 411/ast_convenience.ml | 0 .../ast_convenience.mli | 0 .../ast_mapper_class.ml | 0 .../ast_mapper_class.mli | 0 411/dumpast.ml | 121 ++++ genlifter.ml => 411/genlifter.ml | 0 ppx_metaquot.ml => 411/ppx_metaquot.ml | 0 411/ppx_metaquot_main.ml | 1 + 411/rewriter.ml | 106 +++ dune | 15 + dune-workspace.dev | 3 +- ppx_tools.opam | 2 +- 31 files changed, 3414 insertions(+), 3 deletions(-) create mode 100644 408/ast_convenience.ml create mode 100644 408/ast_convenience.mli create mode 100644 408/ast_mapper_class.ml create mode 100644 408/ast_mapper_class.mli rename dumpast.ml => 408/dumpast.ml (100%) create mode 100644 408/genlifter.ml create mode 100644 408/ppx_metaquot.ml rename ppx_metaquot_main.ml => 408/ppx_metaquot_main.ml (100%) rename rewriter.ml => 408/rewriter.ml (100%) create mode 100644 410/ast_convenience.ml create mode 100644 410/ast_convenience.mli create mode 100644 410/ast_mapper_class.ml create mode 100644 410/ast_mapper_class.mli create mode 100644 410/dumpast.ml create mode 100644 410/genlifter.ml create mode 100644 410/ppx_metaquot.ml create mode 100644 410/ppx_metaquot_main.ml create mode 100644 410/rewriter.ml rename ast_convenience.ml => 411/ast_convenience.ml (100%) rename ast_convenience.mli => 411/ast_convenience.mli (100%) rename ast_mapper_class.ml => 411/ast_mapper_class.ml (100%) rename ast_mapper_class.mli => 411/ast_mapper_class.mli (100%) create mode 100644 411/dumpast.ml rename genlifter.ml => 411/genlifter.ml (100%) rename ppx_metaquot.ml => 411/ppx_metaquot.ml (100%) create mode 100644 411/ppx_metaquot_main.ml create mode 100644 411/rewriter.ml diff --git a/.travis.yml b/.travis.yml index 5665030..1292116 100644 --- a/.travis.yml +++ b/.travis.yml @@ -9,4 +9,7 @@ env: - PACKAGE="ppx_tools" - PRE_INSTALL_HOOK="cd /home/opam/opam-repository && git pull origin master && opam update -u -y" matrix: - - DISTRO=ubuntu-16.04 OCAML_VERSION=4.11.0+trunk OCAML_BETA=enable + - DISTRO=ubuntu-lts OCAML_VERSION=4.11.0+trunk OCAML_BETA=enable + - DISTRO=ubuntu-lts OCAML_VERSION=4.10.0 + - DISTRO=ubuntu-lts OCAML_VERSION=4.09.1 + - DISTRO=ubuntu-lts OCAML_VERSION=4.08.1 diff --git a/408/ast_convenience.ml b/408/ast_convenience.ml new file mode 100644 index 0000000..62dc655 --- /dev/null +++ b/408/ast_convenience.ml @@ -0,0 +1,122 @@ +(* This file is part of the ppx_tools package. It is released *) +(* under the terms of the MIT license (see LICENSE file). *) +(* Copyright 2013 Alain Frisch and LexiFi *) + +open Parsetree +open Asttypes +open Location +open Ast_helper + + +module Label = struct + + type t = Asttypes.arg_label + + type desc = Asttypes.arg_label = + Nolabel + | Labelled of string + | Optional of string + + let explode x = x + + let nolabel = Nolabel + let labelled x = Labelled x + let optional x = Optional x + +end + +module Constant = struct + type t = Parsetree.constant = + Pconst_integer of string * char option + | Pconst_char of char + | Pconst_string of string * string option + | Pconst_float of string * char option + + let of_constant x = x + + let to_constant x = x + +end + +let may_tuple ?loc tup = function + | [] -> None + | [x] -> Some x + | l -> Some (tup ?loc ?attrs:None l) + +let lid ?(loc = !default_loc) s = mkloc (Longident.parse s) loc +let constr ?loc ?attrs s args = Exp.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Exp.tuple args) +let nil ?loc ?attrs () = constr ?loc ?attrs "[]" [] +let unit ?loc ?attrs () = constr ?loc ?attrs "()" [] +let tuple ?loc ?attrs = function + | [] -> unit ?loc ?attrs () + | [x] -> x + | xs -> Exp.tuple ?loc ?attrs xs +let cons ?loc ?attrs hd tl = constr ?loc ?attrs "::" [hd; tl] +let list ?loc ?attrs l = List.fold_right (cons ?loc ?attrs) l (nil ?loc ?attrs ()) +let str ?loc ?attrs s = Exp.constant ?loc ?attrs (Pconst_string (s, None)) +let int ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (string_of_int x, None)) +let int32 ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (Int32.to_string x, Some 'l')) +let int64 ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (Int64.to_string x, Some 'L')) +let char ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_char x) +let float ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_float (string_of_float x, None)) +let record ?loc ?attrs ?over l = + Exp.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.pexp_loc s, e)) l) over +let func ?loc ?attrs l = Exp.function_ ?loc ?attrs (List.map (fun (p, e) -> Exp.case p e) l) +let lam ?loc ?attrs ?(label = Label.nolabel) ?default pat exp = Exp.fun_ ?loc ?attrs label default pat exp +let app ?loc ?attrs f l = if l = [] then f else Exp.apply ?loc ?attrs f (List.map (fun a -> Label.nolabel, a) l) +let evar ?loc ?attrs s = Exp.ident ?loc ?attrs (lid ?loc s) +let let_in ?loc ?attrs ?(recursive = false) b body = + Exp.let_ ?loc ?attrs (if recursive then Recursive else Nonrecursive) b body + +let sequence ?loc ?attrs = function + | [] -> unit ?loc ?attrs () + | hd :: tl -> List.fold_left (fun e1 e2 -> Exp.sequence ?loc ?attrs e1 e2) hd tl + +let pvar ?(loc = !default_loc) ?attrs s = Pat.var ~loc ?attrs (mkloc s loc) +let pconstr ?loc ?attrs s args = Pat.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Pat.tuple args) +let precord ?loc ?attrs ?(closed = Open) l = + Pat.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.ppat_loc s, e)) l) closed +let pnil ?loc ?attrs () = pconstr ?loc ?attrs "[]" [] +let pcons ?loc ?attrs hd tl = pconstr ?loc ?attrs "::" [hd; tl] +let punit ?loc ?attrs () = pconstr ?loc ?attrs "()" [] +let ptuple ?loc ?attrs = function + | [] -> punit ?loc ?attrs () + | [x] -> x + | xs -> Pat.tuple ?loc ?attrs xs +let plist ?loc ?attrs l = List.fold_right (pcons ?loc ?attrs) l (pnil ?loc ?attrs ()) + +let pstr ?loc ?attrs s = Pat.constant ?loc ?attrs (Pconst_string (s, None)) +let pint ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_integer (string_of_int x, None)) +let pchar ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_char x) +let pfloat ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_float (string_of_float x, None)) + +let tconstr ?loc ?attrs c l = Typ.constr ?loc ?attrs (lid ?loc c) l + +let get_str = function + | {pexp_desc=Pexp_constant (Pconst_string (s, _)); _} -> Some s + | _ -> None + +let get_str_with_quotation_delimiter = function + | {pexp_desc=Pexp_constant (Pconst_string (s, d)); _} -> Some (s, d) + | _ -> None + +let get_lid = function + | {pexp_desc=Pexp_ident{txt=id;_};_} -> + Some (String.concat "." (Longident.flatten id)) + | _ -> None + +let find_attr s attrs = + try Some ((List.find (fun {attr_name=x;_} -> x.txt = s) attrs).attr_payload) + with Not_found -> None + +let expr_of_payload = function + | PStr [{pstr_desc=Pstr_eval(e, _); _}] -> Some e + | _ -> None + +let find_attr_expr s attrs = + match find_attr s attrs with + | Some e -> expr_of_payload e + | None -> None + +let has_attr s attrs = + find_attr s attrs <> None diff --git a/408/ast_convenience.mli b/408/ast_convenience.mli new file mode 100644 index 0000000..3ac31fd --- /dev/null +++ b/408/ast_convenience.mli @@ -0,0 +1,110 @@ +(* This file is part of the ppx_tools package. It is released *) +(* under the terms of the MIT license (see LICENSE file). *) +(* Copyright 2013 Alain Frisch and LexiFi *) + +(** {1 Convenience functions to help build and deconstruct AST fragments.} *) + +open Asttypes +open Ast_helper +open Parsetree + +(** {2 Compatibility modules} *) + +module Label : sig + type t = Asttypes.arg_label + + type desc = Asttypes.arg_label = + Nolabel + | Labelled of string + | Optional of string + + val explode : t -> desc + + val nolabel : t + val labelled : string -> t + val optional : string -> t + +end + +(** {2 Provides a unified abstraction over differences in Parsetree.constant and Asttypes.constant + * types defined in ocaml 4.03 and 4.02 respectively}*) +module Constant : sig + type t = Parsetree.constant = + Pconst_integer of string * char option + | Pconst_char of char + | Pconst_string of string * string option + | Pconst_float of string * char option + + (** Convert Asttypes.constant to Constant.t *) + val of_constant : Parsetree.constant -> t + + (** Convert Constant.t to Asttypes.constant *) + val to_constant : t -> Parsetree.constant + +end + +(** {2 Misc} *) + +val lid: ?loc:loc -> string -> lid + +(** {2 Expressions} *) + +val evar: ?loc:loc -> ?attrs:attrs -> string -> expression +val let_in: ?loc:loc -> ?attrs:attrs -> ?recursive:bool -> value_binding list -> expression -> expression + +val constr: ?loc:loc -> ?attrs:attrs -> string -> expression list -> expression +val record: ?loc:loc -> ?attrs:attrs -> ?over:expression -> (string * expression) list -> expression +val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression + +val nil: ?loc:loc -> ?attrs:attrs -> unit -> expression +val cons: ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression +val list: ?loc:loc -> ?attrs:attrs -> expression list -> expression + +val unit: ?loc:loc -> ?attrs:attrs -> unit -> expression + +val func: ?loc:loc -> ?attrs:attrs -> (pattern * expression) list -> expression +val lam: ?loc:loc -> ?attrs:attrs -> ?label:Label.t -> ?default:expression -> pattern -> expression -> expression +val app: ?loc:loc -> ?attrs:attrs -> expression -> expression list -> expression + +val str: ?loc:loc -> ?attrs:attrs -> string -> expression +val int: ?loc:loc -> ?attrs:attrs -> int -> expression +val int32: ?loc:loc -> ?attrs:attrs -> int32 -> expression +val int64: ?loc:loc -> ?attrs:attrs -> int64 -> expression +val char: ?loc:loc -> ?attrs:attrs -> char -> expression +val float: ?loc:loc -> ?attrs:attrs -> float -> expression + +val sequence: ?loc:loc -> ?attrs:attrs -> expression list -> expression +(** Return [()] if the list is empty. Tail rec. *) + +(** {2 Patterns} *) + +val pvar: ?loc:loc -> ?attrs:attrs -> string -> pattern +val pconstr: ?loc:loc -> ?attrs:attrs -> string -> pattern list -> pattern +val precord: ?loc:loc -> ?attrs:attrs -> ?closed:closed_flag -> (string * pattern) list -> pattern +val ptuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern + +val pnil: ?loc:loc -> ?attrs:attrs -> unit -> pattern +val pcons: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern +val plist: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern + +val pstr: ?loc:loc -> ?attrs:attrs -> string -> pattern +val pint: ?loc:loc -> ?attrs:attrs -> int -> pattern +val pchar: ?loc:loc -> ?attrs:attrs -> char -> pattern +val pfloat: ?loc:loc -> ?attrs:attrs -> float -> pattern + +val punit: ?loc:loc -> ?attrs:attrs -> unit -> pattern + + +(** {2 Types} *) + +val tconstr: ?loc:loc -> ?attrs:attrs -> string -> core_type list -> core_type + +(** {2 AST deconstruction} *) + +val get_str: expression -> string option +val get_str_with_quotation_delimiter: expression -> (string * string option) option +val get_lid: expression -> string option + +val has_attr: string -> attributes -> bool +val find_attr: string -> attributes -> payload option +val find_attr_expr: string -> attributes -> expression option diff --git a/408/ast_mapper_class.ml b/408/ast_mapper_class.ml new file mode 100644 index 0000000..60d8b72 --- /dev/null +++ b/408/ast_mapper_class.ml @@ -0,0 +1,652 @@ +(* This file is part of the ppx_tools package. It is released *) +(* under the terms of the MIT license (see LICENSE file). *) +(* Copyright 2013 Alain Frisch and LexiFi *) + +(** Class-based customizable mapper *) + +open Parsetree +open Asttypes +open Ast_helper + +let map_fst f (x, y) = (f x, y) +let map_snd f (x, y) = (x, f y) +let map_tuple f1 f2 (x, y) = (f1 x, f2 y) +let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) +let map_opt f = function None -> None | Some x -> Some (f x) + +let map_loc sub {loc; txt} = {loc = sub # location loc; txt} + +module T = struct + (* Type expressions for the core language *) + + let row_field_desc sub = function + | Rtag (l, b, tl) -> Rtag (l, b, List.map (sub # typ) tl) + | Rinherit t -> Rinherit (sub # typ t) + + let row_field sub {prf_desc = desc; prf_loc = loc; prf_attributes = attrs} = + let desc = row_field_desc sub desc in + let loc = sub # location loc in + let attrs = sub # attributes attrs in + {prf_desc = desc; prf_loc = loc; prf_attributes = attrs} + + let object_field_desc sub = function + | Otag (s, t) -> Otag (s, sub # typ t) + | Oinherit t -> Oinherit (sub # typ t) + + let object_field sub {pof_desc = desc; pof_loc = loc; pof_attributes = attrs} = + let desc = object_field_desc sub desc in + let loc = sub # location loc in + let attrs = sub # attributes attrs in + {pof_desc = desc; pof_loc = loc; pof_attributes = attrs} + + let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_loc_stack = _; ptyp_attributes = attrs} = + let open Typ in + let loc = sub # location loc in + let attrs = sub # attributes 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 (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) + | Ptyp_object (l, o) -> + object_ ~loc ~attrs (List.map (object_field sub) l) o + | Ptyp_class (lid, tl) -> + class_ ~loc ~attrs (map_loc sub lid) (List.map (sub # typ) tl) + | 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) + + let map_type_declaration sub + {ptype_name; ptype_params; ptype_cstrs; + ptype_kind; + ptype_private; + ptype_manifest; + ptype_attributes; + ptype_loc} = + Type.mk (map_loc sub ptype_name) + ~params:(List.map (map_fst (sub # typ)) ptype_params) + ~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) + + let map_type_kind sub = function + | Ptype_abstract -> Ptype_abstract + | Ptype_variant l -> + Ptype_variant (List.map (sub # constructor_declaration) l) + | Ptype_record l -> Ptype_record (List.map (sub # label_declaration) l) + | Ptype_open -> Ptype_open + + let map_type_extension sub + {ptyext_path; ptyext_params; + ptyext_constructors; + ptyext_private; + ptyext_loc; + ptyext_attributes} = + Te.mk + (map_loc sub ptyext_path) + (List.map (sub # extension_constructor) ptyext_constructors) + ~params:(List.map (map_fst (sub # typ)) ptyext_params) + ~priv:ptyext_private + ~loc:(sub # location ptyext_loc) + ~attrs:(sub # attributes ptyext_attributes) + + let map_extension_constructor_kind sub = function + Pext_decl(ctl, cto) -> + Pext_decl(sub # constructor_arguments ctl, map_opt (sub # typ) cto) + | Pext_rebind li -> + Pext_rebind (map_loc sub li) + + let map_extension_constructor sub + {pext_name; + pext_kind; + pext_loc; + pext_attributes} = + Te.constructor + (map_loc sub pext_name) + (map_extension_constructor_kind sub pext_kind) + ~loc:(sub # location pext_loc) + ~attrs:(sub # attributes pext_attributes) + + let map_type_exception sub {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} = + Te.mk_exception + (map_extension_constructor sub ptyexn_constructor) + ~loc:(sub # location ptyexn_loc) + ~attrs:(sub # attributes ptyexn_attributes) + +end + +module CT = struct + (* Type expressions for the class language *) + + let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = + let open Cty in + let loc = sub # location loc in + match desc with + | Pcty_constr (lid, tys) -> + constr ~loc ~attrs (map_loc sub lid) (List.map (sub # typ) tys) + | Pcty_signature x -> signature ~loc ~attrs (sub # class_signature x) + | Pcty_arrow (lab, t, ct) -> + arrow ~loc ~attrs lab (sub # typ t) (sub # class_type ct) + | Pcty_extension x -> extension ~loc ~attrs (sub # extension x) + | Pcty_open (od, ct) -> + open_ ~loc ~attrs (sub # open_description od) (sub # class_type ct) + + let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} + = + let open Ctf in + let loc = sub # location loc in + match desc with + | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub # class_type ct) + | Pctf_val (s, m, v, t) -> val_ ~loc ~attrs s m v (sub # typ t) + | Pctf_method (s, p, v, t) -> method_ ~loc ~attrs s p v (sub # typ t) + | Pctf_constraint (t1, t2) -> + constraint_ ~loc ~attrs (sub # typ t1) (sub # typ t2) + | Pctf_attribute x -> attribute ~loc (sub # attribute x) + | Pctf_extension x -> extension ~loc ~attrs (sub # extension x) + + let map_signature sub {pcsig_self; pcsig_fields} = + Csig.mk + (sub # typ pcsig_self) + (List.map (sub # class_type_field) pcsig_fields) +end + +module MT = struct + (* Type expressions for the module language *) + + let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = + let open Mty in + let loc = sub # location loc in + let attrs = sub # attributes attrs in + match desc with + | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) + | Pmty_alias s -> alias ~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) + (map_opt (sub # module_type) mt1) + (sub # module_type mt2) + | Pmty_with (mt, l) -> + with_ ~loc ~attrs (sub # module_type mt) + (List.map (sub # with_constraint) l) + | Pmty_typeof me -> typeof_ ~loc ~attrs (sub # module_expr me) + | Pmty_extension x -> extension ~loc ~attrs (sub # extension x) + + let map_with_constraint sub = function + | Pwith_type (lid, d) -> + Pwith_type (map_loc sub lid, sub # type_declaration d) + | Pwith_module (lid, lid2) -> + Pwith_module (map_loc sub lid, map_loc sub lid2) + | Pwith_typesubst (lid, d) -> + Pwith_typesubst (map_loc sub lid, sub # type_declaration d) + | Pwith_modsubst (lid, lid2) -> + Pwith_modsubst (map_loc sub lid, map_loc sub lid2) + + let map_signature_item sub {psig_desc = desc; psig_loc = loc} = + let open Sig in + let loc = sub # location loc in + match desc with + | Psig_value vd -> value ~loc (sub # value_description vd) + | Psig_type (rf, l) -> type_ ~loc rf (List.map (sub # type_declaration) l) + | Psig_typesubst l -> type_subst ~loc (List.map (sub # type_declaration) l) + | Psig_typext te -> type_extension ~loc (sub # type_extension te) + | Psig_exception texn -> exception_ ~loc (sub # type_exception texn) + | Psig_module x -> module_ ~loc (sub # module_declaration x) + | Psig_modsubst ms -> mod_subst ~loc (sub # module_substitution ms) + | Psig_recmodule l -> + rec_module ~loc (List.map (sub # module_declaration) l) + | Psig_modtype x -> modtype ~loc (sub # module_type_declaration x) + | Psig_open od -> open_ ~loc (sub # open_description od) + | Psig_include x -> include_ ~loc (sub # include_description x) + | 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) + | Psig_extension (x, attrs) -> + extension ~loc (sub # extension x) ~attrs:(sub # attributes attrs) + | Psig_attribute x -> attribute ~loc (sub # attribute x) +end + +module M = struct + (* Value expressions for the module language *) + + let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = + let open Mod in + let loc = sub # location loc in + let attrs = sub # attributes attrs in + match desc with + | 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) + (map_opt (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) + + let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = + let open Str in + let loc = sub # location loc in + match desc with + | Pstr_eval (x, attrs) -> + eval ~loc ~attrs:(sub # attributes attrs) (sub # expr x) + | Pstr_value (r, vbs) -> value ~loc r (List.map (sub # value_binding) vbs) + | Pstr_primitive vd -> primitive ~loc (sub # value_description vd) + | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub # type_declaration) l) + | Pstr_typext te -> type_extension ~loc (sub # type_extension te) + | Pstr_exception ed -> exception_ ~loc (sub # type_exception ed) + | Pstr_module x -> module_ ~loc (sub # module_binding x) + | Pstr_recmodule l -> rec_module ~loc (List.map (sub # module_binding) l) + | Pstr_modtype x -> modtype ~loc (sub # module_type_declaration x) + | Pstr_open od -> open_ ~loc (sub # open_declaration od) + | 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) + | Pstr_include x -> include_ ~loc (sub # include_declaration x) + | Pstr_extension (x, attrs) -> + extension ~loc (sub # extension x) ~attrs:(sub # attributes attrs) + | Pstr_attribute x -> attribute ~loc (sub # attribute x) +end + +module E = struct + (* Value expressions for the core language *) + + let map_binding_op sub {pbop_op = op; pbop_pat = pat; pbop_exp = exp; pbop_loc = loc} = + let op = map_loc sub op in + let pat = sub # pat pat in + let exp = sub # expr exp in + let loc = sub # location loc in + {pbop_op = op; pbop_pat = pat; pbop_exp = exp; pbop_loc = loc} + + let map sub {pexp_loc = loc; pexp_loc_stack = _; pexp_desc = desc; pexp_attributes = attrs} = + let open Exp in + let loc = sub # location loc in + let attrs = sub # attributes 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 (sub # value_binding) vbs) (sub # expr e) + | Pexp_fun (lab, def, p, e) -> + fun_ ~loc ~attrs lab (map_opt (sub # expr) def) (sub # pat p) + (sub # expr e) + | Pexp_function pel -> function_ ~loc ~attrs (sub # cases pel) + | Pexp_apply (e, l) -> + apply ~loc ~attrs (sub # expr e) (List.map (map_snd (sub # expr)) l) + | Pexp_match (e, pel) -> match_ ~loc ~attrs (sub # expr e) (sub # cases pel) + | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub # expr e) (sub # cases pel) + | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub # expr) el) + | Pexp_construct (lid, arg) -> + construct ~loc ~attrs (map_loc sub lid) (map_opt (sub # expr) arg) + | 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 (p, e1, e2, d, e3) -> + for_ ~loc ~attrs (sub # pat p) (sub # expr e1) (sub # expr e2) d + (sub # expr e3) + | Pexp_coerce (e, t1, t2) -> + coerce ~loc ~attrs (sub # expr e) (map_opt (sub # typ) t1) + (sub # typ t2) + | Pexp_constraint (e, t) -> + constraint_ ~loc ~attrs (sub # expr e) (sub # typ t) + | 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_letexception (cd, e) -> + letexception ~loc ~attrs + (sub # extension_constructor cd) + (sub # expr e) + | Pexp_assert e -> assert_ ~loc ~attrs (sub # expr e) + | 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 (od, e) -> + open_ ~loc ~attrs (sub # open_declaration od) (sub # expr e) + | Pexp_letop x -> + let let_ = map_binding_op sub x.let_ in + let ands = List.map (map_binding_op sub) x.ands in + let body = sub # expr x.body in + letop ~loc ~attrs let_ ands body + | Pexp_extension x -> extension ~loc ~attrs (sub # extension x) + | Pexp_unreachable -> unreachable ~loc ~attrs () +end + +module P = struct + (* Patterns *) + + let map sub {ppat_desc = desc; ppat_loc = loc; ppat_loc_stack = _; ppat_attributes = attrs} = + let open Pat in + let loc = sub # location loc in + let attrs = sub # attributes 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 (sub # pat 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 (sub # pat) pl) + | Ppat_construct (l, p) -> + construct ~loc ~attrs (map_loc sub l) (map_opt (sub # pat) p) + | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub # pat) p) + | Ppat_record (lpl, cf) -> + 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_exception p -> exception_ ~loc ~attrs (sub # pat p) + | Ppat_extension x -> extension ~loc ~attrs (sub # extension x) + | Ppat_open (l, p) -> open_ ~loc ~attrs (map_loc sub l) (sub # pat p) +end + +module CE = struct + (* Value expressions for the class language *) + + let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = + let open Cl in + let loc = sub # location loc in + match desc with + | Pcl_constr (lid, tys) -> + constr ~loc ~attrs (map_loc sub lid) (List.map (sub # typ) tys) + | Pcl_structure s -> + structure ~loc ~attrs (sub # class_structure s) + | Pcl_fun (lab, e, p, ce) -> + fun_ ~loc ~attrs lab + (map_opt (sub # expr) e) + (sub # pat p) + (sub # class_expr ce) + | Pcl_apply (ce, l) -> + apply ~loc ~attrs (sub # class_expr ce) + (List.map (map_snd (sub # expr)) l) + | Pcl_let (r, vbs, ce) -> + let_ ~loc ~attrs r (List.map (sub # value_binding) vbs) + (sub # class_expr ce) + | Pcl_constraint (ce, ct) -> + constraint_ ~loc ~attrs (sub # class_expr ce) (sub # class_type ct) + | Pcl_extension x -> extension ~loc ~attrs (sub # extension x) + | Pcl_open (od, ce) -> + open_ ~loc ~attrs (sub # open_description od) (sub # class_expr ce) + + let map_kind sub = function + | Cfk_concrete (o, e) -> Cfk_concrete (o, sub # expr e) + | Cfk_virtual t -> Cfk_virtual (sub # typ t) + + let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = + let open Cf in + let loc = sub # location loc in + match desc with + | Pcf_inherit (o, ce, s) -> inherit_ ~loc ~attrs o (sub # class_expr 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 (sub # typ t1) (sub # typ t2) + | Pcf_initializer e -> initializer_ ~loc ~attrs (sub # expr e) + | Pcf_attribute x -> attribute ~loc (sub # attribute x) + | Pcf_extension x -> extension ~loc ~attrs (sub # extension x) + + let map_structure sub {pcstr_self; pcstr_fields} = + { + pcstr_self = sub # pat pcstr_self; + pcstr_fields = List.map (sub # class_field) pcstr_fields; + } + + let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; + pci_loc; pci_attributes} = + Ci.mk + ~virt:pci_virt + ~params:(List.map (map_fst (sub # typ)) pl) + (map_loc sub pci_name) + (f pci_expr) + ~loc:(sub # location pci_loc) + ~attrs:(sub # attributes pci_attributes) +end + +(* 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. *) + +class mapper = + object(this) + method structure l = List.map (this # structure_item) l + method structure_item si = M.map_structure_item this si + method module_expr = M.map this + + method signature l = List.map (this # signature_item) l + method signature_item si = MT.map_signature_item this si + method module_type = MT.map this + method with_constraint c = MT.map_with_constraint this c + + method class_declaration = CE.class_infos this (this # class_expr) + 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 + + method class_type_declaration = CE.class_infos this (this # class_type) + method class_description = CE.class_infos this (this # class_type) + + method binding_op = E.map_binding_op this + + method type_declaration = T.map_type_declaration this + method type_kind = T.map_type_kind this + method typ = T.map this + + method type_extension = T.map_type_extension this + method type_exception = T.map_type_exception this + method extension_constructor = T.map_extension_constructor this + + method value_description {pval_name; pval_type; pval_prim; pval_loc; + pval_attributes} = + Val.mk + (map_loc this pval_name) + (this # typ pval_type) + ~attrs:(this # attributes pval_attributes) + ~loc:(this # location pval_loc) + ~prim:pval_prim + + method pat = P.map this + method expr = E.map this + + method module_declaration {pmd_name; pmd_type; pmd_attributes; pmd_loc} = + Md.mk + (map_loc this pmd_name) + (this # module_type pmd_type) + ~attrs:(this # attributes pmd_attributes) + ~loc:(this # location pmd_loc) + + method module_substitution {pms_name; pms_manifest; pms_attributes; pms_loc} = + Ms.mk + (map_loc this pms_name) + (map_loc this pms_manifest) + ~attrs:(this # attributes pms_attributes) + ~loc:(this # location pms_loc) + + method module_type_declaration {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} = + Mtd.mk + (map_loc this pmtd_name) + ?typ:(map_opt (this # module_type) pmtd_type) + ~attrs:(this # attributes pmtd_attributes) + ~loc:(this # location pmtd_loc) + + method module_binding {pmb_name; pmb_expr; pmb_attributes; pmb_loc} = + Mb.mk (map_loc this pmb_name) (this # module_expr pmb_expr) + ~attrs:(this # attributes pmb_attributes) + ~loc:(this # location pmb_loc) + + method value_binding {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} = + Vb.mk + (this # pat pvb_pat) + (this # expr pvb_expr) + ~attrs:(this # attributes pvb_attributes) + ~loc:(this # location pvb_loc) + + method constructor_arguments = function + | Pcstr_tuple (tys) -> Pcstr_tuple (List.map (this # typ) tys) + | Pcstr_record (ls) -> Pcstr_record (List.map (this # label_declaration) ls) + + method constructor_declaration {pcd_name; pcd_args; pcd_res; pcd_loc; + pcd_attributes} = + Type.constructor + (map_loc this pcd_name) + ~args:(this # constructor_arguments pcd_args) + ?res:(map_opt (this # typ) pcd_res) + ~loc:(this # location pcd_loc) + ~attrs:(this # attributes pcd_attributes) + + method label_declaration {pld_name; pld_type; pld_loc; pld_mutable; + pld_attributes} = + Type.field + (map_loc this pld_name) + (this # typ pld_type) + ~mut:pld_mutable + ~loc:(this # location pld_loc) + ~attrs:(this # attributes pld_attributes) + + + method cases l = List.map (this # case) l + method case {pc_lhs; pc_guard; pc_rhs} = + { + pc_lhs = this # pat pc_lhs; + pc_guard = map_opt (this # expr) pc_guard; + pc_rhs = this # expr pc_rhs; + } + + method open_declaration + {popen_expr; popen_override; popen_attributes; popen_loc} = + Opn.mk (this # module_expr popen_expr) + ~override:popen_override + ~loc:(this # location popen_loc) + ~attrs:(this # attributes popen_attributes) + + method open_description + {popen_expr; popen_override; popen_attributes; popen_loc} = + Opn.mk (map_loc this popen_expr) + ~override:popen_override + ~loc:(this # location popen_loc) + ~attrs:(this # attributes popen_attributes) + + method include_description + {pincl_mod; pincl_attributes; pincl_loc} = + Incl.mk (this # module_type pincl_mod) + ~loc:(this # location pincl_loc) + ~attrs:(this # attributes pincl_attributes) + + method include_declaration + {pincl_mod; pincl_attributes; pincl_loc} = + Incl.mk (this # module_expr pincl_mod) + ~loc:(this # location pincl_loc) + ~attrs:(this # attributes pincl_attributes) + + method location l = l + + method extension (s, e) = (map_loc this s, this # payload e) + + method attribute a = + { + attr_name = map_loc this a.attr_name; + attr_payload = this # payload a.attr_payload; + attr_loc = this # location a.attr_loc; + } + + method attributes l = List.map (this # attribute) l + + method payload = function + | PStr x -> PStr (this # structure x) + | PTyp x -> PTyp (this # typ x) + | PPat (x, g) -> PPat (this # pat x, map_opt (this # expr) g) + | PSig x -> PSig (this # signature x) + end + + +let to_mapper this = + let open Ast_mapper in + { + attribute = (fun _ -> this # attribute); + attributes = (fun _ -> this # attributes); + binding_op = (fun _ -> this # binding_op); + case = (fun _ -> this # case); + cases = (fun _ -> this # cases); + class_declaration = (fun _ -> this # class_declaration); + class_description = (fun _ -> this # class_description); + class_expr = (fun _ -> this # class_expr); + class_field = (fun _ -> this # class_field); + class_signature = (fun _ -> this # class_signature); + class_structure = (fun _ -> this # class_structure); + class_type = (fun _ -> this # class_type); + class_type_declaration = (fun _ -> this # class_type_declaration); + class_type_field = (fun _ -> this # class_type_field); + constructor_declaration = (fun _ -> this # constructor_declaration); + expr = (fun _ -> this # expr); + extension = (fun _ -> this # extension); + extension_constructor = (fun _ -> this # extension_constructor); + include_declaration = (fun _ -> this # include_declaration); + include_description = (fun _ -> this # include_description); + label_declaration = (fun _ -> this # label_declaration); + location = (fun _ -> this # location); + module_binding = (fun _ -> this # module_binding); + module_declaration = (fun _ -> this # module_declaration); + module_expr = (fun _ -> this # module_expr); + module_substitution = (fun _ -> this # module_substitution); + module_type = (fun _ -> this # module_type); + module_type_declaration = (fun _ -> this # module_type_declaration); + open_declaration = (fun _ -> this # open_declaration); + open_description = (fun _ -> this # open_description); + pat = (fun _ -> this # pat); + payload = (fun _ -> this # payload); + signature = (fun _ -> this # signature); + signature_item = (fun _ -> this # signature_item); + structure = (fun _ -> this # structure); + structure_item = (fun _ -> this # structure_item); + typ = (fun _ -> this # typ); + type_declaration = (fun _ -> this # type_declaration); + type_exception = (fun _ -> this # type_exception); + type_extension = (fun _ -> this # type_extension); + type_kind = (fun _ -> this # type_kind); + value_binding = (fun _ -> this # value_binding); + value_description = (fun _ -> this # value_description); + with_constraint = (fun _ -> this # with_constraint); + } diff --git a/408/ast_mapper_class.mli b/408/ast_mapper_class.mli new file mode 100644 index 0000000..9829378 --- /dev/null +++ b/408/ast_mapper_class.mli @@ -0,0 +1,60 @@ +(* This file is part of the ppx_tools package. It is released *) +(* under the terms of the MIT license (see LICENSE file). *) +(* Copyright 2013 Alain Frisch and LexiFi *) + +(** Class-based customizable mapper *) + +open Parsetree + +class mapper: + object + method attribute: attribute -> attribute + method attributes: attribute list -> attribute list + method binding_op: binding_op -> binding_op + method case: case -> case + method cases: case list -> case list + method class_declaration: class_declaration -> class_declaration + method class_description: class_description -> class_description + method class_expr: class_expr -> class_expr + method class_field: class_field -> class_field + method class_signature: class_signature -> class_signature + method class_structure: class_structure -> class_structure + method class_type: class_type -> class_type + method class_type_declaration: class_type_declaration -> class_type_declaration + method class_type_field: class_type_field -> class_type_field + method constructor_arguments: constructor_arguments -> constructor_arguments + method constructor_declaration: constructor_declaration -> constructor_declaration + method expr: expression -> expression + method extension: extension -> extension + method extension_constructor: extension_constructor -> extension_constructor + method include_declaration: include_declaration -> include_declaration + method include_description: include_description -> include_description + method label_declaration: label_declaration -> label_declaration + method location: Location.t -> Location.t + method module_binding: module_binding -> module_binding + method module_declaration: module_declaration -> module_declaration + method module_substitution: module_substitution -> module_substitution + method module_expr: module_expr -> module_expr + method module_type: module_type -> module_type + method module_type_declaration: module_type_declaration -> module_type_declaration + method open_declaration: open_declaration -> open_declaration + method open_description: open_description -> open_description + method pat: pattern -> pattern + method payload: payload -> payload + method signature: signature -> signature + method signature_item: signature_item -> signature_item + method structure: structure -> structure + method structure_item: structure_item -> structure_item + method typ: core_type -> core_type + method type_declaration: type_declaration -> type_declaration + method type_exception: type_exception -> type_exception + method type_extension: type_extension -> type_extension + method type_kind: type_kind -> type_kind + method value_binding: value_binding -> value_binding + method value_description: value_description -> value_description + method with_constraint: with_constraint -> with_constraint + end + +val to_mapper: #mapper -> Ast_mapper.mapper +(** The resulting mapper is "closed", i.e. methods ignore + their first argument. *) diff --git a/dumpast.ml b/408/dumpast.ml similarity index 100% rename from dumpast.ml rename to 408/dumpast.ml diff --git a/408/genlifter.ml b/408/genlifter.ml new file mode 100644 index 0000000..b8e499a --- /dev/null +++ b/408/genlifter.ml @@ -0,0 +1,234 @@ +(* This file is part of the ppx_tools package. It is released *) +(* under the terms of the MIT license (see LICENSE file). *) +(* Copyright 2013 Alain Frisch and LexiFi *) + + +(* Generate code to lift values of a certain type. + This illustrates how to build fragments of Parsetree through + Ast_helper and more local helper functions. *) + +module Main : sig end = struct + + open Location + open Types + open Asttypes + open Ast_helper + open Ast_convenience + + let selfcall ?(this = "this") m args = app (Exp.send (evar this) (mknoloc m)) args + + (*************************************************************************) + + + let env = Env.initial_safe_string + + let clean s = + let s = Bytes.of_string s in + for i = 0 to Bytes.length s - 1 do + if Bytes.get s i = '.' then Bytes.set s i '_' + done; + Bytes.to_string s + + let print_fun s = "lift_" ^ clean s + + let printed = Hashtbl.create 16 + let meths = ref [] + let use_existentials = ref false + let use_arrows = ref false + + let existential_method = + Cf.(method_ (mknoloc "existential") Public + (virtual_ Typ.(poly [mknoloc "a"] (arrow Nolabel (var "a") (var "res")))) + ) + + let arrow_method = + Cf.(method_ (mknoloc "arrow") Public + (virtual_ Typ.(poly [mknoloc "a"] (arrow Nolabel (var "a") (var "res")))) + ) + + let rec gen ty = + if Hashtbl.mem printed ty then () + else let tylid = Longident.parse ty in + let td = + try Env.find_type (Env.lookup_type tylid env) env + with Not_found -> + Format.eprintf "** Cannot resolve type %s@." ty; + exit 2 + in + let prefix = + let open Longident in + match tylid with + | Ldot (m, _) -> String.concat "." (Longident.flatten m) ^ "." + | Lident _ -> "" + | Lapply _ -> assert false + in + Hashtbl.add printed ty (); + let params = List.mapi (fun i _ -> mknoloc (Printf.sprintf "f%i" i)) td.type_params in + let env = List.map2 (fun s t -> t.id, evar s.txt) params td.type_params in + let make_result_t tyargs = Typ.(arrow Asttypes.Nolabel (constr (lid ty) tyargs) (var "res")) in + let make_t tyargs = + List.fold_right + (fun arg t -> + Typ.(arrow Asttypes.Nolabel (arrow Asttypes.Nolabel arg (var "res")) t)) + tyargs (make_result_t tyargs) + in + let tyargs = List.map (fun t -> Typ.var t.txt) params in + let t = Typ.poly params (make_t tyargs) in + let concrete e = + let e = List.fold_right (fun x e -> lam x e) (List.map (fun x -> pvar x.txt) params) e in + let tyargs = List.map (fun t -> Typ.constr (lid t.txt) []) params in + let e = Exp.constraint_ e (make_t tyargs) in + let e = List.fold_right (fun x e -> Exp.newtype x e) params e in + let body = Exp.poly e (Some t) in + meths := Cf.(method_ (mknoloc (print_fun ty)) Public (concrete Fresh body)) :: !meths + in + let field ld = + let s = Ident.name ld.ld_id in + (lid (prefix ^ s), pvar s), + tuple[str s; tyexpr env ld.ld_type (evar s)] + in + match td.type_kind, td.type_manifest with + | Type_record (l, _), _ -> + let l = List.map field l in + concrete + (lam + (Pat.record (List.map fst l) Closed) + (selfcall "record" [str ty; list (List.map snd l)])) + | Type_variant l, _ -> + let case cd = + let c = Ident.name cd.cd_id in + let qc = prefix ^ c in + match cd.cd_args with + | Cstr_tuple (tys) -> + let p, args = gentuple env tys in + pconstr qc p, selfcall "constr" [str ty; tuple[str c; list args]] + | Cstr_record (l) -> + let l = List.map field l in + let keep_head ((lid, pattern), _) = + let txt = Longident.Lident (Longident.last lid.txt) in + ({lid with txt}, pattern) + in + pconstr qc [Pat.record (List.map keep_head l) Closed], + selfcall "constr" + [str ty; + tuple [str c; + list [selfcall "record" + [str ""; list (List.map snd l)]]]] + in + concrete (func (List.map case l)) + | Type_abstract, Some t -> + concrete (tyexpr_fun env t) + | Type_abstract, None -> + (* Generate an abstract method to lift abstract types *) + meths := Cf.(method_ (mknoloc (print_fun ty)) Public (virtual_ t)) :: !meths + | Type_open, _ -> + failwith "Open types are not yet supported." + + and gentuple env tl = + let arg i t = + let x = Printf.sprintf "x%i" i in + pvar x, tyexpr env t (evar x) + in + List.split (List.mapi arg tl) + + and tyexpr env ty x = + match ty.desc with + | Tvar _ -> + (match List.assoc ty.id env with + | f -> app f [x] + | exception Not_found -> + use_existentials := true; + selfcall "existential" [x]) + | Ttuple tl -> + let p, e = gentuple env tl in + let_in [Vb.mk (Pat.tuple p) x] (selfcall "tuple" [list e]) + | Tconstr (path, [t], _) when Path.same path Predef.path_list -> + selfcall "list" [app (evar "List.map") [tyexpr_fun env t; x]] + | Tconstr (path, [t], _) when Path.same path Predef.path_array -> + selfcall "array" [app (evar "Array.map") [tyexpr_fun env t; x]] + | Tconstr (path, [], _) when Path.same path Predef.path_string -> + selfcall "string" [x] + | Tconstr (path, [], _) when Path.same path Predef.path_int -> + selfcall "int" [x] + | Tconstr (path, [], _) when Path.same path Predef.path_char -> + selfcall "char" [x] + | Tconstr (path, [], _) when Path.same path Predef.path_int32 -> + selfcall "int32" [x] + | Tconstr (path, [], _) when Path.same path Predef.path_int64 -> + selfcall "int64" [x] + | Tconstr (path, [], _) when Path.same path Predef.path_nativeint -> + selfcall "nativeint" [x] + | Tconstr (path, tl, _) -> + let ty = Path.name path in + gen ty; + selfcall (print_fun ty) (List.map (tyexpr_fun env) tl @ [x]) + | Tarrow _ -> + use_arrows := true; + selfcall "arrow" [x] + | _ -> + Format.eprintf "** Cannot deal with type %a@." Printtyp.type_expr ty; + exit 2 + + and tyexpr_fun env ty = + lam (pvar "x") (tyexpr env ty (evar "x")) + + let simplify = + (* (fun x -> x) ====> *) + let open Ast_mapper in + let super = default_mapper in + let expr this e = + let e = super.expr this e in + let open Longident in + let open Parsetree in + match e.pexp_desc with + | Pexp_fun + (Asttypes.Nolabel, None, + {ppat_desc = Ppat_var{txt=id;_};_}, + {pexp_desc = + Pexp_apply + (f, + [Asttypes.Nolabel + ,{pexp_desc= Pexp_ident{txt=Lident id2;_};_}]);_}) + when id = id2 -> f + | _ -> e + in + {super with expr} + + let args = + let open Arg in + [ + "-I", String (fun s -> Load_path.add_dir (Misc.expand_directory Config.standard_library s)), + " Add to the list of include directories"; + ] + + let usage = + Printf.sprintf "%s [options] \n" Sys.argv.(0) + + let main () = + Load_path.init [Config.standard_library]; + Arg.parse (Arg.align args) gen usage; + let meths = !meths in + let meths = + if !use_existentials then + existential_method :: meths + else + meths + in + let meths = + if !use_arrows then + arrow_method :: meths + else + meths + in + let cl = Cstr.mk (pvar "this") meths in + let params = [Typ.var "res", Invariant] in + let cl = Ci.mk ~virt:Virtual ~params (mknoloc "lifter") (Cl.structure cl) in + let s = [Str.class_ [cl]] in + Format.printf "%a@." Pprintast.structure (simplify.Ast_mapper.structure simplify s) + + let () = + try main () + with exn -> + Printf.eprintf "** fatal error: %s\n%!" (Printexc.to_string exn) + +end diff --git a/408/ppx_metaquot.ml b/408/ppx_metaquot.ml new file mode 100644 index 0000000..943c06a --- /dev/null +++ b/408/ppx_metaquot.ml @@ -0,0 +1,288 @@ +(* This file is part of the ppx_tools package. It is released *) +(* under the terms of the MIT license (see LICENSE file). *) +(* Copyright 2013 Alain Frisch and LexiFi *) + +(* A -ppx rewriter to be used to write Parsetree-generating code + (including other -ppx rewriters) using concrete syntax. + + We support the following extensions in expression position: + + [%expr ...] maps to code which creates the expression represented by ... + [%pat? ...] maps to code which creates the pattern represented by ... + [%str ...] maps to code which creates the structure represented by ... + [%stri ...] maps to code which creates the structure item represented by ... + [%sig: ...] maps to code which creates the signature represented by ... + [%sigi: ...] maps to code which creates the signature item represented by ... + [%type: ...] maps to code which creates the core type represented by ... + + Quoted code can refer to expressions representing AST fragments, + using the following extensions: + + [%e ...] where ... is an expression of type Parsetree.expression + [%t ...] where ... is an expression of type Parsetree.core_type + [%p ...] where ... is an expression of type Parsetree.pattern + [%%s ...] where ... is an expression of type Parsetree.structure + or Parsetree.signature depending on the context. + + + All locations generated by the meta quotation are by default set + to [Ast_helper.default_loc]. This can be overriden by providing a custom + expression which will be inserted whereever a location is required + in the generated AST. This expression can be specified globally + (for the current structure) as a structure item attribute: + + ;;[@@metaloc ...] + + or locally for the scope of an expression: + + e [@metaloc ...] + + + + Support is also provided to use concrete syntax in pattern + position. The location and attribute fields are currently ignored + by patterns generated from meta quotations. + + We support the following extensions in pattern position: + + [%expr ...] maps to code which creates the expression represented by ... + [%pat? ...] maps to code which creates the pattern represented by ... + [%str ...] maps to code which creates the structure represented by ... + [%type: ...] maps to code which creates the core type represented by ... + + Quoted code can refer to expressions representing AST fragments, + using the following extensions: + + [%e? ...] where ... is a pattern of type Parsetree.expression + [%t? ...] where ... is a pattern of type Parsetree.core_type + [%p? ...] where ... is a pattern of type Parsetree.pattern + +*) + +module Main : sig + val main : unit -> unit +end = struct + open Asttypes + open Parsetree + open Ast_helper + open Ast_convenience + + let prefix ty s = + let open Longident in + match parse ty with + | Ldot(m, _) -> String.concat "." (Longident.flatten m) ^ "." ^ s + | _ -> s + + let append ?loc ?attrs e e' = + let fn = Location.mknoloc (Longident.(Ldot (Lident "List", "append"))) in + Exp.apply ?loc ?attrs (Exp.ident fn) [Nolabel, e; Nolabel, e'] + + class exp_builder = + object + method record ty x = record (List.map (fun (l, e) -> prefix ty l, e) x) + method constr ty (c, args) = constr (prefix ty c) args + method list l = list l + method tuple l = tuple l + method int i = int i + method string s = str s + method char c = char c + method int32 x = Exp.constant (Const.int32 x) + method int64 x = Exp.constant (Const.int64 x) + method nativeint x = Exp.constant (Const.nativeint x) + end + + class pat_builder = + object + method record ty x = precord ~closed:Closed (List.map (fun (l, e) -> prefix ty l, e) x) + method constr ty (c, args) = pconstr (prefix ty c) args + method list l = plist l + method tuple l = ptuple l + method int i = pint i + method string s = pstr s + method char c = pchar c + method int32 x = Pat.constant (Const.int32 x) + method int64 x = Pat.constant (Const.int64 x) + method nativeint x = Pat.constant (Const.nativeint x) + end + + + let get_exp loc = function + | PStr [ {pstr_desc=Pstr_eval (e, _); _} ] -> e + | _ -> + let report = Location.error ~loc "Expression expected." in + Location.print_report Format.err_formatter report; + exit 2 + + let get_typ loc = function + | PTyp t -> t + | _ -> + let report = Location.error ~loc "Type expected." in + Location.print_report Format.err_formatter report; + exit 2 + + let get_pat loc = function + | PPat (t, None) -> t + | _ -> + let report = Location.error ~loc "Pattern expected." in + Location.print_report Format.err_formatter report; + exit 2 + + let exp_lifter loc map = + let map = map.Ast_mapper.expr map in + object + inherit [_] Ast_lifter.lifter as super + inherit exp_builder + + (* Special support for location in the generated AST *) + method! lift_Location_t _ = loc + + (* Support for antiquotations *) + method! lift_Parsetree_expression = function + | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> map (get_exp loc e) + | x -> super # lift_Parsetree_expression x + + method! lift_Parsetree_pattern = function + | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> map (get_exp loc e) + | x -> super # lift_Parsetree_pattern x + + method! lift_Parsetree_structure str = + List.fold_right + (function + | {pstr_desc=Pstr_extension(({txt="s";loc}, e), _); _} -> + append (get_exp loc e) + | x -> + cons (super # lift_Parsetree_structure_item x)) + str (nil ()) + + method! lift_Parsetree_signature sign = + List.fold_right + (function + | {psig_desc=Psig_extension(({txt="s";loc}, e), _); _} -> + append (get_exp loc e) + | x -> + cons (super # lift_Parsetree_signature_item x)) + sign (nil ()) + + method! lift_Parsetree_core_type = function + | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} ->map (get_exp loc e) + | x -> super # lift_Parsetree_core_type x + end + + let pat_lifter map = + let map = map.Ast_mapper.pat map in + object + inherit [_] Ast_lifter.lifter as super + inherit pat_builder as builder + + (* Special support for location and attributes in the generated AST *) + method! lift_Location_t _ = Pat.any () + method! lift_Parsetree_attributes _ = Pat.any () + method! record n fields = + let fields = + List.map (fun (name, pat) -> + match name with + | "pexp_loc_stack" | "ppat_loc_stack" | "ptyp_loc_stack" -> + name, Pat.any () + | _ -> name, pat) fields + in + builder#record n fields + + (* Support for antiquotations *) + method! lift_Parsetree_expression = function + | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> map (get_pat loc e) + | x -> super # lift_Parsetree_expression x + + method! lift_Parsetree_pattern = function + | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> map (get_pat loc e) + | x -> super # lift_Parsetree_pattern x + + method! lift_Parsetree_core_type = function + | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} -> map (get_pat loc e) + | x -> super # lift_Parsetree_core_type x + end + + let loc = ref (app (evar "Stdlib.!") [evar "Ast_helper.default_loc"]) + + let handle_attr = function + | {attr_name={txt="metaloc";loc=l}; attr_payload=e; _} -> loc := get_exp l e + | _ -> () + + let with_loc ?(attrs = []) f = + let old_loc = !loc in + List.iter handle_attr attrs; + let r = f () in + loc := old_loc; + r + + let expander _args = + let open Ast_mapper in + let super = default_mapper in + let expr this e = + with_loc ~attrs:e.pexp_attributes + (fun () -> + match e.pexp_desc with + | Pexp_extension({txt="expr";loc=l}, e) -> + (exp_lifter !loc this) # lift_Parsetree_expression (get_exp l e) + | Pexp_extension({txt="pat";loc=l}, e) -> + (exp_lifter !loc this) # lift_Parsetree_pattern (get_pat l e) + | Pexp_extension({txt="str";_}, PStr e) -> + (exp_lifter !loc this) # lift_Parsetree_structure e + | Pexp_extension({txt="stri";_}, PStr [e]) -> + (exp_lifter !loc this) # lift_Parsetree_structure_item e + | Pexp_extension({txt="sig";_}, PSig e) -> + (exp_lifter !loc this) # lift_Parsetree_signature e + | Pexp_extension({txt="sigi";_}, PSig [e]) -> + (exp_lifter !loc this) # lift_Parsetree_signature_item e + | Pexp_extension({txt="type";loc=l}, e) -> + (exp_lifter !loc this) # lift_Parsetree_core_type (get_typ l e) + | _ -> + super.expr this e + ) + and pat this p = + with_loc ~attrs:p.ppat_attributes + (fun () -> + match p.ppat_desc with + | Ppat_extension({txt="expr";loc=l}, e) -> + (pat_lifter this) # lift_Parsetree_expression (get_exp l e) + | Ppat_extension({txt="pat";loc=l}, e) -> + (pat_lifter this) # lift_Parsetree_pattern (get_pat l e) + | Ppat_extension({txt="str";_}, PStr e) -> + (pat_lifter this) # lift_Parsetree_structure e + | Ppat_extension({txt="stri";_}, PStr [e]) -> + (pat_lifter this) # lift_Parsetree_structure_item e + | Ppat_extension({txt="sig";_}, PSig e) -> + (pat_lifter this) # lift_Parsetree_signature e + | Ppat_extension({txt="sigi";_}, PSig [e]) -> + (pat_lifter this) # lift_Parsetree_signature_item e + | Ppat_extension({txt="type";loc=l}, e) -> + (pat_lifter this) # lift_Parsetree_core_type (get_typ l e) + | _ -> + super.pat this p + ) + and structure this l = + with_loc + (fun () -> super.structure this l) + + and structure_item this x = + begin match x.pstr_desc with + | Pstr_attribute x -> handle_attr x + | _ -> () + end; + super.structure_item this x + + and signature this l = + with_loc + (fun () -> super.signature this l) + + and signature_item this x = + begin match x.psig_desc with + | Psig_attribute x -> handle_attr x + | _ -> () + end; + super.signature_item this x + + in + {super with expr; pat; structure; structure_item; signature; signature_item} + + let main () = Ast_mapper.run_main expander +end diff --git a/ppx_metaquot_main.ml b/408/ppx_metaquot_main.ml similarity index 100% rename from ppx_metaquot_main.ml rename to 408/ppx_metaquot_main.ml diff --git a/rewriter.ml b/408/rewriter.ml similarity index 100% rename from rewriter.ml rename to 408/rewriter.ml diff --git a/410/ast_convenience.ml b/410/ast_convenience.ml new file mode 100644 index 0000000..62dc655 --- /dev/null +++ b/410/ast_convenience.ml @@ -0,0 +1,122 @@ +(* This file is part of the ppx_tools package. It is released *) +(* under the terms of the MIT license (see LICENSE file). *) +(* Copyright 2013 Alain Frisch and LexiFi *) + +open Parsetree +open Asttypes +open Location +open Ast_helper + + +module Label = struct + + type t = Asttypes.arg_label + + type desc = Asttypes.arg_label = + Nolabel + | Labelled of string + | Optional of string + + let explode x = x + + let nolabel = Nolabel + let labelled x = Labelled x + let optional x = Optional x + +end + +module Constant = struct + type t = Parsetree.constant = + Pconst_integer of string * char option + | Pconst_char of char + | Pconst_string of string * string option + | Pconst_float of string * char option + + let of_constant x = x + + let to_constant x = x + +end + +let may_tuple ?loc tup = function + | [] -> None + | [x] -> Some x + | l -> Some (tup ?loc ?attrs:None l) + +let lid ?(loc = !default_loc) s = mkloc (Longident.parse s) loc +let constr ?loc ?attrs s args = Exp.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Exp.tuple args) +let nil ?loc ?attrs () = constr ?loc ?attrs "[]" [] +let unit ?loc ?attrs () = constr ?loc ?attrs "()" [] +let tuple ?loc ?attrs = function + | [] -> unit ?loc ?attrs () + | [x] -> x + | xs -> Exp.tuple ?loc ?attrs xs +let cons ?loc ?attrs hd tl = constr ?loc ?attrs "::" [hd; tl] +let list ?loc ?attrs l = List.fold_right (cons ?loc ?attrs) l (nil ?loc ?attrs ()) +let str ?loc ?attrs s = Exp.constant ?loc ?attrs (Pconst_string (s, None)) +let int ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (string_of_int x, None)) +let int32 ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (Int32.to_string x, Some 'l')) +let int64 ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (Int64.to_string x, Some 'L')) +let char ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_char x) +let float ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_float (string_of_float x, None)) +let record ?loc ?attrs ?over l = + Exp.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.pexp_loc s, e)) l) over +let func ?loc ?attrs l = Exp.function_ ?loc ?attrs (List.map (fun (p, e) -> Exp.case p e) l) +let lam ?loc ?attrs ?(label = Label.nolabel) ?default pat exp = Exp.fun_ ?loc ?attrs label default pat exp +let app ?loc ?attrs f l = if l = [] then f else Exp.apply ?loc ?attrs f (List.map (fun a -> Label.nolabel, a) l) +let evar ?loc ?attrs s = Exp.ident ?loc ?attrs (lid ?loc s) +let let_in ?loc ?attrs ?(recursive = false) b body = + Exp.let_ ?loc ?attrs (if recursive then Recursive else Nonrecursive) b body + +let sequence ?loc ?attrs = function + | [] -> unit ?loc ?attrs () + | hd :: tl -> List.fold_left (fun e1 e2 -> Exp.sequence ?loc ?attrs e1 e2) hd tl + +let pvar ?(loc = !default_loc) ?attrs s = Pat.var ~loc ?attrs (mkloc s loc) +let pconstr ?loc ?attrs s args = Pat.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Pat.tuple args) +let precord ?loc ?attrs ?(closed = Open) l = + Pat.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.ppat_loc s, e)) l) closed +let pnil ?loc ?attrs () = pconstr ?loc ?attrs "[]" [] +let pcons ?loc ?attrs hd tl = pconstr ?loc ?attrs "::" [hd; tl] +let punit ?loc ?attrs () = pconstr ?loc ?attrs "()" [] +let ptuple ?loc ?attrs = function + | [] -> punit ?loc ?attrs () + | [x] -> x + | xs -> Pat.tuple ?loc ?attrs xs +let plist ?loc ?attrs l = List.fold_right (pcons ?loc ?attrs) l (pnil ?loc ?attrs ()) + +let pstr ?loc ?attrs s = Pat.constant ?loc ?attrs (Pconst_string (s, None)) +let pint ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_integer (string_of_int x, None)) +let pchar ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_char x) +let pfloat ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_float (string_of_float x, None)) + +let tconstr ?loc ?attrs c l = Typ.constr ?loc ?attrs (lid ?loc c) l + +let get_str = function + | {pexp_desc=Pexp_constant (Pconst_string (s, _)); _} -> Some s + | _ -> None + +let get_str_with_quotation_delimiter = function + | {pexp_desc=Pexp_constant (Pconst_string (s, d)); _} -> Some (s, d) + | _ -> None + +let get_lid = function + | {pexp_desc=Pexp_ident{txt=id;_};_} -> + Some (String.concat "." (Longident.flatten id)) + | _ -> None + +let find_attr s attrs = + try Some ((List.find (fun {attr_name=x;_} -> x.txt = s) attrs).attr_payload) + with Not_found -> None + +let expr_of_payload = function + | PStr [{pstr_desc=Pstr_eval(e, _); _}] -> Some e + | _ -> None + +let find_attr_expr s attrs = + match find_attr s attrs with + | Some e -> expr_of_payload e + | None -> None + +let has_attr s attrs = + find_attr s attrs <> None diff --git a/410/ast_convenience.mli b/410/ast_convenience.mli new file mode 100644 index 0000000..3ac31fd --- /dev/null +++ b/410/ast_convenience.mli @@ -0,0 +1,110 @@ +(* This file is part of the ppx_tools package. It is released *) +(* under the terms of the MIT license (see LICENSE file). *) +(* Copyright 2013 Alain Frisch and LexiFi *) + +(** {1 Convenience functions to help build and deconstruct AST fragments.} *) + +open Asttypes +open Ast_helper +open Parsetree + +(** {2 Compatibility modules} *) + +module Label : sig + type t = Asttypes.arg_label + + type desc = Asttypes.arg_label = + Nolabel + | Labelled of string + | Optional of string + + val explode : t -> desc + + val nolabel : t + val labelled : string -> t + val optional : string -> t + +end + +(** {2 Provides a unified abstraction over differences in Parsetree.constant and Asttypes.constant + * types defined in ocaml 4.03 and 4.02 respectively}*) +module Constant : sig + type t = Parsetree.constant = + Pconst_integer of string * char option + | Pconst_char of char + | Pconst_string of string * string option + | Pconst_float of string * char option + + (** Convert Asttypes.constant to Constant.t *) + val of_constant : Parsetree.constant -> t + + (** Convert Constant.t to Asttypes.constant *) + val to_constant : t -> Parsetree.constant + +end + +(** {2 Misc} *) + +val lid: ?loc:loc -> string -> lid + +(** {2 Expressions} *) + +val evar: ?loc:loc -> ?attrs:attrs -> string -> expression +val let_in: ?loc:loc -> ?attrs:attrs -> ?recursive:bool -> value_binding list -> expression -> expression + +val constr: ?loc:loc -> ?attrs:attrs -> string -> expression list -> expression +val record: ?loc:loc -> ?attrs:attrs -> ?over:expression -> (string * expression) list -> expression +val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression + +val nil: ?loc:loc -> ?attrs:attrs -> unit -> expression +val cons: ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression +val list: ?loc:loc -> ?attrs:attrs -> expression list -> expression + +val unit: ?loc:loc -> ?attrs:attrs -> unit -> expression + +val func: ?loc:loc -> ?attrs:attrs -> (pattern * expression) list -> expression +val lam: ?loc:loc -> ?attrs:attrs -> ?label:Label.t -> ?default:expression -> pattern -> expression -> expression +val app: ?loc:loc -> ?attrs:attrs -> expression -> expression list -> expression + +val str: ?loc:loc -> ?attrs:attrs -> string -> expression +val int: ?loc:loc -> ?attrs:attrs -> int -> expression +val int32: ?loc:loc -> ?attrs:attrs -> int32 -> expression +val int64: ?loc:loc -> ?attrs:attrs -> int64 -> expression +val char: ?loc:loc -> ?attrs:attrs -> char -> expression +val float: ?loc:loc -> ?attrs:attrs -> float -> expression + +val sequence: ?loc:loc -> ?attrs:attrs -> expression list -> expression +(** Return [()] if the list is empty. Tail rec. *) + +(** {2 Patterns} *) + +val pvar: ?loc:loc -> ?attrs:attrs -> string -> pattern +val pconstr: ?loc:loc -> ?attrs:attrs -> string -> pattern list -> pattern +val precord: ?loc:loc -> ?attrs:attrs -> ?closed:closed_flag -> (string * pattern) list -> pattern +val ptuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern + +val pnil: ?loc:loc -> ?attrs:attrs -> unit -> pattern +val pcons: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern +val plist: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern + +val pstr: ?loc:loc -> ?attrs:attrs -> string -> pattern +val pint: ?loc:loc -> ?attrs:attrs -> int -> pattern +val pchar: ?loc:loc -> ?attrs:attrs -> char -> pattern +val pfloat: ?loc:loc -> ?attrs:attrs -> float -> pattern + +val punit: ?loc:loc -> ?attrs:attrs -> unit -> pattern + + +(** {2 Types} *) + +val tconstr: ?loc:loc -> ?attrs:attrs -> string -> core_type list -> core_type + +(** {2 AST deconstruction} *) + +val get_str: expression -> string option +val get_str_with_quotation_delimiter: expression -> (string * string option) option +val get_lid: expression -> string option + +val has_attr: string -> attributes -> bool +val find_attr: string -> attributes -> payload option +val find_attr_expr: string -> attributes -> expression option diff --git a/410/ast_mapper_class.ml b/410/ast_mapper_class.ml new file mode 100644 index 0000000..0756440 --- /dev/null +++ b/410/ast_mapper_class.ml @@ -0,0 +1,656 @@ +(* This file is part of the ppx_tools package. It is released *) +(* under the terms of the MIT license (see LICENSE file). *) +(* Copyright 2013 Alain Frisch and LexiFi *) + +(** Class-based customizable mapper *) + +open Parsetree +open Asttypes +open Ast_helper + +let map_fst f (x, y) = (f x, y) +let map_snd f (x, y) = (x, f y) +let map_tuple f1 f2 (x, y) = (f1 x, f2 y) +let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) +let map_opt f = function None -> None | Some x -> Some (f x) + +let map_loc sub {loc; txt} = {loc = sub # location loc; txt} + +module T = struct + (* Type expressions for the core language *) + + let row_field_desc sub = function + | Rtag (l, b, tl) -> Rtag (l, b, List.map (sub # typ) tl) + | Rinherit t -> Rinherit (sub # typ t) + + let row_field sub {prf_desc = desc; prf_loc = loc; prf_attributes = attrs} = + let desc = row_field_desc sub desc in + let loc = sub # location loc in + let attrs = sub # attributes attrs in + {prf_desc = desc; prf_loc = loc; prf_attributes = attrs} + + let object_field_desc sub = function + | Otag (s, t) -> Otag (s, sub # typ t) + | Oinherit t -> Oinherit (sub # typ t) + + let object_field sub {pof_desc = desc; pof_loc = loc; pof_attributes = attrs} = + let desc = object_field_desc sub desc in + let loc = sub # location loc in + let attrs = sub # attributes attrs in + {pof_desc = desc; pof_loc = loc; pof_attributes = attrs} + + let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_loc_stack = _; ptyp_attributes = attrs} = + let open Typ in + let loc = sub # location loc in + let attrs = sub # attributes 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 (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) + | Ptyp_object (l, o) -> + object_ ~loc ~attrs (List.map (object_field sub) l) o + | Ptyp_class (lid, tl) -> + class_ ~loc ~attrs (map_loc sub lid) (List.map (sub # typ) tl) + | 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) + + let map_type_declaration sub + {ptype_name; ptype_params; ptype_cstrs; + ptype_kind; + ptype_private; + ptype_manifest; + ptype_attributes; + ptype_loc} = + Type.mk (map_loc sub ptype_name) + ~params:(List.map (map_fst (sub # typ)) ptype_params) + ~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) + + let map_type_kind sub = function + | Ptype_abstract -> Ptype_abstract + | Ptype_variant l -> + Ptype_variant (List.map (sub # constructor_declaration) l) + | Ptype_record l -> Ptype_record (List.map (sub # label_declaration) l) + | Ptype_open -> Ptype_open + + let map_type_extension sub + {ptyext_path; ptyext_params; + ptyext_constructors; + ptyext_private; + ptyext_loc; + ptyext_attributes} = + Te.mk + (map_loc sub ptyext_path) + (List.map (sub # extension_constructor) ptyext_constructors) + ~params:(List.map (map_fst (sub # typ)) ptyext_params) + ~priv:ptyext_private + ~loc:(sub # location ptyext_loc) + ~attrs:(sub # attributes ptyext_attributes) + + let map_extension_constructor_kind sub = function + Pext_decl(ctl, cto) -> + Pext_decl(sub # constructor_arguments ctl, map_opt (sub # typ) cto) + | Pext_rebind li -> + Pext_rebind (map_loc sub li) + + let map_extension_constructor sub + {pext_name; + pext_kind; + pext_loc; + pext_attributes} = + Te.constructor + (map_loc sub pext_name) + (map_extension_constructor_kind sub pext_kind) + ~loc:(sub # location pext_loc) + ~attrs:(sub # attributes pext_attributes) + + let map_type_exception sub {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} = + Te.mk_exception + (map_extension_constructor sub ptyexn_constructor) + ~loc:(sub # location ptyexn_loc) + ~attrs:(sub # attributes ptyexn_attributes) + +end + +module CT = struct + (* Type expressions for the class language *) + + let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = + let open Cty in + let loc = sub # location loc in + match desc with + | Pcty_constr (lid, tys) -> + constr ~loc ~attrs (map_loc sub lid) (List.map (sub # typ) tys) + | Pcty_signature x -> signature ~loc ~attrs (sub # class_signature x) + | Pcty_arrow (lab, t, ct) -> + arrow ~loc ~attrs lab (sub # typ t) (sub # class_type ct) + | Pcty_extension x -> extension ~loc ~attrs (sub # extension x) + | Pcty_open (od, ct) -> + open_ ~loc ~attrs (sub # open_description od) (sub # class_type ct) + + let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} + = + let open Ctf in + let loc = sub # location loc in + match desc with + | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub # class_type ct) + | Pctf_val (s, m, v, t) -> val_ ~loc ~attrs s m v (sub # typ t) + | Pctf_method (s, p, v, t) -> method_ ~loc ~attrs s p v (sub # typ t) + | Pctf_constraint (t1, t2) -> + constraint_ ~loc ~attrs (sub # typ t1) (sub # typ t2) + | Pctf_attribute x -> attribute ~loc (sub # attribute x) + | Pctf_extension x -> extension ~loc ~attrs (sub # extension x) + + let map_signature sub {pcsig_self; pcsig_fields} = + Csig.mk + (sub # typ pcsig_self) + (List.map (sub # class_type_field) pcsig_fields) +end + +let map_functor_param sub = function + | Unit -> Unit + | Named (s, mt) -> Named (map_loc sub s, sub # module_type mt) + +module MT = struct + (* Type expressions for the module language *) + + let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = + let open Mty in + let loc = sub # location loc in + let attrs = sub # attributes attrs in + match desc with + | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) + | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) + | Pmty_signature sg -> signature ~loc ~attrs (sub # signature sg) + | Pmty_functor (param, mt) -> + functor_ ~loc ~attrs + (map_functor_param sub param) + (sub # module_type mt) + | Pmty_with (mt, l) -> + with_ ~loc ~attrs (sub # module_type mt) + (List.map (sub # with_constraint) l) + | Pmty_typeof me -> typeof_ ~loc ~attrs (sub # module_expr me) + | Pmty_extension x -> extension ~loc ~attrs (sub # extension x) + + let map_with_constraint sub = function + | Pwith_type (lid, d) -> + Pwith_type (map_loc sub lid, sub # type_declaration d) + | Pwith_module (lid, lid2) -> + Pwith_module (map_loc sub lid, map_loc sub lid2) + | Pwith_typesubst (lid, d) -> + Pwith_typesubst (map_loc sub lid, sub # type_declaration d) + | Pwith_modsubst (lid, lid2) -> + Pwith_modsubst (map_loc sub lid, map_loc sub lid2) + + let map_signature_item sub {psig_desc = desc; psig_loc = loc} = + let open Sig in + let loc = sub # location loc in + match desc with + | Psig_value vd -> value ~loc (sub # value_description vd) + | Psig_type (rf, l) -> type_ ~loc rf (List.map (sub # type_declaration) l) + | Psig_typesubst l -> type_subst ~loc (List.map (sub # type_declaration) l) + | Psig_typext te -> type_extension ~loc (sub # type_extension te) + | Psig_exception texn -> exception_ ~loc (sub # type_exception texn) + | Psig_module x -> module_ ~loc (sub # module_declaration x) + | Psig_modsubst ms -> mod_subst ~loc (sub # module_substitution ms) + | Psig_recmodule l -> + rec_module ~loc (List.map (sub # module_declaration) l) + | Psig_modtype x -> modtype ~loc (sub # module_type_declaration x) + | Psig_open od -> open_ ~loc (sub # open_description od) + | Psig_include x -> include_ ~loc (sub # include_description x) + | 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) + | Psig_extension (x, attrs) -> + extension ~loc (sub # extension x) ~attrs:(sub # attributes attrs) + | Psig_attribute x -> attribute ~loc (sub # attribute x) +end + +module M = struct + (* Value expressions for the module language *) + + let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = + let open Mod in + let loc = sub # location loc in + let attrs = sub # attributes attrs in + match desc with + | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) + | Pmod_structure str -> structure ~loc ~attrs (sub # structure str) + | Pmod_functor (param, body) -> + functor_ ~loc ~attrs + (map_functor_param sub param) + (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) + + let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = + let open Str in + let loc = sub # location loc in + match desc with + | Pstr_eval (x, attrs) -> + eval ~loc ~attrs:(sub # attributes attrs) (sub # expr x) + | Pstr_value (r, vbs) -> value ~loc r (List.map (sub # value_binding) vbs) + | Pstr_primitive vd -> primitive ~loc (sub # value_description vd) + | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub # type_declaration) l) + | Pstr_typext te -> type_extension ~loc (sub # type_extension te) + | Pstr_exception ed -> exception_ ~loc (sub # type_exception ed) + | Pstr_module x -> module_ ~loc (sub # module_binding x) + | Pstr_recmodule l -> rec_module ~loc (List.map (sub # module_binding) l) + | Pstr_modtype x -> modtype ~loc (sub # module_type_declaration x) + | Pstr_open od -> open_ ~loc (sub # open_declaration od) + | 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) + | Pstr_include x -> include_ ~loc (sub # include_declaration x) + | Pstr_extension (x, attrs) -> + extension ~loc (sub # extension x) ~attrs:(sub # attributes attrs) + | Pstr_attribute x -> attribute ~loc (sub # attribute x) +end + +module E = struct + (* Value expressions for the core language *) + + let map_binding_op sub {pbop_op = op; pbop_pat = pat; pbop_exp = exp; pbop_loc = loc} = + let op = map_loc sub op in + let pat = sub # pat pat in + let exp = sub # expr exp in + let loc = sub # location loc in + {pbop_op = op; pbop_pat = pat; pbop_exp = exp; pbop_loc = loc} + + let map sub {pexp_loc = loc; pexp_loc_stack = _; pexp_desc = desc; pexp_attributes = attrs} = + let open Exp in + let loc = sub # location loc in + let attrs = sub # attributes 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 (sub # value_binding) vbs) (sub # expr e) + | Pexp_fun (lab, def, p, e) -> + fun_ ~loc ~attrs lab (map_opt (sub # expr) def) (sub # pat p) + (sub # expr e) + | Pexp_function pel -> function_ ~loc ~attrs (sub # cases pel) + | Pexp_apply (e, l) -> + apply ~loc ~attrs (sub # expr e) (List.map (map_snd (sub # expr)) l) + | Pexp_match (e, pel) -> match_ ~loc ~attrs (sub # expr e) (sub # cases pel) + | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub # expr e) (sub # cases pel) + | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub # expr) el) + | Pexp_construct (lid, arg) -> + construct ~loc ~attrs (map_loc sub lid) (map_opt (sub # expr) arg) + | 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 (p, e1, e2, d, e3) -> + for_ ~loc ~attrs (sub # pat p) (sub # expr e1) (sub # expr e2) d + (sub # expr e3) + | Pexp_coerce (e, t1, t2) -> + coerce ~loc ~attrs (sub # expr e) (map_opt (sub # typ) t1) + (sub # typ t2) + | Pexp_constraint (e, t) -> + constraint_ ~loc ~attrs (sub # expr e) (sub # typ t) + | 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_letexception (cd, e) -> + letexception ~loc ~attrs + (sub # extension_constructor cd) + (sub # expr e) + | Pexp_assert e -> assert_ ~loc ~attrs (sub # expr e) + | 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 (od, e) -> + open_ ~loc ~attrs (sub # open_declaration od) (sub # expr e) + | Pexp_letop x -> + let let_ = map_binding_op sub x.let_ in + let ands = List.map (map_binding_op sub) x.ands in + let body = sub # expr x.body in + letop ~loc ~attrs let_ ands body + | Pexp_extension x -> extension ~loc ~attrs (sub # extension x) + | Pexp_unreachable -> unreachable ~loc ~attrs () +end + +module P = struct + (* Patterns *) + + let map sub {ppat_desc = desc; ppat_loc = loc; ppat_loc_stack = _; ppat_attributes = attrs} = + let open Pat in + let loc = sub # location loc in + let attrs = sub # attributes 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 (sub # pat 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 (sub # pat) pl) + | Ppat_construct (l, p) -> + construct ~loc ~attrs (map_loc sub l) (map_opt (sub # pat) p) + | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub # pat) p) + | Ppat_record (lpl, cf) -> + 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_exception p -> exception_ ~loc ~attrs (sub # pat p) + | Ppat_extension x -> extension ~loc ~attrs (sub # extension x) + | Ppat_open (l, p) -> open_ ~loc ~attrs (map_loc sub l) (sub # pat p) +end + +module CE = struct + (* Value expressions for the class language *) + + let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = + let open Cl in + let loc = sub # location loc in + match desc with + | Pcl_constr (lid, tys) -> + constr ~loc ~attrs (map_loc sub lid) (List.map (sub # typ) tys) + | Pcl_structure s -> + structure ~loc ~attrs (sub # class_structure s) + | Pcl_fun (lab, e, p, ce) -> + fun_ ~loc ~attrs lab + (map_opt (sub # expr) e) + (sub # pat p) + (sub # class_expr ce) + | Pcl_apply (ce, l) -> + apply ~loc ~attrs (sub # class_expr ce) + (List.map (map_snd (sub # expr)) l) + | Pcl_let (r, vbs, ce) -> + let_ ~loc ~attrs r (List.map (sub # value_binding) vbs) + (sub # class_expr ce) + | Pcl_constraint (ce, ct) -> + constraint_ ~loc ~attrs (sub # class_expr ce) (sub # class_type ct) + | Pcl_extension x -> extension ~loc ~attrs (sub # extension x) + | Pcl_open (od, ce) -> + open_ ~loc ~attrs (sub # open_description od) (sub # class_expr ce) + + let map_kind sub = function + | Cfk_concrete (o, e) -> Cfk_concrete (o, sub # expr e) + | Cfk_virtual t -> Cfk_virtual (sub # typ t) + + let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = + let open Cf in + let loc = sub # location loc in + match desc with + | Pcf_inherit (o, ce, s) -> inherit_ ~loc ~attrs o (sub # class_expr 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 (sub # typ t1) (sub # typ t2) + | Pcf_initializer e -> initializer_ ~loc ~attrs (sub # expr e) + | Pcf_attribute x -> attribute ~loc (sub # attribute x) + | Pcf_extension x -> extension ~loc ~attrs (sub # extension x) + + let map_structure sub {pcstr_self; pcstr_fields} = + { + pcstr_self = sub # pat pcstr_self; + pcstr_fields = List.map (sub # class_field) pcstr_fields; + } + + let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; + pci_loc; pci_attributes} = + Ci.mk + ~virt:pci_virt + ~params:(List.map (map_fst (sub # typ)) pl) + (map_loc sub pci_name) + (f pci_expr) + ~loc:(sub # location pci_loc) + ~attrs:(sub # attributes pci_attributes) +end + +(* 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. *) + +class mapper = + object(this) + method structure l = List.map (this # structure_item) l + method structure_item si = M.map_structure_item this si + method module_expr = M.map this + + method signature l = List.map (this # signature_item) l + method signature_item si = MT.map_signature_item this si + method module_type = MT.map this + method with_constraint c = MT.map_with_constraint this c + + method class_declaration = CE.class_infos this (this # class_expr) + 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 + + method class_type_declaration = CE.class_infos this (this # class_type) + method class_description = CE.class_infos this (this # class_type) + + method binding_op = E.map_binding_op this + + method type_declaration = T.map_type_declaration this + method type_kind = T.map_type_kind this + method typ = T.map this + + method type_extension = T.map_type_extension this + method type_exception = T.map_type_exception this + method extension_constructor = T.map_extension_constructor this + + method value_description {pval_name; pval_type; pval_prim; pval_loc; + pval_attributes} = + Val.mk + (map_loc this pval_name) + (this # typ pval_type) + ~attrs:(this # attributes pval_attributes) + ~loc:(this # location pval_loc) + ~prim:pval_prim + + method pat = P.map this + method expr = E.map this + + method module_declaration {pmd_name; pmd_type; pmd_attributes; pmd_loc} = + Md.mk + (map_loc this pmd_name) + (this # module_type pmd_type) + ~attrs:(this # attributes pmd_attributes) + ~loc:(this # location pmd_loc) + + method module_substitution {pms_name; pms_manifest; pms_attributes; pms_loc} = + Ms.mk + (map_loc this pms_name) + (map_loc this pms_manifest) + ~attrs:(this # attributes pms_attributes) + ~loc:(this # location pms_loc) + + method module_type_declaration {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} = + Mtd.mk + (map_loc this pmtd_name) + ?typ:(map_opt (this # module_type) pmtd_type) + ~attrs:(this # attributes pmtd_attributes) + ~loc:(this # location pmtd_loc) + + method module_binding {pmb_name; pmb_expr; pmb_attributes; pmb_loc} = + Mb.mk (map_loc this pmb_name) (this # module_expr pmb_expr) + ~attrs:(this # attributes pmb_attributes) + ~loc:(this # location pmb_loc) + + method value_binding {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} = + Vb.mk + (this # pat pvb_pat) + (this # expr pvb_expr) + ~attrs:(this # attributes pvb_attributes) + ~loc:(this # location pvb_loc) + + method constructor_arguments = function + | Pcstr_tuple (tys) -> Pcstr_tuple (List.map (this # typ) tys) + | Pcstr_record (ls) -> Pcstr_record (List.map (this # label_declaration) ls) + + method constructor_declaration {pcd_name; pcd_args; pcd_res; pcd_loc; + pcd_attributes} = + Type.constructor + (map_loc this pcd_name) + ~args:(this # constructor_arguments pcd_args) + ?res:(map_opt (this # typ) pcd_res) + ~loc:(this # location pcd_loc) + ~attrs:(this # attributes pcd_attributes) + + method label_declaration {pld_name; pld_type; pld_loc; pld_mutable; + pld_attributes} = + Type.field + (map_loc this pld_name) + (this # typ pld_type) + ~mut:pld_mutable + ~loc:(this # location pld_loc) + ~attrs:(this # attributes pld_attributes) + + + method cases l = List.map (this # case) l + method case {pc_lhs; pc_guard; pc_rhs} = + { + pc_lhs = this # pat pc_lhs; + pc_guard = map_opt (this # expr) pc_guard; + pc_rhs = this # expr pc_rhs; + } + + method open_declaration + {popen_expr; popen_override; popen_attributes; popen_loc} = + Opn.mk (this # module_expr popen_expr) + ~override:popen_override + ~loc:(this # location popen_loc) + ~attrs:(this # attributes popen_attributes) + + method open_description + {popen_expr; popen_override; popen_attributes; popen_loc} = + Opn.mk (map_loc this popen_expr) + ~override:popen_override + ~loc:(this # location popen_loc) + ~attrs:(this # attributes popen_attributes) + + method include_description + {pincl_mod; pincl_attributes; pincl_loc} = + Incl.mk (this # module_type pincl_mod) + ~loc:(this # location pincl_loc) + ~attrs:(this # attributes pincl_attributes) + + method include_declaration + {pincl_mod; pincl_attributes; pincl_loc} = + Incl.mk (this # module_expr pincl_mod) + ~loc:(this # location pincl_loc) + ~attrs:(this # attributes pincl_attributes) + + method location l = l + + method extension (s, e) = (map_loc this s, this # payload e) + + method attribute a = + { + attr_name = map_loc this a.attr_name; + attr_payload = this # payload a.attr_payload; + attr_loc = this # location a.attr_loc; + } + + method attributes l = List.map (this # attribute) l + + method payload = function + | PStr x -> PStr (this # structure x) + | PTyp x -> PTyp (this # typ x) + | PPat (x, g) -> PPat (this # pat x, map_opt (this # expr) g) + | PSig x -> PSig (this # signature x) + end + + +let to_mapper this = + let open Ast_mapper in + { + attribute = (fun _ -> this # attribute); + attributes = (fun _ -> this # attributes); + binding_op = (fun _ -> this # binding_op); + case = (fun _ -> this # case); + cases = (fun _ -> this # cases); + class_declaration = (fun _ -> this # class_declaration); + class_description = (fun _ -> this # class_description); + class_expr = (fun _ -> this # class_expr); + class_field = (fun _ -> this # class_field); + class_signature = (fun _ -> this # class_signature); + class_structure = (fun _ -> this # class_structure); + class_type = (fun _ -> this # class_type); + class_type_declaration = (fun _ -> this # class_type_declaration); + class_type_field = (fun _ -> this # class_type_field); + constructor_declaration = (fun _ -> this # constructor_declaration); + expr = (fun _ -> this # expr); + extension = (fun _ -> this # extension); + extension_constructor = (fun _ -> this # extension_constructor); + include_declaration = (fun _ -> this # include_declaration); + include_description = (fun _ -> this # include_description); + label_declaration = (fun _ -> this # label_declaration); + location = (fun _ -> this # location); + module_binding = (fun _ -> this # module_binding); + module_declaration = (fun _ -> this # module_declaration); + module_expr = (fun _ -> this # module_expr); + module_substitution = (fun _ -> this # module_substitution); + module_type = (fun _ -> this # module_type); + module_type_declaration = (fun _ -> this # module_type_declaration); + open_declaration = (fun _ -> this # open_declaration); + open_description = (fun _ -> this # open_description); + pat = (fun _ -> this # pat); + payload = (fun _ -> this # payload); + signature = (fun _ -> this # signature); + signature_item = (fun _ -> this # signature_item); + structure = (fun _ -> this # structure); + structure_item = (fun _ -> this # structure_item); + typ = (fun _ -> this # typ); + type_declaration = (fun _ -> this # type_declaration); + type_exception = (fun _ -> this # type_exception); + type_extension = (fun _ -> this # type_extension); + type_kind = (fun _ -> this # type_kind); + value_binding = (fun _ -> this # value_binding); + value_description = (fun _ -> this # value_description); + with_constraint = (fun _ -> this # with_constraint); + } diff --git a/410/ast_mapper_class.mli b/410/ast_mapper_class.mli new file mode 100644 index 0000000..9829378 --- /dev/null +++ b/410/ast_mapper_class.mli @@ -0,0 +1,60 @@ +(* This file is part of the ppx_tools package. It is released *) +(* under the terms of the MIT license (see LICENSE file). *) +(* Copyright 2013 Alain Frisch and LexiFi *) + +(** Class-based customizable mapper *) + +open Parsetree + +class mapper: + object + method attribute: attribute -> attribute + method attributes: attribute list -> attribute list + method binding_op: binding_op -> binding_op + method case: case -> case + method cases: case list -> case list + method class_declaration: class_declaration -> class_declaration + method class_description: class_description -> class_description + method class_expr: class_expr -> class_expr + method class_field: class_field -> class_field + method class_signature: class_signature -> class_signature + method class_structure: class_structure -> class_structure + method class_type: class_type -> class_type + method class_type_declaration: class_type_declaration -> class_type_declaration + method class_type_field: class_type_field -> class_type_field + method constructor_arguments: constructor_arguments -> constructor_arguments + method constructor_declaration: constructor_declaration -> constructor_declaration + method expr: expression -> expression + method extension: extension -> extension + method extension_constructor: extension_constructor -> extension_constructor + method include_declaration: include_declaration -> include_declaration + method include_description: include_description -> include_description + method label_declaration: label_declaration -> label_declaration + method location: Location.t -> Location.t + method module_binding: module_binding -> module_binding + method module_declaration: module_declaration -> module_declaration + method module_substitution: module_substitution -> module_substitution + method module_expr: module_expr -> module_expr + method module_type: module_type -> module_type + method module_type_declaration: module_type_declaration -> module_type_declaration + method open_declaration: open_declaration -> open_declaration + method open_description: open_description -> open_description + method pat: pattern -> pattern + method payload: payload -> payload + method signature: signature -> signature + method signature_item: signature_item -> signature_item + method structure: structure -> structure + method structure_item: structure_item -> structure_item + method typ: core_type -> core_type + method type_declaration: type_declaration -> type_declaration + method type_exception: type_exception -> type_exception + method type_extension: type_extension -> type_extension + method type_kind: type_kind -> type_kind + method value_binding: value_binding -> value_binding + method value_description: value_description -> value_description + method with_constraint: with_constraint -> with_constraint + end + +val to_mapper: #mapper -> Ast_mapper.mapper +(** The resulting mapper is "closed", i.e. methods ignore + their first argument. *) diff --git a/410/dumpast.ml b/410/dumpast.ml new file mode 100644 index 0000000..3929cd4 --- /dev/null +++ b/410/dumpast.ml @@ -0,0 +1,121 @@ +(* This file is part of the ppx_tools package. It is released *) +(* under the terms of the MIT license (see LICENSE file). *) +(* Copyright 2013 Alain Frisch and LexiFi *) + +(* Illustrate how to use AST lifting to create a pretty-printer *) + +open Outcometree + +let locs = ref (`Discard : [`Discard|`Underscore|`Keep]) +let attrs = ref (`Discard_empty : [`Discard|`Underscore|`Keep|`Discard_empty]) + +class out_value_builder = + object + method record (_ty : string) x = + let x = + List.filter (function (_, Oval_ellipsis) -> false | _ -> true) x + in + let f (l, s) = Oide_ident { printed_name = l }, s in + Oval_record (List.map f x) + method constr (_ty : string) (c, args) = + Oval_constr (Oide_ident { printed_name = c }, args) + method list x = Oval_list x + method array x = Oval_list (Array.to_list x) + method tuple x = Oval_tuple x + method int x = Oval_int x + method string x = Oval_string (x, max_int, Ostr_string) + method char x = Oval_char x + method int32 x = Oval_int32 x + method int64 x = Oval_int64 x + method nativeint x = Oval_nativeint x + end + +let lift = + object + inherit [_] Ast_lifter.lifter as super + inherit out_value_builder + method! lift_Location_t l = + match !locs with + | `Discard -> Oval_ellipsis + | `Underscore -> Oval_stuff "_" + | `Keep -> super # lift_Location_t l + method! lift_Parsetree_attributes l = + match !attrs, l with + | `Discard, _ | `Discard_empty, [] -> Oval_ellipsis + | `Underscore, _ -> Oval_stuff "_" + | `Keep, _ | (`Discard_empty, _ :: _) -> + super # lift_Parsetree_attributes l + end + +let show lifter parse s = + let v = lifter (parse (Lexing.from_string s)) in + Format.printf "%s@.==>@.%a@.=========@." s !Oprint.out_value v + +let show_expr = show (lift # lift_Parsetree_expression) Parse.expression +let show_pat = show (lift # lift_Parsetree_pattern) Parse.pattern +let show_typ = show (lift # lift_Parsetree_core_type) Parse.core_type + +let show_file fn = + Compenv.readenv Format.err_formatter (Compenv.Before_compile fn); + let v = + if Filename.check_suffix fn ".mli" then + let ast = Pparse.parse_interface ~tool_name:"ocamlc" fn in + lift # lift_Parsetree_signature ast + else if Filename.check_suffix fn ".ml" then + let ast = Pparse.parse_implementation ~tool_name:"ocamlc" fn in + lift # lift_Parsetree_structure ast + else + failwith (Printf.sprintf "Don't know what to do with file %s" fn) + in + Format.printf "%s@.==>@.%a@.=========@." fn !Oprint.out_value v + +let args = + let open Arg in + [ + "-e", String show_expr, + " Dump AST for expression ."; + + "-p", String show_pat, + " Dump AST for pattern ."; + + "-t", String show_typ, + " Dump AST for type expression ."; + + "-loc_discard", Unit (fun () -> locs := `Discard), + " Discard location fields. (default)"; + + "-loc_underscore", Unit (fun () -> locs := `Underscore), + " Display '_' for location fields"; + + "-loc_keep", Unit (fun () -> locs := `Keep), + " Display real value of location fields"; + + "-attrs_discard_empty", Unit (fun () -> attrs := `Discard_empty), + " Discard empty attribute fields. (default)"; + + "-attrs_discard", Unit (fun () -> attrs := `Discard), + " Discard all attribute fields."; + + "-attrs_underscore", Unit (fun () -> attrs := `Underscore), + " Display '_' for attribute fields"; + + "-attrs_keep", Unit (fun () -> attrs := `Keep), + " Display real value of attribute fields"; + + "-pp", Arg.String (fun s -> Clflags.preprocessor := Some s), + " Pipe sources through preprocessor "; + + "-ppx", Arg.String (fun s -> Compenv.first_ppx := s :: !Compenv.first_ppx), + " Pipe abstract syntax trees through preprocessor "; + ] + + +let usage = + Printf.sprintf "%s [options] [.ml/.mli files]\n" Sys.argv.(0) + +let () = + Compenv.readenv Format.err_formatter Compenv.Before_args; + try Arg.parse (Arg.align args) show_file usage + with exn -> + Errors.report_error Format.err_formatter exn; + exit 2 diff --git a/410/genlifter.ml b/410/genlifter.ml new file mode 100644 index 0000000..e0b9696 --- /dev/null +++ b/410/genlifter.ml @@ -0,0 +1,234 @@ +(* This file is part of the ppx_tools package. It is released *) +(* under the terms of the MIT license (see LICENSE file). *) +(* Copyright 2013 Alain Frisch and LexiFi *) + + +(* Generate code to lift values of a certain type. + This illustrates how to build fragments of Parsetree through + Ast_helper and more local helper functions. *) + +module Main : sig end = struct + + open Location + open Types + open Asttypes + open Ast_helper + open Ast_convenience + + let selfcall ?(this = "this") m args = app (Exp.send (evar this) (mknoloc m)) args + + (*************************************************************************) + + + let env = Env.initial_safe_string + + let clean s = + let s = Bytes.of_string s in + for i = 0 to Bytes.length s - 1 do + if Bytes.get s i = '.' then Bytes.set s i '_' + done; + Bytes.to_string s + + let print_fun s = "lift_" ^ clean s + + let printed = Hashtbl.create 16 + let meths = ref [] + let use_existentials = ref false + let use_arrows = ref false + + let existential_method = + Cf.(method_ (mknoloc "existential") Public + (virtual_ Typ.(poly [mknoloc "a"] (arrow Nolabel (var "a") (var "res")))) + ) + + let arrow_method = + Cf.(method_ (mknoloc "arrow") Public + (virtual_ Typ.(poly [mknoloc "a"] (arrow Nolabel (var "a") (var "res")))) + ) + + let rec gen ty = + if Hashtbl.mem printed ty then () + else let tylid = Longident.parse ty in + let td = + try snd (Env.find_type_by_name tylid env) + with Not_found -> + Format.eprintf "** Cannot resolve type %s@." ty; + exit 2 + in + let prefix = + let open Longident in + match tylid with + | Ldot (m, _) -> String.concat "." (Longident.flatten m) ^ "." + | Lident _ -> "" + | Lapply _ -> assert false + in + Hashtbl.add printed ty (); + let params = List.mapi (fun i _ -> mknoloc (Printf.sprintf "f%i" i)) td.type_params in + let env = List.map2 (fun s t -> t.id, evar s.txt) params td.type_params in + let make_result_t tyargs = Typ.(arrow Asttypes.Nolabel (constr (lid ty) tyargs) (var "res")) in + let make_t tyargs = + List.fold_right + (fun arg t -> + Typ.(arrow Asttypes.Nolabel (arrow Asttypes.Nolabel arg (var "res")) t)) + tyargs (make_result_t tyargs) + in + let tyargs = List.map (fun t -> Typ.var t.txt) params in + let t = Typ.poly params (make_t tyargs) in + let concrete e = + let e = List.fold_right (fun x e -> lam x e) (List.map (fun x -> pvar x.txt) params) e in + let tyargs = List.map (fun t -> Typ.constr (lid t.txt) []) params in + let e = Exp.constraint_ e (make_t tyargs) in + let e = List.fold_right (fun x e -> Exp.newtype x e) params e in + let body = Exp.poly e (Some t) in + meths := Cf.(method_ (mknoloc (print_fun ty)) Public (concrete Fresh body)) :: !meths + in + let field ld = + let s = Ident.name ld.ld_id in + (lid (prefix ^ s), pvar s), + tuple[str s; tyexpr env ld.ld_type (evar s)] + in + match td.type_kind, td.type_manifest with + | Type_record (l, _), _ -> + let l = List.map field l in + concrete + (lam + (Pat.record (List.map fst l) Closed) + (selfcall "record" [str ty; list (List.map snd l)])) + | Type_variant l, _ -> + let case cd = + let c = Ident.name cd.cd_id in + let qc = prefix ^ c in + match cd.cd_args with + | Cstr_tuple (tys) -> + let p, args = gentuple env tys in + pconstr qc p, selfcall "constr" [str ty; tuple[str c; list args]] + | Cstr_record (l) -> + let l = List.map field l in + let keep_head ((lid, pattern), _) = + let txt = Longident.Lident (Longident.last lid.txt) in + ({lid with txt}, pattern) + in + pconstr qc [Pat.record (List.map keep_head l) Closed], + selfcall "constr" + [str ty; + tuple [str c; + list [selfcall "record" + [str ""; list (List.map snd l)]]]] + in + concrete (func (List.map case l)) + | Type_abstract, Some t -> + concrete (tyexpr_fun env t) + | Type_abstract, None -> + (* Generate an abstract method to lift abstract types *) + meths := Cf.(method_ (mknoloc (print_fun ty)) Public (virtual_ t)) :: !meths + | Type_open, _ -> + failwith "Open types are not yet supported." + + and gentuple env tl = + let arg i t = + let x = Printf.sprintf "x%i" i in + pvar x, tyexpr env t (evar x) + in + List.split (List.mapi arg tl) + + and tyexpr env ty x = + match ty.desc with + | Tvar _ -> + (match List.assoc ty.id env with + | f -> app f [x] + | exception Not_found -> + use_existentials := true; + selfcall "existential" [x]) + | Ttuple tl -> + let p, e = gentuple env tl in + let_in [Vb.mk (Pat.tuple p) x] (selfcall "tuple" [list e]) + | Tconstr (path, [t], _) when Path.same path Predef.path_list -> + selfcall "list" [app (evar "List.map") [tyexpr_fun env t; x]] + | Tconstr (path, [t], _) when Path.same path Predef.path_array -> + selfcall "array" [app (evar "Array.map") [tyexpr_fun env t; x]] + | Tconstr (path, [], _) when Path.same path Predef.path_string -> + selfcall "string" [x] + | Tconstr (path, [], _) when Path.same path Predef.path_int -> + selfcall "int" [x] + | Tconstr (path, [], _) when Path.same path Predef.path_char -> + selfcall "char" [x] + | Tconstr (path, [], _) when Path.same path Predef.path_int32 -> + selfcall "int32" [x] + | Tconstr (path, [], _) when Path.same path Predef.path_int64 -> + selfcall "int64" [x] + | Tconstr (path, [], _) when Path.same path Predef.path_nativeint -> + selfcall "nativeint" [x] + | Tconstr (path, tl, _) -> + let ty = Path.name path in + gen ty; + selfcall (print_fun ty) (List.map (tyexpr_fun env) tl @ [x]) + | Tarrow _ -> + use_arrows := true; + selfcall "arrow" [x] + | _ -> + Format.eprintf "** Cannot deal with type %a@." Printtyp.type_expr ty; + exit 2 + + and tyexpr_fun env ty = + lam (pvar "x") (tyexpr env ty (evar "x")) + + let simplify = + (* (fun x -> x) ====> *) + let open Ast_mapper in + let super = default_mapper in + let expr this e = + let e = super.expr this e in + let open Longident in + let open Parsetree in + match e.pexp_desc with + | Pexp_fun + (Asttypes.Nolabel, None, + {ppat_desc = Ppat_var{txt=id;_};_}, + {pexp_desc = + Pexp_apply + (f, + [Asttypes.Nolabel + ,{pexp_desc= Pexp_ident{txt=Lident id2;_};_}]);_}) + when id = id2 -> f + | _ -> e + in + {super with expr} + + let args = + let open Arg in + [ + "-I", String (fun s -> Load_path.add_dir (Misc.expand_directory Config.standard_library s)), + " Add to the list of include directories"; + ] + + let usage = + Printf.sprintf "%s [options] \n" Sys.argv.(0) + + let main () = + Load_path.init [Config.standard_library]; + Arg.parse (Arg.align args) gen usage; + let meths = !meths in + let meths = + if !use_existentials then + existential_method :: meths + else + meths + in + let meths = + if !use_arrows then + arrow_method :: meths + else + meths + in + let cl = Cstr.mk (pvar "this") meths in + let params = [Typ.var "res", Invariant] in + let cl = Ci.mk ~virt:Virtual ~params (mknoloc "lifter") (Cl.structure cl) in + let s = [Str.class_ [cl]] in + Format.printf "%a@." Pprintast.structure (simplify.Ast_mapper.structure simplify s) + + let () = + try main () + with exn -> + Printf.eprintf "** fatal error: %s\n%!" (Printexc.to_string exn) + +end diff --git a/410/ppx_metaquot.ml b/410/ppx_metaquot.ml new file mode 100644 index 0000000..943c06a --- /dev/null +++ b/410/ppx_metaquot.ml @@ -0,0 +1,288 @@ +(* This file is part of the ppx_tools package. It is released *) +(* under the terms of the MIT license (see LICENSE file). *) +(* Copyright 2013 Alain Frisch and LexiFi *) + +(* A -ppx rewriter to be used to write Parsetree-generating code + (including other -ppx rewriters) using concrete syntax. + + We support the following extensions in expression position: + + [%expr ...] maps to code which creates the expression represented by ... + [%pat? ...] maps to code which creates the pattern represented by ... + [%str ...] maps to code which creates the structure represented by ... + [%stri ...] maps to code which creates the structure item represented by ... + [%sig: ...] maps to code which creates the signature represented by ... + [%sigi: ...] maps to code which creates the signature item represented by ... + [%type: ...] maps to code which creates the core type represented by ... + + Quoted code can refer to expressions representing AST fragments, + using the following extensions: + + [%e ...] where ... is an expression of type Parsetree.expression + [%t ...] where ... is an expression of type Parsetree.core_type + [%p ...] where ... is an expression of type Parsetree.pattern + [%%s ...] where ... is an expression of type Parsetree.structure + or Parsetree.signature depending on the context. + + + All locations generated by the meta quotation are by default set + to [Ast_helper.default_loc]. This can be overriden by providing a custom + expression which will be inserted whereever a location is required + in the generated AST. This expression can be specified globally + (for the current structure) as a structure item attribute: + + ;;[@@metaloc ...] + + or locally for the scope of an expression: + + e [@metaloc ...] + + + + Support is also provided to use concrete syntax in pattern + position. The location and attribute fields are currently ignored + by patterns generated from meta quotations. + + We support the following extensions in pattern position: + + [%expr ...] maps to code which creates the expression represented by ... + [%pat? ...] maps to code which creates the pattern represented by ... + [%str ...] maps to code which creates the structure represented by ... + [%type: ...] maps to code which creates the core type represented by ... + + Quoted code can refer to expressions representing AST fragments, + using the following extensions: + + [%e? ...] where ... is a pattern of type Parsetree.expression + [%t? ...] where ... is a pattern of type Parsetree.core_type + [%p? ...] where ... is a pattern of type Parsetree.pattern + +*) + +module Main : sig + val main : unit -> unit +end = struct + open Asttypes + open Parsetree + open Ast_helper + open Ast_convenience + + let prefix ty s = + let open Longident in + match parse ty with + | Ldot(m, _) -> String.concat "." (Longident.flatten m) ^ "." ^ s + | _ -> s + + let append ?loc ?attrs e e' = + let fn = Location.mknoloc (Longident.(Ldot (Lident "List", "append"))) in + Exp.apply ?loc ?attrs (Exp.ident fn) [Nolabel, e; Nolabel, e'] + + class exp_builder = + object + method record ty x = record (List.map (fun (l, e) -> prefix ty l, e) x) + method constr ty (c, args) = constr (prefix ty c) args + method list l = list l + method tuple l = tuple l + method int i = int i + method string s = str s + method char c = char c + method int32 x = Exp.constant (Const.int32 x) + method int64 x = Exp.constant (Const.int64 x) + method nativeint x = Exp.constant (Const.nativeint x) + end + + class pat_builder = + object + method record ty x = precord ~closed:Closed (List.map (fun (l, e) -> prefix ty l, e) x) + method constr ty (c, args) = pconstr (prefix ty c) args + method list l = plist l + method tuple l = ptuple l + method int i = pint i + method string s = pstr s + method char c = pchar c + method int32 x = Pat.constant (Const.int32 x) + method int64 x = Pat.constant (Const.int64 x) + method nativeint x = Pat.constant (Const.nativeint x) + end + + + let get_exp loc = function + | PStr [ {pstr_desc=Pstr_eval (e, _); _} ] -> e + | _ -> + let report = Location.error ~loc "Expression expected." in + Location.print_report Format.err_formatter report; + exit 2 + + let get_typ loc = function + | PTyp t -> t + | _ -> + let report = Location.error ~loc "Type expected." in + Location.print_report Format.err_formatter report; + exit 2 + + let get_pat loc = function + | PPat (t, None) -> t + | _ -> + let report = Location.error ~loc "Pattern expected." in + Location.print_report Format.err_formatter report; + exit 2 + + let exp_lifter loc map = + let map = map.Ast_mapper.expr map in + object + inherit [_] Ast_lifter.lifter as super + inherit exp_builder + + (* Special support for location in the generated AST *) + method! lift_Location_t _ = loc + + (* Support for antiquotations *) + method! lift_Parsetree_expression = function + | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> map (get_exp loc e) + | x -> super # lift_Parsetree_expression x + + method! lift_Parsetree_pattern = function + | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> map (get_exp loc e) + | x -> super # lift_Parsetree_pattern x + + method! lift_Parsetree_structure str = + List.fold_right + (function + | {pstr_desc=Pstr_extension(({txt="s";loc}, e), _); _} -> + append (get_exp loc e) + | x -> + cons (super # lift_Parsetree_structure_item x)) + str (nil ()) + + method! lift_Parsetree_signature sign = + List.fold_right + (function + | {psig_desc=Psig_extension(({txt="s";loc}, e), _); _} -> + append (get_exp loc e) + | x -> + cons (super # lift_Parsetree_signature_item x)) + sign (nil ()) + + method! lift_Parsetree_core_type = function + | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} ->map (get_exp loc e) + | x -> super # lift_Parsetree_core_type x + end + + let pat_lifter map = + let map = map.Ast_mapper.pat map in + object + inherit [_] Ast_lifter.lifter as super + inherit pat_builder as builder + + (* Special support for location and attributes in the generated AST *) + method! lift_Location_t _ = Pat.any () + method! lift_Parsetree_attributes _ = Pat.any () + method! record n fields = + let fields = + List.map (fun (name, pat) -> + match name with + | "pexp_loc_stack" | "ppat_loc_stack" | "ptyp_loc_stack" -> + name, Pat.any () + | _ -> name, pat) fields + in + builder#record n fields + + (* Support for antiquotations *) + method! lift_Parsetree_expression = function + | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> map (get_pat loc e) + | x -> super # lift_Parsetree_expression x + + method! lift_Parsetree_pattern = function + | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> map (get_pat loc e) + | x -> super # lift_Parsetree_pattern x + + method! lift_Parsetree_core_type = function + | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} -> map (get_pat loc e) + | x -> super # lift_Parsetree_core_type x + end + + let loc = ref (app (evar "Stdlib.!") [evar "Ast_helper.default_loc"]) + + let handle_attr = function + | {attr_name={txt="metaloc";loc=l}; attr_payload=e; _} -> loc := get_exp l e + | _ -> () + + let with_loc ?(attrs = []) f = + let old_loc = !loc in + List.iter handle_attr attrs; + let r = f () in + loc := old_loc; + r + + let expander _args = + let open Ast_mapper in + let super = default_mapper in + let expr this e = + with_loc ~attrs:e.pexp_attributes + (fun () -> + match e.pexp_desc with + | Pexp_extension({txt="expr";loc=l}, e) -> + (exp_lifter !loc this) # lift_Parsetree_expression (get_exp l e) + | Pexp_extension({txt="pat";loc=l}, e) -> + (exp_lifter !loc this) # lift_Parsetree_pattern (get_pat l e) + | Pexp_extension({txt="str";_}, PStr e) -> + (exp_lifter !loc this) # lift_Parsetree_structure e + | Pexp_extension({txt="stri";_}, PStr [e]) -> + (exp_lifter !loc this) # lift_Parsetree_structure_item e + | Pexp_extension({txt="sig";_}, PSig e) -> + (exp_lifter !loc this) # lift_Parsetree_signature e + | Pexp_extension({txt="sigi";_}, PSig [e]) -> + (exp_lifter !loc this) # lift_Parsetree_signature_item e + | Pexp_extension({txt="type";loc=l}, e) -> + (exp_lifter !loc this) # lift_Parsetree_core_type (get_typ l e) + | _ -> + super.expr this e + ) + and pat this p = + with_loc ~attrs:p.ppat_attributes + (fun () -> + match p.ppat_desc with + | Ppat_extension({txt="expr";loc=l}, e) -> + (pat_lifter this) # lift_Parsetree_expression (get_exp l e) + | Ppat_extension({txt="pat";loc=l}, e) -> + (pat_lifter this) # lift_Parsetree_pattern (get_pat l e) + | Ppat_extension({txt="str";_}, PStr e) -> + (pat_lifter this) # lift_Parsetree_structure e + | Ppat_extension({txt="stri";_}, PStr [e]) -> + (pat_lifter this) # lift_Parsetree_structure_item e + | Ppat_extension({txt="sig";_}, PSig e) -> + (pat_lifter this) # lift_Parsetree_signature e + | Ppat_extension({txt="sigi";_}, PSig [e]) -> + (pat_lifter this) # lift_Parsetree_signature_item e + | Ppat_extension({txt="type";loc=l}, e) -> + (pat_lifter this) # lift_Parsetree_core_type (get_typ l e) + | _ -> + super.pat this p + ) + and structure this l = + with_loc + (fun () -> super.structure this l) + + and structure_item this x = + begin match x.pstr_desc with + | Pstr_attribute x -> handle_attr x + | _ -> () + end; + super.structure_item this x + + and signature this l = + with_loc + (fun () -> super.signature this l) + + and signature_item this x = + begin match x.psig_desc with + | Psig_attribute x -> handle_attr x + | _ -> () + end; + super.signature_item this x + + in + {super with expr; pat; structure; structure_item; signature; signature_item} + + let main () = Ast_mapper.run_main expander +end diff --git a/410/ppx_metaquot_main.ml b/410/ppx_metaquot_main.ml new file mode 100644 index 0000000..4bab3f6 --- /dev/null +++ b/410/ppx_metaquot_main.ml @@ -0,0 +1 @@ +let () = Ppx_metaquot.Main.main () diff --git a/410/rewriter.ml b/410/rewriter.ml new file mode 100644 index 0000000..6de0d16 --- /dev/null +++ b/410/rewriter.ml @@ -0,0 +1,106 @@ +(* This file is part of the ppx_tools package. It is released *) +(* under the terms of the MIT license (see LICENSE file). *) +(* Copyright 2014 Peter Zotov *) + +let inputs : ([ `Struct | `Sig ] * [ `String | `Path ] * string) list ref = ref [] +let output_file : string ref = ref "-" +let tool_name = ref "ocamlc" + +let args = + let open Arg in + align [ + "-ppx", String (fun s -> Clflags.all_ppx := s :: !Clflags.all_ppx), + " Invoke as a ppx preprocessor"; + + "-str", String (fun s -> inputs := (`Struct, `String, s) :: !inputs), + " Parse as a structure"; + + "-sig", String (fun s -> inputs := (`Sig, `String, s) :: !inputs), + " Parse as a signature"; + + "-impl", String (fun s -> inputs := (`Struct, `Path, s) :: !inputs), + " Parse as an implementation (specify - for stdin)"; + + "-intf", String (fun s -> inputs := (`Sig, `Path, s) :: !inputs), + " Parse as an interface (specify - for stdin)"; + + "-o", Set_string output_file, + " Write result into (stdout by default)"; + + "-tool-name", Set_string tool_name, + " Set tool name to (ocamlc by default)"; + + "-I", String (fun s -> Clflags.include_dirs := s :: !Clflags.include_dirs), + " Add to the list of include directories"; + + "-open", String (fun s -> Clflags.open_modules := s :: !Clflags.open_modules), + " Add to the list of opened modules"; + + "-for-pack", String (fun s -> Clflags.for_package := Some s), + " Preprocess code as if it will be packed inside "; + + "-g", Set Clflags.debug, + " Request debug information from preprocessor"; + ] + +let anon_arg s = + match !Clflags.all_ppx with + | [] -> Clflags.all_ppx := s :: !Clflags.all_ppx + | _ -> inputs := (`Struct, `Path, s) :: !inputs + +let usage_msg = + Printf.sprintf + "Usage: %s [ppx-rewriter] [options...] [implementations...]\n\ + If no implementations are specified, parses stdin." + Sys.argv.(0) + +let wrap_open fn file = + try fn file + with Sys_error msg -> + prerr_endline msg; + exit 1 + +let make_lexer source_kind source = + match source_kind, source with + | `String, _ -> + Location.input_name := "//toplevel//"; + Lexing.from_string source + | `Path, "-" -> + Location.input_name := "//toplevel//"; + Lexing.from_channel stdin + | `Path, _ -> + Location.input_name := source; + Lexing.from_channel (wrap_open open_in source) + +let () = + Arg.parse args anon_arg usage_msg; + if !Clflags.all_ppx = [] then begin + Arg.usage args usage_msg; + exit 1 + end; + if !inputs = [] then + inputs := [`Struct, `Path, "-"]; + let fmt = + match !output_file with + | "-" -> Format.std_formatter + | file -> Format.formatter_of_out_channel (wrap_open open_out file) + in + try + !inputs |> List.iter (fun (ast_kind, source_kind, source) -> + let lexer = make_lexer source_kind source in + match ast_kind with + | `Struct -> + let pstr = Parse.implementation lexer in + let pstr = Pparse.apply_rewriters (* ~restore:true *) ~tool_name:!tool_name + Pparse.Structure pstr in + Pprintast.structure fmt pstr; + Format.pp_print_newline fmt () + | `Sig -> + let psig = Parse.interface lexer in + let psig = Pparse.apply_rewriters (* ~restore:true *) ~tool_name:!tool_name + Pparse.Signature psig in + Pprintast.signature fmt psig; + Format.pp_print_newline fmt ()) + with exn -> + Location.report_exception Format.err_formatter exn; + exit 2 diff --git a/ast_convenience.ml b/411/ast_convenience.ml similarity index 100% rename from ast_convenience.ml rename to 411/ast_convenience.ml diff --git a/ast_convenience.mli b/411/ast_convenience.mli similarity index 100% rename from ast_convenience.mli rename to 411/ast_convenience.mli diff --git a/ast_mapper_class.ml b/411/ast_mapper_class.ml similarity index 100% rename from ast_mapper_class.ml rename to 411/ast_mapper_class.ml diff --git a/ast_mapper_class.mli b/411/ast_mapper_class.mli similarity index 100% rename from ast_mapper_class.mli rename to 411/ast_mapper_class.mli diff --git a/411/dumpast.ml b/411/dumpast.ml new file mode 100644 index 0000000..3929cd4 --- /dev/null +++ b/411/dumpast.ml @@ -0,0 +1,121 @@ +(* This file is part of the ppx_tools package. It is released *) +(* under the terms of the MIT license (see LICENSE file). *) +(* Copyright 2013 Alain Frisch and LexiFi *) + +(* Illustrate how to use AST lifting to create a pretty-printer *) + +open Outcometree + +let locs = ref (`Discard : [`Discard|`Underscore|`Keep]) +let attrs = ref (`Discard_empty : [`Discard|`Underscore|`Keep|`Discard_empty]) + +class out_value_builder = + object + method record (_ty : string) x = + let x = + List.filter (function (_, Oval_ellipsis) -> false | _ -> true) x + in + let f (l, s) = Oide_ident { printed_name = l }, s in + Oval_record (List.map f x) + method constr (_ty : string) (c, args) = + Oval_constr (Oide_ident { printed_name = c }, args) + method list x = Oval_list x + method array x = Oval_list (Array.to_list x) + method tuple x = Oval_tuple x + method int x = Oval_int x + method string x = Oval_string (x, max_int, Ostr_string) + method char x = Oval_char x + method int32 x = Oval_int32 x + method int64 x = Oval_int64 x + method nativeint x = Oval_nativeint x + end + +let lift = + object + inherit [_] Ast_lifter.lifter as super + inherit out_value_builder + method! lift_Location_t l = + match !locs with + | `Discard -> Oval_ellipsis + | `Underscore -> Oval_stuff "_" + | `Keep -> super # lift_Location_t l + method! lift_Parsetree_attributes l = + match !attrs, l with + | `Discard, _ | `Discard_empty, [] -> Oval_ellipsis + | `Underscore, _ -> Oval_stuff "_" + | `Keep, _ | (`Discard_empty, _ :: _) -> + super # lift_Parsetree_attributes l + end + +let show lifter parse s = + let v = lifter (parse (Lexing.from_string s)) in + Format.printf "%s@.==>@.%a@.=========@." s !Oprint.out_value v + +let show_expr = show (lift # lift_Parsetree_expression) Parse.expression +let show_pat = show (lift # lift_Parsetree_pattern) Parse.pattern +let show_typ = show (lift # lift_Parsetree_core_type) Parse.core_type + +let show_file fn = + Compenv.readenv Format.err_formatter (Compenv.Before_compile fn); + let v = + if Filename.check_suffix fn ".mli" then + let ast = Pparse.parse_interface ~tool_name:"ocamlc" fn in + lift # lift_Parsetree_signature ast + else if Filename.check_suffix fn ".ml" then + let ast = Pparse.parse_implementation ~tool_name:"ocamlc" fn in + lift # lift_Parsetree_structure ast + else + failwith (Printf.sprintf "Don't know what to do with file %s" fn) + in + Format.printf "%s@.==>@.%a@.=========@." fn !Oprint.out_value v + +let args = + let open Arg in + [ + "-e", String show_expr, + " Dump AST for expression ."; + + "-p", String show_pat, + " Dump AST for pattern ."; + + "-t", String show_typ, + " Dump AST for type expression ."; + + "-loc_discard", Unit (fun () -> locs := `Discard), + " Discard location fields. (default)"; + + "-loc_underscore", Unit (fun () -> locs := `Underscore), + " Display '_' for location fields"; + + "-loc_keep", Unit (fun () -> locs := `Keep), + " Display real value of location fields"; + + "-attrs_discard_empty", Unit (fun () -> attrs := `Discard_empty), + " Discard empty attribute fields. (default)"; + + "-attrs_discard", Unit (fun () -> attrs := `Discard), + " Discard all attribute fields."; + + "-attrs_underscore", Unit (fun () -> attrs := `Underscore), + " Display '_' for attribute fields"; + + "-attrs_keep", Unit (fun () -> attrs := `Keep), + " Display real value of attribute fields"; + + "-pp", Arg.String (fun s -> Clflags.preprocessor := Some s), + " Pipe sources through preprocessor "; + + "-ppx", Arg.String (fun s -> Compenv.first_ppx := s :: !Compenv.first_ppx), + " Pipe abstract syntax trees through preprocessor "; + ] + + +let usage = + Printf.sprintf "%s [options] [.ml/.mli files]\n" Sys.argv.(0) + +let () = + Compenv.readenv Format.err_formatter Compenv.Before_args; + try Arg.parse (Arg.align args) show_file usage + with exn -> + Errors.report_error Format.err_formatter exn; + exit 2 diff --git a/genlifter.ml b/411/genlifter.ml similarity index 100% rename from genlifter.ml rename to 411/genlifter.ml diff --git a/ppx_metaquot.ml b/411/ppx_metaquot.ml similarity index 100% rename from ppx_metaquot.ml rename to 411/ppx_metaquot.ml diff --git a/411/ppx_metaquot_main.ml b/411/ppx_metaquot_main.ml new file mode 100644 index 0000000..4bab3f6 --- /dev/null +++ b/411/ppx_metaquot_main.ml @@ -0,0 +1 @@ +let () = Ppx_metaquot.Main.main () diff --git a/411/rewriter.ml b/411/rewriter.ml new file mode 100644 index 0000000..6de0d16 --- /dev/null +++ b/411/rewriter.ml @@ -0,0 +1,106 @@ +(* This file is part of the ppx_tools package. It is released *) +(* under the terms of the MIT license (see LICENSE file). *) +(* Copyright 2014 Peter Zotov *) + +let inputs : ([ `Struct | `Sig ] * [ `String | `Path ] * string) list ref = ref [] +let output_file : string ref = ref "-" +let tool_name = ref "ocamlc" + +let args = + let open Arg in + align [ + "-ppx", String (fun s -> Clflags.all_ppx := s :: !Clflags.all_ppx), + " Invoke as a ppx preprocessor"; + + "-str", String (fun s -> inputs := (`Struct, `String, s) :: !inputs), + " Parse as a structure"; + + "-sig", String (fun s -> inputs := (`Sig, `String, s) :: !inputs), + " Parse as a signature"; + + "-impl", String (fun s -> inputs := (`Struct, `Path, s) :: !inputs), + " Parse as an implementation (specify - for stdin)"; + + "-intf", String (fun s -> inputs := (`Sig, `Path, s) :: !inputs), + " Parse as an interface (specify - for stdin)"; + + "-o", Set_string output_file, + " Write result into (stdout by default)"; + + "-tool-name", Set_string tool_name, + " Set tool name to (ocamlc by default)"; + + "-I", String (fun s -> Clflags.include_dirs := s :: !Clflags.include_dirs), + " Add to the list of include directories"; + + "-open", String (fun s -> Clflags.open_modules := s :: !Clflags.open_modules), + " Add to the list of opened modules"; + + "-for-pack", String (fun s -> Clflags.for_package := Some s), + " Preprocess code as if it will be packed inside "; + + "-g", Set Clflags.debug, + " Request debug information from preprocessor"; + ] + +let anon_arg s = + match !Clflags.all_ppx with + | [] -> Clflags.all_ppx := s :: !Clflags.all_ppx + | _ -> inputs := (`Struct, `Path, s) :: !inputs + +let usage_msg = + Printf.sprintf + "Usage: %s [ppx-rewriter] [options...] [implementations...]\n\ + If no implementations are specified, parses stdin." + Sys.argv.(0) + +let wrap_open fn file = + try fn file + with Sys_error msg -> + prerr_endline msg; + exit 1 + +let make_lexer source_kind source = + match source_kind, source with + | `String, _ -> + Location.input_name := "//toplevel//"; + Lexing.from_string source + | `Path, "-" -> + Location.input_name := "//toplevel//"; + Lexing.from_channel stdin + | `Path, _ -> + Location.input_name := source; + Lexing.from_channel (wrap_open open_in source) + +let () = + Arg.parse args anon_arg usage_msg; + if !Clflags.all_ppx = [] then begin + Arg.usage args usage_msg; + exit 1 + end; + if !inputs = [] then + inputs := [`Struct, `Path, "-"]; + let fmt = + match !output_file with + | "-" -> Format.std_formatter + | file -> Format.formatter_of_out_channel (wrap_open open_out file) + in + try + !inputs |> List.iter (fun (ast_kind, source_kind, source) -> + let lexer = make_lexer source_kind source in + match ast_kind with + | `Struct -> + let pstr = Parse.implementation lexer in + let pstr = Pparse.apply_rewriters (* ~restore:true *) ~tool_name:!tool_name + Pparse.Structure pstr in + Pprintast.structure fmt pstr; + Format.pp_print_newline fmt () + | `Sig -> + let psig = Parse.interface lexer in + let psig = Pparse.apply_rewriters (* ~restore:true *) ~tool_name:!tool_name + Pparse.Signature psig in + Pprintast.signature fmt psig; + Format.pp_print_newline fmt ()) + with exn -> + Location.report_exception Format.err_formatter exn; + exit 2 diff --git a/dune b/dune index a9f71c9..4d43198 100644 --- a/dune +++ b/dune @@ -1,3 +1,16 @@ +(* -*- tuareg -*- *) + +module J = Jbuild_plugin.V1 + +let ver = + match Scanf.sscanf J.ocaml_version "%s@.%s@." (fun maj min -> maj ^ min) with + | "409" -> "408" + | v -> v +;; + +Printf.ksprintf J.send {| +(copy_files# %s/*.ml{,i}) + (library (public_name ppx_tools) (synopsis "Tools for authors of ppx rewriters and other syntactic tools") @@ -55,3 +68,5 @@ (dumpast.exe as dumpast) (ppx_metaquot_main.exe as ppx_metaquot) (rewriter.exe as rewriter))) +|} ver + diff --git a/dune-workspace.dev b/dune-workspace.dev index 1b78da4..0539229 100644 --- a/dune-workspace.dev +++ b/dune-workspace.dev @@ -2,4 +2,5 @@ ;; This file is used by `make all-supported-ocaml-versions` (context (opam (switch 4.08.1))) -(context (opam (switch 4.09.0))) +(context (opam (switch 4.09.1))) +(context (opam (switch 4.10.0))) diff --git a/ppx_tools.opam b/ppx_tools.opam index f180f11..7579749 100644 --- a/ppx_tools.opam +++ b/ppx_tools.opam @@ -9,6 +9,6 @@ bug-reports: "https://github.com/ocaml-ppx/ppx_tools/issues" dev-repo: "git://github.com/ocaml-ppx/ppx_tools.git" build: ["dune" "build" "-p" name "-j" jobs] depends: [ - "ocaml" {>= "4.10.0"} + "ocaml" {>= "4.08.0"} "dune" {>= "1.6"} ] From f6323a341d36d4a4279a10e4a0b6a8b0d8748b0b Mon Sep 17 00:00:00 2001 From: Kate Date: Fri, 3 Jul 2020 20:08:00 +0100 Subject: [PATCH 2/2] Set the upper-bound limit for OCaml (won't be able to compile with future releases) --- ppx_tools.opam | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/ppx_tools.opam b/ppx_tools.opam index 7579749..d78b78a 100644 --- a/ppx_tools.opam +++ b/ppx_tools.opam @@ -9,6 +9,6 @@ bug-reports: "https://github.com/ocaml-ppx/ppx_tools/issues" dev-repo: "git://github.com/ocaml-ppx/ppx_tools.git" build: ["dune" "build" "-p" name "-j" jobs] depends: [ - "ocaml" {>= "4.08.0"} + "ocaml" {>= "4.08.0" & < "4.12.0"} "dune" {>= "1.6"} ]