pax_global_header00006660000000000000000000000064127121347550014521gustar00rootroot0000000000000052 comment=874d5ed0d83bb0ca0462a1ae60f9448af062f085 ppx_tools-5.0-4.02.0/000077500000000000000000000000001271213475500141335ustar00rootroot00000000000000ppx_tools-5.0-4.02.0/.depend000066400000000000000000000007011271213475500153710ustar00rootroot00000000000000ast_convenience.cmo : ast_convenience.cmi ast_convenience.cmx : ast_convenience.cmi ast_lifter.cmo : ast_lifter.cmx : ast_mapper_class.cmo : ast_mapper_class.cmi ast_mapper_class.cmx : ast_mapper_class.cmi dumpast.cmo : ast_lifter.cmo dumpast.cmx : ast_lifter.cmx genlifter.cmo : ast_convenience.cmi genlifter.cmx : ast_convenience.cmx ppx_metaquot.cmo : ast_lifter.cmo ppx_metaquot.cmx : ast_lifter.cmx ast_convenience.cmi : ast_mapper_class.cmi : ppx_tools-5.0-4.02.0/.gitignore000066400000000000000000000001771271213475500161300ustar00rootroot00000000000000*.annot *.cmo *.cma *.cmi *.a *.o *.cmx *.cmxs *.cmxa *.exe *.cmt *.cmti dumpast genlifter ppx_metaquot rewriter ast_lifter.ml ppx_tools-5.0-4.02.0/.merlin000066400000000000000000000000431271213475500154170ustar00rootroot00000000000000PKG compiler-libs FLG -safe-stringppx_tools-5.0-4.02.0/.ocp-indent000066400000000000000000000000401271213475500161660ustar00rootroot00000000000000match_clause=4 strict_with=auto ppx_tools-5.0-4.02.0/LICENSE000066400000000000000000000021021271213475500151330ustar00rootroot00000000000000The MIT License (MIT) Copyright (c) 2013 Alain Frisch and LexiFi Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ppx_tools-5.0-4.02.0/META000066400000000000000000000005711271213475500146070ustar00rootroot00000000000000version = "5.0+4.0.2" description = "Tools for authors of ppx rewriters and other syntactic tools" archive(byte) = "ppx_tools.cma" archive(native) = "ppx_tools.cmxa" requires = "compiler-libs.common" package "metaquot" ( version = "5.0+4.0.2" description = "Meta-quotation: Parsetree manipulation using concrete syntax" requires = "ppx_tools" ppx = "./ppx_metaquot" ) ppx_tools-5.0-4.02.0/Makefile000066400000000000000000000057371271213475500156070ustar00rootroot00000000000000# 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 include $(shell ocamlc -where)/Makefile.config PACKAGE = ppx_tools VERSION = 5.0+4.02.2 # Don't forget to change META file as well OCAMLC = ocamlc -bin-annot OCAMLOPT = ocamlopt COMPFLAGS = -w +A-4-17-44-45 -I +compiler-libs -safe-string .PHONY: all all: genlifter$(EXE) dumpast$(EXE) ppx_metaquot$(EXE) rewriter$(EXE) ast_mapper_class.cmo ppx_tools.cma ifneq ($(ARCH),none) all: ppx_tools.cmxa ifeq ($(NATDYNLINK),true) all: ppx_tools.cmxs endif endif genlifter$(EXE): ppx_tools.cma genlifter.cmo $(OCAMLC) $(COMPFLAGS) -o genlifter$(EXE) ocamlcommon.cma ppx_tools.cma genlifter.cmo dumpast$(EXE): dumpast.cmo $(OCAMLC) $(COMPFLAGS) -o dumpast$(EXE) ocamlcommon.cma ocamlbytecomp.cma ast_lifter.cmo dumpast.cmo ppx_metaquot$(EXE): ppx_metaquot.cmo $(OCAMLC) $(COMPFLAGS) -o ppx_metaquot$(EXE) ocamlcommon.cma ppx_tools.cma ast_lifter.cmo ppx_metaquot.cmo rewriter$(EXE): rewriter.cmo $(OCAMLC) $(COMPFLAGS) -o rewriter$(EXE) ocamlcommon.cma rewriter.cmo ast_lifter.ml: genlifter$(EXE) ./genlifter$(EXE) -I +compiler-libs Parsetree.expression > ast_lifter.ml || rm -rf ast_lifter.ml OBJS = ast_convenience.cmo ast_mapper_class.cmo ppx_tools.cma: $(OBJS) $(OCAMLC) -a -o ppx_tools.cma $(OBJS) ppx_tools.cmxa: $(OBJS:.cmo=.cmx) $(OCAMLOPT) -a -o ppx_tools.cmxa $(OBJS:.cmo=.cmx) ppx_tools.cmxs: $(OBJS:.cmo=.cmx) $(OCAMLOPT) -shared -o ppx_tools.cmxs -linkall ppx_tools.cmxa .PHONY: depend depend: touch ast_lifter.ml ocamldep *.ml *.mli > .depend -include .depend .PHONY: clean clean: rm -f *.cm* *~ *.o *.obj *.a *.lib *.tar.gz *.cmxs *.cmt *.cmti rm -f genlifter$(EXE) dumpast$(EXE) ppx_metaquot$(EXE) rm -f ast_lifter.ml # Default rules .SUFFIXES: .ml .mli .cmo .cmi .cmx .ml.cmo: $(OCAMLC) $(COMPFLAGS) -c $< .mli.cmi: $(OCAMLC) $(COMPFLAGS) -c $< .ml.cmx: $(OCAMLOPT) $(COMPFLAGS) -c $< # Install/uninstall targets = $(1).mli $(1).cmi $(1).cmt $(1).cmti $(wildcard $(1).cmx) INSTALL = META \ genlifter$(EXE) dumpast$(EXE) ppx_metaquot$(EXE) rewriter$(EXE) \ ppx_tools.cma $(wildcard ppx_tools.cmxa ppx_tools$(EXT_LIB)) \ $(wildcard ppx_tools.cmxs) \ $(call targets,ast_convenience) \ $(call targets,ast_mapper_class) .PHONY: install install: ocamlfind install $(PACKAGE) $(INSTALL) .PHONY: uninstall uninstall: ocamlfind remove $(PACKAGE) # Packaging DISTRIB = \ README.md LICENSE META \ Makefile .depend \ dumpast.ml \ genlifter.ml \ ppx_metaquot.ml \ rewriter.ml \ ast_mapper_class.ml ast_mapper_class.mli FPACKAGE = $(PACKAGE)-$(VERSION) .PHONY: package package: clean rm -rf files.tar.gz $(FPACKAGE) $(FPACKAGE).tar.gz tar czf files.tar.gz $(DISTRIB) mkdir $(FPACKAGE) cd $(FPACKAGE) && tar xzf ../files.tar.gz tar czf $(FPACKAGE).tar.gz $(FPACKAGE) cd $(FPACKAGE) && make all rm -rf files.tar.gz $(FPACKAGE) TARGET=foo:bar/ppx_tools_data upload: scp $(FPACKAGE).tar.gz $(TARGET)/ ppx_tools-5.0-4.02.0/README.md000066400000000000000000000101311271213475500154060ustar00rootroot00000000000000ppx_tools ========= Tools for authors of syntactic tools (such as ppx rewriters). This package is licensed by LexiFi under the terms of the MIT license. The tools are installed as a findlib package called 'ppx_tools'. Executables are thus accessible through the ocamlfind driver (e.g.: ocamlfind ppx_tools/dumpast). ppx_metaquot ------------ A ppx filter to help writing programs which manipulate the Parsetree, by allowing the programmer to use concrete syntax for expressions creating Parsetree fragments and patterns deconstructing Parsetree fragments. See the top of ppx_metaquot.ml for a description of the supported extensions. Usage: ocamlfind -c -package ppx_tools.metaquot my_ppx_code.ml rewriter -------- An utility to help testing ppx rewriters that runs the rewriter on user-provided code and returns the result. Usage: ocamlfind ppx_tools/rewriter ./my_ppx_rewriter sample.ml See the integrated help message for more details: ocamlfind ppx_tools/rewriter -help Ast_mapper_class ---------------- This module implements an API similar to Ast_mapper from the compiler-libs, i.e. a generic mapper from Parsetree to Parsetree implemeting a deep identity copy, which can be customized with a custom behavior for each syntactic category. The difference with Ast_mapper is that Ast_mapper_class implements the open recursion using a class. dumpast ------- This tool parses fragments of OCaml code (or entire source files) and dump the resulting internal Parsetree representation. Intended uses: - Help to learn about the OCaml Parsetree structure and how it corresponds to OCaml source syntax. - Create fragments of Parsetree to be copy-pasted into the source code of syntax-manipulating programs (such as ppx rewriters). Usage: ocamlfind ppx_tools/dumpast -e "1 + 2" The tool can be used to show the Parsetree representation of small fragments of syntax passed on the command line (-e for expressions, -p for patterns, -t for type expressions) or for entire .ml/mli files. The standard -pp and -ppx options are supported, but only applied on whole files. The tool has further option to control how location and attribute fields in the Parsetree should be displayed. genlifter --------- This tool generates a virtual "lifter" class for one or several OCaml type constructors. It does so by loading the .cmi files which define those types. The generated lifter class exposes one method to "reify" type constructors passed on the command-line and other type constructors accessible from them. The class is parametrized over the target type of the reification, and it must provide method to deal with basic types (int, string, char, int32, int64, nativeint) and data type builders (record, constr, tuple, list, array). As an example, calling: ocamlfind ppx_tools/genlifter -I +compiler-libs Location.t produces the following class: class virtual ['res] lifter = object (this) method lift_Location_t : Location.t -> 'res= fun { Location.loc_start = loc_start; Location.loc_end = loc_end; Location.loc_ghost = loc_ghost } -> this#record "Location.t" [("loc_start", (this#lift_Lexing_position loc_start)); ("loc_end", (this#lift_Lexing_position loc_end)); ("loc_ghost", (this#lift_bool loc_ghost))] method lift_bool : bool -> 'res= function | false -> this#constr "bool" ("false", []) | true -> this#constr "bool" ("true", []) method lift_Lexing_position : Lexing.position -> 'res= fun { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } -> this#record "Lexing.position" [("pos_fname", (this#string pos_fname)); ("pos_lnum", (this#int pos_lnum)); ("pos_bol", (this#int pos_bol)); ("pos_cnum", (this#int pos_cnum))] end _dumpast_ is a direct example of using _genlifter_ applied on the OCaml Parsetree definition itself. ppx_metaquot is another similar example. ppx_tools-5.0-4.02.0/ast_convenience.ml000066400000000000000000000137041271213475500176350ustar00rootroot00000000000000(* 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 = string type desc = Nolabel | Labelled of string | Optional of string let explode s = if s = "" then Nolabel else if s.[0] = '?' then Optional (String.sub s 1 (String.length s - 1)) else Labelled s let nolabel = "" let labelled s = s let optional s = "?"^s end module Constant = struct type t = Pconst_integer of string * char option | Pconst_char of char | Pconst_string of string * string option | Pconst_float of string * char option exception Unknown_literal of string * char (** Backport Int_literal_converter from ocaml 4.03 - * https://github.com/ocaml/ocaml/blob/trunk/utils/misc.ml#L298 *) module Int_literal_converter = struct let cvt_int_aux str neg of_string = if String.length str = 0 || str.[0] = '-' then of_string str else neg (of_string ("-" ^ str)) let int s = cvt_int_aux s (~-) int_of_string let int32 s = cvt_int_aux s Int32.neg Int32.of_string let int64 s = cvt_int_aux s Int64.neg Int64.of_string let nativeint s = cvt_int_aux s Nativeint.neg Nativeint.of_string end let of_constant = function | Asttypes.Const_int32(i) -> Pconst_integer(Int32.to_string i, Some 'l') | Asttypes.Const_int64(i) -> Pconst_integer(Int64.to_string i, Some 'L') | Asttypes.Const_nativeint(i) -> Pconst_integer(Nativeint.to_string i, Some 'n') | Asttypes.Const_int(i) -> Pconst_integer(string_of_int i, None) | Asttypes.Const_char c -> Pconst_char c | Asttypes.Const_string(s, s_opt) -> Pconst_string(s, s_opt) | Asttypes.Const_float f -> Pconst_float(f, None) let to_constant = function | Pconst_integer(i,Some 'l') -> Asttypes.Const_int32 (Int_literal_converter.int32 i) | Pconst_integer(i,Some 'L') -> Asttypes.Const_int64 (Int_literal_converter.int64 i) | Pconst_integer(i,Some 'n') -> Asttypes.Const_nativeint (Int_literal_converter.nativeint i) | Pconst_integer(i,None) -> Asttypes.Const_int (Int_literal_converter.int i) | Pconst_integer(i,Some c) -> raise (Unknown_literal (i, c)) | Pconst_char c -> Asttypes.Const_char c | Pconst_string(s,d) -> Asttypes.Const_string(s, d) | Pconst_float(f,None) -> Asttypes.Const_float f | Pconst_float(f,Some c) -> raise (Unknown_literal (f, c)) 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 (Const_string (s, None)) let int ?loc ?attrs x = Exp.constant ?loc ?attrs (Const_int x) let char ?loc ?attrs x = Exp.constant ?loc ?attrs (Const_char x) let float ?loc ?attrs x = Exp.constant ?loc ?attrs (Const_float (string_of_float x)) 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 (Const_string (s, None)) let pint ?loc ?attrs x = Pat.constant ?loc ?attrs (Const_int x) let pchar ?loc ?attrs x = Pat.constant ?loc ?attrs (Const_char x) let pfloat ?loc ?attrs x = Pat.constant ?loc ?attrs (Const_float (string_of_float x)) let tconstr ?loc ?attrs c l = Typ.constr ?loc ?attrs (lid ?loc c) l let get_str = function | {pexp_desc=Pexp_constant (Const_string (s, _)); _} -> Some s | _ -> None let get_str_with_quotation_delimiter = function | {pexp_desc=Pexp_constant (Const_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 (snd (List.find (fun (x, _) -> x.txt = s) attrs)) 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 ppx_tools-5.0-4.02.0/ast_convenience.mli000066400000000000000000000072241271213475500200060ustar00rootroot00000000000000(* 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 Parsetree open Asttypes open Ast_helper (** {2 Compatibility modules} *) module Label : sig type t = string type desc = 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 abstraction over Asttypes.constant type }*) module Constant : sig type t = Pconst_integer of string * char option | Pconst_char of char | Pconst_string of string * string option | Pconst_float of string * char option exception Unknown_literal of string * char (** Converts Asttypes.constant to Constant.t *) val of_constant : constant -> t (** Converts Constant.t to Asttypes.constant. Raises Unknown_literal if conversion fails *) val to_constant : t -> 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 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 ppx_tools-5.0-4.02.0/ast_mapper_class.ml000066400000000000000000000560161271213475500200150ustar00rootroot00000000000000(* 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 sub = function | Rtag (l, attrs, b, tl) -> Rtag (l, sub # attributes attrs, b, List.map (sub # typ) tl) | Rinherit t -> Rinherit (sub # typ t) let map sub {ptyp_desc = desc; ptyp_loc = loc; 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) -> let f (s, a, t) = (s, sub # attributes a, sub # typ t) in object_ ~loc ~attrs (List.map f 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_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 ~attrs:(sub # attributes ptyext_attributes) let map_extension_constructor_kind sub = function Pext_decl(ctl, cto) -> Pext_decl(List.map (sub # typ) 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) 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) let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} = let open Ctf in let loc = sub # location loc in match desc with | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub # class_type ct) | Pctf_val (s, m, v, t) -> val_ ~loc ~attrs s m v (sub # typ t) | Pctf_method (s, p, v, t) -> method_ ~loc ~attrs s p v (sub # typ t) | Pctf_constraint (t1, t2) -> constraint_ ~loc ~attrs (sub # typ t1) (sub # typ t2) | Pctf_attribute x -> attribute ~loc (sub # attribute x) | Pctf_extension x -> extension ~loc ~attrs (sub # extension x) let map_signature sub {pcsig_self; pcsig_fields} = Csig.mk (sub # typ pcsig_self) (List.map (sub # class_type_field) pcsig_fields) end module MT = struct (* Type expressions for the module language *) let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = let open Mty in let loc = sub # location loc in let attrs = sub # attributes attrs in match desc with | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) | Pmty_signature sg -> signature ~loc ~attrs (sub # signature sg) | Pmty_functor (s, mt1, mt2) -> functor_ ~loc ~attrs (map_loc sub s) (map_opt (sub # module_type) mt1) (sub # module_type mt2) | Pmty_with (mt, l) -> with_ ~loc ~attrs (sub # module_type mt) (List.map (sub # with_constraint) l) | Pmty_typeof me -> typeof_ ~loc ~attrs (sub # module_expr me) | Pmty_extension x -> extension ~loc ~attrs (sub # extension x) let map_with_constraint sub = function | Pwith_type (lid, d) -> Pwith_type (map_loc sub lid, sub # type_declaration d) | Pwith_module (lid, lid2) -> Pwith_module (map_loc sub lid, map_loc sub lid2) | Pwith_typesubst d -> Pwith_typesubst (sub # type_declaration d) | Pwith_modsubst (s, lid) -> Pwith_modsubst (map_loc sub s, map_loc sub lid) let map_signature_item sub {psig_desc = desc; psig_loc = loc} = let open Sig in let loc = sub # location loc in match desc with | Psig_value vd -> value ~loc (sub # value_description vd) | Psig_type l -> type_ ~loc (List.map (sub # type_declaration) l) | Psig_typext te -> type_extension ~loc (sub # type_extension te) | Psig_exception ed -> exception_ ~loc (sub # extension_constructor ed) | Psig_module x -> module_ ~loc (sub # module_declaration x) | Psig_recmodule l -> rec_module ~loc (List.map (sub # module_declaration) l) | Psig_modtype x -> modtype ~loc (sub # module_type_declaration x) | Psig_open od -> open_ ~loc (sub # open_description od) | Psig_include x -> include_ ~loc (sub # include_description x) | Psig_class l -> class_ ~loc (List.map (sub # class_description) l) | Psig_class_type l -> class_type ~loc (List.map (sub # class_type_declaration) l) | Psig_extension (x, attrs) -> extension ~loc (sub # extension x) ~attrs:(sub # attributes attrs) | Psig_attribute x -> attribute ~loc (sub # attribute x) end module M = struct (* Value expressions for the module language *) let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = let open Mod in let loc = sub # location loc in let attrs = sub # attributes attrs in match desc with | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) | Pmod_structure str -> structure ~loc ~attrs (sub # structure str) | Pmod_functor (arg, arg_ty, body) -> functor_ ~loc ~attrs (map_loc sub arg) (map_opt (sub # module_type) arg_ty) (sub # module_expr body) | Pmod_apply (m1, m2) -> apply ~loc ~attrs (sub # module_expr m1) (sub # module_expr m2) | Pmod_constraint (m, mty) -> constraint_ ~loc ~attrs (sub # module_expr m) (sub # module_type mty) | Pmod_unpack e -> unpack ~loc ~attrs (sub # expr e) | Pmod_extension x -> extension ~loc ~attrs (sub # extension x) let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = let open Str in let loc = sub # location loc in match desc with | Pstr_eval (x, attrs) -> eval ~loc ~attrs:(sub # attributes attrs) (sub # expr x) | Pstr_value (r, vbs) -> value ~loc r (List.map (sub # value_binding) vbs) | Pstr_primitive vd -> primitive ~loc (sub # value_description vd) | Pstr_type l -> type_ ~loc (List.map (sub # type_declaration) l) | Pstr_typext te -> type_extension ~loc (sub # type_extension te) | Pstr_exception ed -> exception_ ~loc (sub # extension_constructor 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_description 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 sub {pexp_loc = loc; 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_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 (ovf, lid, e) -> open_ ~loc ~attrs ovf (map_loc sub lid) (sub # expr e) | Pexp_extension x -> extension ~loc ~attrs (sub # extension x) end module P = struct (* Patterns *) let map sub {ppat_desc = desc; ppat_loc = loc; 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) 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) 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 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 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_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_declaration {pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes} = Type.constructor (map_loc this pcd_name) ~args:(List.map (this # typ) 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_description {popen_lid; popen_override; popen_attributes; popen_loc} = Opn.mk (map_loc this popen_lid) ~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 (s, e) = (map_loc this s, this # payload e) 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) end let to_mapper this = let open Ast_mapper in { attribute = (fun _ -> this # attribute); attributes = (fun _ -> this # attributes); 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_type = (fun _ -> this # module_type); module_type_declaration = (fun _ -> this # module_type_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_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); } ppx_tools-5.0-4.02.0/ast_mapper_class.mli000066400000000000000000000052711271213475500201630ustar00rootroot00000000000000(* 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 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_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_expr: module_expr -> module_expr method module_type: module_type -> module_type method module_type_declaration: module_type_declaration -> module_type_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_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. *) ppx_tools-5.0-4.02.0/dumpast.ml000066400000000000000000000077751271213475500161620ustar00rootroot00000000000000(* 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 Oval_record (List.map (fun (l, s) -> (Oide_ident l, s)) x) method constr (_ty : string) (c, args) = Oval_constr (Oide_ident 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 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; let v = if Filename.check_suffix fn ".mli" then let ast = Pparse.parse_interface ~tool_name:"ocamlc" Format.err_formatter fn in lift # lift_Parsetree_signature ast else if Filename.check_suffix fn ".ml" then let ast = Pparse.parse_implementation ~tool_name:"ocamlc" Format.err_formatter 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 ppx_tools-5.0-4.02.0/genlifter.ml000066400000000000000000000163341271213475500164530ustar00rootroot00000000000000(* 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) 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 ["a"] (arrow "" (var "a") (var "res")))) ) let arrow_method = Cf.(method_ (mknoloc "arrow") Public (virtual_ Typ.(poly ["a"] (arrow "" (var "a") (var "res")))) ) let rec gen ty = if Hashtbl.mem printed ty then () else let tylid = Longident.parse ty in let (_, td) = try Env.lookup_type 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 _ -> Printf.sprintf "f%i" i) td.type_params in let env = List.map2 (fun s t -> t.id, evar s) params td.type_params in let make_result_t tyargs = Typ.(arrow "" (constr (lid ty) tyargs) (var "res")) in let make_t tyargs = List.fold_right (fun arg t -> Typ.(arrow "" (arrow "" arg (var "res")) t)) tyargs (make_result_t tyargs) in let tyargs = List.map (fun t -> Typ.var t) 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) params) e in let tyargs = List.map (fun t -> Typ.constr (lid t) []) 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 match td.type_kind, td.type_manifest with | Type_record (l, _), _ -> 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 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 let p, args = gentuple env cd.cd_args in pconstr qc p, selfcall "constr" [str ty; tuple[str c; list args]] 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 ("", None, {ppat_desc = Ppat_var{txt=id;_};_}, {pexp_desc = Pexp_apply (f, ["",{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 -> Config.load_path := Misc.expand_directory Config.standard_library s :: !Config.load_path), " Add to the list of include directories"; ] let usage = Printf.sprintf "%s [options] \n" Sys.argv.(0) let main () = Config.load_path := [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 ppx_tools-5.0-4.02.0/opam000066400000000000000000000010041271213475500150050ustar00rootroot00000000000000opam-version: "1.2" maintainer: "alain.frisch@lexifi.com" authors: [ "Alain Frisch " ] license: "MIT" homepage: "https://github.com/alainfrisch/ppx_tools" bug-reports: "https://github.com/alainfrisch/ppx_tools/issues" dev-repo: "git://github.com/alainfrisch/ppx_tools.git" tags: [ "syntax" ] build: [[make "all"]] install: [[make "install"]] remove: [["ocamlfind" "remove" "ppx_tools"]] depends: [ "ocamlfind" {>= "1.5.0"} ] available: ocaml-version >= "4.02.0" & ocaml-version < "4.03.0" ppx_tools-5.0-4.02.0/ppx_metaquot.ml000066400000000000000000000201411271213475500172110ustar00rootroot00000000000000(* 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 ... [%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 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 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 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 | _ -> Format.eprintf "%aExpression expected@." Location.print_error loc; exit 2 let get_typ loc = function | PTyp t -> t | _ -> Format.eprintf "%aType expected@." Location.print_error loc; exit 2 let get_pat loc = function | PPat (t, None) -> t | _ -> Format.eprintf "%aPattern expected@." Location.print_error loc; 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_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 (* Special support for location and attributes in the generated AST *) method! lift_Location_t _ = Pat.any () method! lift_Parsetree_attributes _ = Pat.any () (* 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 "Pervasives.!") [evar "Ast_helper.default_loc"]) let handle_attr = function | {txt="metaloc";loc=l}, 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="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="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 in {super with expr; pat; structure; structure_item} let () = Ast_mapper.run_main expander end ppx_tools-5.0-4.02.0/rewriter.ml000066400000000000000000000071371271213475500163400ustar00rootroot00000000000000(* 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 Config.ast_impl_magic_number 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 Config.ast_intf_magic_number psig in Pprintast.signature fmt psig; Format.pp_print_newline fmt ()) with exn -> Location.report_exception Format.err_formatter exn; exit 2