├── .gitignore ├── .ocp-indent ├── src ├── ppx_metaquot_main.ml ├── dune ├── ast_mapper_class.mli ├── rewriter.ml ├── ast_convenience.mli ├── dumpast.ml ├── ast_convenience.ml ├── genlifter.ml ├── ppx_metaquot.ml └── ast_mapper_class.ml ├── dune-project ├── dune-workspace.dev ├── CHANGES ├── Makefile ├── ppx_tools.opam ├── .travis.yml ├── LICENSE └── README.md /.gitignore: -------------------------------------------------------------------------------- 1 | _build 2 | *.install 3 | .merlin 4 | -------------------------------------------------------------------------------- /.ocp-indent: -------------------------------------------------------------------------------- 1 | match_clause=4 2 | strict_with=auto 3 | -------------------------------------------------------------------------------- /src/ppx_metaquot_main.ml: -------------------------------------------------------------------------------- 1 | let () = Ppx_metaquot.Main.main () 2 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.6) 2 | (name ppx_tools) 3 | (version 6.6) 4 | -------------------------------------------------------------------------------- /dune-workspace.dev: -------------------------------------------------------------------------------- 1 | (lang dune 1.0) 2 | 3 | ;; This file is used by `make all-supported-ocaml-versions` 4 | (context (opam (switch 4.08.1))) 5 | (context (opam (switch 4.09.1))) 6 | (context (opam (switch 4.10.0))) 7 | -------------------------------------------------------------------------------- /CHANGES: -------------------------------------------------------------------------------- 1 | 6.6 (26/09/2022) 2 | ---------------- 3 | 4 | * Add support for OCaml 5.0 (#92, Kate Deplaix) 5 | 6 | 6.5 (05/03/2022) 7 | ---------------- 8 | 9 | * Add support for OCaml 4.14 (#90, Kate Deplaix) 10 | 11 | 6.4 (04/08/2021) 12 | ---------------- 13 | 14 | * Add support for OCaml 4.13 (#89, Kate Deplaix) 15 | 16 | 6.3 (18/11/2020) 17 | ---------------- 18 | 19 | * Add support for OCaml 4.12 (#88, Kate Deplaix) 20 | * Merge the different implementations into a common folder (#87, Kate Deplaix) 21 | - ppx_tools now requires cppo to build 22 | -------------------------------------------------------------------------------- /Makefile: -------------------------------------------------------------------------------- 1 | # This file is part of the ppx_tools package. It is released 2 | # under the terms of the MIT license (see LICENSE file). 3 | # Copyright 2013 Alain Frisch and LexiFi 4 | 5 | INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) 6 | 7 | default: 8 | dune build 9 | 10 | release: 11 | dune build -p ppx_tools 12 | 13 | install: 14 | dune install $(INSTALL_ARGS) 15 | 16 | uninstall: 17 | dune uninstall $(INSTALL_ARGS) 18 | 19 | clean: 20 | dune clean 21 | 22 | all-supported-ocaml-versions: 23 | dune build @install @runtest --workspace dune-workspace.dev 24 | -------------------------------------------------------------------------------- /ppx_tools.opam: -------------------------------------------------------------------------------- 1 | opam-version: "2.0" 2 | version: "6.6" 3 | synopsis: "Tools for authors of ppx rewriters and other syntactic tools" 4 | maintainer: "Kate " 5 | authors: "Alain Frisch " 6 | license: "MIT" 7 | tags: [ "syntax" ] 8 | homepage: "https://github.com/ocaml-ppx/ppx_tools" 9 | bug-reports: "https://github.com/ocaml-ppx/ppx_tools/issues" 10 | dev-repo: "git+https://github.com/ocaml-ppx/ppx_tools.git" 11 | build: ["dune" "build" "-p" name "-j" jobs] 12 | depends: [ 13 | "ocaml" {>= "4.08.0" & < "5.1.0"} 14 | "dune" {>= "1.6"} 15 | "cppo" {build & >= "1.1.0"} 16 | ] 17 | -------------------------------------------------------------------------------- /.travis.yml: -------------------------------------------------------------------------------- 1 | language: c 2 | sudo: false 3 | services: 4 | - docker 5 | install: wget https://raw.githubusercontent.com/ocaml/ocaml-travisci-skeleton/master/.travis-docker.sh 6 | script: bash -ex .travis-docker.sh 7 | env: 8 | global: 9 | - PACKAGE="ppx_tools" 10 | - PRE_INSTALL_HOOK="cd /home/opam/opam-repository && git pull origin master && opam update -u -y" 11 | matrix: 12 | - DISTRO=ubuntu-lts OCAML_VERSION=4.12.0+trunk OCAML_BETA=enable 13 | - DISTRO=ubuntu-lts OCAML_VERSION=4.11.0 14 | - DISTRO=ubuntu-lts OCAML_VERSION=4.10.0 15 | - DISTRO=ubuntu-lts OCAML_VERSION=4.09.1 16 | - DISTRO=ubuntu-lts OCAML_VERSION=4.08.1 17 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | The MIT License (MIT) 2 | 3 | Copyright (c) 2013 Alain Frisch and LexiFi 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy of 6 | this software and associated documentation files (the "Software"), to deal in 7 | the Software without restriction, including without limitation the rights to 8 | use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of 9 | the Software, and to permit persons to whom the Software is furnished to do so, 10 | subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS 17 | FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR 18 | COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER 19 | IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN 20 | CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (public_name ppx_tools) 3 | (synopsis "Tools for authors of ppx rewriters and other syntactic tools") 4 | (wrapped false) 5 | (modules ast_convenience ast_mapper_class) 6 | (preprocess (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{input-file}))) 7 | (libraries compiler-libs.common)) 8 | 9 | (library 10 | (name ppx_metaquot) 11 | (public_name ppx_tools.metaquot) 12 | (synopsis "Meta-quotation: Parsetree manipulation using concrete syntax") 13 | (wrapped false) 14 | (kind ppx_rewriter) 15 | (modules ppx_metaquot) 16 | (ppx.driver (main Ppx_metaquot.Main.main)) 17 | (ppx_runtime_libraries ppx_tools) 18 | (libraries compiler-libs.common ppx_tools ast_lifter)) 19 | 20 | (executable 21 | (name genlifter) 22 | (modules genlifter) 23 | (preprocess (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{input-file}))) 24 | (libraries compiler-libs.common ppx_tools)) 25 | 26 | (executable 27 | (name dumpast) 28 | (modules dumpast) 29 | (libraries compiler-libs.common compiler-libs.bytecomp ast_lifter)) 30 | 31 | (executable 32 | (name ppx_metaquot_main) 33 | (modules ppx_metaquot_main) 34 | (libraries ppx_metaquot)) 35 | 36 | (executable 37 | (name rewriter) 38 | (modules rewriter) 39 | (libraries compiler-libs.common)) 40 | 41 | (rule 42 | (with-stdout-to ast_lifter.ml 43 | (run ./genlifter.exe -I +compiler-libs Parsetree.expression))) 44 | 45 | (library 46 | (name ast_lifter) 47 | (public_name ppx_tools.ast_lifter) 48 | (wrapped false) 49 | (modules ast_lifter) 50 | (flags :standard -w -17) 51 | (libraries compiler-libs.common)) 52 | 53 | (install 54 | (section libexec) 55 | (files 56 | (genlifter.exe as genlifter) 57 | (dumpast.exe as dumpast) 58 | (ppx_metaquot_main.exe as ppx_metaquot) 59 | (rewriter.exe as rewriter))) 60 | -------------------------------------------------------------------------------- /src/ast_mapper_class.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of the ppx_tools package. It is released *) 2 | (* under the terms of the MIT license (see LICENSE file). *) 3 | (* Copyright 2013 Alain Frisch and LexiFi *) 4 | 5 | (** Class-based customizable mapper *) 6 | 7 | open Parsetree 8 | 9 | class mapper: 10 | object 11 | method attribute: attribute -> attribute 12 | method attributes: attribute list -> attribute list 13 | method binding_op: binding_op -> binding_op 14 | method case: case -> case 15 | method cases: case list -> case list 16 | method class_declaration: class_declaration -> class_declaration 17 | method class_description: class_description -> class_description 18 | method class_expr: class_expr -> class_expr 19 | method class_field: class_field -> class_field 20 | method class_signature: class_signature -> class_signature 21 | method class_structure: class_structure -> class_structure 22 | method class_type: class_type -> class_type 23 | method class_type_declaration: class_type_declaration -> class_type_declaration 24 | method class_type_field: class_type_field -> class_type_field 25 | #if OCAML_VERSION >= (4, 11, 0) 26 | method constant : constant -> constant 27 | #endif 28 | method constructor_arguments: constructor_arguments -> constructor_arguments 29 | method constructor_declaration: constructor_declaration -> constructor_declaration 30 | method expr: expression -> expression 31 | method extension: extension -> extension 32 | method extension_constructor: extension_constructor -> extension_constructor 33 | method include_declaration: include_declaration -> include_declaration 34 | method include_description: include_description -> include_description 35 | method label_declaration: label_declaration -> label_declaration 36 | method location: Location.t -> Location.t 37 | method module_binding: module_binding -> module_binding 38 | method module_declaration: module_declaration -> module_declaration 39 | method module_substitution: module_substitution -> module_substitution 40 | method module_expr: module_expr -> module_expr 41 | method module_type: module_type -> module_type 42 | method module_type_declaration: module_type_declaration -> module_type_declaration 43 | method open_declaration: open_declaration -> open_declaration 44 | method open_description: open_description -> open_description 45 | method pat: pattern -> pattern 46 | method payload: payload -> payload 47 | method signature: signature -> signature 48 | method signature_item: signature_item -> signature_item 49 | method structure: structure -> structure 50 | method structure_item: structure_item -> structure_item 51 | method typ: core_type -> core_type 52 | method type_declaration: type_declaration -> type_declaration 53 | method type_exception: type_exception -> type_exception 54 | method type_extension: type_extension -> type_extension 55 | method type_kind: type_kind -> type_kind 56 | method value_binding: value_binding -> value_binding 57 | method value_description: value_description -> value_description 58 | method with_constraint: with_constraint -> with_constraint 59 | end 60 | 61 | val to_mapper: #mapper -> Ast_mapper.mapper 62 | (** The resulting mapper is "closed", i.e. methods ignore 63 | their first argument. *) 64 | -------------------------------------------------------------------------------- /src/rewriter.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of the ppx_tools package. It is released *) 2 | (* under the terms of the MIT license (see LICENSE file). *) 3 | (* Copyright 2014 Peter Zotov *) 4 | 5 | let inputs : ([ `Struct | `Sig ] * [ `String | `Path ] * string) list ref = ref [] 6 | let output_file : string ref = ref "-" 7 | let tool_name = ref "ocamlc" 8 | 9 | let args = 10 | let open Arg in 11 | align [ 12 | "-ppx", String (fun s -> Clflags.all_ppx := s :: !Clflags.all_ppx), 13 | " Invoke as a ppx preprocessor"; 14 | 15 | "-str", String (fun s -> inputs := (`Struct, `String, s) :: !inputs), 16 | " Parse as a structure"; 17 | 18 | "-sig", String (fun s -> inputs := (`Sig, `String, s) :: !inputs), 19 | " Parse as a signature"; 20 | 21 | "-impl", String (fun s -> inputs := (`Struct, `Path, s) :: !inputs), 22 | " Parse as an implementation (specify - for stdin)"; 23 | 24 | "-intf", String (fun s -> inputs := (`Sig, `Path, s) :: !inputs), 25 | " Parse as an interface (specify - for stdin)"; 26 | 27 | "-o", Set_string output_file, 28 | " Write result into (stdout by default)"; 29 | 30 | "-tool-name", Set_string tool_name, 31 | " Set tool name to (ocamlc by default)"; 32 | 33 | "-I", String (fun s -> Clflags.include_dirs := s :: !Clflags.include_dirs), 34 | " Add to the list of include directories"; 35 | 36 | "-open", String (fun s -> Clflags.open_modules := s :: !Clflags.open_modules), 37 | " Add to the list of opened modules"; 38 | 39 | "-for-pack", String (fun s -> Clflags.for_package := Some s), 40 | " Preprocess code as if it will be packed inside "; 41 | 42 | "-g", Set Clflags.debug, 43 | " Request debug information from preprocessor"; 44 | ] 45 | 46 | let anon_arg s = 47 | match !Clflags.all_ppx with 48 | | [] -> Clflags.all_ppx := s :: !Clflags.all_ppx 49 | | _ -> inputs := (`Struct, `Path, s) :: !inputs 50 | 51 | let usage_msg = 52 | Printf.sprintf 53 | "Usage: %s [ppx-rewriter] [options...] [implementations...]\n\ 54 | If no implementations are specified, parses stdin." 55 | Sys.argv.(0) 56 | 57 | let wrap_open fn file = 58 | try fn file 59 | with Sys_error msg -> 60 | prerr_endline msg; 61 | exit 1 62 | 63 | let make_lexer source_kind source = 64 | match source_kind, source with 65 | | `String, _ -> 66 | Location.input_name := "//toplevel//"; 67 | Lexing.from_string source 68 | | `Path, "-" -> 69 | Location.input_name := "//toplevel//"; 70 | Lexing.from_channel stdin 71 | | `Path, _ -> 72 | Location.input_name := source; 73 | Lexing.from_channel (wrap_open open_in source) 74 | 75 | let () = 76 | Arg.parse args anon_arg usage_msg; 77 | if !Clflags.all_ppx = [] then begin 78 | Arg.usage args usage_msg; 79 | exit 1 80 | end; 81 | if !inputs = [] then 82 | inputs := [`Struct, `Path, "-"]; 83 | let fmt = 84 | match !output_file with 85 | | "-" -> Format.std_formatter 86 | | file -> Format.formatter_of_out_channel (wrap_open open_out file) 87 | in 88 | try 89 | !inputs |> List.iter (fun (ast_kind, source_kind, source) -> 90 | let lexer = make_lexer source_kind source in 91 | match ast_kind with 92 | | `Struct -> 93 | let pstr = Parse.implementation lexer in 94 | let pstr = Pparse.apply_rewriters (* ~restore:true *) ~tool_name:!tool_name 95 | Pparse.Structure pstr in 96 | Pprintast.structure fmt pstr; 97 | Format.pp_print_newline fmt () 98 | | `Sig -> 99 | let psig = Parse.interface lexer in 100 | let psig = Pparse.apply_rewriters (* ~restore:true *) ~tool_name:!tool_name 101 | Pparse.Signature psig in 102 | Pprintast.signature fmt psig; 103 | Format.pp_print_newline fmt ()) 104 | with exn -> 105 | Location.report_exception Format.err_formatter exn; 106 | exit 2 107 | -------------------------------------------------------------------------------- /src/ast_convenience.mli: -------------------------------------------------------------------------------- 1 | (* This file is part of the ppx_tools package. It is released *) 2 | (* under the terms of the MIT license (see LICENSE file). *) 3 | (* Copyright 2013 Alain Frisch and LexiFi *) 4 | 5 | (** {1 Convenience functions to help build and deconstruct AST fragments.} *) 6 | 7 | open Asttypes 8 | open Ast_helper 9 | open Parsetree 10 | 11 | (** {2 Compatibility modules} *) 12 | 13 | module Label : sig 14 | type t = Asttypes.arg_label 15 | 16 | type desc = Asttypes.arg_label = 17 | Nolabel 18 | | Labelled of string 19 | | Optional of string 20 | 21 | val explode : t -> desc 22 | 23 | val nolabel : t 24 | val labelled : string -> t 25 | val optional : string -> t 26 | 27 | end 28 | 29 | (** {2 Provides a unified abstraction over differences in Parsetree.constant and Asttypes.constant 30 | * types defined in ocaml 4.03 and 4.02 respectively}*) 31 | module Constant : sig 32 | type t = Parsetree.constant = 33 | Pconst_integer of string * char option 34 | | Pconst_char of char 35 | #if OCAML_VERSION >= (4, 11, 0) 36 | | Pconst_string of string * Location.t * string option 37 | #else 38 | | Pconst_string of string * string option 39 | #endif 40 | | Pconst_float of string * char option 41 | 42 | (** Convert Asttypes.constant to Constant.t *) 43 | val of_constant : Parsetree.constant -> t 44 | 45 | (** Convert Constant.t to Asttypes.constant *) 46 | val to_constant : t -> Parsetree.constant 47 | 48 | end 49 | 50 | (** {2 Misc} *) 51 | 52 | val lid: ?loc:loc -> string -> lid 53 | 54 | (** {2 Expressions} *) 55 | 56 | val evar: ?loc:loc -> ?attrs:attrs -> string -> expression 57 | val let_in: ?loc:loc -> ?attrs:attrs -> ?recursive:bool -> value_binding list -> expression -> expression 58 | 59 | val constr: ?loc:loc -> ?attrs:attrs -> string -> expression list -> expression 60 | val record: ?loc:loc -> ?attrs:attrs -> ?over:expression -> (string * expression) list -> expression 61 | val tuple: ?loc:loc -> ?attrs:attrs -> expression list -> expression 62 | 63 | val nil: ?loc:loc -> ?attrs:attrs -> unit -> expression 64 | val cons: ?loc:loc -> ?attrs:attrs -> expression -> expression -> expression 65 | val list: ?loc:loc -> ?attrs:attrs -> expression list -> expression 66 | 67 | val unit: ?loc:loc -> ?attrs:attrs -> unit -> expression 68 | 69 | val func: ?loc:loc -> ?attrs:attrs -> (pattern * expression) list -> expression 70 | val lam: ?loc:loc -> ?attrs:attrs -> ?label:Label.t -> ?default:expression -> pattern -> expression -> expression 71 | val app: ?loc:loc -> ?attrs:attrs -> expression -> expression list -> expression 72 | 73 | val str: ?loc:loc -> ?attrs:attrs -> string -> expression 74 | val int: ?loc:loc -> ?attrs:attrs -> int -> expression 75 | val int32: ?loc:loc -> ?attrs:attrs -> int32 -> expression 76 | val int64: ?loc:loc -> ?attrs:attrs -> int64 -> expression 77 | val char: ?loc:loc -> ?attrs:attrs -> char -> expression 78 | val float: ?loc:loc -> ?attrs:attrs -> float -> expression 79 | 80 | val sequence: ?loc:loc -> ?attrs:attrs -> expression list -> expression 81 | (** Return [()] if the list is empty. Tail rec. *) 82 | 83 | (** {2 Patterns} *) 84 | 85 | val pvar: ?loc:loc -> ?attrs:attrs -> string -> pattern 86 | val pconstr: ?loc:loc -> ?attrs:attrs -> string -> pattern list -> pattern 87 | val precord: ?loc:loc -> ?attrs:attrs -> ?closed:closed_flag -> (string * pattern) list -> pattern 88 | val ptuple: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern 89 | 90 | val pnil: ?loc:loc -> ?attrs:attrs -> unit -> pattern 91 | val pcons: ?loc:loc -> ?attrs:attrs -> pattern -> pattern -> pattern 92 | val plist: ?loc:loc -> ?attrs:attrs -> pattern list -> pattern 93 | 94 | val pstr: ?loc:loc -> ?attrs:attrs -> string -> pattern 95 | val pint: ?loc:loc -> ?attrs:attrs -> int -> pattern 96 | val pchar: ?loc:loc -> ?attrs:attrs -> char -> pattern 97 | val pfloat: ?loc:loc -> ?attrs:attrs -> float -> pattern 98 | 99 | val punit: ?loc:loc -> ?attrs:attrs -> unit -> pattern 100 | 101 | 102 | (** {2 Types} *) 103 | 104 | val tconstr: ?loc:loc -> ?attrs:attrs -> string -> core_type list -> core_type 105 | 106 | (** {2 AST deconstruction} *) 107 | 108 | val get_str: expression -> string option 109 | val get_str_with_quotation_delimiter: expression -> (string * string option) option 110 | val get_lid: expression -> string option 111 | 112 | val has_attr: string -> attributes -> bool 113 | val find_attr: string -> attributes -> payload option 114 | val find_attr_expr: string -> attributes -> expression option 115 | -------------------------------------------------------------------------------- /src/dumpast.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of the ppx_tools package. It is released *) 2 | (* under the terms of the MIT license (see LICENSE file). *) 3 | (* Copyright 2013 Alain Frisch and LexiFi *) 4 | 5 | (* Illustrate how to use AST lifting to create a pretty-printer *) 6 | 7 | open Outcometree 8 | 9 | let locs = ref (`Discard : [`Discard|`Underscore|`Keep]) 10 | let attrs = ref (`Discard_empty : [`Discard|`Underscore|`Keep|`Discard_empty]) 11 | 12 | class out_value_builder = 13 | object 14 | method record (_ty : string) x = 15 | let x = 16 | List.filter (function (_, Oval_ellipsis) -> false | _ -> true) x 17 | in 18 | let f (l, s) = Oide_ident { printed_name = l }, s in 19 | Oval_record (List.map f x) 20 | method constr (_ty : string) (c, args) = 21 | Oval_constr (Oide_ident { printed_name = c }, args) 22 | method list x = Oval_list x 23 | method array x = Oval_list (Array.to_list x) 24 | method tuple x = Oval_tuple x 25 | method int x = Oval_int x 26 | method string x = Oval_string (x, max_int, Ostr_string) 27 | method char x = Oval_char x 28 | method int32 x = Oval_int32 x 29 | method int64 x = Oval_int64 x 30 | method nativeint x = Oval_nativeint x 31 | end 32 | 33 | let lift = 34 | object 35 | inherit [_] Ast_lifter.lifter as super 36 | inherit out_value_builder 37 | method! lift_Location_t l = 38 | match !locs with 39 | | `Discard -> Oval_ellipsis 40 | | `Underscore -> Oval_stuff "_" 41 | | `Keep -> super # lift_Location_t l 42 | method! lift_Parsetree_attributes l = 43 | match !attrs, l with 44 | | `Discard, _ | `Discard_empty, [] -> Oval_ellipsis 45 | | `Underscore, _ -> Oval_stuff "_" 46 | | `Keep, _ | (`Discard_empty, _ :: _) -> 47 | super # lift_Parsetree_attributes l 48 | end 49 | 50 | let show lifter parse s = 51 | let v = lifter (parse (Lexing.from_string s)) in 52 | Format.printf "%s@.==>@.%a@.=========@." s !Oprint.out_value v 53 | 54 | let show_expr = show (lift # lift_Parsetree_expression) Parse.expression 55 | let show_pat = show (lift # lift_Parsetree_pattern) Parse.pattern 56 | let show_typ = show (lift # lift_Parsetree_core_type) Parse.core_type 57 | 58 | let show_file fn = 59 | Compenv.readenv Format.err_formatter (Compenv.Before_compile fn); 60 | let v = 61 | if Filename.check_suffix fn ".mli" then 62 | let ast = Pparse.parse_interface ~tool_name:"ocamlc" fn in 63 | lift # lift_Parsetree_signature ast 64 | else if Filename.check_suffix fn ".ml" then 65 | let ast = Pparse.parse_implementation ~tool_name:"ocamlc" fn in 66 | lift # lift_Parsetree_structure ast 67 | else 68 | failwith (Printf.sprintf "Don't know what to do with file %s" fn) 69 | in 70 | Format.printf "%s@.==>@.%a@.=========@." fn !Oprint.out_value v 71 | 72 | let args = 73 | let open Arg in 74 | [ 75 | "-e", String show_expr, 76 | " Dump AST for expression ."; 77 | 78 | "-p", String show_pat, 79 | " Dump AST for pattern ."; 80 | 81 | "-t", String show_typ, 82 | " Dump AST for type expression ."; 83 | 84 | "-loc_discard", Unit (fun () -> locs := `Discard), 85 | " Discard location fields. (default)"; 86 | 87 | "-loc_underscore", Unit (fun () -> locs := `Underscore), 88 | " Display '_' for location fields"; 89 | 90 | "-loc_keep", Unit (fun () -> locs := `Keep), 91 | " Display real value of location fields"; 92 | 93 | "-attrs_discard_empty", Unit (fun () -> attrs := `Discard_empty), 94 | " Discard empty attribute fields. (default)"; 95 | 96 | "-attrs_discard", Unit (fun () -> attrs := `Discard), 97 | " Discard all attribute fields."; 98 | 99 | "-attrs_underscore", Unit (fun () -> attrs := `Underscore), 100 | " Display '_' for attribute fields"; 101 | 102 | "-attrs_keep", Unit (fun () -> attrs := `Keep), 103 | " Display real value of attribute fields"; 104 | 105 | "-pp", Arg.String (fun s -> Clflags.preprocessor := Some s), 106 | " Pipe sources through preprocessor "; 107 | 108 | "-ppx", Arg.String (fun s -> Compenv.first_ppx := s :: !Compenv.first_ppx), 109 | " Pipe abstract syntax trees through preprocessor "; 110 | ] 111 | 112 | 113 | let usage = 114 | Printf.sprintf "%s [options] [.ml/.mli files]\n" Sys.argv.(0) 115 | 116 | let () = 117 | Compenv.readenv Format.err_formatter Compenv.Before_args; 118 | try Arg.parse (Arg.align args) show_file usage 119 | with exn -> 120 | Errors.report_error Format.err_formatter exn; 121 | exit 2 122 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | ppx_tools 2 | ========= 3 | 4 | Tools for authors of syntactic tools (such as ppx rewriters). 5 | 6 | This package is licensed by LexiFi under the terms of the MIT license. 7 | 8 | The tools are installed as a findlib package called 'ppx_tools'. 9 | Executables are thus accessible through the ocamlfind driver (e.g.: 10 | ocamlfind ppx_tools/dumpast). 11 | 12 | Main contributors: 13 | 14 | - Alain Frisch 15 | - Peter Zotov (whitequark) 16 | - Gabriel Radanne (Drup) 17 | 18 | Master : [![Build Status](https://travis-ci.org/ocaml-ppx/ppx_tools.svg?branch=master)](https://travis-ci.org/ocaml-ppx/ppx_tools) 19 | 20 | 4.06 : [![Build Status](https://travis-ci.org/ocaml-ppx/ppx_tools.svg?branch=4.06)](https://travis-ci.org/ocaml-ppx/ppx_tools) 21 | 22 | 4.05 : [![Build Status](https://travis-ci.org/ocaml-ppx/ppx_tools.svg?branch=4.05)](https://travis-ci.org/ocaml-ppx/ppx_tools) 23 | 24 | 4.04 : [![Build Status](https://travis-ci.org/ocaml-ppx/ppx_tools.svg?branch=4.04)](https://travis-ci.org/ocaml-ppx/ppx_tools) 25 | 26 | 4.03 : [![Build Status](https://travis-ci.org/ocaml-ppx/ppx_tools.svg?branch=4.03)](https://travis-ci.org/ocaml-ppx/ppx_tools) 27 | 28 | 4.02 : [![Build Status](https://travis-ci.org/ocaml-ppx/ppx_tools.svg?branch=4.02)](https://travis-ci.org/ocaml-ppx/ppx_tools) 29 | 30 | ppx_metaquot 31 | ------------ 32 | 33 | A ppx filter to help writing programs which manipulate the Parsetree, 34 | by allowing the programmer to use concrete syntax for expressions 35 | creating Parsetree fragments and patterns deconstructing Parsetree 36 | fragments. See the top of ppx_metaquot.ml for a description of the 37 | supported extensions. 38 | 39 | Usage: 40 | 41 | ocamlfind ocamlc -c -package ppx_tools.metaquot my_ppx_code.ml 42 | 43 | 44 | rewriter 45 | -------- 46 | 47 | An utility to help testing ppx rewriters that runs the rewriter on 48 | user-provided code and returns the result. 49 | 50 | Usage: 51 | 52 | ocamlfind ppx_tools/rewriter ./my_ppx_rewriter sample.ml 53 | 54 | See the integrated help message for more details: 55 | 56 | ocamlfind ppx_tools/rewriter -help 57 | 58 | 59 | Ast_mapper_class 60 | ---------------- 61 | 62 | This module implements an API similar to Ast_mapper from the 63 | compiler-libs, i.e. a generic mapper from Parsetree to Parsetree 64 | implemeting a deep identity copy, which can be customized with a 65 | custom behavior for each syntactic category. The difference with 66 | Ast_mapper is that Ast_mapper_class implements the open recursion 67 | using a class. 68 | 69 | 70 | dumpast 71 | ------- 72 | 73 | This tool parses fragments of OCaml code (or entire source files) and 74 | dump the resulting internal Parsetree representation. Intended uses: 75 | 76 | - Help to learn about the OCaml Parsetree structure and how it 77 | corresponds to OCaml source syntax. 78 | 79 | - Create fragments of Parsetree to be copy-pasted into the source 80 | code of syntax-manipulating programs (such as ppx rewriters). 81 | 82 | Usage: 83 | 84 | ocamlfind ppx_tools/dumpast -e "1 + 2" 85 | 86 | The tool can be used to show the Parsetree representation of small 87 | fragments of syntax passed on the command line (-e for expressions, -p 88 | for patterns, -t for type expressions) or for entire .ml/mli files. 89 | The standard -pp and -ppx options are supported, but only applied on 90 | whole files. The tool has further option to control how location and 91 | attribute fields in the Parsetree should be displayed. 92 | 93 | 94 | genlifter 95 | --------- 96 | 97 | This tool generates a virtual "lifter" class for one or several OCaml 98 | type constructors. It does so by loading the .cmi files which define 99 | those types. The generated lifter class exposes one method to "reify" 100 | type constructors passed on the command-line and other type 101 | constructors accessible from them. The class is parametrized over the 102 | target type of the reification, and it must provide method to deal 103 | with basic types (int, string, char, int32, int64, nativeint) and data 104 | type builders (record, constr, tuple, list, array). As an example, 105 | calling: 106 | 107 | ocamlfind ppx_tools/genlifter -I +compiler-libs Location.t 108 | 109 | produces the following class: 110 | 111 | class virtual ['res] lifter = 112 | object (this) 113 | method lift_Location_t : Location.t -> 'res= 114 | fun 115 | { Location.loc_start = loc_start; Location.loc_end = loc_end; 116 | Location.loc_ghost = loc_ghost } 117 | -> 118 | this#record "Location.t" 119 | [("loc_start", (this#lift_Lexing_position loc_start)); 120 | ("loc_end", (this#lift_Lexing_position loc_end)); 121 | ("loc_ghost", (this#lift_bool loc_ghost))] 122 | method lift_bool : bool -> 'res= 123 | function 124 | | false -> this#constr "bool" ("false", []) 125 | | true -> this#constr "bool" ("true", []) 126 | method lift_Lexing_position : Lexing.position -> 'res= 127 | fun 128 | { Lexing.pos_fname = pos_fname; Lexing.pos_lnum = pos_lnum; 129 | Lexing.pos_bol = pos_bol; Lexing.pos_cnum = pos_cnum } 130 | -> 131 | this#record "Lexing.position" 132 | [("pos_fname", (this#string pos_fname)); 133 | ("pos_lnum", (this#int pos_lnum)); 134 | ("pos_bol", (this#int pos_bol)); 135 | ("pos_cnum", (this#int pos_cnum))] 136 | end 137 | 138 | _dumpast_ is a direct example of using _genlifter_ applied on the 139 | OCaml Parsetree definition itself. ppx_metaquot is another 140 | similar example. 141 | -------------------------------------------------------------------------------- /src/ast_convenience.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of the ppx_tools package. It is released *) 2 | (* under the terms of the MIT license (see LICENSE file). *) 3 | (* Copyright 2013 Alain Frisch and LexiFi *) 4 | 5 | open Parsetree 6 | open Asttypes 7 | open Location 8 | open Ast_helper 9 | 10 | 11 | module Label = struct 12 | 13 | type t = Asttypes.arg_label 14 | 15 | type desc = Asttypes.arg_label = 16 | Nolabel 17 | | Labelled of string 18 | | Optional of string 19 | 20 | let explode x = x 21 | 22 | let nolabel = Nolabel 23 | let labelled x = Labelled x 24 | let optional x = Optional x 25 | 26 | end 27 | 28 | module Constant = struct 29 | type t = Parsetree.constant = 30 | Pconst_integer of string * char option 31 | | Pconst_char of char 32 | #if OCAML_VERSION >= (4, 11, 0) 33 | | Pconst_string of string * Location.t * string option 34 | #else 35 | | Pconst_string of string * string option 36 | #endif 37 | | Pconst_float of string * char option 38 | 39 | let of_constant x = x 40 | 41 | let to_constant x = x 42 | 43 | end 44 | 45 | let may_tuple ?loc tup = function 46 | | [] -> None 47 | | [x] -> Some x 48 | | l -> Some (tup ?loc ?attrs:None l) 49 | 50 | #if OCAML_VERSION >= (4, 13, 0) 51 | let may_pat_tuple ?loc tup = function 52 | | [] -> None 53 | | [x] -> Some ([], x) 54 | | l -> Some ([], tup ?loc ?attrs:None l) 55 | #else 56 | let may_pat_tuple ?loc tup x = may_tuple ?loc tup x 57 | #endif 58 | 59 | let lid ?(loc = !default_loc) s = mkloc (Longident.parse s) loc [@ocaml.warning "-3"] 60 | let constr ?loc ?attrs s args = Exp.construct ?loc ?attrs (lid ?loc s) (may_tuple ?loc Exp.tuple args) 61 | let nil ?loc ?attrs () = constr ?loc ?attrs "[]" [] 62 | let unit ?loc ?attrs () = constr ?loc ?attrs "()" [] 63 | let tuple ?loc ?attrs = function 64 | | [] -> unit ?loc ?attrs () 65 | | [x] -> x 66 | | xs -> Exp.tuple ?loc ?attrs xs 67 | let cons ?loc ?attrs hd tl = constr ?loc ?attrs "::" [hd; tl] 68 | let list ?loc ?attrs l = List.fold_right (cons ?loc ?attrs) l (nil ?loc ?attrs ()) 69 | #if OCAML_VERSION >= (4, 11, 0) 70 | let str ?(loc = !default_loc) ?attrs s = Exp.constant ~loc ?attrs (Pconst_string (s, loc, None)) 71 | #else 72 | let str ?loc ?attrs s = Exp.constant ?loc ?attrs (Pconst_string (s, None)) 73 | #endif 74 | let int ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (string_of_int x, None)) 75 | let int32 ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (Int32.to_string x, Some 'l')) 76 | let int64 ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_integer (Int64.to_string x, Some 'L')) 77 | let char ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_char x) 78 | let float ?loc ?attrs x = Exp.constant ?loc ?attrs (Pconst_float (string_of_float x, None)) 79 | let record ?loc ?attrs ?over l = 80 | Exp.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.pexp_loc s, e)) l) over 81 | let func ?loc ?attrs l = Exp.function_ ?loc ?attrs (List.map (fun (p, e) -> Exp.case p e) l) 82 | let lam ?loc ?attrs ?(label = Label.nolabel) ?default pat exp = Exp.fun_ ?loc ?attrs label default pat exp 83 | let app ?loc ?attrs f l = if l = [] then f else Exp.apply ?loc ?attrs f (List.map (fun a -> Label.nolabel, a) l) 84 | let evar ?loc ?attrs s = Exp.ident ?loc ?attrs (lid ?loc s) 85 | let let_in ?loc ?attrs ?(recursive = false) b body = 86 | Exp.let_ ?loc ?attrs (if recursive then Recursive else Nonrecursive) b body 87 | 88 | let sequence ?loc ?attrs = function 89 | | [] -> unit ?loc ?attrs () 90 | | hd :: tl -> List.fold_left (fun e1 e2 -> Exp.sequence ?loc ?attrs e1 e2) hd tl 91 | 92 | let pvar ?(loc = !default_loc) ?attrs s = Pat.var ~loc ?attrs (mkloc s loc) 93 | let pconstr ?loc ?attrs s args = Pat.construct ?loc ?attrs (lid ?loc s) (may_pat_tuple ?loc Pat.tuple args) 94 | let precord ?loc ?attrs ?(closed = Open) l = 95 | Pat.record ?loc ?attrs (List.map (fun (s, e) -> (lid ~loc:e.ppat_loc s, e)) l) closed 96 | let pnil ?loc ?attrs () = pconstr ?loc ?attrs "[]" [] 97 | let pcons ?loc ?attrs hd tl = pconstr ?loc ?attrs "::" [hd; tl] 98 | let punit ?loc ?attrs () = pconstr ?loc ?attrs "()" [] 99 | let ptuple ?loc ?attrs = function 100 | | [] -> punit ?loc ?attrs () 101 | | [x] -> x 102 | | xs -> Pat.tuple ?loc ?attrs xs 103 | let plist ?loc ?attrs l = List.fold_right (pcons ?loc ?attrs) l (pnil ?loc ?attrs ()) 104 | 105 | #if OCAML_VERSION >= (4, 11, 0) 106 | let pstr ?(loc = !default_loc) ?attrs s = Pat.constant ~loc ?attrs (Pconst_string (s, loc, None)) 107 | #else 108 | let pstr ?loc ?attrs s = Pat.constant ?loc ?attrs (Pconst_string (s, None)) 109 | #endif 110 | let pint ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_integer (string_of_int x, None)) 111 | let pchar ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_char x) 112 | let pfloat ?loc ?attrs x = Pat.constant ?loc ?attrs (Pconst_float (string_of_float x, None)) 113 | 114 | let tconstr ?loc ?attrs c l = Typ.constr ?loc ?attrs (lid ?loc c) l 115 | 116 | let get_str = function 117 | #if OCAML_VERSION >= (4, 11, 0) 118 | | {pexp_desc=Pexp_constant (Pconst_string (s, _, _)); _} -> Some s 119 | #else 120 | | {pexp_desc=Pexp_constant (Pconst_string (s, _)); _} -> Some s 121 | #endif 122 | | _ -> None 123 | 124 | let get_str_with_quotation_delimiter = function 125 | #if OCAML_VERSION >= (4, 11, 0) 126 | | {pexp_desc=Pexp_constant (Pconst_string (s, _, d)); _} -> Some (s, d) 127 | #else 128 | | {pexp_desc=Pexp_constant (Pconst_string (s, d)); _} -> Some (s, d) 129 | #endif 130 | | _ -> None 131 | 132 | let get_lid = function 133 | | {pexp_desc=Pexp_ident{txt=id;_};_} -> 134 | Some (String.concat "." (Longident.flatten id)) 135 | | _ -> None 136 | 137 | let find_attr s attrs = 138 | try Some ((List.find (fun {attr_name=x;_} -> x.txt = s) attrs).attr_payload) 139 | with Not_found -> None 140 | 141 | let expr_of_payload = function 142 | | PStr [{pstr_desc=Pstr_eval(e, _); _}] -> Some e 143 | | _ -> None 144 | 145 | let find_attr_expr s attrs = 146 | match find_attr s attrs with 147 | | Some e -> expr_of_payload e 148 | | None -> None 149 | 150 | let has_attr s attrs = 151 | find_attr s attrs <> None 152 | -------------------------------------------------------------------------------- /src/genlifter.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of the ppx_tools package. It is released *) 2 | (* under the terms of the MIT license (see LICENSE file). *) 3 | (* Copyright 2013 Alain Frisch and LexiFi *) 4 | 5 | 6 | (* Generate code to lift values of a certain type. 7 | This illustrates how to build fragments of Parsetree through 8 | Ast_helper and more local helper functions. *) 9 | 10 | module Main : sig end = struct 11 | 12 | open Location 13 | open Types 14 | open Asttypes 15 | open Ast_helper 16 | open Ast_convenience 17 | 18 | let selfcall ?(this = "this") m args = app (Exp.send (evar this) (mknoloc m)) args 19 | 20 | (*************************************************************************) 21 | 22 | module Compat = struct 23 | #if OCAML_VERSION >= (4, 14, 0) 24 | let get_desc = Types.get_desc 25 | let repr = Transient_expr.repr 26 | #else 27 | let get_desc x = x.desc 28 | let repr x = x 29 | #endif 30 | end 31 | 32 | #if OCAML_VERSION >= (5, 0, 0) 33 | let env = Env.initial 34 | #else 35 | let env = Env.initial_safe_string 36 | #endif 37 | 38 | let clean s = 39 | let s = Bytes.of_string s in 40 | for i = 0 to Bytes.length s - 1 do 41 | if Bytes.get s i = '.' then Bytes.set s i '_' 42 | done; 43 | Bytes.to_string s 44 | 45 | let print_fun s = "lift_" ^ clean s 46 | 47 | let printed = Hashtbl.create 16 48 | let meths = ref [] 49 | let use_existentials = ref false 50 | let use_arrows = ref false 51 | 52 | let existential_method = 53 | Cf.(method_ (mknoloc "existential") Public 54 | (virtual_ Typ.(poly [mknoloc "a"] (arrow Nolabel (var "a") (var "res")))) 55 | ) 56 | 57 | let arrow_method = 58 | Cf.(method_ (mknoloc "arrow") Public 59 | (virtual_ Typ.(poly [mknoloc "a"] (arrow Nolabel (var "a") (var "res")))) 60 | ) 61 | 62 | let rec gen ty = 63 | if Hashtbl.mem printed ty then () 64 | else let tylid = Longident.parse ty [@ocaml.warning "-3"] in 65 | let td = 66 | #if OCAML_VERSION >= (4, 10, 0) 67 | try snd (Env.find_type_by_name tylid env) 68 | #else 69 | try Env.find_type (Env.lookup_type tylid env) env 70 | #endif 71 | with Not_found -> 72 | Format.eprintf "** Cannot resolve type %s@." ty; 73 | exit 2 74 | in 75 | let prefix = 76 | let open Longident in 77 | match tylid with 78 | | Ldot (m, _) -> String.concat "." (Longident.flatten m) ^ "." 79 | | Lident _ -> "" 80 | | Lapply _ -> assert false 81 | in 82 | Hashtbl.add printed ty (); 83 | let params = List.mapi (fun i _ -> mknoloc (Printf.sprintf "f%i" i)) td.type_params in 84 | let env = List.map2 (fun s t -> (Compat.repr t).id, evar s.txt) params td.type_params in 85 | let make_result_t tyargs = Typ.(arrow Asttypes.Nolabel (constr (lid ty) tyargs) (var "res")) in 86 | let make_t tyargs = 87 | List.fold_right 88 | (fun arg t -> 89 | Typ.(arrow Asttypes.Nolabel (arrow Asttypes.Nolabel arg (var "res")) t)) 90 | tyargs (make_result_t tyargs) 91 | in 92 | let tyargs = List.map (fun t -> Typ.var t.txt) params in 93 | let t = Typ.poly params (make_t tyargs) in 94 | let concrete e = 95 | let e = List.fold_right (fun x e -> lam x e) (List.map (fun x -> pvar x.txt) params) e in 96 | let tyargs = List.map (fun t -> Typ.constr (lid t.txt) []) params in 97 | let e = Exp.constraint_ e (make_t tyargs) in 98 | let e = List.fold_right (fun x e -> Exp.newtype x e) params e in 99 | let body = Exp.poly e (Some t) in 100 | meths := Cf.(method_ (mknoloc (print_fun ty)) Public (concrete Fresh body)) :: !meths 101 | in 102 | let field ld = 103 | let s = Ident.name ld.ld_id in 104 | (lid (prefix ^ s), pvar s), 105 | tuple[str s; tyexpr env ld.ld_type (evar s)] 106 | in 107 | match td.type_kind, td.type_manifest with 108 | | Type_record (l, _), _ -> 109 | let l = List.map field l in 110 | concrete 111 | (lam 112 | (Pat.record (List.map fst l) Closed) 113 | (selfcall "record" [str ty; list (List.map snd l)])) 114 | #if OCAML_VERSION >= (4, 13, 0) 115 | | Type_variant (l, _rep), _ -> 116 | #else 117 | | Type_variant l, _ -> 118 | #endif 119 | let case cd = 120 | let c = Ident.name cd.cd_id in 121 | let qc = prefix ^ c in 122 | match cd.cd_args with 123 | | Cstr_tuple (tys) -> 124 | let p, args = gentuple env tys in 125 | pconstr qc p, selfcall "constr" [str ty; tuple[str c; list args]] 126 | | Cstr_record (l) -> 127 | let l = List.map field l in 128 | let keep_head ((lid, pattern), _) = 129 | let txt = Longident.Lident (Longident.last lid.txt) in 130 | ({lid with txt}, pattern) 131 | in 132 | pconstr qc [Pat.record (List.map keep_head l) Closed], 133 | selfcall "constr" 134 | [str ty; 135 | tuple [str c; 136 | list [selfcall "record" 137 | [str ""; list (List.map snd l)]]]] 138 | in 139 | concrete (func (List.map case l)) 140 | | Type_abstract, Some t -> 141 | concrete (tyexpr_fun env t) 142 | | Type_abstract, None -> 143 | (* Generate an abstract method to lift abstract types *) 144 | meths := Cf.(method_ (mknoloc (print_fun ty)) Public (virtual_ t)) :: !meths 145 | | Type_open, _ -> 146 | failwith "Open types are not yet supported." 147 | 148 | and gentuple env tl = 149 | let arg i t = 150 | let x = Printf.sprintf "x%i" i in 151 | pvar x, tyexpr env t (evar x) 152 | in 153 | List.split (List.mapi arg tl) 154 | 155 | and tyexpr env ty x = 156 | match Compat.get_desc ty with 157 | | Tvar _ -> 158 | (match List.assoc (Compat.repr ty).id env with 159 | | f -> app f [x] 160 | | exception Not_found -> 161 | use_existentials := true; 162 | selfcall "existential" [x]) 163 | | Ttuple tl -> 164 | let p, e = gentuple env tl in 165 | let_in [Vb.mk (Pat.tuple p) x] (selfcall "tuple" [list e]) 166 | | Tconstr (path, [t], _) when Path.same path Predef.path_list -> 167 | selfcall "list" [app (evar "List.map") [tyexpr_fun env t; x]] 168 | | Tconstr (path, [t], _) when Path.same path Predef.path_array -> 169 | selfcall "array" [app (evar "Array.map") [tyexpr_fun env t; x]] 170 | | Tconstr (path, [], _) when Path.same path Predef.path_string -> 171 | selfcall "string" [x] 172 | | Tconstr (path, [], _) when Path.same path Predef.path_int -> 173 | selfcall "int" [x] 174 | | Tconstr (path, [], _) when Path.same path Predef.path_char -> 175 | selfcall "char" [x] 176 | | Tconstr (path, [], _) when Path.same path Predef.path_int32 -> 177 | selfcall "int32" [x] 178 | | Tconstr (path, [], _) when Path.same path Predef.path_int64 -> 179 | selfcall "int64" [x] 180 | | Tconstr (path, [], _) when Path.same path Predef.path_nativeint -> 181 | selfcall "nativeint" [x] 182 | | Tconstr (path, tl, _) -> 183 | let ty = Path.name path in 184 | gen ty; 185 | selfcall (print_fun ty) (List.map (tyexpr_fun env) tl @ [x]) 186 | | Tarrow _ -> 187 | use_arrows := true; 188 | selfcall "arrow" [x] 189 | | _ -> 190 | Format.eprintf "** Cannot deal with type %a@." Printtyp.type_expr ty; 191 | exit 2 192 | 193 | and tyexpr_fun env ty = 194 | lam (pvar "x") (tyexpr env ty (evar "x")) 195 | 196 | let simplify = 197 | (* (fun x -> x) ====> *) 198 | let open Ast_mapper in 199 | let super = default_mapper in 200 | let expr this e = 201 | let e = super.expr this e in 202 | let open Longident in 203 | let open Parsetree in 204 | match e.pexp_desc with 205 | | Pexp_fun 206 | (Asttypes.Nolabel, None, 207 | {ppat_desc = Ppat_var{txt=id;_};_}, 208 | {pexp_desc = 209 | Pexp_apply 210 | (f, 211 | [Asttypes.Nolabel 212 | ,{pexp_desc= Pexp_ident{txt=Lident id2;_};_}]);_}) 213 | when id = id2 -> f 214 | | _ -> e 215 | in 216 | {super with expr} 217 | 218 | let args = 219 | let open Arg in 220 | [ 221 | "-I", String (fun s -> Load_path.add_dir (Misc.expand_directory Config.standard_library s)), 222 | " Add to the list of include directories"; 223 | ] 224 | 225 | let usage = 226 | Printf.sprintf "%s [options] \n" Sys.argv.(0) 227 | 228 | let main () = 229 | #if OCAML_VERSION >= (5, 0, 0) 230 | Load_path.init ~auto_include:Load_path.no_auto_include [Config.standard_library]; 231 | #else 232 | Load_path.init [Config.standard_library]; 233 | #endif 234 | Arg.parse (Arg.align args) gen usage; 235 | let meths = !meths in 236 | let meths = 237 | if !use_existentials then 238 | existential_method :: meths 239 | else 240 | meths 241 | in 242 | let meths = 243 | if !use_arrows then 244 | arrow_method :: meths 245 | else 246 | meths 247 | in 248 | let cl = Cstr.mk (pvar "this") meths in 249 | #if OCAML_VERSION >= (4, 12, 0) 250 | let params = [Typ.var "res", (NoVariance, NoInjectivity)] in 251 | #else 252 | let params = [Typ.var "res", Invariant] in 253 | #endif 254 | let cl = Ci.mk ~virt:Virtual ~params (mknoloc "lifter") (Cl.structure cl) in 255 | let s = [Str.class_ [cl]] in 256 | Format.printf "%a@." Pprintast.structure (simplify.Ast_mapper.structure simplify s) 257 | 258 | let () = 259 | try main () 260 | with exn -> 261 | Printf.eprintf "** fatal error: %s\n%!" (Printexc.to_string exn) 262 | 263 | end 264 | -------------------------------------------------------------------------------- /src/ppx_metaquot.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of the ppx_tools package. It is released *) 2 | (* under the terms of the MIT license (see LICENSE file). *) 3 | (* Copyright 2013 Alain Frisch and LexiFi *) 4 | 5 | (* A -ppx rewriter to be used to write Parsetree-generating code 6 | (including other -ppx rewriters) using concrete syntax. 7 | 8 | We support the following extensions in expression position: 9 | 10 | [%expr ...] maps to code which creates the expression represented by ... 11 | [%pat? ...] maps to code which creates the pattern represented by ... 12 | [%str ...] maps to code which creates the structure represented by ... 13 | [%stri ...] maps to code which creates the structure item represented by ... 14 | [%sig: ...] maps to code which creates the signature represented by ... 15 | [%sigi: ...] maps to code which creates the signature item represented by ... 16 | [%type: ...] maps to code which creates the core type represented by ... 17 | 18 | Quoted code can refer to expressions representing AST fragments, 19 | using the following extensions: 20 | 21 | [%e ...] where ... is an expression of type Parsetree.expression 22 | [%t ...] where ... is an expression of type Parsetree.core_type 23 | [%p ...] where ... is an expression of type Parsetree.pattern 24 | [%%s ...] where ... is an expression of type Parsetree.structure 25 | or Parsetree.signature depending on the context. 26 | 27 | 28 | All locations generated by the meta quotation are by default set 29 | to [Ast_helper.default_loc]. This can be overriden by providing a custom 30 | expression which will be inserted whereever a location is required 31 | in the generated AST. This expression can be specified globally 32 | (for the current structure) as a structure item attribute: 33 | 34 | ;;[@@metaloc ...] 35 | 36 | or locally for the scope of an expression: 37 | 38 | e [@metaloc ...] 39 | 40 | 41 | 42 | Support is also provided to use concrete syntax in pattern 43 | position. The location and attribute fields are currently ignored 44 | by patterns generated from meta quotations. 45 | 46 | We support the following extensions in pattern position: 47 | 48 | [%expr ...] maps to code which creates the expression represented by ... 49 | [%pat? ...] maps to code which creates the pattern represented by ... 50 | [%str ...] maps to code which creates the structure represented by ... 51 | [%type: ...] maps to code which creates the core type represented by ... 52 | 53 | Quoted code can refer to expressions representing AST fragments, 54 | using the following extensions: 55 | 56 | [%e? ...] where ... is a pattern of type Parsetree.expression 57 | [%t? ...] where ... is a pattern of type Parsetree.core_type 58 | [%p? ...] where ... is a pattern of type Parsetree.pattern 59 | 60 | *) 61 | 62 | module Main : sig 63 | val main : unit -> unit 64 | end = struct 65 | open Asttypes 66 | open Parsetree 67 | open Ast_helper 68 | open Ast_convenience 69 | 70 | let prefix ty s = 71 | let open Longident in 72 | match Longident.parse ty [@ocaml.warning "-3"] with 73 | | Ldot(m, _) -> String.concat "." (Longident.flatten m) ^ "." ^ s 74 | | _ -> s 75 | 76 | let append ?loc ?attrs e e' = 77 | let fn = Location.mknoloc (Longident.(Ldot (Lident "List", "append"))) in 78 | Exp.apply ?loc ?attrs (Exp.ident fn) [Nolabel, e; Nolabel, e'] 79 | 80 | class exp_builder = 81 | object 82 | method record ty x = record (List.map (fun (l, e) -> prefix ty l, e) x) 83 | method constr ty (c, args) = constr (prefix ty c) args 84 | method list l = list l 85 | method tuple l = tuple l 86 | method int i = int i 87 | method string s = str s 88 | method char c = char c 89 | method int32 x = Exp.constant (Const.int32 x) 90 | method int64 x = Exp.constant (Const.int64 x) 91 | method nativeint x = Exp.constant (Const.nativeint x) 92 | end 93 | 94 | class pat_builder = 95 | object 96 | method record ty x = precord ~closed:Closed (List.map (fun (l, e) -> prefix ty l, e) x) 97 | method constr ty (c, args) = pconstr (prefix ty c) args 98 | method list l = plist l 99 | method tuple l = ptuple l 100 | method int i = pint i 101 | method string s = pstr s 102 | method char c = pchar c 103 | method int32 x = Pat.constant (Const.int32 x) 104 | method int64 x = Pat.constant (Const.int64 x) 105 | method nativeint x = Pat.constant (Const.nativeint x) 106 | end 107 | 108 | 109 | let get_exp loc = function 110 | | PStr [ {pstr_desc=Pstr_eval (e, _); _} ] -> e 111 | | _ -> 112 | let report = Location.error ~loc "Expression expected." in 113 | Location.print_report Format.err_formatter report; 114 | exit 2 115 | 116 | let get_typ loc = function 117 | | PTyp t -> t 118 | | _ -> 119 | let report = Location.error ~loc "Type expected." in 120 | Location.print_report Format.err_formatter report; 121 | exit 2 122 | 123 | let get_pat loc = function 124 | | PPat (t, None) -> t 125 | | _ -> 126 | let report = Location.error ~loc "Pattern expected." in 127 | Location.print_report Format.err_formatter report; 128 | exit 2 129 | 130 | let exp_lifter loc map = 131 | let map = map.Ast_mapper.expr map in 132 | object 133 | inherit [_] Ast_lifter.lifter as super 134 | inherit exp_builder 135 | 136 | (* Special support for location in the generated AST *) 137 | method! lift_Location_t _ = loc 138 | 139 | (* Support for antiquotations *) 140 | method! lift_Parsetree_expression = function 141 | | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> map (get_exp loc e) 142 | | x -> super # lift_Parsetree_expression x 143 | 144 | method! lift_Parsetree_pattern = function 145 | | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> map (get_exp loc e) 146 | | x -> super # lift_Parsetree_pattern x 147 | 148 | method! lift_Parsetree_structure str = 149 | List.fold_right 150 | (function 151 | | {pstr_desc=Pstr_extension(({txt="s";loc}, e), _); _} -> 152 | append (get_exp loc e) 153 | | x -> 154 | cons (super # lift_Parsetree_structure_item x)) 155 | str (nil ()) 156 | 157 | method! lift_Parsetree_signature sign = 158 | List.fold_right 159 | (function 160 | | {psig_desc=Psig_extension(({txt="s";loc}, e), _); _} -> 161 | append (get_exp loc e) 162 | | x -> 163 | cons (super # lift_Parsetree_signature_item x)) 164 | sign (nil ()) 165 | 166 | method! lift_Parsetree_core_type = function 167 | | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} ->map (get_exp loc e) 168 | | x -> super # lift_Parsetree_core_type x 169 | end 170 | 171 | let pat_lifter map = 172 | let map = map.Ast_mapper.pat map in 173 | object 174 | inherit [_] Ast_lifter.lifter as super 175 | inherit pat_builder as builder 176 | 177 | (* Special support for location and attributes in the generated AST *) 178 | method! lift_Location_t _ = Pat.any () 179 | method! lift_Parsetree_attributes _ = Pat.any () 180 | method! record n fields = 181 | let fields = 182 | List.map (fun (name, pat) -> 183 | match name with 184 | | "pexp_loc_stack" | "ppat_loc_stack" | "ptyp_loc_stack" -> 185 | name, Pat.any () 186 | | _ -> name, pat) fields 187 | in 188 | builder#record n fields 189 | 190 | (* Support for antiquotations *) 191 | method! lift_Parsetree_expression = function 192 | | {pexp_desc=Pexp_extension({txt="e";loc}, e); _} -> map (get_pat loc e) 193 | | x -> super # lift_Parsetree_expression x 194 | 195 | method! lift_Parsetree_pattern = function 196 | | {ppat_desc=Ppat_extension({txt="p";loc}, e); _} -> map (get_pat loc e) 197 | | x -> super # lift_Parsetree_pattern x 198 | 199 | method! lift_Parsetree_core_type = function 200 | | {ptyp_desc=Ptyp_extension({txt="t";loc}, e); _} -> map (get_pat loc e) 201 | | x -> super # lift_Parsetree_core_type x 202 | end 203 | 204 | let loc = ref (app (evar "Stdlib.!") [evar "Ast_helper.default_loc"]) 205 | 206 | let handle_attr = function 207 | | {attr_name={txt="metaloc";loc=l}; attr_payload=e; _} -> loc := get_exp l e 208 | | _ -> () 209 | 210 | let with_loc ?(attrs = []) f = 211 | let old_loc = !loc in 212 | List.iter handle_attr attrs; 213 | let r = f () in 214 | loc := old_loc; 215 | r 216 | 217 | let expander _args = 218 | let open Ast_mapper in 219 | let super = default_mapper in 220 | let expr this e = 221 | with_loc ~attrs:e.pexp_attributes 222 | (fun () -> 223 | match e.pexp_desc with 224 | | Pexp_extension({txt="expr";loc=l}, e) -> 225 | (exp_lifter !loc this) # lift_Parsetree_expression (get_exp l e) 226 | | Pexp_extension({txt="pat";loc=l}, e) -> 227 | (exp_lifter !loc this) # lift_Parsetree_pattern (get_pat l e) 228 | | Pexp_extension({txt="str";_}, PStr e) -> 229 | (exp_lifter !loc this) # lift_Parsetree_structure e 230 | | Pexp_extension({txt="stri";_}, PStr [e]) -> 231 | (exp_lifter !loc this) # lift_Parsetree_structure_item e 232 | | Pexp_extension({txt="sig";_}, PSig e) -> 233 | (exp_lifter !loc this) # lift_Parsetree_signature e 234 | | Pexp_extension({txt="sigi";_}, PSig [e]) -> 235 | (exp_lifter !loc this) # lift_Parsetree_signature_item e 236 | | Pexp_extension({txt="type";loc=l}, e) -> 237 | (exp_lifter !loc this) # lift_Parsetree_core_type (get_typ l e) 238 | | _ -> 239 | super.expr this e 240 | ) 241 | and pat this p = 242 | with_loc ~attrs:p.ppat_attributes 243 | (fun () -> 244 | match p.ppat_desc with 245 | | Ppat_extension({txt="expr";loc=l}, e) -> 246 | (pat_lifter this) # lift_Parsetree_expression (get_exp l e) 247 | | Ppat_extension({txt="pat";loc=l}, e) -> 248 | (pat_lifter this) # lift_Parsetree_pattern (get_pat l e) 249 | | Ppat_extension({txt="str";_}, PStr e) -> 250 | (pat_lifter this) # lift_Parsetree_structure e 251 | | Ppat_extension({txt="stri";_}, PStr [e]) -> 252 | (pat_lifter this) # lift_Parsetree_structure_item e 253 | | Ppat_extension({txt="sig";_}, PSig e) -> 254 | (pat_lifter this) # lift_Parsetree_signature e 255 | | Ppat_extension({txt="sigi";_}, PSig [e]) -> 256 | (pat_lifter this) # lift_Parsetree_signature_item e 257 | | Ppat_extension({txt="type";loc=l}, e) -> 258 | (pat_lifter this) # lift_Parsetree_core_type (get_typ l e) 259 | | _ -> 260 | super.pat this p 261 | ) 262 | and structure this l = 263 | with_loc 264 | (fun () -> super.structure this l) 265 | 266 | and structure_item this x = 267 | begin match x.pstr_desc with 268 | | Pstr_attribute x -> handle_attr x 269 | | _ -> () 270 | end; 271 | super.structure_item this x 272 | 273 | and signature this l = 274 | with_loc 275 | (fun () -> super.signature this l) 276 | 277 | and signature_item this x = 278 | begin match x.psig_desc with 279 | | Psig_attribute x -> handle_attr x 280 | | _ -> () 281 | end; 282 | super.signature_item this x 283 | 284 | in 285 | {super with expr; pat; structure; structure_item; signature; signature_item} 286 | 287 | let main () = Ast_mapper.run_main expander 288 | end 289 | -------------------------------------------------------------------------------- /src/ast_mapper_class.ml: -------------------------------------------------------------------------------- 1 | (* This file is part of the ppx_tools package. It is released *) 2 | (* under the terms of the MIT license (see LICENSE file). *) 3 | (* Copyright 2013 Alain Frisch and LexiFi *) 4 | 5 | (** Class-based customizable mapper *) 6 | 7 | open Parsetree 8 | open Asttypes 9 | open Ast_helper 10 | 11 | let map_fst f (x, y) = (f x, y) 12 | let map_snd f (x, y) = (x, f y) 13 | let map_tuple f1 f2 (x, y) = (f1 x, f2 y) 14 | let map_tuple3 f1 f2 f3 (x, y, z) = (f1 x, f2 y, f3 z) 15 | let map_opt f = function None -> None | Some x -> Some (f x) 16 | 17 | let map_loc sub {loc; txt} = {loc = sub # location loc; txt} 18 | 19 | #if OCAML_VERSION >= (4, 13, 0) 20 | let map_pat_opt sub f = function 21 | | None -> None 22 | | Some (exist, x) -> Some (List.map (map_loc sub) exist, f x) 23 | #else 24 | let map_pat_opt _sub f x = map_opt f x 25 | #endif 26 | 27 | module T = struct 28 | (* Type expressions for the core language *) 29 | 30 | let row_field_desc sub = function 31 | | Rtag (l, b, tl) -> Rtag (l, b, List.map (sub # typ) tl) 32 | | Rinherit t -> Rinherit (sub # typ t) 33 | 34 | let row_field sub {prf_desc = desc; prf_loc = loc; prf_attributes = attrs} = 35 | let desc = row_field_desc sub desc in 36 | let loc = sub # location loc in 37 | let attrs = sub # attributes attrs in 38 | {prf_desc = desc; prf_loc = loc; prf_attributes = attrs} 39 | 40 | let object_field_desc sub = function 41 | | Otag (s, t) -> Otag (s, sub # typ t) 42 | | Oinherit t -> Oinherit (sub # typ t) 43 | 44 | let object_field sub {pof_desc = desc; pof_loc = loc; pof_attributes = attrs} = 45 | let desc = object_field_desc sub desc in 46 | let loc = sub # location loc in 47 | let attrs = sub # attributes attrs in 48 | {pof_desc = desc; pof_loc = loc; pof_attributes = attrs} 49 | 50 | let map sub {ptyp_desc = desc; ptyp_loc = loc; ptyp_loc_stack = _; ptyp_attributes = attrs} = 51 | let open Typ in 52 | let loc = sub # location loc in 53 | let attrs = sub # attributes attrs in 54 | match desc with 55 | | Ptyp_any -> any ~loc ~attrs () 56 | | Ptyp_var s -> var ~loc ~attrs s 57 | | Ptyp_arrow (lab, t1, t2) -> 58 | arrow ~loc ~attrs lab (sub # typ t1) (sub # typ t2) 59 | | Ptyp_tuple tyl -> tuple ~loc ~attrs (List.map (sub # typ) tyl) 60 | | Ptyp_constr (lid, tl) -> 61 | constr ~loc ~attrs (map_loc sub lid) (List.map (sub # typ) tl) 62 | | Ptyp_object (l, o) -> 63 | object_ ~loc ~attrs (List.map (object_field sub) l) o 64 | | Ptyp_class (lid, tl) -> 65 | class_ ~loc ~attrs (map_loc sub lid) (List.map (sub # typ) tl) 66 | | Ptyp_alias (t, s) -> alias ~loc ~attrs (sub # typ t) s 67 | | Ptyp_variant (rl, b, ll) -> 68 | variant ~loc ~attrs (List.map (row_field sub) rl) b ll 69 | | Ptyp_poly (sl, t) -> poly ~loc ~attrs sl (sub # typ t) 70 | | Ptyp_package (lid, l) -> 71 | package ~loc ~attrs (map_loc sub lid) 72 | (List.map (map_tuple (map_loc sub) (sub # typ)) l) 73 | | Ptyp_extension x -> extension ~loc ~attrs (sub # extension x) 74 | 75 | let map_type_declaration sub 76 | {ptype_name; ptype_params; ptype_cstrs; 77 | ptype_kind; 78 | ptype_private; 79 | ptype_manifest; 80 | ptype_attributes; 81 | ptype_loc} = 82 | Type.mk (map_loc sub ptype_name) 83 | ~params:(List.map (map_fst (sub # typ)) ptype_params) 84 | ~priv:ptype_private 85 | ~cstrs:(List.map (map_tuple3 (sub # typ) (sub # typ) (sub # location)) 86 | ptype_cstrs) 87 | ~kind:(sub # type_kind ptype_kind) 88 | ?manifest:(map_opt (sub # typ) ptype_manifest) 89 | ~loc:(sub # location ptype_loc) 90 | ~attrs:(sub # attributes ptype_attributes) 91 | 92 | let map_type_kind sub = function 93 | | Ptype_abstract -> Ptype_abstract 94 | | Ptype_variant l -> 95 | Ptype_variant (List.map (sub # constructor_declaration) l) 96 | | Ptype_record l -> Ptype_record (List.map (sub # label_declaration) l) 97 | | Ptype_open -> Ptype_open 98 | 99 | let map_type_extension sub 100 | {ptyext_path; ptyext_params; 101 | ptyext_constructors; 102 | ptyext_private; 103 | ptyext_loc; 104 | ptyext_attributes} = 105 | Te.mk 106 | (map_loc sub ptyext_path) 107 | (List.map (sub # extension_constructor) ptyext_constructors) 108 | ~params:(List.map (map_fst (sub # typ)) ptyext_params) 109 | ~priv:ptyext_private 110 | ~loc:(sub # location ptyext_loc) 111 | ~attrs:(sub # attributes ptyext_attributes) 112 | 113 | let map_extension_constructor_kind sub = function 114 | #if OCAML_VERSION >= (4, 14, 0) 115 | Pext_decl(vars, ctl, cto) -> 116 | Pext_decl(List.map (map_loc sub) vars, sub # constructor_arguments ctl, map_opt (sub # typ) cto) 117 | #else 118 | Pext_decl(ctl, cto) -> 119 | Pext_decl(sub # constructor_arguments ctl, map_opt (sub # typ) cto) 120 | #endif 121 | | Pext_rebind li -> 122 | Pext_rebind (map_loc sub li) 123 | 124 | let map_extension_constructor sub 125 | {pext_name; 126 | pext_kind; 127 | pext_loc; 128 | pext_attributes} = 129 | Te.constructor 130 | (map_loc sub pext_name) 131 | (map_extension_constructor_kind sub pext_kind) 132 | ~loc:(sub # location pext_loc) 133 | ~attrs:(sub # attributes pext_attributes) 134 | 135 | let map_type_exception sub {ptyexn_constructor; ptyexn_loc; ptyexn_attributes} = 136 | Te.mk_exception 137 | (map_extension_constructor sub ptyexn_constructor) 138 | ~loc:(sub # location ptyexn_loc) 139 | ~attrs:(sub # attributes ptyexn_attributes) 140 | 141 | end 142 | 143 | module CT = struct 144 | (* Type expressions for the class language *) 145 | 146 | let map sub {pcty_loc = loc; pcty_desc = desc; pcty_attributes = attrs} = 147 | let open Cty in 148 | let loc = sub # location loc in 149 | match desc with 150 | | Pcty_constr (lid, tys) -> 151 | constr ~loc ~attrs (map_loc sub lid) (List.map (sub # typ) tys) 152 | | Pcty_signature x -> signature ~loc ~attrs (sub # class_signature x) 153 | | Pcty_arrow (lab, t, ct) -> 154 | arrow ~loc ~attrs lab (sub # typ t) (sub # class_type ct) 155 | | Pcty_extension x -> extension ~loc ~attrs (sub # extension x) 156 | | Pcty_open (od, ct) -> 157 | open_ ~loc ~attrs (sub # open_description od) (sub # class_type ct) 158 | 159 | let map_field sub {pctf_desc = desc; pctf_loc = loc; pctf_attributes = attrs} 160 | = 161 | let open Ctf in 162 | let loc = sub # location loc in 163 | match desc with 164 | | Pctf_inherit ct -> inherit_ ~loc ~attrs (sub # class_type ct) 165 | | Pctf_val (s, m, v, t) -> val_ ~loc ~attrs s m v (sub # typ t) 166 | | Pctf_method (s, p, v, t) -> method_ ~loc ~attrs s p v (sub # typ t) 167 | | Pctf_constraint (t1, t2) -> 168 | constraint_ ~loc ~attrs (sub # typ t1) (sub # typ t2) 169 | | Pctf_attribute x -> attribute ~loc (sub # attribute x) 170 | | Pctf_extension x -> extension ~loc ~attrs (sub # extension x) 171 | 172 | let map_signature sub {pcsig_self; pcsig_fields} = 173 | Csig.mk 174 | (sub # typ pcsig_self) 175 | (List.map (sub # class_type_field) pcsig_fields) 176 | end 177 | 178 | #if OCAML_VERSION >= (4, 10, 0) 179 | let map_functor_param sub = function 180 | | Unit -> Unit 181 | | Named (s, mt) -> Named (map_loc sub s, sub # module_type mt) 182 | #endif 183 | 184 | module MT = struct 185 | (* Type expressions for the module language *) 186 | 187 | let map sub {pmty_desc = desc; pmty_loc = loc; pmty_attributes = attrs} = 188 | let open Mty in 189 | let loc = sub # location loc in 190 | let attrs = sub # attributes attrs in 191 | match desc with 192 | | Pmty_ident s -> ident ~loc ~attrs (map_loc sub s) 193 | | Pmty_alias s -> alias ~loc ~attrs (map_loc sub s) 194 | | Pmty_signature sg -> signature ~loc ~attrs (sub # signature sg) 195 | #if OCAML_VERSION >= (4, 10, 0) 196 | | Pmty_functor (param, mt) -> 197 | functor_ ~loc ~attrs 198 | (map_functor_param sub param) 199 | (sub # module_type mt) 200 | #else 201 | | Pmty_functor (s, mt1, mt2) -> 202 | functor_ ~loc ~attrs (map_loc sub s) 203 | (map_opt (sub # module_type) mt1) 204 | (sub # module_type mt2) 205 | #endif 206 | | Pmty_with (mt, l) -> 207 | with_ ~loc ~attrs (sub # module_type mt) 208 | (List.map (sub # with_constraint) l) 209 | | Pmty_typeof me -> typeof_ ~loc ~attrs (sub # module_expr me) 210 | | Pmty_extension x -> extension ~loc ~attrs (sub # extension x) 211 | 212 | let map_with_constraint sub = function 213 | | Pwith_type (lid, d) -> 214 | Pwith_type (map_loc sub lid, sub # type_declaration d) 215 | | Pwith_module (lid, lid2) -> 216 | Pwith_module (map_loc sub lid, map_loc sub lid2) 217 | | Pwith_typesubst (lid, d) -> 218 | Pwith_typesubst (map_loc sub lid, sub # type_declaration d) 219 | | Pwith_modsubst (lid, lid2) -> 220 | Pwith_modsubst (map_loc sub lid, map_loc sub lid2) 221 | #if OCAML_VERSION >= (4, 13, 0) 222 | | Pwith_modtype (lid, mty) -> 223 | Pwith_modtype (map_loc sub lid, sub # module_type mty) 224 | | Pwith_modtypesubst (lid, mty) -> 225 | Pwith_modtypesubst (map_loc sub lid, sub # module_type mty) 226 | #endif 227 | 228 | let map_signature_item sub {psig_desc = desc; psig_loc = loc} = 229 | let open Sig in 230 | let loc = sub # location loc in 231 | match desc with 232 | | Psig_value vd -> value ~loc (sub # value_description vd) 233 | | Psig_type (rf, l) -> type_ ~loc rf (List.map (sub # type_declaration) l) 234 | | Psig_typesubst l -> type_subst ~loc (List.map (sub # type_declaration) l) 235 | | Psig_typext te -> type_extension ~loc (sub # type_extension te) 236 | | Psig_exception texn -> exception_ ~loc (sub # type_exception texn) 237 | | Psig_module x -> module_ ~loc (sub # module_declaration x) 238 | | Psig_modsubst ms -> mod_subst ~loc (sub # module_substitution ms) 239 | #if OCAML_VERSION >= (4, 13, 0) 240 | | Psig_modtypesubst ms -> modtype_subst ~loc (sub # module_type_declaration ms) 241 | #endif 242 | | Psig_recmodule l -> 243 | rec_module ~loc (List.map (sub # module_declaration) l) 244 | | Psig_modtype x -> modtype ~loc (sub # module_type_declaration x) 245 | | Psig_open od -> open_ ~loc (sub # open_description od) 246 | | Psig_include x -> include_ ~loc (sub # include_description x) 247 | | Psig_class l -> class_ ~loc (List.map (sub # class_description) l) 248 | | Psig_class_type l -> 249 | class_type ~loc (List.map (sub # class_type_declaration) l) 250 | | Psig_extension (x, attrs) -> 251 | extension ~loc (sub # extension x) ~attrs:(sub # attributes attrs) 252 | | Psig_attribute x -> attribute ~loc (sub # attribute x) 253 | end 254 | 255 | module M = struct 256 | (* Value expressions for the module language *) 257 | 258 | let map sub {pmod_loc = loc; pmod_desc = desc; pmod_attributes = attrs} = 259 | let open Mod in 260 | let loc = sub # location loc in 261 | let attrs = sub # attributes attrs in 262 | match desc with 263 | | Pmod_ident x -> ident ~loc ~attrs (map_loc sub x) 264 | | Pmod_structure str -> structure ~loc ~attrs (sub # structure str) 265 | #if OCAML_VERSION >= (4, 10, 0) 266 | | Pmod_functor (param, body) -> 267 | functor_ ~loc ~attrs 268 | (map_functor_param sub param) 269 | (sub # module_expr body) 270 | #else 271 | | Pmod_functor (arg, arg_ty, body) -> 272 | functor_ ~loc ~attrs (map_loc sub arg) 273 | (map_opt (sub # module_type) arg_ty) 274 | (sub # module_expr body) 275 | #endif 276 | | Pmod_apply (m1, m2) -> 277 | apply ~loc ~attrs (sub # module_expr m1) (sub # module_expr m2) 278 | | Pmod_constraint (m, mty) -> 279 | constraint_ ~loc ~attrs (sub # module_expr m) (sub # module_type mty) 280 | | Pmod_unpack e -> unpack ~loc ~attrs (sub # expr e) 281 | | Pmod_extension x -> extension ~loc ~attrs (sub # extension x) 282 | 283 | let map_structure_item sub {pstr_loc = loc; pstr_desc = desc} = 284 | let open Str in 285 | let loc = sub # location loc in 286 | match desc with 287 | | Pstr_eval (x, attrs) -> 288 | eval ~loc ~attrs:(sub # attributes attrs) (sub # expr x) 289 | | Pstr_value (r, vbs) -> value ~loc r (List.map (sub # value_binding) vbs) 290 | | Pstr_primitive vd -> primitive ~loc (sub # value_description vd) 291 | | Pstr_type (rf, l) -> type_ ~loc rf (List.map (sub # type_declaration) l) 292 | | Pstr_typext te -> type_extension ~loc (sub # type_extension te) 293 | | Pstr_exception ed -> exception_ ~loc (sub # type_exception ed) 294 | | Pstr_module x -> module_ ~loc (sub # module_binding x) 295 | | Pstr_recmodule l -> rec_module ~loc (List.map (sub # module_binding) l) 296 | | Pstr_modtype x -> modtype ~loc (sub # module_type_declaration x) 297 | | Pstr_open od -> open_ ~loc (sub # open_declaration od) 298 | | Pstr_class l -> class_ ~loc (List.map (sub # class_declaration) l) 299 | | Pstr_class_type l -> 300 | class_type ~loc (List.map (sub # class_type_declaration) l) 301 | | Pstr_include x -> include_ ~loc (sub # include_declaration x) 302 | | Pstr_extension (x, attrs) -> 303 | extension ~loc (sub # extension x) ~attrs:(sub # attributes attrs) 304 | | Pstr_attribute x -> attribute ~loc (sub # attribute x) 305 | end 306 | 307 | module E = struct 308 | (* Value expressions for the core language *) 309 | 310 | let map_binding_op sub {pbop_op = op; pbop_pat = pat; pbop_exp = exp; pbop_loc = loc} = 311 | let op = map_loc sub op in 312 | let pat = sub # pat pat in 313 | let exp = sub # expr exp in 314 | let loc = sub # location loc in 315 | {pbop_op = op; pbop_pat = pat; pbop_exp = exp; pbop_loc = loc} 316 | 317 | let map sub {pexp_loc = loc; pexp_loc_stack = _; pexp_desc = desc; pexp_attributes = attrs} = 318 | let open Exp in 319 | let loc = sub # location loc in 320 | let attrs = sub # attributes attrs in 321 | match desc with 322 | | Pexp_ident x -> ident ~loc ~attrs (map_loc sub x) 323 | | Pexp_constant x -> constant ~loc ~attrs x 324 | | Pexp_let (r, vbs, e) -> 325 | let_ ~loc ~attrs r (List.map (sub # value_binding) vbs) (sub # expr e) 326 | | Pexp_fun (lab, def, p, e) -> 327 | fun_ ~loc ~attrs lab (map_opt (sub # expr) def) (sub # pat p) 328 | (sub # expr e) 329 | | Pexp_function pel -> function_ ~loc ~attrs (sub # cases pel) 330 | | Pexp_apply (e, l) -> 331 | apply ~loc ~attrs (sub # expr e) (List.map (map_snd (sub # expr)) l) 332 | | Pexp_match (e, pel) -> match_ ~loc ~attrs (sub # expr e) (sub # cases pel) 333 | | Pexp_try (e, pel) -> try_ ~loc ~attrs (sub # expr e) (sub # cases pel) 334 | | Pexp_tuple el -> tuple ~loc ~attrs (List.map (sub # expr) el) 335 | | Pexp_construct (lid, arg) -> 336 | construct ~loc ~attrs (map_loc sub lid) (map_opt (sub # expr) arg) 337 | | Pexp_variant (lab, eo) -> 338 | variant ~loc ~attrs lab (map_opt (sub # expr) eo) 339 | | Pexp_record (l, eo) -> 340 | record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub # expr)) l) 341 | (map_opt (sub # expr) eo) 342 | | Pexp_field (e, lid) -> field ~loc ~attrs (sub # expr e) (map_loc sub lid) 343 | | Pexp_setfield (e1, lid, e2) -> 344 | setfield ~loc ~attrs (sub # expr e1) (map_loc sub lid) (sub # expr e2) 345 | | Pexp_array el -> array ~loc ~attrs (List.map (sub # expr) el) 346 | | Pexp_ifthenelse (e1, e2, e3) -> 347 | ifthenelse ~loc ~attrs (sub # expr e1) (sub # expr e2) 348 | (map_opt (sub # expr) e3) 349 | | Pexp_sequence (e1, e2) -> 350 | sequence ~loc ~attrs (sub # expr e1) (sub # expr e2) 351 | | Pexp_while (e1, e2) -> while_ ~loc ~attrs (sub # expr e1) (sub # expr e2) 352 | | Pexp_for (p, e1, e2, d, e3) -> 353 | for_ ~loc ~attrs (sub # pat p) (sub # expr e1) (sub # expr e2) d 354 | (sub # expr e3) 355 | | Pexp_coerce (e, t1, t2) -> 356 | coerce ~loc ~attrs (sub # expr e) (map_opt (sub # typ) t1) 357 | (sub # typ t2) 358 | | Pexp_constraint (e, t) -> 359 | constraint_ ~loc ~attrs (sub # expr e) (sub # typ t) 360 | | Pexp_send (e, s) -> send ~loc ~attrs (sub # expr e) s 361 | | Pexp_new lid -> new_ ~loc ~attrs (map_loc sub lid) 362 | | Pexp_setinstvar (s, e) -> 363 | setinstvar ~loc ~attrs (map_loc sub s) (sub # expr e) 364 | | Pexp_override sel -> 365 | override ~loc ~attrs 366 | (List.map (map_tuple (map_loc sub) (sub # expr)) sel) 367 | | Pexp_letmodule (s, me, e) -> 368 | letmodule ~loc ~attrs (map_loc sub s) (sub # module_expr me) 369 | (sub # expr e) 370 | | Pexp_letexception (cd, e) -> 371 | letexception ~loc ~attrs 372 | (sub # extension_constructor cd) 373 | (sub # expr e) 374 | | Pexp_assert e -> assert_ ~loc ~attrs (sub # expr e) 375 | | Pexp_lazy e -> lazy_ ~loc ~attrs (sub # expr e) 376 | | Pexp_poly (e, t) -> 377 | poly ~loc ~attrs (sub # expr e) (map_opt (sub # typ) t) 378 | | Pexp_object cls -> object_ ~loc ~attrs (sub # class_structure cls) 379 | | Pexp_newtype (s, e) -> newtype ~loc ~attrs s (sub # expr e) 380 | | Pexp_pack me -> pack ~loc ~attrs (sub # module_expr me) 381 | | Pexp_open (od, e) -> 382 | open_ ~loc ~attrs (sub # open_declaration od) (sub # expr e) 383 | | Pexp_letop x -> 384 | let let_ = map_binding_op sub x.let_ in 385 | let ands = List.map (map_binding_op sub) x.ands in 386 | let body = sub # expr x.body in 387 | letop ~loc ~attrs let_ ands body 388 | | Pexp_extension x -> extension ~loc ~attrs (sub # extension x) 389 | | Pexp_unreachable -> unreachable ~loc ~attrs () 390 | end 391 | 392 | module P = struct 393 | (* Patterns *) 394 | 395 | let map sub {ppat_desc = desc; ppat_loc = loc; ppat_loc_stack = _; ppat_attributes = attrs} = 396 | let open Pat in 397 | let loc = sub # location loc in 398 | let attrs = sub # attributes attrs in 399 | match desc with 400 | | Ppat_any -> any ~loc ~attrs () 401 | | Ppat_var s -> var ~loc ~attrs (map_loc sub s) 402 | | Ppat_alias (p, s) -> alias ~loc ~attrs (sub # pat p) (map_loc sub s) 403 | | Ppat_constant c -> constant ~loc ~attrs c 404 | | Ppat_interval (c1, c2) -> interval ~loc ~attrs c1 c2 405 | | Ppat_tuple pl -> tuple ~loc ~attrs (List.map (sub # pat) pl) 406 | | Ppat_construct (l, p) -> 407 | construct ~loc ~attrs (map_loc sub l) (map_pat_opt sub (sub # pat) p) 408 | | Ppat_variant (l, p) -> variant ~loc ~attrs l (map_opt (sub # pat) p) 409 | | Ppat_record (lpl, cf) -> 410 | record ~loc ~attrs (List.map (map_tuple (map_loc sub) (sub # pat)) lpl) 411 | cf 412 | | Ppat_array pl -> array ~loc ~attrs (List.map (sub # pat) pl) 413 | | Ppat_or (p1, p2) -> or_ ~loc ~attrs (sub # pat p1) (sub # pat p2) 414 | | Ppat_constraint (p, t) -> 415 | constraint_ ~loc ~attrs (sub # pat p) (sub # typ t) 416 | | Ppat_type s -> type_ ~loc ~attrs (map_loc sub s) 417 | | Ppat_lazy p -> lazy_ ~loc ~attrs (sub # pat p) 418 | | Ppat_unpack s -> unpack ~loc ~attrs (map_loc sub s) 419 | | Ppat_exception p -> exception_ ~loc ~attrs (sub # pat p) 420 | | Ppat_extension x -> extension ~loc ~attrs (sub # extension x) 421 | | Ppat_open (l, p) -> open_ ~loc ~attrs (map_loc sub l) (sub # pat p) 422 | end 423 | 424 | module CE = struct 425 | (* Value expressions for the class language *) 426 | 427 | let map sub {pcl_loc = loc; pcl_desc = desc; pcl_attributes = attrs} = 428 | let open Cl in 429 | let loc = sub # location loc in 430 | match desc with 431 | | Pcl_constr (lid, tys) -> 432 | constr ~loc ~attrs (map_loc sub lid) (List.map (sub # typ) tys) 433 | | Pcl_structure s -> 434 | structure ~loc ~attrs (sub # class_structure s) 435 | | Pcl_fun (lab, e, p, ce) -> 436 | fun_ ~loc ~attrs lab 437 | (map_opt (sub # expr) e) 438 | (sub # pat p) 439 | (sub # class_expr ce) 440 | | Pcl_apply (ce, l) -> 441 | apply ~loc ~attrs (sub # class_expr ce) 442 | (List.map (map_snd (sub # expr)) l) 443 | | Pcl_let (r, vbs, ce) -> 444 | let_ ~loc ~attrs r (List.map (sub # value_binding) vbs) 445 | (sub # class_expr ce) 446 | | Pcl_constraint (ce, ct) -> 447 | constraint_ ~loc ~attrs (sub # class_expr ce) (sub # class_type ct) 448 | | Pcl_extension x -> extension ~loc ~attrs (sub # extension x) 449 | | Pcl_open (od, ce) -> 450 | open_ ~loc ~attrs (sub # open_description od) (sub # class_expr ce) 451 | 452 | let map_kind sub = function 453 | | Cfk_concrete (o, e) -> Cfk_concrete (o, sub # expr e) 454 | | Cfk_virtual t -> Cfk_virtual (sub # typ t) 455 | 456 | let map_field sub {pcf_desc = desc; pcf_loc = loc; pcf_attributes = attrs} = 457 | let open Cf in 458 | let loc = sub # location loc in 459 | match desc with 460 | | Pcf_inherit (o, ce, s) -> inherit_ ~loc ~attrs o (sub # class_expr ce) s 461 | | Pcf_val (s, m, k) -> val_ ~loc ~attrs (map_loc sub s) m (map_kind sub k) 462 | | Pcf_method (s, p, k) -> 463 | method_ ~loc ~attrs (map_loc sub s) p (map_kind sub k) 464 | | Pcf_constraint (t1, t2) -> 465 | constraint_ ~loc ~attrs (sub # typ t1) (sub # typ t2) 466 | | Pcf_initializer e -> initializer_ ~loc ~attrs (sub # expr e) 467 | | Pcf_attribute x -> attribute ~loc (sub # attribute x) 468 | | Pcf_extension x -> extension ~loc ~attrs (sub # extension x) 469 | 470 | let map_structure sub {pcstr_self; pcstr_fields} = 471 | { 472 | pcstr_self = sub # pat pcstr_self; 473 | pcstr_fields = List.map (sub # class_field) pcstr_fields; 474 | } 475 | 476 | let class_infos sub f {pci_virt; pci_params = pl; pci_name; pci_expr; 477 | pci_loc; pci_attributes} = 478 | Ci.mk 479 | ~virt:pci_virt 480 | ~params:(List.map (map_fst (sub # typ)) pl) 481 | (map_loc sub pci_name) 482 | (f pci_expr) 483 | ~loc:(sub # location pci_loc) 484 | ~attrs:(sub # attributes pci_attributes) 485 | end 486 | 487 | (* Now, a generic AST mapper class, to be extended to cover all kinds 488 | and cases of the OCaml grammar. The default behavior of the mapper 489 | is the identity. *) 490 | 491 | class mapper = 492 | object(this) 493 | method structure l = List.map (this # structure_item) l 494 | method structure_item si = M.map_structure_item this si 495 | method module_expr = M.map this 496 | 497 | method signature l = List.map (this # signature_item) l 498 | method signature_item si = MT.map_signature_item this si 499 | method module_type = MT.map this 500 | method with_constraint c = MT.map_with_constraint this c 501 | 502 | method class_declaration = CE.class_infos this (this # class_expr) 503 | method class_expr = CE.map this 504 | method class_field = CE.map_field this 505 | method class_structure = CE.map_structure this 506 | 507 | method class_type = CT.map this 508 | method class_type_field = CT.map_field this 509 | method class_signature = CT.map_signature this 510 | 511 | method class_type_declaration = CE.class_infos this (this # class_type) 512 | method class_description = CE.class_infos this (this # class_type) 513 | 514 | method binding_op = E.map_binding_op this 515 | 516 | method type_declaration = T.map_type_declaration this 517 | method type_kind = T.map_type_kind this 518 | method typ = T.map this 519 | 520 | method type_extension = T.map_type_extension this 521 | method type_exception = T.map_type_exception this 522 | method extension_constructor = T.map_extension_constructor this 523 | 524 | method value_description {pval_name; pval_type; pval_prim; pval_loc; 525 | pval_attributes} = 526 | Val.mk 527 | (map_loc this pval_name) 528 | (this # typ pval_type) 529 | ~attrs:(this # attributes pval_attributes) 530 | ~loc:(this # location pval_loc) 531 | ~prim:pval_prim 532 | 533 | method pat = P.map this 534 | method expr = E.map this 535 | 536 | method module_declaration {pmd_name; pmd_type; pmd_attributes; pmd_loc} = 537 | Md.mk 538 | (map_loc this pmd_name) 539 | (this # module_type pmd_type) 540 | ~attrs:(this # attributes pmd_attributes) 541 | ~loc:(this # location pmd_loc) 542 | 543 | method module_substitution {pms_name; pms_manifest; pms_attributes; pms_loc} = 544 | Ms.mk 545 | (map_loc this pms_name) 546 | (map_loc this pms_manifest) 547 | ~attrs:(this # attributes pms_attributes) 548 | ~loc:(this # location pms_loc) 549 | 550 | method module_type_declaration {pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc} = 551 | Mtd.mk 552 | (map_loc this pmtd_name) 553 | ?typ:(map_opt (this # module_type) pmtd_type) 554 | ~attrs:(this # attributes pmtd_attributes) 555 | ~loc:(this # location pmtd_loc) 556 | 557 | method module_binding {pmb_name; pmb_expr; pmb_attributes; pmb_loc} = 558 | Mb.mk (map_loc this pmb_name) (this # module_expr pmb_expr) 559 | ~attrs:(this # attributes pmb_attributes) 560 | ~loc:(this # location pmb_loc) 561 | 562 | method value_binding {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} = 563 | Vb.mk 564 | (this # pat pvb_pat) 565 | (this # expr pvb_expr) 566 | ~attrs:(this # attributes pvb_attributes) 567 | ~loc:(this # location pvb_loc) 568 | 569 | method constructor_arguments = function 570 | | Pcstr_tuple (tys) -> Pcstr_tuple (List.map (this # typ) tys) 571 | | Pcstr_record (ls) -> Pcstr_record (List.map (this # label_declaration) ls) 572 | 573 | method constructor_declaration {pcd_name; pcd_args; pcd_res; pcd_loc; 574 | pcd_attributes; 575 | #if OCAML_VERSION >= (4, 14, 0) 576 | pcd_vars} = 577 | #else 578 | } = 579 | #endif 580 | Type.constructor 581 | (map_loc this pcd_name) 582 | ~args:(this # constructor_arguments pcd_args) 583 | ?res:(map_opt (this # typ) pcd_res) 584 | ~loc:(this # location pcd_loc) 585 | ~attrs:(this # attributes pcd_attributes) 586 | #if OCAML_VERSION >= (4, 14, 0) 587 | ~vars:(List.map (map_loc this) pcd_vars) 588 | #endif 589 | 590 | method label_declaration {pld_name; pld_type; pld_loc; pld_mutable; 591 | pld_attributes} = 592 | Type.field 593 | (map_loc this pld_name) 594 | (this # typ pld_type) 595 | ~mut:pld_mutable 596 | ~loc:(this # location pld_loc) 597 | ~attrs:(this # attributes pld_attributes) 598 | 599 | 600 | method cases l = List.map (this # case) l 601 | method case {pc_lhs; pc_guard; pc_rhs} = 602 | { 603 | pc_lhs = this # pat pc_lhs; 604 | pc_guard = map_opt (this # expr) pc_guard; 605 | pc_rhs = this # expr pc_rhs; 606 | } 607 | 608 | method open_declaration 609 | {popen_expr; popen_override; popen_attributes; popen_loc} = 610 | Opn.mk (this # module_expr popen_expr) 611 | ~override:popen_override 612 | ~loc:(this # location popen_loc) 613 | ~attrs:(this # attributes popen_attributes) 614 | 615 | method open_description 616 | {popen_expr; popen_override; popen_attributes; popen_loc} = 617 | Opn.mk (map_loc this popen_expr) 618 | ~override:popen_override 619 | ~loc:(this # location popen_loc) 620 | ~attrs:(this # attributes popen_attributes) 621 | 622 | method include_description 623 | {pincl_mod; pincl_attributes; pincl_loc} = 624 | Incl.mk (this # module_type pincl_mod) 625 | ~loc:(this # location pincl_loc) 626 | ~attrs:(this # attributes pincl_attributes) 627 | 628 | method include_declaration 629 | {pincl_mod; pincl_attributes; pincl_loc} = 630 | Incl.mk (this # module_expr pincl_mod) 631 | ~loc:(this # location pincl_loc) 632 | ~attrs:(this # attributes pincl_attributes) 633 | 634 | method location l = l 635 | 636 | method extension (s, e) = (map_loc this s, this # payload e) 637 | 638 | method attribute a = 639 | { 640 | attr_name = map_loc this a.attr_name; 641 | attr_payload = this # payload a.attr_payload; 642 | attr_loc = this # location a.attr_loc; 643 | } 644 | 645 | method attributes l = List.map (this # attribute) l 646 | 647 | method payload = function 648 | | PStr x -> PStr (this # structure x) 649 | | PTyp x -> PTyp (this # typ x) 650 | | PPat (x, g) -> PPat (this # pat x, map_opt (this # expr) g) 651 | | PSig x -> PSig (this # signature x) 652 | 653 | #if OCAML_VERSION >= (4, 11, 0) 654 | method constant = function 655 | | Pconst_integer (str, suffix) -> Pconst_integer (str, suffix) 656 | | Pconst_char c -> Pconst_char c 657 | | Pconst_string (str, loc, delim) -> Pconst_string (str, this # location loc, delim) 658 | | Pconst_float (str, suffix) -> Pconst_float (str, suffix) 659 | #endif 660 | end 661 | 662 | 663 | let to_mapper this = 664 | let open Ast_mapper in 665 | { 666 | attribute = (fun _ -> this # attribute); 667 | attributes = (fun _ -> this # attributes); 668 | binding_op = (fun _ -> this # binding_op); 669 | case = (fun _ -> this # case); 670 | cases = (fun _ -> this # cases); 671 | class_declaration = (fun _ -> this # class_declaration); 672 | class_description = (fun _ -> this # class_description); 673 | class_expr = (fun _ -> this # class_expr); 674 | class_field = (fun _ -> this # class_field); 675 | class_signature = (fun _ -> this # class_signature); 676 | class_structure = (fun _ -> this # class_structure); 677 | class_type = (fun _ -> this # class_type); 678 | class_type_declaration = (fun _ -> this # class_type_declaration); 679 | class_type_field = (fun _ -> this # class_type_field); 680 | #if OCAML_VERSION >= (4, 11, 0) 681 | constant = (fun _ -> this # constant); 682 | #endif 683 | constructor_declaration = (fun _ -> this # constructor_declaration); 684 | expr = (fun _ -> this # expr); 685 | extension = (fun _ -> this # extension); 686 | extension_constructor = (fun _ -> this # extension_constructor); 687 | include_declaration = (fun _ -> this # include_declaration); 688 | include_description = (fun _ -> this # include_description); 689 | label_declaration = (fun _ -> this # label_declaration); 690 | location = (fun _ -> this # location); 691 | module_binding = (fun _ -> this # module_binding); 692 | module_declaration = (fun _ -> this # module_declaration); 693 | module_expr = (fun _ -> this # module_expr); 694 | module_substitution = (fun _ -> this # module_substitution); 695 | module_type = (fun _ -> this # module_type); 696 | module_type_declaration = (fun _ -> this # module_type_declaration); 697 | open_declaration = (fun _ -> this # open_declaration); 698 | open_description = (fun _ -> this # open_description); 699 | pat = (fun _ -> this # pat); 700 | payload = (fun _ -> this # payload); 701 | signature = (fun _ -> this # signature); 702 | signature_item = (fun _ -> this # signature_item); 703 | structure = (fun _ -> this # structure); 704 | structure_item = (fun _ -> this # structure_item); 705 | typ = (fun _ -> this # typ); 706 | type_declaration = (fun _ -> this # type_declaration); 707 | type_exception = (fun _ -> this # type_exception); 708 | type_extension = (fun _ -> this # type_extension); 709 | type_kind = (fun _ -> this # type_kind); 710 | value_binding = (fun _ -> this # value_binding); 711 | value_description = (fun _ -> this # value_description); 712 | with_constraint = (fun _ -> this # with_constraint); 713 | } 714 | --------------------------------------------------------------------------------