From 5098d04aacecb14307a230e6027a17f03972661f Mon Sep 17 00:00:00 2001 From: Kate Date: Mon, 6 Jul 2020 12:48:10 +0100 Subject: [PATCH 1/4] Move the OCaml 4.08 version to a common src folder --- {408 => src}/ast_convenience.ml | 0 {408 => src}/ast_convenience.mli | 0 {408 => src}/ast_mapper_class.ml | 0 {408 => src}/ast_mapper_class.mli | 0 {408 => src}/dumpast.ml | 0 {408 => src}/genlifter.ml | 0 {408 => src}/ppx_metaquot.ml | 0 {408 => src}/ppx_metaquot_main.ml | 0 {408 => src}/rewriter.ml | 0 9 files changed, 0 insertions(+), 0 deletions(-) rename {408 => src}/ast_convenience.ml (100%) rename {408 => src}/ast_convenience.mli (100%) rename {408 => src}/ast_mapper_class.ml (100%) rename {408 => src}/ast_mapper_class.mli (100%) rename {408 => src}/dumpast.ml (100%) rename {408 => src}/genlifter.ml (100%) rename {408 => src}/ppx_metaquot.ml (100%) rename {408 => src}/ppx_metaquot_main.ml (100%) rename {408 => src}/rewriter.ml (100%) diff --git a/408/ast_convenience.ml b/src/ast_convenience.ml similarity index 100% rename from 408/ast_convenience.ml rename to src/ast_convenience.ml diff --git a/408/ast_convenience.mli b/src/ast_convenience.mli similarity index 100% rename from 408/ast_convenience.mli rename to src/ast_convenience.mli diff --git a/408/ast_mapper_class.ml b/src/ast_mapper_class.ml similarity index 100% rename from 408/ast_mapper_class.ml rename to src/ast_mapper_class.ml diff --git a/408/ast_mapper_class.mli b/src/ast_mapper_class.mli similarity index 100% rename from 408/ast_mapper_class.mli rename to src/ast_mapper_class.mli diff --git a/408/dumpast.ml b/src/dumpast.ml similarity index 100% rename from 408/dumpast.ml rename to src/dumpast.ml diff --git a/408/genlifter.ml b/src/genlifter.ml similarity index 100% rename from 408/genlifter.ml rename to src/genlifter.ml diff --git a/408/ppx_metaquot.ml b/src/ppx_metaquot.ml similarity index 100% rename from 408/ppx_metaquot.ml rename to src/ppx_metaquot.ml diff --git a/408/ppx_metaquot_main.ml b/src/ppx_metaquot_main.ml similarity index 100% rename from 408/ppx_metaquot_main.ml rename to src/ppx_metaquot_main.ml diff --git a/408/rewriter.ml b/src/rewriter.ml similarity index 100% rename from 408/rewriter.ml rename to src/rewriter.ml From 2d4a185042dcf34e27e8f0a8af98dcceae650511 Mon Sep 17 00:00:00 2001 From: Kate Date: Mon, 6 Jul 2020 13:02:55 +0100 Subject: [PATCH 2/4] Port the OCaml 4.10 version to the common folder using cppo --- 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 ------- src/ast_mapper_class.ml | 20 ++ dune => src/dune | 17 +- src/genlifter.ml | 4 + 12 files changed, 26 insertions(+), 1713 deletions(-) delete mode 100644 410/ast_convenience.ml delete mode 100644 410/ast_convenience.mli delete mode 100644 410/ast_mapper_class.ml delete mode 100644 410/ast_mapper_class.mli delete mode 100644 410/dumpast.ml delete mode 100644 410/genlifter.ml delete mode 100644 410/ppx_metaquot.ml delete mode 100644 410/ppx_metaquot_main.ml delete mode 100644 410/rewriter.ml rename dune => src/dune (85%) diff --git a/410/ast_convenience.ml b/410/ast_convenience.ml deleted file mode 100644 index 62dc655..0000000 --- a/410/ast_convenience.ml +++ /dev/null @@ -1,122 +0,0 @@ -(* 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 deleted file mode 100644 index 3ac31fd..0000000 --- a/410/ast_convenience.mli +++ /dev/null @@ -1,110 +0,0 @@ -(* 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 deleted file mode 100644 index 0756440..0000000 --- a/410/ast_mapper_class.ml +++ /dev/null @@ -1,656 +0,0 @@ -(* 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 deleted file mode 100644 index 9829378..0000000 --- a/410/ast_mapper_class.mli +++ /dev/null @@ -1,60 +0,0 @@ -(* 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 deleted file mode 100644 index 3929cd4..0000000 --- a/410/dumpast.ml +++ /dev/null @@ -1,121 +0,0 @@ -(* 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 deleted file mode 100644 index e0b9696..0000000 --- a/410/genlifter.ml +++ /dev/null @@ -1,234 +0,0 @@ -(* 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 deleted file mode 100644 index 943c06a..0000000 --- a/410/ppx_metaquot.ml +++ /dev/null @@ -1,288 +0,0 @@ -(* 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 deleted file mode 100644 index 4bab3f6..0000000 --- a/410/ppx_metaquot_main.ml +++ /dev/null @@ -1 +0,0 @@ -let () = Ppx_metaquot.Main.main () diff --git a/410/rewriter.ml b/410/rewriter.ml deleted file mode 100644 index 6de0d16..0000000 --- a/410/rewriter.ml +++ /dev/null @@ -1,106 +0,0 @@ -(* 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/src/ast_mapper_class.ml b/src/ast_mapper_class.ml index 60d8b72..f125fda 100644 --- a/src/ast_mapper_class.ml +++ b/src/ast_mapper_class.ml @@ -162,6 +162,12 @@ module CT = struct (List.map (sub # class_type_field) pcsig_fields) end +#if OCAML_VERSION >= (4, 10, 0) +let map_functor_param sub = function + | Unit -> Unit + | Named (s, mt) -> Named (map_loc sub s, sub # module_type mt) +#endif + module MT = struct (* Type expressions for the module language *) @@ -173,10 +179,17 @@ module MT = struct | 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) +#if OCAML_VERSION >= (4, 10, 0) + | Pmty_functor (param, mt) -> + functor_ ~loc ~attrs + (map_functor_param sub param) + (sub # module_type mt) +#else | Pmty_functor (s, mt1, mt2) -> functor_ ~loc ~attrs (map_loc sub s) (map_opt (sub # module_type) mt1) (sub # module_type mt2) +#endif | Pmty_with (mt, l) -> with_ ~loc ~attrs (sub # module_type mt) (List.map (sub # with_constraint) l) @@ -227,10 +240,17 @@ module M = struct match desc with | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) | Pmod_structure str -> structure ~loc ~attrs (sub # structure str) +#if OCAML_VERSION >= (4, 10, 0) + | Pmod_functor (param, body) -> + functor_ ~loc ~attrs + (map_functor_param sub param) + (sub # module_expr body) +#else | Pmod_functor (arg, arg_ty, body) -> functor_ ~loc ~attrs (map_loc sub arg) (map_opt (sub # module_type) arg_ty) (sub # module_expr body) +#endif | Pmod_apply (m1, m2) -> apply ~loc ~attrs (sub # module_expr m1) (sub # module_expr m2) | Pmod_constraint (m, mty) -> diff --git a/dune b/src/dune similarity index 85% rename from dune rename to src/dune index 4d43198..03a7a74 100644 --- a/dune +++ b/src/dune @@ -1,21 +1,9 @@ -(* -*- 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") (wrapped false) (modules ast_convenience ast_mapper_class) + (preprocess (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{input-file}))) (libraries compiler-libs.common)) (library @@ -32,6 +20,7 @@ Printf.ksprintf J.send {| (executable (name genlifter) (modules genlifter) + (preprocess (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{input-file}))) (libraries compiler-libs.common ppx_tools)) (executable @@ -68,5 +57,3 @@ Printf.ksprintf J.send {| (dumpast.exe as dumpast) (ppx_metaquot_main.exe as ppx_metaquot) (rewriter.exe as rewriter))) -|} ver - diff --git a/src/genlifter.ml b/src/genlifter.ml index b8e499a..ac4595a 100644 --- a/src/genlifter.ml +++ b/src/genlifter.ml @@ -50,7 +50,11 @@ module Main : sig end = struct if Hashtbl.mem printed ty then () else let tylid = Longident.parse ty in let td = +#if OCAML_VERSION >= (4, 10, 0) + try snd (Env.find_type_by_name tylid env) +#else try Env.find_type (Env.lookup_type tylid env) env +#endif with Not_found -> Format.eprintf "** Cannot resolve type %s@." ty; exit 2 From 07eb2d175d89e8ba4f01c0d85f2f3627ec0218cd Mon Sep 17 00:00:00 2001 From: Kate Date: Mon, 6 Jul 2020 13:15:25 +0100 Subject: [PATCH 3/4] Port the OCaml 4.11 version to the common folder using cppo --- 411/ast_convenience.ml | 122 ------- 411/ast_convenience.mli | 110 ------- 411/ast_mapper_class.ml | 663 --------------------------------------- 411/ast_mapper_class.mli | 61 ---- 411/dumpast.ml | 121 ------- 411/genlifter.ml | 234 -------------- 411/ppx_metaquot.ml | 288 ----------------- 411/ppx_metaquot_main.ml | 1 - 411/rewriter.ml | 106 ------- src/ast_convenience.ml | 22 +- src/ast_convenience.mli | 6 +- src/ast_mapper_class.ml | 11 + src/ast_mapper_class.mli | 3 + src/genlifter.ml | 2 +- src/ppx_metaquot.ml | 2 +- 15 files changed, 42 insertions(+), 1710 deletions(-) delete mode 100644 411/ast_convenience.ml delete mode 100644 411/ast_convenience.mli delete mode 100644 411/ast_mapper_class.ml delete mode 100644 411/ast_mapper_class.mli delete mode 100644 411/dumpast.ml delete mode 100644 411/genlifter.ml delete mode 100644 411/ppx_metaquot.ml delete mode 100644 411/ppx_metaquot_main.ml delete mode 100644 411/rewriter.ml diff --git a/411/ast_convenience.ml b/411/ast_convenience.ml deleted file mode 100644 index 80e4850..0000000 --- a/411/ast_convenience.ml +++ /dev/null @@ -1,122 +0,0 @@ -(* 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 * Location.t * 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 [@ocaml.warning "-3"] -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 = !default_loc) ?attrs s = Exp.constant ~loc ?attrs (Pconst_string (s, loc, 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 = !default_loc) ?attrs s = Pat.constant ~loc ?attrs (Pconst_string (s, loc, 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/411/ast_convenience.mli b/411/ast_convenience.mli deleted file mode 100644 index 78e5614..0000000 --- a/411/ast_convenience.mli +++ /dev/null @@ -1,110 +0,0 @@ -(* 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 * Location.t * 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/411/ast_mapper_class.ml b/411/ast_mapper_class.ml deleted file mode 100644 index dca4aa7..0000000 --- a/411/ast_mapper_class.ml +++ /dev/null @@ -1,663 +0,0 @@ -(* 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) - - method constant = function - | Pconst_integer (str, suffix) -> Pconst_integer (str, suffix) - | Pconst_char c -> Pconst_char c - | Pconst_string (str, loc, delim) -> Pconst_string (str, this # location loc, delim) - | Pconst_float (str, suffix) -> Pconst_float (str, suffix) - 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); - constant = (fun _ -> this # constant); - 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/411/ast_mapper_class.mli b/411/ast_mapper_class.mli deleted file mode 100644 index ca4015f..0000000 --- a/411/ast_mapper_class.mli +++ /dev/null @@ -1,61 +0,0 @@ -(* 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 constant : constant -> constant - 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/411/dumpast.ml b/411/dumpast.ml deleted file mode 100644 index 3929cd4..0000000 --- a/411/dumpast.ml +++ /dev/null @@ -1,121 +0,0 @@ -(* 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/411/genlifter.ml b/411/genlifter.ml deleted file mode 100644 index cc98360..0000000 --- a/411/genlifter.ml +++ /dev/null @@ -1,234 +0,0 @@ -(* 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 [@ocaml.warning "-3"] 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/411/ppx_metaquot.ml b/411/ppx_metaquot.ml deleted file mode 100644 index 4dcbd59..0000000 --- a/411/ppx_metaquot.ml +++ /dev/null @@ -1,288 +0,0 @@ -(* 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 Longident.parse ty [@ocaml.warning "-3"] 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/411/ppx_metaquot_main.ml b/411/ppx_metaquot_main.ml deleted file mode 100644 index 4bab3f6..0000000 --- a/411/ppx_metaquot_main.ml +++ /dev/null @@ -1 +0,0 @@ -let () = Ppx_metaquot.Main.main () diff --git a/411/rewriter.ml b/411/rewriter.ml deleted file mode 100644 index 6de0d16..0000000 --- a/411/rewriter.ml +++ /dev/null @@ -1,106 +0,0 @@ -(* 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/src/ast_convenience.ml b/src/ast_convenience.ml index 62dc655..15f0c05 100644 --- a/src/ast_convenience.ml +++ b/src/ast_convenience.ml @@ -29,7 +29,11 @@ module Constant = struct type t = Parsetree.constant = Pconst_integer of string * char option | Pconst_char of char +#if OCAML_VERSION >= (4, 11, 0) + | Pconst_string of string * Location.t * string option +#else | Pconst_string of string * string option +#endif | Pconst_float of string * char option let of_constant x = x @@ -43,7 +47,7 @@ let may_tuple ?loc tup = function | [x] -> Some x | l -> Some (tup ?loc ?attrs:None l) -let lid ?(loc = !default_loc) s = mkloc (Longident.parse s) loc +let lid ?(loc = !default_loc) s = mkloc (Longident.parse s) loc [@ocaml.warning "-3"] 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 "()" [] @@ -53,7 +57,11 @@ let tuple ?loc ?attrs = function | 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 ()) +#if OCAML_VERSION >= (4, 11, 0) +let str ?(loc = !default_loc) ?attrs s = Exp.constant ~loc ?attrs (Pconst_string (s, loc, None)) +#else let str ?loc ?attrs s = Exp.constant ?loc ?attrs (Pconst_string (s, None)) +#endif 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')) @@ -85,7 +93,11 @@ let ptuple ?loc ?attrs = function | xs -> Pat.tuple ?loc ?attrs xs let plist ?loc ?attrs l = List.fold_right (pcons ?loc ?attrs) l (pnil ?loc ?attrs ()) +#if OCAML_VERSION >= (4, 11, 0) +let pstr ?(loc = !default_loc) ?attrs s = Pat.constant ~loc ?attrs (Pconst_string (s, loc, None)) +#else let pstr ?loc ?attrs s = Pat.constant ?loc ?attrs (Pconst_string (s, None)) +#endif 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)) @@ -93,11 +105,19 @@ let pfloat ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_float (string_of_flo let tconstr ?loc ?attrs c l = Typ.constr ?loc ?attrs (lid ?loc c) l let get_str = function +#if OCAML_VERSION >= (4, 11, 0) + | {pexp_desc=Pexp_constant (Pconst_string (s, _, _)); _} -> Some s +#else | {pexp_desc=Pexp_constant (Pconst_string (s, _)); _} -> Some s +#endif | _ -> None let get_str_with_quotation_delimiter = function +#if OCAML_VERSION >= (4, 11, 0) + | {pexp_desc=Pexp_constant (Pconst_string (s, _, d)); _} -> Some (s, d) +#else | {pexp_desc=Pexp_constant (Pconst_string (s, d)); _} -> Some (s, d) +#endif | _ -> None let get_lid = function diff --git a/src/ast_convenience.mli b/src/ast_convenience.mli index 3ac31fd..c41e79e 100644 --- a/src/ast_convenience.mli +++ b/src/ast_convenience.mli @@ -32,7 +32,11 @@ module Constant : sig type t = Parsetree.constant = Pconst_integer of string * char option | Pconst_char of char - | Pconst_string of string * string option +#if OCAML_VERSION >= (4, 11, 0) + | Pconst_string of string * Location.t * string option +#else + | Pconst_string of string * string option +#endif | Pconst_float of string * char option (** Convert Asttypes.constant to Constant.t *) diff --git a/src/ast_mapper_class.ml b/src/ast_mapper_class.ml index f125fda..68ece82 100644 --- a/src/ast_mapper_class.ml +++ b/src/ast_mapper_class.ml @@ -619,6 +619,14 @@ class mapper = | PTyp x -> PTyp (this # typ x) | PPat (x, g) -> PPat (this # pat x, map_opt (this # expr) g) | PSig x -> PSig (this # signature x) + +#if OCAML_VERSION >= (4, 11, 0) + method constant = function + | Pconst_integer (str, suffix) -> Pconst_integer (str, suffix) + | Pconst_char c -> Pconst_char c + | Pconst_string (str, loc, delim) -> Pconst_string (str, this # location loc, delim) + | Pconst_float (str, suffix) -> Pconst_float (str, suffix) +#endif end @@ -639,6 +647,9 @@ let to_mapper this = class_type = (fun _ -> this # class_type); class_type_declaration = (fun _ -> this # class_type_declaration); class_type_field = (fun _ -> this # class_type_field); +#if OCAML_VERSION >= (4, 11, 0) + constant = (fun _ -> this # constant); +#endif constructor_declaration = (fun _ -> this # constructor_declaration); expr = (fun _ -> this # expr); extension = (fun _ -> this # extension); diff --git a/src/ast_mapper_class.mli b/src/ast_mapper_class.mli index 9829378..fe3c8c3 100644 --- a/src/ast_mapper_class.mli +++ b/src/ast_mapper_class.mli @@ -22,6 +22,9 @@ class mapper: 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 +#if OCAML_VERSION >= (4, 11, 0) + method constant : constant -> constant +#endif method constructor_arguments: constructor_arguments -> constructor_arguments method constructor_declaration: constructor_declaration -> constructor_declaration method expr: expression -> expression diff --git a/src/genlifter.ml b/src/genlifter.ml index ac4595a..b0627fb 100644 --- a/src/genlifter.ml +++ b/src/genlifter.ml @@ -48,7 +48,7 @@ module Main : sig end = struct let rec gen ty = if Hashtbl.mem printed ty then () - else let tylid = Longident.parse ty in + else let tylid = Longident.parse ty [@ocaml.warning "-3"] in let td = #if OCAML_VERSION >= (4, 10, 0) try snd (Env.find_type_by_name tylid env) diff --git a/src/ppx_metaquot.ml b/src/ppx_metaquot.ml index 943c06a..4dcbd59 100644 --- a/src/ppx_metaquot.ml +++ b/src/ppx_metaquot.ml @@ -69,7 +69,7 @@ end = struct let prefix ty s = let open Longident in - match parse ty with + match Longident.parse ty [@ocaml.warning "-3"] with | Ldot(m, _) -> String.concat "." (Longident.flatten m) ^ "." ^ s | _ -> s From ed14753cf4fb5961ddb8312c40f7408d05c991b7 Mon Sep 17 00:00:00 2001 From: Kate Date: Mon, 6 Jul 2020 13:15:35 +0100 Subject: [PATCH 4/4] Add cppo as a dependency --- ppx_tools.opam | 1 + 1 file changed, 1 insertion(+) diff --git a/ppx_tools.opam b/ppx_tools.opam index e367642..1e835aa 100644 --- a/ppx_tools.opam +++ b/ppx_tools.opam @@ -11,4 +11,5 @@ build: ["dune" "build" "-p" name "-j" jobs] depends: [ "ocaml" {>= "4.08.0" & < "4.12.0"} "dune" {>= "1.6"} + "cppo" {build} ]