pax_global_header00006660000000000000000000000064143144024040014506gustar00rootroot0000000000000052 comment=7d7dd5b61e85aec2fc42acf139341621c181e50f ppx_tools-6.6/000077500000000000000000000000001431440240400134105ustar00rootroot00000000000000ppx_tools-6.6/.gitignore000066400000000000000000000000311431440240400153720ustar00rootroot00000000000000_build *.install .merlin ppx_tools-6.6/.ocp-indent000066400000000000000000000000401431440240400154430ustar00rootroot00000000000000match_clause=4 strict_with=auto ppx_tools-6.6/.travis.yml000066400000000000000000000011001431440240400155110ustar00rootroot00000000000000language: c sudo: false services: - docker install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-docker.sh script: bash -ex .travis-docker.sh env: global: - PACKAGE="ppx_tools" - PRE_INSTALL_HOOK="cd /home/opam/opam-repository && git pull origin master && opam update -u -y" matrix: - DISTRO=ubuntu-lts OCAML_VERSION=4.12.0+trunk OCAML_BETA=enable - DISTRO=ubuntu-lts OCAML_VERSION=4.11.0 - DISTRO=ubuntu-lts OCAML_VERSION=4.10.0 - DISTRO=ubuntu-lts OCAML_VERSION=4.09.1 - DISTRO=ubuntu-lts OCAML_VERSION=4.08.1 ppx_tools-6.6/CHANGES000066400000000000000000000007261431440240400144100ustar00rootroot000000000000006.6 (26/09/2022) ---------------- * Add support for OCaml 5.0 (#92, Kate Deplaix) 6.5 (05/03/2022) ---------------- * Add support for OCaml 4.14 (#90, Kate Deplaix) 6.4 (04/08/2021) ---------------- * Add support for OCaml 4.13 (#89, Kate Deplaix) 6.3 (18/11/2020) ---------------- * Add support for OCaml 4.12 (#88, Kate Deplaix) * Merge the different implementations into a common folder (#87, Kate Deplaix) - ppx_tools now requires cppo to build ppx_tools-6.6/LICENSE000066400000000000000000000021021431440240400144100ustar00rootroot00000000000000The 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-6.6/Makefile000066400000000000000000000007261431440240400150550ustar00rootroot00000000000000# 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 INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) default: dune build release: dune build -p ppx_tools install: dune install $(INSTALL_ARGS) uninstall: dune uninstall $(INSTALL_ARGS) clean: dune clean all-supported-ocaml-versions: dune build @install @runtest --workspace dune-workspace.dev ppx_tools-6.6/README.md000066400000000000000000000117011431440240400146670ustar00rootroot00000000000000ppx_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). Main contributors: - Alain Frisch - Peter Zotov (whitequark) - Gabriel Radanne (Drup) Master : [![Build Status](https://travis-ci.org/ocaml-ppx/ppx_tools.svg?branch=master)](https://travis-ci.org/ocaml-ppx/ppx_tools) 4.06 : [![Build Status](https://travis-ci.org/ocaml-ppx/ppx_tools.svg?branch=4.06)](https://travis-ci.org/ocaml-ppx/ppx_tools) 4.05 : [![Build Status](https://travis-ci.org/ocaml-ppx/ppx_tools.svg?branch=4.05)](https://travis-ci.org/ocaml-ppx/ppx_tools) 4.04 : [![Build Status](https://travis-ci.org/ocaml-ppx/ppx_tools.svg?branch=4.04)](https://travis-ci.org/ocaml-ppx/ppx_tools) 4.03 : [![Build Status](https://travis-ci.org/ocaml-ppx/ppx_tools.svg?branch=4.03)](https://travis-ci.org/ocaml-ppx/ppx_tools) 4.02 : [![Build Status](https://travis-ci.org/ocaml-ppx/ppx_tools.svg?branch=4.02)](https://travis-ci.org/ocaml-ppx/ppx_tools) 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 ocamlc -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-6.6/dune-project000066400000000000000000000000571431440240400157340ustar00rootroot00000000000000(lang dune 1.6) (name ppx_tools) (version 6.6) ppx_tools-6.6/dune-workspace.dev000066400000000000000000000002601431440240400170350ustar00rootroot00000000000000(lang dune 1.0) ;; This file is used by `make all-supported-ocaml-versions` (context (opam (switch 4.08.1))) (context (opam (switch 4.09.1))) (context (opam (switch 4.10.0))) ppx_tools-6.6/ppx_tools.opam000066400000000000000000000010471431440240400163170ustar00rootroot00000000000000opam-version: "2.0" version: "6.6" synopsis: "Tools for authors of ppx rewriters and other syntactic tools" maintainer: "Kate " authors: "Alain Frisch " license: "MIT" tags: [ "syntax" ] homepage: "https://github.com/ocaml-ppx/ppx_tools" bug-reports: "https://github.com/ocaml-ppx/ppx_tools/issues" dev-repo: "git+https://github.com/ocaml-ppx/ppx_tools.git" build: ["dune" "build" "-p" name "-j" jobs] depends: [ "ocaml" {>= "4.08.0" & < "5.1.0"} "dune" {>= "1.6"} "cppo" {build & >= "1.1.0"} ] ppx_tools-6.6/src/000077500000000000000000000000001431440240400141775ustar00rootroot00000000000000ppx_tools-6.6/src/ast_convenience.ml000066400000000000000000000124741431440240400177040ustar00rootroot00000000000000(* 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 #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 let to_constant x = x end let may_tuple ?loc tup = function | [] -> None | [x] -> Some x | l -> Some (tup ?loc ?attrs:None l) #if OCAML_VERSION >= (4, 13, 0) let may_pat_tuple ?loc tup = function | [] -> None | [x] -> Some ([], x) | l -> Some ([], tup ?loc ?attrs:None l) #else let may_pat_tuple ?loc tup x = may_tuple ?loc tup x #endif 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 ()) #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')) 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_pat_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 ()) #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)) 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 | {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 ppx_tools-6.6/src/ast_convenience.mli000066400000000000000000000076771431440240400200660ustar00rootroot00000000000000(* 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 #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 *) 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 ppx_tools-6.6/src/ast_mapper_class.ml000066400000000000000000000702301431440240400200530ustar00rootroot00000000000000(* 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} #if OCAML_VERSION >= (4, 13, 0) let map_pat_opt sub f = function | None -> None | Some (exist, x) -> Some (List.map (map_loc sub) exist, f x) #else let map_pat_opt _sub f x = map_opt f x #endif 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 #if OCAML_VERSION >= (4, 14, 0) Pext_decl(vars, ctl, cto) -> Pext_decl(List.map (map_loc sub) vars, sub # constructor_arguments ctl, map_opt (sub # typ) cto) #else Pext_decl(ctl, cto) -> Pext_decl(sub # constructor_arguments ctl, map_opt (sub # typ) cto) #endif | 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 #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 *) 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) #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) | 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) #if OCAML_VERSION >= (4, 13, 0) | Pwith_modtype (lid, mty) -> Pwith_modtype (map_loc sub lid, sub # module_type mty) | Pwith_modtypesubst (lid, mty) -> Pwith_modtypesubst (map_loc sub lid, sub # module_type mty) #endif 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) #if OCAML_VERSION >= (4, 13, 0) | Psig_modtypesubst ms -> modtype_subst ~loc (sub # module_type_declaration ms) #endif | 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) #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) -> 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_pat_opt sub (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; #if OCAML_VERSION >= (4, 14, 0) pcd_vars} = #else } = #endif 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) #if OCAML_VERSION >= (4, 14, 0) ~vars:(List.map (map_loc this) pcd_vars) #endif 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) #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 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); #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); 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); } ppx_tools-6.6/src/ast_mapper_class.mli000066400000000000000000000061251431440240400202260ustar00rootroot00000000000000(* 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 #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 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. *) ppx_tools-6.6/src/dumpast.ml000066400000000000000000000100461431440240400162070ustar00rootroot00000000000000(* 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 ppx_tools-6.6/src/dune000066400000000000000000000027761431440240400150710ustar00rootroot00000000000000(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 (name ppx_metaquot) (public_name ppx_tools.metaquot) (synopsis "Meta-quotation: Parsetree manipulation using concrete syntax") (wrapped false) (kind ppx_rewriter) (modules ppx_metaquot) (ppx.driver (main Ppx_metaquot.Main.main)) (ppx_runtime_libraries ppx_tools) (libraries compiler-libs.common ppx_tools ast_lifter)) (executable (name genlifter) (modules genlifter) (preprocess (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{input-file}))) (libraries compiler-libs.common ppx_tools)) (executable (name dumpast) (modules dumpast) (libraries compiler-libs.common compiler-libs.bytecomp ast_lifter)) (executable (name ppx_metaquot_main) (modules ppx_metaquot_main) (libraries ppx_metaquot)) (executable (name rewriter) (modules rewriter) (libraries compiler-libs.common)) (rule (with-stdout-to ast_lifter.ml (run ./genlifter.exe -I +compiler-libs Parsetree.expression))) (library (name ast_lifter) (public_name ppx_tools.ast_lifter) (wrapped false) (modules ast_lifter) (flags :standard -w -17) (libraries compiler-libs.common)) (install (section libexec) (files (genlifter.exe as genlifter) (dumpast.exe as dumpast) (ppx_metaquot_main.exe as ppx_metaquot) (rewriter.exe as rewriter))) ppx_tools-6.6/src/genlifter.ml000066400000000000000000000212671431440240400165200ustar00rootroot00000000000000(* 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 (*************************************************************************) module Compat = struct #if OCAML_VERSION >= (4, 14, 0) let get_desc = Types.get_desc let repr = Transient_expr.repr #else let get_desc x = x.desc let repr x = x #endif end #if OCAML_VERSION >= (5, 0, 0) let env = Env.initial #else let env = Env.initial_safe_string #endif 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 = #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 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 -> (Compat.repr 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)])) #if OCAML_VERSION >= (4, 13, 0) | Type_variant (l, _rep), _ -> #else | Type_variant l, _ -> #endif 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 Compat.get_desc ty with | Tvar _ -> (match List.assoc (Compat.repr 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 () = #if OCAML_VERSION >= (5, 0, 0) Load_path.init ~auto_include:Load_path.no_auto_include [Config.standard_library]; #else Load_path.init [Config.standard_library]; #endif 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 #if OCAML_VERSION >= (4, 12, 0) let params = [Typ.var "res", (NoVariance, NoInjectivity)] in #else let params = [Typ.var "res", Invariant] in #endif 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-6.6/src/ppx_metaquot.ml000066400000000000000000000246531431440240400172710ustar00rootroot00000000000000(* 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 ppx_tools-6.6/src/ppx_metaquot_main.ml000066400000000000000000000000431431440240400202600ustar00rootroot00000000000000let () = Ppx_metaquot.Main.main () ppx_tools-6.6/src/rewriter.ml000066400000000000000000000071071431440240400164010ustar00rootroot00000000000000(* 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