pax_global_header00006660000000000000000000000064136051267370014524gustar00rootroot0000000000000052 comment=f13dc352b9bb17e8ced3d12d2533cffba2fcbfac ppxlib-0.12.0/000077500000000000000000000000001360512673700131025ustar00rootroot00000000000000ppxlib-0.12.0/.github/000077500000000000000000000000001360512673700144425ustar00rootroot00000000000000ppxlib-0.12.0/.github/CODEOWNERS000066400000000000000000000000221360512673700160270ustar00rootroot00000000000000* @diml @xclerc ppxlib-0.12.0/.gitignore000066400000000000000000000000321360512673700150650ustar00rootroot00000000000000_build *.install *.merlin ppxlib-0.12.0/.ocp-indent000066400000000000000000000000131360512673700151350ustar00rootroot00000000000000JaneStreet ppxlib-0.12.0/.travis.yml000066400000000000000000000006611360512673700152160ustar00rootroot00000000000000language: c install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-docker.sh script: bash -ex .travis-docker.sh services: - docker env: global: - DISTRO="debian-stable" - PACKAGE="ppxlib" matrix: - OCAML_VERSION="4.04" TESTS=false - OCAML_VERSION="4.05" TESTS=false - OCAML_VERSION="4.06" TESTS=false - OCAML_VERSION="4.07" - OCAML_VERSION="4.08" - OCAML_VERSION="4.09" ppxlib-0.12.0/CHANGES.md000066400000000000000000000045711360512673700145030ustar00rootroot000000000000000.10.0 (11/21/2019) ------------------- - Do not produce a suprious empty correction when deriving_inline expands into an extension that undergoes further expansion (#86, @aalekseyev) - Add `Ppxlib.Quoter`. This module allows to generate hygienic code fragments in the spirit of ppx_deriving. (#92, @rgrinberg) - Allow for registering derivers on module type declarations. (#94, fix #83, @rgrinberg) - Fix parsing long idenitifiers. (#98, @NathanReb) 0.9.0 ----- - Bump AST to 4.08 (#80, @xclerc) 0.8.1 ----- ### Fixed - Report errors according to the value of `OCAML_ERROR_STYLE` and `OCAML_COLOR` in the standalone driver (#83, @NathanReb) 0.6.0 ----- - Set `Location.input_name` to the original filename when reading a binary AST (#.., @diml) 0.5.0 ----- - Add an `(** @inline *)` to the include generated when silencing warning 32 (#58, @trefis) - Add `Ppxlib.mk_named_sig` and `Ppxlib.is_polymorphic_variant` (#57, @trefis) 0.4.0 ----- - Do not report errors about dropped or uninterpreted attributes starting with `_` (#46, fix #40, @diml) - Fix he `special_function` rule for dotted operators and allow `Longident.parse` to parse dotted operators (#44, @Octachron) - Port to `dune` and remove use of bash (#45, @rgrinberg) - Ignore all attribites starting with `_` (#46, @diml) - Reserve the `reason` and `refmt` namespaces (#46, @diml) - Reserve the `metaocaml` namespace (#50, @rgrinberg) - Fix attribute extraction for Otag/Rtag (#51, @xclerc) - Do not relocate files unless `-loc-filename` is passed (#55, @hhugo) - Perserve the filename in the output (#56, @hhugo) 0.3.1 ----- - Add `Attribute.declare_with_name_loc` (#33, @diml) - Let the tool name pass throught when used as a -ppx (#41, @diml) - Update the AST to 4.06 (#8, @xclerc) 0.3.0 ----- - Update the AST to 4.06 (#8, @xclerc) - Deprecate old references to type_conv in argument and rewriter names and add new ones mentioning deriving instead (#7, #9 @xclerc) - Fix compatibility with `-safe-string` (#10, @hhugo) - Restore tests (#11, @xclerc) - Allow to set the suffix of corrected files (#15, @diml) - Restore compatibility with OCaml 4.04.x (#16, @xclerc) 0.2.0 ----- - Make sure to import command line arguments registered with ocaml-migrate-parsetree (#5, @diml) - Fix an issue where cookies set from the command line sometimes disappeared (#6, @diml) 0.1.0 ----- Initial release. ppxlib-0.12.0/CONTRIBUTING.md000066400000000000000000000100001360512673700153220ustar00rootroot00000000000000This repository contains core libraries and tools used to develop ppx rewriters. The code was originally developed and is still maintained and used by [Jane Street][js]. This repository is not the first piece of open source software released by Jane Street, however it is the first to be entirely developed on GitHub. We are hoping that opening the development of this repository will help collaboration with other open source users. We welcome contributions and we will be happy to add contributors, given that they are motivated to help maintain and grow the project. However, given how important this code is to the functioning of Jane Street, we do require that at least one Jane Street developer reads every pull request that modifies the source code. Additionally, all contributors must sign-off their commits, see below for details. ### Developing patches We ask that patches changing the code respect the overall coding style. In particular, the code should be indented using [ocp-indent][ocpi]. Additionally the test suite should pass on the contributor's machine before a patch is submitted for review. Note that in addition to the normal dependencies, you need to install [cinaps][cinaps] in order to modify the code. This is because some parts of the code are auto-generated and committed in the repository. So before submitting a PR, make sure to check all the following points: - all the modified code is correctly indented according to ocp-indent - `make` succeeds - `make test` succeeds ### Submitting patches and code review Once a patch is ready according to the criteria stated in the previous section, it should be submitted via the GitHub website. When submitting a pull request, we prefer if you tick the `Allow edits from maintainers` box as it is much simpler to fix typos or do simple improvements directly rather than go back and forth through the web interface. ### Signing commits We require that you sign your contributions. Your signature certifies that you wrote the patch or otherwise have the right to pass it on as an open-source patch. The rules are pretty simple: if you can certify the below (from [developercertificate.org][dco]): ``` Developer Certificate of Origin Version 1.1 Copyright (C) 2004, 2006 The Linux Foundation and its contributors. 1 Letterman Drive Suite D4700 San Francisco, CA, 94129 Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Developer's Certificate of Origin 1.1 By making a contribution to this project, I certify that: (a) The contribution was created in whole or in part by me and I have the right to submit it under the open source license indicated in the file; or (b) The contribution is based upon previous work that, to the best of my knowledge, is covered under an appropriate open source license and I have the right under that license to submit that work with modifications, whether created in whole or in part by me, under the same open source license (unless I am permitted to submit under a different license), as indicated in the file; or (c) The contribution was provided directly to me by some other person who certified (a), (b) or (c) and I have not modified it. (d) I understand and agree that this project and the contribution are public and that a record of the contribution (including all personal information I submit with it, including my sign-off) is maintained indefinitely and may be redistributed consistent with this project or the open source license(s) involved. ``` Then you just add a line to every git commit message: ``` Signed-off-by: Joe Smith ``` Use your real name (sorry, no pseudonyms or anonymous contributions.) If you set your `user.name` and `user.email` git configs, you can sign your commit automatically with git commit -s. [js]: https://opensource.janestreet.com/ [ocpi]: https://github.com/OCamlPro/ocp-indent [cinaps]: https://github.com/janestreet/cinaps [dco]: http://developercertificate.org/ ppxlib-0.12.0/HISTORY.md000066400000000000000000000456241360512673700146000ustar00rootroot00000000000000# History This repository is the merge of several ppx-related repositories, namely: - [ppx_ast](https://github.com/janestreet/ppx_ast); - [ppx_core](https://github.com/janestreet/ppx_core); - [ppx_driver](https://github.com/janestreet/ppx_driver); - [ppx_metaquot](https://github.com/janestreet/ppx_metaquot); - [ppx_traverse](https://github.com/janestreet/ppx_traverse); - [ppx_traverse_builtins](https://github.com/janestreet/ppx_traverse_builtins); - [ppx_type_conv](https://github.com/janestreet/ppx_type_conv). Future development will happen only in this repository, and the aforementioned ones will only contain synonym definitions to provide backward compatibility. The structure of this repository is as follows: - `ast/` contains the `ppxlib.ast` library, that replaces `ppx_ast`; - `src/` contains the `ppxlib` library, that replaces `ppx_core`, `ppx_driver`, and `type_conv`; - `metaquot/` contains the `ppxlib.metaquot` library, that replaces `ppx_metaquot`; - `metaquot_lifters/` contains the `ppxlib.metaquot_lifters` library, that replaces `ppx_metaquot.lifters`; - `print-diff/` contains the `ppxlib.print_diff` library, that replaces `ppx_driver.print_diff`; - `runner/` contains the `ppxlib.runner` library, that replaces `ppx_driver.runner`; - `runner_as_ppx/` contains the `ppxlib.runner_as_ppx` library, that replaces `ppx_driver.runner_as_ppx`; - `traverse/` contains the `ppxlib.traverse` library, that replaces `ppx_traverse`; - `traverse_builtins/` contains the `ppxlib.traverse_builtins/` library, that replaces `ppx_traverse_builtins`. Ast === `Ppxlib_ast` selects a specific version of the OCaml Abstract Syntax Tree from the [ocaml-migrate-parsetree](https://github.com/ocaml-ppx/ocaml-migrate-parsetree) project that is not necessarily the same one as the one being used by the compiler. It also snapshots the corresponding parser and pretty-printer from the OCaml compiler, to create a full frontend independent of the version of OCaml. This AST is used in all Jane Street ppx rewriters, and more generally in all ppx rewriters based on Ppxlib. Using a different AST allows to "detach" the ppx code from the compiler libraries, and allow to use ppx rewriters with new compilers before upgrading the ppx code. Ppxlib ====== Ppxlib is a standard library for OCaml AST transformers, that uses the AST from `Ppxlib_ast`. It features: - various auto-generated AST traversal using an open recursion scheme - helpers for building AST fragments - helpers for matching AST fragments - a framework for dealing with attributes and extension points - spellchecking and other hints on misspelled/misplaced attributes and extension points - checks for unused attributes (they are otherwise silently dropped by the compiler) Other ASTs ---------- If you want to write code that works with several versions of `Ppxlib` using different AST versions, you can use the versionned alternatives for `Ast_builder` and `Ast_pattern`. For instance: ``` open Ppxlib module Ast_builder = Ast_builder_403 module Ast_pattern = Ast_pattern_403 ``` Drivers ------- A driver is an executable created from a set of OCaml AST transformers linked together with a command line frontend. The aim is to provide a tool that can be used to: - easily view the pre-processed version of a file, no need to construct a complex command line: `ppx file.ml` will do; - use a single executable to run several transformations: no need to fork many times just for pre-processing; - improved errors for misspelled/misplaced attributes and extension points. ### Using driver-based rewriters The recommended way to use rewriters based on `Ppxlib.Driver` is through [dune](https://github.com/ocaml/dune). All you need to is add this line to your `(library ...)` or `(executables ...)` stanza: ``` (preprocess (pps (rewriter1 rewriter2 ... ppxlib.runner))) ``` dune will automatically build a static driver including all these rewriters. Note the `ppxlib.runner` at the end of the list, it will still work if you don't put but some specific features of `ppxlib` won't be available. If you are not using dune, you can build a custom driver yourself using ocamlfind. These methods are described in the following sections. ### Creating a new Ppx\_driver based rewriter If using dune, you can just use the following jbuild file: ``` (library ((name my_ppx) (public_name my_ppx) (kind ppx_rewriter) (libraries (ppxlib)) (ppx_runtime_libraries ()) (preprocess (pps (ppx_metaquot))))) ``` `(kind ppx_driver)` has two effects: 1. it links the library with `-linkall`. Since plugins register themselves with the Ppx\_driver library by doing a toplevel side effect, you need to be sure they are linked in the static driver to be taken into accound; 2. it instructs dune to produce a special META file that is compatible with the various ways of using ppx rewriters, i.e. for people not using dune. ### Building a custom driver using ocamlfind To build a custom driver using ocamlfind, simply link all the AST transformers together with the `ppxlib.runner` package at the end: ocamlfind ocamlopt -predicates ppx_driver -o ppx -linkpkg \ -package ppx_sexp_conv -package ppx_bin_prot \ -package ppxlib.runner Normally, `ppxlib.driver`-based rewriters should be build with the approriate `-linkall` option on individual libraries. If one is missing this option, the code rewriter might not get linked in. If this is the case, a workaround is to pass `-linkall` when linking the custom driver. ### Building rewriter that you are currently developing Note: if using dune, you do not need to read this as dune already does all the right things for you. This section is written having ocamlbuild in mind. When developing a new rewriter you are very likely to prepare a few tests for it. The compilation line above doesn't suit this task very well (because ocamlfind package with your rewriter is not yet installed) and it will be more convenient to specify `.cmx[a]` with your rewriter manually. For example, let's suppose that the standalone rewriter (`pp_foo.native`) have this code let () = Ppxlib.Driver.standalone () in `pp_foo.ml` and your generator is begin loaded in `ppx_foo.ml`. You need a few extra switches to compile standalone rewriter (N.B. order matters) ocamlfind ... dependecy1_of_ppx_foo.cmx ... ppx_foo.cmx -package ppxlib -o pp_foo.native or, if you have already created `ppx_foo.cmxa` using `-linkall` option ocamlfind ... ppx_foo.cmxa -package ppxlib -o pp_foo.native And now you can specify that your test suite uses your rewriter and depends on a few extra `.cma`'s by adding a few lines into your `_tags` file : ppx(./pp_foo.native --as-ppx) : depends_on_foo and specifing dependencies in your `myocamlbuild.ml` file using dep ["compile";"depends_on_foo"] ["ppx_foo.cmxa"; "pp_foo.native"] ### The driver as a command line tool It recognizes the following command-line switches: ``` -loc-filename File name to use in locations -reserve-namespace Mark the given namespace as reserved -no-check Disable checks (unsafe) -apply Apply these transformations in order (comma-separated list) -dont-apply Exclude these transformations -no-merge Do not merge context free transformations (better for debugging rewriters) -as-ppx Run as a -ppx rewriter (must be the first argument) --as-ppx Same as -as-ppx -as-pp Shorthand for: -dump-ast -embed-errors --as-pp Same as -as-pp -o Output file (use '-' for stdout) - Read input from stdin -dump-ast Dump the marshaled ast to the output file instead of pretty-printing it --dump-ast Same as -dump-ast -dparsetree Print the parsetree (same as ocamlc -dparsetree) -embed-errors Embed errors in the output AST (default: true when -dump-ast, false otherwise) -null Produce no output, except for errors -impl Treat the input as a .ml file --impl Same as -impl -intf Treat the input as a .mli file --intf Same as -intf -debug-attribute-drop Debug attribute dropping -print-transformations Print linked-in code transformations, in the order they are applied -print-passes Print the actual passes over the whole AST in the order they are applied -ite-check No effect (kept for compatibility) -pp Pipe sources through preprocessor (incompatible with -as-ppx) -reconcile (WIP) Pretty print the output using a mix of the input source and the generated code -reconcile-with-comments (WIP) same as -reconcile but uses comments to enclose the generated code -no-color Don't use colors when printing errors -diff-cmd Diff command when using code expectations -pretty Instruct code generators to improve the prettiness of the generated code -styler Code styler -help Display this list of options --help Display this list of options ``` When passed a file as argument, a ppx driver will pretty-print the code transformed by all its built-in AST transformers. This gives a convenient way of seeing the code generated for a given attribute/extension. A driver can simply be used as the argument of the `-pp` option of the OCaml compiler, or as the argument of the `-ppx` option by passing `-as-ppx` as first argument: ``` $ ocamlc -c -pp "ppx -as-pp" file.ml $ ocamlc -c -ppx "ppx -as-ppx" file.ml ``` ### Rewriters as findlib libraries Note: if using dune, you do not need to read this as dune already does all the right things for you. In normal operation, Ppxlib.Driver rewriters are packaged as findlib libraries. When using dune everything is simple as preprocessors and normal dependencies are separated. However historically, people have been specifying both preprocessors and normal library dependencies together. Even worse, many build system still don't use a static driver and call out to multiple ppx commands to preprocess a single file, which slow downs compilation a lot. In order for all these different methods to work properly, you need a peculiar META file. The rules are explained below. It is recommended to split the findlib package into two: 1. one for the main library, which almost assume it is just a normal library; 2. another sub-package one for: - allowing to mix preprocessors and normal dependencies; - the method of calling one executable per rewriter. In the rest we'll assume we are writing a META file for a `ppx_foo` rewriter, that itself uses the `ppxlib` and `re` libraries, and produces code using `ppx_foo.runtime-lib`. We want the META file to support all of these: 1. mix normal dependencies and preprocessors, using one executable per rewriter: ``` ocamlfind ocamlc -package ppx_foo -c toto.ml ``` 2. mix normal dependencies and preprocessors, using a single ppx driver: ``` $ ocamlfind ocamlc -package ppx_foo -predicates custom_ppx \ -ppx ./custom-driver.exe -c toto.ml ``` 3. build a custom driver: ``` $ ocamlfind ocamlc -linkpkg -package ppx_foo -predicates ppx_driver \ -o custom-driver.exe ``` 4. build systems properly specifying preprocessors as such, separated from normal dependencies, as dune does Since preprocessors and normal dependencies are always specified separately in jbuild files, dune just always set the `ppx_driver` predicates. In the end the META file should look like this: ``` # Standard package, expect it assumes that the "ppx_driver" predicate is set version = "42.0" description = "interprets [%foo ...] extensions" requires(ppx_driver) = "ppxlib re" archives(ppx_driver,byte) = "ppx_foo.cma" archives(ppx_driver,native) = "ppx_foo.cmxa" plugin(ppx_driver,byte) = "ppx_foo.cma" plugin(ppx_driver,native) = "ppx_foo.cmxs" # This is what dune uses to find out the runtime dependencies of # a preprocessor ppx_runtime_deps = "ppx_foo.runtime-lib" # This line makes things transparent for people mixing preprocessors # and normal dependencies requires(-ppx_driver) = "ppx_foo.deprecated-ppx-method" package "deprecated-ppx-method" ( description = "glue package for the deprecated method of using ppx" requires = "ppx_foo.runtime-lib" ppx(-ppx_driver,-custom_ppx) = "./as-ppx.exe" ) package "runtime-lib" ( ... ) ``` You can check that this META works for all the 4 methods described above. Derivers -------- The `Ppxlib.Deriving` module factors out functionality needed by different preprocessors that generate code from type specifications. Example libraries currently depending on `Deriving`: - `ppx_bin_prot`; - `ppx_compare`; - `ppx_fields_conv`; - `ppx_sexp_conv`; - `ppx_variants_conv`. ### Derivers compatibility with [`ppx_import`](https://github.com/ocaml-ppx/ppx_import) `ppx_import` is a ppx rewriter that let's you import external type definitions. It will turn ```ocaml type t = [%import A.t] ``` into: ```ocaml type t = A.t = ``` It spares you the need to copy the type definition and to update it when `A.t` definition changes. `ppx_import` is thus often used in combination with ppx derivers. Because `ppx_import` requires extra information from the compiler that aren't available when it is initially called with `ocamldep`, it will not completely expand the type definition and instead rewrite it as: ```ocaml type t = A.t ``` That means that if you want your deriver to work with `ppx_import` and to be able to expand the copied type definition, it must not fail during this intermediate stage. If your deriver doesn't natively handle abstract type definitions, you can always return an empty `structure_item` or `signature_item` list. Compatibility with [ppx_deriving](https://github.com/ocaml-ppx/ppx_deriving) ---------------------------------------------------------------------------- `Ppxlib.Deriving`-based code generators are meant to be used with `Ppxlib.Driver`. However `Deriving` allows to export a compatible `ppx_deriving` plugin. By default, when not linked as part of a driver, packages using `Deriving` will just use `ppx_deriving`. So for instance this will work as expected using `ppx_deriving`: ocamlfind ocamlc -c -package ppx_sexp_conv foo.ml For end users, the main advantage of using `Deriving`-based generators is that it will catch typos and attributes misplacement. For instance: ``` # type t = int [@@derivin sexp] Error: Attribute `derivin' was not used Hint: Did you mean deriving? # type t = int [@@deriving sxp] Error: ppxlib_deriving: 'sxp' is not a supported type deriving generator Hint: Did you mean sexp? # type t = int [@deriving sexp] Error: Attribute `deriving' was not used Hint: `deriving' is available for type declarations, type extensions and extension constructors but is used here in the context of a core type. Did you put it at the wrong level?" ``` Deriving Syntax --------------- This section is only relevant if you are not using `ppx_deriving`. `Deriving` interprets the `[@@deriving ...]` attributes on type declarations, exception declarations and extension constructor declarations: ``` type t = A | B [@@deriving sexp, bin_io] ``` `sexp` and `bin_io` are called generators. They are functions that generate code given the declaration. These functions are implemented by external libraries such as `ppx_sexp_conv` or `ppx_bin_prot`. `Deriving` itself provides no generator, it does only the dispatch. Generators can take arguments. This is done using the following syntax: ``` type t = A | B [@@deriving foo ~arg:42] ``` For arguments that are just switches, it is common to use the following syntax: ``` type t = A | B [@@deriving foo ~bar] ``` Metaquot (and Metaquot_lifters) =============================== `Ppxlib_metaquot` is a ppx rewriter allowing you to write values representing the OCaml AST in the OCaml syntax. For instance: ``` [%expr x + 1] ``` is a value of type `Ppxlib_ast.Ast.expression`, represention the OCaml expression `x + 1`. `Ppxlib_metaquot` is similar to [ppx_tools.metaquot](https://github.com/ocaml-ppx/ppx_tools), expect that: - it uses the version of the OCaml AST defined by Ppxlib_ast rather than the one from the current compiler - it can be used simultaneously with other rewriters using `Ppxlib.Driver`. `Ppxlib_metaquot_lifters` provides lifting functions for OCaml predefined types (`int`, `string`, `list`, ...). Traverse (and Traverse_builtins) ================================ `Ppxlib_traverse` is a `Deriving` plugin generating open recursion classes from type definition. Users can overwrite a specific method of the generated classes in order to specialize the recursion on specific nodes. `Ppxlib_traverse` is in particular used to generate the open recursion classes to traverse the OCaml AST. For instance, this is the kind of code generated (the generated code is between the `[@@deriving_inline ...]` and `[@@@end]`): ``` type expression = | Var of string | Const of int | Add of expression * expression | If of cond * expression * expression and cond = | Cond_var of string | Cond_const of bool | Cond_and of cond * cond [@@deriving_inline traverse_map] class map = object(self) method virtual int : int -> int method virtual string : string -> string method virtual int : int -> int method expression = function | Var x -> Var (self#string x) | Const x -> Const (self#int x) | Add (x, y) -> Add (self#expression x, self#expression y) | If (x, y, z) -> If (self#cond x, self#expression y, self#expression z) method cond = function | Cond_var x -> Cond_var (self#string x) | Cond_const x -> Cond_const (self#bool x) | Cond_and (x, y) -> Cond_and (self#cond x, self#cond y) [@@end] ``` Now if you wanted to do a deep-copy of an expression, replacing boolean variable `foo` by `true`: ``` let replace_var = object inherit Ppx_traverse_builtins.map inherit map as super method cond = function | Cond_var "foo" -> Cond_const true | c -> super#cond c end let replace_var expr = replace_var replace_var#expression expr ``` `Ppx_traverse_builtins.map` contains the definition for all the builtin types, such as `int`, `string`, `list`, ... Classes ------- `Ppx_traverse` can generate the following classes: `map`, `iter`, `fold`, `fold_map`, `map_with_context`, `lift`. `[@@deriving traverse]` is an alias to generate all the supported classes. `lift` is a special class that is mostly useful to lift an OCaml constant to the AST that represent this constant. To do so, you can use `Ppx_metaquot_lifters`: ``` type t = { x : int; y : int } [@@deriving traverse_lift] let expression_of_t ~loc t : Ast.expression = let lift = object inherit Ppx_metaquot_lifters.expression_lifters loc inherit lift end in lift#t t ``` ppxlib-0.12.0/LICENSE.md000066400000000000000000000021271360512673700145100ustar00rootroot00000000000000The MIT License Copyright (c) 2018 Jane Street Group, LLC 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. ppxlib-0.12.0/Makefile000066400000000000000000000014031360512673700145400ustar00rootroot00000000000000INSTALL_ARGS := $(if $(PREFIX),--prefix $(PREFIX),) # Default rule default: dune build --auto-promote @install install: dune install $(INSTALL_ARGS) uninstall: dune uninstall $(INSTALL_ARGS) reinstall: uninstall reinstall test: dune runtest doc: cd doc && sphinx-build . _build livedoc: cd doc && sphinx-autobuild . _build \ -p 8888 -q --host $(shell hostname) -r '\.#.*' clean: dune clean all-supported-ocaml-versions: dune build @install --workspace dune-workspace.dev --root . opam-release: dune-release distrib --skip-build --skip-lint --skip-tests dune-release publish distrib --verbose dune-release opam pkg dune-release opam submit .PHONY: default install uninstall reinstall clean test .PHONY: all-supported-ocaml-versions opam-release ppxlib-0.12.0/README.md000066400000000000000000000015731360512673700143670ustar00rootroot00000000000000# Ppxlib - Meta-programming for OCaml [![Travis status][travis-img]][travis] [![AppVeyor status][appveyor-img]][appveyor] [travis]: https://travis-ci.org/ocaml-ppx/ppxlib [travis-img]: https://travis-ci.org/ocaml-ppx/ppxlib.svg?branch=master [appveyor]: https://ci.appveyor.com/project/diml/ppxlib/branch/master [appveyor-img]: https://ci.appveyor.com/api/projects/status/bogbsm33uvh083jx?svg=true # Overview The ppxlib project provides the basis for the ppx system, which is currently the officially supported method for meta-programming in OCaml. It offers a principled way to generate code at compile time in OCaml projects. Ppxlib comes with a [user manual](http://ppxlib.readthedocs.io/) aimed at both users and authors of ppx rewriters. # History This repository was created by merging several older projects. See [the history](HISTORY.md) for more details. ppxlib-0.12.0/appveyor.yml000066400000000000000000000016401360512673700154730ustar00rootroot00000000000000platform: - x86 environment: global: FORK_USER: ocaml FORK_BRANCH: master CYG_ROOT: C:\cygwin64 PINS: ppxlib:. matrix: - OPAM_SWITCH: 4.04.2+mingw64c PACKAGE: ppxlib - OPAM_SWITCH: 4.04.2+mingw32c PACKAGE: ppxlib - OPAM_SWITCH: 4.05.0+mingw64c PACKAGE: ppxlib - OPAM_SWITCH: 4.05.0+mingw32c PACKAGE: ppxlib - OPAM_SWITCH: 4.06.0+mingw64c PACKAGE: ppxlib - OPAM_SWITCH: 4.06.0+mingw32c PACKAGE: ppxlib - OPAM_SWITCH: 4.07.1+mingw64c PACKAGE: ppxlib - OPAM_SWITCH: 4.07.1+mingw32c PACKAGE: ppxlib - OPAM_SWITCH: 4.08.0+mingw64c PACKAGE: ppxlib - OPAM_SWITCH: 4.08.0+mingw32c PACKAGE: ppxlib install: - ps: iex ((new-object net.webclient).DownloadString("https://raw.githubusercontent.com/$env:FORK_USER/ocaml-ci-scripts/$env:FORK_BRANCH/appveyor-install.ps1")) build_script: - call %CYG_ROOT%\bin\bash.exe -l %APPVEYOR_BUILD_FOLDER%\appveyor-opam.sh ppxlib-0.12.0/ast/000077500000000000000000000000001360512673700136715ustar00rootroot00000000000000ppxlib-0.12.0/ast/ast.ml000066400000000000000000010705221360512673700150210ustar00rootroot00000000000000(**************************************************************************) (* *) (* OCaml *) (* *) (* Xavier Leroy, projet Cristal, INRIA Rocquencourt *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. *) (* *) (* All rights reserved. This file is distributed under the terms of *) (* the GNU Lesser General Public License version 2.1, with the *) (* special exception on linking described in the file LICENSE. *) (* *) (**************************************************************************) (** Definition of the OCaml AST *) open Import (* This file is obtained by: - copying a subset of the corresponding ast_xxx.ml file from migrate-parsetree (sub-modules Asttypes and Parsetree) - adding the type definitions for position, location, loc and longident - flattening all the modules - removing Asttypes.constant (unused and conflicts with Parsetree.constant) - renaming a few types: - - Location.t -> location - - Longident.t -> longident - adding a type longident_loc = longident loc and replacing all the occurences of the latter by the former. This is so that we can override iteration an the level of a longident loc - replacing all the (*IF_CURRENT = Foo.bar*) by: = Foo.bar - removing the extra values at the end of the file - replacing app [type ...] by [and ...] to make everything one recursive block - adding [@@deriving_inline traverse][@@@end] at the end *) (* Source code locations (ranges of positions), used in parsetree. *) type position = Lexing.position = { pos_fname : string ; pos_lnum : int ; pos_bol : int ; pos_cnum : int } and location = Location.t = { loc_start: position; loc_end: position; loc_ghost: bool; } and location_stack = location list (* Note on the use of Lexing.position in this module. If [pos_fname = ""], then use [!input_name] instead. If [pos_lnum = -1], then [pos_bol = 0]. Use [pos_cnum] and re-parse the file to get the line and character numbers. Else all fields are correct. *) and 'a loc = 'a Location.loc = { txt : 'a; loc : location; } (* Long identifiers, used in parsetree. *) and longident = Longident.t = Lident of string | Ldot of longident * string | Lapply of longident * longident and longident_loc = longident loc (** Auxiliary AST types used by parsetree and typedtree. *) and rec_flag = Asttypes.rec_flag = Nonrecursive | Recursive and direction_flag = Asttypes.direction_flag = Upto | Downto (* Order matters, used in polymorphic comparison *) and private_flag = Asttypes.private_flag = Private | Public and mutable_flag = Asttypes.mutable_flag = Immutable | Mutable and virtual_flag = Asttypes.virtual_flag = Virtual | Concrete and override_flag = Asttypes.override_flag = Override | Fresh and closed_flag = Asttypes.closed_flag = Closed | Open and label = string and arg_label = Asttypes.arg_label = Nolabel | Labelled of string (* label:T -> ... *) | Optional of string (* ?label:T -> ... *) and variance = Asttypes.variance = | Covariant | Contravariant | Invariant (** Abstract syntax tree produced by parsing *) and constant = Parsetree.constant = Pconst_integer of string * char option (* 3 3l 3L 3n Suffixes [g-z][G-Z] are accepted by the parser. Suffixes except 'l', 'L' and 'n' are rejected by the typechecker *) | Pconst_char of char (* 'c' *) | Pconst_string of string * string option (* "constant" {delim|other constant|delim} *) | Pconst_float of string * char option (* 3.4 2e5 1.4e-4 Suffixes [g-z][G-Z] are accepted by the parser. Suffixes are rejected by the typechecker. *) (** {1 Extension points} *) and attribute = Parsetree.attribute = { attr_name : string loc; attr_payload : payload; attr_loc : location; } (* [@id ARG] [@@id ARG] Metadata containers passed around within the AST. The compiler ignores unknown attributes. *) and extension = string loc * payload (* [%id ARG] [%%id ARG] Sub-language placeholder -- rejected by the typechecker. *) and attributes = attribute list and payload = Parsetree.payload = | PStr of structure | PSig of signature (* : SIG *) | PTyp of core_type (* : T *) | PPat of pattern * expression option (* ? P or ? P when E *) (** {1 Core language} *) (* Type expressions *) and core_type = Parsetree.core_type = { ptyp_desc: core_type_desc; ptyp_loc: location; ptyp_loc_stack: location_stack; ptyp_attributes: attributes; (* ... [@id1] [@id2] *) } and core_type_desc = Parsetree.core_type_desc = | Ptyp_any (* _ *) | Ptyp_var of string (* 'a *) | Ptyp_arrow of arg_label * core_type * core_type (* T1 -> T2 Simple ~l:T1 -> T2 Labelled ?l:T1 -> T2 Optional *) | Ptyp_tuple of core_type list (* T1 * ... * Tn Invariant: n >= 2 *) | Ptyp_constr of longident_loc * core_type list (* tconstr T tconstr (T1, ..., Tn) tconstr *) | Ptyp_object of object_field list * closed_flag (* < l1:T1; ...; ln:Tn > (flag = Closed) < l1:T1; ...; ln:Tn; .. > (flag = Open) *) | Ptyp_class of longident_loc * core_type list (* #tconstr T #tconstr (T1, ..., Tn) #tconstr *) | Ptyp_alias of core_type * string (* T as 'a *) | Ptyp_variant of row_field list * closed_flag * label list option (* [ `A|`B ] (flag = Closed; labels = None) [> `A|`B ] (flag = Open; labels = None) [< `A|`B ] (flag = Closed; labels = Some []) [< `A|`B > `X `Y ](flag = Closed; labels = Some ["X";"Y"]) *) | Ptyp_poly of string loc list * core_type (* 'a1 ... 'an. T Can only appear in the following context: - As the core_type of a Ppat_constraint node corresponding to a constraint on a let-binding: let x : 'a1 ... 'an. T = e ... - Under Cfk_virtual for methods (not values). - As the core_type of a Pctf_method node. - As the core_type of a Pexp_poly node. - As the pld_type field of a label_declaration. - As a core_type of a Ptyp_object node. *) | Ptyp_package of package_type (* (module S) *) | Ptyp_extension of extension (* [%id] *) and package_type = longident_loc * (longident_loc * core_type) list (* (module S) (module S with type t1 = T1 and ... and tn = Tn) *) and row_field = Parsetree.row_field = { prf_desc : row_field_desc; prf_loc : location; prf_attributes : attributes; } and row_field_desc = Parsetree.row_field_desc = | Rtag of label loc * bool * core_type list (* [`A] ( true, [] ) [`A of T] ( false, [T] ) [`A of T1 & .. & Tn] ( false, [T1;...Tn] ) [`A of & T1 & .. & Tn] ( true, [T1;...Tn] ) - The 2nd field is true if the tag contains a constant (empty) constructor. - '&' occurs when several types are used for the same constructor (see 4.2 in the manual) - TODO: switch to a record representation, and keep location *) | Rinherit of core_type (* [ T ] *) and object_field = Parsetree.object_field = { pof_desc : object_field_desc; pof_loc : location; pof_attributes : attributes; } and object_field_desc = Parsetree.object_field_desc = | Otag of label loc * core_type | Oinherit of core_type (* Patterns *) and pattern = Parsetree.pattern = { ppat_desc: pattern_desc; ppat_loc: location; ppat_loc_stack: location_stack; ppat_attributes: attributes; (* ... [@id1] [@id2] *) } and pattern_desc = Parsetree.pattern_desc = | Ppat_any (* _ *) | Ppat_var of string loc (* x *) | Ppat_alias of pattern * string loc (* P as 'a *) | Ppat_constant of constant (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) | Ppat_interval of constant * constant (* 'a'..'z' Other forms of interval are recognized by the parser but rejected by the type-checker. *) | Ppat_tuple of pattern list (* (P1, ..., Pn) Invariant: n >= 2 *) | Ppat_construct of longident_loc * pattern option (* C None C P Some P C (P1, ..., Pn) Some (Ppat_tuple [P1; ...; Pn]) *) | Ppat_variant of label * pattern option (* `A (None) `A P (Some P) *) | Ppat_record of (longident_loc * pattern) list * closed_flag (* { l1=P1; ...; ln=Pn } (flag = Closed) { l1=P1; ...; ln=Pn; _} (flag = Open) Invariant: n > 0 *) | Ppat_array of pattern list (* [| P1; ...; Pn |] *) | Ppat_or of pattern * pattern (* P1 | P2 *) | Ppat_constraint of pattern * core_type (* (P : T) *) | Ppat_type of longident_loc (* #tconst *) | Ppat_lazy of pattern (* lazy P *) | Ppat_unpack of string loc (* (module P) Note: (module P : S) is represented as Ppat_constraint(Ppat_unpack, Ptyp_package) *) | Ppat_exception of pattern (* exception P *) | Ppat_extension of extension (* [%id] *) | Ppat_open of longident_loc * pattern (* M.(P) *) (* Value expressions *) and expression = Parsetree.expression = { pexp_desc: expression_desc; pexp_loc: location; pexp_loc_stack: location_stack; pexp_attributes: attributes; (* ... [@id1] [@id2] *) } and expression_desc = Parsetree.expression_desc = | Pexp_ident of longident_loc (* x M.x *) | Pexp_constant of constant (* 1, 'a', "true", 1.0, 1l, 1L, 1n *) | Pexp_let of rec_flag * value_binding list * expression (* let P1 = E1 and ... and Pn = EN in E (flag = Nonrecursive) let rec P1 = E1 and ... and Pn = EN in E (flag = Recursive) *) | Pexp_function of case list (* function P1 -> E1 | ... | Pn -> En *) | Pexp_fun of arg_label * expression option * pattern * expression (* fun P -> E1 (Simple, None) fun ~l:P -> E1 (Labelled l, None) fun ?l:P -> E1 (Optional l, None) fun ?l:(P = E0) -> E1 (Optional l, Some E0) Notes: - If E0 is provided, only Optional is allowed. - "fun P1 P2 .. Pn -> E1" is represented as nested Pexp_fun. - "let f P = E" is represented using Pexp_fun. *) | Pexp_apply of expression * (arg_label * expression) list (* E0 ~l1:E1 ... ~ln:En li can be empty (non labeled argument) or start with '?' (optional argument). Invariant: n > 0 *) | Pexp_match of expression * case list (* match E0 with P1 -> E1 | ... | Pn -> En *) | Pexp_try of expression * case list (* try E0 with P1 -> E1 | ... | Pn -> En *) | Pexp_tuple of expression list (* (E1, ..., En) Invariant: n >= 2 *) | Pexp_construct of longident_loc * expression option (* C None C E Some E C (E1, ..., En) Some (Pexp_tuple[E1;...;En]) *) | Pexp_variant of label * expression option (* `A (None) `A E (Some E) *) | Pexp_record of (longident_loc * expression) list * expression option (* { l1=P1; ...; ln=Pn } (None) { E0 with l1=P1; ...; ln=Pn } (Some E0) Invariant: n > 0 *) | Pexp_field of expression * longident_loc (* E.l *) | Pexp_setfield of expression * longident_loc * expression (* E1.l <- E2 *) | Pexp_array of expression list (* [| E1; ...; En |] *) | Pexp_ifthenelse of expression * expression * expression option (* if E1 then E2 else E3 *) | Pexp_sequence of expression * expression (* E1; E2 *) | Pexp_while of expression * expression (* while E1 do E2 done *) | Pexp_for of pattern * expression * expression * direction_flag * expression (* for i = E1 to E2 do E3 done (flag = Upto) for i = E1 downto E2 do E3 done (flag = Downto) *) | Pexp_constraint of expression * core_type (* (E : T) *) | Pexp_coerce of expression * core_type option * core_type (* (E :> T) (None, T) (E : T0 :> T) (Some T0, T) *) | Pexp_send of expression * label loc (* E # m *) | Pexp_new of longident_loc (* new M.c *) | Pexp_setinstvar of label loc * expression (* x <- 2 *) | Pexp_override of (label loc * expression) list (* {< x1 = E1; ...; Xn = En >} *) | Pexp_letmodule of string loc * module_expr * expression (* let module M = ME in E *) | Pexp_letexception of extension_constructor * expression (* let exception C in E *) | Pexp_assert of expression (* assert E Note: "assert false" is treated in a special way by the type-checker. *) | Pexp_lazy of expression (* lazy E *) | Pexp_poly of expression * core_type option (* Used for method bodies. Can only be used as the expression under Cfk_concrete for methods (not values). *) | Pexp_object of class_structure (* object ... end *) | Pexp_newtype of string loc * expression (* fun (type t) -> E *) | Pexp_pack of module_expr (* (module ME) (module ME : S) is represented as Pexp_constraint(Pexp_pack, Ptyp_package S) *) | Pexp_open of open_declaration * expression (* M.(E) let open M in E let! open M in E *) | Pexp_letop of letop (* let* P = E in E let* P = E and* P = E in E *) | Pexp_extension of extension (* [%id] *) | Pexp_unreachable (* . *) and case = Parsetree.case = (* (P -> E) or (P when E0 -> E) *) { pc_lhs: pattern; pc_guard: expression option; pc_rhs: expression; } and letop = Parsetree.letop = { let_ : binding_op; ands : binding_op list; body : expression; } and binding_op = Parsetree.binding_op = { pbop_op : string loc; pbop_pat : pattern; pbop_exp : expression; pbop_loc : location; } (* Value descriptions *) and value_description = Parsetree.value_description = { pval_name: string loc; pval_type: core_type; pval_prim: string list; pval_attributes: attributes; (* ... [@@id1] [@@id2] *) pval_loc: location; } (* val x: T (prim = []) external x: T = "s1" ... "sn" (prim = ["s1";..."sn"]) *) (* Type declarations *) and type_declaration = Parsetree.type_declaration = { ptype_name: string loc; ptype_params: (core_type * variance) list; (* ('a1,...'an) t; None represents _*) ptype_cstrs: (core_type * core_type * location) list; (* ... constraint T1=T1' ... constraint Tn=Tn' *) ptype_kind: type_kind; ptype_private: private_flag; (* = private ... *) ptype_manifest: core_type option; (* = T *) ptype_attributes: attributes; (* ... [@@id1] [@@id2] *) ptype_loc: location; } (* type t (abstract, no manifest) type t = T0 (abstract, manifest=T0) type t = C of T | ... (variant, no manifest) type t = T0 = C of T | ... (variant, manifest=T0) type t = {l: T; ...} (record, no manifest) type t = T0 = {l : T; ...} (record, manifest=T0) type t = .. (open, no manifest) *) and type_kind = Parsetree.type_kind = | Ptype_abstract | Ptype_variant of constructor_declaration list | Ptype_record of label_declaration list (* Invariant: non-empty list *) | Ptype_open and label_declaration = Parsetree.label_declaration = { pld_name: string loc; pld_mutable: mutable_flag; pld_type: core_type; pld_loc: location; pld_attributes: attributes; (* l : T [@id1] [@id2] *) } (* { ...; l: T; ... } (mutable=Immutable) { ...; mutable l: T; ... } (mutable=Mutable) Note: T can be a Ptyp_poly. *) and constructor_declaration = Parsetree.constructor_declaration = { pcd_name: string loc; pcd_args: constructor_arguments; pcd_res: core_type option; pcd_loc: location; pcd_attributes: attributes; (* C of ... [@id1] [@id2] *) } and constructor_arguments = Parsetree.constructor_arguments = | Pcstr_tuple of core_type list | Pcstr_record of label_declaration list (* | C of T1 * ... * Tn (res = None, args = Pcstr_tuple []) | C: T0 (res = Some T0, args = []) | C: T1 * ... * Tn -> T0 (res = Some T0, args = Pcstr_tuple) | C of {...} (res = None, args = Pcstr_record) | C: {...} -> T0 (res = Some T0, args = Pcstr_record) | C of {...} as t (res = None, args = Pcstr_record) *) and type_extension = Parsetree.type_extension = { ptyext_path: longident_loc; ptyext_params: (core_type * variance) list; ptyext_constructors: extension_constructor list; ptyext_private: private_flag; ptyext_loc: location; ptyext_attributes: attributes; (* ... [@@id1] [@@id2] *) } (* type t += ... *) and extension_constructor = Parsetree.extension_constructor = { pext_name: string loc; pext_kind : extension_constructor_kind; pext_loc : location; pext_attributes: attributes; (* C of ... [@id1] [@id2] *) } and type_exception = Parsetree.type_exception = { ptyexn_constructor: extension_constructor; ptyexn_loc: location; ptyexn_attributes: attributes; } and extension_constructor_kind = Parsetree.extension_constructor_kind = Pext_decl of constructor_arguments * core_type option (* | C of T1 * ... * Tn ([T1; ...; Tn], None) | C: T0 ([], Some T0) | C: T1 * ... * Tn -> T0 ([T1; ...; Tn], Some T0) *) | Pext_rebind of longident_loc (* | C = D *) (** {1 Class language} *) (* Type expressions for the class language *) and class_type = Parsetree.class_type = { pcty_desc: class_type_desc; pcty_loc: location; pcty_attributes: attributes; (* ... [@id1] [@id2] *) } and class_type_desc = Parsetree.class_type_desc = | Pcty_constr of longident_loc * core_type list (* c ['a1, ..., 'an] c *) | Pcty_signature of class_signature (* object ... end *) | Pcty_arrow of arg_label * core_type * class_type (* T -> CT Simple ~l:T -> CT Labelled l ?l:T -> CT Optional l *) | Pcty_extension of extension (* [%id] *) | Pcty_open of open_description * class_type (* let open M in CT *) and class_signature = Parsetree.class_signature = { pcsig_self: core_type; pcsig_fields: class_type_field list; } (* object('selfpat) ... end object ... end (self = Ptyp_any) *) and class_type_field = Parsetree.class_type_field = { pctf_desc: class_type_field_desc; pctf_loc: location; pctf_attributes: attributes; (* ... [@@id1] [@@id2] *) } and class_type_field_desc = Parsetree.class_type_field_desc = | Pctf_inherit of class_type (* inherit CT *) | Pctf_val of (label loc * mutable_flag * virtual_flag * core_type) (* val x: T *) | Pctf_method of (label loc * private_flag * virtual_flag * core_type) (* method x: T Note: T can be a Ptyp_poly. *) | Pctf_constraint of (core_type * core_type) (* constraint T1 = T2 *) | Pctf_attribute of attribute (* [@@@id] *) | Pctf_extension of extension (* [%%id] *) and 'a class_infos = 'a Parsetree.class_infos = { pci_virt: virtual_flag; pci_params: (core_type * variance) list; pci_name: string loc; pci_expr: 'a; pci_loc: location; pci_attributes: attributes; (* ... [@@id1] [@@id2] *) } (* class c = ... class ['a1,...,'an] c = ... class virtual c = ... Also used for "class type" declaration. *) and class_description = class_type class_infos and class_type_declaration = class_type class_infos (* Value expressions for the class language *) and class_expr = Parsetree.class_expr = { pcl_desc: class_expr_desc; pcl_loc: location; pcl_attributes: attributes; (* ... [@id1] [@id2] *) } and class_expr_desc = Parsetree.class_expr_desc = | Pcl_constr of longident_loc * core_type list (* c ['a1, ..., 'an] c *) | Pcl_structure of class_structure (* object ... end *) | Pcl_fun of arg_label * expression option * pattern * class_expr (* fun P -> CE (Simple, None) fun ~l:P -> CE (Labelled l, None) fun ?l:P -> CE (Optional l, None) fun ?l:(P = E0) -> CE (Optional l, Some E0) *) | Pcl_apply of class_expr * (arg_label * expression) list (* CE ~l1:E1 ... ~ln:En li can be empty (non labeled argument) or start with '?' (optional argument). Invariant: n > 0 *) | Pcl_let of rec_flag * value_binding list * class_expr (* let P1 = E1 and ... and Pn = EN in CE (flag = Nonrecursive) let rec P1 = E1 and ... and Pn = EN in CE (flag = Recursive) *) | Pcl_constraint of class_expr * class_type (* (CE : CT) *) | Pcl_extension of extension (* [%id] *) | Pcl_open of open_description * class_expr (* let open M in CE *) and class_structure = Parsetree.class_structure = { pcstr_self: pattern; pcstr_fields: class_field list; } (* object(selfpat) ... end object ... end (self = Ppat_any) *) and class_field = Parsetree.class_field = { pcf_desc: class_field_desc; pcf_loc: location; pcf_attributes: attributes; (* ... [@@id1] [@@id2] *) } and class_field_desc = Parsetree.class_field_desc = | Pcf_inherit of override_flag * class_expr * string loc option (* inherit CE inherit CE as x inherit! CE inherit! CE as x *) | Pcf_val of (label loc * mutable_flag * class_field_kind) (* val x = E val virtual x: T *) | Pcf_method of (label loc * private_flag * class_field_kind) (* method x = E (E can be a Pexp_poly) method virtual x: T (T can be a Ptyp_poly) *) | Pcf_constraint of (core_type * core_type) (* constraint T1 = T2 *) | Pcf_initializer of expression (* initializer E *) | Pcf_attribute of attribute (* [@@@id] *) | Pcf_extension of extension (* [%%id] *) and class_field_kind = Parsetree.class_field_kind = | Cfk_virtual of core_type | Cfk_concrete of override_flag * expression and class_declaration = class_expr class_infos (** {1 Module language} *) (* Type expressions for the module language *) and module_type = Parsetree.module_type = { pmty_desc: module_type_desc; pmty_loc: location; pmty_attributes: attributes; (* ... [@id1] [@id2] *) } and module_type_desc = Parsetree.module_type_desc = | Pmty_ident of longident_loc (* S *) | Pmty_signature of signature (* sig ... end *) | Pmty_functor of string loc * module_type option * module_type (* functor(X : MT1) -> MT2 *) | Pmty_with of module_type * with_constraint list (* MT with ... *) | Pmty_typeof of module_expr (* module type of ME *) | Pmty_extension of extension (* [%id] *) | Pmty_alias of longident_loc (* (module M) *) and signature = signature_item list and signature_item = Parsetree.signature_item = { psig_desc: signature_item_desc; psig_loc: location; } and signature_item_desc = Parsetree.signature_item_desc = | Psig_value of value_description (* val x: T external x: T = "s1" ... "sn" *) | Psig_type of rec_flag * type_declaration list (* type t1 = ... and ... and tn = ... *) | Psig_typesubst of type_declaration list (* type t1 := ... and ... and tn := ... *) | Psig_typext of type_extension (* type t1 += ... *) | Psig_exception of type_exception (* exception C of T *) | Psig_module of module_declaration (* module X : MT *) | Psig_modsubst of module_substitution (* module X := M *) | Psig_recmodule of module_declaration list (* module rec X1 : MT1 and ... and Xn : MTn *) | Psig_modtype of module_type_declaration (* module type S = MT module type S *) | Psig_open of open_description (* open X *) | Psig_include of include_description (* include MT *) | Psig_class of class_description list (* class c1 : ... and ... and cn : ... *) | Psig_class_type of class_type_declaration list (* class type ct1 = ... and ... and ctn = ... *) | Psig_attribute of attribute (* [@@@id] *) | Psig_extension of extension * attributes (* [%%id] *) and module_declaration = Parsetree.module_declaration = { pmd_name: string loc; pmd_type: module_type; pmd_attributes: attributes; (* ... [@@id1] [@@id2] *) pmd_loc: location; } (* S : MT *) and module_substitution = Parsetree.module_substitution = { pms_name: string loc; pms_manifest: longident_loc; pms_attributes: attributes; pms_loc: location; } and module_type_declaration = Parsetree.module_type_declaration = { pmtd_name: string loc; pmtd_type: module_type option; pmtd_attributes: attributes; (* ... [@@id1] [@@id2] *) pmtd_loc: location; } (* S = MT S (abstract module type declaration, pmtd_type = None) *) and 'a open_infos = 'a Parsetree.open_infos = { popen_expr: 'a; popen_override: override_flag; popen_loc: location; popen_attributes: attributes; } and open_description = longident_loc open_infos (* open! X - popen_override = Override (silences the 'used identifier shadowing' warning) open X - popen_override = Fresh *) and open_declaration = module_expr open_infos and 'a include_infos = 'a Parsetree.include_infos = { pincl_mod: 'a; pincl_loc: location; pincl_attributes: attributes; } and include_description = module_type include_infos (* include MT *) and include_declaration = module_expr include_infos (* include ME *) and with_constraint = Parsetree.with_constraint = | Pwith_type of longident_loc * type_declaration (* with type X.t = ... Note: the last component of the longident must match the name of the type_declaration. *) | Pwith_module of longident_loc * longident_loc (* with module X.Y = Z *) | Pwith_typesubst of longident_loc * type_declaration (* with type X.t := ..., same format as [Pwith_type] *) | Pwith_modsubst of longident_loc * longident_loc (* with module X.Y := Z *) (* Value expressions for the module language *) and module_expr = Parsetree.module_expr = { pmod_desc: module_expr_desc; pmod_loc: location; pmod_attributes: attributes; (* ... [@id1] [@id2] *) } and module_expr_desc = Parsetree.module_expr_desc = | Pmod_ident of longident_loc (* X *) | Pmod_structure of structure (* struct ... end *) | Pmod_functor of string loc * module_type option * module_expr (* functor(X : MT1) -> ME *) | Pmod_apply of module_expr * module_expr (* ME1(ME2) *) | Pmod_constraint of module_expr * module_type (* (ME : MT) *) | Pmod_unpack of expression (* (val E) *) | Pmod_extension of extension (* [%id] *) and structure = structure_item list and structure_item = Parsetree.structure_item = { pstr_desc: structure_item_desc; pstr_loc: location; } and structure_item_desc = Parsetree.structure_item_desc = | Pstr_eval of expression * attributes (* E *) | Pstr_value of rec_flag * value_binding list (* let P1 = E1 and ... and Pn = EN (flag = Nonrecursive) let rec P1 = E1 and ... and Pn = EN (flag = Recursive) *) | Pstr_primitive of value_description (* val x: T external x: T = "s1" ... "sn" *) | Pstr_type of rec_flag * type_declaration list (* type t1 = ... and ... and tn = ... *) | Pstr_typext of type_extension (* type t1 += ... *) | Pstr_exception of type_exception (* exception C of T exception C = M.X *) | Pstr_module of module_binding (* module X = ME *) | Pstr_recmodule of module_binding list (* module rec X1 = ME1 and ... and Xn = MEn *) | Pstr_modtype of module_type_declaration (* module type S = MT *) | Pstr_open of open_declaration (* open X *) | Pstr_class of class_declaration list (* class c1 = ... and ... and cn = ... *) | Pstr_class_type of class_type_declaration list (* class type ct1 = ... and ... and ctn = ... *) | Pstr_include of include_declaration (* include ME *) | Pstr_attribute of attribute (* [@@@id] *) | Pstr_extension of extension * attributes (* [%%id] *) and value_binding = Parsetree.value_binding = { pvb_pat: pattern; pvb_expr: expression; pvb_attributes: attributes; pvb_loc: location; } and module_binding = Parsetree.module_binding = { pmb_name: string loc; pmb_expr: module_expr; pmb_attributes: attributes; pmb_loc: location; } (* X = ME *) (** {1 Toplevel} *) (* Toplevel phrases *) and toplevel_phrase = Parsetree.toplevel_phrase = | Ptop_def of structure | Ptop_dir of toplevel_directive (* #use, #load ... *) and toplevel_directive = Parsetree.toplevel_directive = { pdir_name : string loc; pdir_arg : directive_argument option; pdir_loc : location; } and directive_argument = Parsetree.directive_argument = { pdira_desc : directive_argument_desc; pdira_loc : location; } and directive_argument_desc = Parsetree.directive_argument_desc = | Pdir_string of string | Pdir_int of string * char option | Pdir_ident of longident | Pdir_bool of bool [@@deriving_inline traverse] class virtual map = object (self) method virtual bool : bool -> bool method virtual char : char -> char method virtual int : int -> int method virtual list : 'a . ('a -> 'a) -> 'a list -> 'a list method virtual option : 'a . ('a -> 'a) -> 'a option -> 'a option method virtual string : string -> string method position : position -> position= fun { pos_fname; pos_lnum; pos_bol; pos_cnum } -> let pos_fname = self#string pos_fname in let pos_lnum = self#int pos_lnum in let pos_bol = self#int pos_bol in let pos_cnum = self#int pos_cnum in { pos_fname; pos_lnum; pos_bol; pos_cnum } method location : location -> location= fun { loc_start; loc_end; loc_ghost } -> let loc_start = self#position loc_start in let loc_end = self#position loc_end in let loc_ghost = self#bool loc_ghost in { loc_start; loc_end; loc_ghost } method location_stack : location_stack -> location_stack= self#list self#location method loc : 'a . ('a -> 'a) -> 'a loc -> 'a loc= fun _a -> fun { txt; loc } -> let txt = _a txt in let loc = self#location loc in { txt; loc } method longident : longident -> longident= fun x -> match x with | Lident a -> let a = self#string a in Lident a | Ldot (a, b) -> let a = self#longident a in let b = self#string b in Ldot (a, b) | Lapply (a, b) -> let a = self#longident a in let b = self#longident b in Lapply (a, b) method longident_loc : longident_loc -> longident_loc= self#loc self#longident method rec_flag : rec_flag -> rec_flag= fun x -> x method direction_flag : direction_flag -> direction_flag= fun x -> x method private_flag : private_flag -> private_flag= fun x -> x method mutable_flag : mutable_flag -> mutable_flag= fun x -> x method virtual_flag : virtual_flag -> virtual_flag= fun x -> x method override_flag : override_flag -> override_flag= fun x -> x method closed_flag : closed_flag -> closed_flag= fun x -> x method label : label -> label= self#string method arg_label : arg_label -> arg_label= fun x -> match x with | Nolabel -> Nolabel | Labelled a -> let a = self#string a in Labelled a | Optional a -> let a = self#string a in Optional a method variance : variance -> variance= fun x -> x method constant : constant -> constant= fun x -> match x with | Pconst_integer (a, b) -> let a = self#string a in let b = self#option self#char b in Pconst_integer (a, b) | Pconst_char a -> let a = self#char a in Pconst_char a | Pconst_string (a, b) -> let a = self#string a in let b = self#option self#string b in Pconst_string (a, b) | Pconst_float (a, b) -> let a = self#string a in let b = self#option self#char b in Pconst_float (a, b) method attribute : attribute -> attribute= fun { attr_name; attr_payload; attr_loc } -> let attr_name = self#loc self#string attr_name in let attr_payload = self#payload attr_payload in let attr_loc = self#location attr_loc in { attr_name; attr_payload; attr_loc } method extension : extension -> extension= fun (a, b) -> let a = self#loc self#string a in let b = self#payload b in (a, b) method attributes : attributes -> attributes= self#list self#attribute method payload : payload -> payload= fun x -> match x with | PStr a -> let a = self#structure a in PStr a | PSig a -> let a = self#signature a in PSig a | PTyp a -> let a = self#core_type a in PTyp a | PPat (a, b) -> let a = self#pattern a in let b = self#option self#expression b in PPat (a, b) method core_type : core_type -> core_type= fun { ptyp_desc; ptyp_loc; ptyp_loc_stack; ptyp_attributes } -> let ptyp_desc = self#core_type_desc ptyp_desc in let ptyp_loc = self#location ptyp_loc in let ptyp_loc_stack = self#location_stack ptyp_loc_stack in let ptyp_attributes = self#attributes ptyp_attributes in { ptyp_desc; ptyp_loc; ptyp_loc_stack; ptyp_attributes } method core_type_desc : core_type_desc -> core_type_desc= fun x -> match x with | Ptyp_any -> Ptyp_any | Ptyp_var a -> let a = self#string a in Ptyp_var a | Ptyp_arrow (a, b, c) -> let a = self#arg_label a in let b = self#core_type b in let c = self#core_type c in Ptyp_arrow (a, b, c) | Ptyp_tuple a -> let a = self#list self#core_type a in Ptyp_tuple a | Ptyp_constr (a, b) -> let a = self#longident_loc a in let b = self#list self#core_type b in Ptyp_constr (a, b) | Ptyp_object (a, b) -> let a = self#list self#object_field a in let b = self#closed_flag b in Ptyp_object (a, b) | Ptyp_class (a, b) -> let a = self#longident_loc a in let b = self#list self#core_type b in Ptyp_class (a, b) | Ptyp_alias (a, b) -> let a = self#core_type a in let b = self#string b in Ptyp_alias (a, b) | Ptyp_variant (a, b, c) -> let a = self#list self#row_field a in let b = self#closed_flag b in let c = self#option (self#list self#label) c in Ptyp_variant (a, b, c) | Ptyp_poly (a, b) -> let a = self#list (self#loc self#string) a in let b = self#core_type b in Ptyp_poly (a, b) | Ptyp_package a -> let a = self#package_type a in Ptyp_package a | Ptyp_extension a -> let a = self#extension a in Ptyp_extension a method package_type : package_type -> package_type= fun (a, b) -> let a = self#longident_loc a in let b = self#list (fun (a, b) -> let a = self#longident_loc a in let b = self#core_type b in (a, b)) b in (a, b) method row_field : row_field -> row_field= fun { prf_desc; prf_loc; prf_attributes } -> let prf_desc = self#row_field_desc prf_desc in let prf_loc = self#location prf_loc in let prf_attributes = self#attributes prf_attributes in { prf_desc; prf_loc; prf_attributes } method row_field_desc : row_field_desc -> row_field_desc= fun x -> match x with | Rtag (a, b, c) -> let a = self#loc self#label a in let b = self#bool b in let c = self#list self#core_type c in Rtag (a, b, c) | Rinherit a -> let a = self#core_type a in Rinherit a method object_field : object_field -> object_field= fun { pof_desc; pof_loc; pof_attributes } -> let pof_desc = self#object_field_desc pof_desc in let pof_loc = self#location pof_loc in let pof_attributes = self#attributes pof_attributes in { pof_desc; pof_loc; pof_attributes } method object_field_desc : object_field_desc -> object_field_desc= fun x -> match x with | Otag (a, b) -> let a = self#loc self#label a in let b = self#core_type b in Otag (a, b) | Oinherit a -> let a = self#core_type a in Oinherit a method pattern : pattern -> pattern= fun { ppat_desc; ppat_loc; ppat_loc_stack; ppat_attributes } -> let ppat_desc = self#pattern_desc ppat_desc in let ppat_loc = self#location ppat_loc in let ppat_loc_stack = self#location_stack ppat_loc_stack in let ppat_attributes = self#attributes ppat_attributes in { ppat_desc; ppat_loc; ppat_loc_stack; ppat_attributes } method pattern_desc : pattern_desc -> pattern_desc= fun x -> match x with | Ppat_any -> Ppat_any | Ppat_var a -> let a = self#loc self#string a in Ppat_var a | Ppat_alias (a, b) -> let a = self#pattern a in let b = self#loc self#string b in Ppat_alias (a, b) | Ppat_constant a -> let a = self#constant a in Ppat_constant a | Ppat_interval (a, b) -> let a = self#constant a in let b = self#constant b in Ppat_interval (a, b) | Ppat_tuple a -> let a = self#list self#pattern a in Ppat_tuple a | Ppat_construct (a, b) -> let a = self#longident_loc a in let b = self#option self#pattern b in Ppat_construct (a, b) | Ppat_variant (a, b) -> let a = self#label a in let b = self#option self#pattern b in Ppat_variant (a, b) | Ppat_record (a, b) -> let a = self#list (fun (a, b) -> let a = self#longident_loc a in let b = self#pattern b in (a, b)) a in let b = self#closed_flag b in Ppat_record (a, b) | Ppat_array a -> let a = self#list self#pattern a in Ppat_array a | Ppat_or (a, b) -> let a = self#pattern a in let b = self#pattern b in Ppat_or (a, b) | Ppat_constraint (a, b) -> let a = self#pattern a in let b = self#core_type b in Ppat_constraint (a, b) | Ppat_type a -> let a = self#longident_loc a in Ppat_type a | Ppat_lazy a -> let a = self#pattern a in Ppat_lazy a | Ppat_unpack a -> let a = self#loc self#string a in Ppat_unpack a | Ppat_exception a -> let a = self#pattern a in Ppat_exception a | Ppat_extension a -> let a = self#extension a in Ppat_extension a | Ppat_open (a, b) -> let a = self#longident_loc a in let b = self#pattern b in Ppat_open (a, b) method expression : expression -> expression= fun { pexp_desc; pexp_loc; pexp_loc_stack; pexp_attributes } -> let pexp_desc = self#expression_desc pexp_desc in let pexp_loc = self#location pexp_loc in let pexp_loc_stack = self#location_stack pexp_loc_stack in let pexp_attributes = self#attributes pexp_attributes in { pexp_desc; pexp_loc; pexp_loc_stack; pexp_attributes } method expression_desc : expression_desc -> expression_desc= fun x -> match x with | Pexp_ident a -> let a = self#longident_loc a in Pexp_ident a | Pexp_constant a -> let a = self#constant a in Pexp_constant a | Pexp_let (a, b, c) -> let a = self#rec_flag a in let b = self#list self#value_binding b in let c = self#expression c in Pexp_let (a, b, c) | Pexp_function a -> let a = self#list self#case a in Pexp_function a | Pexp_fun (a, b, c, d) -> let a = self#arg_label a in let b = self#option self#expression b in let c = self#pattern c in let d = self#expression d in Pexp_fun (a, b, c, d) | Pexp_apply (a, b) -> let a = self#expression a in let b = self#list (fun (a, b) -> let a = self#arg_label a in let b = self#expression b in (a, b)) b in Pexp_apply (a, b) | Pexp_match (a, b) -> let a = self#expression a in let b = self#list self#case b in Pexp_match (a, b) | Pexp_try (a, b) -> let a = self#expression a in let b = self#list self#case b in Pexp_try (a, b) | Pexp_tuple a -> let a = self#list self#expression a in Pexp_tuple a | Pexp_construct (a, b) -> let a = self#longident_loc a in let b = self#option self#expression b in Pexp_construct (a, b) | Pexp_variant (a, b) -> let a = self#label a in let b = self#option self#expression b in Pexp_variant (a, b) | Pexp_record (a, b) -> let a = self#list (fun (a, b) -> let a = self#longident_loc a in let b = self#expression b in (a, b)) a in let b = self#option self#expression b in Pexp_record (a, b) | Pexp_field (a, b) -> let a = self#expression a in let b = self#longident_loc b in Pexp_field (a, b) | Pexp_setfield (a, b, c) -> let a = self#expression a in let b = self#longident_loc b in let c = self#expression c in Pexp_setfield (a, b, c) | Pexp_array a -> let a = self#list self#expression a in Pexp_array a | Pexp_ifthenelse (a, b, c) -> let a = self#expression a in let b = self#expression b in let c = self#option self#expression c in Pexp_ifthenelse (a, b, c) | Pexp_sequence (a, b) -> let a = self#expression a in let b = self#expression b in Pexp_sequence (a, b) | Pexp_while (a, b) -> let a = self#expression a in let b = self#expression b in Pexp_while (a, b) | Pexp_for (a, b, c, d, e) -> let a = self#pattern a in let b = self#expression b in let c = self#expression c in let d = self#direction_flag d in let e = self#expression e in Pexp_for (a, b, c, d, e) | Pexp_constraint (a, b) -> let a = self#expression a in let b = self#core_type b in Pexp_constraint (a, b) | Pexp_coerce (a, b, c) -> let a = self#expression a in let b = self#option self#core_type b in let c = self#core_type c in Pexp_coerce (a, b, c) | Pexp_send (a, b) -> let a = self#expression a in let b = self#loc self#label b in Pexp_send (a, b) | Pexp_new a -> let a = self#longident_loc a in Pexp_new a | Pexp_setinstvar (a, b) -> let a = self#loc self#label a in let b = self#expression b in Pexp_setinstvar (a, b) | Pexp_override a -> let a = self#list (fun (a, b) -> let a = self#loc self#label a in let b = self#expression b in (a, b)) a in Pexp_override a | Pexp_letmodule (a, b, c) -> let a = self#loc self#string a in let b = self#module_expr b in let c = self#expression c in Pexp_letmodule (a, b, c) | Pexp_letexception (a, b) -> let a = self#extension_constructor a in let b = self#expression b in Pexp_letexception (a, b) | Pexp_assert a -> let a = self#expression a in Pexp_assert a | Pexp_lazy a -> let a = self#expression a in Pexp_lazy a | Pexp_poly (a, b) -> let a = self#expression a in let b = self#option self#core_type b in Pexp_poly (a, b) | Pexp_object a -> let a = self#class_structure a in Pexp_object a | Pexp_newtype (a, b) -> let a = self#loc self#string a in let b = self#expression b in Pexp_newtype (a, b) | Pexp_pack a -> let a = self#module_expr a in Pexp_pack a | Pexp_open (a, b) -> let a = self#open_declaration a in let b = self#expression b in Pexp_open (a, b) | Pexp_letop a -> let a = self#letop a in Pexp_letop a | Pexp_extension a -> let a = self#extension a in Pexp_extension a | Pexp_unreachable -> Pexp_unreachable method case : case -> case= fun { pc_lhs; pc_guard; pc_rhs } -> let pc_lhs = self#pattern pc_lhs in let pc_guard = self#option self#expression pc_guard in let pc_rhs = self#expression pc_rhs in { pc_lhs; pc_guard; pc_rhs } method letop : letop -> letop= fun { let_; ands; body } -> let let_ = self#binding_op let_ in let ands = self#list self#binding_op ands in let body = self#expression body in { let_; ands; body } method binding_op : binding_op -> binding_op= fun { pbop_op; pbop_pat; pbop_exp; pbop_loc } -> let pbop_op = self#loc self#string pbop_op in let pbop_pat = self#pattern pbop_pat in let pbop_exp = self#expression pbop_exp in let pbop_loc = self#location pbop_loc in { pbop_op; pbop_pat; pbop_exp; pbop_loc } method value_description : value_description -> value_description= fun { pval_name; pval_type; pval_prim; pval_attributes; pval_loc } -> let pval_name = self#loc self#string pval_name in let pval_type = self#core_type pval_type in let pval_prim = self#list self#string pval_prim in let pval_attributes = self#attributes pval_attributes in let pval_loc = self#location pval_loc in { pval_name; pval_type; pval_prim; pval_attributes; pval_loc } method type_declaration : type_declaration -> type_declaration= fun { ptype_name; ptype_params; ptype_cstrs; ptype_kind; ptype_private; ptype_manifest; ptype_attributes; ptype_loc } -> let ptype_name = self#loc self#string ptype_name in let ptype_params = self#list (fun (a, b) -> let a = self#core_type a in let b = self#variance b in (a, b)) ptype_params in let ptype_cstrs = self#list (fun (a, b, c) -> let a = self#core_type a in let b = self#core_type b in let c = self#location c in (a, b, c)) ptype_cstrs in let ptype_kind = self#type_kind ptype_kind in let ptype_private = self#private_flag ptype_private in let ptype_manifest = self#option self#core_type ptype_manifest in let ptype_attributes = self#attributes ptype_attributes in let ptype_loc = self#location ptype_loc in { ptype_name; ptype_params; ptype_cstrs; ptype_kind; ptype_private; ptype_manifest; ptype_attributes; ptype_loc } method type_kind : type_kind -> type_kind= fun x -> match x with | Ptype_abstract -> Ptype_abstract | Ptype_variant a -> let a = self#list self#constructor_declaration a in Ptype_variant a | Ptype_record a -> let a = self#list self#label_declaration a in Ptype_record a | Ptype_open -> Ptype_open method label_declaration : label_declaration -> label_declaration= fun { pld_name; pld_mutable; pld_type; pld_loc; pld_attributes } -> let pld_name = self#loc self#string pld_name in let pld_mutable = self#mutable_flag pld_mutable in let pld_type = self#core_type pld_type in let pld_loc = self#location pld_loc in let pld_attributes = self#attributes pld_attributes in { pld_name; pld_mutable; pld_type; pld_loc; pld_attributes } method constructor_declaration : constructor_declaration -> constructor_declaration= fun { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } -> let pcd_name = self#loc self#string pcd_name in let pcd_args = self#constructor_arguments pcd_args in let pcd_res = self#option self#core_type pcd_res in let pcd_loc = self#location pcd_loc in let pcd_attributes = self#attributes pcd_attributes in { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } method constructor_arguments : constructor_arguments -> constructor_arguments= fun x -> match x with | Pcstr_tuple a -> let a = self#list self#core_type a in Pcstr_tuple a | Pcstr_record a -> let a = self#list self#label_declaration a in Pcstr_record a method type_extension : type_extension -> type_extension= fun { ptyext_path; ptyext_params; ptyext_constructors; ptyext_private; ptyext_loc; ptyext_attributes } -> let ptyext_path = self#longident_loc ptyext_path in let ptyext_params = self#list (fun (a, b) -> let a = self#core_type a in let b = self#variance b in (a, b)) ptyext_params in let ptyext_constructors = self#list self#extension_constructor ptyext_constructors in let ptyext_private = self#private_flag ptyext_private in let ptyext_loc = self#location ptyext_loc in let ptyext_attributes = self#attributes ptyext_attributes in { ptyext_path; ptyext_params; ptyext_constructors; ptyext_private; ptyext_loc; ptyext_attributes } method extension_constructor : extension_constructor -> extension_constructor= fun { pext_name; pext_kind; pext_loc; pext_attributes } -> let pext_name = self#loc self#string pext_name in let pext_kind = self#extension_constructor_kind pext_kind in let pext_loc = self#location pext_loc in let pext_attributes = self#attributes pext_attributes in { pext_name; pext_kind; pext_loc; pext_attributes } method type_exception : type_exception -> type_exception= fun { ptyexn_constructor; ptyexn_loc; ptyexn_attributes } -> let ptyexn_constructor = self#extension_constructor ptyexn_constructor in let ptyexn_loc = self#location ptyexn_loc in let ptyexn_attributes = self#attributes ptyexn_attributes in { ptyexn_constructor; ptyexn_loc; ptyexn_attributes } method extension_constructor_kind : extension_constructor_kind -> extension_constructor_kind= fun x -> match x with | Pext_decl (a, b) -> let a = self#constructor_arguments a in let b = self#option self#core_type b in Pext_decl (a, b) | Pext_rebind a -> let a = self#longident_loc a in Pext_rebind a method class_type : class_type -> class_type= fun { pcty_desc; pcty_loc; pcty_attributes } -> let pcty_desc = self#class_type_desc pcty_desc in let pcty_loc = self#location pcty_loc in let pcty_attributes = self#attributes pcty_attributes in { pcty_desc; pcty_loc; pcty_attributes } method class_type_desc : class_type_desc -> class_type_desc= fun x -> match x with | Pcty_constr (a, b) -> let a = self#longident_loc a in let b = self#list self#core_type b in Pcty_constr (a, b) | Pcty_signature a -> let a = self#class_signature a in Pcty_signature a | Pcty_arrow (a, b, c) -> let a = self#arg_label a in let b = self#core_type b in let c = self#class_type c in Pcty_arrow (a, b, c) | Pcty_extension a -> let a = self#extension a in Pcty_extension a | Pcty_open (a, b) -> let a = self#open_description a in let b = self#class_type b in Pcty_open (a, b) method class_signature : class_signature -> class_signature= fun { pcsig_self; pcsig_fields } -> let pcsig_self = self#core_type pcsig_self in let pcsig_fields = self#list self#class_type_field pcsig_fields in { pcsig_self; pcsig_fields } method class_type_field : class_type_field -> class_type_field= fun { pctf_desc; pctf_loc; pctf_attributes } -> let pctf_desc = self#class_type_field_desc pctf_desc in let pctf_loc = self#location pctf_loc in let pctf_attributes = self#attributes pctf_attributes in { pctf_desc; pctf_loc; pctf_attributes } method class_type_field_desc : class_type_field_desc -> class_type_field_desc= fun x -> match x with | Pctf_inherit a -> let a = self#class_type a in Pctf_inherit a | Pctf_val a -> let a = (fun (a, b, c, d) -> let a = self#loc self#label a in let b = self#mutable_flag b in let c = self#virtual_flag c in let d = self#core_type d in (a, b, c, d)) a in Pctf_val a | Pctf_method a -> let a = (fun (a, b, c, d) -> let a = self#loc self#label a in let b = self#private_flag b in let c = self#virtual_flag c in let d = self#core_type d in (a, b, c, d)) a in Pctf_method a | Pctf_constraint a -> let a = (fun (a, b) -> let a = self#core_type a in let b = self#core_type b in (a, b)) a in Pctf_constraint a | Pctf_attribute a -> let a = self#attribute a in Pctf_attribute a | Pctf_extension a -> let a = self#extension a in Pctf_extension a method class_infos : 'a . ('a -> 'a) -> 'a class_infos -> 'a class_infos= fun _a -> fun { pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes } -> let pci_virt = self#virtual_flag pci_virt in let pci_params = self#list (fun (a, b) -> let a = self#core_type a in let b = self#variance b in (a, b)) pci_params in let pci_name = self#loc self#string pci_name in let pci_expr = _a pci_expr in let pci_loc = self#location pci_loc in let pci_attributes = self#attributes pci_attributes in { pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes } method class_description : class_description -> class_description= self#class_infos self#class_type method class_type_declaration : class_type_declaration -> class_type_declaration= self#class_infos self#class_type method class_expr : class_expr -> class_expr= fun { pcl_desc; pcl_loc; pcl_attributes } -> let pcl_desc = self#class_expr_desc pcl_desc in let pcl_loc = self#location pcl_loc in let pcl_attributes = self#attributes pcl_attributes in { pcl_desc; pcl_loc; pcl_attributes } method class_expr_desc : class_expr_desc -> class_expr_desc= fun x -> match x with | Pcl_constr (a, b) -> let a = self#longident_loc a in let b = self#list self#core_type b in Pcl_constr (a, b) | Pcl_structure a -> let a = self#class_structure a in Pcl_structure a | Pcl_fun (a, b, c, d) -> let a = self#arg_label a in let b = self#option self#expression b in let c = self#pattern c in let d = self#class_expr d in Pcl_fun (a, b, c, d) | Pcl_apply (a, b) -> let a = self#class_expr a in let b = self#list (fun (a, b) -> let a = self#arg_label a in let b = self#expression b in (a, b)) b in Pcl_apply (a, b) | Pcl_let (a, b, c) -> let a = self#rec_flag a in let b = self#list self#value_binding b in let c = self#class_expr c in Pcl_let (a, b, c) | Pcl_constraint (a, b) -> let a = self#class_expr a in let b = self#class_type b in Pcl_constraint (a, b) | Pcl_extension a -> let a = self#extension a in Pcl_extension a | Pcl_open (a, b) -> let a = self#open_description a in let b = self#class_expr b in Pcl_open (a, b) method class_structure : class_structure -> class_structure= fun { pcstr_self; pcstr_fields } -> let pcstr_self = self#pattern pcstr_self in let pcstr_fields = self#list self#class_field pcstr_fields in { pcstr_self; pcstr_fields } method class_field : class_field -> class_field= fun { pcf_desc; pcf_loc; pcf_attributes } -> let pcf_desc = self#class_field_desc pcf_desc in let pcf_loc = self#location pcf_loc in let pcf_attributes = self#attributes pcf_attributes in { pcf_desc; pcf_loc; pcf_attributes } method class_field_desc : class_field_desc -> class_field_desc= fun x -> match x with | Pcf_inherit (a, b, c) -> let a = self#override_flag a in let b = self#class_expr b in let c = self#option (self#loc self#string) c in Pcf_inherit (a, b, c) | Pcf_val a -> let a = (fun (a, b, c) -> let a = self#loc self#label a in let b = self#mutable_flag b in let c = self#class_field_kind c in (a, b, c)) a in Pcf_val a | Pcf_method a -> let a = (fun (a, b, c) -> let a = self#loc self#label a in let b = self#private_flag b in let c = self#class_field_kind c in (a, b, c)) a in Pcf_method a | Pcf_constraint a -> let a = (fun (a, b) -> let a = self#core_type a in let b = self#core_type b in (a, b)) a in Pcf_constraint a | Pcf_initializer a -> let a = self#expression a in Pcf_initializer a | Pcf_attribute a -> let a = self#attribute a in Pcf_attribute a | Pcf_extension a -> let a = self#extension a in Pcf_extension a method class_field_kind : class_field_kind -> class_field_kind= fun x -> match x with | Cfk_virtual a -> let a = self#core_type a in Cfk_virtual a | Cfk_concrete (a, b) -> let a = self#override_flag a in let b = self#expression b in Cfk_concrete (a, b) method class_declaration : class_declaration -> class_declaration= self#class_infos self#class_expr method module_type : module_type -> module_type= fun { pmty_desc; pmty_loc; pmty_attributes } -> let pmty_desc = self#module_type_desc pmty_desc in let pmty_loc = self#location pmty_loc in let pmty_attributes = self#attributes pmty_attributes in { pmty_desc; pmty_loc; pmty_attributes } method module_type_desc : module_type_desc -> module_type_desc= fun x -> match x with | Pmty_ident a -> let a = self#longident_loc a in Pmty_ident a | Pmty_signature a -> let a = self#signature a in Pmty_signature a | Pmty_functor (a, b, c) -> let a = self#loc self#string a in let b = self#option self#module_type b in let c = self#module_type c in Pmty_functor (a, b, c) | Pmty_with (a, b) -> let a = self#module_type a in let b = self#list self#with_constraint b in Pmty_with (a, b) | Pmty_typeof a -> let a = self#module_expr a in Pmty_typeof a | Pmty_extension a -> let a = self#extension a in Pmty_extension a | Pmty_alias a -> let a = self#longident_loc a in Pmty_alias a method signature : signature -> signature= self#list self#signature_item method signature_item : signature_item -> signature_item= fun { psig_desc; psig_loc } -> let psig_desc = self#signature_item_desc psig_desc in let psig_loc = self#location psig_loc in { psig_desc; psig_loc } method signature_item_desc : signature_item_desc -> signature_item_desc= fun x -> match x with | Psig_value a -> let a = self#value_description a in Psig_value a | Psig_type (a, b) -> let a = self#rec_flag a in let b = self#list self#type_declaration b in Psig_type (a, b) | Psig_typesubst a -> let a = self#list self#type_declaration a in Psig_typesubst a | Psig_typext a -> let a = self#type_extension a in Psig_typext a | Psig_exception a -> let a = self#type_exception a in Psig_exception a | Psig_module a -> let a = self#module_declaration a in Psig_module a | Psig_modsubst a -> let a = self#module_substitution a in Psig_modsubst a | Psig_recmodule a -> let a = self#list self#module_declaration a in Psig_recmodule a | Psig_modtype a -> let a = self#module_type_declaration a in Psig_modtype a | Psig_open a -> let a = self#open_description a in Psig_open a | Psig_include a -> let a = self#include_description a in Psig_include a | Psig_class a -> let a = self#list self#class_description a in Psig_class a | Psig_class_type a -> let a = self#list self#class_type_declaration a in Psig_class_type a | Psig_attribute a -> let a = self#attribute a in Psig_attribute a | Psig_extension (a, b) -> let a = self#extension a in let b = self#attributes b in Psig_extension (a, b) method module_declaration : module_declaration -> module_declaration= fun { pmd_name; pmd_type; pmd_attributes; pmd_loc } -> let pmd_name = self#loc self#string pmd_name in let pmd_type = self#module_type pmd_type in let pmd_attributes = self#attributes pmd_attributes in let pmd_loc = self#location pmd_loc in { pmd_name; pmd_type; pmd_attributes; pmd_loc } method module_substitution : module_substitution -> module_substitution= fun { pms_name; pms_manifest; pms_attributes; pms_loc } -> let pms_name = self#loc self#string pms_name in let pms_manifest = self#longident_loc pms_manifest in let pms_attributes = self#attributes pms_attributes in let pms_loc = self#location pms_loc in { pms_name; pms_manifest; pms_attributes; pms_loc } method module_type_declaration : module_type_declaration -> module_type_declaration= fun { pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc } -> let pmtd_name = self#loc self#string pmtd_name in let pmtd_type = self#option self#module_type pmtd_type in let pmtd_attributes = self#attributes pmtd_attributes in let pmtd_loc = self#location pmtd_loc in { pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc } method open_infos : 'a . ('a -> 'a) -> 'a open_infos -> 'a open_infos= fun _a -> fun { popen_expr; popen_override; popen_loc; popen_attributes } -> let popen_expr = _a popen_expr in let popen_override = self#override_flag popen_override in let popen_loc = self#location popen_loc in let popen_attributes = self#attributes popen_attributes in { popen_expr; popen_override; popen_loc; popen_attributes } method open_description : open_description -> open_description= self#open_infos self#longident_loc method open_declaration : open_declaration -> open_declaration= self#open_infos self#module_expr method include_infos : 'a . ('a -> 'a) -> 'a include_infos -> 'a include_infos= fun _a -> fun { pincl_mod; pincl_loc; pincl_attributes } -> let pincl_mod = _a pincl_mod in let pincl_loc = self#location pincl_loc in let pincl_attributes = self#attributes pincl_attributes in { pincl_mod; pincl_loc; pincl_attributes } method include_description : include_description -> include_description= self#include_infos self#module_type method include_declaration : include_declaration -> include_declaration= self#include_infos self#module_expr method with_constraint : with_constraint -> with_constraint= fun x -> match x with | Pwith_type (a, b) -> let a = self#longident_loc a in let b = self#type_declaration b in Pwith_type (a, b) | Pwith_module (a, b) -> let a = self#longident_loc a in let b = self#longident_loc b in Pwith_module (a, b) | Pwith_typesubst (a, b) -> let a = self#longident_loc a in let b = self#type_declaration b in Pwith_typesubst (a, b) | Pwith_modsubst (a, b) -> let a = self#longident_loc a in let b = self#longident_loc b in Pwith_modsubst (a, b) method module_expr : module_expr -> module_expr= fun { pmod_desc; pmod_loc; pmod_attributes } -> let pmod_desc = self#module_expr_desc pmod_desc in let pmod_loc = self#location pmod_loc in let pmod_attributes = self#attributes pmod_attributes in { pmod_desc; pmod_loc; pmod_attributes } method module_expr_desc : module_expr_desc -> module_expr_desc= fun x -> match x with | Pmod_ident a -> let a = self#longident_loc a in Pmod_ident a | Pmod_structure a -> let a = self#structure a in Pmod_structure a | Pmod_functor (a, b, c) -> let a = self#loc self#string a in let b = self#option self#module_type b in let c = self#module_expr c in Pmod_functor (a, b, c) | Pmod_apply (a, b) -> let a = self#module_expr a in let b = self#module_expr b in Pmod_apply (a, b) | Pmod_constraint (a, b) -> let a = self#module_expr a in let b = self#module_type b in Pmod_constraint (a, b) | Pmod_unpack a -> let a = self#expression a in Pmod_unpack a | Pmod_extension a -> let a = self#extension a in Pmod_extension a method structure : structure -> structure= self#list self#structure_item method structure_item : structure_item -> structure_item= fun { pstr_desc; pstr_loc } -> let pstr_desc = self#structure_item_desc pstr_desc in let pstr_loc = self#location pstr_loc in { pstr_desc; pstr_loc } method structure_item_desc : structure_item_desc -> structure_item_desc= fun x -> match x with | Pstr_eval (a, b) -> let a = self#expression a in let b = self#attributes b in Pstr_eval (a, b) | Pstr_value (a, b) -> let a = self#rec_flag a in let b = self#list self#value_binding b in Pstr_value (a, b) | Pstr_primitive a -> let a = self#value_description a in Pstr_primitive a | Pstr_type (a, b) -> let a = self#rec_flag a in let b = self#list self#type_declaration b in Pstr_type (a, b) | Pstr_typext a -> let a = self#type_extension a in Pstr_typext a | Pstr_exception a -> let a = self#type_exception a in Pstr_exception a | Pstr_module a -> let a = self#module_binding a in Pstr_module a | Pstr_recmodule a -> let a = self#list self#module_binding a in Pstr_recmodule a | Pstr_modtype a -> let a = self#module_type_declaration a in Pstr_modtype a | Pstr_open a -> let a = self#open_declaration a in Pstr_open a | Pstr_class a -> let a = self#list self#class_declaration a in Pstr_class a | Pstr_class_type a -> let a = self#list self#class_type_declaration a in Pstr_class_type a | Pstr_include a -> let a = self#include_declaration a in Pstr_include a | Pstr_attribute a -> let a = self#attribute a in Pstr_attribute a | Pstr_extension (a, b) -> let a = self#extension a in let b = self#attributes b in Pstr_extension (a, b) method value_binding : value_binding -> value_binding= fun { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } -> let pvb_pat = self#pattern pvb_pat in let pvb_expr = self#expression pvb_expr in let pvb_attributes = self#attributes pvb_attributes in let pvb_loc = self#location pvb_loc in { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } method module_binding : module_binding -> module_binding= fun { pmb_name; pmb_expr; pmb_attributes; pmb_loc } -> let pmb_name = self#loc self#string pmb_name in let pmb_expr = self#module_expr pmb_expr in let pmb_attributes = self#attributes pmb_attributes in let pmb_loc = self#location pmb_loc in { pmb_name; pmb_expr; pmb_attributes; pmb_loc } method toplevel_phrase : toplevel_phrase -> toplevel_phrase= fun x -> match x with | Ptop_def a -> let a = self#structure a in Ptop_def a | Ptop_dir a -> let a = self#toplevel_directive a in Ptop_dir a method toplevel_directive : toplevel_directive -> toplevel_directive= fun { pdir_name; pdir_arg; pdir_loc } -> let pdir_name = self#loc self#string pdir_name in let pdir_arg = self#option self#directive_argument pdir_arg in let pdir_loc = self#location pdir_loc in { pdir_name; pdir_arg; pdir_loc } method directive_argument : directive_argument -> directive_argument= fun { pdira_desc; pdira_loc } -> let pdira_desc = self#directive_argument_desc pdira_desc in let pdira_loc = self#location pdira_loc in { pdira_desc; pdira_loc } method directive_argument_desc : directive_argument_desc -> directive_argument_desc= fun x -> match x with | Pdir_string a -> let a = self#string a in Pdir_string a | Pdir_int (a, b) -> let a = self#string a in let b = self#option self#char b in Pdir_int (a, b) | Pdir_ident a -> let a = self#longident a in Pdir_ident a | Pdir_bool a -> let a = self#bool a in Pdir_bool a end class virtual iter = object (self) method virtual bool : bool -> unit method virtual char : char -> unit method virtual int : int -> unit method virtual list : 'a . ('a -> unit) -> 'a list -> unit method virtual option : 'a . ('a -> unit) -> 'a option -> unit method virtual string : string -> unit method position : position -> unit= fun { pos_fname; pos_lnum; pos_bol; pos_cnum } -> self#string pos_fname; self#int pos_lnum; self#int pos_bol; self#int pos_cnum method location : location -> unit= fun { loc_start; loc_end; loc_ghost } -> self#position loc_start; self#position loc_end; self#bool loc_ghost method location_stack : location_stack -> unit= self#list self#location method loc : 'a . ('a -> unit) -> 'a loc -> unit= fun _a -> fun { txt; loc } -> _a txt; self#location loc method longident : longident -> unit= fun x -> match x with | Lident a -> self#string a | Ldot (a, b) -> (self#longident a; self#string b) | Lapply (a, b) -> (self#longident a; self#longident b) method longident_loc : longident_loc -> unit= self#loc self#longident method rec_flag : rec_flag -> unit= fun _ -> () method direction_flag : direction_flag -> unit= fun _ -> () method private_flag : private_flag -> unit= fun _ -> () method mutable_flag : mutable_flag -> unit= fun _ -> () method virtual_flag : virtual_flag -> unit= fun _ -> () method override_flag : override_flag -> unit= fun _ -> () method closed_flag : closed_flag -> unit= fun _ -> () method label : label -> unit= self#string method arg_label : arg_label -> unit= fun x -> match x with | Nolabel -> () | Labelled a -> self#string a | Optional a -> self#string a method variance : variance -> unit= fun _ -> () method constant : constant -> unit= fun x -> match x with | Pconst_integer (a, b) -> (self#string a; self#option self#char b) | Pconst_char a -> self#char a | Pconst_string (a, b) -> (self#string a; self#option self#string b) | Pconst_float (a, b) -> (self#string a; self#option self#char b) method attribute : attribute -> unit= fun { attr_name; attr_payload; attr_loc } -> self#loc self#string attr_name; self#payload attr_payload; self#location attr_loc method extension : extension -> unit= fun (a, b) -> self#loc self#string a; self#payload b method attributes : attributes -> unit= self#list self#attribute method payload : payload -> unit= fun x -> match x with | PStr a -> self#structure a | PSig a -> self#signature a | PTyp a -> self#core_type a | PPat (a, b) -> (self#pattern a; self#option self#expression b) method core_type : core_type -> unit= fun { ptyp_desc; ptyp_loc; ptyp_loc_stack; ptyp_attributes } -> self#core_type_desc ptyp_desc; self#location ptyp_loc; self#location_stack ptyp_loc_stack; self#attributes ptyp_attributes method core_type_desc : core_type_desc -> unit= fun x -> match x with | Ptyp_any -> () | Ptyp_var a -> self#string a | Ptyp_arrow (a, b, c) -> (self#arg_label a; self#core_type b; self#core_type c) | Ptyp_tuple a -> self#list self#core_type a | Ptyp_constr (a, b) -> (self#longident_loc a; self#list self#core_type b) | Ptyp_object (a, b) -> (self#list self#object_field a; self#closed_flag b) | Ptyp_class (a, b) -> (self#longident_loc a; self#list self#core_type b) | Ptyp_alias (a, b) -> (self#core_type a; self#string b) | Ptyp_variant (a, b, c) -> (self#list self#row_field a; self#closed_flag b; self#option (self#list self#label) c) | Ptyp_poly (a, b) -> (self#list (self#loc self#string) a; self#core_type b) | Ptyp_package a -> self#package_type a | Ptyp_extension a -> self#extension a method package_type : package_type -> unit= fun (a, b) -> self#longident_loc a; self#list (fun (a, b) -> self#longident_loc a; self#core_type b) b method row_field : row_field -> unit= fun { prf_desc; prf_loc; prf_attributes } -> self#row_field_desc prf_desc; self#location prf_loc; self#attributes prf_attributes method row_field_desc : row_field_desc -> unit= fun x -> match x with | Rtag (a, b, c) -> (self#loc self#label a; self#bool b; self#list self#core_type c) | Rinherit a -> self#core_type a method object_field : object_field -> unit= fun { pof_desc; pof_loc; pof_attributes } -> self#object_field_desc pof_desc; self#location pof_loc; self#attributes pof_attributes method object_field_desc : object_field_desc -> unit= fun x -> match x with | Otag (a, b) -> (self#loc self#label a; self#core_type b) | Oinherit a -> self#core_type a method pattern : pattern -> unit= fun { ppat_desc; ppat_loc; ppat_loc_stack; ppat_attributes } -> self#pattern_desc ppat_desc; self#location ppat_loc; self#location_stack ppat_loc_stack; self#attributes ppat_attributes method pattern_desc : pattern_desc -> unit= fun x -> match x with | Ppat_any -> () | Ppat_var a -> self#loc self#string a | Ppat_alias (a, b) -> (self#pattern a; self#loc self#string b) | Ppat_constant a -> self#constant a | Ppat_interval (a, b) -> (self#constant a; self#constant b) | Ppat_tuple a -> self#list self#pattern a | Ppat_construct (a, b) -> (self#longident_loc a; self#option self#pattern b) | Ppat_variant (a, b) -> (self#label a; self#option self#pattern b) | Ppat_record (a, b) -> (self#list (fun (a, b) -> self#longident_loc a; self#pattern b) a; self#closed_flag b) | Ppat_array a -> self#list self#pattern a | Ppat_or (a, b) -> (self#pattern a; self#pattern b) | Ppat_constraint (a, b) -> (self#pattern a; self#core_type b) | Ppat_type a -> self#longident_loc a | Ppat_lazy a -> self#pattern a | Ppat_unpack a -> self#loc self#string a | Ppat_exception a -> self#pattern a | Ppat_extension a -> self#extension a | Ppat_open (a, b) -> (self#longident_loc a; self#pattern b) method expression : expression -> unit= fun { pexp_desc; pexp_loc; pexp_loc_stack; pexp_attributes } -> self#expression_desc pexp_desc; self#location pexp_loc; self#location_stack pexp_loc_stack; self#attributes pexp_attributes method expression_desc : expression_desc -> unit= fun x -> match x with | Pexp_ident a -> self#longident_loc a | Pexp_constant a -> self#constant a | Pexp_let (a, b, c) -> (self#rec_flag a; self#list self#value_binding b; self#expression c) | Pexp_function a -> self#list self#case a | Pexp_fun (a, b, c, d) -> (self#arg_label a; self#option self#expression b; self#pattern c; self#expression d) | Pexp_apply (a, b) -> (self#expression a; self#list (fun (a, b) -> self#arg_label a; self#expression b) b) | Pexp_match (a, b) -> (self#expression a; self#list self#case b) | Pexp_try (a, b) -> (self#expression a; self#list self#case b) | Pexp_tuple a -> self#list self#expression a | Pexp_construct (a, b) -> (self#longident_loc a; self#option self#expression b) | Pexp_variant (a, b) -> (self#label a; self#option self#expression b) | Pexp_record (a, b) -> (self#list (fun (a, b) -> self#longident_loc a; self#expression b) a; self#option self#expression b) | Pexp_field (a, b) -> (self#expression a; self#longident_loc b) | Pexp_setfield (a, b, c) -> (self#expression a; self#longident_loc b; self#expression c) | Pexp_array a -> self#list self#expression a | Pexp_ifthenelse (a, b, c) -> (self#expression a; self#expression b; self#option self#expression c) | Pexp_sequence (a, b) -> (self#expression a; self#expression b) | Pexp_while (a, b) -> (self#expression a; self#expression b) | Pexp_for (a, b, c, d, e) -> (self#pattern a; self#expression b; self#expression c; self#direction_flag d; self#expression e) | Pexp_constraint (a, b) -> (self#expression a; self#core_type b) | Pexp_coerce (a, b, c) -> (self#expression a; self#option self#core_type b; self#core_type c) | Pexp_send (a, b) -> (self#expression a; self#loc self#label b) | Pexp_new a -> self#longident_loc a | Pexp_setinstvar (a, b) -> (self#loc self#label a; self#expression b) | Pexp_override a -> self#list (fun (a, b) -> self#loc self#label a; self#expression b) a | Pexp_letmodule (a, b, c) -> (self#loc self#string a; self#module_expr b; self#expression c) | Pexp_letexception (a, b) -> (self#extension_constructor a; self#expression b) | Pexp_assert a -> self#expression a | Pexp_lazy a -> self#expression a | Pexp_poly (a, b) -> (self#expression a; self#option self#core_type b) | Pexp_object a -> self#class_structure a | Pexp_newtype (a, b) -> (self#loc self#string a; self#expression b) | Pexp_pack a -> self#module_expr a | Pexp_open (a, b) -> (self#open_declaration a; self#expression b) | Pexp_letop a -> self#letop a | Pexp_extension a -> self#extension a | Pexp_unreachable -> () method case : case -> unit= fun { pc_lhs; pc_guard; pc_rhs } -> self#pattern pc_lhs; self#option self#expression pc_guard; self#expression pc_rhs method letop : letop -> unit= fun { let_; ands; body } -> self#binding_op let_; self#list self#binding_op ands; self#expression body method binding_op : binding_op -> unit= fun { pbop_op; pbop_pat; pbop_exp; pbop_loc } -> self#loc self#string pbop_op; self#pattern pbop_pat; self#expression pbop_exp; self#location pbop_loc method value_description : value_description -> unit= fun { pval_name; pval_type; pval_prim; pval_attributes; pval_loc } -> self#loc self#string pval_name; self#core_type pval_type; self#list self#string pval_prim; self#attributes pval_attributes; self#location pval_loc method type_declaration : type_declaration -> unit= fun { ptype_name; ptype_params; ptype_cstrs; ptype_kind; ptype_private; ptype_manifest; ptype_attributes; ptype_loc } -> self#loc self#string ptype_name; self#list (fun (a, b) -> self#core_type a; self#variance b) ptype_params; self#list (fun (a, b, c) -> self#core_type a; self#core_type b; self#location c) ptype_cstrs; self#type_kind ptype_kind; self#private_flag ptype_private; self#option self#core_type ptype_manifest; self#attributes ptype_attributes; self#location ptype_loc method type_kind : type_kind -> unit= fun x -> match x with | Ptype_abstract -> () | Ptype_variant a -> self#list self#constructor_declaration a | Ptype_record a -> self#list self#label_declaration a | Ptype_open -> () method label_declaration : label_declaration -> unit= fun { pld_name; pld_mutable; pld_type; pld_loc; pld_attributes } -> self#loc self#string pld_name; self#mutable_flag pld_mutable; self#core_type pld_type; self#location pld_loc; self#attributes pld_attributes method constructor_declaration : constructor_declaration -> unit= fun { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } -> self#loc self#string pcd_name; self#constructor_arguments pcd_args; self#option self#core_type pcd_res; self#location pcd_loc; self#attributes pcd_attributes method constructor_arguments : constructor_arguments -> unit= fun x -> match x with | Pcstr_tuple a -> self#list self#core_type a | Pcstr_record a -> self#list self#label_declaration a method type_extension : type_extension -> unit= fun { ptyext_path; ptyext_params; ptyext_constructors; ptyext_private; ptyext_loc; ptyext_attributes } -> self#longident_loc ptyext_path; self#list (fun (a, b) -> self#core_type a; self#variance b) ptyext_params; self#list self#extension_constructor ptyext_constructors; self#private_flag ptyext_private; self#location ptyext_loc; self#attributes ptyext_attributes method extension_constructor : extension_constructor -> unit= fun { pext_name; pext_kind; pext_loc; pext_attributes } -> self#loc self#string pext_name; self#extension_constructor_kind pext_kind; self#location pext_loc; self#attributes pext_attributes method type_exception : type_exception -> unit= fun { ptyexn_constructor; ptyexn_loc; ptyexn_attributes } -> self#extension_constructor ptyexn_constructor; self#location ptyexn_loc; self#attributes ptyexn_attributes method extension_constructor_kind : extension_constructor_kind -> unit= fun x -> match x with | Pext_decl (a, b) -> (self#constructor_arguments a; self#option self#core_type b) | Pext_rebind a -> self#longident_loc a method class_type : class_type -> unit= fun { pcty_desc; pcty_loc; pcty_attributes } -> self#class_type_desc pcty_desc; self#location pcty_loc; self#attributes pcty_attributes method class_type_desc : class_type_desc -> unit= fun x -> match x with | Pcty_constr (a, b) -> (self#longident_loc a; self#list self#core_type b) | Pcty_signature a -> self#class_signature a | Pcty_arrow (a, b, c) -> (self#arg_label a; self#core_type b; self#class_type c) | Pcty_extension a -> self#extension a | Pcty_open (a, b) -> (self#open_description a; self#class_type b) method class_signature : class_signature -> unit= fun { pcsig_self; pcsig_fields } -> self#core_type pcsig_self; self#list self#class_type_field pcsig_fields method class_type_field : class_type_field -> unit= fun { pctf_desc; pctf_loc; pctf_attributes } -> self#class_type_field_desc pctf_desc; self#location pctf_loc; self#attributes pctf_attributes method class_type_field_desc : class_type_field_desc -> unit= fun x -> match x with | Pctf_inherit a -> self#class_type a | Pctf_val a -> ((fun (a, b, c, d) -> self#loc self#label a; self#mutable_flag b; self#virtual_flag c; self#core_type d)) a | Pctf_method a -> ((fun (a, b, c, d) -> self#loc self#label a; self#private_flag b; self#virtual_flag c; self#core_type d)) a | Pctf_constraint a -> ((fun (a, b) -> self#core_type a; self#core_type b)) a | Pctf_attribute a -> self#attribute a | Pctf_extension a -> self#extension a method class_infos : 'a . ('a -> unit) -> 'a class_infos -> unit= fun _a -> fun { pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes } -> self#virtual_flag pci_virt; self#list (fun (a, b) -> self#core_type a; self#variance b) pci_params; self#loc self#string pci_name; _a pci_expr; self#location pci_loc; self#attributes pci_attributes method class_description : class_description -> unit= self#class_infos self#class_type method class_type_declaration : class_type_declaration -> unit= self#class_infos self#class_type method class_expr : class_expr -> unit= fun { pcl_desc; pcl_loc; pcl_attributes } -> self#class_expr_desc pcl_desc; self#location pcl_loc; self#attributes pcl_attributes method class_expr_desc : class_expr_desc -> unit= fun x -> match x with | Pcl_constr (a, b) -> (self#longident_loc a; self#list self#core_type b) | Pcl_structure a -> self#class_structure a | Pcl_fun (a, b, c, d) -> (self#arg_label a; self#option self#expression b; self#pattern c; self#class_expr d) | Pcl_apply (a, b) -> (self#class_expr a; self#list (fun (a, b) -> self#arg_label a; self#expression b) b) | Pcl_let (a, b, c) -> (self#rec_flag a; self#list self#value_binding b; self#class_expr c) | Pcl_constraint (a, b) -> (self#class_expr a; self#class_type b) | Pcl_extension a -> self#extension a | Pcl_open (a, b) -> (self#open_description a; self#class_expr b) method class_structure : class_structure -> unit= fun { pcstr_self; pcstr_fields } -> self#pattern pcstr_self; self#list self#class_field pcstr_fields method class_field : class_field -> unit= fun { pcf_desc; pcf_loc; pcf_attributes } -> self#class_field_desc pcf_desc; self#location pcf_loc; self#attributes pcf_attributes method class_field_desc : class_field_desc -> unit= fun x -> match x with | Pcf_inherit (a, b, c) -> (self#override_flag a; self#class_expr b; self#option (self#loc self#string) c) | Pcf_val a -> ((fun (a, b, c) -> self#loc self#label a; self#mutable_flag b; self#class_field_kind c)) a | Pcf_method a -> ((fun (a, b, c) -> self#loc self#label a; self#private_flag b; self#class_field_kind c)) a | Pcf_constraint a -> ((fun (a, b) -> self#core_type a; self#core_type b)) a | Pcf_initializer a -> self#expression a | Pcf_attribute a -> self#attribute a | Pcf_extension a -> self#extension a method class_field_kind : class_field_kind -> unit= fun x -> match x with | Cfk_virtual a -> self#core_type a | Cfk_concrete (a, b) -> (self#override_flag a; self#expression b) method class_declaration : class_declaration -> unit= self#class_infos self#class_expr method module_type : module_type -> unit= fun { pmty_desc; pmty_loc; pmty_attributes } -> self#module_type_desc pmty_desc; self#location pmty_loc; self#attributes pmty_attributes method module_type_desc : module_type_desc -> unit= fun x -> match x with | Pmty_ident a -> self#longident_loc a | Pmty_signature a -> self#signature a | Pmty_functor (a, b, c) -> (self#loc self#string a; self#option self#module_type b; self#module_type c) | Pmty_with (a, b) -> (self#module_type a; self#list self#with_constraint b) | Pmty_typeof a -> self#module_expr a | Pmty_extension a -> self#extension a | Pmty_alias a -> self#longident_loc a method signature : signature -> unit= self#list self#signature_item method signature_item : signature_item -> unit= fun { psig_desc; psig_loc } -> self#signature_item_desc psig_desc; self#location psig_loc method signature_item_desc : signature_item_desc -> unit= fun x -> match x with | Psig_value a -> self#value_description a | Psig_type (a, b) -> (self#rec_flag a; self#list self#type_declaration b) | Psig_typesubst a -> self#list self#type_declaration a | Psig_typext a -> self#type_extension a | Psig_exception a -> self#type_exception a | Psig_module a -> self#module_declaration a | Psig_modsubst a -> self#module_substitution a | Psig_recmodule a -> self#list self#module_declaration a | Psig_modtype a -> self#module_type_declaration a | Psig_open a -> self#open_description a | Psig_include a -> self#include_description a | Psig_class a -> self#list self#class_description a | Psig_class_type a -> self#list self#class_type_declaration a | Psig_attribute a -> self#attribute a | Psig_extension (a, b) -> (self#extension a; self#attributes b) method module_declaration : module_declaration -> unit= fun { pmd_name; pmd_type; pmd_attributes; pmd_loc } -> self#loc self#string pmd_name; self#module_type pmd_type; self#attributes pmd_attributes; self#location pmd_loc method module_substitution : module_substitution -> unit= fun { pms_name; pms_manifest; pms_attributes; pms_loc } -> self#loc self#string pms_name; self#longident_loc pms_manifest; self#attributes pms_attributes; self#location pms_loc method module_type_declaration : module_type_declaration -> unit= fun { pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc } -> self#loc self#string pmtd_name; self#option self#module_type pmtd_type; self#attributes pmtd_attributes; self#location pmtd_loc method open_infos : 'a . ('a -> unit) -> 'a open_infos -> unit= fun _a -> fun { popen_expr; popen_override; popen_loc; popen_attributes } -> _a popen_expr; self#override_flag popen_override; self#location popen_loc; self#attributes popen_attributes method open_description : open_description -> unit= self#open_infos self#longident_loc method open_declaration : open_declaration -> unit= self#open_infos self#module_expr method include_infos : 'a . ('a -> unit) -> 'a include_infos -> unit= fun _a -> fun { pincl_mod; pincl_loc; pincl_attributes } -> _a pincl_mod; self#location pincl_loc; self#attributes pincl_attributes method include_description : include_description -> unit= self#include_infos self#module_type method include_declaration : include_declaration -> unit= self#include_infos self#module_expr method with_constraint : with_constraint -> unit= fun x -> match x with | Pwith_type (a, b) -> (self#longident_loc a; self#type_declaration b) | Pwith_module (a, b) -> (self#longident_loc a; self#longident_loc b) | Pwith_typesubst (a, b) -> (self#longident_loc a; self#type_declaration b) | Pwith_modsubst (a, b) -> (self#longident_loc a; self#longident_loc b) method module_expr : module_expr -> unit= fun { pmod_desc; pmod_loc; pmod_attributes } -> self#module_expr_desc pmod_desc; self#location pmod_loc; self#attributes pmod_attributes method module_expr_desc : module_expr_desc -> unit= fun x -> match x with | Pmod_ident a -> self#longident_loc a | Pmod_structure a -> self#structure a | Pmod_functor (a, b, c) -> (self#loc self#string a; self#option self#module_type b; self#module_expr c) | Pmod_apply (a, b) -> (self#module_expr a; self#module_expr b) | Pmod_constraint (a, b) -> (self#module_expr a; self#module_type b) | Pmod_unpack a -> self#expression a | Pmod_extension a -> self#extension a method structure : structure -> unit= self#list self#structure_item method structure_item : structure_item -> unit= fun { pstr_desc; pstr_loc } -> self#structure_item_desc pstr_desc; self#location pstr_loc method structure_item_desc : structure_item_desc -> unit= fun x -> match x with | Pstr_eval (a, b) -> (self#expression a; self#attributes b) | Pstr_value (a, b) -> (self#rec_flag a; self#list self#value_binding b) | Pstr_primitive a -> self#value_description a | Pstr_type (a, b) -> (self#rec_flag a; self#list self#type_declaration b) | Pstr_typext a -> self#type_extension a | Pstr_exception a -> self#type_exception a | Pstr_module a -> self#module_binding a | Pstr_recmodule a -> self#list self#module_binding a | Pstr_modtype a -> self#module_type_declaration a | Pstr_open a -> self#open_declaration a | Pstr_class a -> self#list self#class_declaration a | Pstr_class_type a -> self#list self#class_type_declaration a | Pstr_include a -> self#include_declaration a | Pstr_attribute a -> self#attribute a | Pstr_extension (a, b) -> (self#extension a; self#attributes b) method value_binding : value_binding -> unit= fun { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } -> self#pattern pvb_pat; self#expression pvb_expr; self#attributes pvb_attributes; self#location pvb_loc method module_binding : module_binding -> unit= fun { pmb_name; pmb_expr; pmb_attributes; pmb_loc } -> self#loc self#string pmb_name; self#module_expr pmb_expr; self#attributes pmb_attributes; self#location pmb_loc method toplevel_phrase : toplevel_phrase -> unit= fun x -> match x with | Ptop_def a -> self#structure a | Ptop_dir a -> self#toplevel_directive a method toplevel_directive : toplevel_directive -> unit= fun { pdir_name; pdir_arg; pdir_loc } -> self#loc self#string pdir_name; self#option self#directive_argument pdir_arg; self#location pdir_loc method directive_argument : directive_argument -> unit= fun { pdira_desc; pdira_loc } -> self#directive_argument_desc pdira_desc; self#location pdira_loc method directive_argument_desc : directive_argument_desc -> unit= fun x -> match x with | Pdir_string a -> self#string a | Pdir_int (a, b) -> (self#string a; self#option self#char b) | Pdir_ident a -> self#longident a | Pdir_bool a -> self#bool a end class virtual ['acc] fold = object (self) method virtual bool : bool -> 'acc -> 'acc method virtual char : char -> 'acc -> 'acc method virtual int : int -> 'acc -> 'acc method virtual list : 'a . ('a -> 'acc -> 'acc) -> 'a list -> 'acc -> 'acc method virtual option : 'a . ('a -> 'acc -> 'acc) -> 'a option -> 'acc -> 'acc method virtual string : string -> 'acc -> 'acc method position : position -> 'acc -> 'acc= fun { pos_fname; pos_lnum; pos_bol; pos_cnum } -> fun acc -> let acc = self#string pos_fname acc in let acc = self#int pos_lnum acc in let acc = self#int pos_bol acc in let acc = self#int pos_cnum acc in acc method location : location -> 'acc -> 'acc= fun { loc_start; loc_end; loc_ghost } -> fun acc -> let acc = self#position loc_start acc in let acc = self#position loc_end acc in let acc = self#bool loc_ghost acc in acc method location_stack : location_stack -> 'acc -> 'acc= self#list self#location method loc : 'a . ('a -> 'acc -> 'acc) -> 'a loc -> 'acc -> 'acc= fun _a -> fun { txt; loc } -> fun acc -> let acc = _a txt acc in let acc = self#location loc acc in acc method longident : longident -> 'acc -> 'acc= fun x -> fun acc -> match x with | Lident a -> self#string a acc | Ldot (a, b) -> let acc = self#longident a acc in let acc = self#string b acc in acc | Lapply (a, b) -> let acc = self#longident a acc in let acc = self#longident b acc in acc method longident_loc : longident_loc -> 'acc -> 'acc= self#loc self#longident method rec_flag : rec_flag -> 'acc -> 'acc= fun _ -> fun acc -> acc method direction_flag : direction_flag -> 'acc -> 'acc= fun _ -> fun acc -> acc method private_flag : private_flag -> 'acc -> 'acc= fun _ -> fun acc -> acc method mutable_flag : mutable_flag -> 'acc -> 'acc= fun _ -> fun acc -> acc method virtual_flag : virtual_flag -> 'acc -> 'acc= fun _ -> fun acc -> acc method override_flag : override_flag -> 'acc -> 'acc= fun _ -> fun acc -> acc method closed_flag : closed_flag -> 'acc -> 'acc= fun _ -> fun acc -> acc method label : label -> 'acc -> 'acc= self#string method arg_label : arg_label -> 'acc -> 'acc= fun x -> fun acc -> match x with | Nolabel -> acc | Labelled a -> self#string a acc | Optional a -> self#string a acc method variance : variance -> 'acc -> 'acc= fun _ -> fun acc -> acc method constant : constant -> 'acc -> 'acc= fun x -> fun acc -> match x with | Pconst_integer (a, b) -> let acc = self#string a acc in let acc = self#option self#char b acc in acc | Pconst_char a -> self#char a acc | Pconst_string (a, b) -> let acc = self#string a acc in let acc = self#option self#string b acc in acc | Pconst_float (a, b) -> let acc = self#string a acc in let acc = self#option self#char b acc in acc method attribute : attribute -> 'acc -> 'acc= fun { attr_name; attr_payload; attr_loc } -> fun acc -> let acc = self#loc self#string attr_name acc in let acc = self#payload attr_payload acc in let acc = self#location attr_loc acc in acc method extension : extension -> 'acc -> 'acc= fun (a, b) -> fun acc -> let acc = self#loc self#string a acc in let acc = self#payload b acc in acc method attributes : attributes -> 'acc -> 'acc= self#list self#attribute method payload : payload -> 'acc -> 'acc= fun x -> fun acc -> match x with | PStr a -> self#structure a acc | PSig a -> self#signature a acc | PTyp a -> self#core_type a acc | PPat (a, b) -> let acc = self#pattern a acc in let acc = self#option self#expression b acc in acc method core_type : core_type -> 'acc -> 'acc= fun { ptyp_desc; ptyp_loc; ptyp_loc_stack; ptyp_attributes } -> fun acc -> let acc = self#core_type_desc ptyp_desc acc in let acc = self#location ptyp_loc acc in let acc = self#location_stack ptyp_loc_stack acc in let acc = self#attributes ptyp_attributes acc in acc method core_type_desc : core_type_desc -> 'acc -> 'acc= fun x -> fun acc -> match x with | Ptyp_any -> acc | Ptyp_var a -> self#string a acc | Ptyp_arrow (a, b, c) -> let acc = self#arg_label a acc in let acc = self#core_type b acc in let acc = self#core_type c acc in acc | Ptyp_tuple a -> self#list self#core_type a acc | Ptyp_constr (a, b) -> let acc = self#longident_loc a acc in let acc = self#list self#core_type b acc in acc | Ptyp_object (a, b) -> let acc = self#list self#object_field a acc in let acc = self#closed_flag b acc in acc | Ptyp_class (a, b) -> let acc = self#longident_loc a acc in let acc = self#list self#core_type b acc in acc | Ptyp_alias (a, b) -> let acc = self#core_type a acc in let acc = self#string b acc in acc | Ptyp_variant (a, b, c) -> let acc = self#list self#row_field a acc in let acc = self#closed_flag b acc in let acc = self#option (self#list self#label) c acc in acc | Ptyp_poly (a, b) -> let acc = self#list (self#loc self#string) a acc in let acc = self#core_type b acc in acc | Ptyp_package a -> self#package_type a acc | Ptyp_extension a -> self#extension a acc method package_type : package_type -> 'acc -> 'acc= fun (a, b) -> fun acc -> let acc = self#longident_loc a acc in let acc = self#list (fun (a, b) -> fun acc -> let acc = self#longident_loc a acc in let acc = self#core_type b acc in acc) b acc in acc method row_field : row_field -> 'acc -> 'acc= fun { prf_desc; prf_loc; prf_attributes } -> fun acc -> let acc = self#row_field_desc prf_desc acc in let acc = self#location prf_loc acc in let acc = self#attributes prf_attributes acc in acc method row_field_desc : row_field_desc -> 'acc -> 'acc= fun x -> fun acc -> match x with | Rtag (a, b, c) -> let acc = self#loc self#label a acc in let acc = self#bool b acc in let acc = self#list self#core_type c acc in acc | Rinherit a -> self#core_type a acc method object_field : object_field -> 'acc -> 'acc= fun { pof_desc; pof_loc; pof_attributes } -> fun acc -> let acc = self#object_field_desc pof_desc acc in let acc = self#location pof_loc acc in let acc = self#attributes pof_attributes acc in acc method object_field_desc : object_field_desc -> 'acc -> 'acc= fun x -> fun acc -> match x with | Otag (a, b) -> let acc = self#loc self#label a acc in let acc = self#core_type b acc in acc | Oinherit a -> self#core_type a acc method pattern : pattern -> 'acc -> 'acc= fun { ppat_desc; ppat_loc; ppat_loc_stack; ppat_attributes } -> fun acc -> let acc = self#pattern_desc ppat_desc acc in let acc = self#location ppat_loc acc in let acc = self#location_stack ppat_loc_stack acc in let acc = self#attributes ppat_attributes acc in acc method pattern_desc : pattern_desc -> 'acc -> 'acc= fun x -> fun acc -> match x with | Ppat_any -> acc | Ppat_var a -> self#loc self#string a acc | Ppat_alias (a, b) -> let acc = self#pattern a acc in let acc = self#loc self#string b acc in acc | Ppat_constant a -> self#constant a acc | Ppat_interval (a, b) -> let acc = self#constant a acc in let acc = self#constant b acc in acc | Ppat_tuple a -> self#list self#pattern a acc | Ppat_construct (a, b) -> let acc = self#longident_loc a acc in let acc = self#option self#pattern b acc in acc | Ppat_variant (a, b) -> let acc = self#label a acc in let acc = self#option self#pattern b acc in acc | Ppat_record (a, b) -> let acc = self#list (fun (a, b) -> fun acc -> let acc = self#longident_loc a acc in let acc = self#pattern b acc in acc) a acc in let acc = self#closed_flag b acc in acc | Ppat_array a -> self#list self#pattern a acc | Ppat_or (a, b) -> let acc = self#pattern a acc in let acc = self#pattern b acc in acc | Ppat_constraint (a, b) -> let acc = self#pattern a acc in let acc = self#core_type b acc in acc | Ppat_type a -> self#longident_loc a acc | Ppat_lazy a -> self#pattern a acc | Ppat_unpack a -> self#loc self#string a acc | Ppat_exception a -> self#pattern a acc | Ppat_extension a -> self#extension a acc | Ppat_open (a, b) -> let acc = self#longident_loc a acc in let acc = self#pattern b acc in acc method expression : expression -> 'acc -> 'acc= fun { pexp_desc; pexp_loc; pexp_loc_stack; pexp_attributes } -> fun acc -> let acc = self#expression_desc pexp_desc acc in let acc = self#location pexp_loc acc in let acc = self#location_stack pexp_loc_stack acc in let acc = self#attributes pexp_attributes acc in acc method expression_desc : expression_desc -> 'acc -> 'acc= fun x -> fun acc -> match x with | Pexp_ident a -> self#longident_loc a acc | Pexp_constant a -> self#constant a acc | Pexp_let (a, b, c) -> let acc = self#rec_flag a acc in let acc = self#list self#value_binding b acc in let acc = self#expression c acc in acc | Pexp_function a -> self#list self#case a acc | Pexp_fun (a, b, c, d) -> let acc = self#arg_label a acc in let acc = self#option self#expression b acc in let acc = self#pattern c acc in let acc = self#expression d acc in acc | Pexp_apply (a, b) -> let acc = self#expression a acc in let acc = self#list (fun (a, b) -> fun acc -> let acc = self#arg_label a acc in let acc = self#expression b acc in acc) b acc in acc | Pexp_match (a, b) -> let acc = self#expression a acc in let acc = self#list self#case b acc in acc | Pexp_try (a, b) -> let acc = self#expression a acc in let acc = self#list self#case b acc in acc | Pexp_tuple a -> self#list self#expression a acc | Pexp_construct (a, b) -> let acc = self#longident_loc a acc in let acc = self#option self#expression b acc in acc | Pexp_variant (a, b) -> let acc = self#label a acc in let acc = self#option self#expression b acc in acc | Pexp_record (a, b) -> let acc = self#list (fun (a, b) -> fun acc -> let acc = self#longident_loc a acc in let acc = self#expression b acc in acc) a acc in let acc = self#option self#expression b acc in acc | Pexp_field (a, b) -> let acc = self#expression a acc in let acc = self#longident_loc b acc in acc | Pexp_setfield (a, b, c) -> let acc = self#expression a acc in let acc = self#longident_loc b acc in let acc = self#expression c acc in acc | Pexp_array a -> self#list self#expression a acc | Pexp_ifthenelse (a, b, c) -> let acc = self#expression a acc in let acc = self#expression b acc in let acc = self#option self#expression c acc in acc | Pexp_sequence (a, b) -> let acc = self#expression a acc in let acc = self#expression b acc in acc | Pexp_while (a, b) -> let acc = self#expression a acc in let acc = self#expression b acc in acc | Pexp_for (a, b, c, d, e) -> let acc = self#pattern a acc in let acc = self#expression b acc in let acc = self#expression c acc in let acc = self#direction_flag d acc in let acc = self#expression e acc in acc | Pexp_constraint (a, b) -> let acc = self#expression a acc in let acc = self#core_type b acc in acc | Pexp_coerce (a, b, c) -> let acc = self#expression a acc in let acc = self#option self#core_type b acc in let acc = self#core_type c acc in acc | Pexp_send (a, b) -> let acc = self#expression a acc in let acc = self#loc self#label b acc in acc | Pexp_new a -> self#longident_loc a acc | Pexp_setinstvar (a, b) -> let acc = self#loc self#label a acc in let acc = self#expression b acc in acc | Pexp_override a -> self#list (fun (a, b) -> fun acc -> let acc = self#loc self#label a acc in let acc = self#expression b acc in acc) a acc | Pexp_letmodule (a, b, c) -> let acc = self#loc self#string a acc in let acc = self#module_expr b acc in let acc = self#expression c acc in acc | Pexp_letexception (a, b) -> let acc = self#extension_constructor a acc in let acc = self#expression b acc in acc | Pexp_assert a -> self#expression a acc | Pexp_lazy a -> self#expression a acc | Pexp_poly (a, b) -> let acc = self#expression a acc in let acc = self#option self#core_type b acc in acc | Pexp_object a -> self#class_structure a acc | Pexp_newtype (a, b) -> let acc = self#loc self#string a acc in let acc = self#expression b acc in acc | Pexp_pack a -> self#module_expr a acc | Pexp_open (a, b) -> let acc = self#open_declaration a acc in let acc = self#expression b acc in acc | Pexp_letop a -> self#letop a acc | Pexp_extension a -> self#extension a acc | Pexp_unreachable -> acc method case : case -> 'acc -> 'acc= fun { pc_lhs; pc_guard; pc_rhs } -> fun acc -> let acc = self#pattern pc_lhs acc in let acc = self#option self#expression pc_guard acc in let acc = self#expression pc_rhs acc in acc method letop : letop -> 'acc -> 'acc= fun { let_; ands; body } -> fun acc -> let acc = self#binding_op let_ acc in let acc = self#list self#binding_op ands acc in let acc = self#expression body acc in acc method binding_op : binding_op -> 'acc -> 'acc= fun { pbop_op; pbop_pat; pbop_exp; pbop_loc } -> fun acc -> let acc = self#loc self#string pbop_op acc in let acc = self#pattern pbop_pat acc in let acc = self#expression pbop_exp acc in let acc = self#location pbop_loc acc in acc method value_description : value_description -> 'acc -> 'acc= fun { pval_name; pval_type; pval_prim; pval_attributes; pval_loc } -> fun acc -> let acc = self#loc self#string pval_name acc in let acc = self#core_type pval_type acc in let acc = self#list self#string pval_prim acc in let acc = self#attributes pval_attributes acc in let acc = self#location pval_loc acc in acc method type_declaration : type_declaration -> 'acc -> 'acc= fun { ptype_name; ptype_params; ptype_cstrs; ptype_kind; ptype_private; ptype_manifest; ptype_attributes; ptype_loc } -> fun acc -> let acc = self#loc self#string ptype_name acc in let acc = self#list (fun (a, b) -> fun acc -> let acc = self#core_type a acc in let acc = self#variance b acc in acc) ptype_params acc in let acc = self#list (fun (a, b, c) -> fun acc -> let acc = self#core_type a acc in let acc = self#core_type b acc in let acc = self#location c acc in acc) ptype_cstrs acc in let acc = self#type_kind ptype_kind acc in let acc = self#private_flag ptype_private acc in let acc = self#option self#core_type ptype_manifest acc in let acc = self#attributes ptype_attributes acc in let acc = self#location ptype_loc acc in acc method type_kind : type_kind -> 'acc -> 'acc= fun x -> fun acc -> match x with | Ptype_abstract -> acc | Ptype_variant a -> self#list self#constructor_declaration a acc | Ptype_record a -> self#list self#label_declaration a acc | Ptype_open -> acc method label_declaration : label_declaration -> 'acc -> 'acc= fun { pld_name; pld_mutable; pld_type; pld_loc; pld_attributes } -> fun acc -> let acc = self#loc self#string pld_name acc in let acc = self#mutable_flag pld_mutable acc in let acc = self#core_type pld_type acc in let acc = self#location pld_loc acc in let acc = self#attributes pld_attributes acc in acc method constructor_declaration : constructor_declaration -> 'acc -> 'acc= fun { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } -> fun acc -> let acc = self#loc self#string pcd_name acc in let acc = self#constructor_arguments pcd_args acc in let acc = self#option self#core_type pcd_res acc in let acc = self#location pcd_loc acc in let acc = self#attributes pcd_attributes acc in acc method constructor_arguments : constructor_arguments -> 'acc -> 'acc= fun x -> fun acc -> match x with | Pcstr_tuple a -> self#list self#core_type a acc | Pcstr_record a -> self#list self#label_declaration a acc method type_extension : type_extension -> 'acc -> 'acc= fun { ptyext_path; ptyext_params; ptyext_constructors; ptyext_private; ptyext_loc; ptyext_attributes } -> fun acc -> let acc = self#longident_loc ptyext_path acc in let acc = self#list (fun (a, b) -> fun acc -> let acc = self#core_type a acc in let acc = self#variance b acc in acc) ptyext_params acc in let acc = self#list self#extension_constructor ptyext_constructors acc in let acc = self#private_flag ptyext_private acc in let acc = self#location ptyext_loc acc in let acc = self#attributes ptyext_attributes acc in acc method extension_constructor : extension_constructor -> 'acc -> 'acc= fun { pext_name; pext_kind; pext_loc; pext_attributes } -> fun acc -> let acc = self#loc self#string pext_name acc in let acc = self#extension_constructor_kind pext_kind acc in let acc = self#location pext_loc acc in let acc = self#attributes pext_attributes acc in acc method type_exception : type_exception -> 'acc -> 'acc= fun { ptyexn_constructor; ptyexn_loc; ptyexn_attributes } -> fun acc -> let acc = self#extension_constructor ptyexn_constructor acc in let acc = self#location ptyexn_loc acc in let acc = self#attributes ptyexn_attributes acc in acc method extension_constructor_kind : extension_constructor_kind -> 'acc -> 'acc= fun x -> fun acc -> match x with | Pext_decl (a, b) -> let acc = self#constructor_arguments a acc in let acc = self#option self#core_type b acc in acc | Pext_rebind a -> self#longident_loc a acc method class_type : class_type -> 'acc -> 'acc= fun { pcty_desc; pcty_loc; pcty_attributes } -> fun acc -> let acc = self#class_type_desc pcty_desc acc in let acc = self#location pcty_loc acc in let acc = self#attributes pcty_attributes acc in acc method class_type_desc : class_type_desc -> 'acc -> 'acc= fun x -> fun acc -> match x with | Pcty_constr (a, b) -> let acc = self#longident_loc a acc in let acc = self#list self#core_type b acc in acc | Pcty_signature a -> self#class_signature a acc | Pcty_arrow (a, b, c) -> let acc = self#arg_label a acc in let acc = self#core_type b acc in let acc = self#class_type c acc in acc | Pcty_extension a -> self#extension a acc | Pcty_open (a, b) -> let acc = self#open_description a acc in let acc = self#class_type b acc in acc method class_signature : class_signature -> 'acc -> 'acc= fun { pcsig_self; pcsig_fields } -> fun acc -> let acc = self#core_type pcsig_self acc in let acc = self#list self#class_type_field pcsig_fields acc in acc method class_type_field : class_type_field -> 'acc -> 'acc= fun { pctf_desc; pctf_loc; pctf_attributes } -> fun acc -> let acc = self#class_type_field_desc pctf_desc acc in let acc = self#location pctf_loc acc in let acc = self#attributes pctf_attributes acc in acc method class_type_field_desc : class_type_field_desc -> 'acc -> 'acc= fun x -> fun acc -> match x with | Pctf_inherit a -> self#class_type a acc | Pctf_val a -> ((fun (a, b, c, d) -> fun acc -> let acc = self#loc self#label a acc in let acc = self#mutable_flag b acc in let acc = self#virtual_flag c acc in let acc = self#core_type d acc in acc)) a acc | Pctf_method a -> ((fun (a, b, c, d) -> fun acc -> let acc = self#loc self#label a acc in let acc = self#private_flag b acc in let acc = self#virtual_flag c acc in let acc = self#core_type d acc in acc)) a acc | Pctf_constraint a -> ((fun (a, b) -> fun acc -> let acc = self#core_type a acc in let acc = self#core_type b acc in acc)) a acc | Pctf_attribute a -> self#attribute a acc | Pctf_extension a -> self#extension a acc method class_infos : 'a . ('a -> 'acc -> 'acc) -> 'a class_infos -> 'acc -> 'acc= fun _a -> fun { pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes } -> fun acc -> let acc = self#virtual_flag pci_virt acc in let acc = self#list (fun (a, b) -> fun acc -> let acc = self#core_type a acc in let acc = self#variance b acc in acc) pci_params acc in let acc = self#loc self#string pci_name acc in let acc = _a pci_expr acc in let acc = self#location pci_loc acc in let acc = self#attributes pci_attributes acc in acc method class_description : class_description -> 'acc -> 'acc= self#class_infos self#class_type method class_type_declaration : class_type_declaration -> 'acc -> 'acc= self#class_infos self#class_type method class_expr : class_expr -> 'acc -> 'acc= fun { pcl_desc; pcl_loc; pcl_attributes } -> fun acc -> let acc = self#class_expr_desc pcl_desc acc in let acc = self#location pcl_loc acc in let acc = self#attributes pcl_attributes acc in acc method class_expr_desc : class_expr_desc -> 'acc -> 'acc= fun x -> fun acc -> match x with | Pcl_constr (a, b) -> let acc = self#longident_loc a acc in let acc = self#list self#core_type b acc in acc | Pcl_structure a -> self#class_structure a acc | Pcl_fun (a, b, c, d) -> let acc = self#arg_label a acc in let acc = self#option self#expression b acc in let acc = self#pattern c acc in let acc = self#class_expr d acc in acc | Pcl_apply (a, b) -> let acc = self#class_expr a acc in let acc = self#list (fun (a, b) -> fun acc -> let acc = self#arg_label a acc in let acc = self#expression b acc in acc) b acc in acc | Pcl_let (a, b, c) -> let acc = self#rec_flag a acc in let acc = self#list self#value_binding b acc in let acc = self#class_expr c acc in acc | Pcl_constraint (a, b) -> let acc = self#class_expr a acc in let acc = self#class_type b acc in acc | Pcl_extension a -> self#extension a acc | Pcl_open (a, b) -> let acc = self#open_description a acc in let acc = self#class_expr b acc in acc method class_structure : class_structure -> 'acc -> 'acc= fun { pcstr_self; pcstr_fields } -> fun acc -> let acc = self#pattern pcstr_self acc in let acc = self#list self#class_field pcstr_fields acc in acc method class_field : class_field -> 'acc -> 'acc= fun { pcf_desc; pcf_loc; pcf_attributes } -> fun acc -> let acc = self#class_field_desc pcf_desc acc in let acc = self#location pcf_loc acc in let acc = self#attributes pcf_attributes acc in acc method class_field_desc : class_field_desc -> 'acc -> 'acc= fun x -> fun acc -> match x with | Pcf_inherit (a, b, c) -> let acc = self#override_flag a acc in let acc = self#class_expr b acc in let acc = self#option (self#loc self#string) c acc in acc | Pcf_val a -> ((fun (a, b, c) -> fun acc -> let acc = self#loc self#label a acc in let acc = self#mutable_flag b acc in let acc = self#class_field_kind c acc in acc)) a acc | Pcf_method a -> ((fun (a, b, c) -> fun acc -> let acc = self#loc self#label a acc in let acc = self#private_flag b acc in let acc = self#class_field_kind c acc in acc)) a acc | Pcf_constraint a -> ((fun (a, b) -> fun acc -> let acc = self#core_type a acc in let acc = self#core_type b acc in acc)) a acc | Pcf_initializer a -> self#expression a acc | Pcf_attribute a -> self#attribute a acc | Pcf_extension a -> self#extension a acc method class_field_kind : class_field_kind -> 'acc -> 'acc= fun x -> fun acc -> match x with | Cfk_virtual a -> self#core_type a acc | Cfk_concrete (a, b) -> let acc = self#override_flag a acc in let acc = self#expression b acc in acc method class_declaration : class_declaration -> 'acc -> 'acc= self#class_infos self#class_expr method module_type : module_type -> 'acc -> 'acc= fun { pmty_desc; pmty_loc; pmty_attributes } -> fun acc -> let acc = self#module_type_desc pmty_desc acc in let acc = self#location pmty_loc acc in let acc = self#attributes pmty_attributes acc in acc method module_type_desc : module_type_desc -> 'acc -> 'acc= fun x -> fun acc -> match x with | Pmty_ident a -> self#longident_loc a acc | Pmty_signature a -> self#signature a acc | Pmty_functor (a, b, c) -> let acc = self#loc self#string a acc in let acc = self#option self#module_type b acc in let acc = self#module_type c acc in acc | Pmty_with (a, b) -> let acc = self#module_type a acc in let acc = self#list self#with_constraint b acc in acc | Pmty_typeof a -> self#module_expr a acc | Pmty_extension a -> self#extension a acc | Pmty_alias a -> self#longident_loc a acc method signature : signature -> 'acc -> 'acc= self#list self#signature_item method signature_item : signature_item -> 'acc -> 'acc= fun { psig_desc; psig_loc } -> fun acc -> let acc = self#signature_item_desc psig_desc acc in let acc = self#location psig_loc acc in acc method signature_item_desc : signature_item_desc -> 'acc -> 'acc= fun x -> fun acc -> match x with | Psig_value a -> self#value_description a acc | Psig_type (a, b) -> let acc = self#rec_flag a acc in let acc = self#list self#type_declaration b acc in acc | Psig_typesubst a -> self#list self#type_declaration a acc | Psig_typext a -> self#type_extension a acc | Psig_exception a -> self#type_exception a acc | Psig_module a -> self#module_declaration a acc | Psig_modsubst a -> self#module_substitution a acc | Psig_recmodule a -> self#list self#module_declaration a acc | Psig_modtype a -> self#module_type_declaration a acc | Psig_open a -> self#open_description a acc | Psig_include a -> self#include_description a acc | Psig_class a -> self#list self#class_description a acc | Psig_class_type a -> self#list self#class_type_declaration a acc | Psig_attribute a -> self#attribute a acc | Psig_extension (a, b) -> let acc = self#extension a acc in let acc = self#attributes b acc in acc method module_declaration : module_declaration -> 'acc -> 'acc= fun { pmd_name; pmd_type; pmd_attributes; pmd_loc } -> fun acc -> let acc = self#loc self#string pmd_name acc in let acc = self#module_type pmd_type acc in let acc = self#attributes pmd_attributes acc in let acc = self#location pmd_loc acc in acc method module_substitution : module_substitution -> 'acc -> 'acc= fun { pms_name; pms_manifest; pms_attributes; pms_loc } -> fun acc -> let acc = self#loc self#string pms_name acc in let acc = self#longident_loc pms_manifest acc in let acc = self#attributes pms_attributes acc in let acc = self#location pms_loc acc in acc method module_type_declaration : module_type_declaration -> 'acc -> 'acc= fun { pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc } -> fun acc -> let acc = self#loc self#string pmtd_name acc in let acc = self#option self#module_type pmtd_type acc in let acc = self#attributes pmtd_attributes acc in let acc = self#location pmtd_loc acc in acc method open_infos : 'a . ('a -> 'acc -> 'acc) -> 'a open_infos -> 'acc -> 'acc= fun _a -> fun { popen_expr; popen_override; popen_loc; popen_attributes } -> fun acc -> let acc = _a popen_expr acc in let acc = self#override_flag popen_override acc in let acc = self#location popen_loc acc in let acc = self#attributes popen_attributes acc in acc method open_description : open_description -> 'acc -> 'acc= self#open_infos self#longident_loc method open_declaration : open_declaration -> 'acc -> 'acc= self#open_infos self#module_expr method include_infos : 'a . ('a -> 'acc -> 'acc) -> 'a include_infos -> 'acc -> 'acc= fun _a -> fun { pincl_mod; pincl_loc; pincl_attributes } -> fun acc -> let acc = _a pincl_mod acc in let acc = self#location pincl_loc acc in let acc = self#attributes pincl_attributes acc in acc method include_description : include_description -> 'acc -> 'acc= self#include_infos self#module_type method include_declaration : include_declaration -> 'acc -> 'acc= self#include_infos self#module_expr method with_constraint : with_constraint -> 'acc -> 'acc= fun x -> fun acc -> match x with | Pwith_type (a, b) -> let acc = self#longident_loc a acc in let acc = self#type_declaration b acc in acc | Pwith_module (a, b) -> let acc = self#longident_loc a acc in let acc = self#longident_loc b acc in acc | Pwith_typesubst (a, b) -> let acc = self#longident_loc a acc in let acc = self#type_declaration b acc in acc | Pwith_modsubst (a, b) -> let acc = self#longident_loc a acc in let acc = self#longident_loc b acc in acc method module_expr : module_expr -> 'acc -> 'acc= fun { pmod_desc; pmod_loc; pmod_attributes } -> fun acc -> let acc = self#module_expr_desc pmod_desc acc in let acc = self#location pmod_loc acc in let acc = self#attributes pmod_attributes acc in acc method module_expr_desc : module_expr_desc -> 'acc -> 'acc= fun x -> fun acc -> match x with | Pmod_ident a -> self#longident_loc a acc | Pmod_structure a -> self#structure a acc | Pmod_functor (a, b, c) -> let acc = self#loc self#string a acc in let acc = self#option self#module_type b acc in let acc = self#module_expr c acc in acc | Pmod_apply (a, b) -> let acc = self#module_expr a acc in let acc = self#module_expr b acc in acc | Pmod_constraint (a, b) -> let acc = self#module_expr a acc in let acc = self#module_type b acc in acc | Pmod_unpack a -> self#expression a acc | Pmod_extension a -> self#extension a acc method structure : structure -> 'acc -> 'acc= self#list self#structure_item method structure_item : structure_item -> 'acc -> 'acc= fun { pstr_desc; pstr_loc } -> fun acc -> let acc = self#structure_item_desc pstr_desc acc in let acc = self#location pstr_loc acc in acc method structure_item_desc : structure_item_desc -> 'acc -> 'acc= fun x -> fun acc -> match x with | Pstr_eval (a, b) -> let acc = self#expression a acc in let acc = self#attributes b acc in acc | Pstr_value (a, b) -> let acc = self#rec_flag a acc in let acc = self#list self#value_binding b acc in acc | Pstr_primitive a -> self#value_description a acc | Pstr_type (a, b) -> let acc = self#rec_flag a acc in let acc = self#list self#type_declaration b acc in acc | Pstr_typext a -> self#type_extension a acc | Pstr_exception a -> self#type_exception a acc | Pstr_module a -> self#module_binding a acc | Pstr_recmodule a -> self#list self#module_binding a acc | Pstr_modtype a -> self#module_type_declaration a acc | Pstr_open a -> self#open_declaration a acc | Pstr_class a -> self#list self#class_declaration a acc | Pstr_class_type a -> self#list self#class_type_declaration a acc | Pstr_include a -> self#include_declaration a acc | Pstr_attribute a -> self#attribute a acc | Pstr_extension (a, b) -> let acc = self#extension a acc in let acc = self#attributes b acc in acc method value_binding : value_binding -> 'acc -> 'acc= fun { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } -> fun acc -> let acc = self#pattern pvb_pat acc in let acc = self#expression pvb_expr acc in let acc = self#attributes pvb_attributes acc in let acc = self#location pvb_loc acc in acc method module_binding : module_binding -> 'acc -> 'acc= fun { pmb_name; pmb_expr; pmb_attributes; pmb_loc } -> fun acc -> let acc = self#loc self#string pmb_name acc in let acc = self#module_expr pmb_expr acc in let acc = self#attributes pmb_attributes acc in let acc = self#location pmb_loc acc in acc method toplevel_phrase : toplevel_phrase -> 'acc -> 'acc= fun x -> fun acc -> match x with | Ptop_def a -> self#structure a acc | Ptop_dir a -> self#toplevel_directive a acc method toplevel_directive : toplevel_directive -> 'acc -> 'acc= fun { pdir_name; pdir_arg; pdir_loc } -> fun acc -> let acc = self#loc self#string pdir_name acc in let acc = self#option self#directive_argument pdir_arg acc in let acc = self#location pdir_loc acc in acc method directive_argument : directive_argument -> 'acc -> 'acc= fun { pdira_desc; pdira_loc } -> fun acc -> let acc = self#directive_argument_desc pdira_desc acc in let acc = self#location pdira_loc acc in acc method directive_argument_desc : directive_argument_desc -> 'acc -> 'acc= fun x -> fun acc -> match x with | Pdir_string a -> self#string a acc | Pdir_int (a, b) -> let acc = self#string a acc in let acc = self#option self#char b acc in acc | Pdir_ident a -> self#longident a acc | Pdir_bool a -> self#bool a acc end class virtual ['acc] fold_map = object (self) method virtual bool : bool -> 'acc -> (bool * 'acc) method virtual char : char -> 'acc -> (char * 'acc) method virtual int : int -> 'acc -> (int * 'acc) method virtual list : 'a . ('a -> 'acc -> ('a * 'acc)) -> 'a list -> 'acc -> ('a list * 'acc) method virtual option : 'a . ('a -> 'acc -> ('a * 'acc)) -> 'a option -> 'acc -> ('a option * 'acc) method virtual string : string -> 'acc -> (string * 'acc) method position : position -> 'acc -> (position * 'acc)= fun { pos_fname; pos_lnum; pos_bol; pos_cnum } -> fun acc -> let (pos_fname, acc) = self#string pos_fname acc in let (pos_lnum, acc) = self#int pos_lnum acc in let (pos_bol, acc) = self#int pos_bol acc in let (pos_cnum, acc) = self#int pos_cnum acc in ({ pos_fname; pos_lnum; pos_bol; pos_cnum }, acc) method location : location -> 'acc -> (location * 'acc)= fun { loc_start; loc_end; loc_ghost } -> fun acc -> let (loc_start, acc) = self#position loc_start acc in let (loc_end, acc) = self#position loc_end acc in let (loc_ghost, acc) = self#bool loc_ghost acc in ({ loc_start; loc_end; loc_ghost }, acc) method location_stack : location_stack -> 'acc -> (location_stack * 'acc)= self#list self#location method loc : 'a . ('a -> 'acc -> ('a * 'acc)) -> 'a loc -> 'acc -> ('a loc * 'acc)= fun _a -> fun { txt; loc } -> fun acc -> let (txt, acc) = _a txt acc in let (loc, acc) = self#location loc acc in ({ txt; loc }, acc) method longident : longident -> 'acc -> (longident * 'acc)= fun x -> fun acc -> match x with | Lident a -> let (a, acc) = self#string a acc in ((Lident a), acc) | Ldot (a, b) -> let (a, acc) = self#longident a acc in let (b, acc) = self#string b acc in ((Ldot (a, b)), acc) | Lapply (a, b) -> let (a, acc) = self#longident a acc in let (b, acc) = self#longident b acc in ((Lapply (a, b)), acc) method longident_loc : longident_loc -> 'acc -> (longident_loc * 'acc)= self#loc self#longident method rec_flag : rec_flag -> 'acc -> (rec_flag * 'acc)= fun x -> fun acc -> (x, acc) method direction_flag : direction_flag -> 'acc -> (direction_flag * 'acc)= fun x -> fun acc -> (x, acc) method private_flag : private_flag -> 'acc -> (private_flag * 'acc)= fun x -> fun acc -> (x, acc) method mutable_flag : mutable_flag -> 'acc -> (mutable_flag * 'acc)= fun x -> fun acc -> (x, acc) method virtual_flag : virtual_flag -> 'acc -> (virtual_flag * 'acc)= fun x -> fun acc -> (x, acc) method override_flag : override_flag -> 'acc -> (override_flag * 'acc)= fun x -> fun acc -> (x, acc) method closed_flag : closed_flag -> 'acc -> (closed_flag * 'acc)= fun x -> fun acc -> (x, acc) method label : label -> 'acc -> (label * 'acc)= self#string method arg_label : arg_label -> 'acc -> (arg_label * 'acc)= fun x -> fun acc -> match x with | Nolabel -> (Nolabel, acc) | Labelled a -> let (a, acc) = self#string a acc in ((Labelled a), acc) | Optional a -> let (a, acc) = self#string a acc in ((Optional a), acc) method variance : variance -> 'acc -> (variance * 'acc)= fun x -> fun acc -> (x, acc) method constant : constant -> 'acc -> (constant * 'acc)= fun x -> fun acc -> match x with | Pconst_integer (a, b) -> let (a, acc) = self#string a acc in let (b, acc) = self#option self#char b acc in ((Pconst_integer (a, b)), acc) | Pconst_char a -> let (a, acc) = self#char a acc in ((Pconst_char a), acc) | Pconst_string (a, b) -> let (a, acc) = self#string a acc in let (b, acc) = self#option self#string b acc in ((Pconst_string (a, b)), acc) | Pconst_float (a, b) -> let (a, acc) = self#string a acc in let (b, acc) = self#option self#char b acc in ((Pconst_float (a, b)), acc) method attribute : attribute -> 'acc -> (attribute * 'acc)= fun { attr_name; attr_payload; attr_loc } -> fun acc -> let (attr_name, acc) = self#loc self#string attr_name acc in let (attr_payload, acc) = self#payload attr_payload acc in let (attr_loc, acc) = self#location attr_loc acc in ({ attr_name; attr_payload; attr_loc }, acc) method extension : extension -> 'acc -> (extension * 'acc)= fun (a, b) -> fun acc -> let (a, acc) = self#loc self#string a acc in let (b, acc) = self#payload b acc in ((a, b), acc) method attributes : attributes -> 'acc -> (attributes * 'acc)= self#list self#attribute method payload : payload -> 'acc -> (payload * 'acc)= fun x -> fun acc -> match x with | PStr a -> let (a, acc) = self#structure a acc in ((PStr a), acc) | PSig a -> let (a, acc) = self#signature a acc in ((PSig a), acc) | PTyp a -> let (a, acc) = self#core_type a acc in ((PTyp a), acc) | PPat (a, b) -> let (a, acc) = self#pattern a acc in let (b, acc) = self#option self#expression b acc in ((PPat (a, b)), acc) method core_type : core_type -> 'acc -> (core_type * 'acc)= fun { ptyp_desc; ptyp_loc; ptyp_loc_stack; ptyp_attributes } -> fun acc -> let (ptyp_desc, acc) = self#core_type_desc ptyp_desc acc in let (ptyp_loc, acc) = self#location ptyp_loc acc in let (ptyp_loc_stack, acc) = self#location_stack ptyp_loc_stack acc in let (ptyp_attributes, acc) = self#attributes ptyp_attributes acc in ({ ptyp_desc; ptyp_loc; ptyp_loc_stack; ptyp_attributes }, acc) method core_type_desc : core_type_desc -> 'acc -> (core_type_desc * 'acc)= fun x -> fun acc -> match x with | Ptyp_any -> (Ptyp_any, acc) | Ptyp_var a -> let (a, acc) = self#string a acc in ((Ptyp_var a), acc) | Ptyp_arrow (a, b, c) -> let (a, acc) = self#arg_label a acc in let (b, acc) = self#core_type b acc in let (c, acc) = self#core_type c acc in ((Ptyp_arrow (a, b, c)), acc) | Ptyp_tuple a -> let (a, acc) = self#list self#core_type a acc in ((Ptyp_tuple a), acc) | Ptyp_constr (a, b) -> let (a, acc) = self#longident_loc a acc in let (b, acc) = self#list self#core_type b acc in ((Ptyp_constr (a, b)), acc) | Ptyp_object (a, b) -> let (a, acc) = self#list self#object_field a acc in let (b, acc) = self#closed_flag b acc in ((Ptyp_object (a, b)), acc) | Ptyp_class (a, b) -> let (a, acc) = self#longident_loc a acc in let (b, acc) = self#list self#core_type b acc in ((Ptyp_class (a, b)), acc) | Ptyp_alias (a, b) -> let (a, acc) = self#core_type a acc in let (b, acc) = self#string b acc in ((Ptyp_alias (a, b)), acc) | Ptyp_variant (a, b, c) -> let (a, acc) = self#list self#row_field a acc in let (b, acc) = self#closed_flag b acc in let (c, acc) = self#option (self#list self#label) c acc in ((Ptyp_variant (a, b, c)), acc) | Ptyp_poly (a, b) -> let (a, acc) = self#list (self#loc self#string) a acc in let (b, acc) = self#core_type b acc in ((Ptyp_poly (a, b)), acc) | Ptyp_package a -> let (a, acc) = self#package_type a acc in ((Ptyp_package a), acc) | Ptyp_extension a -> let (a, acc) = self#extension a acc in ((Ptyp_extension a), acc) method package_type : package_type -> 'acc -> (package_type * 'acc)= fun (a, b) -> fun acc -> let (a, acc) = self#longident_loc a acc in let (b, acc) = self#list (fun (a, b) -> fun acc -> let (a, acc) = self#longident_loc a acc in let (b, acc) = self#core_type b acc in ((a, b), acc)) b acc in ((a, b), acc) method row_field : row_field -> 'acc -> (row_field * 'acc)= fun { prf_desc; prf_loc; prf_attributes } -> fun acc -> let (prf_desc, acc) = self#row_field_desc prf_desc acc in let (prf_loc, acc) = self#location prf_loc acc in let (prf_attributes, acc) = self#attributes prf_attributes acc in ({ prf_desc; prf_loc; prf_attributes }, acc) method row_field_desc : row_field_desc -> 'acc -> (row_field_desc * 'acc)= fun x -> fun acc -> match x with | Rtag (a, b, c) -> let (a, acc) = self#loc self#label a acc in let (b, acc) = self#bool b acc in let (c, acc) = self#list self#core_type c acc in ((Rtag (a, b, c)), acc) | Rinherit a -> let (a, acc) = self#core_type a acc in ((Rinherit a), acc) method object_field : object_field -> 'acc -> (object_field * 'acc)= fun { pof_desc; pof_loc; pof_attributes } -> fun acc -> let (pof_desc, acc) = self#object_field_desc pof_desc acc in let (pof_loc, acc) = self#location pof_loc acc in let (pof_attributes, acc) = self#attributes pof_attributes acc in ({ pof_desc; pof_loc; pof_attributes }, acc) method object_field_desc : object_field_desc -> 'acc -> (object_field_desc * 'acc)= fun x -> fun acc -> match x with | Otag (a, b) -> let (a, acc) = self#loc self#label a acc in let (b, acc) = self#core_type b acc in ((Otag (a, b)), acc) | Oinherit a -> let (a, acc) = self#core_type a acc in ((Oinherit a), acc) method pattern : pattern -> 'acc -> (pattern * 'acc)= fun { ppat_desc; ppat_loc; ppat_loc_stack; ppat_attributes } -> fun acc -> let (ppat_desc, acc) = self#pattern_desc ppat_desc acc in let (ppat_loc, acc) = self#location ppat_loc acc in let (ppat_loc_stack, acc) = self#location_stack ppat_loc_stack acc in let (ppat_attributes, acc) = self#attributes ppat_attributes acc in ({ ppat_desc; ppat_loc; ppat_loc_stack; ppat_attributes }, acc) method pattern_desc : pattern_desc -> 'acc -> (pattern_desc * 'acc)= fun x -> fun acc -> match x with | Ppat_any -> (Ppat_any, acc) | Ppat_var a -> let (a, acc) = self#loc self#string a acc in ((Ppat_var a), acc) | Ppat_alias (a, b) -> let (a, acc) = self#pattern a acc in let (b, acc) = self#loc self#string b acc in ((Ppat_alias (a, b)), acc) | Ppat_constant a -> let (a, acc) = self#constant a acc in ((Ppat_constant a), acc) | Ppat_interval (a, b) -> let (a, acc) = self#constant a acc in let (b, acc) = self#constant b acc in ((Ppat_interval (a, b)), acc) | Ppat_tuple a -> let (a, acc) = self#list self#pattern a acc in ((Ppat_tuple a), acc) | Ppat_construct (a, b) -> let (a, acc) = self#longident_loc a acc in let (b, acc) = self#option self#pattern b acc in ((Ppat_construct (a, b)), acc) | Ppat_variant (a, b) -> let (a, acc) = self#label a acc in let (b, acc) = self#option self#pattern b acc in ((Ppat_variant (a, b)), acc) | Ppat_record (a, b) -> let (a, acc) = self#list (fun (a, b) -> fun acc -> let (a, acc) = self#longident_loc a acc in let (b, acc) = self#pattern b acc in ((a, b), acc)) a acc in let (b, acc) = self#closed_flag b acc in ((Ppat_record (a, b)), acc) | Ppat_array a -> let (a, acc) = self#list self#pattern a acc in ((Ppat_array a), acc) | Ppat_or (a, b) -> let (a, acc) = self#pattern a acc in let (b, acc) = self#pattern b acc in ((Ppat_or (a, b)), acc) | Ppat_constraint (a, b) -> let (a, acc) = self#pattern a acc in let (b, acc) = self#core_type b acc in ((Ppat_constraint (a, b)), acc) | Ppat_type a -> let (a, acc) = self#longident_loc a acc in ((Ppat_type a), acc) | Ppat_lazy a -> let (a, acc) = self#pattern a acc in ((Ppat_lazy a), acc) | Ppat_unpack a -> let (a, acc) = self#loc self#string a acc in ((Ppat_unpack a), acc) | Ppat_exception a -> let (a, acc) = self#pattern a acc in ((Ppat_exception a), acc) | Ppat_extension a -> let (a, acc) = self#extension a acc in ((Ppat_extension a), acc) | Ppat_open (a, b) -> let (a, acc) = self#longident_loc a acc in let (b, acc) = self#pattern b acc in ((Ppat_open (a, b)), acc) method expression : expression -> 'acc -> (expression * 'acc)= fun { pexp_desc; pexp_loc; pexp_loc_stack; pexp_attributes } -> fun acc -> let (pexp_desc, acc) = self#expression_desc pexp_desc acc in let (pexp_loc, acc) = self#location pexp_loc acc in let (pexp_loc_stack, acc) = self#location_stack pexp_loc_stack acc in let (pexp_attributes, acc) = self#attributes pexp_attributes acc in ({ pexp_desc; pexp_loc; pexp_loc_stack; pexp_attributes }, acc) method expression_desc : expression_desc -> 'acc -> (expression_desc * 'acc)= fun x -> fun acc -> match x with | Pexp_ident a -> let (a, acc) = self#longident_loc a acc in ((Pexp_ident a), acc) | Pexp_constant a -> let (a, acc) = self#constant a acc in ((Pexp_constant a), acc) | Pexp_let (a, b, c) -> let (a, acc) = self#rec_flag a acc in let (b, acc) = self#list self#value_binding b acc in let (c, acc) = self#expression c acc in ((Pexp_let (a, b, c)), acc) | Pexp_function a -> let (a, acc) = self#list self#case a acc in ((Pexp_function a), acc) | Pexp_fun (a, b, c, d) -> let (a, acc) = self#arg_label a acc in let (b, acc) = self#option self#expression b acc in let (c, acc) = self#pattern c acc in let (d, acc) = self#expression d acc in ((Pexp_fun (a, b, c, d)), acc) | Pexp_apply (a, b) -> let (a, acc) = self#expression a acc in let (b, acc) = self#list (fun (a, b) -> fun acc -> let (a, acc) = self#arg_label a acc in let (b, acc) = self#expression b acc in ((a, b), acc)) b acc in ((Pexp_apply (a, b)), acc) | Pexp_match (a, b) -> let (a, acc) = self#expression a acc in let (b, acc) = self#list self#case b acc in ((Pexp_match (a, b)), acc) | Pexp_try (a, b) -> let (a, acc) = self#expression a acc in let (b, acc) = self#list self#case b acc in ((Pexp_try (a, b)), acc) | Pexp_tuple a -> let (a, acc) = self#list self#expression a acc in ((Pexp_tuple a), acc) | Pexp_construct (a, b) -> let (a, acc) = self#longident_loc a acc in let (b, acc) = self#option self#expression b acc in ((Pexp_construct (a, b)), acc) | Pexp_variant (a, b) -> let (a, acc) = self#label a acc in let (b, acc) = self#option self#expression b acc in ((Pexp_variant (a, b)), acc) | Pexp_record (a, b) -> let (a, acc) = self#list (fun (a, b) -> fun acc -> let (a, acc) = self#longident_loc a acc in let (b, acc) = self#expression b acc in ((a, b), acc)) a acc in let (b, acc) = self#option self#expression b acc in ((Pexp_record (a, b)), acc) | Pexp_field (a, b) -> let (a, acc) = self#expression a acc in let (b, acc) = self#longident_loc b acc in ((Pexp_field (a, b)), acc) | Pexp_setfield (a, b, c) -> let (a, acc) = self#expression a acc in let (b, acc) = self#longident_loc b acc in let (c, acc) = self#expression c acc in ((Pexp_setfield (a, b, c)), acc) | Pexp_array a -> let (a, acc) = self#list self#expression a acc in ((Pexp_array a), acc) | Pexp_ifthenelse (a, b, c) -> let (a, acc) = self#expression a acc in let (b, acc) = self#expression b acc in let (c, acc) = self#option self#expression c acc in ((Pexp_ifthenelse (a, b, c)), acc) | Pexp_sequence (a, b) -> let (a, acc) = self#expression a acc in let (b, acc) = self#expression b acc in ((Pexp_sequence (a, b)), acc) | Pexp_while (a, b) -> let (a, acc) = self#expression a acc in let (b, acc) = self#expression b acc in ((Pexp_while (a, b)), acc) | Pexp_for (a, b, c, d, e) -> let (a, acc) = self#pattern a acc in let (b, acc) = self#expression b acc in let (c, acc) = self#expression c acc in let (d, acc) = self#direction_flag d acc in let (e, acc) = self#expression e acc in ((Pexp_for (a, b, c, d, e)), acc) | Pexp_constraint (a, b) -> let (a, acc) = self#expression a acc in let (b, acc) = self#core_type b acc in ((Pexp_constraint (a, b)), acc) | Pexp_coerce (a, b, c) -> let (a, acc) = self#expression a acc in let (b, acc) = self#option self#core_type b acc in let (c, acc) = self#core_type c acc in ((Pexp_coerce (a, b, c)), acc) | Pexp_send (a, b) -> let (a, acc) = self#expression a acc in let (b, acc) = self#loc self#label b acc in ((Pexp_send (a, b)), acc) | Pexp_new a -> let (a, acc) = self#longident_loc a acc in ((Pexp_new a), acc) | Pexp_setinstvar (a, b) -> let (a, acc) = self#loc self#label a acc in let (b, acc) = self#expression b acc in ((Pexp_setinstvar (a, b)), acc) | Pexp_override a -> let (a, acc) = self#list (fun (a, b) -> fun acc -> let (a, acc) = self#loc self#label a acc in let (b, acc) = self#expression b acc in ((a, b), acc)) a acc in ((Pexp_override a), acc) | Pexp_letmodule (a, b, c) -> let (a, acc) = self#loc self#string a acc in let (b, acc) = self#module_expr b acc in let (c, acc) = self#expression c acc in ((Pexp_letmodule (a, b, c)), acc) | Pexp_letexception (a, b) -> let (a, acc) = self#extension_constructor a acc in let (b, acc) = self#expression b acc in ((Pexp_letexception (a, b)), acc) | Pexp_assert a -> let (a, acc) = self#expression a acc in ((Pexp_assert a), acc) | Pexp_lazy a -> let (a, acc) = self#expression a acc in ((Pexp_lazy a), acc) | Pexp_poly (a, b) -> let (a, acc) = self#expression a acc in let (b, acc) = self#option self#core_type b acc in ((Pexp_poly (a, b)), acc) | Pexp_object a -> let (a, acc) = self#class_structure a acc in ((Pexp_object a), acc) | Pexp_newtype (a, b) -> let (a, acc) = self#loc self#string a acc in let (b, acc) = self#expression b acc in ((Pexp_newtype (a, b)), acc) | Pexp_pack a -> let (a, acc) = self#module_expr a acc in ((Pexp_pack a), acc) | Pexp_open (a, b) -> let (a, acc) = self#open_declaration a acc in let (b, acc) = self#expression b acc in ((Pexp_open (a, b)), acc) | Pexp_letop a -> let (a, acc) = self#letop a acc in ((Pexp_letop a), acc) | Pexp_extension a -> let (a, acc) = self#extension a acc in ((Pexp_extension a), acc) | Pexp_unreachable -> (Pexp_unreachable, acc) method case : case -> 'acc -> (case * 'acc)= fun { pc_lhs; pc_guard; pc_rhs } -> fun acc -> let (pc_lhs, acc) = self#pattern pc_lhs acc in let (pc_guard, acc) = self#option self#expression pc_guard acc in let (pc_rhs, acc) = self#expression pc_rhs acc in ({ pc_lhs; pc_guard; pc_rhs }, acc) method letop : letop -> 'acc -> (letop * 'acc)= fun { let_; ands; body } -> fun acc -> let (let_, acc) = self#binding_op let_ acc in let (ands, acc) = self#list self#binding_op ands acc in let (body, acc) = self#expression body acc in ({ let_; ands; body }, acc) method binding_op : binding_op -> 'acc -> (binding_op * 'acc)= fun { pbop_op; pbop_pat; pbop_exp; pbop_loc } -> fun acc -> let (pbop_op, acc) = self#loc self#string pbop_op acc in let (pbop_pat, acc) = self#pattern pbop_pat acc in let (pbop_exp, acc) = self#expression pbop_exp acc in let (pbop_loc, acc) = self#location pbop_loc acc in ({ pbop_op; pbop_pat; pbop_exp; pbop_loc }, acc) method value_description : value_description -> 'acc -> (value_description * 'acc)= fun { pval_name; pval_type; pval_prim; pval_attributes; pval_loc } -> fun acc -> let (pval_name, acc) = self#loc self#string pval_name acc in let (pval_type, acc) = self#core_type pval_type acc in let (pval_prim, acc) = self#list self#string pval_prim acc in let (pval_attributes, acc) = self#attributes pval_attributes acc in let (pval_loc, acc) = self#location pval_loc acc in ({ pval_name; pval_type; pval_prim; pval_attributes; pval_loc }, acc) method type_declaration : type_declaration -> 'acc -> (type_declaration * 'acc)= fun { ptype_name; ptype_params; ptype_cstrs; ptype_kind; ptype_private; ptype_manifest; ptype_attributes; ptype_loc } -> fun acc -> let (ptype_name, acc) = self#loc self#string ptype_name acc in let (ptype_params, acc) = self#list (fun (a, b) -> fun acc -> let (a, acc) = self#core_type a acc in let (b, acc) = self#variance b acc in ((a, b), acc)) ptype_params acc in let (ptype_cstrs, acc) = self#list (fun (a, b, c) -> fun acc -> let (a, acc) = self#core_type a acc in let (b, acc) = self#core_type b acc in let (c, acc) = self#location c acc in ((a, b, c), acc)) ptype_cstrs acc in let (ptype_kind, acc) = self#type_kind ptype_kind acc in let (ptype_private, acc) = self#private_flag ptype_private acc in let (ptype_manifest, acc) = self#option self#core_type ptype_manifest acc in let (ptype_attributes, acc) = self#attributes ptype_attributes acc in let (ptype_loc, acc) = self#location ptype_loc acc in ({ ptype_name; ptype_params; ptype_cstrs; ptype_kind; ptype_private; ptype_manifest; ptype_attributes; ptype_loc }, acc) method type_kind : type_kind -> 'acc -> (type_kind * 'acc)= fun x -> fun acc -> match x with | Ptype_abstract -> (Ptype_abstract, acc) | Ptype_variant a -> let (a, acc) = self#list self#constructor_declaration a acc in ((Ptype_variant a), acc) | Ptype_record a -> let (a, acc) = self#list self#label_declaration a acc in ((Ptype_record a), acc) | Ptype_open -> (Ptype_open, acc) method label_declaration : label_declaration -> 'acc -> (label_declaration * 'acc)= fun { pld_name; pld_mutable; pld_type; pld_loc; pld_attributes } -> fun acc -> let (pld_name, acc) = self#loc self#string pld_name acc in let (pld_mutable, acc) = self#mutable_flag pld_mutable acc in let (pld_type, acc) = self#core_type pld_type acc in let (pld_loc, acc) = self#location pld_loc acc in let (pld_attributes, acc) = self#attributes pld_attributes acc in ({ pld_name; pld_mutable; pld_type; pld_loc; pld_attributes }, acc) method constructor_declaration : constructor_declaration -> 'acc -> (constructor_declaration * 'acc)= fun { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } -> fun acc -> let (pcd_name, acc) = self#loc self#string pcd_name acc in let (pcd_args, acc) = self#constructor_arguments pcd_args acc in let (pcd_res, acc) = self#option self#core_type pcd_res acc in let (pcd_loc, acc) = self#location pcd_loc acc in let (pcd_attributes, acc) = self#attributes pcd_attributes acc in ({ pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes }, acc) method constructor_arguments : constructor_arguments -> 'acc -> (constructor_arguments * 'acc)= fun x -> fun acc -> match x with | Pcstr_tuple a -> let (a, acc) = self#list self#core_type a acc in ((Pcstr_tuple a), acc) | Pcstr_record a -> let (a, acc) = self#list self#label_declaration a acc in ((Pcstr_record a), acc) method type_extension : type_extension -> 'acc -> (type_extension * 'acc)= fun { ptyext_path; ptyext_params; ptyext_constructors; ptyext_private; ptyext_loc; ptyext_attributes } -> fun acc -> let (ptyext_path, acc) = self#longident_loc ptyext_path acc in let (ptyext_params, acc) = self#list (fun (a, b) -> fun acc -> let (a, acc) = self#core_type a acc in let (b, acc) = self#variance b acc in ((a, b), acc)) ptyext_params acc in let (ptyext_constructors, acc) = self#list self#extension_constructor ptyext_constructors acc in let (ptyext_private, acc) = self#private_flag ptyext_private acc in let (ptyext_loc, acc) = self#location ptyext_loc acc in let (ptyext_attributes, acc) = self#attributes ptyext_attributes acc in ({ ptyext_path; ptyext_params; ptyext_constructors; ptyext_private; ptyext_loc; ptyext_attributes }, acc) method extension_constructor : extension_constructor -> 'acc -> (extension_constructor * 'acc)= fun { pext_name; pext_kind; pext_loc; pext_attributes } -> fun acc -> let (pext_name, acc) = self#loc self#string pext_name acc in let (pext_kind, acc) = self#extension_constructor_kind pext_kind acc in let (pext_loc, acc) = self#location pext_loc acc in let (pext_attributes, acc) = self#attributes pext_attributes acc in ({ pext_name; pext_kind; pext_loc; pext_attributes }, acc) method type_exception : type_exception -> 'acc -> (type_exception * 'acc)= fun { ptyexn_constructor; ptyexn_loc; ptyexn_attributes } -> fun acc -> let (ptyexn_constructor, acc) = self#extension_constructor ptyexn_constructor acc in let (ptyexn_loc, acc) = self#location ptyexn_loc acc in let (ptyexn_attributes, acc) = self#attributes ptyexn_attributes acc in ({ ptyexn_constructor; ptyexn_loc; ptyexn_attributes }, acc) method extension_constructor_kind : extension_constructor_kind -> 'acc -> (extension_constructor_kind * 'acc)= fun x -> fun acc -> match x with | Pext_decl (a, b) -> let (a, acc) = self#constructor_arguments a acc in let (b, acc) = self#option self#core_type b acc in ((Pext_decl (a, b)), acc) | Pext_rebind a -> let (a, acc) = self#longident_loc a acc in ((Pext_rebind a), acc) method class_type : class_type -> 'acc -> (class_type * 'acc)= fun { pcty_desc; pcty_loc; pcty_attributes } -> fun acc -> let (pcty_desc, acc) = self#class_type_desc pcty_desc acc in let (pcty_loc, acc) = self#location pcty_loc acc in let (pcty_attributes, acc) = self#attributes pcty_attributes acc in ({ pcty_desc; pcty_loc; pcty_attributes }, acc) method class_type_desc : class_type_desc -> 'acc -> (class_type_desc * 'acc)= fun x -> fun acc -> match x with | Pcty_constr (a, b) -> let (a, acc) = self#longident_loc a acc in let (b, acc) = self#list self#core_type b acc in ((Pcty_constr (a, b)), acc) | Pcty_signature a -> let (a, acc) = self#class_signature a acc in ((Pcty_signature a), acc) | Pcty_arrow (a, b, c) -> let (a, acc) = self#arg_label a acc in let (b, acc) = self#core_type b acc in let (c, acc) = self#class_type c acc in ((Pcty_arrow (a, b, c)), acc) | Pcty_extension a -> let (a, acc) = self#extension a acc in ((Pcty_extension a), acc) | Pcty_open (a, b) -> let (a, acc) = self#open_description a acc in let (b, acc) = self#class_type b acc in ((Pcty_open (a, b)), acc) method class_signature : class_signature -> 'acc -> (class_signature * 'acc)= fun { pcsig_self; pcsig_fields } -> fun acc -> let (pcsig_self, acc) = self#core_type pcsig_self acc in let (pcsig_fields, acc) = self#list self#class_type_field pcsig_fields acc in ({ pcsig_self; pcsig_fields }, acc) method class_type_field : class_type_field -> 'acc -> (class_type_field * 'acc)= fun { pctf_desc; pctf_loc; pctf_attributes } -> fun acc -> let (pctf_desc, acc) = self#class_type_field_desc pctf_desc acc in let (pctf_loc, acc) = self#location pctf_loc acc in let (pctf_attributes, acc) = self#attributes pctf_attributes acc in ({ pctf_desc; pctf_loc; pctf_attributes }, acc) method class_type_field_desc : class_type_field_desc -> 'acc -> (class_type_field_desc * 'acc)= fun x -> fun acc -> match x with | Pctf_inherit a -> let (a, acc) = self#class_type a acc in ((Pctf_inherit a), acc) | Pctf_val a -> let (a, acc) = (fun (a, b, c, d) -> fun acc -> let (a, acc) = self#loc self#label a acc in let (b, acc) = self#mutable_flag b acc in let (c, acc) = self#virtual_flag c acc in let (d, acc) = self#core_type d acc in ((a, b, c, d), acc)) a acc in ((Pctf_val a), acc) | Pctf_method a -> let (a, acc) = (fun (a, b, c, d) -> fun acc -> let (a, acc) = self#loc self#label a acc in let (b, acc) = self#private_flag b acc in let (c, acc) = self#virtual_flag c acc in let (d, acc) = self#core_type d acc in ((a, b, c, d), acc)) a acc in ((Pctf_method a), acc) | Pctf_constraint a -> let (a, acc) = (fun (a, b) -> fun acc -> let (a, acc) = self#core_type a acc in let (b, acc) = self#core_type b acc in ((a, b), acc)) a acc in ((Pctf_constraint a), acc) | Pctf_attribute a -> let (a, acc) = self#attribute a acc in ((Pctf_attribute a), acc) | Pctf_extension a -> let (a, acc) = self#extension a acc in ((Pctf_extension a), acc) method class_infos : 'a . ('a -> 'acc -> ('a * 'acc)) -> 'a class_infos -> 'acc -> ('a class_infos * 'acc)= fun _a -> fun { pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes } -> fun acc -> let (pci_virt, acc) = self#virtual_flag pci_virt acc in let (pci_params, acc) = self#list (fun (a, b) -> fun acc -> let (a, acc) = self#core_type a acc in let (b, acc) = self#variance b acc in ((a, b), acc)) pci_params acc in let (pci_name, acc) = self#loc self#string pci_name acc in let (pci_expr, acc) = _a pci_expr acc in let (pci_loc, acc) = self#location pci_loc acc in let (pci_attributes, acc) = self#attributes pci_attributes acc in ({ pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes }, acc) method class_description : class_description -> 'acc -> (class_description * 'acc)= self#class_infos self#class_type method class_type_declaration : class_type_declaration -> 'acc -> (class_type_declaration * 'acc)= self#class_infos self#class_type method class_expr : class_expr -> 'acc -> (class_expr * 'acc)= fun { pcl_desc; pcl_loc; pcl_attributes } -> fun acc -> let (pcl_desc, acc) = self#class_expr_desc pcl_desc acc in let (pcl_loc, acc) = self#location pcl_loc acc in let (pcl_attributes, acc) = self#attributes pcl_attributes acc in ({ pcl_desc; pcl_loc; pcl_attributes }, acc) method class_expr_desc : class_expr_desc -> 'acc -> (class_expr_desc * 'acc)= fun x -> fun acc -> match x with | Pcl_constr (a, b) -> let (a, acc) = self#longident_loc a acc in let (b, acc) = self#list self#core_type b acc in ((Pcl_constr (a, b)), acc) | Pcl_structure a -> let (a, acc) = self#class_structure a acc in ((Pcl_structure a), acc) | Pcl_fun (a, b, c, d) -> let (a, acc) = self#arg_label a acc in let (b, acc) = self#option self#expression b acc in let (c, acc) = self#pattern c acc in let (d, acc) = self#class_expr d acc in ((Pcl_fun (a, b, c, d)), acc) | Pcl_apply (a, b) -> let (a, acc) = self#class_expr a acc in let (b, acc) = self#list (fun (a, b) -> fun acc -> let (a, acc) = self#arg_label a acc in let (b, acc) = self#expression b acc in ((a, b), acc)) b acc in ((Pcl_apply (a, b)), acc) | Pcl_let (a, b, c) -> let (a, acc) = self#rec_flag a acc in let (b, acc) = self#list self#value_binding b acc in let (c, acc) = self#class_expr c acc in ((Pcl_let (a, b, c)), acc) | Pcl_constraint (a, b) -> let (a, acc) = self#class_expr a acc in let (b, acc) = self#class_type b acc in ((Pcl_constraint (a, b)), acc) | Pcl_extension a -> let (a, acc) = self#extension a acc in ((Pcl_extension a), acc) | Pcl_open (a, b) -> let (a, acc) = self#open_description a acc in let (b, acc) = self#class_expr b acc in ((Pcl_open (a, b)), acc) method class_structure : class_structure -> 'acc -> (class_structure * 'acc)= fun { pcstr_self; pcstr_fields } -> fun acc -> let (pcstr_self, acc) = self#pattern pcstr_self acc in let (pcstr_fields, acc) = self#list self#class_field pcstr_fields acc in ({ pcstr_self; pcstr_fields }, acc) method class_field : class_field -> 'acc -> (class_field * 'acc)= fun { pcf_desc; pcf_loc; pcf_attributes } -> fun acc -> let (pcf_desc, acc) = self#class_field_desc pcf_desc acc in let (pcf_loc, acc) = self#location pcf_loc acc in let (pcf_attributes, acc) = self#attributes pcf_attributes acc in ({ pcf_desc; pcf_loc; pcf_attributes }, acc) method class_field_desc : class_field_desc -> 'acc -> (class_field_desc * 'acc)= fun x -> fun acc -> match x with | Pcf_inherit (a, b, c) -> let (a, acc) = self#override_flag a acc in let (b, acc) = self#class_expr b acc in let (c, acc) = self#option (self#loc self#string) c acc in ((Pcf_inherit (a, b, c)), acc) | Pcf_val a -> let (a, acc) = (fun (a, b, c) -> fun acc -> let (a, acc) = self#loc self#label a acc in let (b, acc) = self#mutable_flag b acc in let (c, acc) = self#class_field_kind c acc in ((a, b, c), acc)) a acc in ((Pcf_val a), acc) | Pcf_method a -> let (a, acc) = (fun (a, b, c) -> fun acc -> let (a, acc) = self#loc self#label a acc in let (b, acc) = self#private_flag b acc in let (c, acc) = self#class_field_kind c acc in ((a, b, c), acc)) a acc in ((Pcf_method a), acc) | Pcf_constraint a -> let (a, acc) = (fun (a, b) -> fun acc -> let (a, acc) = self#core_type a acc in let (b, acc) = self#core_type b acc in ((a, b), acc)) a acc in ((Pcf_constraint a), acc) | Pcf_initializer a -> let (a, acc) = self#expression a acc in ((Pcf_initializer a), acc) | Pcf_attribute a -> let (a, acc) = self#attribute a acc in ((Pcf_attribute a), acc) | Pcf_extension a -> let (a, acc) = self#extension a acc in ((Pcf_extension a), acc) method class_field_kind : class_field_kind -> 'acc -> (class_field_kind * 'acc)= fun x -> fun acc -> match x with | Cfk_virtual a -> let (a, acc) = self#core_type a acc in ((Cfk_virtual a), acc) | Cfk_concrete (a, b) -> let (a, acc) = self#override_flag a acc in let (b, acc) = self#expression b acc in ((Cfk_concrete (a, b)), acc) method class_declaration : class_declaration -> 'acc -> (class_declaration * 'acc)= self#class_infos self#class_expr method module_type : module_type -> 'acc -> (module_type * 'acc)= fun { pmty_desc; pmty_loc; pmty_attributes } -> fun acc -> let (pmty_desc, acc) = self#module_type_desc pmty_desc acc in let (pmty_loc, acc) = self#location pmty_loc acc in let (pmty_attributes, acc) = self#attributes pmty_attributes acc in ({ pmty_desc; pmty_loc; pmty_attributes }, acc) method module_type_desc : module_type_desc -> 'acc -> (module_type_desc * 'acc)= fun x -> fun acc -> match x with | Pmty_ident a -> let (a, acc) = self#longident_loc a acc in ((Pmty_ident a), acc) | Pmty_signature a -> let (a, acc) = self#signature a acc in ((Pmty_signature a), acc) | Pmty_functor (a, b, c) -> let (a, acc) = self#loc self#string a acc in let (b, acc) = self#option self#module_type b acc in let (c, acc) = self#module_type c acc in ((Pmty_functor (a, b, c)), acc) | Pmty_with (a, b) -> let (a, acc) = self#module_type a acc in let (b, acc) = self#list self#with_constraint b acc in ((Pmty_with (a, b)), acc) | Pmty_typeof a -> let (a, acc) = self#module_expr a acc in ((Pmty_typeof a), acc) | Pmty_extension a -> let (a, acc) = self#extension a acc in ((Pmty_extension a), acc) | Pmty_alias a -> let (a, acc) = self#longident_loc a acc in ((Pmty_alias a), acc) method signature : signature -> 'acc -> (signature * 'acc)= self#list self#signature_item method signature_item : signature_item -> 'acc -> (signature_item * 'acc)= fun { psig_desc; psig_loc } -> fun acc -> let (psig_desc, acc) = self#signature_item_desc psig_desc acc in let (psig_loc, acc) = self#location psig_loc acc in ({ psig_desc; psig_loc }, acc) method signature_item_desc : signature_item_desc -> 'acc -> (signature_item_desc * 'acc)= fun x -> fun acc -> match x with | Psig_value a -> let (a, acc) = self#value_description a acc in ((Psig_value a), acc) | Psig_type (a, b) -> let (a, acc) = self#rec_flag a acc in let (b, acc) = self#list self#type_declaration b acc in ((Psig_type (a, b)), acc) | Psig_typesubst a -> let (a, acc) = self#list self#type_declaration a acc in ((Psig_typesubst a), acc) | Psig_typext a -> let (a, acc) = self#type_extension a acc in ((Psig_typext a), acc) | Psig_exception a -> let (a, acc) = self#type_exception a acc in ((Psig_exception a), acc) | Psig_module a -> let (a, acc) = self#module_declaration a acc in ((Psig_module a), acc) | Psig_modsubst a -> let (a, acc) = self#module_substitution a acc in ((Psig_modsubst a), acc) | Psig_recmodule a -> let (a, acc) = self#list self#module_declaration a acc in ((Psig_recmodule a), acc) | Psig_modtype a -> let (a, acc) = self#module_type_declaration a acc in ((Psig_modtype a), acc) | Psig_open a -> let (a, acc) = self#open_description a acc in ((Psig_open a), acc) | Psig_include a -> let (a, acc) = self#include_description a acc in ((Psig_include a), acc) | Psig_class a -> let (a, acc) = self#list self#class_description a acc in ((Psig_class a), acc) | Psig_class_type a -> let (a, acc) = self#list self#class_type_declaration a acc in ((Psig_class_type a), acc) | Psig_attribute a -> let (a, acc) = self#attribute a acc in ((Psig_attribute a), acc) | Psig_extension (a, b) -> let (a, acc) = self#extension a acc in let (b, acc) = self#attributes b acc in ((Psig_extension (a, b)), acc) method module_declaration : module_declaration -> 'acc -> (module_declaration * 'acc)= fun { pmd_name; pmd_type; pmd_attributes; pmd_loc } -> fun acc -> let (pmd_name, acc) = self#loc self#string pmd_name acc in let (pmd_type, acc) = self#module_type pmd_type acc in let (pmd_attributes, acc) = self#attributes pmd_attributes acc in let (pmd_loc, acc) = self#location pmd_loc acc in ({ pmd_name; pmd_type; pmd_attributes; pmd_loc }, acc) method module_substitution : module_substitution -> 'acc -> (module_substitution * 'acc)= fun { pms_name; pms_manifest; pms_attributes; pms_loc } -> fun acc -> let (pms_name, acc) = self#loc self#string pms_name acc in let (pms_manifest, acc) = self#longident_loc pms_manifest acc in let (pms_attributes, acc) = self#attributes pms_attributes acc in let (pms_loc, acc) = self#location pms_loc acc in ({ pms_name; pms_manifest; pms_attributes; pms_loc }, acc) method module_type_declaration : module_type_declaration -> 'acc -> (module_type_declaration * 'acc)= fun { pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc } -> fun acc -> let (pmtd_name, acc) = self#loc self#string pmtd_name acc in let (pmtd_type, acc) = self#option self#module_type pmtd_type acc in let (pmtd_attributes, acc) = self#attributes pmtd_attributes acc in let (pmtd_loc, acc) = self#location pmtd_loc acc in ({ pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc }, acc) method open_infos : 'a . ('a -> 'acc -> ('a * 'acc)) -> 'a open_infos -> 'acc -> ('a open_infos * 'acc)= fun _a -> fun { popen_expr; popen_override; popen_loc; popen_attributes } -> fun acc -> let (popen_expr, acc) = _a popen_expr acc in let (popen_override, acc) = self#override_flag popen_override acc in let (popen_loc, acc) = self#location popen_loc acc in let (popen_attributes, acc) = self#attributes popen_attributes acc in ({ popen_expr; popen_override; popen_loc; popen_attributes }, acc) method open_description : open_description -> 'acc -> (open_description * 'acc)= self#open_infos self#longident_loc method open_declaration : open_declaration -> 'acc -> (open_declaration * 'acc)= self#open_infos self#module_expr method include_infos : 'a . ('a -> 'acc -> ('a * 'acc)) -> 'a include_infos -> 'acc -> ('a include_infos * 'acc)= fun _a -> fun { pincl_mod; pincl_loc; pincl_attributes } -> fun acc -> let (pincl_mod, acc) = _a pincl_mod acc in let (pincl_loc, acc) = self#location pincl_loc acc in let (pincl_attributes, acc) = self#attributes pincl_attributes acc in ({ pincl_mod; pincl_loc; pincl_attributes }, acc) method include_description : include_description -> 'acc -> (include_description * 'acc)= self#include_infos self#module_type method include_declaration : include_declaration -> 'acc -> (include_declaration * 'acc)= self#include_infos self#module_expr method with_constraint : with_constraint -> 'acc -> (with_constraint * 'acc)= fun x -> fun acc -> match x with | Pwith_type (a, b) -> let (a, acc) = self#longident_loc a acc in let (b, acc) = self#type_declaration b acc in ((Pwith_type (a, b)), acc) | Pwith_module (a, b) -> let (a, acc) = self#longident_loc a acc in let (b, acc) = self#longident_loc b acc in ((Pwith_module (a, b)), acc) | Pwith_typesubst (a, b) -> let (a, acc) = self#longident_loc a acc in let (b, acc) = self#type_declaration b acc in ((Pwith_typesubst (a, b)), acc) | Pwith_modsubst (a, b) -> let (a, acc) = self#longident_loc a acc in let (b, acc) = self#longident_loc b acc in ((Pwith_modsubst (a, b)), acc) method module_expr : module_expr -> 'acc -> (module_expr * 'acc)= fun { pmod_desc; pmod_loc; pmod_attributes } -> fun acc -> let (pmod_desc, acc) = self#module_expr_desc pmod_desc acc in let (pmod_loc, acc) = self#location pmod_loc acc in let (pmod_attributes, acc) = self#attributes pmod_attributes acc in ({ pmod_desc; pmod_loc; pmod_attributes }, acc) method module_expr_desc : module_expr_desc -> 'acc -> (module_expr_desc * 'acc)= fun x -> fun acc -> match x with | Pmod_ident a -> let (a, acc) = self#longident_loc a acc in ((Pmod_ident a), acc) | Pmod_structure a -> let (a, acc) = self#structure a acc in ((Pmod_structure a), acc) | Pmod_functor (a, b, c) -> let (a, acc) = self#loc self#string a acc in let (b, acc) = self#option self#module_type b acc in let (c, acc) = self#module_expr c acc in ((Pmod_functor (a, b, c)), acc) | Pmod_apply (a, b) -> let (a, acc) = self#module_expr a acc in let (b, acc) = self#module_expr b acc in ((Pmod_apply (a, b)), acc) | Pmod_constraint (a, b) -> let (a, acc) = self#module_expr a acc in let (b, acc) = self#module_type b acc in ((Pmod_constraint (a, b)), acc) | Pmod_unpack a -> let (a, acc) = self#expression a acc in ((Pmod_unpack a), acc) | Pmod_extension a -> let (a, acc) = self#extension a acc in ((Pmod_extension a), acc) method structure : structure -> 'acc -> (structure * 'acc)= self#list self#structure_item method structure_item : structure_item -> 'acc -> (structure_item * 'acc)= fun { pstr_desc; pstr_loc } -> fun acc -> let (pstr_desc, acc) = self#structure_item_desc pstr_desc acc in let (pstr_loc, acc) = self#location pstr_loc acc in ({ pstr_desc; pstr_loc }, acc) method structure_item_desc : structure_item_desc -> 'acc -> (structure_item_desc * 'acc)= fun x -> fun acc -> match x with | Pstr_eval (a, b) -> let (a, acc) = self#expression a acc in let (b, acc) = self#attributes b acc in ((Pstr_eval (a, b)), acc) | Pstr_value (a, b) -> let (a, acc) = self#rec_flag a acc in let (b, acc) = self#list self#value_binding b acc in ((Pstr_value (a, b)), acc) | Pstr_primitive a -> let (a, acc) = self#value_description a acc in ((Pstr_primitive a), acc) | Pstr_type (a, b) -> let (a, acc) = self#rec_flag a acc in let (b, acc) = self#list self#type_declaration b acc in ((Pstr_type (a, b)), acc) | Pstr_typext a -> let (a, acc) = self#type_extension a acc in ((Pstr_typext a), acc) | Pstr_exception a -> let (a, acc) = self#type_exception a acc in ((Pstr_exception a), acc) | Pstr_module a -> let (a, acc) = self#module_binding a acc in ((Pstr_module a), acc) | Pstr_recmodule a -> let (a, acc) = self#list self#module_binding a acc in ((Pstr_recmodule a), acc) | Pstr_modtype a -> let (a, acc) = self#module_type_declaration a acc in ((Pstr_modtype a), acc) | Pstr_open a -> let (a, acc) = self#open_declaration a acc in ((Pstr_open a), acc) | Pstr_class a -> let (a, acc) = self#list self#class_declaration a acc in ((Pstr_class a), acc) | Pstr_class_type a -> let (a, acc) = self#list self#class_type_declaration a acc in ((Pstr_class_type a), acc) | Pstr_include a -> let (a, acc) = self#include_declaration a acc in ((Pstr_include a), acc) | Pstr_attribute a -> let (a, acc) = self#attribute a acc in ((Pstr_attribute a), acc) | Pstr_extension (a, b) -> let (a, acc) = self#extension a acc in let (b, acc) = self#attributes b acc in ((Pstr_extension (a, b)), acc) method value_binding : value_binding -> 'acc -> (value_binding * 'acc)= fun { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } -> fun acc -> let (pvb_pat, acc) = self#pattern pvb_pat acc in let (pvb_expr, acc) = self#expression pvb_expr acc in let (pvb_attributes, acc) = self#attributes pvb_attributes acc in let (pvb_loc, acc) = self#location pvb_loc acc in ({ pvb_pat; pvb_expr; pvb_attributes; pvb_loc }, acc) method module_binding : module_binding -> 'acc -> (module_binding * 'acc)= fun { pmb_name; pmb_expr; pmb_attributes; pmb_loc } -> fun acc -> let (pmb_name, acc) = self#loc self#string pmb_name acc in let (pmb_expr, acc) = self#module_expr pmb_expr acc in let (pmb_attributes, acc) = self#attributes pmb_attributes acc in let (pmb_loc, acc) = self#location pmb_loc acc in ({ pmb_name; pmb_expr; pmb_attributes; pmb_loc }, acc) method toplevel_phrase : toplevel_phrase -> 'acc -> (toplevel_phrase * 'acc)= fun x -> fun acc -> match x with | Ptop_def a -> let (a, acc) = self#structure a acc in ((Ptop_def a), acc) | Ptop_dir a -> let (a, acc) = self#toplevel_directive a acc in ((Ptop_dir a), acc) method toplevel_directive : toplevel_directive -> 'acc -> (toplevel_directive * 'acc)= fun { pdir_name; pdir_arg; pdir_loc } -> fun acc -> let (pdir_name, acc) = self#loc self#string pdir_name acc in let (pdir_arg, acc) = self#option self#directive_argument pdir_arg acc in let (pdir_loc, acc) = self#location pdir_loc acc in ({ pdir_name; pdir_arg; pdir_loc }, acc) method directive_argument : directive_argument -> 'acc -> (directive_argument * 'acc)= fun { pdira_desc; pdira_loc } -> fun acc -> let (pdira_desc, acc) = self#directive_argument_desc pdira_desc acc in let (pdira_loc, acc) = self#location pdira_loc acc in ({ pdira_desc; pdira_loc }, acc) method directive_argument_desc : directive_argument_desc -> 'acc -> (directive_argument_desc * 'acc)= fun x -> fun acc -> match x with | Pdir_string a -> let (a, acc) = self#string a acc in ((Pdir_string a), acc) | Pdir_int (a, b) -> let (a, acc) = self#string a acc in let (b, acc) = self#option self#char b acc in ((Pdir_int (a, b)), acc) | Pdir_ident a -> let (a, acc) = self#longident a acc in ((Pdir_ident a), acc) | Pdir_bool a -> let (a, acc) = self#bool a acc in ((Pdir_bool a), acc) end class virtual ['ctx] map_with_context = object (self) method virtual bool : 'ctx -> bool -> bool method virtual char : 'ctx -> char -> char method virtual int : 'ctx -> int -> int method virtual list : 'a . ('ctx -> 'a -> 'a) -> 'ctx -> 'a list -> 'a list method virtual option : 'a . ('ctx -> 'a -> 'a) -> 'ctx -> 'a option -> 'a option method virtual string : 'ctx -> string -> string method position : 'ctx -> position -> position= fun ctx -> fun { pos_fname; pos_lnum; pos_bol; pos_cnum } -> let pos_fname = self#string ctx pos_fname in let pos_lnum = self#int ctx pos_lnum in let pos_bol = self#int ctx pos_bol in let pos_cnum = self#int ctx pos_cnum in { pos_fname; pos_lnum; pos_bol; pos_cnum } method location : 'ctx -> location -> location= fun ctx -> fun { loc_start; loc_end; loc_ghost } -> let loc_start = self#position ctx loc_start in let loc_end = self#position ctx loc_end in let loc_ghost = self#bool ctx loc_ghost in { loc_start; loc_end; loc_ghost } method location_stack : 'ctx -> location_stack -> location_stack= self#list self#location method loc : 'a . ('ctx -> 'a -> 'a) -> 'ctx -> 'a loc -> 'a loc= fun _a -> fun ctx -> fun { txt; loc } -> let txt = _a ctx txt in let loc = self#location ctx loc in { txt; loc } method longident : 'ctx -> longident -> longident= fun ctx -> fun x -> match x with | Lident a -> let a = self#string ctx a in Lident a | Ldot (a, b) -> let a = self#longident ctx a in let b = self#string ctx b in Ldot (a, b) | Lapply (a, b) -> let a = self#longident ctx a in let b = self#longident ctx b in Lapply (a, b) method longident_loc : 'ctx -> longident_loc -> longident_loc= self#loc self#longident method rec_flag : 'ctx -> rec_flag -> rec_flag= fun _ctx -> fun x -> x method direction_flag : 'ctx -> direction_flag -> direction_flag= fun _ctx -> fun x -> x method private_flag : 'ctx -> private_flag -> private_flag= fun _ctx -> fun x -> x method mutable_flag : 'ctx -> mutable_flag -> mutable_flag= fun _ctx -> fun x -> x method virtual_flag : 'ctx -> virtual_flag -> virtual_flag= fun _ctx -> fun x -> x method override_flag : 'ctx -> override_flag -> override_flag= fun _ctx -> fun x -> x method closed_flag : 'ctx -> closed_flag -> closed_flag= fun _ctx -> fun x -> x method label : 'ctx -> label -> label= self#string method arg_label : 'ctx -> arg_label -> arg_label= fun ctx -> fun x -> match x with | Nolabel -> Nolabel | Labelled a -> let a = self#string ctx a in Labelled a | Optional a -> let a = self#string ctx a in Optional a method variance : 'ctx -> variance -> variance= fun _ctx -> fun x -> x method constant : 'ctx -> constant -> constant= fun ctx -> fun x -> match x with | Pconst_integer (a, b) -> let a = self#string ctx a in let b = self#option self#char ctx b in Pconst_integer (a, b) | Pconst_char a -> let a = self#char ctx a in Pconst_char a | Pconst_string (a, b) -> let a = self#string ctx a in let b = self#option self#string ctx b in Pconst_string (a, b) | Pconst_float (a, b) -> let a = self#string ctx a in let b = self#option self#char ctx b in Pconst_float (a, b) method attribute : 'ctx -> attribute -> attribute= fun ctx -> fun { attr_name; attr_payload; attr_loc } -> let attr_name = self#loc self#string ctx attr_name in let attr_payload = self#payload ctx attr_payload in let attr_loc = self#location ctx attr_loc in { attr_name; attr_payload; attr_loc } method extension : 'ctx -> extension -> extension= fun ctx -> fun (a, b) -> let a = self#loc self#string ctx a in let b = self#payload ctx b in (a, b) method attributes : 'ctx -> attributes -> attributes= self#list self#attribute method payload : 'ctx -> payload -> payload= fun ctx -> fun x -> match x with | PStr a -> let a = self#structure ctx a in PStr a | PSig a -> let a = self#signature ctx a in PSig a | PTyp a -> let a = self#core_type ctx a in PTyp a | PPat (a, b) -> let a = self#pattern ctx a in let b = self#option self#expression ctx b in PPat (a, b) method core_type : 'ctx -> core_type -> core_type= fun ctx -> fun { ptyp_desc; ptyp_loc; ptyp_loc_stack; ptyp_attributes } -> let ptyp_desc = self#core_type_desc ctx ptyp_desc in let ptyp_loc = self#location ctx ptyp_loc in let ptyp_loc_stack = self#location_stack ctx ptyp_loc_stack in let ptyp_attributes = self#attributes ctx ptyp_attributes in { ptyp_desc; ptyp_loc; ptyp_loc_stack; ptyp_attributes } method core_type_desc : 'ctx -> core_type_desc -> core_type_desc= fun ctx -> fun x -> match x with | Ptyp_any -> Ptyp_any | Ptyp_var a -> let a = self#string ctx a in Ptyp_var a | Ptyp_arrow (a, b, c) -> let a = self#arg_label ctx a in let b = self#core_type ctx b in let c = self#core_type ctx c in Ptyp_arrow (a, b, c) | Ptyp_tuple a -> let a = self#list self#core_type ctx a in Ptyp_tuple a | Ptyp_constr (a, b) -> let a = self#longident_loc ctx a in let b = self#list self#core_type ctx b in Ptyp_constr (a, b) | Ptyp_object (a, b) -> let a = self#list self#object_field ctx a in let b = self#closed_flag ctx b in Ptyp_object (a, b) | Ptyp_class (a, b) -> let a = self#longident_loc ctx a in let b = self#list self#core_type ctx b in Ptyp_class (a, b) | Ptyp_alias (a, b) -> let a = self#core_type ctx a in let b = self#string ctx b in Ptyp_alias (a, b) | Ptyp_variant (a, b, c) -> let a = self#list self#row_field ctx a in let b = self#closed_flag ctx b in let c = self#option (self#list self#label) ctx c in Ptyp_variant (a, b, c) | Ptyp_poly (a, b) -> let a = self#list (self#loc self#string) ctx a in let b = self#core_type ctx b in Ptyp_poly (a, b) | Ptyp_package a -> let a = self#package_type ctx a in Ptyp_package a | Ptyp_extension a -> let a = self#extension ctx a in Ptyp_extension a method package_type : 'ctx -> package_type -> package_type= fun ctx -> fun (a, b) -> let a = self#longident_loc ctx a in let b = self#list (fun ctx -> fun (a, b) -> let a = self#longident_loc ctx a in let b = self#core_type ctx b in (a, b)) ctx b in (a, b) method row_field : 'ctx -> row_field -> row_field= fun ctx -> fun { prf_desc; prf_loc; prf_attributes } -> let prf_desc = self#row_field_desc ctx prf_desc in let prf_loc = self#location ctx prf_loc in let prf_attributes = self#attributes ctx prf_attributes in { prf_desc; prf_loc; prf_attributes } method row_field_desc : 'ctx -> row_field_desc -> row_field_desc= fun ctx -> fun x -> match x with | Rtag (a, b, c) -> let a = self#loc self#label ctx a in let b = self#bool ctx b in let c = self#list self#core_type ctx c in Rtag (a, b, c) | Rinherit a -> let a = self#core_type ctx a in Rinherit a method object_field : 'ctx -> object_field -> object_field= fun ctx -> fun { pof_desc; pof_loc; pof_attributes } -> let pof_desc = self#object_field_desc ctx pof_desc in let pof_loc = self#location ctx pof_loc in let pof_attributes = self#attributes ctx pof_attributes in { pof_desc; pof_loc; pof_attributes } method object_field_desc : 'ctx -> object_field_desc -> object_field_desc= fun ctx -> fun x -> match x with | Otag (a, b) -> let a = self#loc self#label ctx a in let b = self#core_type ctx b in Otag (a, b) | Oinherit a -> let a = self#core_type ctx a in Oinherit a method pattern : 'ctx -> pattern -> pattern= fun ctx -> fun { ppat_desc; ppat_loc; ppat_loc_stack; ppat_attributes } -> let ppat_desc = self#pattern_desc ctx ppat_desc in let ppat_loc = self#location ctx ppat_loc in let ppat_loc_stack = self#location_stack ctx ppat_loc_stack in let ppat_attributes = self#attributes ctx ppat_attributes in { ppat_desc; ppat_loc; ppat_loc_stack; ppat_attributes } method pattern_desc : 'ctx -> pattern_desc -> pattern_desc= fun ctx -> fun x -> match x with | Ppat_any -> Ppat_any | Ppat_var a -> let a = self#loc self#string ctx a in Ppat_var a | Ppat_alias (a, b) -> let a = self#pattern ctx a in let b = self#loc self#string ctx b in Ppat_alias (a, b) | Ppat_constant a -> let a = self#constant ctx a in Ppat_constant a | Ppat_interval (a, b) -> let a = self#constant ctx a in let b = self#constant ctx b in Ppat_interval (a, b) | Ppat_tuple a -> let a = self#list self#pattern ctx a in Ppat_tuple a | Ppat_construct (a, b) -> let a = self#longident_loc ctx a in let b = self#option self#pattern ctx b in Ppat_construct (a, b) | Ppat_variant (a, b) -> let a = self#label ctx a in let b = self#option self#pattern ctx b in Ppat_variant (a, b) | Ppat_record (a, b) -> let a = self#list (fun ctx -> fun (a, b) -> let a = self#longident_loc ctx a in let b = self#pattern ctx b in (a, b)) ctx a in let b = self#closed_flag ctx b in Ppat_record (a, b) | Ppat_array a -> let a = self#list self#pattern ctx a in Ppat_array a | Ppat_or (a, b) -> let a = self#pattern ctx a in let b = self#pattern ctx b in Ppat_or (a, b) | Ppat_constraint (a, b) -> let a = self#pattern ctx a in let b = self#core_type ctx b in Ppat_constraint (a, b) | Ppat_type a -> let a = self#longident_loc ctx a in Ppat_type a | Ppat_lazy a -> let a = self#pattern ctx a in Ppat_lazy a | Ppat_unpack a -> let a = self#loc self#string ctx a in Ppat_unpack a | Ppat_exception a -> let a = self#pattern ctx a in Ppat_exception a | Ppat_extension a -> let a = self#extension ctx a in Ppat_extension a | Ppat_open (a, b) -> let a = self#longident_loc ctx a in let b = self#pattern ctx b in Ppat_open (a, b) method expression : 'ctx -> expression -> expression= fun ctx -> fun { pexp_desc; pexp_loc; pexp_loc_stack; pexp_attributes } -> let pexp_desc = self#expression_desc ctx pexp_desc in let pexp_loc = self#location ctx pexp_loc in let pexp_loc_stack = self#location_stack ctx pexp_loc_stack in let pexp_attributes = self#attributes ctx pexp_attributes in { pexp_desc; pexp_loc; pexp_loc_stack; pexp_attributes } method expression_desc : 'ctx -> expression_desc -> expression_desc= fun ctx -> fun x -> match x with | Pexp_ident a -> let a = self#longident_loc ctx a in Pexp_ident a | Pexp_constant a -> let a = self#constant ctx a in Pexp_constant a | Pexp_let (a, b, c) -> let a = self#rec_flag ctx a in let b = self#list self#value_binding ctx b in let c = self#expression ctx c in Pexp_let (a, b, c) | Pexp_function a -> let a = self#list self#case ctx a in Pexp_function a | Pexp_fun (a, b, c, d) -> let a = self#arg_label ctx a in let b = self#option self#expression ctx b in let c = self#pattern ctx c in let d = self#expression ctx d in Pexp_fun (a, b, c, d) | Pexp_apply (a, b) -> let a = self#expression ctx a in let b = self#list (fun ctx -> fun (a, b) -> let a = self#arg_label ctx a in let b = self#expression ctx b in (a, b)) ctx b in Pexp_apply (a, b) | Pexp_match (a, b) -> let a = self#expression ctx a in let b = self#list self#case ctx b in Pexp_match (a, b) | Pexp_try (a, b) -> let a = self#expression ctx a in let b = self#list self#case ctx b in Pexp_try (a, b) | Pexp_tuple a -> let a = self#list self#expression ctx a in Pexp_tuple a | Pexp_construct (a, b) -> let a = self#longident_loc ctx a in let b = self#option self#expression ctx b in Pexp_construct (a, b) | Pexp_variant (a, b) -> let a = self#label ctx a in let b = self#option self#expression ctx b in Pexp_variant (a, b) | Pexp_record (a, b) -> let a = self#list (fun ctx -> fun (a, b) -> let a = self#longident_loc ctx a in let b = self#expression ctx b in (a, b)) ctx a in let b = self#option self#expression ctx b in Pexp_record (a, b) | Pexp_field (a, b) -> let a = self#expression ctx a in let b = self#longident_loc ctx b in Pexp_field (a, b) | Pexp_setfield (a, b, c) -> let a = self#expression ctx a in let b = self#longident_loc ctx b in let c = self#expression ctx c in Pexp_setfield (a, b, c) | Pexp_array a -> let a = self#list self#expression ctx a in Pexp_array a | Pexp_ifthenelse (a, b, c) -> let a = self#expression ctx a in let b = self#expression ctx b in let c = self#option self#expression ctx c in Pexp_ifthenelse (a, b, c) | Pexp_sequence (a, b) -> let a = self#expression ctx a in let b = self#expression ctx b in Pexp_sequence (a, b) | Pexp_while (a, b) -> let a = self#expression ctx a in let b = self#expression ctx b in Pexp_while (a, b) | Pexp_for (a, b, c, d, e) -> let a = self#pattern ctx a in let b = self#expression ctx b in let c = self#expression ctx c in let d = self#direction_flag ctx d in let e = self#expression ctx e in Pexp_for (a, b, c, d, e) | Pexp_constraint (a, b) -> let a = self#expression ctx a in let b = self#core_type ctx b in Pexp_constraint (a, b) | Pexp_coerce (a, b, c) -> let a = self#expression ctx a in let b = self#option self#core_type ctx b in let c = self#core_type ctx c in Pexp_coerce (a, b, c) | Pexp_send (a, b) -> let a = self#expression ctx a in let b = self#loc self#label ctx b in Pexp_send (a, b) | Pexp_new a -> let a = self#longident_loc ctx a in Pexp_new a | Pexp_setinstvar (a, b) -> let a = self#loc self#label ctx a in let b = self#expression ctx b in Pexp_setinstvar (a, b) | Pexp_override a -> let a = self#list (fun ctx -> fun (a, b) -> let a = self#loc self#label ctx a in let b = self#expression ctx b in (a, b)) ctx a in Pexp_override a | Pexp_letmodule (a, b, c) -> let a = self#loc self#string ctx a in let b = self#module_expr ctx b in let c = self#expression ctx c in Pexp_letmodule (a, b, c) | Pexp_letexception (a, b) -> let a = self#extension_constructor ctx a in let b = self#expression ctx b in Pexp_letexception (a, b) | Pexp_assert a -> let a = self#expression ctx a in Pexp_assert a | Pexp_lazy a -> let a = self#expression ctx a in Pexp_lazy a | Pexp_poly (a, b) -> let a = self#expression ctx a in let b = self#option self#core_type ctx b in Pexp_poly (a, b) | Pexp_object a -> let a = self#class_structure ctx a in Pexp_object a | Pexp_newtype (a, b) -> let a = self#loc self#string ctx a in let b = self#expression ctx b in Pexp_newtype (a, b) | Pexp_pack a -> let a = self#module_expr ctx a in Pexp_pack a | Pexp_open (a, b) -> let a = self#open_declaration ctx a in let b = self#expression ctx b in Pexp_open (a, b) | Pexp_letop a -> let a = self#letop ctx a in Pexp_letop a | Pexp_extension a -> let a = self#extension ctx a in Pexp_extension a | Pexp_unreachable -> Pexp_unreachable method case : 'ctx -> case -> case= fun ctx -> fun { pc_lhs; pc_guard; pc_rhs } -> let pc_lhs = self#pattern ctx pc_lhs in let pc_guard = self#option self#expression ctx pc_guard in let pc_rhs = self#expression ctx pc_rhs in { pc_lhs; pc_guard; pc_rhs } method letop : 'ctx -> letop -> letop= fun ctx -> fun { let_; ands; body } -> let let_ = self#binding_op ctx let_ in let ands = self#list self#binding_op ctx ands in let body = self#expression ctx body in { let_; ands; body } method binding_op : 'ctx -> binding_op -> binding_op= fun ctx -> fun { pbop_op; pbop_pat; pbop_exp; pbop_loc } -> let pbop_op = self#loc self#string ctx pbop_op in let pbop_pat = self#pattern ctx pbop_pat in let pbop_exp = self#expression ctx pbop_exp in let pbop_loc = self#location ctx pbop_loc in { pbop_op; pbop_pat; pbop_exp; pbop_loc } method value_description : 'ctx -> value_description -> value_description= fun ctx -> fun { pval_name; pval_type; pval_prim; pval_attributes; pval_loc } -> let pval_name = self#loc self#string ctx pval_name in let pval_type = self#core_type ctx pval_type in let pval_prim = self#list self#string ctx pval_prim in let pval_attributes = self#attributes ctx pval_attributes in let pval_loc = self#location ctx pval_loc in { pval_name; pval_type; pval_prim; pval_attributes; pval_loc } method type_declaration : 'ctx -> type_declaration -> type_declaration= fun ctx -> fun { ptype_name; ptype_params; ptype_cstrs; ptype_kind; ptype_private; ptype_manifest; ptype_attributes; ptype_loc } -> let ptype_name = self#loc self#string ctx ptype_name in let ptype_params = self#list (fun ctx -> fun (a, b) -> let a = self#core_type ctx a in let b = self#variance ctx b in (a, b)) ctx ptype_params in let ptype_cstrs = self#list (fun ctx -> fun (a, b, c) -> let a = self#core_type ctx a in let b = self#core_type ctx b in let c = self#location ctx c in (a, b, c)) ctx ptype_cstrs in let ptype_kind = self#type_kind ctx ptype_kind in let ptype_private = self#private_flag ctx ptype_private in let ptype_manifest = self#option self#core_type ctx ptype_manifest in let ptype_attributes = self#attributes ctx ptype_attributes in let ptype_loc = self#location ctx ptype_loc in { ptype_name; ptype_params; ptype_cstrs; ptype_kind; ptype_private; ptype_manifest; ptype_attributes; ptype_loc } method type_kind : 'ctx -> type_kind -> type_kind= fun ctx -> fun x -> match x with | Ptype_abstract -> Ptype_abstract | Ptype_variant a -> let a = self#list self#constructor_declaration ctx a in Ptype_variant a | Ptype_record a -> let a = self#list self#label_declaration ctx a in Ptype_record a | Ptype_open -> Ptype_open method label_declaration : 'ctx -> label_declaration -> label_declaration= fun ctx -> fun { pld_name; pld_mutable; pld_type; pld_loc; pld_attributes } -> let pld_name = self#loc self#string ctx pld_name in let pld_mutable = self#mutable_flag ctx pld_mutable in let pld_type = self#core_type ctx pld_type in let pld_loc = self#location ctx pld_loc in let pld_attributes = self#attributes ctx pld_attributes in { pld_name; pld_mutable; pld_type; pld_loc; pld_attributes } method constructor_declaration : 'ctx -> constructor_declaration -> constructor_declaration= fun ctx -> fun { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } -> let pcd_name = self#loc self#string ctx pcd_name in let pcd_args = self#constructor_arguments ctx pcd_args in let pcd_res = self#option self#core_type ctx pcd_res in let pcd_loc = self#location ctx pcd_loc in let pcd_attributes = self#attributes ctx pcd_attributes in { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } method constructor_arguments : 'ctx -> constructor_arguments -> constructor_arguments= fun ctx -> fun x -> match x with | Pcstr_tuple a -> let a = self#list self#core_type ctx a in Pcstr_tuple a | Pcstr_record a -> let a = self#list self#label_declaration ctx a in Pcstr_record a method type_extension : 'ctx -> type_extension -> type_extension= fun ctx -> fun { ptyext_path; ptyext_params; ptyext_constructors; ptyext_private; ptyext_loc; ptyext_attributes } -> let ptyext_path = self#longident_loc ctx ptyext_path in let ptyext_params = self#list (fun ctx -> fun (a, b) -> let a = self#core_type ctx a in let b = self#variance ctx b in (a, b)) ctx ptyext_params in let ptyext_constructors = self#list self#extension_constructor ctx ptyext_constructors in let ptyext_private = self#private_flag ctx ptyext_private in let ptyext_loc = self#location ctx ptyext_loc in let ptyext_attributes = self#attributes ctx ptyext_attributes in { ptyext_path; ptyext_params; ptyext_constructors; ptyext_private; ptyext_loc; ptyext_attributes } method extension_constructor : 'ctx -> extension_constructor -> extension_constructor= fun ctx -> fun { pext_name; pext_kind; pext_loc; pext_attributes } -> let pext_name = self#loc self#string ctx pext_name in let pext_kind = self#extension_constructor_kind ctx pext_kind in let pext_loc = self#location ctx pext_loc in let pext_attributes = self#attributes ctx pext_attributes in { pext_name; pext_kind; pext_loc; pext_attributes } method type_exception : 'ctx -> type_exception -> type_exception= fun ctx -> fun { ptyexn_constructor; ptyexn_loc; ptyexn_attributes } -> let ptyexn_constructor = self#extension_constructor ctx ptyexn_constructor in let ptyexn_loc = self#location ctx ptyexn_loc in let ptyexn_attributes = self#attributes ctx ptyexn_attributes in { ptyexn_constructor; ptyexn_loc; ptyexn_attributes } method extension_constructor_kind : 'ctx -> extension_constructor_kind -> extension_constructor_kind= fun ctx -> fun x -> match x with | Pext_decl (a, b) -> let a = self#constructor_arguments ctx a in let b = self#option self#core_type ctx b in Pext_decl (a, b) | Pext_rebind a -> let a = self#longident_loc ctx a in Pext_rebind a method class_type : 'ctx -> class_type -> class_type= fun ctx -> fun { pcty_desc; pcty_loc; pcty_attributes } -> let pcty_desc = self#class_type_desc ctx pcty_desc in let pcty_loc = self#location ctx pcty_loc in let pcty_attributes = self#attributes ctx pcty_attributes in { pcty_desc; pcty_loc; pcty_attributes } method class_type_desc : 'ctx -> class_type_desc -> class_type_desc= fun ctx -> fun x -> match x with | Pcty_constr (a, b) -> let a = self#longident_loc ctx a in let b = self#list self#core_type ctx b in Pcty_constr (a, b) | Pcty_signature a -> let a = self#class_signature ctx a in Pcty_signature a | Pcty_arrow (a, b, c) -> let a = self#arg_label ctx a in let b = self#core_type ctx b in let c = self#class_type ctx c in Pcty_arrow (a, b, c) | Pcty_extension a -> let a = self#extension ctx a in Pcty_extension a | Pcty_open (a, b) -> let a = self#open_description ctx a in let b = self#class_type ctx b in Pcty_open (a, b) method class_signature : 'ctx -> class_signature -> class_signature= fun ctx -> fun { pcsig_self; pcsig_fields } -> let pcsig_self = self#core_type ctx pcsig_self in let pcsig_fields = self#list self#class_type_field ctx pcsig_fields in { pcsig_self; pcsig_fields } method class_type_field : 'ctx -> class_type_field -> class_type_field= fun ctx -> fun { pctf_desc; pctf_loc; pctf_attributes } -> let pctf_desc = self#class_type_field_desc ctx pctf_desc in let pctf_loc = self#location ctx pctf_loc in let pctf_attributes = self#attributes ctx pctf_attributes in { pctf_desc; pctf_loc; pctf_attributes } method class_type_field_desc : 'ctx -> class_type_field_desc -> class_type_field_desc= fun ctx -> fun x -> match x with | Pctf_inherit a -> let a = self#class_type ctx a in Pctf_inherit a | Pctf_val a -> let a = (fun ctx -> fun (a, b, c, d) -> let a = self#loc self#label ctx a in let b = self#mutable_flag ctx b in let c = self#virtual_flag ctx c in let d = self#core_type ctx d in (a, b, c, d)) ctx a in Pctf_val a | Pctf_method a -> let a = (fun ctx -> fun (a, b, c, d) -> let a = self#loc self#label ctx a in let b = self#private_flag ctx b in let c = self#virtual_flag ctx c in let d = self#core_type ctx d in (a, b, c, d)) ctx a in Pctf_method a | Pctf_constraint a -> let a = (fun ctx -> fun (a, b) -> let a = self#core_type ctx a in let b = self#core_type ctx b in (a, b)) ctx a in Pctf_constraint a | Pctf_attribute a -> let a = self#attribute ctx a in Pctf_attribute a | Pctf_extension a -> let a = self#extension ctx a in Pctf_extension a method class_infos : 'a . ('ctx -> 'a -> 'a) -> 'ctx -> 'a class_infos -> 'a class_infos= fun _a -> fun ctx -> fun { pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes } -> let pci_virt = self#virtual_flag ctx pci_virt in let pci_params = self#list (fun ctx -> fun (a, b) -> let a = self#core_type ctx a in let b = self#variance ctx b in (a, b)) ctx pci_params in let pci_name = self#loc self#string ctx pci_name in let pci_expr = _a ctx pci_expr in let pci_loc = self#location ctx pci_loc in let pci_attributes = self#attributes ctx pci_attributes in { pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes } method class_description : 'ctx -> class_description -> class_description= self#class_infos self#class_type method class_type_declaration : 'ctx -> class_type_declaration -> class_type_declaration= self#class_infos self#class_type method class_expr : 'ctx -> class_expr -> class_expr= fun ctx -> fun { pcl_desc; pcl_loc; pcl_attributes } -> let pcl_desc = self#class_expr_desc ctx pcl_desc in let pcl_loc = self#location ctx pcl_loc in let pcl_attributes = self#attributes ctx pcl_attributes in { pcl_desc; pcl_loc; pcl_attributes } method class_expr_desc : 'ctx -> class_expr_desc -> class_expr_desc= fun ctx -> fun x -> match x with | Pcl_constr (a, b) -> let a = self#longident_loc ctx a in let b = self#list self#core_type ctx b in Pcl_constr (a, b) | Pcl_structure a -> let a = self#class_structure ctx a in Pcl_structure a | Pcl_fun (a, b, c, d) -> let a = self#arg_label ctx a in let b = self#option self#expression ctx b in let c = self#pattern ctx c in let d = self#class_expr ctx d in Pcl_fun (a, b, c, d) | Pcl_apply (a, b) -> let a = self#class_expr ctx a in let b = self#list (fun ctx -> fun (a, b) -> let a = self#arg_label ctx a in let b = self#expression ctx b in (a, b)) ctx b in Pcl_apply (a, b) | Pcl_let (a, b, c) -> let a = self#rec_flag ctx a in let b = self#list self#value_binding ctx b in let c = self#class_expr ctx c in Pcl_let (a, b, c) | Pcl_constraint (a, b) -> let a = self#class_expr ctx a in let b = self#class_type ctx b in Pcl_constraint (a, b) | Pcl_extension a -> let a = self#extension ctx a in Pcl_extension a | Pcl_open (a, b) -> let a = self#open_description ctx a in let b = self#class_expr ctx b in Pcl_open (a, b) method class_structure : 'ctx -> class_structure -> class_structure= fun ctx -> fun { pcstr_self; pcstr_fields } -> let pcstr_self = self#pattern ctx pcstr_self in let pcstr_fields = self#list self#class_field ctx pcstr_fields in { pcstr_self; pcstr_fields } method class_field : 'ctx -> class_field -> class_field= fun ctx -> fun { pcf_desc; pcf_loc; pcf_attributes } -> let pcf_desc = self#class_field_desc ctx pcf_desc in let pcf_loc = self#location ctx pcf_loc in let pcf_attributes = self#attributes ctx pcf_attributes in { pcf_desc; pcf_loc; pcf_attributes } method class_field_desc : 'ctx -> class_field_desc -> class_field_desc= fun ctx -> fun x -> match x with | Pcf_inherit (a, b, c) -> let a = self#override_flag ctx a in let b = self#class_expr ctx b in let c = self#option (self#loc self#string) ctx c in Pcf_inherit (a, b, c) | Pcf_val a -> let a = (fun ctx -> fun (a, b, c) -> let a = self#loc self#label ctx a in let b = self#mutable_flag ctx b in let c = self#class_field_kind ctx c in (a, b, c)) ctx a in Pcf_val a | Pcf_method a -> let a = (fun ctx -> fun (a, b, c) -> let a = self#loc self#label ctx a in let b = self#private_flag ctx b in let c = self#class_field_kind ctx c in (a, b, c)) ctx a in Pcf_method a | Pcf_constraint a -> let a = (fun ctx -> fun (a, b) -> let a = self#core_type ctx a in let b = self#core_type ctx b in (a, b)) ctx a in Pcf_constraint a | Pcf_initializer a -> let a = self#expression ctx a in Pcf_initializer a | Pcf_attribute a -> let a = self#attribute ctx a in Pcf_attribute a | Pcf_extension a -> let a = self#extension ctx a in Pcf_extension a method class_field_kind : 'ctx -> class_field_kind -> class_field_kind= fun ctx -> fun x -> match x with | Cfk_virtual a -> let a = self#core_type ctx a in Cfk_virtual a | Cfk_concrete (a, b) -> let a = self#override_flag ctx a in let b = self#expression ctx b in Cfk_concrete (a, b) method class_declaration : 'ctx -> class_declaration -> class_declaration= self#class_infos self#class_expr method module_type : 'ctx -> module_type -> module_type= fun ctx -> fun { pmty_desc; pmty_loc; pmty_attributes } -> let pmty_desc = self#module_type_desc ctx pmty_desc in let pmty_loc = self#location ctx pmty_loc in let pmty_attributes = self#attributes ctx pmty_attributes in { pmty_desc; pmty_loc; pmty_attributes } method module_type_desc : 'ctx -> module_type_desc -> module_type_desc= fun ctx -> fun x -> match x with | Pmty_ident a -> let a = self#longident_loc ctx a in Pmty_ident a | Pmty_signature a -> let a = self#signature ctx a in Pmty_signature a | Pmty_functor (a, b, c) -> let a = self#loc self#string ctx a in let b = self#option self#module_type ctx b in let c = self#module_type ctx c in Pmty_functor (a, b, c) | Pmty_with (a, b) -> let a = self#module_type ctx a in let b = self#list self#with_constraint ctx b in Pmty_with (a, b) | Pmty_typeof a -> let a = self#module_expr ctx a in Pmty_typeof a | Pmty_extension a -> let a = self#extension ctx a in Pmty_extension a | Pmty_alias a -> let a = self#longident_loc ctx a in Pmty_alias a method signature : 'ctx -> signature -> signature= self#list self#signature_item method signature_item : 'ctx -> signature_item -> signature_item= fun ctx -> fun { psig_desc; psig_loc } -> let psig_desc = self#signature_item_desc ctx psig_desc in let psig_loc = self#location ctx psig_loc in { psig_desc; psig_loc } method signature_item_desc : 'ctx -> signature_item_desc -> signature_item_desc= fun ctx -> fun x -> match x with | Psig_value a -> let a = self#value_description ctx a in Psig_value a | Psig_type (a, b) -> let a = self#rec_flag ctx a in let b = self#list self#type_declaration ctx b in Psig_type (a, b) | Psig_typesubst a -> let a = self#list self#type_declaration ctx a in Psig_typesubst a | Psig_typext a -> let a = self#type_extension ctx a in Psig_typext a | Psig_exception a -> let a = self#type_exception ctx a in Psig_exception a | Psig_module a -> let a = self#module_declaration ctx a in Psig_module a | Psig_modsubst a -> let a = self#module_substitution ctx a in Psig_modsubst a | Psig_recmodule a -> let a = self#list self#module_declaration ctx a in Psig_recmodule a | Psig_modtype a -> let a = self#module_type_declaration ctx a in Psig_modtype a | Psig_open a -> let a = self#open_description ctx a in Psig_open a | Psig_include a -> let a = self#include_description ctx a in Psig_include a | Psig_class a -> let a = self#list self#class_description ctx a in Psig_class a | Psig_class_type a -> let a = self#list self#class_type_declaration ctx a in Psig_class_type a | Psig_attribute a -> let a = self#attribute ctx a in Psig_attribute a | Psig_extension (a, b) -> let a = self#extension ctx a in let b = self#attributes ctx b in Psig_extension (a, b) method module_declaration : 'ctx -> module_declaration -> module_declaration= fun ctx -> fun { pmd_name; pmd_type; pmd_attributes; pmd_loc } -> let pmd_name = self#loc self#string ctx pmd_name in let pmd_type = self#module_type ctx pmd_type in let pmd_attributes = self#attributes ctx pmd_attributes in let pmd_loc = self#location ctx pmd_loc in { pmd_name; pmd_type; pmd_attributes; pmd_loc } method module_substitution : 'ctx -> module_substitution -> module_substitution= fun ctx -> fun { pms_name; pms_manifest; pms_attributes; pms_loc } -> let pms_name = self#loc self#string ctx pms_name in let pms_manifest = self#longident_loc ctx pms_manifest in let pms_attributes = self#attributes ctx pms_attributes in let pms_loc = self#location ctx pms_loc in { pms_name; pms_manifest; pms_attributes; pms_loc } method module_type_declaration : 'ctx -> module_type_declaration -> module_type_declaration= fun ctx -> fun { pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc } -> let pmtd_name = self#loc self#string ctx pmtd_name in let pmtd_type = self#option self#module_type ctx pmtd_type in let pmtd_attributes = self#attributes ctx pmtd_attributes in let pmtd_loc = self#location ctx pmtd_loc in { pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc } method open_infos : 'a . ('ctx -> 'a -> 'a) -> 'ctx -> 'a open_infos -> 'a open_infos= fun _a -> fun ctx -> fun { popen_expr; popen_override; popen_loc; popen_attributes } -> let popen_expr = _a ctx popen_expr in let popen_override = self#override_flag ctx popen_override in let popen_loc = self#location ctx popen_loc in let popen_attributes = self#attributes ctx popen_attributes in { popen_expr; popen_override; popen_loc; popen_attributes } method open_description : 'ctx -> open_description -> open_description= self#open_infos self#longident_loc method open_declaration : 'ctx -> open_declaration -> open_declaration= self#open_infos self#module_expr method include_infos : 'a . ('ctx -> 'a -> 'a) -> 'ctx -> 'a include_infos -> 'a include_infos= fun _a -> fun ctx -> fun { pincl_mod; pincl_loc; pincl_attributes } -> let pincl_mod = _a ctx pincl_mod in let pincl_loc = self#location ctx pincl_loc in let pincl_attributes = self#attributes ctx pincl_attributes in { pincl_mod; pincl_loc; pincl_attributes } method include_description : 'ctx -> include_description -> include_description= self#include_infos self#module_type method include_declaration : 'ctx -> include_declaration -> include_declaration= self#include_infos self#module_expr method with_constraint : 'ctx -> with_constraint -> with_constraint= fun ctx -> fun x -> match x with | Pwith_type (a, b) -> let a = self#longident_loc ctx a in let b = self#type_declaration ctx b in Pwith_type (a, b) | Pwith_module (a, b) -> let a = self#longident_loc ctx a in let b = self#longident_loc ctx b in Pwith_module (a, b) | Pwith_typesubst (a, b) -> let a = self#longident_loc ctx a in let b = self#type_declaration ctx b in Pwith_typesubst (a, b) | Pwith_modsubst (a, b) -> let a = self#longident_loc ctx a in let b = self#longident_loc ctx b in Pwith_modsubst (a, b) method module_expr : 'ctx -> module_expr -> module_expr= fun ctx -> fun { pmod_desc; pmod_loc; pmod_attributes } -> let pmod_desc = self#module_expr_desc ctx pmod_desc in let pmod_loc = self#location ctx pmod_loc in let pmod_attributes = self#attributes ctx pmod_attributes in { pmod_desc; pmod_loc; pmod_attributes } method module_expr_desc : 'ctx -> module_expr_desc -> module_expr_desc= fun ctx -> fun x -> match x with | Pmod_ident a -> let a = self#longident_loc ctx a in Pmod_ident a | Pmod_structure a -> let a = self#structure ctx a in Pmod_structure a | Pmod_functor (a, b, c) -> let a = self#loc self#string ctx a in let b = self#option self#module_type ctx b in let c = self#module_expr ctx c in Pmod_functor (a, b, c) | Pmod_apply (a, b) -> let a = self#module_expr ctx a in let b = self#module_expr ctx b in Pmod_apply (a, b) | Pmod_constraint (a, b) -> let a = self#module_expr ctx a in let b = self#module_type ctx b in Pmod_constraint (a, b) | Pmod_unpack a -> let a = self#expression ctx a in Pmod_unpack a | Pmod_extension a -> let a = self#extension ctx a in Pmod_extension a method structure : 'ctx -> structure -> structure= self#list self#structure_item method structure_item : 'ctx -> structure_item -> structure_item= fun ctx -> fun { pstr_desc; pstr_loc } -> let pstr_desc = self#structure_item_desc ctx pstr_desc in let pstr_loc = self#location ctx pstr_loc in { pstr_desc; pstr_loc } method structure_item_desc : 'ctx -> structure_item_desc -> structure_item_desc= fun ctx -> fun x -> match x with | Pstr_eval (a, b) -> let a = self#expression ctx a in let b = self#attributes ctx b in Pstr_eval (a, b) | Pstr_value (a, b) -> let a = self#rec_flag ctx a in let b = self#list self#value_binding ctx b in Pstr_value (a, b) | Pstr_primitive a -> let a = self#value_description ctx a in Pstr_primitive a | Pstr_type (a, b) -> let a = self#rec_flag ctx a in let b = self#list self#type_declaration ctx b in Pstr_type (a, b) | Pstr_typext a -> let a = self#type_extension ctx a in Pstr_typext a | Pstr_exception a -> let a = self#type_exception ctx a in Pstr_exception a | Pstr_module a -> let a = self#module_binding ctx a in Pstr_module a | Pstr_recmodule a -> let a = self#list self#module_binding ctx a in Pstr_recmodule a | Pstr_modtype a -> let a = self#module_type_declaration ctx a in Pstr_modtype a | Pstr_open a -> let a = self#open_declaration ctx a in Pstr_open a | Pstr_class a -> let a = self#list self#class_declaration ctx a in Pstr_class a | Pstr_class_type a -> let a = self#list self#class_type_declaration ctx a in Pstr_class_type a | Pstr_include a -> let a = self#include_declaration ctx a in Pstr_include a | Pstr_attribute a -> let a = self#attribute ctx a in Pstr_attribute a | Pstr_extension (a, b) -> let a = self#extension ctx a in let b = self#attributes ctx b in Pstr_extension (a, b) method value_binding : 'ctx -> value_binding -> value_binding= fun ctx -> fun { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } -> let pvb_pat = self#pattern ctx pvb_pat in let pvb_expr = self#expression ctx pvb_expr in let pvb_attributes = self#attributes ctx pvb_attributes in let pvb_loc = self#location ctx pvb_loc in { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } method module_binding : 'ctx -> module_binding -> module_binding= fun ctx -> fun { pmb_name; pmb_expr; pmb_attributes; pmb_loc } -> let pmb_name = self#loc self#string ctx pmb_name in let pmb_expr = self#module_expr ctx pmb_expr in let pmb_attributes = self#attributes ctx pmb_attributes in let pmb_loc = self#location ctx pmb_loc in { pmb_name; pmb_expr; pmb_attributes; pmb_loc } method toplevel_phrase : 'ctx -> toplevel_phrase -> toplevel_phrase= fun ctx -> fun x -> match x with | Ptop_def a -> let a = self#structure ctx a in Ptop_def a | Ptop_dir a -> let a = self#toplevel_directive ctx a in Ptop_dir a method toplevel_directive : 'ctx -> toplevel_directive -> toplevel_directive= fun ctx -> fun { pdir_name; pdir_arg; pdir_loc } -> let pdir_name = self#loc self#string ctx pdir_name in let pdir_arg = self#option self#directive_argument ctx pdir_arg in let pdir_loc = self#location ctx pdir_loc in { pdir_name; pdir_arg; pdir_loc } method directive_argument : 'ctx -> directive_argument -> directive_argument= fun ctx -> fun { pdira_desc; pdira_loc } -> let pdira_desc = self#directive_argument_desc ctx pdira_desc in let pdira_loc = self#location ctx pdira_loc in { pdira_desc; pdira_loc } method directive_argument_desc : 'ctx -> directive_argument_desc -> directive_argument_desc= fun ctx -> fun x -> match x with | Pdir_string a -> let a = self#string ctx a in Pdir_string a | Pdir_int (a, b) -> let a = self#string ctx a in let b = self#option self#char ctx b in Pdir_int (a, b) | Pdir_ident a -> let a = self#longident ctx a in Pdir_ident a | Pdir_bool a -> let a = self#bool ctx a in Pdir_bool a end class virtual ['res] lift = object (self) method virtual record : (string * 'res) list -> 'res method virtual constr : string -> 'res list -> 'rest method virtual tuple : 'res list -> 'res method virtual bool : bool -> 'res method virtual char : char -> 'res method virtual int : int -> 'res method virtual list : 'a . ('a -> 'res) -> 'a list -> 'res method virtual option : 'a . ('a -> 'res) -> 'a option -> 'res method virtual string : string -> 'res method position : position -> 'res= fun { pos_fname; pos_lnum; pos_bol; pos_cnum } -> let pos_fname = self#string pos_fname in let pos_lnum = self#int pos_lnum in let pos_bol = self#int pos_bol in let pos_cnum = self#int pos_cnum in self#record [("pos_fname", pos_fname); ("pos_lnum", pos_lnum); ("pos_bol", pos_bol); ("pos_cnum", pos_cnum)] method location : location -> 'res= fun { loc_start; loc_end; loc_ghost } -> let loc_start = self#position loc_start in let loc_end = self#position loc_end in let loc_ghost = self#bool loc_ghost in self#record [("loc_start", loc_start); ("loc_end", loc_end); ("loc_ghost", loc_ghost)] method location_stack : location_stack -> 'res= self#list self#location method loc : 'a . ('a -> 'res) -> 'a loc -> 'res= fun _a -> fun { txt; loc } -> let txt = _a txt in let loc = self#location loc in self#record [("txt", txt); ("loc", loc)] method longident : longident -> 'res= fun x -> match x with | Lident a -> let a = self#string a in self#constr "Lident" [a] | Ldot (a, b) -> let a = self#longident a in let b = self#string b in self#constr "Ldot" [a; b] | Lapply (a, b) -> let a = self#longident a in let b = self#longident b in self#constr "Lapply" [a; b] method longident_loc : longident_loc -> 'res= self#loc self#longident method rec_flag : rec_flag -> 'res= fun x -> match x with | Nonrecursive -> self#constr "Nonrecursive" [] | Recursive -> self#constr "Recursive" [] method direction_flag : direction_flag -> 'res= fun x -> match x with | Upto -> self#constr "Upto" [] | Downto -> self#constr "Downto" [] method private_flag : private_flag -> 'res= fun x -> match x with | Private -> self#constr "Private" [] | Public -> self#constr "Public" [] method mutable_flag : mutable_flag -> 'res= fun x -> match x with | Immutable -> self#constr "Immutable" [] | Mutable -> self#constr "Mutable" [] method virtual_flag : virtual_flag -> 'res= fun x -> match x with | Virtual -> self#constr "Virtual" [] | Concrete -> self#constr "Concrete" [] method override_flag : override_flag -> 'res= fun x -> match x with | Override -> self#constr "Override" [] | Fresh -> self#constr "Fresh" [] method closed_flag : closed_flag -> 'res= fun x -> match x with | Closed -> self#constr "Closed" [] | Open -> self#constr "Open" [] method label : label -> 'res= self#string method arg_label : arg_label -> 'res= fun x -> match x with | Nolabel -> self#constr "Nolabel" [] | Labelled a -> let a = self#string a in self#constr "Labelled" [a] | Optional a -> let a = self#string a in self#constr "Optional" [a] method variance : variance -> 'res= fun x -> match x with | Covariant -> self#constr "Covariant" [] | Contravariant -> self#constr "Contravariant" [] | Invariant -> self#constr "Invariant" [] method constant : constant -> 'res= fun x -> match x with | Pconst_integer (a, b) -> let a = self#string a in let b = self#option self#char b in self#constr "Pconst_integer" [a; b] | Pconst_char a -> let a = self#char a in self#constr "Pconst_char" [a] | Pconst_string (a, b) -> let a = self#string a in let b = self#option self#string b in self#constr "Pconst_string" [a; b] | Pconst_float (a, b) -> let a = self#string a in let b = self#option self#char b in self#constr "Pconst_float" [a; b] method attribute : attribute -> 'res= fun { attr_name; attr_payload; attr_loc } -> let attr_name = self#loc self#string attr_name in let attr_payload = self#payload attr_payload in let attr_loc = self#location attr_loc in self#record [("attr_name", attr_name); ("attr_payload", attr_payload); ("attr_loc", attr_loc)] method extension : extension -> 'res= fun (a, b) -> let a = self#loc self#string a in let b = self#payload b in self#tuple [a; b] method attributes : attributes -> 'res= self#list self#attribute method payload : payload -> 'res= fun x -> match x with | PStr a -> let a = self#structure a in self#constr "PStr" [a] | PSig a -> let a = self#signature a in self#constr "PSig" [a] | PTyp a -> let a = self#core_type a in self#constr "PTyp" [a] | PPat (a, b) -> let a = self#pattern a in let b = self#option self#expression b in self#constr "PPat" [a; b] method core_type : core_type -> 'res= fun { ptyp_desc; ptyp_loc; ptyp_loc_stack; ptyp_attributes } -> let ptyp_desc = self#core_type_desc ptyp_desc in let ptyp_loc = self#location ptyp_loc in let ptyp_loc_stack = self#location_stack ptyp_loc_stack in let ptyp_attributes = self#attributes ptyp_attributes in self#record [("ptyp_desc", ptyp_desc); ("ptyp_loc", ptyp_loc); ("ptyp_loc_stack", ptyp_loc_stack); ("ptyp_attributes", ptyp_attributes)] method core_type_desc : core_type_desc -> 'res= fun x -> match x with | Ptyp_any -> self#constr "Ptyp_any" [] | Ptyp_var a -> let a = self#string a in self#constr "Ptyp_var" [a] | Ptyp_arrow (a, b, c) -> let a = self#arg_label a in let b = self#core_type b in let c = self#core_type c in self#constr "Ptyp_arrow" [a; b; c] | Ptyp_tuple a -> let a = self#list self#core_type a in self#constr "Ptyp_tuple" [a] | Ptyp_constr (a, b) -> let a = self#longident_loc a in let b = self#list self#core_type b in self#constr "Ptyp_constr" [a; b] | Ptyp_object (a, b) -> let a = self#list self#object_field a in let b = self#closed_flag b in self#constr "Ptyp_object" [a; b] | Ptyp_class (a, b) -> let a = self#longident_loc a in let b = self#list self#core_type b in self#constr "Ptyp_class" [a; b] | Ptyp_alias (a, b) -> let a = self#core_type a in let b = self#string b in self#constr "Ptyp_alias" [a; b] | Ptyp_variant (a, b, c) -> let a = self#list self#row_field a in let b = self#closed_flag b in let c = self#option (self#list self#label) c in self#constr "Ptyp_variant" [a; b; c] | Ptyp_poly (a, b) -> let a = self#list (self#loc self#string) a in let b = self#core_type b in self#constr "Ptyp_poly" [a; b] | Ptyp_package a -> let a = self#package_type a in self#constr "Ptyp_package" [a] | Ptyp_extension a -> let a = self#extension a in self#constr "Ptyp_extension" [a] method package_type : package_type -> 'res= fun (a, b) -> let a = self#longident_loc a in let b = self#list (fun (a, b) -> let a = self#longident_loc a in let b = self#core_type b in self#tuple [a; b]) b in self#tuple [a; b] method row_field : row_field -> 'res= fun { prf_desc; prf_loc; prf_attributes } -> let prf_desc = self#row_field_desc prf_desc in let prf_loc = self#location prf_loc in let prf_attributes = self#attributes prf_attributes in self#record [("prf_desc", prf_desc); ("prf_loc", prf_loc); ("prf_attributes", prf_attributes)] method row_field_desc : row_field_desc -> 'res= fun x -> match x with | Rtag (a, b, c) -> let a = self#loc self#label a in let b = self#bool b in let c = self#list self#core_type c in self#constr "Rtag" [a; b; c] | Rinherit a -> let a = self#core_type a in self#constr "Rinherit" [a] method object_field : object_field -> 'res= fun { pof_desc; pof_loc; pof_attributes } -> let pof_desc = self#object_field_desc pof_desc in let pof_loc = self#location pof_loc in let pof_attributes = self#attributes pof_attributes in self#record [("pof_desc", pof_desc); ("pof_loc", pof_loc); ("pof_attributes", pof_attributes)] method object_field_desc : object_field_desc -> 'res= fun x -> match x with | Otag (a, b) -> let a = self#loc self#label a in let b = self#core_type b in self#constr "Otag" [a; b] | Oinherit a -> let a = self#core_type a in self#constr "Oinherit" [a] method pattern : pattern -> 'res= fun { ppat_desc; ppat_loc; ppat_loc_stack; ppat_attributes } -> let ppat_desc = self#pattern_desc ppat_desc in let ppat_loc = self#location ppat_loc in let ppat_loc_stack = self#location_stack ppat_loc_stack in let ppat_attributes = self#attributes ppat_attributes in self#record [("ppat_desc", ppat_desc); ("ppat_loc", ppat_loc); ("ppat_loc_stack", ppat_loc_stack); ("ppat_attributes", ppat_attributes)] method pattern_desc : pattern_desc -> 'res= fun x -> match x with | Ppat_any -> self#constr "Ppat_any" [] | Ppat_var a -> let a = self#loc self#string a in self#constr "Ppat_var" [a] | Ppat_alias (a, b) -> let a = self#pattern a in let b = self#loc self#string b in self#constr "Ppat_alias" [a; b] | Ppat_constant a -> let a = self#constant a in self#constr "Ppat_constant" [a] | Ppat_interval (a, b) -> let a = self#constant a in let b = self#constant b in self#constr "Ppat_interval" [a; b] | Ppat_tuple a -> let a = self#list self#pattern a in self#constr "Ppat_tuple" [a] | Ppat_construct (a, b) -> let a = self#longident_loc a in let b = self#option self#pattern b in self#constr "Ppat_construct" [a; b] | Ppat_variant (a, b) -> let a = self#label a in let b = self#option self#pattern b in self#constr "Ppat_variant" [a; b] | Ppat_record (a, b) -> let a = self#list (fun (a, b) -> let a = self#longident_loc a in let b = self#pattern b in self#tuple [a; b]) a in let b = self#closed_flag b in self#constr "Ppat_record" [a; b] | Ppat_array a -> let a = self#list self#pattern a in self#constr "Ppat_array" [a] | Ppat_or (a, b) -> let a = self#pattern a in let b = self#pattern b in self#constr "Ppat_or" [a; b] | Ppat_constraint (a, b) -> let a = self#pattern a in let b = self#core_type b in self#constr "Ppat_constraint" [a; b] | Ppat_type a -> let a = self#longident_loc a in self#constr "Ppat_type" [a] | Ppat_lazy a -> let a = self#pattern a in self#constr "Ppat_lazy" [a] | Ppat_unpack a -> let a = self#loc self#string a in self#constr "Ppat_unpack" [a] | Ppat_exception a -> let a = self#pattern a in self#constr "Ppat_exception" [a] | Ppat_extension a -> let a = self#extension a in self#constr "Ppat_extension" [a] | Ppat_open (a, b) -> let a = self#longident_loc a in let b = self#pattern b in self#constr "Ppat_open" [a; b] method expression : expression -> 'res= fun { pexp_desc; pexp_loc; pexp_loc_stack; pexp_attributes } -> let pexp_desc = self#expression_desc pexp_desc in let pexp_loc = self#location pexp_loc in let pexp_loc_stack = self#location_stack pexp_loc_stack in let pexp_attributes = self#attributes pexp_attributes in self#record [("pexp_desc", pexp_desc); ("pexp_loc", pexp_loc); ("pexp_loc_stack", pexp_loc_stack); ("pexp_attributes", pexp_attributes)] method expression_desc : expression_desc -> 'res= fun x -> match x with | Pexp_ident a -> let a = self#longident_loc a in self#constr "Pexp_ident" [a] | Pexp_constant a -> let a = self#constant a in self#constr "Pexp_constant" [a] | Pexp_let (a, b, c) -> let a = self#rec_flag a in let b = self#list self#value_binding b in let c = self#expression c in self#constr "Pexp_let" [a; b; c] | Pexp_function a -> let a = self#list self#case a in self#constr "Pexp_function" [a] | Pexp_fun (a, b, c, d) -> let a = self#arg_label a in let b = self#option self#expression b in let c = self#pattern c in let d = self#expression d in self#constr "Pexp_fun" [a; b; c; d] | Pexp_apply (a, b) -> let a = self#expression a in let b = self#list (fun (a, b) -> let a = self#arg_label a in let b = self#expression b in self#tuple [a; b]) b in self#constr "Pexp_apply" [a; b] | Pexp_match (a, b) -> let a = self#expression a in let b = self#list self#case b in self#constr "Pexp_match" [a; b] | Pexp_try (a, b) -> let a = self#expression a in let b = self#list self#case b in self#constr "Pexp_try" [a; b] | Pexp_tuple a -> let a = self#list self#expression a in self#constr "Pexp_tuple" [a] | Pexp_construct (a, b) -> let a = self#longident_loc a in let b = self#option self#expression b in self#constr "Pexp_construct" [a; b] | Pexp_variant (a, b) -> let a = self#label a in let b = self#option self#expression b in self#constr "Pexp_variant" [a; b] | Pexp_record (a, b) -> let a = self#list (fun (a, b) -> let a = self#longident_loc a in let b = self#expression b in self#tuple [a; b]) a in let b = self#option self#expression b in self#constr "Pexp_record" [a; b] | Pexp_field (a, b) -> let a = self#expression a in let b = self#longident_loc b in self#constr "Pexp_field" [a; b] | Pexp_setfield (a, b, c) -> let a = self#expression a in let b = self#longident_loc b in let c = self#expression c in self#constr "Pexp_setfield" [a; b; c] | Pexp_array a -> let a = self#list self#expression a in self#constr "Pexp_array" [a] | Pexp_ifthenelse (a, b, c) -> let a = self#expression a in let b = self#expression b in let c = self#option self#expression c in self#constr "Pexp_ifthenelse" [a; b; c] | Pexp_sequence (a, b) -> let a = self#expression a in let b = self#expression b in self#constr "Pexp_sequence" [a; b] | Pexp_while (a, b) -> let a = self#expression a in let b = self#expression b in self#constr "Pexp_while" [a; b] | Pexp_for (a, b, c, d, e) -> let a = self#pattern a in let b = self#expression b in let c = self#expression c in let d = self#direction_flag d in let e = self#expression e in self#constr "Pexp_for" [a; b; c; d; e] | Pexp_constraint (a, b) -> let a = self#expression a in let b = self#core_type b in self#constr "Pexp_constraint" [a; b] | Pexp_coerce (a, b, c) -> let a = self#expression a in let b = self#option self#core_type b in let c = self#core_type c in self#constr "Pexp_coerce" [a; b; c] | Pexp_send (a, b) -> let a = self#expression a in let b = self#loc self#label b in self#constr "Pexp_send" [a; b] | Pexp_new a -> let a = self#longident_loc a in self#constr "Pexp_new" [a] | Pexp_setinstvar (a, b) -> let a = self#loc self#label a in let b = self#expression b in self#constr "Pexp_setinstvar" [a; b] | Pexp_override a -> let a = self#list (fun (a, b) -> let a = self#loc self#label a in let b = self#expression b in self#tuple [a; b]) a in self#constr "Pexp_override" [a] | Pexp_letmodule (a, b, c) -> let a = self#loc self#string a in let b = self#module_expr b in let c = self#expression c in self#constr "Pexp_letmodule" [a; b; c] | Pexp_letexception (a, b) -> let a = self#extension_constructor a in let b = self#expression b in self#constr "Pexp_letexception" [a; b] | Pexp_assert a -> let a = self#expression a in self#constr "Pexp_assert" [a] | Pexp_lazy a -> let a = self#expression a in self#constr "Pexp_lazy" [a] | Pexp_poly (a, b) -> let a = self#expression a in let b = self#option self#core_type b in self#constr "Pexp_poly" [a; b] | Pexp_object a -> let a = self#class_structure a in self#constr "Pexp_object" [a] | Pexp_newtype (a, b) -> let a = self#loc self#string a in let b = self#expression b in self#constr "Pexp_newtype" [a; b] | Pexp_pack a -> let a = self#module_expr a in self#constr "Pexp_pack" [a] | Pexp_open (a, b) -> let a = self#open_declaration a in let b = self#expression b in self#constr "Pexp_open" [a; b] | Pexp_letop a -> let a = self#letop a in self#constr "Pexp_letop" [a] | Pexp_extension a -> let a = self#extension a in self#constr "Pexp_extension" [a] | Pexp_unreachable -> self#constr "Pexp_unreachable" [] method case : case -> 'res= fun { pc_lhs; pc_guard; pc_rhs } -> let pc_lhs = self#pattern pc_lhs in let pc_guard = self#option self#expression pc_guard in let pc_rhs = self#expression pc_rhs in self#record [("pc_lhs", pc_lhs); ("pc_guard", pc_guard); ("pc_rhs", pc_rhs)] method letop : letop -> 'res= fun { let_; ands; body } -> let let_ = self#binding_op let_ in let ands = self#list self#binding_op ands in let body = self#expression body in self#record [("let_", let_); ("ands", ands); ("body", body)] method binding_op : binding_op -> 'res= fun { pbop_op; pbop_pat; pbop_exp; pbop_loc } -> let pbop_op = self#loc self#string pbop_op in let pbop_pat = self#pattern pbop_pat in let pbop_exp = self#expression pbop_exp in let pbop_loc = self#location pbop_loc in self#record [("pbop_op", pbop_op); ("pbop_pat", pbop_pat); ("pbop_exp", pbop_exp); ("pbop_loc", pbop_loc)] method value_description : value_description -> 'res= fun { pval_name; pval_type; pval_prim; pval_attributes; pval_loc } -> let pval_name = self#loc self#string pval_name in let pval_type = self#core_type pval_type in let pval_prim = self#list self#string pval_prim in let pval_attributes = self#attributes pval_attributes in let pval_loc = self#location pval_loc in self#record [("pval_name", pval_name); ("pval_type", pval_type); ("pval_prim", pval_prim); ("pval_attributes", pval_attributes); ("pval_loc", pval_loc)] method type_declaration : type_declaration -> 'res= fun { ptype_name; ptype_params; ptype_cstrs; ptype_kind; ptype_private; ptype_manifest; ptype_attributes; ptype_loc } -> let ptype_name = self#loc self#string ptype_name in let ptype_params = self#list (fun (a, b) -> let a = self#core_type a in let b = self#variance b in self#tuple [a; b]) ptype_params in let ptype_cstrs = self#list (fun (a, b, c) -> let a = self#core_type a in let b = self#core_type b in let c = self#location c in self#tuple [a; b; c]) ptype_cstrs in let ptype_kind = self#type_kind ptype_kind in let ptype_private = self#private_flag ptype_private in let ptype_manifest = self#option self#core_type ptype_manifest in let ptype_attributes = self#attributes ptype_attributes in let ptype_loc = self#location ptype_loc in self#record [("ptype_name", ptype_name); ("ptype_params", ptype_params); ("ptype_cstrs", ptype_cstrs); ("ptype_kind", ptype_kind); ("ptype_private", ptype_private); ("ptype_manifest", ptype_manifest); ("ptype_attributes", ptype_attributes); ("ptype_loc", ptype_loc)] method type_kind : type_kind -> 'res= fun x -> match x with | Ptype_abstract -> self#constr "Ptype_abstract" [] | Ptype_variant a -> let a = self#list self#constructor_declaration a in self#constr "Ptype_variant" [a] | Ptype_record a -> let a = self#list self#label_declaration a in self#constr "Ptype_record" [a] | Ptype_open -> self#constr "Ptype_open" [] method label_declaration : label_declaration -> 'res= fun { pld_name; pld_mutable; pld_type; pld_loc; pld_attributes } -> let pld_name = self#loc self#string pld_name in let pld_mutable = self#mutable_flag pld_mutable in let pld_type = self#core_type pld_type in let pld_loc = self#location pld_loc in let pld_attributes = self#attributes pld_attributes in self#record [("pld_name", pld_name); ("pld_mutable", pld_mutable); ("pld_type", pld_type); ("pld_loc", pld_loc); ("pld_attributes", pld_attributes)] method constructor_declaration : constructor_declaration -> 'res= fun { pcd_name; pcd_args; pcd_res; pcd_loc; pcd_attributes } -> let pcd_name = self#loc self#string pcd_name in let pcd_args = self#constructor_arguments pcd_args in let pcd_res = self#option self#core_type pcd_res in let pcd_loc = self#location pcd_loc in let pcd_attributes = self#attributes pcd_attributes in self#record [("pcd_name", pcd_name); ("pcd_args", pcd_args); ("pcd_res", pcd_res); ("pcd_loc", pcd_loc); ("pcd_attributes", pcd_attributes)] method constructor_arguments : constructor_arguments -> 'res= fun x -> match x with | Pcstr_tuple a -> let a = self#list self#core_type a in self#constr "Pcstr_tuple" [a] | Pcstr_record a -> let a = self#list self#label_declaration a in self#constr "Pcstr_record" [a] method type_extension : type_extension -> 'res= fun { ptyext_path; ptyext_params; ptyext_constructors; ptyext_private; ptyext_loc; ptyext_attributes } -> let ptyext_path = self#longident_loc ptyext_path in let ptyext_params = self#list (fun (a, b) -> let a = self#core_type a in let b = self#variance b in self#tuple [a; b]) ptyext_params in let ptyext_constructors = self#list self#extension_constructor ptyext_constructors in let ptyext_private = self#private_flag ptyext_private in let ptyext_loc = self#location ptyext_loc in let ptyext_attributes = self#attributes ptyext_attributes in self#record [("ptyext_path", ptyext_path); ("ptyext_params", ptyext_params); ("ptyext_constructors", ptyext_constructors); ("ptyext_private", ptyext_private); ("ptyext_loc", ptyext_loc); ("ptyext_attributes", ptyext_attributes)] method extension_constructor : extension_constructor -> 'res= fun { pext_name; pext_kind; pext_loc; pext_attributes } -> let pext_name = self#loc self#string pext_name in let pext_kind = self#extension_constructor_kind pext_kind in let pext_loc = self#location pext_loc in let pext_attributes = self#attributes pext_attributes in self#record [("pext_name", pext_name); ("pext_kind", pext_kind); ("pext_loc", pext_loc); ("pext_attributes", pext_attributes)] method type_exception : type_exception -> 'res= fun { ptyexn_constructor; ptyexn_loc; ptyexn_attributes } -> let ptyexn_constructor = self#extension_constructor ptyexn_constructor in let ptyexn_loc = self#location ptyexn_loc in let ptyexn_attributes = self#attributes ptyexn_attributes in self#record [("ptyexn_constructor", ptyexn_constructor); ("ptyexn_loc", ptyexn_loc); ("ptyexn_attributes", ptyexn_attributes)] method extension_constructor_kind : extension_constructor_kind -> 'res= fun x -> match x with | Pext_decl (a, b) -> let a = self#constructor_arguments a in let b = self#option self#core_type b in self#constr "Pext_decl" [a; b] | Pext_rebind a -> let a = self#longident_loc a in self#constr "Pext_rebind" [a] method class_type : class_type -> 'res= fun { pcty_desc; pcty_loc; pcty_attributes } -> let pcty_desc = self#class_type_desc pcty_desc in let pcty_loc = self#location pcty_loc in let pcty_attributes = self#attributes pcty_attributes in self#record [("pcty_desc", pcty_desc); ("pcty_loc", pcty_loc); ("pcty_attributes", pcty_attributes)] method class_type_desc : class_type_desc -> 'res= fun x -> match x with | Pcty_constr (a, b) -> let a = self#longident_loc a in let b = self#list self#core_type b in self#constr "Pcty_constr" [a; b] | Pcty_signature a -> let a = self#class_signature a in self#constr "Pcty_signature" [a] | Pcty_arrow (a, b, c) -> let a = self#arg_label a in let b = self#core_type b in let c = self#class_type c in self#constr "Pcty_arrow" [a; b; c] | Pcty_extension a -> let a = self#extension a in self#constr "Pcty_extension" [a] | Pcty_open (a, b) -> let a = self#open_description a in let b = self#class_type b in self#constr "Pcty_open" [a; b] method class_signature : class_signature -> 'res= fun { pcsig_self; pcsig_fields } -> let pcsig_self = self#core_type pcsig_self in let pcsig_fields = self#list self#class_type_field pcsig_fields in self#record [("pcsig_self", pcsig_self); ("pcsig_fields", pcsig_fields)] method class_type_field : class_type_field -> 'res= fun { pctf_desc; pctf_loc; pctf_attributes } -> let pctf_desc = self#class_type_field_desc pctf_desc in let pctf_loc = self#location pctf_loc in let pctf_attributes = self#attributes pctf_attributes in self#record [("pctf_desc", pctf_desc); ("pctf_loc", pctf_loc); ("pctf_attributes", pctf_attributes)] method class_type_field_desc : class_type_field_desc -> 'res= fun x -> match x with | Pctf_inherit a -> let a = self#class_type a in self#constr "Pctf_inherit" [a] | Pctf_val a -> let a = (fun (a, b, c, d) -> let a = self#loc self#label a in let b = self#mutable_flag b in let c = self#virtual_flag c in let d = self#core_type d in self#tuple [a; b; c; d]) a in self#constr "Pctf_val" [a] | Pctf_method a -> let a = (fun (a, b, c, d) -> let a = self#loc self#label a in let b = self#private_flag b in let c = self#virtual_flag c in let d = self#core_type d in self#tuple [a; b; c; d]) a in self#constr "Pctf_method" [a] | Pctf_constraint a -> let a = (fun (a, b) -> let a = self#core_type a in let b = self#core_type b in self#tuple [a; b]) a in self#constr "Pctf_constraint" [a] | Pctf_attribute a -> let a = self#attribute a in self#constr "Pctf_attribute" [a] | Pctf_extension a -> let a = self#extension a in self#constr "Pctf_extension" [a] method class_infos : 'a . ('a -> 'res) -> 'a class_infos -> 'res= fun _a -> fun { pci_virt; pci_params; pci_name; pci_expr; pci_loc; pci_attributes } -> let pci_virt = self#virtual_flag pci_virt in let pci_params = self#list (fun (a, b) -> let a = self#core_type a in let b = self#variance b in self#tuple [a; b]) pci_params in let pci_name = self#loc self#string pci_name in let pci_expr = _a pci_expr in let pci_loc = self#location pci_loc in let pci_attributes = self#attributes pci_attributes in self#record [("pci_virt", pci_virt); ("pci_params", pci_params); ("pci_name", pci_name); ("pci_expr", pci_expr); ("pci_loc", pci_loc); ("pci_attributes", pci_attributes)] method class_description : class_description -> 'res= self#class_infos self#class_type method class_type_declaration : class_type_declaration -> 'res= self#class_infos self#class_type method class_expr : class_expr -> 'res= fun { pcl_desc; pcl_loc; pcl_attributes } -> let pcl_desc = self#class_expr_desc pcl_desc in let pcl_loc = self#location pcl_loc in let pcl_attributes = self#attributes pcl_attributes in self#record [("pcl_desc", pcl_desc); ("pcl_loc", pcl_loc); ("pcl_attributes", pcl_attributes)] method class_expr_desc : class_expr_desc -> 'res= fun x -> match x with | Pcl_constr (a, b) -> let a = self#longident_loc a in let b = self#list self#core_type b in self#constr "Pcl_constr" [a; b] | Pcl_structure a -> let a = self#class_structure a in self#constr "Pcl_structure" [a] | Pcl_fun (a, b, c, d) -> let a = self#arg_label a in let b = self#option self#expression b in let c = self#pattern c in let d = self#class_expr d in self#constr "Pcl_fun" [a; b; c; d] | Pcl_apply (a, b) -> let a = self#class_expr a in let b = self#list (fun (a, b) -> let a = self#arg_label a in let b = self#expression b in self#tuple [a; b]) b in self#constr "Pcl_apply" [a; b] | Pcl_let (a, b, c) -> let a = self#rec_flag a in let b = self#list self#value_binding b in let c = self#class_expr c in self#constr "Pcl_let" [a; b; c] | Pcl_constraint (a, b) -> let a = self#class_expr a in let b = self#class_type b in self#constr "Pcl_constraint" [a; b] | Pcl_extension a -> let a = self#extension a in self#constr "Pcl_extension" [a] | Pcl_open (a, b) -> let a = self#open_description a in let b = self#class_expr b in self#constr "Pcl_open" [a; b] method class_structure : class_structure -> 'res= fun { pcstr_self; pcstr_fields } -> let pcstr_self = self#pattern pcstr_self in let pcstr_fields = self#list self#class_field pcstr_fields in self#record [("pcstr_self", pcstr_self); ("pcstr_fields", pcstr_fields)] method class_field : class_field -> 'res= fun { pcf_desc; pcf_loc; pcf_attributes } -> let pcf_desc = self#class_field_desc pcf_desc in let pcf_loc = self#location pcf_loc in let pcf_attributes = self#attributes pcf_attributes in self#record [("pcf_desc", pcf_desc); ("pcf_loc", pcf_loc); ("pcf_attributes", pcf_attributes)] method class_field_desc : class_field_desc -> 'res= fun x -> match x with | Pcf_inherit (a, b, c) -> let a = self#override_flag a in let b = self#class_expr b in let c = self#option (self#loc self#string) c in self#constr "Pcf_inherit" [a; b; c] | Pcf_val a -> let a = (fun (a, b, c) -> let a = self#loc self#label a in let b = self#mutable_flag b in let c = self#class_field_kind c in self#tuple [a; b; c]) a in self#constr "Pcf_val" [a] | Pcf_method a -> let a = (fun (a, b, c) -> let a = self#loc self#label a in let b = self#private_flag b in let c = self#class_field_kind c in self#tuple [a; b; c]) a in self#constr "Pcf_method" [a] | Pcf_constraint a -> let a = (fun (a, b) -> let a = self#core_type a in let b = self#core_type b in self#tuple [a; b]) a in self#constr "Pcf_constraint" [a] | Pcf_initializer a -> let a = self#expression a in self#constr "Pcf_initializer" [a] | Pcf_attribute a -> let a = self#attribute a in self#constr "Pcf_attribute" [a] | Pcf_extension a -> let a = self#extension a in self#constr "Pcf_extension" [a] method class_field_kind : class_field_kind -> 'res= fun x -> match x with | Cfk_virtual a -> let a = self#core_type a in self#constr "Cfk_virtual" [a] | Cfk_concrete (a, b) -> let a = self#override_flag a in let b = self#expression b in self#constr "Cfk_concrete" [a; b] method class_declaration : class_declaration -> 'res= self#class_infos self#class_expr method module_type : module_type -> 'res= fun { pmty_desc; pmty_loc; pmty_attributes } -> let pmty_desc = self#module_type_desc pmty_desc in let pmty_loc = self#location pmty_loc in let pmty_attributes = self#attributes pmty_attributes in self#record [("pmty_desc", pmty_desc); ("pmty_loc", pmty_loc); ("pmty_attributes", pmty_attributes)] method module_type_desc : module_type_desc -> 'res= fun x -> match x with | Pmty_ident a -> let a = self#longident_loc a in self#constr "Pmty_ident" [a] | Pmty_signature a -> let a = self#signature a in self#constr "Pmty_signature" [a] | Pmty_functor (a, b, c) -> let a = self#loc self#string a in let b = self#option self#module_type b in let c = self#module_type c in self#constr "Pmty_functor" [a; b; c] | Pmty_with (a, b) -> let a = self#module_type a in let b = self#list self#with_constraint b in self#constr "Pmty_with" [a; b] | Pmty_typeof a -> let a = self#module_expr a in self#constr "Pmty_typeof" [a] | Pmty_extension a -> let a = self#extension a in self#constr "Pmty_extension" [a] | Pmty_alias a -> let a = self#longident_loc a in self#constr "Pmty_alias" [a] method signature : signature -> 'res= self#list self#signature_item method signature_item : signature_item -> 'res= fun { psig_desc; psig_loc } -> let psig_desc = self#signature_item_desc psig_desc in let psig_loc = self#location psig_loc in self#record [("psig_desc", psig_desc); ("psig_loc", psig_loc)] method signature_item_desc : signature_item_desc -> 'res= fun x -> match x with | Psig_value a -> let a = self#value_description a in self#constr "Psig_value" [a] | Psig_type (a, b) -> let a = self#rec_flag a in let b = self#list self#type_declaration b in self#constr "Psig_type" [a; b] | Psig_typesubst a -> let a = self#list self#type_declaration a in self#constr "Psig_typesubst" [a] | Psig_typext a -> let a = self#type_extension a in self#constr "Psig_typext" [a] | Psig_exception a -> let a = self#type_exception a in self#constr "Psig_exception" [a] | Psig_module a -> let a = self#module_declaration a in self#constr "Psig_module" [a] | Psig_modsubst a -> let a = self#module_substitution a in self#constr "Psig_modsubst" [a] | Psig_recmodule a -> let a = self#list self#module_declaration a in self#constr "Psig_recmodule" [a] | Psig_modtype a -> let a = self#module_type_declaration a in self#constr "Psig_modtype" [a] | Psig_open a -> let a = self#open_description a in self#constr "Psig_open" [a] | Psig_include a -> let a = self#include_description a in self#constr "Psig_include" [a] | Psig_class a -> let a = self#list self#class_description a in self#constr "Psig_class" [a] | Psig_class_type a -> let a = self#list self#class_type_declaration a in self#constr "Psig_class_type" [a] | Psig_attribute a -> let a = self#attribute a in self#constr "Psig_attribute" [a] | Psig_extension (a, b) -> let a = self#extension a in let b = self#attributes b in self#constr "Psig_extension" [a; b] method module_declaration : module_declaration -> 'res= fun { pmd_name; pmd_type; pmd_attributes; pmd_loc } -> let pmd_name = self#loc self#string pmd_name in let pmd_type = self#module_type pmd_type in let pmd_attributes = self#attributes pmd_attributes in let pmd_loc = self#location pmd_loc in self#record [("pmd_name", pmd_name); ("pmd_type", pmd_type); ("pmd_attributes", pmd_attributes); ("pmd_loc", pmd_loc)] method module_substitution : module_substitution -> 'res= fun { pms_name; pms_manifest; pms_attributes; pms_loc } -> let pms_name = self#loc self#string pms_name in let pms_manifest = self#longident_loc pms_manifest in let pms_attributes = self#attributes pms_attributes in let pms_loc = self#location pms_loc in self#record [("pms_name", pms_name); ("pms_manifest", pms_manifest); ("pms_attributes", pms_attributes); ("pms_loc", pms_loc)] method module_type_declaration : module_type_declaration -> 'res= fun { pmtd_name; pmtd_type; pmtd_attributes; pmtd_loc } -> let pmtd_name = self#loc self#string pmtd_name in let pmtd_type = self#option self#module_type pmtd_type in let pmtd_attributes = self#attributes pmtd_attributes in let pmtd_loc = self#location pmtd_loc in self#record [("pmtd_name", pmtd_name); ("pmtd_type", pmtd_type); ("pmtd_attributes", pmtd_attributes); ("pmtd_loc", pmtd_loc)] method open_infos : 'a . ('a -> 'res) -> 'a open_infos -> 'res= fun _a -> fun { popen_expr; popen_override; popen_loc; popen_attributes } -> let popen_expr = _a popen_expr in let popen_override = self#override_flag popen_override in let popen_loc = self#location popen_loc in let popen_attributes = self#attributes popen_attributes in self#record [("popen_expr", popen_expr); ("popen_override", popen_override); ("popen_loc", popen_loc); ("popen_attributes", popen_attributes)] method open_description : open_description -> 'res= self#open_infos self#longident_loc method open_declaration : open_declaration -> 'res= self#open_infos self#module_expr method include_infos : 'a . ('a -> 'res) -> 'a include_infos -> 'res= fun _a -> fun { pincl_mod; pincl_loc; pincl_attributes } -> let pincl_mod = _a pincl_mod in let pincl_loc = self#location pincl_loc in let pincl_attributes = self#attributes pincl_attributes in self#record [("pincl_mod", pincl_mod); ("pincl_loc", pincl_loc); ("pincl_attributes", pincl_attributes)] method include_description : include_description -> 'res= self#include_infos self#module_type method include_declaration : include_declaration -> 'res= self#include_infos self#module_expr method with_constraint : with_constraint -> 'res= fun x -> match x with | Pwith_type (a, b) -> let a = self#longident_loc a in let b = self#type_declaration b in self#constr "Pwith_type" [a; b] | Pwith_module (a, b) -> let a = self#longident_loc a in let b = self#longident_loc b in self#constr "Pwith_module" [a; b] | Pwith_typesubst (a, b) -> let a = self#longident_loc a in let b = self#type_declaration b in self#constr "Pwith_typesubst" [a; b] | Pwith_modsubst (a, b) -> let a = self#longident_loc a in let b = self#longident_loc b in self#constr "Pwith_modsubst" [a; b] method module_expr : module_expr -> 'res= fun { pmod_desc; pmod_loc; pmod_attributes } -> let pmod_desc = self#module_expr_desc pmod_desc in let pmod_loc = self#location pmod_loc in let pmod_attributes = self#attributes pmod_attributes in self#record [("pmod_desc", pmod_desc); ("pmod_loc", pmod_loc); ("pmod_attributes", pmod_attributes)] method module_expr_desc : module_expr_desc -> 'res= fun x -> match x with | Pmod_ident a -> let a = self#longident_loc a in self#constr "Pmod_ident" [a] | Pmod_structure a -> let a = self#structure a in self#constr "Pmod_structure" [a] | Pmod_functor (a, b, c) -> let a = self#loc self#string a in let b = self#option self#module_type b in let c = self#module_expr c in self#constr "Pmod_functor" [a; b; c] | Pmod_apply (a, b) -> let a = self#module_expr a in let b = self#module_expr b in self#constr "Pmod_apply" [a; b] | Pmod_constraint (a, b) -> let a = self#module_expr a in let b = self#module_type b in self#constr "Pmod_constraint" [a; b] | Pmod_unpack a -> let a = self#expression a in self#constr "Pmod_unpack" [a] | Pmod_extension a -> let a = self#extension a in self#constr "Pmod_extension" [a] method structure : structure -> 'res= self#list self#structure_item method structure_item : structure_item -> 'res= fun { pstr_desc; pstr_loc } -> let pstr_desc = self#structure_item_desc pstr_desc in let pstr_loc = self#location pstr_loc in self#record [("pstr_desc", pstr_desc); ("pstr_loc", pstr_loc)] method structure_item_desc : structure_item_desc -> 'res= fun x -> match x with | Pstr_eval (a, b) -> let a = self#expression a in let b = self#attributes b in self#constr "Pstr_eval" [a; b] | Pstr_value (a, b) -> let a = self#rec_flag a in let b = self#list self#value_binding b in self#constr "Pstr_value" [a; b] | Pstr_primitive a -> let a = self#value_description a in self#constr "Pstr_primitive" [a] | Pstr_type (a, b) -> let a = self#rec_flag a in let b = self#list self#type_declaration b in self#constr "Pstr_type" [a; b] | Pstr_typext a -> let a = self#type_extension a in self#constr "Pstr_typext" [a] | Pstr_exception a -> let a = self#type_exception a in self#constr "Pstr_exception" [a] | Pstr_module a -> let a = self#module_binding a in self#constr "Pstr_module" [a] | Pstr_recmodule a -> let a = self#list self#module_binding a in self#constr "Pstr_recmodule" [a] | Pstr_modtype a -> let a = self#module_type_declaration a in self#constr "Pstr_modtype" [a] | Pstr_open a -> let a = self#open_declaration a in self#constr "Pstr_open" [a] | Pstr_class a -> let a = self#list self#class_declaration a in self#constr "Pstr_class" [a] | Pstr_class_type a -> let a = self#list self#class_type_declaration a in self#constr "Pstr_class_type" [a] | Pstr_include a -> let a = self#include_declaration a in self#constr "Pstr_include" [a] | Pstr_attribute a -> let a = self#attribute a in self#constr "Pstr_attribute" [a] | Pstr_extension (a, b) -> let a = self#extension a in let b = self#attributes b in self#constr "Pstr_extension" [a; b] method value_binding : value_binding -> 'res= fun { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } -> let pvb_pat = self#pattern pvb_pat in let pvb_expr = self#expression pvb_expr in let pvb_attributes = self#attributes pvb_attributes in let pvb_loc = self#location pvb_loc in self#record [("pvb_pat", pvb_pat); ("pvb_expr", pvb_expr); ("pvb_attributes", pvb_attributes); ("pvb_loc", pvb_loc)] method module_binding : module_binding -> 'res= fun { pmb_name; pmb_expr; pmb_attributes; pmb_loc } -> let pmb_name = self#loc self#string pmb_name in let pmb_expr = self#module_expr pmb_expr in let pmb_attributes = self#attributes pmb_attributes in let pmb_loc = self#location pmb_loc in self#record [("pmb_name", pmb_name); ("pmb_expr", pmb_expr); ("pmb_attributes", pmb_attributes); ("pmb_loc", pmb_loc)] method toplevel_phrase : toplevel_phrase -> 'res= fun x -> match x with | Ptop_def a -> let a = self#structure a in self#constr "Ptop_def" [a] | Ptop_dir a -> let a = self#toplevel_directive a in self#constr "Ptop_dir" [a] method toplevel_directive : toplevel_directive -> 'res= fun { pdir_name; pdir_arg; pdir_loc } -> let pdir_name = self#loc self#string pdir_name in let pdir_arg = self#option self#directive_argument pdir_arg in let pdir_loc = self#location pdir_loc in self#record [("pdir_name", pdir_name); ("pdir_arg", pdir_arg); ("pdir_loc", pdir_loc)] method directive_argument : directive_argument -> 'res= fun { pdira_desc; pdira_loc } -> let pdira_desc = self#directive_argument_desc pdira_desc in let pdira_loc = self#location pdira_loc in self#record [("pdira_desc", pdira_desc); ("pdira_loc", pdira_loc)] method directive_argument_desc : directive_argument_desc -> 'res= fun x -> match x with | Pdir_string a -> let a = self#string a in self#constr "Pdir_string" [a] | Pdir_int (a, b) -> let a = self#string a in let b = self#option self#char b in self#constr "Pdir_int" [a; b] | Pdir_ident a -> let a = self#longident a in self#constr "Pdir_ident" [a] | Pdir_bool a -> let a = self#bool a in self#constr "Pdir_bool" [a] end [@@@end] ppxlib-0.12.0/ast/dune000066400000000000000000000012101360512673700145410ustar00rootroot00000000000000(library (name ppxlib_ast) (public_name ppxlib.ast) (libraries ocaml-compiler-libs.shadow ocaml-compiler-libs.common compiler-libs.common ocaml-migrate-parsetree) (flags (:standard -open Ocaml_shadow -safe-string) -w -9-27-32) (modules ast import lexer_helper location_helper misc_helper pprintast ppxlib_ast warn) (lint (pps ppxlib_traverse -deriving-keep-w32=impl))) ;; This is to make the code compatible with different versions of ;; OCaml (rule (targets location_helper.ml clflags_helper.ml misc_helper.ml) (deps gen-compiler_specifics) (action (run %{ocaml} %{deps} %{ocaml_version} %{targets}))) ppxlib-0.12.0/ast/gen-compiler_specifics000066400000000000000000000025241360512673700202300ustar00rootroot00000000000000(* -*- tuareg -*- *) open Printf let with_file path ~f = let oc = open_out_bin path in let pr fmt = fprintf oc (fmt ^^ "\n") in f pr; close_out oc let () = let ver = Scanf.sscanf Sys.argv.(1) "%u.%u" (fun a b -> a, b) in with_file Sys.argv.(2) ~f:(fun pr -> (* location_helper *) if ver < (4, 06) then pr {| let deprecated loc s = Ocaml_common.Location.prerr_warning loc (Ocaml_common.Warnings.Deprecated s) |}; if ver < (4, 08) then begin pr {| let print_error ppf loc = Ocaml_common.Location.print_error ppf loc let error_of_printer ~loc x y = Ocaml_common.Location.error_of_printer loc x y |}; end else begin pr {| let print_error ppf loc = Format.fprintf ppf "%%aError:" Ocaml_common.Location.print_loc loc let error_of_printer ~loc x y = Ocaml_common.Location.error_of_printer ~loc x y |}; end); with_file Sys.argv.(3) ~f:(fun pr -> (* clflags_helper *) if ver < (4, 08) then begin pr {| let is_unsafe () = !Ocaml_common.Clflags.fast[@ocaml.warning "-3"] |}; end else begin pr {| let is_unsafe () = !Ocaml_common.Clflags.unsafe[@ocaml.warning "-3"] |}; end); with_file Sys.argv.(4) ~f:(fun pr -> (* misc_helper *) if ver < (4, 10) then begin pr {| let may = Import.Misc.may |}; end else begin pr {| let may f = function Some v -> f v | None -> () |}; end) ppxlib-0.12.0/ast/import.ml000066400000000000000000000126571360512673700155500ustar00rootroot00000000000000(* This file is used to control what we use from the current compiler and what is embed in this library. It must be opened in all modules, especially the ones coming from the compiler. *) module Js = Migrate_parsetree.OCaml_408 module Ocaml = Migrate_parsetree.Versions.OCaml_current module Select_ast(Ocaml : Migrate_parsetree.Versions.OCaml_version) = struct open Migrate_parsetree include Js module Type = struct type ('js, 'ocaml) t = | Signature : (Js .Ast.Parsetree.signature, Ocaml.Ast.Parsetree.signature) t | Structure : (Js .Ast.Parsetree.structure, Ocaml.Ast.Parsetree.structure) t | Toplevel_phrase : (Js .Ast.Parsetree.toplevel_phrase, Ocaml.Ast.Parsetree.toplevel_phrase) t | Out_phrase : (Js .Ast.Outcometree.out_phrase, Ocaml.Ast.Outcometree.out_phrase) t | Expression : (Js .Ast.Parsetree.expression, Ocaml.Ast.Parsetree.expression) t | Core_type : (Js .Ast.Parsetree.core_type, Ocaml.Ast.Parsetree.core_type) t | Type_declaration : (Js .Ast.Parsetree.type_declaration, Ocaml.Ast.Parsetree.type_declaration) t | Type_extension : (Js .Ast.Parsetree.type_extension, Ocaml.Ast.Parsetree.type_extension) t | Extension_constructor : (Js .Ast.Parsetree.extension_constructor, Ocaml.Ast.Parsetree.extension_constructor) t | List : ('a, 'b) t -> ('a list, 'b list) t | Pair : ('a, 'b) t * ('c, 'd) t -> ('a * 'c, 'b * 'd) t end open Type module Of_ocaml = Versions.Convert(Ocaml)(Js) module To_ocaml = Versions.Convert(Js)(Ocaml) let rec of_ocaml : type ocaml js. (js, ocaml) Type.t -> ocaml -> js = let open Of_ocaml in fun node -> match node with | Signature -> copy_signature | Structure -> copy_structure | Toplevel_phrase -> copy_toplevel_phrase | Out_phrase -> copy_out_phrase | Expression -> copy_expression | Core_type -> copy_core_type | Type_declaration -> copy_type_declaration | Type_extension -> copy_type_extension | Extension_constructor -> copy_extension_constructor | List t -> List.map (of_ocaml t) | Pair (a, b) -> let f = of_ocaml a in let g = of_ocaml b in fun (x, y) -> (f x, g y) let rec to_ocaml : type ocaml js. (js, ocaml) Type.t -> js -> ocaml = let open To_ocaml in fun node -> match node with | Signature -> copy_signature | Structure -> copy_structure | Toplevel_phrase -> copy_toplevel_phrase | Out_phrase -> copy_out_phrase | Expression -> copy_expression | Core_type -> copy_core_type | Type_declaration -> copy_type_declaration | Type_extension -> copy_type_extension | Extension_constructor -> copy_extension_constructor | List t -> List.map (to_ocaml t) | Pair (a, b) -> let f = to_ocaml a in let g = to_ocaml b in fun (x, y) -> (f x, g y) let of_ocaml_mapper item f x = to_ocaml item x |> f |> of_ocaml item let to_ocaml_mapper item f x = of_ocaml item x |> f |> to_ocaml item end module Selected_ast = Select_ast(Ocaml) (* Modules from migrate_parsetree *) module Parsetree = Selected_ast.Ast.Parsetree module Asttypes = Selected_ast.Ast.Asttypes module Ast_helper = Selected_ast.Ast.Ast_helper module Docstrings = Selected_ast.Ast.Docstrings module Location = struct include Ocaml_common.Location include Location_helper end module Lexer = struct include Ocaml_common.Lexer include Lexer_helper end module Syntaxerr = struct include Ocaml_common.Syntaxerr end module Parse = struct include Ocaml_common.Parse module Of_ocaml = Migrate_parsetree.Versions.Convert(Ocaml)(Js) let implementation lexbuf = implementation lexbuf |> Of_ocaml.copy_structure let interface lexbuf = interface lexbuf |> Of_ocaml.copy_signature let toplevel_phrase lexbuf = toplevel_phrase lexbuf |> Of_ocaml.copy_toplevel_phrase let use_file lexbuf = use_file lexbuf |> List.map Of_ocaml.copy_toplevel_phrase let core_type lexbuf = core_type lexbuf |> Of_ocaml.copy_core_type let expression lexbuf = expression lexbuf |> Of_ocaml.copy_expression let pattern lexbuf = pattern lexbuf |> Of_ocaml.copy_pattern end module Parser = struct include Ocaml_common.Parser module Of_ocaml = Migrate_parsetree.Versions.Convert(Ocaml)(Js) let use_file lexer lexbuf = use_file lexer lexbuf |> List.map Of_ocaml.copy_toplevel_phrase let toplevel_phrase lexer lexbuf = toplevel_phrase lexer lexbuf |> Of_ocaml.copy_toplevel_phrase let parse_pattern lexer lexbuf = parse_pattern lexer lexbuf |> Of_ocaml.copy_pattern let parse_expression lexer lexbuf = parse_expression lexer lexbuf |> Of_ocaml.copy_expression let parse_core_type lexer lexbuf = parse_core_type lexer lexbuf |> Of_ocaml.copy_core_type let interface lexer lexbuf = interface lexer lexbuf |> Of_ocaml.copy_signature let implementation lexer lexbuf = implementation lexer lexbuf |> Of_ocaml.copy_structure end (* Modules imported directly from the compiler *) module Longident = Ocaml_common.Longident module Misc = Ocaml_common.Misc module Warnings = Ocaml_common.Warnings ppxlib-0.12.0/ast/lexer_helper.ml000066400000000000000000000024561360512673700167100ustar00rootroot00000000000000open Ocaml_common.Parser let keyword_table = Ocaml_common.Misc.create_hashtable 149 [ "and", AND; "as", AS; "assert", ASSERT; "begin", BEGIN; "class", CLASS; "constraint", CONSTRAINT; "do", DO; "done", DONE; "downto", DOWNTO; "else", ELSE; "end", END; "exception", EXCEPTION; "external", EXTERNAL; "false", FALSE; "for", FOR; "fun", FUN; "function", FUNCTION; "functor", FUNCTOR; "if", IF; "in", IN; "include", INCLUDE; "inherit", INHERIT; "initializer", INITIALIZER; "lazy", LAZY; "let", LET; "match", MATCH; "method", METHOD; "module", MODULE; "mutable", MUTABLE; "new", NEW; "nonrec", NONREC; "object", OBJECT; "of", OF; "open", OPEN; "or", OR; (* "parser", PARSER; *) "private", PRIVATE; "rec", REC; "sig", SIG; "struct", STRUCT; "then", THEN; "to", TO; "true", TRUE; "try", TRY; "type", TYPE; "val", VAL; "virtual", VIRTUAL; "when", WHEN; "while", WHILE; "with", WITH; "lor", INFIXOP3("lor"); (* Should be INFIXOP2 *) "lxor", INFIXOP3("lxor"); (* Should be INFIXOP2 *) "mod", INFIXOP3("mod"); "land", INFIXOP3("land"); "lsl", INFIXOP4("lsl"); "lsr", INFIXOP4("lsr"); "asr", INFIXOP4("asr") ] ppxlib-0.12.0/ast/pprintast.ml000066400000000000000000001652541360512673700162640ustar00rootroot00000000000000(**************************************************************************) (* *) (* OCaml *) (* *) (* Thomas Gazagnaire, OCamlPro *) (* Fabrice Le Fessant, INRIA Saclay *) (* Hongbo Zhang, University of Pennsylvania *) (* *) (* Copyright 2007 Institut National de Recherche en Informatique et *) (* en Automatique. *) (* *) (* All rights reserved. This file is distributed under the terms of *) (* the GNU Lesser General Public License version 2.1, with the *) (* special exception on linking described in the file LICENSE. *) (* *) (**************************************************************************) (* Original Code from Ber-metaocaml, modified for 3.12.0 and fixed *) (* Printing code expressions *) (* Authors: Ed Pizzi, Fabrice Le Fessant *) (* Extensive Rewrite: Hongbo Zhang: University of Pennsylvania *) (* TODO more fine-grained precedence pretty-printing *) open Import open Asttypes open Format open Location open Longident open Parsetree open Ast_helper let prefix_symbols = [ '!'; '?'; '~' ] ;; let infix_symbols = [ '='; '<'; '>'; '@'; '^'; '|'; '&'; '+'; '-'; '*'; '/'; '$'; '%'; '#' ] (* type fixity = Infix| Prefix *) let special_infix_strings = ["asr"; "land"; "lor"; "lsl"; "lsr"; "lxor"; "mod"; "or"; ":="; "!="; "::" ] let letop s = String.length s > 3 && s.[0] = 'l' && s.[1] = 'e' && s.[2] = 't' && List.mem s.[3] infix_symbols let andop s = String.length s > 3 && s.[0] = 'a' && s.[1] = 'n' && s.[2] = 'd' && List.mem s.[3] infix_symbols (* determines if the string is an infix string. checks backwards, first allowing a renaming postfix ("_102") which may have resulted from Pexp -> Texp -> Pexp translation, then checking if all the characters in the beginning of the string are valid infix characters. *) let fixity_of_string = function | "" -> `Normal | s when List.mem s special_infix_strings -> `Infix s | s when List.mem s.[0] infix_symbols -> `Infix s | s when List.mem s.[0] prefix_symbols -> `Prefix s | s when s.[0] = '.' -> `Mixfix s | s when letop s -> `Letop s | s when andop s -> `Andop s | _ -> `Normal let view_fixity_of_exp = function | {pexp_desc = Pexp_ident {txt=Lident l;_}; pexp_attributes = []} -> fixity_of_string l | _ -> `Normal let is_infix = function `Infix _ -> true | _ -> false let is_mixfix = function `Mixfix _ -> true | _ -> false let is_kwdop = function `Letop _ | `Andop _ -> true | _ -> false let first_is c str = str <> "" && str.[0] = c let last_is c str = str <> "" && str.[String.length str - 1] = c let first_is_in cs str = str <> "" && List.mem str.[0] cs (* which identifiers are in fact operators needing parentheses *) let needs_parens txt = let fix = fixity_of_string txt in is_infix fix || is_mixfix fix || is_kwdop fix || first_is_in prefix_symbols txt (* some infixes need spaces around parens to avoid clashes with comment syntax *) let needs_spaces txt = first_is '*' txt || last_is '*' txt (* add parentheses to binders when they are in fact infix or prefix operators *) let protect_ident ppf txt = let format : (_, _, _) format = if not (needs_parens txt) then "%s" else if needs_spaces txt then "(@;%s@;)" else "(%s)" in fprintf ppf format txt let protect_longident ppf print_longident longprefix txt = let format : (_, _, _) format = if not (needs_parens txt) then "%a.%s" else if needs_spaces txt then "%a.(@;%s@;)" else "%a.(%s)" in fprintf ppf format print_longident longprefix txt type space_formatter = (unit, Format.formatter, unit) format let override = function | Override -> "!" | Fresh -> "" (* variance encoding: need to sync up with the [parser.mly] *) let type_variance = function | Invariant -> "" | Covariant -> "+" | Contravariant -> "-" type construct = [ `cons of expression list | `list of expression list | `nil | `normal | `simple of Longident.t | `tuple ] let view_expr x = match x.pexp_desc with | Pexp_construct ( {txt= Lident "()"; _},_) -> `tuple | Pexp_construct ( {txt= Lident "[]";_},_) -> `nil | Pexp_construct ( {txt= Lident"::";_},Some _) -> let rec loop exp acc = match exp with | {pexp_desc=Pexp_construct ({txt=Lident "[]";_},_); pexp_attributes = []} -> (List.rev acc,true) | {pexp_desc= Pexp_construct ({txt=Lident "::";_}, Some ({pexp_desc= Pexp_tuple([e1;e2]); pexp_attributes = []})); pexp_attributes = []} -> loop e2 (e1::acc) | e -> (List.rev (e::acc),false) in let (ls,b) = loop x [] in if b then `list ls else `cons ls | Pexp_construct (x,None) -> `simple (x.txt) | _ -> `normal let is_simple_construct :construct -> bool = function | `nil | `tuple | `list _ | `simple _ -> true | `cons _ | `normal -> false let pp = fprintf type ctxt = { pipe : bool; semi : bool; ifthenelse : bool; } let reset_ctxt = { pipe=false; semi=false; ifthenelse=false } let under_pipe ctxt = { ctxt with pipe=true } let under_semi ctxt = { ctxt with semi=true } let under_ifthenelse ctxt = { ctxt with ifthenelse=true } (* let reset_semi ctxt = { ctxt with semi=false } let reset_ifthenelse ctxt = { ctxt with ifthenelse=false } let reset_pipe ctxt = { ctxt with pipe=false } *) let list : 'a . ?sep:space_formatter -> ?first:space_formatter -> ?last:space_formatter -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a list -> unit = fun ?sep ?first ?last fu f xs -> let first = match first with Some x -> x |None -> ("": _ format6) and last = match last with Some x -> x |None -> ("": _ format6) and sep = match sep with Some x -> x |None -> ("@ ": _ format6) in let aux f = function | [] -> () | [x] -> fu f x | xs -> let rec loop f = function | [x] -> fu f x | x::xs -> fu f x; pp f sep; loop f xs; | _ -> assert false in begin pp f first; loop f xs; pp f last; end in aux f xs let option : 'a. ?first:space_formatter -> ?last:space_formatter -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a option -> unit = fun ?first ?last fu f a -> let first = match first with Some x -> x | None -> ("": _ format6) and last = match last with Some x -> x | None -> ("": _ format6) in match a with | None -> () | Some x -> pp f first; fu f x; pp f last let paren: 'a . ?first:space_formatter -> ?last:space_formatter -> bool -> (Format.formatter -> 'a -> unit) -> Format.formatter -> 'a -> unit = fun ?(first=("": _ format6)) ?(last=("": _ format6)) b fu f x -> if b then (pp f "("; pp f first; fu f x; pp f last; pp f ")") else fu f x let rec longident f = function | Lident s -> protect_ident f s | Ldot(y,s) -> protect_longident f longident y s | Lapply (y,s) -> pp f "%a(%a)" longident y longident s let longident_loc f x = pp f "%a" longident x.txt let constant f = function | Pconst_char i -> pp f "%C" i | Pconst_string (i, None) -> pp f "%S" i | Pconst_string (i, Some delim) -> pp f "{%s|%s|%s}" delim i delim | Pconst_integer (i, None) -> paren (first_is '-' i) (fun f -> pp f "%s") f i | Pconst_integer (i, Some m) -> paren (first_is '-' i) (fun f (i, m) -> pp f "%s%c" i m) f (i,m) | Pconst_float (i, None) -> paren (first_is '-' i) (fun f -> pp f "%s") f i | Pconst_float (i, Some m) -> paren (first_is '-' i) (fun f (i,m) -> pp f "%s%c" i m) f (i,m) (* trailing space*) let mutable_flag f = function | Immutable -> () | Mutable -> pp f "mutable@;" let virtual_flag f = function | Concrete -> () | Virtual -> pp f "virtual@;" (* trailing space added *) let rec_flag f rf = match rf with | Nonrecursive -> () | Recursive -> pp f "rec " let nonrec_flag f rf = match rf with | Nonrecursive -> pp f "nonrec " | Recursive -> () let direction_flag f = function | Upto -> pp f "to@ " | Downto -> pp f "downto@ " let private_flag f = function | Public -> () | Private -> pp f "private@ " let iter_loc f ctxt {txt; loc = _} = f ctxt txt let constant_string f s = pp f "%S" s let tyvar ppf s = if String.length s >= 2 && s.[1] = '\'' then (* without the space, this would be parsed as a character literal *) Format.fprintf ppf "' %s" s else Format.fprintf ppf "'%s" s let tyvar_loc f str = tyvar f str.txt let string_quot f x = pp f "`%s" x (* c ['a,'b] *) let rec class_params_def ctxt f = function | [] -> () | l -> pp f "[%a] " (* space *) (list (type_param ctxt) ~sep:",") l and type_with_label ctxt f (label, c) = match label with | Nolabel -> core_type1 ctxt f c (* otherwise parenthesize *) | Labelled s -> pp f "%s:%a" s (core_type1 ctxt) c | Optional s -> pp f "?%s:%a" s (core_type1 ctxt) c and core_type ctxt f x = if x.ptyp_attributes <> [] then begin pp f "((%a)%a)" (core_type ctxt) {x with ptyp_attributes=[]} (attributes ctxt) x.ptyp_attributes end else match x.ptyp_desc with | Ptyp_arrow (l, ct1, ct2) -> pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) (type_with_label ctxt) (l,ct1) (core_type ctxt) ct2 | Ptyp_alias (ct, s) -> pp f "@[<2>%a@;as@;%a@]" (core_type1 ctxt) ct tyvar s | Ptyp_poly ([], ct) -> core_type ctxt f ct | Ptyp_poly (sl, ct) -> pp f "@[<2>%a%a@]" (fun f l -> pp f "%a" (fun f l -> match l with | [] -> () | _ -> pp f "%a@;.@;" (list tyvar_loc ~sep:"@;") l) l) sl (core_type ctxt) ct | _ -> pp f "@[<2>%a@]" (core_type1 ctxt) x and core_type1 ctxt f x = if x.ptyp_attributes <> [] then core_type ctxt f x else match x.ptyp_desc with | Ptyp_any -> pp f "_"; | Ptyp_var s -> tyvar f s; | Ptyp_tuple l -> pp f "(%a)" (list (core_type1 ctxt) ~sep:"@;*@;") l | Ptyp_constr (li, l) -> pp f (* "%a%a@;" *) "%a%a" (fun f l -> match l with |[] -> () |[x]-> pp f "%a@;" (core_type1 ctxt) x | _ -> list ~first:"(" ~last:")@;" (core_type ctxt) ~sep:",@;" f l) l longident_loc li | Ptyp_variant (l, closed, low) -> let type_variant_helper f x = match x.prf_desc with | Rtag (l, _, ctl) -> pp f "@[<2>%a%a@;%a@]" (iter_loc string_quot) l (fun f l -> match l with |[] -> () | _ -> pp f "@;of@;%a" (list (core_type ctxt) ~sep:"&") ctl) ctl (attributes ctxt) x.prf_attributes | Rinherit ct -> core_type ctxt f ct in pp f "@[<2>[%a%a]@]" (fun f l -> match l, closed with | [], Closed -> () | [], Open -> pp f ">" (* Cf #7200: print [>] correctly *) | _ -> pp f "%s@;%a" (match (closed,low) with | (Closed,None) -> "" | (Closed,Some _) -> "<" (* FIXME desugar the syntax sugar*) | (Open,_) -> ">") (list type_variant_helper ~sep:"@;<1 -2>| ") l) l (fun f low -> match low with |Some [] |None -> () |Some xs -> pp f ">@ %a" (list string_quot) xs) low | Ptyp_object (l, o) -> let core_field_type f x = match x.pof_desc with | Otag (l, ct) -> (* Cf #7200 *) pp f "@[%s: %a@ %a@ @]" l.txt (core_type ctxt) ct (attributes ctxt) x.pof_attributes | Oinherit ct -> pp f "@[%a@ @]" (core_type ctxt) ct in let field_var f = function | Asttypes.Closed -> () | Asttypes.Open -> match l with | [] -> pp f ".." | _ -> pp f " ;.." in pp f "@[<@ %a%a@ > @]" (list core_field_type ~sep:";") l field_var o (* Cf #7200 *) | Ptyp_class (li, l) -> (*FIXME*) pp f "@[%a#%a@]" (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") l longident_loc li | Ptyp_package (lid, cstrs) -> let aux f (s, ct) = pp f "type %a@ =@ %a" longident_loc s (core_type ctxt) ct in (match cstrs with |[] -> pp f "@[(module@ %a)@]" longident_loc lid |_ -> pp f "@[(module@ %a@ with@ %a)@]" longident_loc lid (list aux ~sep:"@ and@ ") cstrs) | Ptyp_extension e -> extension ctxt f e | _ -> paren true (core_type ctxt) f x (********************pattern********************) (* be cautious when use [pattern], [pattern1] is preferred *) and pattern ctxt f x = let rec list_of_pattern acc = function (* only consider ((A|B)|C)*) | {ppat_desc= Ppat_or (p1,p2); ppat_attributes = []} -> list_of_pattern (p2::acc) p1 | x -> x::acc in if x.ppat_attributes <> [] then begin pp f "((%a)%a)" (pattern ctxt) {x with ppat_attributes=[]} (attributes ctxt) x.ppat_attributes end else match x.ppat_desc with | Ppat_alias (p, s) -> pp f "@[<2>%a@;as@;%a@]" (pattern ctxt) p protect_ident s.txt (* RA*) | Ppat_or _ -> (* *) pp f "@[%a@]" (list ~sep:"@,|" (pattern ctxt)) (list_of_pattern [] x) | _ -> pattern1 ctxt f x and pattern1 ctxt (f:Format.formatter) (x:pattern) : unit = let rec pattern_list_helper f = function | {ppat_desc = Ppat_construct ({ txt = Lident("::") ;_}, Some ({ppat_desc = Ppat_tuple([pat1; pat2]);_})); ppat_attributes = []} -> pp f "%a::%a" (simple_pattern ctxt) pat1 pattern_list_helper pat2 (*RA*) | p -> pattern1 ctxt f p in if x.ppat_attributes <> [] then pattern ctxt f x else match x.ppat_desc with | Ppat_variant (l, Some p) -> pp f "@[<2>`%s@;%a@]" l (simple_pattern ctxt) p | Ppat_construct (({txt=Lident("()"|"[]");_}), _) -> simple_pattern ctxt f x | Ppat_construct (({txt;_} as li), po) -> (* FIXME The third field always false *) if txt = Lident "::" then pp f "%a" pattern_list_helper x else (match po with | Some x -> pp f "%a@;%a" longident_loc li (simple_pattern ctxt) x | None -> pp f "%a" longident_loc li) | _ -> simple_pattern ctxt f x and simple_pattern ctxt (f:Format.formatter) (x:pattern) : unit = if x.ppat_attributes <> [] then pattern ctxt f x else match x.ppat_desc with | Ppat_construct (({txt=Lident ("()"|"[]" as x);_}), _) -> pp f "%s" x | Ppat_any -> pp f "_"; | Ppat_var ({txt = txt;_}) -> protect_ident f txt | Ppat_array l -> pp f "@[<2>[|%a|]@]" (list (pattern1 ctxt) ~sep:";") l | Ppat_unpack (s) -> pp f "(module@ %s)@ " s.txt | Ppat_type li -> pp f "#%a" longident_loc li | Ppat_record (l, closed) -> let longident_x_pattern f (li, p) = match (li,p) with | ({txt=Lident s;_ }, {ppat_desc=Ppat_var {txt;_}; ppat_attributes=[]; _}) when s = txt -> pp f "@[<2>%a@]" longident_loc li | _ -> pp f "@[<2>%a@;=@;%a@]" longident_loc li (pattern1 ctxt) p in begin match closed with | Closed -> pp f "@[<2>{@;%a@;}@]" (list longident_x_pattern ~sep:";@;") l | _ -> pp f "@[<2>{@;%a;_}@]" (list longident_x_pattern ~sep:";@;") l end | Ppat_tuple l -> pp f "@[<1>(%a)@]" (list ~sep:",@;" (pattern1 ctxt)) l (* level1*) | Ppat_constant (c) -> pp f "%a" constant c | Ppat_interval (c1, c2) -> pp f "%a..%a" constant c1 constant c2 | Ppat_variant (l,None) -> pp f "`%s" l | Ppat_constraint (p, ct) -> pp f "@[<2>(%a@;:@;%a)@]" (pattern1 ctxt) p (core_type ctxt) ct | Ppat_lazy p -> pp f "@[<2>(lazy@;%a)@]" (pattern1 ctxt) p | Ppat_exception p -> pp f "@[<2>exception@;%a@]" (pattern1 ctxt) p | Ppat_extension e -> extension ctxt f e | Ppat_open (lid, p) -> let with_paren = match p.ppat_desc with | Ppat_array _ | Ppat_record _ | Ppat_construct (({txt=Lident ("()"|"[]");_}), _) -> false | _ -> true in pp f "@[<2>%a.%a @]" longident_loc lid (paren with_paren @@ pattern1 ctxt) p | _ -> paren true (pattern ctxt) f x and label_exp ctxt f (l,opt,p) = match l with | Nolabel -> (* single case pattern parens needed here *) pp f "%a@ " (simple_pattern ctxt) p | Optional rest -> begin match p with | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} when txt = rest -> (match opt with | Some o -> pp f "?(%s=@;%a)@;" rest (expression ctxt) o | None -> pp f "?%s@ " rest) | _ -> (match opt with | Some o -> pp f "?%s:(%a=@;%a)@;" rest (pattern1 ctxt) p (expression ctxt) o | None -> pp f "?%s:%a@;" rest (simple_pattern ctxt) p) end | Labelled l -> match p with | {ppat_desc = Ppat_var {txt;_}; ppat_attributes = []} when txt = l -> pp f "~%s@;" l | _ -> pp f "~%s:%a@;" l (simple_pattern ctxt) p and sugar_expr ctxt f e = if e.pexp_attributes <> [] then false else match e.pexp_desc with | Pexp_apply ({ pexp_desc = Pexp_ident {txt = id; _}; pexp_attributes=[]; _}, args) when List.for_all (fun (lab, _) -> lab = Nolabel) args -> begin let print_indexop a path_prefix assign left right print_index indices rem_args = let print_path ppf = function | None -> () | Some m -> pp ppf ".%a" longident m in match assign, rem_args with | false, [] -> pp f "@[%a%a%s%a%s@]" (simple_expr ctxt) a print_path path_prefix left (list ~sep:"," print_index) indices right; true | true, [v] -> pp f "@[%a%a%s%a%s@ <-@;<1 2>%a@]" (simple_expr ctxt) a print_path path_prefix left (list ~sep:"," print_index) indices right (simple_expr ctxt) v; true | _ -> false in match id, List.map snd args with | Lident "!", [e] -> pp f "@[!%a@]" (simple_expr ctxt) e; true | Ldot (path, ("get"|"set" as func)), a :: other_args -> begin let assign = func = "set" in let print = print_indexop a None assign in match path, other_args with | Lident "Array", i :: rest -> print ".(" ")" (expression ctxt) [i] rest | Lident "String", i :: rest -> print ".[" "]" (expression ctxt) [i] rest | Ldot (Lident "Bigarray", "Array1"), i1 :: rest -> print ".{" "}" (simple_expr ctxt) [i1] rest | Ldot (Lident "Bigarray", "Array2"), i1 :: i2 :: rest -> print ".{" "}" (simple_expr ctxt) [i1; i2] rest | Ldot (Lident "Bigarray", "Array3"), i1 :: i2 :: i3 :: rest -> print ".{" "}" (simple_expr ctxt) [i1; i2; i3] rest | Ldot (Lident "Bigarray", "Genarray"), {pexp_desc = Pexp_array indexes; pexp_attributes = []} :: rest -> print ".{" "}" (simple_expr ctxt) indexes rest | _ -> false end | (Lident s | Ldot(_,s)) , a :: i :: rest when first_is '.' s -> (* extract operator: assignment operators end with [right_bracket ^ "<-"], access operators end with [right_bracket] directly *) let assign = last_is '-' s in let kind = (* extract the right end bracket *) let n = String.length s in if assign then s.[n - 3] else s.[n - 1] in let left, right = match kind with | ')' -> '(', ")" | ']' -> '[', "]" | '}' -> '{', "}" | _ -> assert false in let path_prefix = match id with | Ldot(m,_) -> Some m | _ -> None in let left = String.sub s 0 (1+String.index s left) in print_indexop a path_prefix assign left right (expression ctxt) [i] rest | _ -> false end | _ -> false and expression ctxt f x = if x.pexp_attributes <> [] then pp f "((%a)@,%a)" (expression ctxt) {x with pexp_attributes=[]} (attributes ctxt) x.pexp_attributes else match x.pexp_desc with | Pexp_function _ | Pexp_fun _ | Pexp_match _ | Pexp_try _ | Pexp_sequence _ when ctxt.pipe || ctxt.semi -> paren true (expression reset_ctxt) f x | Pexp_ifthenelse _ | Pexp_sequence _ when ctxt.ifthenelse -> paren true (expression reset_ctxt) f x | Pexp_let _ | Pexp_letmodule _ | Pexp_open _ | Pexp_letexception _ | Pexp_letop _ when ctxt.semi -> paren true (expression reset_ctxt) f x | Pexp_fun (l, e0, p, e) -> pp f "@[<2>fun@;%a->@;%a@]" (label_exp ctxt) (l, e0, p) (expression ctxt) e | Pexp_function l -> pp f "@[function%a@]" (case_list ctxt) l | Pexp_match (e, l) -> pp f "@[@[@[<2>match %a@]@ with@]%a@]" (expression reset_ctxt) e (case_list ctxt) l | Pexp_try (e, l) -> pp f "@[<0>@[try@ %a@]@ @[<0>with%a@]@]" (* "try@;@[<2>%a@]@\nwith@\n%a"*) (expression reset_ctxt) e (case_list ctxt) l | Pexp_let (rf, l, e) -> (* pp f "@[<2>let %a%a in@;<1 -2>%a@]" (*no indentation here, a new line*) *) (* rec_flag rf *) pp f "@[<2>%a in@;<1 -2>%a@]" (bindings reset_ctxt) (rf,l) (expression ctxt) e | Pexp_apply (e, l) -> begin if not (sugar_expr ctxt f x) then match view_fixity_of_exp e with | `Infix s -> begin match l with | [ (Nolabel, _) as arg1; (Nolabel, _) as arg2 ] -> (* FIXME associativity label_x_expression_param *) pp f "@[<2>%a@;%s@;%a@]" (label_x_expression_param reset_ctxt) arg1 s (label_x_expression_param ctxt) arg2 | _ -> pp f "@[<2>%a %a@]" (simple_expr ctxt) e (list (label_x_expression_param ctxt)) l end | `Prefix s -> let s = if List.mem s ["~+";"~-";"~+.";"~-."] && (match l with (* See #7200: avoid turning (~- 1) into (- 1) which is parsed as an int literal *) |[(_,{pexp_desc=Pexp_constant _})] -> false | _ -> true) then String.sub s 1 (String.length s -1) else s in begin match l with | [(Nolabel, x)] -> pp f "@[<2>%s@;%a@]" s (simple_expr ctxt) x | _ -> pp f "@[<2>%a %a@]" (simple_expr ctxt) e (list (label_x_expression_param ctxt)) l end | _ -> pp f "@[%a@]" begin fun f (e,l) -> pp f "%a@ %a" (expression2 ctxt) e (list (label_x_expression_param reset_ctxt)) l (* reset here only because [function,match,try,sequence] are lower priority *) end (e,l) end | Pexp_construct (li, Some eo) when not (is_simple_construct (view_expr x))-> (* Not efficient FIXME*) (match view_expr x with | `cons ls -> list (simple_expr ctxt) f ls ~sep:"@;::@;" | `normal -> pp f "@[<2>%a@;%a@]" longident_loc li (simple_expr ctxt) eo | _ -> assert false) | Pexp_setfield (e1, li, e2) -> pp f "@[<2>%a.%a@ <-@ %a@]" (simple_expr ctxt) e1 longident_loc li (simple_expr ctxt) e2 | Pexp_ifthenelse (e1, e2, eo) -> (* @;@[<2>else@ %a@]@] *) let fmt:(_,_,_)format ="@[@[<2>if@ %a@]@;@[<2>then@ %a@]%a@]" in let expression_under_ifthenelse = expression (under_ifthenelse ctxt) in pp f fmt expression_under_ifthenelse e1 expression_under_ifthenelse e2 (fun f eo -> match eo with | Some x -> pp f "@;@[<2>else@;%a@]" (expression (under_semi ctxt)) x | None -> () (* pp f "()" *)) eo | Pexp_sequence _ -> let rec sequence_helper acc = function | {pexp_desc=Pexp_sequence(e1,e2); pexp_attributes = []} -> sequence_helper (e1::acc) e2 | v -> List.rev (v::acc) in let lst = sequence_helper [] x in pp f "@[%a@]" (list (expression (under_semi ctxt)) ~sep:";@;") lst | Pexp_new (li) -> pp f "@[new@ %a@]" longident_loc li; | Pexp_setinstvar (s, e) -> pp f "@[%s@ <-@ %a@]" s.txt (expression ctxt) e | Pexp_override l -> (* FIXME *) let string_x_expression f (s, e) = pp f "@[%s@ =@ %a@]" s.txt (expression ctxt) e in pp f "@[{<%a>}@]" (list string_x_expression ~sep:";" ) l; | Pexp_letmodule (s, me, e) -> pp f "@[let@ module@ %s@ =@ %a@ in@ %a@]" s.txt (module_expr reset_ctxt) me (expression ctxt) e | Pexp_letexception (cd, e) -> pp f "@[let@ exception@ %a@ in@ %a@]" (extension_constructor ctxt) cd (expression ctxt) e | Pexp_assert e -> pp f "@[assert@ %a@]" (simple_expr ctxt) e | Pexp_lazy (e) -> pp f "@[lazy@ %a@]" (simple_expr ctxt) e (* Pexp_poly: impossible but we should print it anyway, rather than assert false *) | Pexp_poly (e, None) -> pp f "@[!poly!@ %a@]" (simple_expr ctxt) e | Pexp_poly (e, Some ct) -> pp f "@[(!poly!@ %a@ : %a)@]" (simple_expr ctxt) e (core_type ctxt) ct | Pexp_open (o, e) -> pp f "@[<2>let open%s %a in@;%a@]" (override o.popen_override) (module_expr ctxt) o.popen_expr (expression ctxt) e | Pexp_variant (l,Some eo) -> pp f "@[<2>`%s@;%a@]" l (simple_expr ctxt) eo | Pexp_letop {let_; ands; body} -> pp f "@[<2>@[%a@,%a@] in@;<1 -2>%a@]" (binding_op ctxt) let_ (list ~sep:"@," (binding_op ctxt)) ands (expression ctxt) body | Pexp_extension e -> extension ctxt f e | Pexp_unreachable -> pp f "." | _ -> expression1 ctxt f x and expression1 ctxt f x = if x.pexp_attributes <> [] then expression ctxt f x else match x.pexp_desc with | Pexp_object cs -> pp f "%a" (class_structure ctxt) cs | _ -> expression2 ctxt f x (* used in [Pexp_apply] *) and expression2 ctxt f x = if x.pexp_attributes <> [] then expression ctxt f x else match x.pexp_desc with | Pexp_field (e, li) -> pp f "@[%a.%a@]" (simple_expr ctxt) e longident_loc li | Pexp_send (e, s) -> pp f "@[%a#%s@]" (simple_expr ctxt) e s.txt | _ -> simple_expr ctxt f x and simple_expr ctxt f x = if x.pexp_attributes <> [] then expression ctxt f x else match x.pexp_desc with | Pexp_construct _ when is_simple_construct (view_expr x) -> (match view_expr x with | `nil -> pp f "[]" | `tuple -> pp f "()" | `list xs -> pp f "@[[%a]@]" (list (expression (under_semi ctxt)) ~sep:";@;") xs | `simple x -> longident f x | _ -> assert false) | Pexp_ident li -> longident_loc f li (* (match view_fixity_of_exp x with *) (* |`Normal -> longident_loc f li *) (* | `Prefix _ | `Infix _ -> pp f "( %a )" longident_loc li) *) | Pexp_constant c -> constant f c; | Pexp_pack me -> pp f "(module@;%a)" (module_expr ctxt) me | Pexp_newtype (lid, e) -> pp f "fun@;(type@;%s)@;->@;%a" lid.txt (expression ctxt) e | Pexp_tuple l -> pp f "@[(%a)@]" (list (simple_expr ctxt) ~sep:",@;") l | Pexp_constraint (e, ct) -> pp f "(%a : %a)" (expression ctxt) e (core_type ctxt) ct | Pexp_coerce (e, cto1, ct) -> pp f "(%a%a :> %a)" (expression ctxt) e (option (core_type ctxt) ~first:" : " ~last:" ") cto1 (* no sep hint*) (core_type ctxt) ct | Pexp_variant (l, None) -> pp f "`%s" l | Pexp_record (l, eo) -> let longident_x_expression f ( li, e) = match e with | {pexp_desc=Pexp_ident {txt;_}; pexp_attributes=[]; _} when li.txt = txt -> pp f "@[%a@]" longident_loc li | _ -> pp f "@[%a@;=@;%a@]" longident_loc li (simple_expr ctxt) e in pp f "@[@[{@;%a%a@]@;}@]"(* "@[{%a%a}@]" *) (option ~last:" with@;" (simple_expr ctxt)) eo (list longident_x_expression ~sep:";@;") l | Pexp_array (l) -> pp f "@[<0>@[<2>[|%a|]@]@]" (list (simple_expr (under_semi ctxt)) ~sep:";") l | Pexp_while (e1, e2) -> let fmt : (_,_,_) format = "@[<2>while@;%a@;do@;%a@;done@]" in pp f fmt (expression ctxt) e1 (expression ctxt) e2 | Pexp_for (s, e1, e2, df, e3) -> let fmt:(_,_,_)format = "@[@[@[<2>for %a =@;%a@;%a%a@;do@]@;%a@]@;done@]" in let expression = expression ctxt in pp f fmt (pattern ctxt) s expression e1 direction_flag df expression e2 expression e3 | _ -> paren true (expression ctxt) f x and attributes ctxt f l = List.iter (attribute ctxt f) l and item_attributes ctxt f l = List.iter (item_attribute ctxt f) l and attribute ctxt f a = pp f "@[<2>[@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload and item_attribute ctxt f a = pp f "@[<2>[@@@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload and floating_attribute ctxt f a = pp f "@[<2>[@@@@@@%s@ %a]@]" a.attr_name.txt (payload ctxt) a.attr_payload and value_description ctxt f x = (* note: value_description has an attribute field, but they're already printed by the callers this method *) pp f "@[%a%a@]" (core_type ctxt) x.pval_type (fun f x -> if x.pval_prim <> [] then pp f "@ =@ %a" (list constant_string) x.pval_prim ) x and extension ctxt f (s, e) = pp f "@[<2>[%%%s@ %a]@]" s.txt (payload ctxt) e and item_extension ctxt f (s, e) = pp f "@[<2>[%%%%%s@ %a]@]" s.txt (payload ctxt) e and exception_declaration ctxt f x = pp f "@[exception@ %a@]%a" (extension_constructor ctxt) x.ptyexn_constructor (item_attributes ctxt) x.ptyexn_attributes and class_type_field ctxt f x = match x.pctf_desc with | Pctf_inherit (ct) -> pp f "@[<2>inherit@ %a@]%a" (class_type ctxt) ct (item_attributes ctxt) x.pctf_attributes | Pctf_val (s, mf, vf, ct) -> pp f "@[<2>val @ %a%a%s@ :@ %a@]%a" mutable_flag mf virtual_flag vf s.txt (core_type ctxt) ct (item_attributes ctxt) x.pctf_attributes | Pctf_method (s, pf, vf, ct) -> pp f "@[<2>method %a %a%s :@;%a@]%a" private_flag pf virtual_flag vf s.txt (core_type ctxt) ct (item_attributes ctxt) x.pctf_attributes | Pctf_constraint (ct1, ct2) -> pp f "@[<2>constraint@ %a@ =@ %a@]%a" (core_type ctxt) ct1 (core_type ctxt) ct2 (item_attributes ctxt) x.pctf_attributes | Pctf_attribute a -> floating_attribute ctxt f a | Pctf_extension e -> item_extension ctxt f e; item_attributes ctxt f x.pctf_attributes and class_signature ctxt f { pcsig_self = ct; pcsig_fields = l ;_} = pp f "@[@[object@[<1>%a@]@ %a@]@ end@]" (fun f -> function {ptyp_desc=Ptyp_any; ptyp_attributes=[]; _} -> () | ct -> pp f " (%a)" (core_type ctxt) ct) ct (list (class_type_field ctxt) ~sep:"@;") l (* call [class_signature] called by [class_signature] *) and class_type ctxt f x = match x.pcty_desc with | Pcty_signature cs -> class_signature ctxt f cs; attributes ctxt f x.pcty_attributes | Pcty_constr (li, l) -> pp f "%a%a%a" (fun f l -> match l with | [] -> () | _ -> pp f "[%a]@ " (list (core_type ctxt) ~sep:"," ) l) l longident_loc li (attributes ctxt) x.pcty_attributes | Pcty_arrow (l, co, cl) -> pp f "@[<2>%a@;->@;%a@]" (* FIXME remove parens later *) (type_with_label ctxt) (l,co) (class_type ctxt) cl | Pcty_extension e -> extension ctxt f e; attributes ctxt f x.pcty_attributes | Pcty_open (o, e) -> pp f "@[<2>let open%s %a in@;%a@]" (override o.popen_override) longident_loc o.popen_expr (class_type ctxt) e (* [class type a = object end] *) and class_type_declaration_list ctxt f l = let class_type_declaration kwd f x = let { pci_params=ls; pci_name={ txt; _ }; _ } = x in pp f "@[<2>%s %a%a%s@ =@ %a@]%a" kwd virtual_flag x.pci_virt (class_params_def ctxt) ls txt (class_type ctxt) x.pci_expr (item_attributes ctxt) x.pci_attributes in match l with | [] -> () | [x] -> class_type_declaration "class type" f x | x :: xs -> pp f "@[%a@,%a@]" (class_type_declaration "class type") x (list ~sep:"@," (class_type_declaration "and")) xs and class_field ctxt f x = match x.pcf_desc with | Pcf_inherit (ovf, ce, so) -> pp f "@[<2>inherit@ %s@ %a%a@]%a" (override ovf) (class_expr ctxt) ce (fun f so -> match so with | None -> (); | Some (s) -> pp f "@ as %s" s.txt ) so (item_attributes ctxt) x.pcf_attributes | Pcf_val (s, mf, Cfk_concrete (ovf, e)) -> pp f "@[<2>val%s %a%s =@;%a@]%a" (override ovf) mutable_flag mf s.txt (expression ctxt) e (item_attributes ctxt) x.pcf_attributes | Pcf_method (s, pf, Cfk_virtual ct) -> pp f "@[<2>method virtual %a %s :@;%a@]%a" private_flag pf s.txt (core_type ctxt) ct (item_attributes ctxt) x.pcf_attributes | Pcf_val (s, mf, Cfk_virtual ct) -> pp f "@[<2>val virtual %a%s :@ %a@]%a" mutable_flag mf s.txt (core_type ctxt) ct (item_attributes ctxt) x.pcf_attributes | Pcf_method (s, pf, Cfk_concrete (ovf, e)) -> let bind e = binding ctxt f {pvb_pat= {ppat_desc=Ppat_var s; ppat_loc=Location.none; ppat_loc_stack=[]; ppat_attributes=[]}; pvb_expr=e; pvb_attributes=[]; pvb_loc=Location.none; } in pp f "@[<2>method%s %a%a@]%a" (override ovf) private_flag pf (fun f -> function | {pexp_desc=Pexp_poly (e, Some ct); pexp_attributes=[]; _} -> pp f "%s :@;%a=@;%a" s.txt (core_type ctxt) ct (expression ctxt) e | {pexp_desc=Pexp_poly (e, None); pexp_attributes=[]; _} -> bind e | _ -> bind e) e (item_attributes ctxt) x.pcf_attributes | Pcf_constraint (ct1, ct2) -> pp f "@[<2>constraint %a =@;%a@]%a" (core_type ctxt) ct1 (core_type ctxt) ct2 (item_attributes ctxt) x.pcf_attributes | Pcf_initializer (e) -> pp f "@[<2>initializer@ %a@]%a" (expression ctxt) e (item_attributes ctxt) x.pcf_attributes | Pcf_attribute a -> floating_attribute ctxt f a | Pcf_extension e -> item_extension ctxt f e; item_attributes ctxt f x.pcf_attributes and class_structure ctxt f { pcstr_self = p; pcstr_fields = l } = pp f "@[@[object%a@;%a@]@;end@]" (fun f p -> match p.ppat_desc with | Ppat_any -> () | Ppat_constraint _ -> pp f " %a" (pattern ctxt) p | _ -> pp f " (%a)" (pattern ctxt) p) p (list (class_field ctxt)) l and class_expr ctxt f x = if x.pcl_attributes <> [] then begin pp f "((%a)%a)" (class_expr ctxt) {x with pcl_attributes=[]} (attributes ctxt) x.pcl_attributes end else match x.pcl_desc with | Pcl_structure (cs) -> class_structure ctxt f cs | Pcl_fun (l, eo, p, e) -> pp f "fun@ %a@ ->@ %a" (label_exp ctxt) (l,eo,p) (class_expr ctxt) e | Pcl_let (rf, l, ce) -> pp f "%a@ in@ %a" (bindings ctxt) (rf,l) (class_expr ctxt) ce | Pcl_apply (ce, l) -> pp f "((%a)@ %a)" (* Cf: #7200 *) (class_expr ctxt) ce (list (label_x_expression_param ctxt)) l | Pcl_constr (li, l) -> pp f "%a%a" (fun f l-> if l <>[] then pp f "[%a]@ " (list (core_type ctxt) ~sep:",") l) l longident_loc li | Pcl_constraint (ce, ct) -> pp f "(%a@ :@ %a)" (class_expr ctxt) ce (class_type ctxt) ct | Pcl_extension e -> extension ctxt f e | Pcl_open (o, e) -> pp f "@[<2>let open%s %a in@;%a@]" (override o.popen_override) longident_loc o.popen_expr (class_expr ctxt) e and module_type ctxt f x = if x.pmty_attributes <> [] then begin pp f "((%a)%a)" (module_type ctxt) {x with pmty_attributes=[]} (attributes ctxt) x.pmty_attributes end else match x.pmty_desc with | Pmty_functor (_, None, mt2) -> pp f "@[functor () ->@ %a@]" (module_type ctxt) mt2 | Pmty_functor (s, Some mt1, mt2) -> if s.txt = "_" then pp f "@[%a@ ->@ %a@]" (module_type1 ctxt) mt1 (module_type ctxt) mt2 else pp f "@[functor@ (%s@ :@ %a)@ ->@ %a@]" s.txt (module_type ctxt) mt1 (module_type ctxt) mt2 | Pmty_with (mt, []) -> module_type ctxt f mt | Pmty_with (mt, l) -> let with_constraint f = function | Pwith_type (li, ({ptype_params= ls ;_} as td)) -> let ls = List.map fst ls in pp f "type@ %a %a =@ %a" (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") ls longident_loc li (type_declaration ctxt) td | Pwith_module (li, li2) -> pp f "module %a =@ %a" longident_loc li longident_loc li2; | Pwith_typesubst (li, ({ptype_params=ls;_} as td)) -> let ls = List.map fst ls in pp f "type@ %a %a :=@ %a" (list (core_type ctxt) ~sep:"," ~first:"(" ~last:")") ls longident_loc li (type_declaration ctxt) td | Pwith_modsubst (li, li2) -> pp f "module %a :=@ %a" longident_loc li longident_loc li2 in pp f "@[%a@ with@ %a@]" (module_type1 ctxt) mt (list with_constraint ~sep:"@ and@ ") l | _ -> module_type1 ctxt f x and module_type1 ctxt f x = if x.pmty_attributes <> [] then module_type ctxt f x else match x.pmty_desc with | Pmty_ident li -> pp f "%a" longident_loc li; | Pmty_alias li -> pp f "(module %a)" longident_loc li; | Pmty_signature (s) -> pp f "@[@[sig@ %a@]@ end@]" (* "@[sig@ %a@ end@]" *) (list (signature_item ctxt)) s (* FIXME wrong indentation*) | Pmty_typeof me -> pp f "@[module@ type@ of@ %a@]" (module_expr ctxt) me | Pmty_extension e -> extension ctxt f e | _ -> paren true (module_type ctxt) f x and signature ctxt f x = list ~sep:"@\n" (signature_item ctxt) f x and signature_item ctxt f x : unit = match x.psig_desc with | Psig_type (rf, l) -> type_def_list ctxt f (rf, true, l) | Psig_typesubst l -> type_def_list ctxt f (Nonrecursive, false, l) | Psig_value vd -> let intro = if vd.pval_prim = [] then "val" else "external" in pp f "@[<2>%s@ %a@ :@ %a@]%a" intro protect_ident vd.pval_name.txt (value_description ctxt) vd (item_attributes ctxt) vd.pval_attributes | Psig_typext te -> type_extension ctxt f te | Psig_exception ed -> exception_declaration ctxt f ed | Psig_class l -> let class_description kwd f ({pci_params=ls;pci_name={txt;_};_} as x) = pp f "@[<2>%s %a%a%s@;:@;%a@]%a" kwd virtual_flag x.pci_virt (class_params_def ctxt) ls txt (class_type ctxt) x.pci_expr (item_attributes ctxt) x.pci_attributes in begin match l with | [] -> () | [x] -> class_description "class" f x | x :: xs -> pp f "@[%a@,%a@]" (class_description "class") x (list ~sep:"@," (class_description "and")) xs end | Psig_module ({pmd_type={pmty_desc=Pmty_alias alias; pmty_attributes=[]; _};_} as pmd) -> pp f "@[module@ %s@ =@ %a@]%a" pmd.pmd_name.txt longident_loc alias (item_attributes ctxt) pmd.pmd_attributes | Psig_module pmd -> pp f "@[module@ %s@ :@ %a@]%a" pmd.pmd_name.txt (module_type ctxt) pmd.pmd_type (item_attributes ctxt) pmd.pmd_attributes | Psig_modsubst pms -> pp f "@[module@ %s@ :=@ %a@]%a" pms.pms_name.txt longident_loc pms.pms_manifest (item_attributes ctxt) pms.pms_attributes | Psig_open od -> pp f "@[open%s@ %a@]%a" (override od.popen_override) longident_loc od.popen_expr (item_attributes ctxt) od.popen_attributes | Psig_include incl -> pp f "@[include@ %a@]%a" (module_type ctxt) incl.pincl_mod (item_attributes ctxt) incl.pincl_attributes | Psig_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> pp f "@[module@ type@ %s%a@]%a" s.txt (fun f md -> match md with | None -> () | Some mt -> pp_print_space f () ; pp f "@ =@ %a" (module_type ctxt) mt ) md (item_attributes ctxt) attrs | Psig_class_type (l) -> class_type_declaration_list ctxt f l | Psig_recmodule decls -> let rec string_x_module_type_list f ?(first=true) l = match l with | [] -> () ; | pmd :: tl -> if not first then pp f "@ @[and@ %s:@ %a@]%a" pmd.pmd_name.txt (module_type1 ctxt) pmd.pmd_type (item_attributes ctxt) pmd.pmd_attributes else pp f "@[module@ rec@ %s:@ %a@]%a" pmd.pmd_name.txt (module_type1 ctxt) pmd.pmd_type (item_attributes ctxt) pmd.pmd_attributes; string_x_module_type_list f ~first:false tl in string_x_module_type_list f decls | Psig_attribute a -> floating_attribute ctxt f a | Psig_extension(e, a) -> item_extension ctxt f e; item_attributes ctxt f a and module_expr ctxt f x = if x.pmod_attributes <> [] then pp f "((%a)%a)" (module_expr ctxt) {x with pmod_attributes=[]} (attributes ctxt) x.pmod_attributes else match x.pmod_desc with | Pmod_structure (s) -> pp f "@[struct@;@[<0>%a@]@;<1 -2>end@]" (list (structure_item ctxt) ~sep:"@\n") s; | Pmod_constraint (me, mt) -> pp f "@[(%a@ :@ %a)@]" (module_expr ctxt) me (module_type ctxt) mt | Pmod_ident (li) -> pp f "%a" longident_loc li; | Pmod_functor (_, None, me) -> pp f "functor ()@;->@;%a" (module_expr ctxt) me | Pmod_functor (s, Some mt, me) -> pp f "functor@ (%s@ :@ %a)@;->@;%a" s.txt (module_type ctxt) mt (module_expr ctxt) me | Pmod_apply (me1, me2) -> pp f "(%a)(%a)" (module_expr ctxt) me1 (module_expr ctxt) me2 (* Cf: #7200 *) | Pmod_unpack e -> pp f "(val@ %a)" (expression ctxt) e | Pmod_extension e -> extension ctxt f e and structure ctxt f x = list ~sep:"@\n" (structure_item ctxt) f x and payload ctxt f = function | PStr [{pstr_desc = Pstr_eval (e, attrs)}] -> pp f "@[<2>%a@]%a" (expression ctxt) e (item_attributes ctxt) attrs | PStr x -> structure ctxt f x | PTyp x -> pp f ":"; core_type ctxt f x | PSig x -> pp f ":"; signature ctxt f x | PPat (x, None) -> pp f "?"; pattern ctxt f x | PPat (x, Some e) -> pp f "?"; pattern ctxt f x; pp f " when "; expression ctxt f e (* transform [f = fun g h -> ..] to [f g h = ... ] could be improved *) and binding ctxt f {pvb_pat=p; pvb_expr=x; _} = (* .pvb_attributes have already been printed by the caller, #bindings *) let rec pp_print_pexp_function f x = if x.pexp_attributes <> [] then pp f "=@;%a" (expression ctxt) x else match x.pexp_desc with | Pexp_fun (label, eo, p, e) -> if label=Nolabel then pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function e else pp f "%a@ %a" (label_exp ctxt) (label,eo,p) pp_print_pexp_function e | Pexp_newtype (str,e) -> pp f "(type@ %s)@ %a" str.txt pp_print_pexp_function e | _ -> pp f "=@;%a" (expression ctxt) x in let tyvars_str tyvars = List.map (fun v -> v.txt) tyvars in let is_desugared_gadt p e = let gadt_pattern = match p with | {ppat_desc=Ppat_constraint({ppat_desc=Ppat_var _} as pat, {ptyp_desc=Ptyp_poly (args_tyvars, rt)}); ppat_attributes=[]}-> Some (pat, args_tyvars, rt) | _ -> None in let rec gadt_exp tyvars e = match e with | {pexp_desc=Pexp_newtype (tyvar, e); pexp_attributes=[]} -> gadt_exp (tyvar :: tyvars) e | {pexp_desc=Pexp_constraint (e, ct); pexp_attributes=[]} -> Some (List.rev tyvars, e, ct) | _ -> None in let gadt_exp = gadt_exp [] e in match gadt_pattern, gadt_exp with | Some (p, pt_tyvars, pt_ct), Some (e_tyvars, e, e_ct) when tyvars_str pt_tyvars = tyvars_str e_tyvars -> let ety = Typ.varify_constructors e_tyvars e_ct in if ety = pt_ct then Some (p, pt_tyvars, e_ct, e) else None | _ -> None in if x.pexp_attributes <> [] then pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x else match is_desugared_gadt p x with | Some (p, [], ct, e) -> pp f "%a@;: %a@;=@;%a" (simple_pattern ctxt) p (core_type ctxt) ct (expression ctxt) e | Some (p, tyvars, ct, e) -> begin pp f "%a@;: type@;%a.@;%a@;=@;%a" (simple_pattern ctxt) p (list pp_print_string ~sep:"@;") (tyvars_str tyvars) (core_type ctxt) ct (expression ctxt) e end | None -> begin match p with | {ppat_desc=Ppat_constraint(p ,ty); ppat_attributes=[]} -> (* special case for the first*) begin match ty with | {ptyp_desc=Ptyp_poly _; ptyp_attributes=[]} -> pp f "%a@;:@;%a@;=@;%a" (simple_pattern ctxt) p (core_type ctxt) ty (expression ctxt) x | _ -> pp f "(%a@;:@;%a)@;=@;%a" (simple_pattern ctxt) p (core_type ctxt) ty (expression ctxt) x end | {ppat_desc=Ppat_var _; ppat_attributes=[]} -> pp f "%a@ %a" (simple_pattern ctxt) p pp_print_pexp_function x | _ -> pp f "%a@;=@;%a" (pattern ctxt) p (expression ctxt) x end (* [in] is not printed *) and bindings ctxt f (rf,l) = let binding kwd rf f x = pp f "@[<2>%s %a%a@]%a" kwd rec_flag rf (binding ctxt) x (item_attributes ctxt) x.pvb_attributes in match l with | [] -> () | [x] -> binding "let" rf f x | x::xs -> pp f "@[%a@,%a@]" (binding "let" rf) x (list ~sep:"@," (binding "and" Nonrecursive)) xs and binding_op ctxt f x = pp f "@[<2>%s %a@;=@;%a@]" x.pbop_op.txt (pattern ctxt) x.pbop_pat (expression ctxt) x.pbop_exp and structure_item ctxt f x = match x.pstr_desc with | Pstr_eval (e, attrs) -> pp f "@[;;%a@]%a" (expression ctxt) e (item_attributes ctxt) attrs | Pstr_type (_, []) -> assert false | Pstr_type (rf, l) -> type_def_list ctxt f (rf, true, l) | Pstr_value (rf, l) -> (* pp f "@[let %a%a@]" rec_flag rf bindings l *) pp f "@[<2>%a@]" (bindings ctxt) (rf,l) | Pstr_typext te -> type_extension ctxt f te | Pstr_exception ed -> exception_declaration ctxt f ed | Pstr_module x -> let rec module_helper = function | {pmod_desc=Pmod_functor(s,mt,me'); pmod_attributes = []} -> if mt = None then pp f "()" else Misc_helper.may (pp f "(%s:%a)" s.txt (module_type ctxt)) mt; module_helper me' | me -> me in pp f "@[module %s%a@]%a" x.pmb_name.txt (fun f me -> let me = module_helper me in match me with | {pmod_desc= Pmod_constraint (me', ({pmty_desc=(Pmty_ident (_) | Pmty_signature (_));_} as mt)); pmod_attributes = []} -> pp f " :@;%a@;=@;%a@;" (module_type ctxt) mt (module_expr ctxt) me' | _ -> pp f " =@ %a" (module_expr ctxt) me ) x.pmb_expr (item_attributes ctxt) x.pmb_attributes | Pstr_open od -> pp f "@[<2>open%s@;%a@]%a" (override od.popen_override) (module_expr ctxt) od.popen_expr (item_attributes ctxt) od.popen_attributes | Pstr_modtype {pmtd_name=s; pmtd_type=md; pmtd_attributes=attrs} -> pp f "@[module@ type@ %s%a@]%a" s.txt (fun f md -> match md with | None -> () | Some mt -> pp_print_space f () ; pp f "@ =@ %a" (module_type ctxt) mt ) md (item_attributes ctxt) attrs | Pstr_class l -> let extract_class_args cl = let rec loop acc = function | {pcl_desc=Pcl_fun (l, eo, p, cl'); pcl_attributes = []} -> loop ((l,eo,p) :: acc) cl' | cl -> List.rev acc, cl in let args, cl = loop [] cl in let constr, cl = match cl with | {pcl_desc=Pcl_constraint (cl', ct); pcl_attributes = []} -> Some ct, cl' | _ -> None, cl in args, constr, cl in let class_constraint f ct = pp f ": @[%a@] " (class_type ctxt) ct in let class_declaration kwd f ({pci_params=ls; pci_name={txt;_}; _} as x) = let args, constr, cl = extract_class_args x.pci_expr in pp f "@[<2>%s %a%a%s %a%a=@;%a@]%a" kwd virtual_flag x.pci_virt (class_params_def ctxt) ls txt (list (label_exp ctxt)) args (option class_constraint) constr (class_expr ctxt) cl (item_attributes ctxt) x.pci_attributes in begin match l with | [] -> () | [x] -> class_declaration "class" f x | x :: xs -> pp f "@[%a@,%a@]" (class_declaration "class") x (list ~sep:"@," (class_declaration "and")) xs end | Pstr_class_type l -> class_type_declaration_list ctxt f l | Pstr_primitive vd -> pp f "@[external@ %a@ :@ %a@]%a" protect_ident vd.pval_name.txt (value_description ctxt) vd (item_attributes ctxt) vd.pval_attributes | Pstr_include incl -> pp f "@[include@ %a@]%a" (module_expr ctxt) incl.pincl_mod (item_attributes ctxt) incl.pincl_attributes | Pstr_recmodule decls -> (* 3.07 *) let aux f = function | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) -> pp f "@[@ and@ %s:%a@ =@ %a@]%a" pmb.pmb_name.txt (module_type ctxt) typ (module_expr ctxt) expr (item_attributes ctxt) pmb.pmb_attributes | _ -> assert false in begin match decls with | ({pmb_expr={pmod_desc=Pmod_constraint (expr, typ)}} as pmb) :: l2 -> pp f "@[@[module@ rec@ %s:%a@ =@ %a@]%a@ %a@]" pmb.pmb_name.txt (module_type ctxt) typ (module_expr ctxt) expr (item_attributes ctxt) pmb.pmb_attributes (fun f l2 -> List.iter (aux f) l2) l2 | _ -> assert false end | Pstr_attribute a -> floating_attribute ctxt f a | Pstr_extension(e, a) -> item_extension ctxt f e; item_attributes ctxt f a and type_param ctxt f (ct, a) = pp f "%s%a" (type_variance a) (core_type ctxt) ct and type_params ctxt f = function | [] -> () | l -> pp f "%a " (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",@;") l and type_def_list ctxt f (rf, exported, l) = let type_decl kwd rf f x = let eq = if (x.ptype_kind = Ptype_abstract) && (x.ptype_manifest = None) then "" else if exported then " =" else " :=" in pp f "@[<2>%s %a%a%s%s%a@]%a" kwd nonrec_flag rf (type_params ctxt) x.ptype_params x.ptype_name.txt eq (type_declaration ctxt) x (item_attributes ctxt) x.ptype_attributes in match l with | [] -> assert false | [x] -> type_decl "type" rf f x | x :: xs -> pp f "@[%a@,%a@]" (type_decl "type" rf) x (list ~sep:"@," (type_decl "and" Recursive)) xs and record_declaration ctxt f lbls = let type_record_field f pld = pp f "@[<2>%a%s:@;%a@;%a@]" mutable_flag pld.pld_mutable pld.pld_name.txt (core_type ctxt) pld.pld_type (attributes ctxt) pld.pld_attributes in pp f "{@\n%a}" (list type_record_field ~sep:";@\n" ) lbls and type_declaration ctxt f x = (* type_declaration has an attribute field, but it's been printed by the caller of this method *) let priv f = match x.ptype_private with | Public -> () | Private -> pp f "@;private" in let manifest f = match x.ptype_manifest with | None -> () | Some y -> if x.ptype_kind = Ptype_abstract then pp f "%t@;%a" priv (core_type ctxt) y else pp f "@;%a" (core_type ctxt) y in let constructor_declaration f pcd = pp f "|@;"; constructor_declaration ctxt f (pcd.pcd_name.txt, pcd.pcd_args, pcd.pcd_res, pcd.pcd_attributes) in let repr f = let intro f = if x.ptype_manifest = None then () else pp f "@;=" in match x.ptype_kind with | Ptype_variant xs -> let variants fmt xs = if xs = [] then pp fmt " |" else pp fmt "@\n%a" (list ~sep:"@\n" constructor_declaration) xs in pp f "%t%t%a" intro priv variants xs | Ptype_abstract -> () | Ptype_record l -> pp f "%t%t@;%a" intro priv (record_declaration ctxt) l | Ptype_open -> pp f "%t%t@;.." intro priv in let constraints f = List.iter (fun (ct1,ct2,_) -> pp f "@[@ constraint@ %a@ =@ %a@]" (core_type ctxt) ct1 (core_type ctxt) ct2) x.ptype_cstrs in pp f "%t%t%t" manifest repr constraints and type_extension ctxt f x = let extension_constructor f x = pp f "@\n|@;%a" (extension_constructor ctxt) x in pp f "@[<2>type %a%a += %a@ %a@]%a" (fun f -> function | [] -> () | l -> pp f "%a@;" (list (type_param ctxt) ~first:"(" ~last:")" ~sep:",") l) x.ptyext_params longident_loc x.ptyext_path private_flag x.ptyext_private (* Cf: #7200 *) (list ~sep:"" extension_constructor) x.ptyext_constructors (item_attributes ctxt) x.ptyext_attributes and constructor_declaration ctxt f (name, args, res, attrs) = let name = match name with | "::" -> "(::)" | s -> s in match res with | None -> pp f "%s%a@;%a" name (fun f -> function | Pcstr_tuple [] -> () | Pcstr_tuple l -> pp f "@;of@;%a" (list (core_type1 ctxt) ~sep:"@;*@;") l | Pcstr_record l -> pp f "@;of@;%a" (record_declaration ctxt) l ) args (attributes ctxt) attrs | Some r -> pp f "%s:@;%a@;%a" name (fun f -> function | Pcstr_tuple [] -> core_type1 ctxt f r | Pcstr_tuple l -> pp f "%a@;->@;%a" (list (core_type1 ctxt) ~sep:"@;*@;") l (core_type1 ctxt) r | Pcstr_record l -> pp f "%a@;->@;%a" (record_declaration ctxt) l (core_type1 ctxt) r ) args (attributes ctxt) attrs and extension_constructor ctxt f x = (* Cf: #7200 *) match x.pext_kind with | Pext_decl(l, r) -> constructor_declaration ctxt f (x.pext_name.txt, l, r, x.pext_attributes) | Pext_rebind li -> pp f "%s%a@;=@;%a" x.pext_name.txt (attributes ctxt) x.pext_attributes longident_loc li and case_list ctxt f l : unit = let aux f {pc_lhs; pc_guard; pc_rhs} = pp f "@;| @[<2>%a%a@;->@;%a@]" (pattern ctxt) pc_lhs (option (expression ctxt) ~first:"@;when@;") pc_guard (expression (under_pipe ctxt)) pc_rhs in list aux f l ~sep:"" and label_x_expression_param ctxt f (l,e) = let simple_name = match e with | {pexp_desc=Pexp_ident {txt=Lident l;_}; pexp_attributes=[]} -> Some l | _ -> None in match l with | Nolabel -> expression2 ctxt f e (* level 2*) | Optional str -> if Some str = simple_name then pp f "?%s" str else pp f "?%s:%a" str (simple_expr ctxt) e | Labelled lbl -> if Some lbl = simple_name then pp f "~%s" lbl else pp f "~%s:%a" lbl (simple_expr ctxt) e and directive_argument f x = match x.pdira_desc with | Pdir_string (s) -> pp f "@ %S" s | Pdir_int (n, None) -> pp f "@ %s" n | Pdir_int (n, Some m) -> pp f "@ %s%c" n m | Pdir_ident (li) -> pp f "@ %a" longident li | Pdir_bool (b) -> pp f "@ %s" (string_of_bool b) let toplevel_phrase f x = match x with | Ptop_def (s) ->pp f "@[%a@]" (list (structure_item reset_ctxt)) s (* pp_open_hvbox f 0; *) (* pp_print_list structure_item f s ; *) (* pp_close_box f (); *) | Ptop_dir {pdir_name; pdir_arg = None; _} -> pp f "@[#%s@]" pdir_name.txt | Ptop_dir {pdir_name; pdir_arg = Some pdir_arg; _} -> pp f "@[#%s@ %a@]" pdir_name.txt directive_argument pdir_arg let expression f x = pp f "@[%a@]" (expression reset_ctxt) x let string_of_expression x = ignore (flush_str_formatter ()) ; let f = str_formatter in expression f x; flush_str_formatter () let string_of_structure x = ignore (flush_str_formatter ()); let f = str_formatter in structure reset_ctxt f x; flush_str_formatter () let top_phrase f x = pp_print_newline f (); toplevel_phrase f x; pp f ";;"; pp_print_newline f () let core_type = core_type reset_ctxt let pattern = pattern reset_ctxt let signature = signature reset_ctxt let structure = structure reset_ctxt let class_expr = class_expr reset_ctxt let class_field = class_field reset_ctxt let class_type = class_type reset_ctxt let class_signature = class_signature reset_ctxt let class_type_field = class_type_field reset_ctxt let module_expr = module_expr reset_ctxt let module_type = module_type reset_ctxt let signature_item = signature_item reset_ctxt let structure_item = structure_item reset_ctxt ppxlib-0.12.0/ast/pprintast.mli000066400000000000000000000046351360512673700164300ustar00rootroot00000000000000(**************************************************************************) (* *) (* OCaml *) (* *) (* Hongbo Zhang (University of Pennsylvania) *) (* *) (* Copyright 1996 Institut National de Recherche en Informatique et *) (* en Automatique. *) (* *) (* All rights reserved. This file is distributed under the terms of *) (* the GNU Lesser General Public License version 2.1, with the *) (* special exception on linking described in the file LICENSE. *) (* *) (**************************************************************************) open Import type space_formatter = (unit, Format.formatter, unit) format val toplevel_phrase : Format.formatter -> Parsetree.toplevel_phrase -> unit val expression : Format.formatter -> Parsetree.expression -> unit val string_of_expression : Parsetree.expression -> string val top_phrase: Format.formatter -> Parsetree.toplevel_phrase -> unit val core_type: Format.formatter -> Parsetree.core_type -> unit val pattern: Format.formatter -> Parsetree.pattern -> unit val signature: Format.formatter -> Parsetree.signature -> unit val structure: Format.formatter -> Parsetree.structure -> unit val string_of_structure: Parsetree.structure -> string (* Added in the ppxlib copy *) val class_expr : Format.formatter -> Parsetree.class_expr -> unit val class_field : Format.formatter -> Parsetree.class_field -> unit val class_type : Format.formatter -> Parsetree.class_type -> unit val class_signature : Format.formatter -> Parsetree.class_signature -> unit val class_type_field : Format.formatter -> Parsetree.class_type_field -> unit val module_expr : Format.formatter -> Parsetree.module_expr -> unit val module_type : Format.formatter -> Parsetree.module_type -> unit val signature_item : Format.formatter -> Parsetree.signature_item -> unit val structure_item : Format.formatter -> Parsetree.structure_item -> unit ppxlib-0.12.0/ast/ppxlib_ast.ml000066400000000000000000000010071360512673700163660ustar00rootroot00000000000000open Import module Ast = Ast module Ast_helper = Ast_helper module Ast_magic = Selected_ast.Ast.Config module Asttypes = Asttypes module Docstrings = Docstrings module Extra_warnings = Warn module Lexer = Lexer module Parse = Parse module Parser = Parser module Parsetree = Parsetree module Pprintast = Pprintast module Select_ast = Select_ast module Selected_ast = Selected_ast module Syntaxerr = Syntaxerr module Import_for_core = Import ppxlib-0.12.0/ast/warn.ml000066400000000000000000000003041360512673700151670ustar00rootroot00000000000000open! Import let default_print_warning _loc = () let about_ite_branch_ref = ref default_print_warning let care_about_ite_branch = ref false let about_ite_branch loc = !about_ite_branch_ref loc ppxlib-0.12.0/ast/warn.mli000066400000000000000000000004201360512673700153370ustar00rootroot00000000000000open Import val care_about_ite_branch : bool ref (** Ignored -- kept for compatibility. *) val about_ite_branch_ref : (Location.t -> unit) ref (** Ignored -- kept for compatibility. *) val about_ite_branch : Location.t -> unit (** Ignored -- kept for compatibility. *) ppxlib-0.12.0/bench/000077500000000000000000000000001360512673700141615ustar00rootroot00000000000000ppxlib-0.12.0/bench/build_big_input.sh000077500000000000000000000005161360512673700176610ustar00rootroot00000000000000#!/bin/bash set -e -o pipefail ROOT="$(hg root)" OUT=input.ml echo > input.ml find $ROOT/lib/{core,core_kernel,async,async_{kernel,unix,extra}}/src -name \*.ml | { while read fn; do if ! grep -q '^#' "$fn"; then cat >> input.ml <> input.ml fi done } ppxlib-0.12.0/bench/dune000066400000000000000000000001101360512673700150270ustar00rootroot00000000000000(alias (name DEFAULT) (deps %{workspace_root}/.ppx/ppx_jane/ppx.exe)) ppxlib-0.12.0/bench/run_bench.sh000077500000000000000000000002261360512673700164630ustar00rootroot00000000000000#!/bin/bash set -e -o pipefail ROOT="$(hg root)" ppx="$ROOT/.ppx/ppx_jane/ppx.exe" time $ppx -dump-ast -inline-test-lib blah -o /dev/null input.ml ppxlib-0.12.0/doc/000077500000000000000000000000001360512673700136475ustar00rootroot00000000000000ppxlib-0.12.0/doc/conf.py000066400000000000000000000114361360512673700151530ustar00rootroot00000000000000# -*- coding: utf-8 -*- # # ppxlib documentation build configuration file, created by # sphinx-quickstart on Sun Aug 12 15:37:30 2018. # # This file is execfile()d with the current directory set to its # containing dir. # # Note that not all possible configuration values are present in this # autogenerated file. # # All configuration values have a default; values that are commented out # serve to show the default. # If extensions (or modules to document with autodoc) are in another directory, # add these directories to sys.path here. If the directory is relative to the # documentation root, use os.path.abspath to make it absolute, like shown here. # # import os # import sys # sys.path.insert(0, os.path.abspath('.')) # -- General configuration ------------------------------------------------ # If your documentation needs a minimal Sphinx version, state it here. # # needs_sphinx = '1.0' # Add any Sphinx extension module names here, as strings. They can be # extensions coming with Sphinx (named 'sphinx.ext.*') or your custom # ones. extensions = [] # Add any paths that contain templates here, relative to this directory. templates_path = ['_templates'] # The suffix(es) of source filenames. # You can specify multiple suffix as a list of string: # # source_suffix = ['.rst', '.md'] source_suffix = '.rst' # The master toctree document. master_doc = 'index' # General information about the project. project = u'ppxlib' copyright = u'2018, Jane Street Group, LLC' author = u'Jane Street Group, LLC' # The language for content autogenerated by Sphinx. Refer to documentation # for a list of supported languages. # # This is also used if you do content translation via gettext catalogs. # Usually you set "language" from the command line for these cases. language = None # List of patterns, relative to source directory, that match files and # directories to ignore when looking for source files. # This patterns also effect to html_static_path and html_extra_path exclude_patterns = ['_build', 'Thumbs.db', '.DS_Store'] # The name of the Pygments (syntax highlighting) style to use. pygments_style = 'sphinx' # If true, `todo` and `todoList` produce output, else they produce nothing. todo_include_todos = False # -- Options for HTML output ---------------------------------------------- # The theme to use for HTML and HTML Help pages. See the documentation for # a list of builtin themes. # html_theme = 'alabaster' # Theme options are theme-specific and customize the look and feel of a theme # further. For a list of options available for each theme, see the # documentation. # # html_theme_options = {} # Add any paths that contain custom static files (such as style sheets) here, # relative to this directory. They are copied after the builtin static files, # so a file named "default.css" will overwrite the builtin "default.css". # html_static_path = ['_static'] # Custom sidebar templates, must be a dictionary that maps document names # to template names. # # This is required for the alabaster theme # refs: http://alabaster.readthedocs.io/en/latest/installation.html#sidebars html_sidebars = { '**': [ 'relations.html', # needs 'show_related': True theme option to display 'searchbox.html', ] } # -- Options for HTMLHelp output ------------------------------------------ # Output file base name for HTML help builder. htmlhelp_basename = 'ppxlibdoc' # -- Options for LaTeX output --------------------------------------------- latex_elements = { # The paper size ('letterpaper' or 'a4paper'). # # 'papersize': 'letterpaper', # The font size ('10pt', '11pt' or '12pt'). # # 'pointsize': '10pt', # Additional stuff for the LaTeX preamble. # # 'preamble': '', # Latex figure (float) alignment # # 'figure_align': 'htbp', } # Grouping the document tree into LaTeX files. List of tuples # (source start file, target name, title, # author, documentclass [howto, manual, or own class]). latex_documents = [ (master_doc, 'ppxlib.tex', u'ppxlib Documentation', u'Jane Street Group, LLC', 'manual'), ] # -- Options for manual page output --------------------------------------- # One entry per manual page. List of tuples # (source start file, name, description, authors, manual section). man_pages = [ (master_doc, 'ppxlib', u'ppxlib Documentation', [author], 1) ] # -- Options for Texinfo output ------------------------------------------- # Grouping the document tree into Texinfo files. List of tuples # (source start file, target name, title, author, # dir menu entry, description, category) texinfo_documents = [ (master_doc, 'ppxlib', u'ppxlib Documentation', author, 'ppxlib', 'A comprehensive toolbox for ppx development.', 'Miscellaneous'), ] import sphinx_rtd_theme html_theme_path = [sphinx_rtd_theme.get_html_theme_path()] ppxlib-0.12.0/doc/index.rst000066400000000000000000000017011360512673700155070ustar00rootroot00000000000000ppxlib's user manual ==================== Overview -------- This is the user manual for ppxlib, the core of the ppx meta-programming system for OCaml_ and its derivatives such as Reason_. This manual is aimed at both users and authors of ppx rewriters and contains everything one should know in order to use or write ppx rewriters. It is assumed in this manual that the user is familiar with the Dune_ build system. In particular, all the examples in this manual referring to the build system will present Dune_ configurations files and commands. It is possible to use ppxlib with other build systems, however this is not covered by this manual. .. _OCaml: https://ocaml.org/ .. _Dune: https://dune.build/ .. _Reason: https://reasonml.github.io/ .. toctree:: :maxdepth: 2 :caption: Contents: what-is-ppx ppx-for-end-users ppx-for-plugin-authors Indices and tables ------------------ * :ref:`genindex` * :ref:`modindex` * :ref:`search` ppxlib-0.12.0/doc/ppx-for-end-users.rst000066400000000000000000000063021360512673700177000ustar00rootroot00000000000000***************** PPX for end users ***************** This section describes how to use ppx rewriters for end users. Using a ppx rewriter in your project ------------------------------------ To use one or more ppx rewriters written by you or someone else, simply list them in the ``preprocess`` field of your ``dune`` file. For instance: .. code:: scheme (library (name my_lib) (preprocess (pps (ppx_sexp_conv ppx_expect)))) Some ppx rewriters takes parameters in the form of command line flags. These can be specified using the usual convention for command line flags: atoms starting with ``-`` are treated as flags and ``--`` can be used to separate ppx rewriter names from more command line flags. For instance: .. code:: scheme (library (name my_lib) (preprocess (pps (ppx_sexp_conv ppx_expect -inline-test-drop)))) (library (name my_lib) (preprocess (pps (ppx_sexp_conv ppx_expect -- --cookie "x=42")))) Once this is done, you can use whatever feature is offered by the ppx rewriter. Looking at the generated code ----------------------------- At the time of writing this manual, there is no easy way to look at the fully transformed input file in order to see exactly what will be compiled by OCaml. You can however use the following method, which is not great but works: run ``ocamlc -dsource _build/default/``. For instance to see the transformed version of ``src/foo.ml``, run: .. code:: sh $ ocamlc -dsource _build/default/src/foo.pp.ml [@@deriving_inline] ------------------- Ppxlib supports attaching the ``[@@deriving]`` attribute to type declaration. This is used to generate code at compile time based on the structure of the type. For this particular case, ppxlib supports an alternative way to look at the generated code: replace ``[@@deriving ]`` by ``[@@deriving_inline ][@@@end]``. Then run the following command: .. code:: sh $ dune build --auto-promote If you reload the file in your editor, you should now see the contents of the generated code between the ``[@@deriving_inline]`` and ``[@@@end]`` attribute. This can help understanding what is provided by a ppx rewriter or debug compilation errors. Dropping ppx dependencies with [@@deriving_inline] -------------------------------------------------- You might notice that the resulting file when using ``[@@deriving_inline]`` needs no special treatment to be compiled. In particular, you can build it without the ppx rewriter or even ppxlib. You only need them while developing the project, in order to automatically produce the generated code but that's it. End users of your project do not need to install ppxlib and other ppx rewriters themselves. Dune_ gracefully supports this workflow: simply replace ``preprocess`` in your ``dune`` file by ``lint``. For instance: .. code:: scheme (library (name my_lib) (lint (pps (ppx_sexp_conv)))) Then to regenerate the parts between ``[@@deriving_inline]`` and ``[@@@end]``, run the following command: .. code:: sh $ dune build @lint --auto-promote .. _Dune: https://dune.build/ ppxlib-0.12.0/doc/ppx-for-plugin-authors.rst000066400000000000000000000143471360512673700207640ustar00rootroot00000000000000********************** PPX for plugin authors ********************** This section describes how to use ``ppxlib`` for PPX plugin authors. Metaquot -------- ``metaquot`` is a PPX plugin that helps you write PPX plugins. It lets you write AST node values using the actual corresponding OCaml syntax instead of building them with the more verbose AST types or ``Ast_builder``. To use ``metaquot`` you need to add it to the list of preprocessor for your PPX plugin: .. code:: scheme (library (name my_plugin_lib) (preprocess (pps ppxlib.metaquot))) ``metaquot`` can be used both to write expressions of some of the AST types or to write patterns to match over those same types. The various extensions it exposes can be used in both contexts, expressions or patterns. The extension you should use depends on the type of AST node you're trying to write or to pattern-match over. You can use the following extensions with the following syntax: - ``expr`` for ``Parsetree.expression``: ``[%expr 1 + 1]`` - ``pat`` for ``Parsetree.pattern``: ``[%pat? ("", _)]`` - ``type`` for ``Parsetree.core_type``: ``[%type: int -> string]`` - ``stri`` for ``Parsetree.structure_item``: ``[%stri let a = 1]`` - ``sigi`` for ``Parsetree.signature_item``: ``[%sigi: val i : int]`` - ``str`` and ``sig`` respectively for ``Parsetree.structure`` and ``Parsetree.signature``. They use similar syntax to the ``_item`` extensions above as they are just a list of such items. If you consider the first example ``[%expr 1 + 1]``, in an expression context, ``metaquot`` will actually expand it into: .. code:: ocaml { pexp_desc = (Pexp_apply ({ pexp_desc = (Pexp_ident { txt = (Lident "+"); loc }); pexp_loc = loc; pexp_attributes = [] }, [(Nolabel, { pexp_desc = (Pexp_constant (Pconst_integer ("1", None))); pexp_loc = loc; pexp_attributes = [] }); (Nolabel, { pexp_desc = (Pexp_constant (Pconst_integer ("1", None))); pexp_loc = loc; pexp_attributes = [] })])); pexp_loc = loc; pexp_attributes = [] } For this to compile you need the AST types to be in the scope so you should always use ``metaquot`` where ``Ppxlib`` is opened. You'll also note that the generated node expects a ``loc : Location.t`` value to be available. The produced AST node value and every other nodes within it will be located to ``loc``. You should make sure ``loc`` is the location you want for your generated code when using ``metaquot``. When using the pattern extension, it will produce a pattern that matches no matter what the location and attributes are. For the previous example for instance, it will produce the following pattern: .. code:: ocaml { pexp_desc = (Pexp_apply ({ pexp_desc = (Pexp_ident { txt = (Lident "+"); loc = _ }); pexp_loc = _; pexp_attributes = _ }, [(Nolabel, { pexp_desc = (Pexp_constant (Pconst_integer ("1", None))); pexp_loc = _; pexp_attributes = _ }); (Nolabel, { pexp_desc = (Pexp_constant (Pconst_integer ("1", None))); pexp_loc = _; pexp_attributes = _ })])); pexp_loc = _; pexp_attributes = _ } Using these extensions alone, you can only produce constant/static AST nodes. You can't bind variables in the generated patterns either. ``metaquot`` has a solution for that as well: anti-quotation. You can use anti-quotation to insert any expression or pattern representing an AST node. That way you can include dynamically generated nodes inside a ``metaquot`` expression extension point or use a wildcard or variable pattern in a pattern extension. Consider the following example: .. code:: ocaml let with_suffix_expr ~loc s = let dynamic_node = Ast_builder.Default.estring ~loc s in [%expr [%e dynamic_node] ^ "some_fixed_suffix"] The ``with_suffix_expr`` function will create an ``expression`` which is the concatenation of the ``s`` argument and the fixed suffix. I.e. ``with_suffix_expr "some_dynamic_stem"`` is equivalent to ``[%expr "some_dynamic_steme" ^ "some_fixed_suffix"]``. Similarly if you want to ignore some parts of AST nodes and extract some others when pattern-matching over them, you can use anti-quotation: .. code:: ocaml match some_expr_node with | [%expr 1 + [%e? _] + [%e? third]] -> do_something_with third The syntax for anti-quotation depends on the type of the node you wish to insert: - ``e`` to anti-quote values of type ``Parsetree.expression``: ``[%expr 1 + [%e some_expr_node]]`` - ``p`` to anti-quote values of type ``Parsetree.pattern``: ``[%pat? (1, [%p some_pat_node]]`` - ``t`` to anti-quote values of type ``Parsetree.core_type``: ``[%type: int -> [%t some_core_type_node]]`` - ``m`` to anti-quote values of type ``Parsetree.module_expr`` or ``module_type``: ``[%expr let module M = [%m some_module_expr_node]]`` or ``[%sigi: module M : [%m some_module_type_node]]`` - ``i`` to anti-quote values of type ``Parsetree.structure_item`` or ``signature_item``: ``[%str let a = 1 [%%i some_structure_item_node]]`` or ``[%sig: val a : int [%%i some_signature_item_node]]`` Note that when anti-quoting in a pattern context you must always use the ``?`` in the anti-quotation extension as its payload should always be a pattern the same way it must always be an expression in an expression context. As you may have noticed, you can anti-quote expressions which type differs from the type of the whole ``metaquot`` extension point. E.g. you can write: .. code:: ocaml let structure_item = [%stri let [%p some_pat] : [%t some_type] = [%e some_expr]] ppxlib-0.12.0/doc/what-is-ppx.rst000066400000000000000000000115321360512673700165640ustar00rootroot00000000000000************ What is PPX? ************ Overview -------- Ppx is a meta-programming system for the OCaml programming language. It allows developers to generate code at compile time in a principled way. The distinguishing feature of ppx is that it is tightly integrated with the OCaml parser and instead of operating at the text level it operates on the internal structured representation of the language in the compiler, called the Abstract Syntax Tree or AST for short. A few years ago, the OCaml language was extended with two new constructions: annotations and extension points. Annotations are arbitrary pieces of information that can be attached to most parts of the OCaml language. They can be used to control the behavior of the OCaml compiler, or in some specific cases to generate code at compile time. Extension points are compile time functions. The compiler itself doesn't know how to interpret them and they must all be rewritten by the ppx system before the compiler can process input files further. Ppxlib mainly supports two ways of generating code at compile time: by expanding an extension point or by expanding a ``[@@deriving ...]`` attribute after a type declaration. How does it works? ------------------ The ppx system is composed of 3 parts: - individual ppx rewriters - ppxlib - a hook in the compiler Inidividual ppx rewriters are those implemented by various developers to provide features to end users, such as ppx_expect_ which provides a good inline testing framework. All these rewriters are written against the ppxlib API. Ppxlib is responsible for acknowledging the various rewriters a end user wants to use, making sure they can be composed together and performing the actual rewriting of input files. The hook in the compiler allows ppxlib to insert itself in the compilation pipeline and perform the rewriting of input files based on a list of ppx rewriters specified by the user. The hooks take the form of command line flags that takes a command to execute. The compiler supports two slightly different flags, for providing commands that are executed at different stages: ``-pp`` and ``-ppx``. The difference between the two is as follow: - ``-pp`` takes as argument a command that is used to parse the textual representation. Such a command can produce either a plain OCaml source file or a serialised representation of the AST - ``-ppx`` takes as argument a command that is given a serialised representation of the AST and produces another serialised AST Ppxlib generally uses the first one as it yields faster compilation times, however it supports both methods of operation. Is ppxlib necessary? -------------------- Yes. While authors of ppx rewriters may in theory use the compiler hooks directly, doing so is strongly discouraged for the following reasons: - composing such ppx rewriters is slow and yields much slower compilation times - the ABI of the hook is not stable and regularly changes in incompatible ways. This means that a ppx rewriter using the compiler hook directly is likely to work only with a single version of the OCaml compiler - the compiler does not provide a good composition semantics, which means that input files will not always be transformed as expected. It is hard to predict what the final result will be, and for end users it is hard to understand what is happening when things go wrong - the compiler doesn't handle hygiene: if an attribute is mistyped or misplaced, it is silently ignored by the compiler. If two ppx rewriters want to interpret the same attribute or extension point in incompatible ways, the result is not specified In summary, ppxlib abstracts away from all the low-level details of the ppx system and exposes a consistent model to authors of ppx rewriters and end users. Current state of the ppx ecosystem ---------------------------------- Ppxlib was developed after the introduction of the ppx system. As a result, many ppx rewriters do not currently use ppxlib and are using the compiler hooks directly. Ppxlib can acknowledge such rewriters so that they can be used in conjunction with more modern rewriters, however it cannot provide a good composition or hygiene story when using such ppx rewriters. Note on stability regarding new compiler releases ------------------------------------------------- Due to the nature of the ppx system, it is hard for ppxlib to provide full protection against compiler changes. This means that a ppx rewriter written against ppxlib today can be broken by a future release of the OCaml compiler and a new release of the ppx rewriter will be necessary to support the new compiler. However the following is true: every time this might happen, it will be possible to extend ppxlib to provide a greater protection, so that eventually the whole ppx ecosystem is completely shielded from breaking compiler changes. .. _ppx_expect: https://github.com/janestreet/ppx_expect ppxlib-0.12.0/dune000066400000000000000000000000551360512673700137600ustar00rootroot00000000000000(env (dev (flags (:standard -w -66)))) ppxlib-0.12.0/dune-project000066400000000000000000000000611360512673700154210ustar00rootroot00000000000000(lang dune 1.0) (name ppxlib) (using cinaps 1.0) ppxlib-0.12.0/dune-workspace.dev000066400000000000000000000002571360512673700165350ustar00rootroot00000000000000(lang dune 1.0) ;; This file is used by `make all-supported-ocaml-versions` (context (opam (switch 4.04.2))) (context (opam (switch 4.05.0))) (context (opam (switch 4.06.1))) ppxlib-0.12.0/metaquot/000077500000000000000000000000001360512673700147415ustar00rootroot00000000000000ppxlib-0.12.0/metaquot/dune000066400000000000000000000003121360512673700156130ustar00rootroot00000000000000(library (name ppxlib_metaquot) (public_name ppxlib.metaquot) (kind ppx_rewriter) (flags (:standard -safe-string)) (libraries ppxlib ppxlib_traverse_builtins ppxlib_metaquot_lifters)) ppxlib-0.12.0/metaquot/ppxlib_metaquot.ml000066400000000000000000000101351360512673700205100ustar00rootroot00000000000000open Ppxlib open Ast_builder.Default module E = Extension module A = Ast_pattern module Make(M : sig type result val cast : extension -> result val location : location -> result val location_stack : (location -> result) option val attributes : (location -> result) option class std_lifters : location -> [result] Ppxlib_traverse_builtins.std_lifters end) = struct let lift loc = object inherit [M.result] Ast_traverse.lift as super inherit! M.std_lifters loc method! attribute x = Attribute.mark_as_handled_manually x; super#attribute x method! location _ = M.location loc method! attributes x = match M.attributes with | None -> super#attributes x | Some f -> assert_no_attributes x; f loc method! location_stack x = match M.location_stack with | None -> super#location_stack x | Some f -> f loc method! expression e = match e.pexp_desc with | Pexp_extension ({ txt = "e"; _}, _ as ext)-> M.cast ext | _ -> super#expression e method! pattern p = match p.ppat_desc with | Ppat_extension ({ txt = "p"; _}, _ as ext)-> M.cast ext | _ -> super#pattern p method! core_type t = match t.ptyp_desc with | Ptyp_extension ({ txt = "t"; _}, _ as ext)-> M.cast ext | _ -> super#core_type t method! module_expr m = match m.pmod_desc with | Pmod_extension ({ txt = "m"; _}, _ as ext)-> M.cast ext | _ -> super#module_expr m method! module_type m = match m.pmty_desc with | Pmty_extension ({ txt = "m"; _ }, _ as ext)-> M.cast ext | _ -> super#module_type m method! structure_item i = match i.pstr_desc with | Pstr_extension (({ txt = "i"; _}, _ as ext), attrs) -> assert_no_attributes attrs; M.cast ext | _ -> super#structure_item i method! signature_item i = match i.psig_desc with | Psig_extension (({ txt = "i"; _}, _ as ext), attrs) -> assert_no_attributes attrs; M.cast ext | _ -> super#signature_item i end end module Expr = Make(struct type result = expression let location loc = evar ~loc:{ loc with loc_ghost = true } "loc" let location_stack = None let attributes = None class std_lifters = Ppxlib_metaquot_lifters.expression_lifters let cast ext = match snd ext with | PStr [{ pstr_desc = Pstr_eval (e, attrs); _}] -> assert_no_attributes attrs; e | _ -> Location.raise_errorf ~loc:(loc_of_extension ext) "expression expected" end) module Patt = Make(struct type result = pattern let location loc = ppat_any ~loc:{ loc with loc_ghost = true } let location_stack = Some (fun loc -> ppat_any ~loc:{ loc with loc_ghost = true }) let attributes = Some (fun loc -> ppat_any ~loc:{ loc with loc_ghost = true }) class std_lifters = Ppxlib_metaquot_lifters.pattern_lifters let cast ext = match snd ext with | PPat (p, None) -> p | PPat (_, Some e) -> Location.raise_errorf ~loc:e.pexp_loc "guard not expected here" | _ -> Location.raise_errorf ~loc:(loc_of_extension ext) "pattern expected" end) let () = let extensions ctx lifter = [ E.declare "expr" ctx A.(single_expr_payload __) (fun ~loc ~path:_ e -> (lifter loc)#expression e) ; E.declare "pat" ctx A.(ppat __ none) (fun ~loc ~path:_ p -> (lifter loc)#pattern p) ; E.declare "str" ctx A.(pstr __) (fun ~loc ~path:_ s -> (lifter loc)#structure s) ; E.declare "stri" ctx A.(pstr (__ ^:: nil)) (fun ~loc ~path:_ s -> (lifter loc)#structure_item s) ; E.declare "sig" ctx A.(psig __) (fun ~loc ~path:_ s -> (lifter loc)#signature s) ; E.declare "sigi" ctx A.(psig (__ ^:: nil)) (fun ~loc ~path:_ s -> (lifter loc)#signature_item s) ; E.declare "type" ctx A.(ptyp __) (fun ~loc ~path:_ t -> (lifter loc)#core_type t) ] in let extensions = extensions Expression Expr.lift @ extensions Pattern Patt.lift in Driver.register_transformation "metaquot" ~extensions ppxlib-0.12.0/metaquot_lifters/000077500000000000000000000000001360512673700164715ustar00rootroot00000000000000ppxlib-0.12.0/metaquot_lifters/dune000066400000000000000000000002511360512673700173450ustar00rootroot00000000000000(library (name ppxlib_metaquot_lifters) (public_name ppxlib.metaquot_lifters) (flags (:standard -safe-string)) (libraries ppxlib ppxlib_traverse_builtins)) ppxlib-0.12.0/metaquot_lifters/ppxlib_metaquot_lifters.ml000066400000000000000000000043221360512673700237710ustar00rootroot00000000000000open Base open Ppxlib open Ast_builder.Default class expression_lifters loc = let loc = { loc with loc_ghost = true } in object inherit [expression] Ppxlib_traverse_builtins.lift method record flds = pexp_record ~loc (List.map flds ~f:(fun (lab, e) -> ({ loc; txt = Lident lab }, e))) None method constr id args = pexp_construct ~loc { loc; txt = Lident id } (match args with | [] -> None | l -> Some (pexp_tuple ~loc l)) method tuple l = pexp_tuple ~loc l method int i = eint ~loc i method int32 i = eint32 ~loc i method int64 i = eint64 ~loc i method nativeint i = enativeint ~loc i method float f = efloat ~loc (Float.to_string f) method string s = estring ~loc s method char c = echar ~loc c method bool b = ebool ~loc b method array : 'a. ('a -> expression) -> 'a array -> expression = fun f a -> pexp_array ~loc (List.map (Array.to_list a) ~f) method unit () = eunit ~loc method other : 'a. 'a -> expression = fun _ -> failwith "not supported" end class pattern_lifters loc = let loc = { loc with loc_ghost = true } in object inherit [pattern] Ppxlib_traverse_builtins.lift method record flds = ppat_record ~loc (List.map flds ~f:(fun (lab, e) -> ({ loc; txt = Lident lab }, e))) Closed method constr id args = ppat_construct ~loc { loc; txt = Lident id } (match args with | [] -> None | l -> Some (ppat_tuple ~loc l)) method tuple l = ppat_tuple ~loc l method int i = pint ~loc i method int32 i = pint32 ~loc i method int64 i = pint64 ~loc i method nativeint i = pnativeint ~loc i method float f = pfloat ~loc (Float.to_string f) method string s = pstring ~loc s method char c = pchar ~loc c method bool b = pbool ~loc b method array : 'a. ('a -> pattern) -> 'a array -> pattern = fun f a -> ppat_array ~loc (List.map (Array.to_list a) ~f) method unit () = punit ~loc method other : 'a. 'a -> pattern = fun _ -> failwith "not supported" end ppxlib-0.12.0/ppxlib.opam000066400000000000000000000026701360512673700152630ustar00rootroot00000000000000opam-version: "2.0" maintainer: "opensource@janestreet.com" authors: ["Jane Street Group, LLC "] homepage: "https://github.com/ocaml-ppx/ppxlib" bug-reports: "https://github.com/ocaml-ppx/ppxlib/issues" dev-repo: "git+https://github.com/ocaml-ppx/ppxlib.git" doc: "https://ocaml-ppx.github.io/ppxlib/" license: "MIT" build: [ ["dune" "subst"] {pinned} ["dune" "build" "-p" name "-j" jobs] ] run-test: [ ["dune" "runtest" "-p" name "-j" jobs] { ocaml:version >= "4.06" & ocaml:version < "4.08" } ] depends: [ "ocaml" {>= "4.04.1"} "base" {>= "v0.11.0"} "dune" "ocaml-compiler-libs" {>= "v0.11.0"} "ocaml-migrate-parsetree" {>= "1.3.1"} "ppx_derivers" {>= "1.0"} "stdio" {>= "v0.11.0"} "ocamlfind" {with-test} "cinaps" {with-test & >= "v0.12.1"} ] synopsis: "Base library and tools for ppx rewriters" description: """ A comprehensive toolbox for ppx development. It features: - a OCaml AST / parser / pretty-printer snapshot,to create a full frontend independent of the version of OCaml; - a library for library for ppx rewriters in general, and type-driven code generators in particular; - a feature-full driver for OCaml AST transformers; - a quotation mechanism allowing to write values representing the OCaml AST in the OCaml syntax; - a generator of open recursion classes from type definitions. """ ppxlib-0.12.0/print-diff/000077500000000000000000000000001360512673700151445ustar00rootroot00000000000000ppxlib-0.12.0/print-diff/dune000066400000000000000000000001471360512673700160240ustar00rootroot00000000000000(library (name ppxlib_print_diff) (public_name ppxlib.print_diff) (flags (:standard -safe-string))) ppxlib-0.12.0/print-diff/ppxlib_print_diff.ml000066400000000000000000000031551360512673700212040ustar00rootroot00000000000000open StdLabels let patdiff_cmd ~use_color ~extra_patdiff_args = let args = List.concat [ ["-keep-whitespace"]; ["-location-style omake"]; (if use_color then [] else ["-ascii"]); extra_patdiff_args ] in String.concat ~sep:" " ("patdiff" :: args) ;; let print ?diff_command ?(extra_patdiff_args=[]) ?(use_color=false) ~file1 ~file2 () = let exec cmd = let cmd = Printf.sprintf "%s %s %s 1>&2" cmd (Filename.quote file1) (Filename.quote file2) in match Sys.command cmd with | 0 -> `Same | 1 -> `Different | n -> `Error (n, cmd) in match diff_command with | Some s -> ignore (exec s : [> `Same | `Different | `Error of int * string]) | None -> begin match exec (patdiff_cmd ~use_color ~extra_patdiff_args) with | `Same -> (* patdiff produced no output, fallback to diff -u *) Printf.eprintf "File \"%s\", line 1, characters 0-0:\n%!" file1; ignore (exec "diff -u" : [> `Same | `Different | `Error of int * string]) | `Different -> (* patdiff successfully found a difference *) () | `Error (err_code, cmd) -> (* patdiff threw an error... perhaps it wasn't installed? fallback to diff -u *) Printf.eprintf "Error:\n\ > %S exited with code %d\n\ > Perhaps patdiff is not installed? Hint, try: opam install patdiff\n\ > Falling back to diff -u\n\ \n" cmd err_code; Printf.eprintf "File \"%s\", line 1, characters 0-0:\n%!" file1; ignore (exec "diff -u" : [> `Same | `Different | `Error of int * string]) end ;; ppxlib-0.12.0/print-diff/ppxlib_print_diff.mli000066400000000000000000000005701360512673700213530ustar00rootroot00000000000000(** Diff two files. Use [diff_command] to specify what command to use. If not specified [patdiff] is used, with a fallback to [diff -u] if [patdiff] produces no differences. *) val print : ?diff_command:string -> ?extra_patdiff_args:string list (** default: [] *) -> ?use_color:bool (** default: false *) -> file1:string -> file2:string -> unit -> unit ppxlib-0.12.0/runner/000077500000000000000000000000001360512673700144135ustar00rootroot00000000000000ppxlib-0.12.0/runner/dune000066400000000000000000000004251360512673700152720ustar00rootroot00000000000000;; This library just contain the entry point for ppx drivers. It must ;; be linked after all other libraries and units. (library (name ppxlib_runner) (public_name ppxlib.runner) (flags (:standard -safe-string)) (libraries ppxlib) (library_flags -linkall)) ppxlib-0.12.0/runner/ppx_driver_runner.ml000066400000000000000000000000341360512673700205150ustar00rootroot00000000000000Ppxlib.Driver.standalone () ppxlib-0.12.0/runner_as_ppx/000077500000000000000000000000001360512673700157655ustar00rootroot00000000000000ppxlib-0.12.0/runner_as_ppx/dune000066400000000000000000000004231360512673700166420ustar00rootroot00000000000000;; This library just contain the entry point for ppx drivers. It must ;; be linked after all other libraries and units. (library (name ppxlib_runner_as_ppx) (public_name ppxlib.runner_as_ppx) (library_flags -linkall) (flags (:standard -safe-string)) (libraries ppxlib)) ppxlib-0.12.0/runner_as_ppx/ppx_driver_runner_as_ppx.ml000066400000000000000000000000451360512673700234430ustar00rootroot00000000000000Ppxlib.Driver.run_as_ppx_rewriter () ppxlib-0.12.0/src/000077500000000000000000000000001360512673700136715ustar00rootroot00000000000000ppxlib-0.12.0/src/ast_builder.ml000066400000000000000000000261731360512673700165310ustar00rootroot00000000000000open! Import module Default = struct module Located = struct type 'a t = 'a Loc.t let loc (x : _ t) = x.loc let mk ~loc x = { loc; txt = x } let map f t = { t with txt = f t.txt } let map_lident x = map (fun x -> Longident.Lident x) x let lident ~loc x = mk ~loc (Longident.parse x) end include Ast_builder_generated.M let pstr_value_list ~loc rec_flag = function | [] -> [] | vbs -> [pstr_value ~loc rec_flag vbs] let nonrec_type_declaration ~loc:_ ~name:_ ~params:_ ~cstrs:_ ~kind:_ ~private_:_ ~manifest:_ = failwith "Ppxlib.Ast_builder.nonrec_type_declaration: don't use this function" ;; let eint ~loc t = pexp_constant ~loc (Pconst_integer (Int.to_string t, None)) let echar ~loc t = pexp_constant ~loc (Pconst_char t) let estring ~loc t = pexp_constant ~loc (Pconst_string (t, None)) let efloat ~loc t = pexp_constant ~loc (Pconst_float (t, None)) let eint32 ~loc t = pexp_constant ~loc (Pconst_integer (Int32.to_string t, Some 'l')) let eint64 ~loc t = pexp_constant ~loc (Pconst_integer (Int64.to_string t, Some 'L')) let enativeint ~loc t = pexp_constant ~loc (Pconst_integer (Nativeint.to_string t, Some 'n')) let pint ~loc t = ppat_constant ~loc (Pconst_integer (Int.to_string t, None)) let pchar ~loc t = ppat_constant ~loc (Pconst_char t) let pstring ~loc t = ppat_constant ~loc (Pconst_string (t, None)) let pfloat ~loc t = ppat_constant ~loc (Pconst_float (t, None)) let pint32 ~loc t = ppat_constant ~loc (Pconst_integer (Int32.to_string t, Some 'l')) let pint64 ~loc t = ppat_constant ~loc (Pconst_integer (Int64.to_string t, Some 'L')) let pnativeint ~loc t = ppat_constant ~loc (Pconst_integer (Nativeint.to_string t, Some 'n')) let ebool ~loc t = pexp_construct ~loc (Located.lident ~loc (Bool.to_string t)) None let pbool ~loc t = ppat_construct ~loc (Located.lident ~loc (Bool.to_string t)) None let evar ~loc v = pexp_ident ~loc (Located.mk ~loc (Longident.parse v)) let pvar ~loc v = ppat_var ~loc (Located.mk ~loc v) let eunit ~loc = pexp_construct ~loc (Located.lident ~loc "()") None let punit ~loc = ppat_construct ~loc (Located.lident ~loc "()") None let pexp_tuple ~loc l = match l with | [x] -> x | _ -> pexp_tuple ~loc l let ppat_tuple ~loc l = match l with | [x] -> x | _ -> ppat_tuple ~loc l let ptyp_tuple ~loc l = match l with | [x] -> x | _ -> ptyp_tuple ~loc l let pexp_tuple_opt ~loc l = match l with | [] -> None | _ :: _ -> Some (pexp_tuple ~loc l) let ppat_tuple_opt ~loc l = match l with | [] -> None | _ :: _ -> Some (ppat_tuple ~loc l) let ptyp_poly ~loc vars ty = match vars with | [] -> ty | _ -> ptyp_poly ~loc vars ty let pexp_apply ~loc e el = match e, el with | _, [] -> e | { pexp_desc = Pexp_apply (e, args) ; pexp_attributes = []; _ }, _ -> { e with pexp_desc = Pexp_apply (e, args @ el) } | _ -> pexp_apply ~loc e el ;; let eapply ~loc e el = pexp_apply ~loc e (List.map el ~f:(fun e -> (Asttypes.Nolabel, e))) let eabstract ~loc ps e = List.fold_right ps ~init:e ~f:(fun p e -> pexp_fun ~loc Asttypes.Nolabel None p e) ;; let esequence ~loc el = match el with | [] -> eunit ~loc | hd :: tl -> List.fold_left tl ~init:hd ~f:(fun acc e -> pexp_sequence ~loc acc e) ;; let pconstruct cd arg = ppat_construct ~loc:cd.pcd_loc (Located.map_lident cd.pcd_name) arg let econstruct cd arg = pexp_construct ~loc:cd.pcd_loc (Located.map_lident cd.pcd_name) arg let rec elist ~loc l = match l with | [] -> pexp_construct ~loc (Located.mk ~loc (Longident.Lident "[]")) None | x :: l -> pexp_construct ~loc (Located.mk ~loc (Longident.Lident "::")) (Some (pexp_tuple ~loc [x; elist ~loc l])) ;; let rec plist ~loc l = match l with | [] -> ppat_construct ~loc (Located.mk ~loc (Longident.Lident "[]")) None | x :: l -> ppat_construct ~loc (Located.mk ~loc (Longident.Lident "::")) (Some (ppat_tuple ~loc [x; plist ~loc l])) ;; let unapplied_type_constr_conv_without_apply ~loc (ident : Longident.t) ~f = match ident with | Lident n -> pexp_ident ~loc { txt = Lident (f n); loc } | Ldot (path, n) -> pexp_ident ~loc { txt = Ldot (path, f n); loc } | Lapply _ -> Location.raise_errorf ~loc "unexpected applicative functor type" let type_constr_conv ~loc:apply_loc { Loc.loc; txt = longident } ~f args = let loc = { loc with loc_ghost = true } in match (longident : Longident.t) with | Lident _ | Ldot ((Lident _ | Ldot _), _) | Lapply _ -> let ident = unapplied_type_constr_conv_without_apply longident ~loc ~f in begin match args with | [] -> ident | _ :: _ -> eapply ~loc:apply_loc ident args end | Ldot (Lapply _ as module_path, n) -> let suffix_n functor_ = String.uncapitalize functor_ ^ "__" ^ n in let rec gather_lapply functor_args : Longident.t -> Longident.t * _ = function | Lapply (rest, arg) -> gather_lapply (arg :: functor_args) rest | Lident functor_ -> Lident (suffix_n functor_), functor_args | Ldot (functor_path, functor_) -> Ldot (functor_path, suffix_n functor_), functor_args in let ident, functor_args = gather_lapply [] module_path in eapply ~loc:apply_loc (unapplied_type_constr_conv_without_apply ident ~loc ~f) (List.map functor_args ~f:(fun path -> pexp_pack ~loc (pmod_ident ~loc { txt = path; loc })) @ args) let unapplied_type_constr_conv ~loc longident ~f = type_constr_conv longident ~loc ~f [] let eta_reduce = let rec gather_params acc expr = match expr with | { pexp_desc = Pexp_fun (label, None (* no default expression *), subpat, body) ; pexp_attributes = [] ; pexp_loc = _ ; pexp_loc_stack = _ } -> begin match subpat with | { ppat_desc = Ppat_var name; ppat_attributes = []; ppat_loc = _; ppat_loc_stack = _ } -> gather_params ((label, name, None) :: acc) body | { ppat_desc = Ppat_constraint ({ ppat_desc = Ppat_var name ; ppat_attributes = [] ; ppat_loc = _ ; ppat_loc_stack = _ }, ty) ; ppat_attributes = []; ppat_loc = _; ppat_loc_stack = _ } -> (* We reduce [fun (x : ty) -> f x] by rewriting it [(f : ty -> _)]. *) gather_params ((label, name, Some ty) :: acc) body | _ -> List.rev acc, expr end | _ -> List.rev acc, expr in let annotate ~loc expr params = if List.exists params ~f:(fun (_, _, ty) -> Option.is_some ty) then let ty = List.fold_right params ~init:(ptyp_any ~loc) ~f:(fun (param_label, param, ty_opt) acc -> let loc = param.loc in let ty = match ty_opt with | None -> ptyp_any ~loc | Some ty -> ty in ptyp_arrow ~loc param_label ty acc) in pexp_constraint ~loc expr ty else expr in let rec gather_args n x = if n = 0 then Some (x, []) else match x with | { pexp_desc = Pexp_apply (body, args) ; pexp_attributes = []; pexp_loc = _; pexp_loc_stack = _ } -> if List.length args <= n then match gather_args (n - List.length args) body with | None -> None | Some (body, args') -> Some (body, args' @ args) else None | _ -> None in fun expr -> let params, body = gather_params [] expr in match gather_args (List.length params) body with | None -> None | Some (({ pexp_desc = Pexp_ident _; _ } as f_ident), args) -> begin match List.for_all2 args params ~f:(fun (arg_label, arg) (param_label, param, _) -> Poly.(=) (arg_label : arg_label) param_label && match arg with | { pexp_desc = Pexp_ident { txt = Lident name'; _ }; pexp_attributes = []; pexp_loc = _; pexp_loc_stack = _ } -> String.(=) name' param.txt | _ -> false) with | Unequal_lengths -> assert false | Ok false -> None | Ok true -> Some (annotate ~loc:expr.pexp_loc f_ident params) end | _ -> None ;; let eta_reduce_if_possible expr = Option.value (eta_reduce expr) ~default:expr let eta_reduce_if_possible_and_nonrec expr ~rec_flag = match rec_flag with | Recursive -> expr | Nonrecursive -> eta_reduce_if_possible expr end module type Loc = Ast_builder_intf.Loc module type S = Ast_builder_intf.S module Make(Loc : sig val loc : Location.t end) : S = struct include Ast_builder_generated.Make(Loc) let pstr_value_list = Default.pstr_value_list let nonrec_type_declaration ~name ~params ~cstrs ~kind ~private_ ~manifest = Default.nonrec_type_declaration ~loc ~name ~params ~cstrs ~kind ~private_ ~manifest ;; module Located = struct include Default.Located let loc _ = Loc.loc let mk x = mk ~loc:Loc.loc x let lident x = lident ~loc:Loc.loc x end let pexp_tuple l = Default.pexp_tuple ~loc l let ppat_tuple l = Default.ppat_tuple ~loc l let ptyp_tuple l = Default.ptyp_tuple ~loc l let pexp_tuple_opt l = Default.pexp_tuple_opt ~loc l let ppat_tuple_opt l = Default.ppat_tuple_opt ~loc l let ptyp_poly vars ty = Default.ptyp_poly ~loc vars ty let pexp_apply e el = Default.pexp_apply ~loc e el let eint t = Default.eint ~loc t let echar t = Default.echar ~loc t let estring t = Default.estring ~loc t let efloat t = Default.efloat ~loc t let eint32 t = Default.eint32 ~loc t let eint64 t = Default.eint64 ~loc t let enativeint t = Default.enativeint ~loc t let ebool t = Default.ebool ~loc t let evar t = Default.evar ~loc t let pint t = Default.pint ~loc t let pchar t = Default.pchar ~loc t let pstring t = Default.pstring ~loc t let pfloat t = Default.pfloat ~loc t let pint32 t = Default.pint32 ~loc t let pint64 t = Default.pint64 ~loc t let pnativeint t = Default.pnativeint ~loc t let pbool t = Default.pbool ~loc t let pvar t = Default.pvar ~loc t let eunit = Default.eunit ~loc let punit = Default.punit ~loc let econstruct = Default.econstruct let pconstruct = Default.pconstruct let eapply e el = Default.eapply ~loc e el let eabstract ps e = Default.eabstract ~loc ps e let esequence el = Default.esequence ~loc el let elist l = Default.elist ~loc l let plist l = Default.plist ~loc l let type_constr_conv ident ~f args = Default.type_constr_conv ~loc ident ~f args let unapplied_type_constr_conv ident ~f = Default.unapplied_type_constr_conv ~loc ident ~f let eta_reduce = Default.eta_reduce let eta_reduce_if_possible = Default.eta_reduce_if_possible let eta_reduce_if_possible_and_nonrec = Default.eta_reduce_if_possible_and_nonrec end let make loc = (module Make(struct let loc = loc end) : S) ppxlib-0.12.0/src/ast_builder.mli000066400000000000000000000061561360512673700167010ustar00rootroot00000000000000(** Helpers for build OCaml AST fragments *) open! Import (** This module is similar to the [Ast_helper] module distrubuted with OCaml but uses different conventions. {3 Locations} [Ast_helper] uses a global variable for the default locations, we found that to it makes it quite easy to mess up locations. Instead this modules forces you to provide a location argument. For building fragment using the same location everywhere, a functor is provided. {3 Naming} The names match the [Parsetree] names closely, which makes it easy to build AST fragments by just knowing the [Parsetree]. For types of the form a wrapper record with a [_desc] field, helpers are generated for each constructor constructing the record directly. For instance for the type [Parsetree.expression]: {[ type expression = { pexp_desc : expression_desc ; pexp_loc : Location.t ; pexp_attributes : attributes } and expression_desc = | Pexp_ident of Longident.t loc | Pexp_constant of constant | Pexp_let of rec_flag * value_binding list * expression ... ]} The following helpers are created: {[ val pexp_ident : loc:Location.t -> Longident.t Located.t -> expression val pexp_constant : loc:Location.t -> constant -> expression val pexp_let : loc:Location.t -> rec_flag -> value_binding list -> expression ... ]} For other record types, such as type_declaration, we have the following helper: {[ type type_declaration = { ptype_name : string Located.t ; ptype_params : (core_type * variance) list ; ptype_cstrs : (core_type * core_type * Location.t) list ; ptype_kind : type_kind ; ptype_private : private_flag ; ptype_manifest : core_type option ; ptype_attributes : attributes ; ptype_loc : Location.t } val type_declaration : loc : Location.t -> name : string Located.t -> params : (core_type * variance) list -> cstrs : (core_type * core_type * Location.t) list -> kind : type_kind -> private : private_flag -> manifest : core_type option -> type_declaration ]} Attributes are always set to the empty list. If you want to set them you have to override the field with the [{ e with pexp_attributes = ... }] notation. *) (** Helpers taking a [~loc] argument. This module is meant to be opened or aliased. *) module Default : sig module Located : Ast_builder_intf.Located with type 'a with_loc := 'a Ast_builder_intf.with_location include module type of Ast_builder_generated.M include Ast_builder_intf.Additional_helpers with type 'a with_loc := 'a Ast_builder_intf.with_location end module type Loc = Ast_builder_intf.Loc module type S = Ast_builder_intf.S (** Build Ast helpers with the location argument factorized. *) module Make(Loc : Loc) : S (** Functional version of [Make]. *) val make : Location.t -> (module S) ppxlib-0.12.0/src/ast_builder_intf.ml000066400000000000000000000125251360512673700175450ustar00rootroot00000000000000open! Import module type Loc = sig val loc : Location.t end module type Additional_helpers = sig type 'a with_loc val eint : (int -> expression) with_loc val echar : (char -> expression) with_loc val estring : (string -> expression) with_loc val efloat : (string -> expression) with_loc val eint32 : (int32 -> expression) with_loc val eint64 : (int64 -> expression) with_loc val enativeint : (nativeint -> expression) with_loc val ebool : (bool -> expression) with_loc val pint : (int -> pattern) with_loc val pchar : (char -> pattern) with_loc val pstring : (string -> pattern) with_loc val pfloat : (string -> pattern) with_loc val pint32 : (int32 -> pattern) with_loc val pint64 : (int64 -> pattern) with_loc val pnativeint : (nativeint -> pattern) with_loc val pbool : (bool -> pattern) with_loc val eunit : expression with_loc val punit : pattern with_loc (** [evar id] produces a [Pexp_ident _] expression, it parses its input so you can pass any dot-separated identifier, for instance: [evar ~loc "Foo.bar"]. *) val evar : (string -> expression) with_loc val pvar : (string -> pattern ) with_loc (** Same as pexp_apply but without labels *) val eapply : (expression -> expression list -> expression) with_loc val eabstract : (pattern list -> expression -> expression) with_loc val esequence : (expression list -> expression) with_loc val ppat_tuple_opt : (pattern list -> pattern option) with_loc val pexp_tuple_opt : (expression list -> expression option) with_loc val pconstruct : constructor_declaration -> pattern option -> pattern val econstruct : constructor_declaration -> expression option -> expression val elist : (expression list -> expression) with_loc val plist : (pattern list -> pattern ) with_loc val pstr_value_list : loc:Location.t -> Asttypes.rec_flag -> value_binding list -> structure_item list (** [pstr_value_list ~loc rf vbs] = [pstr_value ~loc rf vbs] if [vbs <> []], [[]] otherwise. *) val nonrec_type_declaration : (name:string Loc.t -> params:(core_type * Asttypes.variance) list -> cstrs:(core_type * core_type * Location.t) list -> kind:type_kind -> private_:Asttypes.private_flag -> manifest:core_type option -> type_declaration ) with_loc [@@deprecated "[since 2016-10] use Nonrecursive on the P(str|sig)_type instead"] (** [unapplied_type_constr_conv] is the standard way to map identifiers to conversion fonctions, for preprocessor that creates values that follow the structure of types. More precisely, [path_conv path (sprintf "sexp_of_%s")] is: - sexp_of_t if path is "t" - A.B.sexp_of_foo if path is "A.B.foo" - A.B.sexp_of_f__foo (module A1) (module A2) if path is "A.B.F(A1)(A2).foo" [type_constr_conv] also applies it to a list of expression, which both prevents the compiler from allocating useless closures, and almost always what is needed, since type constructors are always applied. *) val unapplied_type_constr_conv : (Longident.t Loc.t -> f:(string -> string) -> expression) with_loc val type_constr_conv : (Longident.t Loc.t -> f:(string -> string) -> expression list -> expression) with_loc (** Tries to simplify [fun v1 v2 .. -> f v1 v2 ..] into [f]. Only works when [f] is a path, not an arbitrary expression as that would change the meaning of the code. This can be used either for cleaning up the generated code, or to reduce allocation if [f] is a local variable (the compiler won't optimize the allocation of the closure). Eta-reduction can change the types/behavior in some corner cases that are unlikely to show up in generated code: - if [f] has optional arguments, eta-expanding [f] can drop them - because labels commute, it can change the type of an expression: $ let f ~x y = x + y let f2 = fun x -> add x;; val f : x:int -> int -> int = val f2 : int -> x:int -> int = In fact, if [f] does side effects before receiving all its arguments, and if the eta-expansion is partially applied, eta-reducing could change behavior. [eta_reduce_if_possible_and_nonrec] is meant for the case where the resulting expression is going to be bound in a potentially recursive let-binding, where we have to keep the eta-expansion when [rec_flag] is [Recursive] to avoid a compile error. *) val eta_reduce : expression -> expression option val eta_reduce_if_possible : expression -> expression val eta_reduce_if_possible_and_nonrec : expression -> rec_flag:rec_flag -> expression end module type Located = sig type 'a with_loc type 'a t = 'a Loc.t val loc : _ t -> Location.t val mk : ('a -> 'a t) with_loc val map : ('a -> 'b) -> 'a t -> 'b t val map_lident : string t -> Longident.t t val lident : (string -> Longident.t t) with_loc end type 'a without_location = 'a type 'a with_location = loc:Location.t -> 'a module type S = sig module Located : Located with type 'a with_loc := 'a without_location include module type of Ast_builder_generated.Make(struct let loc = Location.none end) include Additional_helpers with type 'a with_loc := 'a without_location end ppxlib-0.12.0/src/ast_pattern.ml000066400000000000000000000147131360512673700165550ustar00rootroot00000000000000open! Import include Ast_pattern0 let save_context ctx = ctx.matched let restore_context ctx backup = ctx.matched <- backup let incr_matched c = c.matched <- c.matched + 1 let parse (T f) loc ?on_error x k = try f { matched = 0 } loc x k with Expected (loc, expected) -> match on_error with | None -> Location.raise_errorf ~loc "%s expected" expected | Some f -> f () module Packed = struct type ('a, 'b) t = T : ('a, 'b, 'c) Ast_pattern0.t * 'b -> ('a, 'c) t let create t f = T (t, f) let parse (T (t, f)) loc x = parse t loc x f end let __ = T (fun ctx _loc x k -> incr_matched ctx; k x) let __' = T (fun ctx loc x k -> incr_matched ctx; k { loc; txt = x }) let drop = T (fun ctx _loc _ k -> incr_matched ctx; k) let cst ~to_string ?(equal=Poly.equal) v = T (fun ctx loc x k -> if equal x v then begin incr_matched ctx; k end else fail loc (to_string v) );; let int v = cst ~to_string:Int.to_string v let char v = cst ~to_string:(Printf.sprintf "%C") v let string v = cst ~to_string:(Printf.sprintf "%S") v let float v = cst ~to_string:Float.to_string v let int32 v = cst ~to_string:Int32.to_string v let int64 v = cst ~to_string:Int64.to_string v let nativeint v = cst ~to_string:Nativeint.to_string v let bool v = cst ~to_string:Bool.to_string v let false_ = T (fun ctx loc x k -> match x with | false -> ctx.matched <- ctx.matched + 1; k | _ -> fail loc "false") ;; let true_ = T (fun ctx loc x k -> match x with | true -> ctx.matched <- ctx.matched + 1; k | _ -> fail loc "true") ;; let nil = T (fun ctx loc x k -> match x with | [] -> ctx.matched <- ctx.matched + 1; k | _ -> fail loc "[]") ;; let ( ^:: ) (T f0) (T f1) = T (fun ctx loc x k -> match x with | x0::x1 -> ctx.matched <- ctx.matched + 1; let k = f0 ctx loc x0 k in let k = f1 ctx loc x1 k in k | _ -> fail loc "::") ;; let none = T (fun ctx loc x k -> match x with | None -> ctx.matched <- ctx.matched + 1; k | _ -> fail loc "None") ;; let some (T f0) = T (fun ctx loc x k -> match x with | Some x0 -> ctx.matched <- ctx.matched + 1; let k = f0 ctx loc x0 k in k | _ -> fail loc "Some") ;; let pair (T f1) (T f2) = T (fun ctx loc (x1, x2) k -> let k = f1 ctx loc x1 k in let k = f2 ctx loc x2 k in k );; let ( ** ) = pair let triple (T f1) (T f2) (T f3) = T (fun ctx loc (x1, x2, x3) k -> let k = f1 ctx loc x1 k in let k = f2 ctx loc x2 k in let k = f3 ctx loc x3 k in k );; let alt (T f1) (T f2) = T (fun ctx loc x k -> let backup = save_context ctx in try f1 ctx loc x k with e1 -> let m1 = save_context ctx in restore_context ctx backup; try f2 ctx loc x k with e2 -> let m2 = save_context ctx in if m1 >= m2 then begin restore_context ctx m1; raise e1 end else raise e2 );; let ( ||| ) = alt let map (T func) ~f = T (fun ctx loc x k -> func ctx loc x (f k)) let map' (T func) ~f = T (fun ctx loc x k -> func ctx loc x (f loc k)) let map_result (T func) ~f = T (fun ctx loc x k -> f (func ctx loc x k)) let ( >>| ) t f = map t ~f let map0 (T func) ~f = T (fun ctx loc x k -> func ctx loc x ( k f )) let map1 (T func) ~f = T (fun ctx loc x k -> func ctx loc x (fun a -> k (f a ))) let map2 (T func) ~f = T (fun ctx loc x k -> func ctx loc x (fun a b -> k (f a b))) let map0' (T func) ~f = T (fun ctx loc x k -> func ctx loc x ( k (f loc ))) let map1' (T func) ~f = T (fun ctx loc x k -> func ctx loc x (fun a -> k (f loc a ))) let map2' (T func) ~f = T (fun ctx loc x k -> func ctx loc x (fun a b -> k (f loc a b))) let alt_option some none = alt (map1 some ~f:(fun x -> Some x)) (map0 none ~f:None) let many (T f) = T (fun ctx loc l k -> k (List.map l ~f:(fun x -> f ctx loc x (fun x -> x)))) ;; let loc (T f) = T (fun ctx _loc (x : _ Loc.t) k -> f ctx x.loc x.txt k) ;; let pack0 t = map t ~f:(fun f -> f ()) let pack2 t = map t ~f:(fun f x y -> f (x, y)) let pack3 t = map t ~f:(fun f x y z -> f (x, y, z)) include Ast_pattern_generated let echar t = pexp_constant (pconst_char t ) let estring t = pexp_constant (pconst_string t drop) let efloat t = pexp_constant (pconst_float t drop) let pchar t = ppat_constant (pconst_char t ) let pstring t = ppat_constant (pconst_string t drop) let pfloat t = ppat_constant (pconst_float t drop) let int' (T f) = T (fun ctx loc x k -> f ctx loc (Int.of_string x) k) let int32' (T f) = T (fun ctx loc x k -> f ctx loc (Int32.of_string x) k) let int64' (T f) = T (fun ctx loc x k -> f ctx loc (Int64.of_string x) k) let nativeint' (T f) = T (fun ctx loc x k -> f ctx loc (Nativeint.of_string x) k) let const_int t = pconst_integer (int' t) none let const_int32 t = pconst_integer (int32' t) (some (char 'l')) let const_int64 t = pconst_integer (int64' t) (some (char 'L')) let const_nativeint t = pconst_integer (nativeint' t) (some (char 'n')) let eint t = pexp_constant (const_int t) let eint32 t = pexp_constant (const_int32 t) let eint64 t = pexp_constant (const_int64 t) let enativeint t = pexp_constant (const_nativeint t) let pint t = ppat_constant (const_int t) let pint32 t = ppat_constant (const_int32 t) let pint64 t = ppat_constant (const_int64 t) let pnativeint t = ppat_constant (const_nativeint t) let single_expr_payload t = pstr (pstr_eval t nil ^:: nil) let no_label t = (cst Asttypes.Nolabel ~to_string:(fun _ -> "Nolabel")) ** t let extension (T f1) (T f2) = T (fun ctx loc ((name : _ Loc.t), payload) k -> let k = f1 ctx name.loc name.txt k in let k = f2 ctx loc payload k in k ) let rec parse_elist (e : Parsetree.expression) acc = Common.assert_no_attributes e.pexp_attributes; match e.pexp_desc with | Pexp_construct ({ txt = Lident "[]"; _ }, None) -> List.rev acc | Pexp_construct ({ txt = Lident "::"; _ }, Some arg) -> begin Common.assert_no_attributes arg.pexp_attributes; match arg.pexp_desc with | Pexp_tuple [hd; tl] -> parse_elist tl (hd :: acc) | _ -> fail arg.pexp_loc "list" end | _ -> fail e.pexp_loc "list" ;; let elist (T f) = T (fun ctx _loc e k -> let l = parse_elist e [] in incr_matched ctx; k (List.map l ~f:(fun x -> f ctx x.Parsetree.pexp_loc x (fun x -> x)))) ;; let of_func f = (T f) let to_func (T f) = f ppxlib-0.12.0/src/ast_pattern.mli000066400000000000000000000202431360512673700167210ustar00rootroot00000000000000(** First class AST patterns *) open! Import (** PPX rewriters often need to recognize fragments the OCaml AST, for instance to parse the payload of an attribute/expression. You can do that with a pattern matching and manual error reporting when the input is not what you expect but this has proven to quickly become extremely verbose and unreadable. This module aims to help with that by providing first class AST patterns. To understand how to use it, let's consider the example of ppx_inline_test. We want to recognize patterns of the form: {[ let%test "name" = expr ]} Which is a syntactic sugar for: {[ [%%test let "name" = expr] ]} If we wanted to write a function that recognizes the payload of [%%test] using normal pattern matching we would write: {[ let match_payload = function | Pstr [ { pstr_desc = Pstr_value (Nonrecursive, [ { pvb_pat = Ppat_constant (Constant_string (name, None)) ; pvb_expr = e ; _ } ]) ; _ } ] -> (name, e) | _ -> Location.raisef ... ]} This is quite cumbersome, and this is still not right: this function drops all attributes without notice. Now let's imagine we wanted to construct the payload instead, using [Ast_builder] one would write: {[ let build_payload ~loc name expr = let (module B) = Ast_builder.with_loc loc in let open B in pstr [ pstr_value Nonrecursive (value_binding ~pat:(pstring name) ~expr) ] ]} Constructing a first class pattern is almost as simple as replacing [Ast_builder] by [Ast_pattern]: {[ let payload_pattern name expr = let open Ast_pattern in pstr (pstr_value nonrecursive (value_binding ~pat:(pstring __) ~expr:__) ^:: nil) ]} Notice that the place-holders for [name] and [expr] have been replaced by [__]. The following pattern with have type: {[ (payload, string -> expression -> 'a, 'a) Ast_pattern.t ]} which means that it matches values of type [payload] and captures a string and expression from it. The two captured elements comes from the use of [__]. *) (** Type of a pattern: - ['a] is the type of value matched by the pattern - ['b] is the continuation, for instance for a pattern that captures an [int] and a [string], ['b] will be [int -> string -> _] - ['c] is the result of the continuation. *) type ('a, 'b, 'c) t = ('a, 'b, 'c) Ast_pattern0.t (** Matches a value against a pattern. *) val parse : ('a, 'b, 'c) t -> Location.t -> ?on_error:(unit -> 'c) -> 'a -> 'b -> 'c module Packed : sig type ('a, 'b, 'c) pattern = ('a, 'b, 'c) t type ('a, 'b) t val create : ('a, 'b, 'c) pattern -> 'b -> ('a, 'c) t val parse : ('a, 'b) t -> Location.t -> 'a -> 'b end with type ('a, 'b, 'c) pattern := ('a, 'b, 'c) t (** Pattern that captures its input. *) val __ : ('a, 'a -> 'b, 'b) t (** Same as [__] but also captures the location. Note: this should only be used for types that do not embed a location. For instance you can use it to capture a string constant: {[ estring __' ]} but using it to capture an expression would not yield the expected result: {[ pair (eint (int 42)) __' ]} In the latter case you should use the [pexp_loc] field of the captured expression instead. *) val __' : ('a, 'a Loc.t -> 'b, 'b) t (** [alt] stands for `alternatives'. It matches either the first pattern or the second one. *) val alt : ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t (** Same as [alt], for the common case where the left-hand-side captures a value but not the right-hand-side. *) val alt_option : ('a, 'v -> 'b, 'c) t -> ('a, 'b, 'c) t -> ('a, 'v option -> 'b, 'c) t (** Same as [alt] *) val ( ||| ) : ('a, 'b, 'c) t -> ('a, 'b, 'c) t -> ('a, 'b, 'c) t val map : ('a, 'b, 'c) t -> f:('d -> 'b) -> ('a, 'd, 'c) t val map' : ('a, 'b, 'c) t -> f:(Location.t -> 'd -> 'b) -> ('a, 'd, 'c) t val map_result : ('a, 'b, 'c) t -> f:('c -> 'd) -> ('a, 'b, 'd) t (** Same as [map] *) val ( >>| ) : ('a, 'b, 'c) t -> ('d -> 'b) -> ('a, 'd, 'c) t val map0 : ('a, 'b, 'c) t -> f: 'v -> ('a, 'v -> 'b, 'c) t val map1 : ('a, 'v1 -> 'b, 'c) t -> f:('v1 -> 'v) -> ('a, 'v -> 'b, 'c) t val map2 : ('a, 'v1 -> 'v2 -> 'b, 'c) t -> f:('v1 -> 'v2 -> 'v) -> ('a, 'v -> 'b, 'c) t val map0' : ('a, 'b, 'c) t -> f:(Location.t -> 'v) -> ('a, 'v -> 'b, 'c) t val map1' : ('a, 'v1 -> 'b, 'c) t -> f:(Location.t -> 'v1 -> 'v) -> ('a, 'v -> 'b, 'c) t val map2' : ('a, 'v1 -> 'v2 -> 'b, 'c) t -> f:(Location.t -> 'v1 -> 'v2 -> 'v) -> ('a, 'v -> 'b, 'c) t val nil : (_ list, 'a, 'a) t val ( ^:: ) : ('a, 'b, 'c) t -> ('a list, 'c, 'd) t -> ('a list, 'b, 'd) t val many : ('a, 'b -> 'b, 'c) t -> ('a list, 'c list -> 'd, 'd) t val int : int -> (int , 'a, 'a) t val char : char -> (char , 'a, 'a) t val string : string -> (string , 'a, 'a) t val float : float -> (float , 'a, 'a) t val int32 : int32 -> (int32 , 'a, 'a) t val int64 : int64 -> (int64 , 'a, 'a) t val nativeint : nativeint -> (nativeint , 'a, 'a) t val bool : bool -> (bool , 'a, 'a) t val cst : to_string:('a -> string) -> ?equal:('a -> 'a -> bool) -> 'a -> ('a, 'b, 'b) t val none : (_ option, 'a, 'a) t val some : ('a, 'b, 'c) t -> ('a option, 'b, 'c) t val pair : ('a1, 'b, 'c) t -> ('a2, 'c, 'd) t -> ('a1 * 'a2, 'b, 'd) t val ( ** ) : ('a1, 'b, 'c) t -> ('a2, 'c, 'd) t -> ('a1 * 'a2, 'b, 'd) t val triple : ('a1, 'b, 'c) t -> ('a2, 'c, 'd) t -> ('a3, 'd, 'e) t -> ('a1 * 'a2 * 'a3, 'b, 'e) t val loc : ('a, 'b, 'c) t -> ('a Loc.t, 'b, 'c) t val pack0 : ('a, 'b, 'c) t -> ('a, unit -> 'b, 'c) t val pack2 : ('a, 'b -> 'c -> 'd, 'e) t -> ('a, 'b * 'c -> 'd, 'e) t val pack3 : ('a, 'b -> 'c -> 'd -> 'e, 'f) t -> ('a, 'b * 'c * 'd -> 'e, 'f) t (** AST patterns for each constructur/record of the parsetree are generated in the same way AST builders are generated. In addition, for every {it wrapper} we generate a pattern to match the [loc] and [attributes] fields. For instanct for the [expression] type: {[ val pexp_loc : (Location.t, 'a, 'b) t -> (expression, 'b, 'c) t -> (expression, 'a, 'c) t val pexp_attributes : (attributes, 'a, 'b) t -> (expression, 'b, 'c) t -> (expression, 'a, 'c) t ]} *) include module type of Ast_pattern_generated val true_ : (bool, 'a, 'a) t val false_ : (bool, 'a, 'a) t val eint : (int , 'a, 'b) t -> (expression, 'a, 'b) t val echar : (char , 'a, 'b) t -> (expression, 'a, 'b) t val estring : (string , 'a, 'b) t -> (expression, 'a, 'b) t val efloat : (string , 'a, 'b) t -> (expression, 'a, 'b) t val eint32 : (int32 , 'a, 'b) t -> (expression, 'a, 'b) t val eint64 : (int64 , 'a, 'b) t -> (expression, 'a, 'b) t val enativeint : (nativeint , 'a, 'b) t -> (expression, 'a, 'b) t val pint : (int , 'a, 'b) t -> (pattern, 'a, 'b) t val pchar : (char , 'a, 'b) t -> (pattern, 'a, 'b) t val pstring : (string , 'a, 'b) t -> (pattern, 'a, 'b) t val pfloat : (string , 'a, 'b) t -> (pattern, 'a, 'b) t val pint32 : (int32 , 'a, 'b) t -> (pattern, 'a, 'b) t val pint64 : (int64 , 'a, 'b) t -> (pattern, 'a, 'b) t val pnativeint : (nativeint , 'a, 'b) t -> (pattern, 'a, 'b) t val single_expr_payload : (expression, 'a, 'b) t -> (payload, 'a, 'b) t val no_label : (expression, 'a, 'b) t -> (Asttypes.arg_label * expression, 'a, 'b) t val attribute : name:(string, 'a, 'b) t -> payload:(payload, 'b, 'c) t -> (attribute, 'a, 'c) t val extension : (string, 'a, 'b) t -> (payload, 'b, 'c) t -> (extension, 'a, 'c) t val elist : (expression, 'a -> 'a, 'b) t -> (expression, 'b list -> 'c, 'c) t type context val of_func : (context -> Location.t -> 'a -> 'b -> 'c) -> ('a, 'b, 'c) t val to_func : ('a, 'b, 'c) t -> (context -> Location.t -> 'a -> 'b -> 'c) ppxlib-0.12.0/src/ast_pattern0.ml000066400000000000000000000011561360512673700166320ustar00rootroot00000000000000open! Import exception Expected of Location.t * string let fail loc expected = raise (Expected (loc, expected)) ;; type context = { (* [matched] counts how many constructors have been matched. This is used to find what pattern matches the most some piece of ast in [Ast_pattern.alt]. In the case where all branches fail to match, we report the error from the one that matches the most. This is only incremented by combinators that can fail. *) mutable matched : int } type ('matched_value, 'k, 'k_result) t = T of (context -> Location.t -> 'matched_value -> 'k -> 'k_result) ppxlib-0.12.0/src/ast_traverse.ml000066400000000000000000000106731360512673700167340ustar00rootroot00000000000000open! Import class map = object inherit Ppxlib_traverse_builtins.map inherit Ast.map end class iter = object inherit Ppxlib_traverse_builtins.iter inherit Ast.iter end class ['acc] fold = object inherit ['acc] Ppxlib_traverse_builtins.fold inherit ['acc] Ast.fold end class ['acc] fold_map = object inherit ['acc] Ppxlib_traverse_builtins.fold_map inherit ['acc] Ast.fold_map end class ['ctx] map_with_context = object inherit ['ctx] Ppxlib_traverse_builtins.map_with_context inherit ['ctx] Ast.map_with_context end class virtual ['res] lift = object inherit ['res] Ppxlib_traverse_builtins.lift inherit ['res] Ast.lift end let enter name path = if String.is_empty path then name else path ^ "." ^ name class map_with_path = object inherit [string] map_with_context as super (* WAS: method! structure_item_desc path x = match x with | Pstr_module mb -> super#structure_item_desc (enter mb.pmb_name.txt path) x | _ -> super#structure_item_desc path x Overriding [module_binding] seems to be OK because it does not catch local module bindings because at the moment the parsetree doesn't make use of [module_binding] for local modules, but that might change in the future, so this might be something to keep in mind. The following: module A = struct .. end module A = struct .. end is disallowed, but let _ = .. let module A = struct .. end in .. module A = struct .. end let _ = .. let module A = struct .. end in .. isn't, and the "path" constructed here would be able to differentiate between them. *) method! module_binding path mb = super#module_binding (enter mb.pmb_name.txt path) mb method! module_declaration path md = super#module_declaration (enter md.pmd_name.txt path) md method! module_type_declaration path mtd = super#module_type_declaration (enter mtd.pmtd_name.txt path) mtd end let var_names_of = object inherit [string list] fold as super method! pattern p acc = let acc = super#pattern p acc in match p.ppat_desc with | Ppat_var {txt; _} -> txt :: acc | _ -> acc end class map_with_expansion_context = object (self) inherit [Expansion_context.Base.t] map_with_context as super method! expression ctxt expr = super#expression (Expansion_context.Base.enter_expr ctxt) expr method! module_binding ctxt mb = super#module_binding (Expansion_context.Base.enter_module ~loc:mb.pmb_loc mb.pmb_name.txt ctxt) mb method! module_declaration ctxt md = super#module_declaration (Expansion_context.Base.enter_module ~loc:md.pmd_loc md.pmd_name.txt ctxt) md method! module_type_declaration ctxt mtd = super#module_type_declaration (Expansion_context.Base.enter_module ~loc:mtd.pmtd_loc mtd.pmtd_name.txt ctxt) mtd method! value_description ctxt vd = super#value_description (Expansion_context.Base.enter_value ~loc:vd.pval_loc vd.pval_name.txt ctxt) vd method! value_binding ctxt {pvb_pat; pvb_expr; pvb_attributes; pvb_loc} = let all_var_names = var_names_of#pattern pvb_pat [] in let var_name = Base.List.last all_var_names in let in_binding_ctxt = Base.Option.fold var_name ~init:ctxt ~f:(fun ctxt var_name -> Expansion_context.Base.enter_value ~loc:pvb_loc var_name ctxt) in let pvb_pat = self#pattern ctxt pvb_pat in let pvb_expr = self#expression in_binding_ctxt pvb_expr in let pvb_attributes = self#attributes in_binding_ctxt pvb_attributes in let pvb_loc = self#location ctxt pvb_loc in { pvb_pat; pvb_expr; pvb_attributes; pvb_loc } end class sexp_of = object inherit [Sexp.t] Ast.lift method int = sexp_of_int method string = sexp_of_string method bool = sexp_of_bool method char = sexp_of_char method float = sexp_of_float method int32 = sexp_of_int32 method int64 = sexp_of_int64 method nativeint = sexp_of_nativeint method unit = sexp_of_unit method option = sexp_of_option method list = sexp_of_list method array : 'a. ('a -> Sexp.t) -> 'a array -> Sexp.t = sexp_of_array method other : 'a. 'a -> Sexp.t = fun _ -> Sexp.Atom "_" method record fields = List (List.map fields ~f:(fun (label, sexp) -> Sexp.List [Atom label; sexp])) method constr tag args = match args with | [] -> Atom tag | _ -> List (Atom tag :: args) method tuple l = List l end let sexp_of = new sexp_of ppxlib-0.12.0/src/ast_traverse.mli000066400000000000000000000033131360512673700170760ustar00rootroot00000000000000(** AST traversal classes *) open! Import (** To use these classes, inherit from them and override the methods corresponding to the types from [Parsetree] you want to process. For instance to collect all the string constants in a structure: {[ let string_constants_of = object inherit [string list] Ast_traverse.fold as super method! expression e acc = let acc = super#expression e acc in match e.pexp_desc with | Pexp_constant (Const_string (s, _)) -> s :: acc | _ -> acc method! pattern p acc = let acc = super#pattern p acc in match p.ppat_desc with | Ppat_constant (Const_string (s, _)) -> s :: acc | _ -> acc end let string_constants_of_structure = string_constants_of#structure ]} *) class map : object inherit Ppxlib_traverse_builtins.map inherit Ast.map end class iter : object inherit Ppxlib_traverse_builtins.iter inherit Ast.iter end class ['acc] fold : object inherit ['acc] Ppxlib_traverse_builtins.fold inherit ['acc] Ast.fold end class ['acc] fold_map : object inherit ['acc] Ppxlib_traverse_builtins.fold_map inherit ['acc] Ast.fold_map end class ['ctx] map_with_context : object inherit ['ctx] Ppxlib_traverse_builtins.map_with_context inherit ['ctx] Ast.map_with_context end class map_with_path : [string] map_with_context class map_with_expansion_context : [Expansion_context.Base.t] map_with_context class virtual ['res] lift : object inherit ['res] Ppxlib_traverse_builtins.lift inherit ['res] Ast.lift end class sexp_of : object inherit [Sexp.t] Ppxlib_traverse_builtins.std_lifters inherit [Sexp.t] Ast.lift end val sexp_of : sexp_of ppxlib-0.12.0/src/attribute.ml000066400000000000000000000554551360512673700162440ustar00rootroot00000000000000open! Import let poly_equal a b = let module Poly = struct type t = T : _ -> t end in Base.Poly.equal (Poly.T a) (Poly.T b) ;; module Context = struct type 'a t = | Label_declaration : label_declaration t | Constructor_declaration : constructor_declaration t | Type_declaration : type_declaration t | Type_exception : type_exception t | Type_extension : type_extension t | Extension_constructor : extension_constructor t | Pattern : pattern t | Core_type : core_type t | Expression : expression t | Value_description : value_description t | Class_type : class_type t | Class_type_field : class_type_field t | Class_infos : _ class_infos t | Class_expr : class_expr t | Class_field : class_field t | Module_type : module_type t | Module_declaration : module_declaration t | Module_type_declaration : module_type_declaration t | Module_substitution : module_substitution t | Open_description : open_description t | Open_declaration : open_declaration t | Include_infos : _ include_infos t | Module_expr : module_expr t | Value_binding : value_binding t | Module_binding : module_binding t | Pstr_eval : structure_item t | Pstr_extension : structure_item t | Psig_extension : signature_item t | Rtag : row_field t | Object_type_field : object_field t let label_declaration = Label_declaration let constructor_declaration = Constructor_declaration let type_declaration = Type_declaration let type_extension = Type_extension let type_exception = Type_exception let extension_constructor = Extension_constructor let pattern = Pattern let core_type = Core_type let expression = Expression let value_description = Value_description let class_type = Class_type let class_type_field = Class_type_field let class_infos = Class_infos let class_expr = Class_expr let class_field = Class_field let module_type = Module_type let module_declaration = Module_declaration let module_type_declaration = Module_type_declaration let open_description = Open_description let include_infos = Include_infos let module_expr = Module_expr let value_binding = Value_binding let module_binding = Module_binding let pstr_eval = Pstr_eval let pstr_extension = Pstr_extension let psig_extension = Psig_extension let rtag = Rtag let object_type_field = Object_type_field let get_pstr_eval st = match st.pstr_desc with | Pstr_eval (e, l) -> (e, l) | _ -> failwith "Attribute.Context.get_pstr_eval" let get_pstr_extension st = match st.pstr_desc with | Pstr_extension (e, l) -> (e, l) | _ -> failwith "Attribute.Context.get_pstr_extension" let get_psig_extension st = match st.psig_desc with | Psig_extension (e, l) -> (e, l) | _ -> failwith "Attribute.Context.get_psig_extension" let get_attributes : type a. a t -> a -> attributes = fun t x -> match t with | Label_declaration -> x.pld_attributes | Constructor_declaration -> x.pcd_attributes | Type_declaration -> x.ptype_attributes | Type_extension -> x.ptyext_attributes | Type_exception -> x.ptyexn_attributes | Extension_constructor -> x.pext_attributes | Pattern -> x.ppat_attributes | Core_type -> x.ptyp_attributes | Expression -> x.pexp_attributes | Value_description -> x.pval_attributes | Class_type -> x.pcty_attributes | Class_type_field -> x.pctf_attributes | Class_infos -> x.pci_attributes | Class_expr -> x.pcl_attributes | Class_field -> x.pcf_attributes | Module_type -> x.pmty_attributes | Module_declaration -> x.pmd_attributes | Module_type_declaration -> x.pmtd_attributes | Module_substitution -> x.pms_attributes | Open_description -> x.popen_attributes | Open_declaration -> x.popen_attributes | Include_infos -> x.pincl_attributes | Module_expr -> x.pmod_attributes | Value_binding -> x.pvb_attributes | Module_binding -> x.pmb_attributes | Pstr_eval -> snd (get_pstr_eval x) | Pstr_extension -> snd (get_pstr_extension x) | Psig_extension -> snd (get_psig_extension x) | Rtag -> x.prf_attributes | Object_type_field -> x.pof_attributes let set_attributes : type a. a t -> a -> attributes -> a = fun t x attrs -> match t with | Label_declaration -> { x with pld_attributes = attrs } | Constructor_declaration -> { x with pcd_attributes = attrs } | Type_declaration -> { x with ptype_attributes = attrs } | Type_extension -> { x with ptyext_attributes = attrs } | Type_exception -> { x with ptyexn_attributes = attrs } | Extension_constructor -> { x with pext_attributes = attrs } | Pattern -> { x with ppat_attributes = attrs } | Core_type -> { x with ptyp_attributes = attrs } | Expression -> { x with pexp_attributes = attrs } | Value_description -> { x with pval_attributes = attrs } | Class_type -> { x with pcty_attributes = attrs } | Class_type_field -> { x with pctf_attributes = attrs } | Class_infos -> { x with pci_attributes = attrs } | Class_expr -> { x with pcl_attributes = attrs } | Class_field -> { x with pcf_attributes = attrs } | Module_type -> { x with pmty_attributes = attrs } | Module_declaration -> { x with pmd_attributes = attrs } | Module_type_declaration -> { x with pmtd_attributes = attrs } | Module_substitution -> { x with pms_attributes = attrs } | Open_description -> { x with popen_attributes = attrs } | Open_declaration -> { x with popen_attributes = attrs } | Include_infos -> { x with pincl_attributes = attrs } | Module_expr -> { x with pmod_attributes = attrs } | Value_binding -> { x with pvb_attributes = attrs } | Module_binding -> { x with pmb_attributes = attrs } | Pstr_eval -> { x with pstr_desc = Pstr_eval (get_pstr_eval x |> fst, attrs) } | Pstr_extension -> { x with pstr_desc = Pstr_extension (get_pstr_extension x |> fst, attrs) } | Psig_extension -> { x with psig_desc = Psig_extension (get_psig_extension x |> fst, attrs) } | Rtag -> { x with prf_attributes = attrs} | Object_type_field -> { x with pof_attributes = attrs} let desc : type a. a t -> string = function | Label_declaration -> "label declaration" | Constructor_declaration -> "constructor declaration" | Type_declaration -> "type declaration" | Type_extension -> "type extension" | Type_exception -> "type exception" | Extension_constructor -> "extension constructor" | Pattern -> "pattern" | Core_type -> "core type" | Expression -> "expression" | Value_description -> "value" | Class_type -> "class type" | Class_type_field -> "class type field" | Class_infos -> "class declaration" | Class_expr -> "class expression" | Class_field -> "class field" | Module_type -> "module type" | Module_declaration -> "module declaration" | Module_type_declaration -> "module type declaration" | Module_substitution -> "module substitution" | Open_description -> "open" | Open_declaration -> "open" | Include_infos -> "include" | Module_expr -> "module expression" | Value_binding -> "value binding" | Module_binding -> "module binding" | Pstr_eval -> "toplevel expression" | Pstr_extension -> "toplevel extension" | Psig_extension -> "toplevel signature extension" | Rtag -> "polymorphic variant tag" | Object_type_field -> "object type field" (* let pattern : type a b c d. a t -> (attributes, b, c) Ast_pattern.t -> (a, c, d) Ast_pattern.t -> (a, b, d) Ast_pattern.t = function | Label_declaration -> Ast_pattern.pld_attributes | Constructor_declaration -> Ast_pattern.pcd_attributes | Type_declaration -> Ast_pattern.ptype_attributes | Type_extension -> Ast_pattern.ptyext_attributes | Extension_constructor -> Ast_pattern.pext_attributes *) let equal : _ t -> _ t -> bool = poly_equal end module Floating_context = struct type 'a t = | Structure_item : structure_item t | Signature_item : signature_item t | Class_field : class_field t | Class_type_field : class_type_field t let structure_item = Structure_item let signature_item = Signature_item let class_field = Class_field let class_type_field = Class_type_field let get_attribute_if_is_floating_node : type a. a t -> a -> attribute option = fun t x -> match t, x with | Structure_item , { pstr_desc = Pstr_attribute a; _ } -> Some a | Signature_item , { psig_desc = Psig_attribute a; _ } -> Some a | Class_field , { pcf_desc = Pcf_attribute a; _ } -> Some a | Class_type_field , { pctf_desc = Pctf_attribute a; _ } -> Some a | _ -> None let get_attribute t x = match get_attribute_if_is_floating_node t x with | Some a -> a | None -> failwith "Attribute.Floating.Context.get_attribute" let replace_by_dummy : type a. a t -> a -> a = let dummy_ext = ({ txt = ""; loc = Location.none }, PStr []) in fun t x -> match t with | Structure_item -> { x with pstr_desc = Pstr_extension (dummy_ext, []) } | Signature_item -> { x with psig_desc = Psig_extension (dummy_ext, []) } | Class_field -> { x with pcf_desc = Pcf_extension dummy_ext } | Class_type_field -> { x with pctf_desc = Pctf_extension dummy_ext } let desc : type a. a t -> string = function | Structure_item -> "structure item" | Signature_item -> "signature item" | Class_field -> "class field" | Class_type_field -> "class type field" let equal : _ t -> _ t -> bool = poly_equal end type packed_context = | On_item : _ Context.t -> packed_context | Floating : _ Floating_context.t -> packed_context type _ payload_parser = Payload_parser : (payload, 'a, 'b) Ast_pattern.t * (name_loc:Location.t -> 'a) -> 'b payload_parser type ('a, 'b) t = { name : Name.Pattern.t ; context : 'a Context.t ; payload : 'b payload_parser } type packed = T : (_, _) t -> packed let name t = Name.Pattern.name t.name let context t = t.context let registrar = Name.Registrar.create ~kind:"attribute" ~current_file:__FILE__ ~string_of_context:(function | On_item t -> Some (Context .desc t) | Floating t -> Some (Floating_context.desc t ^ " (floating)")) ;; let declare_with_name_loc name context pattern k = Name.Registrar.register ~kind:`Attribute registrar (On_item context) name; { name = Name.Pattern.make name ; context ; payload = Payload_parser (pattern, k) } ;; let declare name context pattern k = declare_with_name_loc name context pattern (fun ~name_loc:_ -> k) ;; module Attribute_table = Caml.Hashtbl.Make(struct type t = string loc let hash : t -> int = Hashtbl.hash let equal : t -> t -> bool = Poly.equal end) let not_seen = Attribute_table.create 128 let mark_as_seen { attr_name; _ } = Attribute_table.remove not_seen attr_name ;; let mark_as_handled_manually = mark_as_seen let explicitly_drop = object inherit Ast_traverse.iter method! attribute = mark_as_seen end let get_internal = let rec find_best_match t attributes longest_match = match attributes with | [] -> longest_match | { attr_name = name; _ } as attr :: rest -> if Name.Pattern.matches t.name name.txt then begin match longest_match with | None -> find_best_match t rest (Some attr) | Some { attr_name = name'; _ } -> let len = String.length name.txt in let len' = String.length name'.txt in if len > len' then find_best_match t rest (Some attr) else if len < len' then find_best_match t rest longest_match else Location.raise_errorf ~loc:name.loc "Duplicated attribute" end else find_best_match t rest longest_match in fun t attributes -> find_best_match t attributes None ;; let convert ?(do_mark_as_seen = true) pattern attr = if do_mark_as_seen then mark_as_seen attr; let (Payload_parser (pattern, k)) = pattern in Ast_pattern.parse pattern (Common.loc_of_payload attr) attr.attr_payload (k ~name_loc:attr.attr_name.loc) ;; let get t ?mark_as_seen:do_mark_as_seen x = let attrs = Context.get_attributes t.context x in match get_internal t attrs with | None -> None | Some attr -> Some (convert t.payload attr ?do_mark_as_seen) ;; let consume t x = let attrs = Context.get_attributes t.context x in match get_internal t attrs with | None -> None | Some attr -> let attrs = List.filter attrs ~f:(fun attr' -> not (phys_equal attr attr')) in let x = Context.set_attributes t.context x attrs in Some (x, convert t.payload attr) ;; let remove_seen (type a) (context : a Context.t) packeds (x : a) = let attrs = Context.get_attributes context x in let matched = let rec loop acc = function | [] -> acc | T t :: rest -> if Context.equal t.context context then match get_internal t attrs with | None -> loop acc rest | Some attr -> let name = attr.attr_name in if Attribute_table.mem not_seen name then loop acc rest else loop (attr :: acc) rest else loop acc rest in loop [] packeds in let attrs = List.filter attrs ~f:(fun attr' -> not (List.mem matched attr' ~equal:phys_equal)) in Context.set_attributes context x attrs ;; let pattern t p = let f = Ast_pattern.to_func p in Ast_pattern.of_func (fun ctx loc x k -> match consume t x with | None -> f ctx loc x (k None) | Some (x, v) -> f ctx loc x (k (Some v)) ) ;; module Floating = struct module Context = Floating_context type ('a, 'b) t = { name : Name.Pattern.t ; context : 'a Context.t ; payload : 'b payload_parser } let name t = Name.Pattern.name t.name let declare name context pattern k = Name.Registrar.register ~kind:`Attribute registrar (Floating context) name; { name = Name.Pattern.make name ; context ; payload = Payload_parser (pattern, fun ~name_loc:_ -> k) } ;; let convert ts x = match ts with | [] -> None | { context; _ } :: _ -> assert (List.for_all ts ~f:(fun t -> Context.equal t.context context)); let attr = Context.get_attribute context x in let name = attr.attr_name in match List.filter ts ~f:(fun t -> Name.Pattern.matches t.name name.txt) with | [] -> None | [t] -> Some (convert t.payload attr) | l -> Location.raise_errorf ~loc:name.loc "Multiple match for floating attributes: %s" (String.concat ~sep:", " (List.map l ~f:(fun t -> Name.Pattern.name t.name))) ;; end let check_attribute registrar context name = if not (Name.Whitelisted.is_whitelisted ~kind:`Attribute name.txt || Name.ignore_checks name.txt) && Attribute_table.mem not_seen name then let white_list = Name.Whitelisted.get_attribute_list () in Name.Registrar.raise_errorf registrar context ~white_list "Attribute `%s' was not used" name ;; let check_unused = object(self) inherit Ast_traverse.iter as super method! attribute { attr_name = name; _ } = Location.raise_errorf ~loc:name.loc "attribute not expected here, Ppxlib.Attribute needs updating!" method private check_node : type a. a Context.t -> a -> a = fun context node -> let attrs = Context.get_attributes context node in match attrs with | [] -> node | _ -> List.iter attrs ~f:(fun ({ attr_name = name; attr_payload = payload; _ } as attr) -> self#payload payload; check_attribute registrar (On_item context) name; (* If we allow the attribute to pass through, mark it as seen *) mark_as_seen attr); Context.set_attributes context node [] method private check_floating : type a. a Floating.Context.t -> a -> a = fun context node -> match Floating.Context.get_attribute_if_is_floating_node context node with | None -> node | Some ({ attr_name = name; attr_payload = payload; _ } as attr) -> self#payload payload; check_attribute registrar (Floating context) name; mark_as_seen attr; Floating.Context.replace_by_dummy context node method! label_declaration x = super#label_declaration (self#check_node Label_declaration x) method! constructor_declaration x = super#constructor_declaration (self#check_node Constructor_declaration x) method! type_declaration x = super#type_declaration (self#check_node Type_declaration x) method! type_extension x = super#type_extension (self#check_node Type_extension x) method! type_exception x = super#type_exception (self#check_node Type_exception x) method! extension_constructor x = super#extension_constructor (self#check_node Extension_constructor x) method! pattern x = super#pattern (self#check_node Pattern x) method! core_type x = super#core_type (self#check_node Core_type x) method! expression x = super#expression (self#check_node Expression x) method! value_description x = super#value_description (self#check_node Value_description x) method! class_type x = super#class_type (self#check_node Class_type x) method! class_infos f x = super#class_infos f (self#check_node Class_infos x) method! class_expr x = super#class_expr (self#check_node Class_expr x) method! module_type x = super#module_type (self#check_node Module_type x) method! module_declaration x = super#module_declaration (self#check_node Module_declaration x) method! module_type_declaration x = super#module_type_declaration (self#check_node Module_type_declaration x) method! open_description x = super#open_description (self#check_node Open_description x) method! open_declaration x = super#open_declaration (self#check_node Open_declaration x) method! include_infos f x = super#include_infos f (self#check_node Include_infos x) method! module_expr x = super#module_expr (self#check_node Module_expr x) method! value_binding x = super#value_binding (self#check_node Value_binding x) method! module_binding x = super#module_binding (self#check_node Module_binding x) method! class_field x = let x = self#check_node Class_field x in let x = self#check_floating Class_field x in super#class_field x method! class_type_field x = let x = self#check_node Class_type_field x in let x = self#check_floating Class_type_field x in super#class_type_field x method! row_field x = let x = match x.prf_desc with | Rtag _ -> self#check_node Rtag x | _ -> x in super#row_field x method! core_type_desc x = let x = match x with | Ptyp_object (fields, closed_flag) -> let fields = List.map fields ~f:(self#check_node Object_type_field) in Ptyp_object (fields, closed_flag) | _ -> x in super#core_type_desc x method! structure_item item = let item = self#check_floating Structure_item item in let item = match item.pstr_desc with | Pstr_eval _ -> self#check_node Pstr_eval item | Pstr_extension _ -> self#check_node Pstr_extension item | _ -> item in super#structure_item item method! signature_item item = let item = self#check_floating Signature_item item in let item = match item.psig_desc with | Psig_extension _ -> self#check_node Psig_extension item | _ -> item in super#signature_item item end let reset_checks () = Attribute_table.clear not_seen let collect = object inherit Ast_traverse.iter as super method! attribute ({ attr_name = name; attr_payload = payload; _ } as attr) = let loc = Common.loc_of_attribute attr in super#payload payload; Attribute_table.add not_seen name loc end let check_all_seen () = let fail name loc = let txt = name.txt in if not (Name.ignore_checks txt) then Location.raise_errorf ~loc "Attribute `%s' was silently dropped" txt in Attribute_table.iter fail not_seen ;; let remove_attributes_present_in table = object inherit Ast_traverse.iter as super method! attribute { attr_name = name; attr_payload = payload; _ } = super#payload payload; Attribute_table.remove table name end let copy_of_not_seen () = let copy = Attribute_table.create (Attribute_table.length not_seen) in Attribute_table.iter (Attribute_table.add copy) not_seen; copy ;; let dropped_so_far_structure st = let table = copy_of_not_seen () in (remove_attributes_present_in table)#structure st; Attribute_table.fold (fun name loc acc -> { txt = name.txt; loc } :: acc) table [] ;; let dropped_so_far_signature sg = let table = copy_of_not_seen () in (remove_attributes_present_in table)#signature sg; Attribute_table.fold (fun name loc acc -> { txt = name.txt; loc } :: acc) table [] ;; ppxlib-0.12.0/src/attribute.mli000066400000000000000000000207701360512673700164050ustar00rootroot00000000000000(** Attribute hygiene *) (** This module provides hygiene for attributes. The goal is to report misuses of attributes to the user as soon as possible so that no mistyped attribute get silently ignored. *) open! Import type ('context, 'payload) t (** Type of declared attribute. The ['context] type parameter describes where the attribute is expected and the ['payload] one what its payload should contain. *) type packed = T : (_, _) t -> packed module Context : sig type 'a t = | Label_declaration : label_declaration t | Constructor_declaration : constructor_declaration t | Type_declaration : type_declaration t | Type_exception : type_exception t | Type_extension : type_extension t | Extension_constructor : extension_constructor t | Pattern : pattern t | Core_type : core_type t | Expression : expression t | Value_description : value_description t | Class_type : class_type t | Class_type_field : class_type_field t | Class_infos : _ class_infos t | Class_expr : class_expr t | Class_field : class_field t | Module_type : module_type t | Module_declaration : module_declaration t | Module_type_declaration : module_type_declaration t | Module_substitution : module_substitution t | Open_description : open_description t | Open_declaration : open_declaration t | Include_infos : _ include_infos t | Module_expr : module_expr t | Value_binding : value_binding t | Module_binding : module_binding t | Pstr_eval : structure_item t | Pstr_extension : structure_item t | Psig_extension : signature_item t | Rtag : row_field t | Object_type_field : object_field t val label_declaration : label_declaration t val constructor_declaration : constructor_declaration t val type_declaration : type_declaration t val type_extension : type_extension t val type_exception : type_exception t val extension_constructor : extension_constructor t val pattern : pattern t val core_type : core_type t val expression : expression t val value_description : value_description t val class_type : class_type t val class_type_field : class_type_field t val class_infos : _ class_infos t val class_expr : class_expr t val class_field : class_field t val module_type : module_type t val module_declaration : module_declaration t val module_type_declaration : module_type_declaration t val open_description : open_description t val include_infos : _ include_infos t val module_expr : module_expr t val value_binding : value_binding t val module_binding : module_binding t val pstr_eval : structure_item t val pstr_extension : structure_item t val psig_extension : signature_item t val rtag : row_field t val object_type_field : object_field t end (** [declare fully_qualified_name context payload_pattern k] declares an attribute. [k] is used to build the value resulting from parsing the payload. For instance if a rewriter named "foo" expect the attribute [@@default] on record field declaration with an expression as payload: {[ let default = Attribute.declare "foo.default" Attribute.Context.label_declaration Ast_pattern.(pstr (pstr_eval __ nil)) (fun x -> x) ;; ]} [fully_qualified_name] is expected to be a dot-separated list of names. When matching, any full suffix will be accepted. So for instance an attribute declared with name "foo.bar.default" will match exactly these attribute names: "default", "bar.default" and "foo.bar.default". Additionally it is possible to prevent a suffix to be shortened by prefixing it with '@'. So for instance an attribute declared with name "foo.@bar.default" will match exactly these attribute names: "bar.default" and "foo.bar.default". When matching against a list of attributes on an item, if several matches are possible, the longest one is used. For instance using the attribute "foo.default" declared in the previous example, on this code it will match the [@foo.default 0] attribute: {[ type t = { x : int [@default 42] [@foo.default 0] } ]} This is to allow the user to specify a [@default] attribute for all re-writers that use it but still put a specific one for one specific re-writer. It is not allowed to declare an attribute with a name that matches a previously-defined one on the same context. For instance trying to declare the same attribute twice will fail. *) val declare : string -> 'a Context.t -> (payload, 'b, 'c) Ast_pattern.t -> 'b -> ('a, 'c) t (** Same as [declare] but the callback receives the location of the name of the attribute. *) val declare_with_name_loc : string -> 'a Context.t -> (payload, 'b, 'c) Ast_pattern.t -> (name_loc:Location.t -> 'b) -> ('a, 'c) t val name : _ t -> string val context : ('a, _) t -> 'a Context.t (** Gets the associated attribute value. Marks the attribute as seen unless [mark_as_seen=false]. *) val get : ('a, 'b) t -> ?mark_as_seen:bool (** default [true] *) -> 'a -> 'b option (** [consume t x] returns the value associated to attribute [t] on [x] if present as well as [x] with [t] removed. *) val consume : ('a, 'b) t -> 'a -> ('a * 'b) option (** [remove_seen x attrs] removes the set of attributes matched by elements of [attrs]. Only remove them if they where seen by {!get} or {!consume}. *) val remove_seen : 'a Context.t -> packed list -> 'a -> 'a module Floating : sig type ('context, 'payload) t module Context : sig type 'a t = | Structure_item : structure_item t | Signature_item : signature_item t | Class_field : class_field t | Class_type_field : class_type_field t val structure_item : structure_item t val signature_item : signature_item t val class_field : class_field t val class_type_field : class_type_field t end val declare : string -> 'a Context.t -> (payload, 'b, 'c) Ast_pattern.t -> 'b -> ('a, 'c) t val name : _ t -> string val convert : ('a, 'b) t list -> 'a -> 'b option end (** Code that is voluntarily dropped by a rewriter needs to be given to this object. All attributes inside will be marked as handled. *) val explicitly_drop : Ast_traverse.iter (** Raise if there are unused attributes *) val check_unused : Ast_traverse.iter (** Collect all attribute names. To be used in conjuction with {!check_all_seen}. *) val collect : Ast_traverse.iter (** Check that all attributes collected by {!freshen_and_collect} have been: - matched at least once by one of: {!get}, {!consume} or {!Floating.convert} - seen by [check_unused] (to allow white-listed attributed to pass through) This helps with faulty ppx rewriters that silently drop attributes. *) val check_all_seen : unit -> unit (** Mark an attribute as seen and handled. This is only to make ppx rewriters that don't use ppxlib works well with the ones that do use it. *) val mark_as_handled_manually : attribute -> unit (** Return the list of attributes that have been dropped so far: attributes that haven't been marked and are not present in the given AST. This is used to debug extensions that drop attributes. *) val dropped_so_far_structure : structure -> string Loc.t list val dropped_so_far_signature : signature -> string Loc.t list val reset_checks : unit -> unit val pattern : ('a, 'b) t -> ('a, 'c, 'd) Ast_pattern.t -> ('a, 'b option -> 'c, 'd) Ast_pattern.t ppxlib-0.12.0/src/caller_id.ml000066400000000000000000000012541360512673700161430ustar00rootroot00000000000000open! Import module Printexc = Caml.Printexc (* Small helper to find out who is the caller of a function *) type t = Printexc.location option let get ~skip = let skip = __FILE__ :: skip in let stack = Printexc.get_callstack 16 in let len = Printexc.raw_backtrace_length stack in let rec loop pos = if pos = len then None else match Printexc.get_raw_backtrace_slot stack pos |> Printexc.convert_raw_backtrace_slot |> Printexc.Slot.location with | None -> None | Some loc -> if List.mem ~equal:String.equal skip loc.filename then loop (pos + 1) else Some loc in loop 0 ;; ppxlib-0.12.0/src/cinaps/000077500000000000000000000000001360512673700151465ustar00rootroot00000000000000ppxlib-0.12.0/src/cinaps/dune000066400000000000000000000000701360512673700160210ustar00rootroot00000000000000(library (name ppxlib_cinaps_helpers) (libraries re)) ppxlib-0.12.0/src/cinaps/ppxlib_cinaps_helpers.ml000066400000000000000000000011711360512673700220550ustar00rootroot00000000000000open Re let str_to_sig = let re = Str.regexp {|\(_?[sS]tructure\|impl\(ementation\)?\|str_\|_str\|\b\(st\|Str\)\b\)|} in let map s = match Str.matched_string s with | "st" -> "sg" | "Str" -> "Sig" | "structure" -> "signature" | "Structure" -> "Signature" | "_structure" -> "_signature" | "_Structure" -> "_Signature" | "str_" -> "sig_" | "_str" -> "_sig" | "implementation" -> "interface" | "impl" -> "intf" | _ -> assert false in fun s -> print_string (Str.global_substitute re map s) ppxlib-0.12.0/src/code_matcher.ml000066400000000000000000000120511360512673700166370ustar00rootroot00000000000000(*$ open Ppxlib_cinaps_helpers $*) open! Import module Format = Caml.Format module Filename = Caml.Filename (* TODO: make the "deriving." depend on the matching attribute name. *) let end_marker_sig = Attribute.Floating.declare "deriving.end" Signature_item Ast_pattern.(pstr nil) () let end_marker_str = Attribute.Floating.declare "deriving.end" Structure_item Ast_pattern.(pstr nil) () module type T1 = sig type 'a t end module Make(M : sig type t val get_loc : t -> Location.t val end_marker : (t, unit) Attribute.Floating.t module Transform(T : T1) : sig val apply : < structure_item : structure_item T.t ; signature_item : signature_item T.t ; .. > -> t T.t end val parse : Lexing.lexbuf -> t list val pp : Format.formatter -> t -> unit val to_sexp : t -> Sexp.t end) = struct let extract_prefix ~pos l = let rec loop acc = function | [] -> let loc = { Location. loc_start = pos; loc_end = pos; loc_ghost = false } in Location.raise_errorf ~loc "ppxlib: [@@@@@@%s] attribute missing" (Attribute.Floating.name M.end_marker) | x :: l -> match Attribute.Floating.convert [M.end_marker] x with | None -> loop (x :: acc) l | Some () -> (List.rev acc, (M.get_loc x).loc_start) | exception Failure _ -> loop (x :: acc) l in loop [] l let remove_loc = object inherit Ast_traverse.map method! location _ = Location.none method! location_stack _ = [] end module M_map = M.Transform(struct type 'a t = 'a -> 'a end) let remove_loc x = M_map.apply remove_loc x let rec last prev = function | [] -> prev | x :: l -> last x l let diff_asts ~generated ~round_trip = let with_temp_file f = Exn.protectx (Filename.temp_file "ppxlib" "") ~finally:Caml.Sys.remove ~f in with_temp_file (fun fn1 -> with_temp_file (fun fn2 -> with_temp_file (fun out -> let dump fn ast = Out_channel.with_file fn ~f:(fun oc -> let ppf = Format.formatter_of_out_channel oc in Sexp.pp_hum ppf (M.to_sexp ast); Format.pp_print_flush ppf ()) in dump fn1 generated; dump fn2 round_trip; let cmd = Printf.sprintf "patdiff -ascii -alt-old generated -alt-new 'generated->printed->parsed' \ %s %s &> %s" (Filename.quote fn1) (Filename.quote fn2) (Filename.quote out) in let ok = Caml.Sys.command cmd = 1 || ( let cmd = Printf.sprintf "diff --label generated --label 'generated->printed->parsed' \ %s %s &> %s" (Filename.quote fn1) (Filename.quote fn2) (Filename.quote out) in Caml.Sys.command cmd = 1 ) in if ok then In_channel.read_all out else ""))) let parse_string s = match M.parse (Lexing.from_string s) with | [x] -> x | _ -> assert false let rec match_loop ~end_pos ~mismatch_handler ~expected ~source = match expected, source with | [], [] -> () | [], x :: l -> let loc = { (M.get_loc x) with loc_end = (M.get_loc (last x l)).loc_end } in mismatch_handler loc [] | _, [] -> let loc = { Location. loc_ghost = false; loc_start = end_pos; loc_end = end_pos } in mismatch_handler loc expected | x :: expected, y :: source -> let loc = M.get_loc y in let x = remove_loc x in let y = remove_loc y in if Poly.(<>) x y then begin let round_trip = remove_loc (parse_string (Format.asprintf "%a@." M.pp x)) in if Poly.(<>) x round_trip then Location.raise_errorf ~loc "ppxlib: the corrected code doesn't round-trip.\n\ This is probably a bug in the OCaml printer:\n%s" (diff_asts ~generated:x ~round_trip); mismatch_handler loc [x]; end; match_loop ~end_pos ~mismatch_handler ~expected ~source let do_match ~pos ~expected ~mismatch_handler source = let source, end_pos = extract_prefix ~pos source in match_loop ~end_pos ~mismatch_handler ~expected ~source end (*$*) module Str = Make(struct type t = structure_item let get_loc x = x.pstr_loc let end_marker = end_marker_str module Transform(T : T1) = struct let apply o = o#structure_item end let parse = Parse.implementation let pp = Pprintast.structure_item let to_sexp = Ast_traverse.sexp_of#structure_item end) (*$ str_to_sig _last_text_block *) module Sig = Make(struct type t = signature_item let get_loc x = x.psig_loc let end_marker = end_marker_sig module Transform(T : T1) = struct let apply o = o#signature_item end let parse = Parse.interface let pp = Pprintast.signature_item let to_sexp = Ast_traverse.sexp_of#signature_item end) (*$*) let match_structure = Str.do_match let match_signature = Sig.do_match ppxlib-0.12.0/src/code_matcher.mli000066400000000000000000000012321360512673700170070ustar00rootroot00000000000000(** Match source code against generated code *) open! Import (** Checks that the given code starts with [expected] followed by [@@@deriving.end] or [@@@end]. Raises if there is no [@@@deriving.end]. If some items don't match, it calls [mismatch_handler] with the location of the source items and the expected code. *) val match_structure : pos:Lexing.position -> expected:structure -> mismatch_handler:(Location.t -> structure -> unit) -> structure -> unit (** Same for signatures *) val match_signature : pos:Lexing.position -> expected:signature -> mismatch_handler:(Location.t -> signature -> unit) -> signature -> unit ppxlib-0.12.0/src/code_path.ml000066400000000000000000000026231360512673700161540ustar00rootroot00000000000000open! Import type t = { file_path : string ; main_module_name : string ; submodule_path : string loc list ; value : string loc option ; in_expr : bool } let top_level ~file_path = let main_module_name = file_path |> Caml.Filename.basename |> Caml.Filename.remove_extension |> String.capitalize in {file_path; main_module_name; submodule_path = []; value = None; in_expr = false} let file_path t = t.file_path let main_module_name t = t.main_module_name let submodule_path t = List.rev_map ~f:(fun located -> located.txt) t.submodule_path let value t = Option.map ~f:(fun located -> located.txt) t.value let fully_qualified_path t = let value = value t in let submodule_path = List.rev_map ~f:(fun located -> Some located.txt) t.submodule_path in let names = (Some t.main_module_name)::submodule_path @ [value] in String.concat ~sep:"." @@ List.filter_opt names let enter_expr t = {t with in_expr = true} let enter_module ~loc module_name t = if t.in_expr then t else {t with submodule_path = {txt = module_name; loc} :: t.submodule_path} let enter_value ~loc value_name t = if t.in_expr then t else {t with value = Some {txt = value_name; loc}} let to_string_path t = String.concat ~sep:"." (t.file_path :: (submodule_path t)) let with_string_path f ~loc ~path = f ~loc ~path:(to_string_path path) ;; let module M = struct let a = "lol" end in M.a ppxlib-0.12.0/src/code_path.mli000066400000000000000000000036721360512673700163320ustar00rootroot00000000000000open !Import (** Type for path to AST nodes *) type t (** Return the path to the .ml or .mli file for this code path. *) val file_path : t -> string (** Return the module name corresponding to the file to which this code path leads to. *) val main_module_name : t -> string (** Return the path within the main module this code path represents as a list of module names. *) val submodule_path : t -> string list (** Return the name of the value to which this code path leads or [None] if it leads to the toplevel of a module or submodule. *) val value : t -> string option (** Return the fully qualified path to the module or value this code path leads to, eg ["Some_main_module.Some_submodule.some_value"]. Note that the fully qualified path doesn't descend into expressions which means it will always stop at the first value description or value binding. *) val fully_qualified_path : t -> string (** Return the string version of this code path as built by [Ast_traverse.map_with_path]. Used for compatibility with path from version 0.5.0 and lower. *) val to_string_path : t -> string (**/**) (** Undocumented section *) (** [top_level ~file_path] returns the code path for any toplevel item in the file at [file_path]. *) val top_level : file_path: string -> t (** Return a new code path that now descends into an expression. This is used to delimit the "toplevel" path. It's required because of first class modules and toplevel expressions [Pstr_eval ...]. *) val enter_expr : t -> t (** Return a new code path updated with the given module name and location. *) val enter_module : loc:Location.t -> string -> t -> t (** Return a new code path updated with the given variable name and location. *) val enter_value : loc:Location.t -> string -> t -> t (** Wrap a [fun ~loc ~path] expecting a string path into one expecting a [t]. *) val with_string_path : (loc:Location.t -> path:string -> 'a) -> (loc:Location.t -> path:t -> 'a) ppxlib-0.12.0/src/common.ml000066400000000000000000000151031360512673700155130ustar00rootroot00000000000000open! Import open Ast_builder.Default module Buffer = Caml.Buffer module Format = Caml.Format let lident x = Longident.Lident x let core_type_of_type_declaration td = let loc = td.ptype_name.loc in ptyp_constr ~loc (Located.map lident td.ptype_name) (List.map td.ptype_params ~f:fst) ;; let gen_symbol = let cnt = ref 0 in fun ?(prefix = "_x") () -> cnt := !cnt + 1; Printf.sprintf "%s__%03i_" prefix !cnt ;; let name_type_params_in_td (td : type_declaration) : type_declaration = let name_param (tp, variance) = let ptyp_desc = match tp.ptyp_desc with | Ptyp_any -> Ptyp_var ("v" ^ gen_symbol ()) | Ptyp_var _ as v -> v | _ -> Location.raise_errorf ~loc:tp.ptyp_loc "not a type parameter" in ({ tp with ptyp_desc }, variance) in { td with ptype_params = List.map td.ptype_params ~f:name_param } ;; let combinator_type_of_type_declaration td ~f = let td = name_type_params_in_td td in let result_type = f ~loc:td.ptype_name.loc (core_type_of_type_declaration td) in List.fold_right td.ptype_params ~init:result_type ~f:(fun (tp, _variance) acc -> let loc = tp.ptyp_loc in ptyp_arrow ~loc Nolabel (f ~loc tp) acc) ;; let string_of_core_type ct = let buf = Buffer.create 128 in let ppf = Format.formatter_of_buffer buf in Pprintast.core_type ppf ct; Format.pp_print_flush ppf (); Buffer.contents buf ;; let get_type_param_name (ty, _) = let loc = ty.ptyp_loc in match ty.ptyp_desc with | Ptyp_var name -> Located.mk ~loc name | _ -> Location.raise_errorf ~loc "not a type parameter" exception Type_is_recursive class type_is_recursive rec_flag tds = object(self) inherit Ast_traverse.iter as super val type_names : string list = List.map tds ~f:(fun td -> td.ptype_name.txt) method return_true () = Exn.raise_without_backtrace Type_is_recursive method! core_type ctype = match ctype.ptyp_desc with | Ptyp_arrow _ -> () | Ptyp_constr ({ txt = Longident.Lident id; _ }, _) when List.mem ~equal:String.equal type_names id -> self#return_true () | _ -> super#core_type ctype method! constructor_declaration cd = (* Don't recurse through cd.pcd_res *) match cd.pcd_args with | Pcstr_tuple args -> List.iter args ~f:self#core_type | Pcstr_record fields -> List.iter fields ~f:self#label_declaration method go () = match rec_flag with | Nonrecursive -> Nonrecursive | Recursive -> match List.iter tds ~f:self#type_declaration with | exception Type_is_recursive -> Recursive | () -> Nonrecursive end let really_recursive rec_flag tds = (new type_is_recursive rec_flag tds)#go () let rec last x l = match l with | [] -> x | x :: l -> last x l ;; let loc_of_name_and_payload name payload = match payload with | PStr [] -> name.loc | PStr (x :: l) -> { x.pstr_loc with loc_end = (last x l).pstr_loc.loc_end } | PSig [] -> name.loc | PSig (x :: l) -> { x.psig_loc with loc_end = (last x l).psig_loc.loc_end } | PTyp t -> t.ptyp_loc | PPat (x, None) -> x.ppat_loc | PPat (x, Some e) -> { x.ppat_loc with loc_end = e.pexp_loc.loc_end } ;; let loc_of_payload { attr_name; attr_payload; attr_loc = _; } = loc_of_name_and_payload attr_name attr_payload let loc_of_attribute { attr_name; attr_payload; attr_loc = _; } = (* TODO: fix this in the compiler, and move the logic to omp when converting from older asts. *) (* "ocaml.doc" attributes are generated with [Location.none], which is not helpful for error messages. *) if Poly.(=) attr_name.loc Location.none then loc_of_name_and_payload attr_name attr_payload else { attr_name.loc with loc_end = (loc_of_name_and_payload attr_name attr_payload).loc_end } ;; let loc_of_extension (name, payload) = if Poly.(=) name.loc Location.none then loc_of_name_and_payload name payload else { name.loc with loc_end = (loc_of_name_and_payload name payload).loc_end } ;; let curry_applications expr = let open Ast_builder_generated.M in match expr.pexp_desc with | Pexp_apply (f,orig_forward_args) -> let loc = expr.pexp_loc in let rec loop = function | [] -> f | last_arg::rev_front_args -> pexp_apply ~loc (loop rev_front_args) [last_arg] in loop (List.rev orig_forward_args) | _ -> expr ;; let rec assert_no_attributes = function | [] -> () | { attr_name = name; attr_loc = _; attr_payload = _; } :: rest when Name.ignore_checks name.Location.txt -> assert_no_attributes rest | attr :: _ -> let loc = loc_of_attribute attr in Location.raise_errorf ~loc "Attributes not allowed here" let assert_no_attributes_in = object inherit Ast_traverse.iter method! attribute a = assert_no_attributes [a] end let attribute_of_warning loc s = { attr_name = { loc; txt = "ocaml.ppwarning" }; attr_payload = PStr ([pstr_eval ~loc (estring ~loc s) []]); attr_loc = loc; } let is_polymorphic_variant = let rec check = function | { ptyp_desc = Ptyp_variant _; _ } -> `Definitely | { ptyp_desc = Ptyp_alias (typ,_); _ } -> check typ | { ptyp_desc = Ptyp_constr _; _ } -> `Maybe | _ -> `Surely_not (* Type vars go here even though they could be polymorphic variants, however we don't handle it if they get substituted by a polymorphic variant that is then included. *) in fun td ~sig_ -> match td.ptype_kind with | Ptype_variant _ | Ptype_record _ | Ptype_open -> `Surely_not | Ptype_abstract -> match td.ptype_manifest with | None -> if sig_ then `Maybe else `Surely_not | Some typ -> check typ let mk_named_sig ~loc ~sg_name ~handle_polymorphic_variant = function | [ td ] when String.equal td.ptype_name.txt "t" && List.is_empty td.ptype_cstrs -> if not handle_polymorphic_variant && Poly.(=) (is_polymorphic_variant td ~sig_:true) `Definitely then None else let arity = List.length td.ptype_params in if arity >= 4 then None else let mty = if arity = 0 then sg_name else Printf.sprintf "%s%d" sg_name arity in let td = name_type_params_in_td td in let for_subst = Ast_helper.Type.mk ~loc td.ptype_name ~params:td.ptype_params ~manifest:( ptyp_constr ~loc (Located.map_lident td.ptype_name) (List.map ~f:fst td.ptype_params) ) in Some ( include_infos ~loc (pmty_with ~loc (pmty_ident ~loc (Located.lident mty ~loc)) [Pwith_typesubst (Located.lident ~loc "t", for_subst)]) ) | _ -> None ppxlib-0.12.0/src/common.mli000066400000000000000000000051521360512673700156670ustar00rootroot00000000000000open! Import val lident : string -> Longident.t val core_type_of_type_declaration : type_declaration -> core_type val name_type_params_in_td : type_declaration -> type_declaration val combinator_type_of_type_declaration : type_declaration -> f:(loc:Location.t -> core_type -> core_type) -> core_type val gen_symbol : ?prefix : string -> unit -> string (** [gen_symbol ?prefix ()] generates a fresh variable name with [prefix]. @param prefix default = "_x" *) val string_of_core_type : core_type -> string val assert_no_attributes : attributes -> unit val assert_no_attributes_in : Ast_traverse.iter val get_type_param_name : (core_type * variance) -> string Loc.t (** [get_tparam_id tp] @return the string identifier associated with [tp] if it is a type parameter. *) (** [(new type_is_recursive rec_flag tds)#go ()] returns whether [rec_flag, tds] is really a recursive type. We disregard recursive occurrences appearing in arrow types. You can override the search for certain type expressions by inheriting from this class. *) class type_is_recursive : rec_flag -> type_declaration list -> object inherit Ast_traverse.iter val type_names : string list method return_true : unit -> unit method go : unit -> rec_flag end (** [really_recursive rec_flag tds = (new type_is_recursive rec_flag tds)#go ()] *) val really_recursive : rec_flag -> type_declaration list -> rec_flag val loc_of_payload : attribute -> Location.t val loc_of_attribute : attribute -> Location.t val loc_of_extension : extension -> Location.t (** convert multi-arg function applications into a cascade of 1-arg applications *) val curry_applications : expression -> expression (** Encode a warning message into an 'ocaml.ppwarning' attribute which can be inserted in a generated Parsetree. The compiler will be responsible for reporting the warning. *) val attribute_of_warning : Location.t -> string -> attribute val is_polymorphic_variant : type_declaration -> sig_:bool -> [> `Definitely | `Maybe | `Surely_not ] (** [mk_named_sig ~loc ~sg_name:"Foo" ~handle_polymorphic_variant tds] will generate {[ include Foo (* or Foo1, Foo2, Foo3 *) with type (* ('a, 'b, 'c) *) t := (* ('a, 'b, 'c) *) t ]} when: - there is only one type declaration - the type is named t - there are less than 4 type parameters - there are no constraints on the type parameters It will take care of giving fresh names to unnamed type parameters. *) val mk_named_sig : loc:Location.t -> sg_name:string -> handle_polymorphic_variant:bool -> type_declaration list -> include_description option ppxlib-0.12.0/src/context_free.ml000066400000000000000000000644341360512673700167230ustar00rootroot00000000000000(*$ open Ppxlib_cinaps_helpers $*) open! Import open Common module E = Extension module EC = Extension.Context module A = Attribute module AC = Attribute.Context module Rule = struct module Attr_group_inline = struct type ('a, 'b, 'c) unpacked = { attribute : ('b, 'c) Attribute.t ; expect : bool ; expand : (ctxt:Expansion_context.Deriver.t -> Asttypes.rec_flag -> 'b list -> 'c option list -> 'a list) } type ('a, 'b) t = T : ('a, 'b, _) unpacked -> ('a, 'b) t let attr_name (T t) = Attribute.name t.attribute let split_normal_and_expect l = List.partition_tf l ~f:(fun (T t) -> not t.expect) end module Attr_inline = struct type ('a, 'b, 'c) unpacked = { attribute : ('b, 'c) Attribute.t ; expect : bool ; expand : (ctxt:Expansion_context.Deriver.t -> 'b -> 'c -> 'a list) } type ('a, 'b) t = T : ('a, 'b, _) unpacked -> ('a, 'b) t let attr_name (T t) = Attribute.name t.attribute let split_normal_and_expect l = List.partition_tf l ~f:(fun (T t) -> not t.expect) end module Special_function = struct type t = { name : string ; ident : Longident.t ; expand : Parsetree.expression -> Parsetree.expression option } end module Constant_kind = struct type t = Float | Integer end module Constant = struct type t = { suffix : char ; kind : Constant_kind.t ; expand : Location.t -> string -> Parsetree.expression } end module Field = struct type 'a t = | Extension : Extension.t t | Special_function : Special_function.t t | Constant : Constant.t t | Attr_str_type_decl : (structure_item, type_declaration) Attr_group_inline.t t | Attr_sig_type_decl : (signature_item, type_declaration) Attr_group_inline.t t | Attr_str_module_type_decl : (structure_item, module_type_declaration) Attr_inline.t t | Attr_sig_module_type_decl : (signature_item, module_type_declaration) Attr_inline.t t | Attr_str_type_ext : (structure_item, type_extension) Attr_inline.t t | Attr_sig_type_ext : (signature_item, type_extension) Attr_inline.t t | Attr_str_exception : (structure_item, type_exception) Attr_inline.t t | Attr_sig_exception : (signature_item, type_exception) Attr_inline.t t type (_, _) equality = Eq : ('a, 'a) equality | Ne : (_, _) equality let eq : type a b. a t -> b t -> (a, b) equality = fun a b -> match a, b with | Extension , Extension -> Eq | Special_function , Special_function -> Eq | Constant , Constant -> Eq | Attr_str_type_decl , Attr_str_type_decl -> Eq | Attr_sig_type_decl , Attr_sig_type_decl -> Eq | Attr_str_type_ext , Attr_str_type_ext -> Eq | Attr_sig_type_ext , Attr_sig_type_ext -> Eq | Attr_str_exception , Attr_str_exception -> Eq | Attr_sig_exception , Attr_sig_exception -> Eq | Attr_str_module_type_decl, Attr_str_module_type_decl -> Eq | Attr_sig_module_type_decl, Attr_sig_module_type_decl -> Eq | _ -> Ne end type t = T : 'a Field.t * 'a -> t type ('a, 'b, 'c) attr_group_inline = ('b, 'c) Attribute.t -> (ctxt:Expansion_context.Deriver.t -> Asttypes.rec_flag -> 'b list -> 'c option list -> 'a list) -> t type ('a, 'b, 'c) attr_inline = ('b, 'c) Attribute.t -> (ctxt:Expansion_context.Deriver.t -> 'b -> 'c -> 'a list) -> t let rec filter : type a. a Field.t -> t list -> a list = fun field l -> match l with | [] -> [] | (T (field', x)) :: l -> match Field.eq field field' with | Field.Eq -> x :: filter field l | Field.Ne -> filter field l ;; let extension ext = T (Extension, ext) let special_function id f = T (Special_function, { name = id ; ident = Longident.parse id ; expand = f }) ;; let constant kind suffix expand = T (Constant, { suffix; kind; expand }) ;; let attr_str_type_decl attribute expand = T (Attr_str_type_decl, T { attribute; expand; expect = false }) ;; let attr_sig_type_decl attribute expand = T (Attr_sig_type_decl, T { attribute; expand; expect = false }) ;; let attr_str_module_type_decl attribute expand = T (Attr_str_module_type_decl, T { attribute; expand; expect = false }) ;; let attr_sig_module_type_decl attribute expand = T (Attr_sig_module_type_decl, T { attribute; expand; expect = false }) ;; let attr_str_type_ext attribute expand = T (Attr_str_type_ext, T { attribute; expand; expect = false }) ;; let attr_sig_type_ext attribute expand = T (Attr_sig_type_ext, T { attribute; expand; expect = false }) ;; let attr_str_exception attribute expand = T (Attr_str_exception, T { attribute; expand; expect = false }) ;; let attr_sig_exception attribute expand = T (Attr_sig_exception, T { attribute; expand; expect = false }) ;; let attr_str_type_decl_expect attribute expand = T (Attr_str_type_decl, T { attribute; expand; expect = true }) ;; let attr_sig_type_decl_expect attribute expand = T (Attr_sig_type_decl, T { attribute; expand; expect = true }) ;; let attr_str_module_type_decl_expect attribute expand = T (Attr_str_module_type_decl, T { attribute; expand; expect = true }) ;; let attr_sig_module_type_decl_expect attribute expand = T (Attr_sig_module_type_decl, T { attribute; expand; expect = true }) ;; let attr_str_type_ext_expect attribute expand = T (Attr_str_type_ext, T { attribute; expand; expect = true }) ;; let attr_sig_type_ext_expect attribute expand = T (Attr_sig_type_ext, T { attribute; expand; expect = true }) ;; let attr_str_exception_expect attribute expand = T (Attr_str_exception, T { attribute; expand; expect = true }) ;; let attr_sig_exception_expect attribute expand = T (Attr_sig_exception, T { attribute; expand; expect = true }) ;; end module Generated_code_hook = struct type 'a single_or_many = | Single of 'a | Many of 'a list type t = { f : 'a. 'a Extension.Context.t -> Location.t -> 'a single_or_many -> unit } let nop = { f = (fun _ _ _ -> ()) } let replace t context loc x = t.f context loc x let insert_after t context (loc : Location.t) x = match x with | Many [] -> () | _ -> t.f context { loc with loc_start = loc.loc_end } x end let rec map_node_rec context ts super_call loc base_ctxt x = let ctxt = Expansion_context.Extension.make ~extension_point_loc:loc ~base:base_ctxt () in match EC.get_extension context x with | None -> super_call base_ctxt x | Some (ext, attrs) -> match E.For_context.convert ts ~ctxt ext with | None -> super_call base_ctxt x | Some x -> map_node_rec context ts super_call loc base_ctxt (EC.merge_attributes context x attrs) ;; let map_node context ts super_call loc base_ctxt x ~hook = let ctxt = Expansion_context.Extension.make ~extension_point_loc:loc ~base:base_ctxt () in match EC.get_extension context x with | None -> super_call base_ctxt x | Some (ext, attrs) -> match E.For_context.convert ts ~ctxt ext with | None -> super_call base_ctxt x | Some x -> let generated_code = map_node_rec context ts super_call loc base_ctxt (EC.merge_attributes context x attrs) in Generated_code_hook.replace hook context loc (Single generated_code); generated_code ;; let rec map_nodes context ts super_call get_loc base_ctxt l ~hook ~in_generated_code = match l with | [] -> [] | x :: l -> match EC.get_extension context x with | None -> (* These two lets force the evaluation order, so that errors are reported in the same order as they appear in the source file. *) let x = super_call base_ctxt x in let l = map_nodes context ts super_call get_loc base_ctxt l ~hook ~in_generated_code in x :: l | Some (ext, attrs) -> let extension_point_loc = get_loc x in let ctxt = Expansion_context.Extension.make ~extension_point_loc ~base:base_ctxt () in match E.For_context.convert_inline ts ~ctxt ext with | None -> let x = super_call base_ctxt x in let l = map_nodes context ts super_call get_loc base_ctxt l ~hook ~in_generated_code in x :: l | Some x -> assert_no_attributes attrs; let generated_code = map_nodes context ts super_call get_loc base_ctxt x ~hook ~in_generated_code:true in if not in_generated_code then Generated_code_hook.replace hook context extension_point_loc (Many generated_code); generated_code @ map_nodes context ts super_call get_loc base_ctxt l ~hook ~in_generated_code let map_nodes = map_nodes ~in_generated_code:false let table_of_special_functions special_functions = match List.map special_functions ~f:(fun { Rule.Special_function.ident; expand; _ } -> (ident, expand)) (* We expect the lookup to fail most of the time, by making the table big (and sparse), we make it more likely to fail quickly *) |> Hashtbl.Poly.of_alist ~size:(max 1024 (List.length special_functions * 2)) with | `Ok table -> table | `Duplicate_key ident -> Printf.ksprintf invalid_arg "Context_free.V1.map_top_down: \ %s present twice in list of special functions" (List.find_map_exn special_functions ~f:(fun r -> if Poly.equal r.ident ident then Some r.name else None)) ;; let rec get_group attr l = match l with | [] -> None | x :: l -> match Attribute.get attr x, get_group attr l with | None , None -> None | None , Some vals -> Some (None :: vals) | Some value , None -> Some (Some value :: List.map l ~f:(fun _ -> None)) | Some value , Some vals -> Some (Some value :: vals) ;; (* Same as [List.rev] then [List.concat] but expecting the input to be of length <= 2 *) let rev_concat = function | [] -> [] | [x] -> x | [x; y] -> y @ x | l -> List.concat (List.rev l) ;; let sort_attr_group_inline l = List.sort l ~compare:(fun a b -> String.compare (Rule.Attr_group_inline.attr_name a) (Rule.Attr_group_inline.attr_name b)) let sort_attr_inline l = List.sort l ~compare:(fun a b -> String.compare (Rule.Attr_inline.attr_name a) (Rule.Attr_inline.attr_name b)) (* Returns the code generated by attribute handlers. We don't remove these attributes, as another pass might interpret them later. For instance both ppx_deriving and ppxlib_deriving interprets [@@deriving] attributes. This complexity is horrible, but in practice we don't care as [attrs] is always a list of one element; it only has [@@deriving]. *) let handle_attr_group_inline attrs rf items ~loc ~base_ctxt = List.fold_left attrs ~init:[] ~f:(fun acc (Rule.Attr_group_inline.T group) -> match get_group group.attribute items with | None -> acc | Some values -> let ctxt = Expansion_context.Deriver.make ~derived_item_loc:loc ~inline:group.expect ~base:base_ctxt () in let expect_items = group.expand ~ctxt rf items values in expect_items :: acc) let handle_attr_inline attrs item ~loc ~base_ctxt = List.fold_left attrs ~init:[] ~f:(fun acc (Rule.Attr_inline.T a) -> match Attribute.get a.attribute item with | None -> acc | Some value -> let ctxt = Expansion_context.Deriver.make ~derived_item_loc:loc ~inline:a.expect ~base:base_ctxt () in let expect_items = a.expand ~ctxt item value in expect_items :: acc) module Expect_mismatch_handler = struct type t = { f : 'a. 'a Attribute.Floating.Context.t -> Location.t -> 'a list -> unit } let nop = { f = fun _ _ _ -> () } end class map_top_down ?(expect_mismatch_handler=Expect_mismatch_handler.nop) ?(generated_code_hook=Generated_code_hook.nop) rules = let hook = generated_code_hook in let special_functions = Rule.filter Special_function rules |> table_of_special_functions in let constants = Rule.filter Constant rules |> List.map ~f:(fun (c:Rule.Constant.t) -> ((c.suffix,c.kind),c.expand)) |> Hashtbl.Poly.of_alist_exn in let extensions = Rule.filter Extension rules in let class_expr = E.filter_by_context EC.class_expr extensions and class_field = E.filter_by_context EC.class_field extensions and class_type = E.filter_by_context EC.class_type extensions and class_type_field = E.filter_by_context EC.class_type_field extensions and core_type = E.filter_by_context EC.core_type extensions and expression = E.filter_by_context EC.expression extensions and module_expr = E.filter_by_context EC.module_expr extensions and module_type = E.filter_by_context EC.module_type extensions and pattern = E.filter_by_context EC.pattern extensions and signature_item = E.filter_by_context EC.signature_item extensions and structure_item = E.filter_by_context EC.structure_item extensions in let attr_str_type_decls, attr_str_type_decls_expect = Rule.filter Attr_str_type_decl rules |> sort_attr_group_inline |> Rule.Attr_group_inline.split_normal_and_expect in let attr_sig_type_decls, attr_sig_type_decls_expect = Rule.filter Attr_sig_type_decl rules |> sort_attr_group_inline |> Rule.Attr_group_inline.split_normal_and_expect in let attr_str_module_type_decls, attr_str_module_type_decls_expect = Rule.filter Attr_str_module_type_decl rules |> sort_attr_inline |> Rule.Attr_inline.split_normal_and_expect in let attr_sig_module_type_decls, attr_sig_module_type_decls_expect = Rule.filter Attr_sig_module_type_decl rules |> sort_attr_inline |> Rule.Attr_inline.split_normal_and_expect in let attr_str_type_exts, attr_str_type_exts_expect = Rule.filter Attr_str_type_ext rules |> sort_attr_inline |> Rule.Attr_inline.split_normal_and_expect in let attr_sig_type_exts, attr_sig_type_exts_expect = Rule.filter Attr_sig_type_ext rules |> sort_attr_inline |> Rule.Attr_inline.split_normal_and_expect in let attr_str_exceptions, attr_str_exceptions_expect = Rule.filter Attr_str_exception rules |> sort_attr_inline |> Rule.Attr_inline.split_normal_and_expect in let attr_sig_exceptions, attr_sig_exceptions_expect = Rule.filter Attr_sig_exception rules |> sort_attr_inline |> Rule.Attr_inline.split_normal_and_expect in let map_node = map_node ~hook in let map_nodes = map_nodes ~hook in object(self) inherit Ast_traverse.map_with_expansion_context as super (* No point recursing into every location *) method! location _ x = x method! core_type base_ctxt x = map_node EC.core_type core_type super#core_type x.ptyp_loc base_ctxt x method! pattern base_ctxt x = map_node EC.pattern pattern super#pattern x.ppat_loc base_ctxt x method! expression base_ctxt e = let e = match e.pexp_desc with | Pexp_extension _ -> map_node EC.expression expression (fun _ e -> e) e.pexp_loc base_ctxt e | _ -> e in let expand_constant kind char text = match Hashtbl.find constants (char,kind) with | None -> super#expression base_ctxt e | Some expand -> self#expression base_ctxt (expand e.pexp_loc text) in match e.pexp_desc with | Pexp_apply ({ pexp_desc = Pexp_ident id; _ } as func, args) -> begin match Hashtbl.find special_functions id.txt with | None -> self#pexp_apply_without_traversing_function base_ctxt e func args | Some pattern -> match pattern e with | None -> self#pexp_apply_without_traversing_function base_ctxt e func args | Some e -> self#expression base_ctxt e end | Pexp_ident id -> begin match Hashtbl.find special_functions id.txt with | None -> super#expression base_ctxt e | Some pattern -> match pattern e with | None -> super#expression base_ctxt e | Some e -> self#expression base_ctxt e end | Pexp_constant (Pconst_integer (s, Some c)) -> expand_constant Integer c s | Pexp_constant (Pconst_float (s, Some c)) -> expand_constant Float c s | _ -> super#expression base_ctxt e (* Pre-conditions: - e.pexp_desc = Pexp_apply(func, args) - func.pexp_desc = Pexp_ident _ *) method private pexp_apply_without_traversing_function base_ctxt e func args = let { pexp_desc = _; pexp_loc; pexp_attributes; pexp_loc_stack; } = e in let func = let { pexp_desc; pexp_loc; pexp_attributes; pexp_loc_stack } = func in let pexp_attributes = self#attributes base_ctxt pexp_attributes in { pexp_desc ; pexp_loc (* location doesn't need to be traversed *) ; pexp_attributes ; pexp_loc_stack } in let args = List.map args ~f:(fun (lab, exp) -> (lab, self#expression base_ctxt exp)) in let pexp_attributes = self#attributes base_ctxt pexp_attributes in { pexp_loc ; pexp_attributes ; pexp_desc = Pexp_apply (func, args) ; pexp_loc_stack } method! class_type base_ctxt x = map_node EC.class_type class_type super#class_type x.pcty_loc base_ctxt x method! class_type_field base_ctxt x = map_node EC.class_type_field class_type_field super#class_type_field x.pctf_loc base_ctxt x method! class_expr base_ctxt x = map_node EC.class_expr class_expr super#class_expr x.pcl_loc base_ctxt x method! class_field base_ctxt x = map_node EC.class_field class_field super#class_field x.pcf_loc base_ctxt x method! module_type base_ctxt x = map_node EC.module_type module_type super#module_type x.pmty_loc base_ctxt x method! module_expr base_ctxt x = map_node EC.module_expr module_expr super#module_expr x.pmod_loc base_ctxt x method! structure_item base_ctxt x = map_node EC.structure_item structure_item super#structure_item x.pstr_loc base_ctxt x method! signature_item base_ctxt x = map_node EC.signature_item signature_item super#signature_item x.psig_loc base_ctxt x method! class_structure base_ctxt { pcstr_self; pcstr_fields } = let pcstr_self = self#pattern base_ctxt pcstr_self in let pcstr_fields = map_nodes EC.class_field class_field super#class_field (fun x -> x.pcf_loc) base_ctxt pcstr_fields in { pcstr_self; pcstr_fields } method! class_signature base_ctxt { pcsig_self; pcsig_fields } = let pcsig_self = self#core_type base_ctxt pcsig_self in let pcsig_fields = map_nodes EC.class_type_field class_type_field super#class_type_field (fun x -> x.pctf_loc) base_ctxt pcsig_fields in { pcsig_self; pcsig_fields } (* TODO: try to factorize #structure and #signature without meta-programming *) (*$*) method! structure base_ctxt st = let rec with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code = let item = super#structure_item base_ctxt item in let extra_items = loop (rev_concat extra_items) ~in_generated_code:true in if not in_generated_code then Generated_code_hook.insert_after hook Structure_item item.pstr_loc (Many extra_items); let original_rest = rest in let rest = loop rest ~in_generated_code in (match expect_items with | [] -> () | _ -> let expected = rev_concat expect_items in let pos = item.pstr_loc.loc_end in Code_matcher.match_structure original_rest ~pos ~expected ~mismatch_handler:(fun loc repl -> expect_mismatch_handler.f Structure_item loc repl)); item :: (extra_items @ rest) and loop st ~in_generated_code = match st with | [] -> [] | item :: rest -> let loc = item.pstr_loc in match item.pstr_desc with | Pstr_extension (ext, attrs) -> begin let extension_point_loc = item.pstr_loc in let ctxt = Expansion_context.Extension.make ~extension_point_loc ~base:base_ctxt () in match E.For_context.convert_inline structure_item ~ctxt ext with | None -> let item = super#structure_item base_ctxt item in let rest = self#structure base_ctxt rest in item :: rest | Some items -> assert_no_attributes attrs; let items = loop items ~in_generated_code:true in if not in_generated_code then Generated_code_hook.replace hook Structure_item item.pstr_loc (Many items); items @ loop rest ~in_generated_code end | Pstr_type(rf, tds) -> let extra_items = handle_attr_group_inline attr_str_type_decls rf tds ~loc ~base_ctxt in let expect_items = handle_attr_group_inline attr_str_type_decls_expect rf tds ~loc ~base_ctxt in with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code | Pstr_modtype mtd -> let extra_items = handle_attr_inline attr_str_module_type_decls mtd ~loc ~base_ctxt in let expect_items = handle_attr_inline attr_str_module_type_decls_expect mtd ~loc ~base_ctxt in with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code | Pstr_typext te -> let extra_items = handle_attr_inline attr_str_type_exts te ~loc ~base_ctxt in let expect_items = handle_attr_inline attr_str_type_exts_expect te ~loc ~base_ctxt in with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code | Pstr_exception ec -> let extra_items = handle_attr_inline attr_str_exceptions ec ~loc ~base_ctxt in let expect_items = handle_attr_inline attr_str_exceptions_expect ec ~loc ~base_ctxt in with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code | _ -> let item = self#structure_item base_ctxt item in let rest = self#structure base_ctxt rest in item :: rest in loop st ~in_generated_code:false (*$ str_to_sig _last_text_block *) method! signature base_ctxt sg = let rec with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code = let item = super#signature_item base_ctxt item in let extra_items = loop (rev_concat extra_items) ~in_generated_code:true in if not in_generated_code then Generated_code_hook.insert_after hook Signature_item item.psig_loc (Many extra_items); let original_rest = rest in let rest = loop rest ~in_generated_code in (match expect_items with | [] -> () | _ -> let expected = rev_concat expect_items in let pos = item.psig_loc.loc_end in Code_matcher.match_signature original_rest ~pos ~expected ~mismatch_handler:(fun loc repl -> expect_mismatch_handler.f Signature_item loc repl)); item :: (extra_items @ rest) and loop sg ~in_generated_code = match sg with | [] -> [] | item :: rest -> let loc = item.psig_loc in match item.psig_desc with | Psig_extension (ext, attrs) -> begin let extension_point_loc = item.psig_loc in let ctxt = Expansion_context.Extension.make ~extension_point_loc ~base:base_ctxt () in match E.For_context.convert_inline signature_item ~ctxt ext with | None -> let item = super#signature_item base_ctxt item in let rest = self#signature base_ctxt rest in item :: rest | Some items -> assert_no_attributes attrs; let items = loop items ~in_generated_code:true in if not in_generated_code then Generated_code_hook.replace hook Signature_item item.psig_loc (Many items); items @ loop rest ~in_generated_code end | Psig_type(rf, tds) -> let extra_items = handle_attr_group_inline attr_sig_type_decls rf tds ~loc ~base_ctxt in let expect_items = handle_attr_group_inline attr_sig_type_decls_expect rf tds ~loc ~base_ctxt in with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code | Psig_modtype mtd -> let extra_items = handle_attr_inline attr_sig_module_type_decls mtd ~loc ~base_ctxt in let expect_items = handle_attr_inline attr_sig_module_type_decls_expect mtd ~loc ~base_ctxt in with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code | Psig_typext te -> let extra_items = handle_attr_inline attr_sig_type_exts te ~loc ~base_ctxt in let expect_items = handle_attr_inline attr_sig_type_exts_expect te ~loc ~base_ctxt in with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code | Psig_exception ec -> let extra_items = handle_attr_inline attr_sig_exceptions ec ~loc ~base_ctxt in let expect_items = handle_attr_inline attr_sig_exceptions_expect ec ~loc ~base_ctxt in with_extra_items item ~extra_items ~expect_items ~rest ~in_generated_code | _ -> let item = self#signature_item base_ctxt item in let rest = self#signature base_ctxt rest in item :: rest in loop sg ~in_generated_code:false (*$*) end ppxlib-0.12.0/src/context_free.mli000066400000000000000000000124251360512673700170650ustar00rootroot00000000000000(** Context free rewriting *) open! Import (** Local rewriting rules. This module lets you define local rewriting rules, such as extension point expanders. It is not completely generic and you cannot define any kind of rewriting, it currently focuses on what is commonly used. New scheme can be added on demand. We have some ideas to make this fully generic, but this hasn't been a priority so far. *) module Rule : sig type t (** Rewrite an extension point *) val extension : Extension.t -> t (** [special_function id expand] is a rule to rewrite a function call at parsing time. [id] is the identifier to match on and [expand] is used to expand the full function application (it gets the Pexp_apply node). If the function is found in the tree without being applied, [expand] gets only the identifier (Pexp_ident node) so you should handle both cases. If [id] is an operator identifier and contains dots, it should be parenthesized (e.g. ["(+.+)"]). [expand] must decide whether the expression it receive can be rewritten or not. Especially ppxlib makes the assumption that [expand] is idempotent. It will loop if it is not. *) val special_function : string -> (expression -> expression option) -> t (** Used for the [constant] function. *) module Constant_kind : sig type t = Float | Integer end (** [constant kind suffix expander] Registers an extension for transforming constants literals, based on the suffix character. *) val constant : Constant_kind.t -> char -> (Location.t -> string -> Parsetree.expression) -> t (** The rest of this API is for rewriting rules that apply when a certain attribute is present. The API is not complete and is currently only enough to implement deriving. *) (** Match the attribute on a group of items, such as a group of recursive type definitions (Pstr_type, Psig_type). The expander will be triggered if any of the item has the attribute. The expander is called as follow: [expand ~loc ~path rec_flag items values] where [values] is the list of values associated to the attribute for each item in [items]. [expand] must return a list of element to add after the group. For instance a list of structure item to add after a group of type definitions. *) type ('a, 'b, 'c) attr_group_inline = ('b, 'c) Attribute.t -> (ctxt:Expansion_context.Deriver.t -> Asttypes.rec_flag -> 'b list -> 'c option list -> 'a list) -> t val attr_str_type_decl : (structure_item, type_declaration, _) attr_group_inline val attr_sig_type_decl : (signature_item, type_declaration, _) attr_group_inline (** The _expect variants are for producing code that is compared to what the user wrote in the source code. *) val attr_str_type_decl_expect : (structure_item, type_declaration, _) attr_group_inline val attr_sig_type_decl_expect : (signature_item, type_declaration, _) attr_group_inline (** Same as [attr_group_inline] but for elements that are not part of a group, such as exceptions and type extensions *) type ('a, 'b, 'c) attr_inline = ('b, 'c) Attribute.t -> (ctxt:Expansion_context.Deriver.t -> 'b -> 'c -> 'a list) -> t val attr_str_module_type_decl : (structure_item, module_type_declaration, _) attr_inline val attr_sig_module_type_decl : (signature_item, module_type_declaration, _) attr_inline val attr_str_module_type_decl_expect : (structure_item, module_type_declaration, _) attr_inline val attr_sig_module_type_decl_expect : (signature_item, module_type_declaration, _) attr_inline val attr_str_type_ext : (structure_item, type_extension, _) attr_inline val attr_sig_type_ext : (signature_item, type_extension, _) attr_inline val attr_str_type_ext_expect : (structure_item, type_extension, _) attr_inline val attr_sig_type_ext_expect : (signature_item, type_extension, _) attr_inline val attr_str_exception : (structure_item, type_exception, _) attr_inline val attr_sig_exception : (signature_item, type_exception, _) attr_inline val attr_str_exception_expect : (structure_item, type_exception, _) attr_inline val attr_sig_exception_expect : (signature_item, type_exception, _) attr_inline end (**/**) (*_ This API is not stable *) module Generated_code_hook : sig type 'a single_or_many = | Single of 'a | Many of 'a list (*_ Hook called whenever we generate code some *) type t = { f : 'a. 'a Extension.Context.t -> Location.t -> 'a single_or_many -> unit } val nop : t end module Expect_mismatch_handler : sig type t = { f : 'a. 'a Attribute.Floating.Context.t -> Location.t -> 'a list -> unit } val nop : t end (**/**) (* TODO: a simple comment here is fine, while we would expect only docstring or (*_ *) comments to be accepted. On the contrary, docstrings are *not* accepted. This means https://github.com/ocaml/ocaml/pull/477 was not complete and indeed the parser should be fixed. *) class map_top_down : ?expect_mismatch_handler:Expect_mismatch_handler.t (* default: Expect_mismatch_handler.nop *) -> ?generated_code_hook:Generated_code_hook.t (* default: Generated_code_hook.nop *) -> Rule.t list -> Ast_traverse.map_with_expansion_context ppxlib-0.12.0/src/deriving.ml000066400000000000000000000621121360512673700160340ustar00rootroot00000000000000open Import open Ast_builder.Default (* [do_insert_unused_warning_attribute] -- If true, generated code contains compiler attribute to disable unused warnings, instead of inserting [let _ = ... ]. *) let do_insert_unused_warning_attribute = ref false let keep_w32_impl = ref false let keep_w32_intf = ref false let () = let keep_w32_spec = Caml.Arg.Symbol (["impl"; "intf"; "both"], (function | "impl" -> keep_w32_impl := true | "intf" -> keep_w32_intf := true | "both" -> keep_w32_impl := true; keep_w32_intf := true | _ -> assert false)) in let conv_w32_spec = Caml.Arg.Symbol (["code"; "attribute"], (function | "code" -> do_insert_unused_warning_attribute := false | "attribute" -> do_insert_unused_warning_attribute := true | _ -> assert false)) in Driver.add_arg "-deriving-keep-w32" keep_w32_spec ~doc:" Do not try to disable warning 32 for the generated code"; Driver.add_arg "-deriving-disable-w32-method" conv_w32_spec ~doc:" How to disable warning 32 for the generated code"; Driver.add_arg "-type-conv-keep-w32" keep_w32_spec ~doc:" Deprecated, use -deriving-keep-w32"; Driver.add_arg "-type-conv-w32" conv_w32_spec ~doc:" Deprecated, use -deriving-disable-w32-method" let keep_w32_impl () = !keep_w32_impl || Driver.pretty () let keep_w32_intf () = !keep_w32_intf || Driver.pretty () module List = struct include List let concat_map xs ~f = concat (map xs ~f) let rec filter_map l ~f = match l with | [] -> [] | x :: l -> match f x with | None -> filter_map l ~f | Some y -> y :: filter_map l ~f end module Args = struct include (Ast_pattern : module type of struct include Ast_pattern end with type ('a, 'b, 'c) t := ('a, 'b, 'c) Ast_pattern.t) type 'a param = { name : string ; pattern : (expression, 'a) Ast_pattern.Packed.t ; default : 'a } let arg name pattern = { name ; default = None ; pattern = Ast_pattern.Packed.create pattern (fun x -> Some x) } ;; let flag name = let pattern = pexp_ident (lident (string name)) in { name ; default = false ; pattern = Ast_pattern.Packed.create pattern true } ;; type (_, _) t = | Nil : ('m, 'm) t | Cons : ('m1, 'a -> 'm2) t * 'a param -> ('m1, 'm2) t let empty = Nil let ( +> ) a b = Cons (a, b) let rec names : type a b. (a, b) t -> string list = function | Nil -> [] | Cons (t, p) -> p.name :: names t ;; module Instance = struct type (_, _) instance = | I_nil : ('m, 'm) instance | I_cons : ('m1, 'a -> 'm2) instance * 'a -> ('m1, 'm2) instance let rec create : type a b. (a, b) t -> (string * expression) list -> (a, b) instance = fun spec args -> match spec with | Nil -> I_nil | Cons (t, p) -> let value = match List.Assoc.find args ~equal:String.equal p.name with | None -> p.default | Some expr -> Ast_pattern.Packed.parse p.pattern expr.pexp_loc expr in I_cons (create t args, value) ;; let rec apply : type a b. (a, b) instance -> a -> b = fun t f -> match t with | I_nil -> f | I_cons (t, x) -> apply t f x ;; end let apply t args f = Instance.apply (Instance.create t args) f end (* +-----------------------------------------------------------------+ | Generators | +-----------------------------------------------------------------+ *) type t = string let ignore (_ : t) = () type parsed_args = | Args of (string * expression) list | Unknown_syntax of Location.t * string module Generator = struct type deriver = t type ('a, 'b) t = | T : { spec : ('c, 'a) Args.t ; gen : ctxt:Expansion_context.Deriver.t -> 'b -> 'c ; arg_names : Set.M(String).t ; attributes : Attribute.packed list ; deps : deriver list } -> ('a, 'b) t let deps (T t) = t.deps module V2 = struct let make ?(attributes=[]) ?(deps=[]) spec gen = let arg_names = Set.of_list (module String) (Args.names spec) in T { spec ; gen ; arg_names ; attributes ; deps } ;; let make_noarg ?attributes ?deps gen = make ?attributes ?deps Args.empty gen end let make ?attributes ?deps spec gen = V2.make ?attributes ?deps spec (Expansion_context.Deriver.with_loc_and_path gen) let make_noarg ?attributes ?deps gen = make ?attributes ?deps Args.empty gen let merge_accepted_args l = let rec loop acc = function | [] -> acc | T t :: rest -> loop (Set.union acc t.arg_names) rest in loop (Set.empty (module String)) l let check_arguments name generators (args : (string * expression) list) = List.iter args ~f:(fun (label, e) -> if String.is_empty label then Location.raise_errorf ~loc:e.pexp_loc "Ppxlib.Deriving: generator arguments must be labelled"); Option.iter (List.find_a_dup args ~compare:(fun (a, _) (b, _) -> String.compare a b)) ~f:(fun (label, e) -> Location.raise_errorf ~loc:e.pexp_loc "Ppxlib.Deriving: argument labelled '%s' appears more than once" label); let accepted_args = merge_accepted_args generators in List.iter args ~f:(fun (label, e) -> if not (Set.mem accepted_args label) then let spellcheck_msg = match Spellcheck.spellcheck (Set.to_list accepted_args) label with | None -> "" | Some s -> ".\n" ^ s in Location.raise_errorf ~loc:e.pexp_loc "Ppxlib.Deriving: generator '%s' doesn't accept argument '%s'%s" name label spellcheck_msg); ;; let apply (T t) ~name:_ ~ctxt x args = Args.apply t.spec args (t.gen ~ctxt x) ;; let apply_all ~ctxt entry (name, generators, args) = check_arguments name.txt generators args; List.concat_map generators ~f:(fun t -> apply t ~name:name.txt ~ctxt entry args) ;; let apply_all ~ctxt entry generators = List.concat_map generators ~f:(apply_all ~ctxt entry) ;; end module Deriver = struct module Actual_deriver = struct type t = { name : string ; str_type_decl : (structure, rec_flag * type_declaration list) Generator.t option ; str_type_ext : (structure, type_extension ) Generator.t option ; str_exception : (structure, type_exception ) Generator.t option ; str_module_type_decl : (structure, module_type_declaration ) Generator.t option ; sig_type_decl : (signature, rec_flag * type_declaration list) Generator.t option ; sig_type_ext : (signature, type_extension ) Generator.t option ; sig_exception : (signature, type_exception ) Generator.t option ; sig_module_type_decl : (signature, module_type_declaration ) Generator.t option ; extension : (loc:Location.t -> path:string -> core_type -> expression) option } end module Alias = struct type t = { str_type_decl : string list ; str_type_ext : string list ; str_exception : string list ; str_module_type_decl : string list ; sig_type_decl : string list ; sig_type_ext : string list ; sig_exception : string list ; sig_module_type_decl : string list } end module Field = struct type kind = Str | Sig type ('a, 'b) t = { name : string ; kind : kind ; get : Actual_deriver.t -> ('a, 'b) Generator.t option ; get_set : Alias.t -> string list } let str_type_decl = { kind = Str; name = "type" ; get = (fun t -> t.str_type_decl) ; get_set = (fun t -> t.str_type_decl) } let str_type_ext = { kind = Str; name = "type extension" ; get = (fun t -> t.str_type_ext) ; get_set = (fun t -> t.str_type_ext ) } let str_exception = { kind = Str; name = "exception" ; get = (fun t -> t.str_exception) ; get_set = (fun t -> t.str_exception) } let str_module_type_decl = { kind = Str; name = "module type" ; get = (fun t -> t.str_module_type_decl) ; get_set = (fun t -> t.str_module_type_decl) } let sig_type_decl = { kind = Sig; name = "signature type" ; get = (fun t -> t.sig_type_decl) ; get_set = (fun t -> t.sig_type_decl) } let sig_type_ext = { kind = Sig; name = "signature type extension" ; get = (fun t -> t.sig_type_ext) ; get_set = (fun t -> t.sig_type_ext ) } let sig_exception = { kind = Sig; name = "signature exception" ; get = (fun t -> t.sig_exception) ; get_set = (fun t -> t.sig_exception) } let sig_module_type_decl = { kind = Sig; name = "signature module type" ; get = (fun t -> t.sig_module_type_decl) ; get_set = (fun t -> t.sig_module_type_decl) } end type t = | Actual_deriver of Actual_deriver.t | Alias of Alias.t type Ppx_derivers.deriver += T of t let derivers () = List.filter_map (Ppx_derivers.derivers ()) ~f:(function | name, T t -> Some (name, t) | _ -> None) exception Not_supported of string let resolve_actual_derivers (field : (_, _) Field.t) name = let rec loop name collected = if List.exists collected ~f:(fun (d : Actual_deriver.t) -> String.equal d.name name) then collected else match Ppx_derivers.lookup name with | Some (T (Actual_deriver drv)) -> drv :: collected | Some (T (Alias alias)) -> let set = field.get_set alias in List.fold_right set ~init:collected ~f:loop | _ -> raise (Not_supported name) in List.rev (loop name []) let resolve_internal (field : (_, _) Field.t) name = List.map (resolve_actual_derivers field name) ~f:(fun drv -> match field.get drv with | None -> raise (Not_supported name) | Some g -> (drv.name, g)) ;; let supported_for field = List.fold_left (derivers ()) ~init:(Set.empty (module String)) ~f:(fun acc (name, _) -> match resolve_internal field name with | _ -> Set.add acc name | exception Not_supported _ -> acc) |> Set.to_list ;; let not_supported (field : (_, _) Field.t) ?(spellcheck=true) name = let spellcheck_msg = if spellcheck then match Spellcheck.spellcheck (supported_for field) name.txt with | None -> "" | Some s -> ".\n" ^ s else "" in Location.raise_errorf ~loc:name.loc "Ppxlib.Deriving: '%s' is not a supported %s deriving generator%s" name.txt field.name spellcheck_msg ;; let resolve field name = try resolve_internal field name.txt with Not_supported name' -> not_supported field ~spellcheck:(String.equal name.txt name') name ;; let resolve_all field derivers = let derivers_and_args = List.filter_map derivers ~f:(fun (name, args) -> match Ppx_derivers.lookup name.txt with | None -> not_supported field name | Some (T _) -> (* It's one of ours, parse the arguments now. We can't do it before since ppx_deriving uses a different syntax for arguments. *) Some (name, match args with | Args l -> l | Unknown_syntax (loc, msg) -> Location.raise_errorf ~loc "Ppxlib.Deriving: %s" msg) | Some _ -> (* It's not one of ours, ignore it. *) None) in (* Set of actual deriver names *) let seen = Hash_set.create (module String) in List.map derivers_and_args ~f:(fun (name, args) -> let named_generators = resolve field name in List.iter named_generators ~f:(fun (actual_deriver_name, gen) -> if Options.fail_on_duplicate_derivers && Hash_set.mem seen actual_deriver_name then Location.raise_errorf ~loc:name.loc "Deriver %s appears twice" actual_deriver_name; List.iter (Generator.deps gen) ~f:(fun dep -> List.iter (resolve_actual_derivers field dep) ~f:(fun drv -> let dep_name = drv.name in if not (Hash_set.mem seen dep_name) then Location.raise_errorf ~loc:name.loc "Deriver %s is needed for %s, you need to add it before in the list" dep_name name.txt)); Hash_set.add seen actual_deriver_name); (name, List.map named_generators ~f:snd, args)) ;; let add ?str_type_decl ?str_type_ext ?str_exception ?str_module_type_decl ?sig_type_decl ?sig_type_ext ?sig_exception ?sig_module_type_decl ?extension name = let actual_deriver : Actual_deriver.t = { name ; str_type_decl ; str_type_ext ; str_exception ; str_module_type_decl ; sig_type_decl ; sig_type_ext ; sig_exception ; sig_module_type_decl ; extension } in Ppx_derivers.register name (T (Actual_deriver actual_deriver)); (match extension with | None -> () | Some f -> let extension = Extension.declare name Expression Ast_pattern.(ptyp __) f in Driver.register_transformation ("Ppxlib.Deriving." ^ name) ~rules:[ Context_free.Rule.extension extension ]); name ;; let add_alias name ?str_type_decl ?str_type_ext ?str_exception ?str_module_type_decl ?sig_type_decl ?sig_type_ext ?sig_exception ?sig_module_type_decl set = let alias : Alias.t = let get = function | None -> set | Some set -> set in { str_type_decl = get str_type_decl ; str_type_ext = get str_type_ext ; str_exception = get str_exception ; str_module_type_decl = get str_module_type_decl ; sig_type_decl = get sig_type_decl ; sig_type_ext = get sig_type_ext ; sig_exception = get sig_exception ; sig_module_type_decl = get sig_module_type_decl } in Ppx_derivers.register name (T (Alias alias)); name ;; end let add = Deriver.add let add_alias = Deriver.add_alias (* +-----------------------------------------------------------------+ | [@@deriving ] parsing | +-----------------------------------------------------------------+ *) let invalid_with ~loc = Location.raise_errorf ~loc "invalid [@@deriving ] attribute syntax" let generator_name_of_id loc id = match Longident.flatten_exn id with | l -> { loc; txt = String.concat ~sep:"." l } | exception _ -> invalid_with ~loc:loc ;; exception Unknown_syntax of Location.t * string let parse_arguments l = try Args ( match l with | [(Nolabel, e)] -> begin match e.pexp_desc with | Pexp_record (fields, None) -> List.map fields ~f:(fun (id, expr) -> let name = match id.txt with | Lident s -> s | _ -> Exn.raise_without_backtrace (Unknown_syntax (id.loc, "simple identifier expected")) in (name, expr)) | _ -> Exn.raise_without_backtrace (Unknown_syntax (e.pexp_loc, "non-optional labelled argument or record expected")) end | l -> List.map l ~f:(fun (label, expr) -> match label with | Labelled s -> (s, expr) | _ -> Exn.raise_without_backtrace (Unknown_syntax (expr.pexp_loc, "non-optional labelled argument expected")))) with Unknown_syntax (loc, msg) -> Unknown_syntax (loc, msg) let mk_deriving_attr context ~prefix ~suffix = Attribute.declare (prefix ^ "deriving" ^ suffix) context Ast_pattern.( let generator_name () = map' (pexp_ident __) ~f:(fun loc f id -> f (generator_name_of_id loc id)) in let generator () = map (generator_name ()) ~f:(fun f x -> f (x, Args [])) ||| pack2 (pexp_apply (generator_name ()) (map1 (many __) ~f:parse_arguments)) in let generators = pexp_tuple (many (generator ())) ||| map (generator ()) ~f:(fun f x -> f [x]) in pstr (pstr_eval generators nil ^:: nil) ) (fun x -> x) ;; (* +-----------------------------------------------------------------+ | Unused warning stuff + locations check silencing | +-----------------------------------------------------------------+ *) let disable_unused_warning_attribute = let loc = Location.none in { attr_name = { txt = "ocaml.warning"; loc }; attr_payload = PStr [pstr_eval ~loc (estring ~loc "-32") []]; attr_loc = loc; } ;; let inline_doc_attr = let loc = Location.none in { attr_name = { txt = "ocaml.doc"; loc }; attr_payload = PStr [pstr_eval ~loc (estring ~loc "@inline") []]; attr_loc = loc; } ;; let wrap_str ~loc ~hide st = let include_infos = include_infos ~loc (pmod_structure ~loc st) in let pincl_attributes = if hide then [ inline_doc_attr; Merlin_helpers.hide_attribute ] else [ inline_doc_attr ] in [pstr_include ~loc {include_infos with pincl_attributes}] let wrap_str ~loc ~hide st = let loc = { loc with loc_ghost = true } in let wrap, st = if keep_w32_impl () then hide, st else if not !do_insert_unused_warning_attribute then hide, Ignore_unused_warning.add_dummy_user_for_values#structure st else (* note: a structure is created because it is not currently possible to attach an [@@ocaml.warning] attribute to a single structure item. *) true, (pstr_attribute ~loc disable_unused_warning_attribute :: st) in if wrap then wrap_str ~loc ~hide st else st ;; let wrap_sig ~loc ~hide st = let include_infos = include_infos ~loc (pmty_signature ~loc st) in let pincl_attributes = if hide then [ inline_doc_attr; Merlin_helpers.hide_attribute ] else [ inline_doc_attr ] in [psig_include ~loc {include_infos with pincl_attributes}] let wrap_sig ~loc ~hide sg = let loc = { loc with loc_ghost = true } in let wrap, sg = if keep_w32_intf () then hide, sg else true, (psig_attribute ~loc disable_unused_warning_attribute :: sg) in if wrap then wrap_sig ~loc ~hide sg else sg ;; (* +-----------------------------------------------------------------+ | Remove attributes used by syntax extensions | +-----------------------------------------------------------------+ *) (* let remove generators = let attributes = List.concat_map generators ~f:(fun (_, actual_generators, _) -> List.concat_map actual_generators ~f:(fun (Generator.T g) -> g.attributes)) in object inherit Ast_traverse.map (* Don't recurse through attributes and extensions *) method! attribute x = x method! extension x = x method! label_declaration ld = Attribute.remove_seen Attribute.Context.label_declaration attributes ld method! constructor_declaration cd = Attribute.remove_seen Attribute.Context.constructor_declaration attributes cd end *) (* +-----------------------------------------------------------------+ | Main expansion | +-----------------------------------------------------------------+ *) let types_used_by_deriving (tds : type_declaration list) : structure_item list = if keep_w32_impl () then [] else List.map tds ~f:(fun td -> let typ = Common.core_type_of_type_declaration td in let loc = td.ptype_loc in pstr_value ~loc Nonrecursive [value_binding ~loc ~pat:(ppat_any ~loc) ~expr:(pexp_fun ~loc Nolabel None (ppat_constraint ~loc (ppat_any ~loc) typ) (eunit ~loc))] ) let merge_generators field l = List.filter_map l ~f:(fun x -> x) |> List.concat |> Deriver.resolve_all field let expand_str_type_decls ~ctxt rec_flag tds values = let generators = merge_generators Deriver.Field.str_type_decl values in (* TODO: instead of disabling the unused warning for types themselves, we should add a tag [@@unused]. *) let generated = types_used_by_deriving tds @ Generator.apply_all ~ctxt (rec_flag, tds) generators; in wrap_str ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) ~hide:(not @@ Expansion_context.Deriver.inline ctxt) generated let expand_sig_type_decls ~ctxt rec_flag tds values = let generators = merge_generators Deriver.Field.sig_type_decl values in let generated = Generator.apply_all ~ctxt (rec_flag, tds) generators in wrap_sig ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) ~hide:(not @@ Expansion_context.Deriver.inline ctxt) generated let expand_str_module_type_decl ~ctxt mtd generators = let generators = Deriver.resolve_all Deriver.Field.str_module_type_decl generators in let generated = Generator.apply_all ~ctxt mtd generators in wrap_str ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) ~hide:(not @@ Expansion_context.Deriver.inline ctxt) generated let expand_sig_module_type_decl ~ctxt mtd generators = let generators = Deriver.resolve_all Deriver.Field.sig_module_type_decl generators in let generated = Generator.apply_all ~ctxt mtd generators in wrap_sig ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) ~hide:(not @@ Expansion_context.Deriver.inline ctxt) generated let expand_str_exception ~ctxt ec generators = let generators = Deriver.resolve_all Deriver.Field.str_exception generators in let generated = Generator.apply_all ~ctxt ec generators in wrap_str ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) ~hide:(not @@ Expansion_context.Deriver.inline ctxt) generated let expand_sig_exception ~ctxt ec generators = let generators = Deriver.resolve_all Deriver.Field.sig_exception generators in let generated = Generator.apply_all ~ctxt ec generators in wrap_sig ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) ~hide:(not @@ Expansion_context.Deriver.inline ctxt) generated let expand_str_type_ext ~ctxt te generators = let generators = Deriver.resolve_all Deriver.Field.str_type_ext generators in let generated = Generator.apply_all ~ctxt te generators in wrap_str ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) ~hide:(not @@ Expansion_context.Deriver.inline ctxt) generated let expand_sig_type_ext ~ctxt te generators = let generators = Deriver.resolve_all Deriver.Field.sig_type_ext generators in let generated = Generator.apply_all ~ctxt te generators in wrap_sig ~loc:(Expansion_context.Deriver.derived_item_loc ctxt) ~hide:(not @@ Expansion_context.Deriver.inline ctxt) generated let rules ~typ ~expand_sig ~expand_str ~rule_str ~rule_sig ~rule_str_expect ~rule_sig_expect = let prefix = "ppxlib." in let deriving_attr = mk_deriving_attr ~suffix:"" ~prefix typ in let deriving_attr_expect = mk_deriving_attr ~suffix:"_inline" ~prefix typ in [ rule_sig deriving_attr expand_sig ; rule_str deriving_attr expand_str ; rule_str_expect deriving_attr_expect expand_str ; rule_sig_expect deriving_attr_expect expand_sig ] let rules_type_decl = rules ~typ:Type_declaration ~expand_str:expand_str_type_decls ~expand_sig:expand_sig_type_decls ~rule_str:Context_free.Rule.attr_str_type_decl ~rule_sig:Context_free.Rule.attr_sig_type_decl ~rule_str_expect:Context_free.Rule.attr_str_type_decl_expect ~rule_sig_expect:Context_free.Rule.attr_sig_type_decl_expect let rules_type_ext = rules ~typ:Type_extension ~expand_str:expand_str_type_ext ~expand_sig:expand_sig_type_ext ~rule_str:Context_free.Rule.attr_str_type_ext ~rule_sig:Context_free.Rule.attr_sig_type_ext ~rule_str_expect:Context_free.Rule.attr_str_type_ext_expect ~rule_sig_expect:Context_free.Rule.attr_sig_type_ext_expect let rules_exception = rules ~typ:Type_exception ~expand_str:expand_str_exception ~expand_sig:expand_sig_exception ~rule_str:Context_free.Rule.attr_str_exception ~rule_sig:Context_free.Rule.attr_sig_exception ~rule_str_expect:Context_free.Rule.attr_str_exception_expect ~rule_sig_expect:Context_free.Rule.attr_sig_exception_expect let rules_module_type_decl = rules ~typ:Module_type_declaration ~expand_str:expand_str_module_type_decl ~expand_sig:expand_sig_module_type_decl ~rule_str:Context_free.Rule.attr_str_module_type_decl ~rule_sig:Context_free.Rule.attr_sig_module_type_decl ~rule_str_expect:Context_free.Rule.attr_str_module_type_decl_expect ~rule_sig_expect:Context_free.Rule.attr_sig_module_type_decl_expect let () = let rules = [ rules_type_decl ; rules_type_ext ; rules_exception ; rules_module_type_decl ] |> List.concat in Driver.register_transformation "deriving" ~aliases:["type_conv"] ~rules ;; ppxlib-0.12.0/src/deriving.mli000066400000000000000000000101431360512673700162020ustar00rootroot00000000000000(** Deriving code from type declarations *) open Import (** Specification of generator arguments *) module Args : sig type ('a, 'b) t type 'a param val empty : ('m, 'm) t val arg : string -> (expression, 'a -> 'a option, 'a option) Ast_pattern.t -> 'a option param (** Flag matches punned labelled argument, i.e. of the form [~foo]. It returns [true] iff the argument is present. *) val flag : string -> bool param val ( +> ) : ('m1, 'a -> 'm2) t -> 'a param -> ('m1, 'm2) t (** For convenience, so that one can write the following without having to open both [Ast_pattern] and [Deriving.Args]: {[ Deriving.Args.(empty +> arg_option "foo" (estring __) +> arg_option "bar" (pack2 (eint __ ** eint __)) +> flag "dotdotdot" ) ]} *) include module type of struct include Ast_pattern end with type ('a, 'b, 'c) t := ('a, 'b, 'c) Ast_pattern.t end (** {6 Generator registration} *) (** Type of registered derivers *) type t module Generator : sig type deriver = t type ('output_ast, 'input_ast) t val make : ?attributes:Attribute.packed list -> ?deps:deriver list -> ('f, 'output_ast) Args.t -> (loc:Location.t -> path:string -> 'input_ast -> 'f) -> ('output_ast, 'input_ast) t val make_noarg : ?attributes:Attribute.packed list -> ?deps:deriver list -> (loc:Location.t -> path:string -> 'input_ast -> 'output_ast) -> ('output_ast, 'input_ast) t module V2 : sig val make : ?attributes:Attribute.packed list -> ?deps:deriver list -> ('f, 'output_ast) Args.t -> (ctxt:Expansion_context.Deriver.t -> 'input_ast -> 'f) -> ('output_ast, 'input_ast) t val make_noarg : ?attributes:Attribute.packed list -> ?deps:deriver list -> (ctxt:Expansion_context.Deriver.t -> 'input_ast -> 'output_ast) -> ('output_ast, 'input_ast) t end val apply : ('output_ast, 'input_ast) t -> name:string -> ctxt:Expansion_context.Deriver.t -> 'input_ast -> (string * expression) list -> 'output_ast end with type deriver := t (** Register a new deriving generator. The various arguments are for the various items on which derivers can be attached in structure and signatures. We distinguish [exception] from [type_extension] as [exception E] is not exactly the same as [type exn += E]. Indeed if the type [exn] is redefined, then [type exn += E] will add [E] to the new [exn] type while [exception E] will add [E] to the predefined [exn] type. [extension] register an expander for extension with the name of the deriver. This is here mostly to support the ppx_deriving backend. *) val add : ?str_type_decl:(structure, rec_flag * type_declaration list) Generator.t -> ?str_type_ext :(structure, type_extension ) Generator.t -> ?str_exception:(structure, type_exception ) Generator.t -> ?str_module_type_decl:(structure, module_type_declaration ) Generator.t -> ?sig_type_decl:(signature, rec_flag * type_declaration list) Generator.t -> ?sig_type_ext :(signature, type_extension ) Generator.t -> ?sig_exception:(signature, type_exception ) Generator.t -> ?sig_module_type_decl:(signature, module_type_declaration ) Generator.t -> ?extension:(loc:Location.t -> path:string -> core_type -> expression) -> string -> t (** [add_alias name set] add an alias. When the user write the alias, all the generator of [set] will be used instead. It is possible to override the set for any of the context by passing the specific set in the approriate optional argument of [add_alias]. *) val add_alias : string -> ?str_type_decl:t list -> ?str_type_ext :t list -> ?str_exception:t list -> ?str_module_type_decl:t list -> ?sig_type_decl:t list -> ?sig_type_ext :t list -> ?sig_exception:t list -> ?sig_module_type_decl:t list -> t list -> t (** Ignore a deriver. So that one can write: [Deriving.add ... |> Deriving.ignore] *) val ignore : t -> unit ppxlib-0.12.0/src/driver.ml000066400000000000000000001265411360512673700155270ustar00rootroot00000000000000(*$ open Ppxlib_cinaps_helpers $*) open Import open Utils module Arg = Caml.Arg let exe_name = Caml.Filename.basename Caml.Sys.executable_name let args = ref [] let add_arg key spec ~doc = args := (key, spec, doc) :: !args let loc_fname = ref None let perform_checks = ref Options.perform_checks let perform_checks_on_extensions = ref Options.perform_checks_on_extensions let perform_locations_check = ref Options.perform_locations_check let debug_attribute_drop = ref false let apply_list = ref None let preprocessor = ref None let no_merge = ref false let request_print_passes = ref false let request_print_transformations = ref false let use_color = ref true let diff_command = ref Options.diff_command let pretty = ref false let styler = ref None let output_metadata_filename = ref None let corrected_suffix = ref ".ppx-corrected" module Lint_error = struct type t = Location.t * string let of_string loc s = (loc, s) end module Cookies = struct type t = Migrate_parsetree.Driver.cookies let get t name pattern = Option.map (Migrate_parsetree.Driver.get_cookie t name (module Ppxlib_ast.Selected_ast)) ~f:(fun e -> Ast_pattern.parse pattern e.pexp_loc e Fn.id) let set t name expr = Migrate_parsetree.Driver.set_cookie t name (module Ppxlib_ast.Selected_ast) expr let handlers = ref [] let add_handler f = handlers := !handlers @ [f] let add_simple_handler name pattern ~f = add_handler (fun t -> f (get t name pattern)) let acknoledge_cookies t = List.iter !handlers ~f:(fun f -> f t) let post_handlers = ref [] let add_post_handler f = post_handlers := !post_handlers @ [f] let call_post_handlers t = List.iter !post_handlers ~f:(fun f -> f t) end module Transform = struct type t = { name : string ; aliases : string list ; impl : (Parsetree.structure -> Parsetree.structure) option ; intf : (Parsetree.signature -> Parsetree.signature) option ; lint_impl : (Parsetree.structure -> Lint_error.t list) option ; lint_intf : (Parsetree.signature -> Lint_error.t list) option ; preprocess_impl : (Parsetree.structure -> Parsetree.structure) option ; preprocess_intf : (Parsetree.signature -> Parsetree.signature) option ; enclose_impl : (Location.t option -> Parsetree.structure * Parsetree.structure) option ; enclose_intf : (Location.t option -> Parsetree.signature * Parsetree.signature) option ; rules : Context_free.Rule.t list ; registered_at : Caller_id.t } let has_name t name = (String.equal name t.name) || (List.exists ~f:(String.equal name) t.aliases) let all : t list ref = ref [] let print_caller_id oc (caller_id : Caller_id.t) = match caller_id with | None -> Out_channel.output_string oc "" | Some loc -> Out_channel.fprintf oc "%s:%d" loc.filename loc.line_number ;; let register ?(extensions=[]) ?(rules=[]) ?enclose_impl ?enclose_intf ?impl ?intf ?lint_impl ?lint_intf ?preprocess_impl ?preprocess_intf ?(aliases=[]) name = let rules = List.map extensions ~f:Context_free.Rule.extension @ rules in let caller_id = Caller_id.get ~skip:[Caml.__FILE__] in begin match List.filter !all ~f:(fun ct -> has_name ct name) with | [] -> () | ct :: _ -> eprintf "Warning: code transformation %s registered twice.\n" name; eprintf " - first time was at %a\n" print_caller_id ct.registered_at; eprintf " - second time is at %a\n" print_caller_id caller_id; end; let ct = { name ; aliases ; rules ; enclose_impl ; enclose_intf ; impl ; intf ; lint_impl ; preprocess_impl ; preprocess_intf ; lint_intf ; registered_at = caller_id } in all := ct :: !all ;; let rec last prev l = match l with | [] -> prev | x :: l -> last x l ;; let loc_of_list ~get_loc l = match l with | [] -> None | x :: l -> let first : Location.t = get_loc x in let last = get_loc (last x l) in Some { first with loc_end = last.loc_end } ;; let merge_into_generic_mappers t ~hook ~expect_mismatch_handler ~omp_config = let { rules; enclose_impl; enclose_intf; impl; intf; _ } = t in let map = new Context_free.map_top_down rules ~generated_code_hook:hook ~expect_mismatch_handler in let gen_header_and_footer context whole_loc f = let header, footer = f whole_loc in (match whole_loc with | Some (loc : Location.t) -> let loc_header = { loc with loc_end = loc.loc_start } in let loc_footer = { loc with loc_start = loc.loc_end } in (match header with [] -> () | _ -> hook.f context loc_header (Many header)); (match footer with [] -> () | _ -> hook.f context loc_footer (Many footer)) | None -> match header @ footer with | [] -> () | l -> let pos = { Lexing. pos_fname = "" ; pos_lnum = 1 ; pos_bol = 0 ; pos_cnum = 0 } in let loc = { Location. loc_start = pos; loc_end = pos; loc_ghost = false } in hook.f context loc (Many l)); (header, footer) in let map_impl st_with_attrs = let st = let attrs, st = List.split_while st_with_attrs ~f:(function | { pstr_desc = Pstr_attribute _; _ } -> true | _ -> false) in let header, footer = match enclose_impl with | None -> ([], []) | Some f -> let whole_loc = loc_of_list st ~get_loc:(fun st -> st.Parsetree.pstr_loc) in gen_header_and_footer Structure_item whole_loc f in let file_path = File_path.get_default_path_str st in let base_ctxt = Expansion_context.Base.top_level ~omp_config ~file_path in let attrs = map#structure base_ctxt attrs in let st = map#structure base_ctxt st in List.concat [ attrs; header; st; footer ] in match impl with | None -> st | Some f -> f st in let map_intf sg_with_attrs = let sg = let attrs, sg = List.split_while sg_with_attrs ~f:(function | { psig_desc = Psig_attribute _; _ } -> true | _ -> false) in let header, footer = match enclose_intf with | None -> ([], []) | Some f -> let whole_loc = loc_of_list sg ~get_loc:(fun sg -> sg.Parsetree.psig_loc) in gen_header_and_footer Signature_item whole_loc f in let file_path = File_path.get_default_path_sig sg in let base_ctxt = Expansion_context.Base.top_level ~omp_config ~file_path in let attrs = map#signature base_ctxt attrs in let sg = map#signature base_ctxt sg in List.concat [ attrs; header; sg; footer ] in match intf with | None -> sg | Some f -> f sg in { t with impl = Some map_impl ; intf = Some map_intf } let builtin_of_context_free_rewriters ~hook ~rules ~enclose_impl ~enclose_intf = merge_into_generic_mappers ~hook { name = "" ; aliases = [] ; impl = None ; intf = None ; lint_impl = None ; lint_intf = None ; preprocess_impl = None ; preprocess_intf = None ; enclose_impl ; enclose_intf ; rules ; registered_at = Caller_id.get ~skip:[] } let partition_transformations ts = (`Linters (List.filter_map ts ~f:(fun t -> if Option.is_some t.lint_impl || Option.is_some t.lint_intf then Some { name = Printf.sprintf "" t.name ; aliases = [] ; impl = None ; intf = None ; lint_impl = t.lint_impl ; lint_intf = t.lint_intf ; enclose_impl = None ; enclose_intf = None ; preprocess_impl = None ; preprocess_intf = None ; rules = [] ; registered_at = t.registered_at } else None)), `Preprocess (List.filter_map ts ~f:(fun t -> if Option.is_some t.preprocess_impl || Option.is_some t.preprocess_impl then Some { name = Printf.sprintf "" t.name ; aliases = [] ; impl = t.preprocess_impl ; intf = t.preprocess_intf ; lint_impl = None ; lint_intf = None ; enclose_impl = None ; enclose_intf = None ; preprocess_impl = None ; preprocess_intf = None ; rules = [] ; registered_at = t.registered_at } else None)), `Rest (List.map ts ~f:(fun t -> { t with lint_impl = None ; lint_intf = None ; preprocess_impl = None ; preprocess_intf = None }))) end let register_transformation = Transform.register let register_code_transformation ~name ?(aliases=[]) ~impl ~intf = register_transformation name ~impl ~intf ~aliases ;; let register_transformation_using_ocaml_current_ast ?impl ?intf ?aliases name = let impl = Option.map impl ~f:(Ppxlib_ast.Selected_ast.of_ocaml_mapper Structure) in let intf = Option.map intf ~f:(Ppxlib_ast.Selected_ast.of_ocaml_mapper Signature) in register_transformation ?impl ?intf ?aliases name let debug_dropped_attribute name ~old_dropped ~new_dropped = let print_diff what a b = let diff = List.filter a ~f:(fun (name : _ Loc.t) -> not (List.exists b ~f:(fun (name' : _ Location.loc) -> phys_equal name.txt name'.txt))) in if not (List.is_empty diff) then begin eprintf "The following attributes %s after applying %s:\n" what name; List.iter diff ~f:(fun { Location. txt; loc } -> Caml.Format.eprintf "- %a: %s\n" Location.print loc txt); Caml.Format.eprintf "@." end in print_diff "disappeared" new_dropped old_dropped; print_diff "reappeared" old_dropped new_dropped ;; let get_whole_ast_passes ~hook ~expect_mismatch_handler ~omp_config = let cts = match !apply_list with | None -> List.rev !Transform.all | Some names -> List.map names ~f:(fun name -> List.find_exn !Transform.all ~f:(fun (ct : Transform.t) -> Transform.has_name ct name)) in let (`Linters linters, `Preprocess preprocess, `Rest cts) = Transform.partition_transformations cts in (* Allow only one preprocessor to assure deterministic order *) if (List.length preprocess) > 1 then begin let pp = String.concat ~sep:", " (List.map preprocess ~f:(fun t -> t.name)) in let err = Printf.sprintf "At most one preprocessor is allowed, while got: %s" pp in failwith err end; let cts = if !no_merge then List.map cts ~f:(Transform.merge_into_generic_mappers ~hook ~omp_config ~expect_mismatch_handler) else begin let get_enclosers ~f = List.filter_map cts ~f:(fun (ct : Transform.t) -> match f ct with | None -> None | Some x -> Some (ct.name, x)) (* Sort them to ensure deterministic ordering *) |> List.sort ~compare:(fun (a, _) (b, _) -> String.compare a b) |> List.map ~f:snd in let rules = List.map cts ~f:(fun (ct : Transform.t) -> ct.rules) |> List.concat and impl_enclosers = get_enclosers ~f:(fun ct -> ct.enclose_impl) and intf_enclosers = get_enclosers ~f:(fun ct -> ct.enclose_intf) in match rules, impl_enclosers, intf_enclosers with | [], [], [] -> cts | _ -> let merge_encloser = function | [] -> None | enclosers -> Some (fun loc -> let headers, footers = List.map enclosers ~f:(fun f -> f loc) |> List.unzip in let headers = List.concat headers in let footers = List.concat (List.rev footers) in (headers, footers)) in Transform.builtin_of_context_free_rewriters ~rules ~hook ~expect_mismatch_handler ~enclose_impl:(merge_encloser impl_enclosers) ~enclose_intf:(merge_encloser intf_enclosers) ~omp_config :: cts end in linters @ preprocess @ List.filter cts ~f:(fun (ct : Transform.t) -> match ct.impl, ct.intf with | None, None -> false | _ -> true) ;; let apply_transforms ~omp_config ~field ~lint_field ~dropped_so_far ~hook ~expect_mismatch_handler x = let cts = get_whole_ast_passes ~omp_config ~hook ~expect_mismatch_handler in let x, _dropped, lint_errors = List.fold_left cts ~init:(x, [], []) ~f:(fun (x, dropped, lint_errors) (ct : Transform.t) -> let lint_errors = match lint_field ct with | None -> lint_errors | Some f -> lint_errors @ f x in match field ct with | None -> (x, dropped, lint_errors) | Some f -> let x = f x in let dropped = if !debug_attribute_drop then begin let new_dropped = dropped_so_far x in debug_dropped_attribute ct.name ~old_dropped:dropped ~new_dropped; new_dropped end else [] in (x, dropped, lint_errors)) in (x, List.map lint_errors ~f:(fun (loc, s) -> Common.attribute_of_warning loc s)) ;; (* +-----------------------------------------------------------------+ | Actual rewriting of structure/signatures | +-----------------------------------------------------------------+ *) (* We want driver registered plugins to work with omp driver and vice-versa. To simplify things we do as follow: - we register driver as a single omp driver plugin - driver calls the omp driver rewriting functions, which will apply everything The registration with omp driver is at the end of the file. *) module C = struct type t = { hook : Context_free.Generated_code_hook.t ; expect_mismatch_handler : Context_free.Expect_mismatch_handler.t } type Migrate_parsetree.Driver.extra += T of t let default = { hook = Context_free.Generated_code_hook.nop ; expect_mismatch_handler = Context_free.Expect_mismatch_handler.nop } let find (config : Migrate_parsetree.Driver.config) = List.find_map config.extras ~f:(function | T config -> Some config | _ -> None) |> Option.value ~default end let config ~hook ~expect_mismatch_handler = Migrate_parsetree.Driver.make_config () ~tool_name:"ppxlib_driver" ~extras:[C.T { hook ; expect_mismatch_handler }] let as_ppx_config () = Migrate_parsetree.Driver.make_config () ~tool_name:(Ocaml_common.Ast_mapper.tool_name ()) ~include_dirs:!Ocaml_common.Clflags.include_dirs ~load_path:(Compiler_specifics.get_load_path ()) ~debug:!Ocaml_common.Clflags.debug ?for_package:!Ocaml_common.Clflags.for_package let print_passes () = let hook = Context_free.Generated_code_hook.nop in let expect_mismatch_handler = Context_free.Expect_mismatch_handler.nop in let omp_config = config ~hook ~expect_mismatch_handler in let cts = get_whole_ast_passes ~hook ~expect_mismatch_handler ~omp_config in if !perform_checks then printf "\n"; List.iter cts ~f:(fun ct -> printf "%s\n" ct.Transform.name); if !perform_checks then begin printf "\n"; if !perform_checks_on_extensions then printf "\n" end ;; (*$*) let real_map_structure config cookies st = let { C. hook; expect_mismatch_handler } = C.find config in Cookies.acknoledge_cookies cookies; if !perform_checks then begin Attribute.reset_checks (); Attribute.collect#structure st end; let st, lint_errors = apply_transforms st ~omp_config:config ~field:(fun (ct : Transform.t) -> ct.impl) ~lint_field:(fun (ct : Transform.t) -> ct.lint_impl) ~dropped_so_far:Attribute.dropped_so_far_structure ~hook ~expect_mismatch_handler in let st = match lint_errors with | [] -> st | _ -> List.map lint_errors ~f:(fun ({ attr_name = { loc; _ }; _} as attr) -> Ast_builder.Default.pstr_attribute ~loc attr) @ st in Cookies.call_post_handlers cookies; if !perform_checks then begin (* TODO: these two passes could be merged, we now have more passes for checks than for actual rewriting. *) Attribute.check_unused#structure st; if !perform_checks_on_extensions then Extension.check_unused#structure st; Attribute.check_all_seen (); if !perform_locations_check then let open Location_check in ignore ( (enforce_invariants !loc_fname)#structure st Non_intersecting_ranges.empty : Non_intersecting_ranges.t) end; st ;; let map_structure_gen st ~config : Migrate_parsetree.Driver.some_structure = Migrate_parsetree.Driver.rewrite_structure config (module Ppxlib_ast.Selected_ast) st let map_structure st = map_structure_gen st ~config:(as_ppx_config ()) (*$ str_to_sig _last_text_block *) let real_map_signature config cookies sg = let { C. hook; expect_mismatch_handler } = C.find config in Cookies.acknoledge_cookies cookies; if !perform_checks then begin Attribute.reset_checks (); Attribute.collect#signature sg end; let sg, lint_errors = apply_transforms sg ~omp_config:config ~field:(fun (ct : Transform.t) -> ct.intf) ~lint_field:(fun (ct : Transform.t) -> ct.lint_intf) ~dropped_so_far:Attribute.dropped_so_far_signature ~hook ~expect_mismatch_handler in let sg = match lint_errors with | [] -> sg | _ -> List.map lint_errors ~f:(fun ({ attr_name = { loc; _ }; _} as attr) -> Ast_builder.Default.psig_attribute ~loc attr) @ sg in Cookies.call_post_handlers cookies; if !perform_checks then begin (* TODO: these two passes could be merged, we now have more passes for checks than for actual rewriting. *) Attribute.check_unused#signature sg; if !perform_checks_on_extensions then Extension.check_unused#signature sg; Attribute.check_all_seen (); if !perform_locations_check then let open Location_check in ignore ( (enforce_invariants !loc_fname)#signature sg Non_intersecting_ranges.empty : Non_intersecting_ranges.t) end; sg ;; let map_signature_gen sg ~config : Migrate_parsetree.Driver.some_signature = Migrate_parsetree.Driver.rewrite_signature config (module Ppxlib_ast.Selected_ast) sg let map_signature sg = map_signature_gen sg ~config:(as_ppx_config ()) (*$*) (* +-----------------------------------------------------------------+ | Entry points | +-----------------------------------------------------------------+ *) let mapper = let module Js = Ppxlib_ast.Selected_ast in (*$*) let structure _ st = Js.of_ocaml Structure st |> map_structure |> Migrate_parsetree.Driver.migrate_some_structure (module Migrate_parsetree.OCaml_current) in (*$ str_to_sig _last_text_block *) let signature _ sg = Js.of_ocaml Signature sg |> map_signature |> Migrate_parsetree.Driver.migrate_some_signature (module Migrate_parsetree.OCaml_current) in (*$*) { Ocaml_common.Ast_mapper.default_mapper with structure; signature } ;; let as_ppx_rewriter_main argv = let argv = Caml.Sys.executable_name :: argv in let usage = Printf.sprintf "%s [extra_args] " exe_name in match Arg.parse_argv (Array.of_list argv) (Arg.align (List.rev !args)) (fun _ -> raise (Arg.Bad "anonymous arguments not accepted")) usage with | exception Arg.Bad msg -> eprintf "%s" msg; Caml.exit 2 | exception Arg.Help msg -> eprintf "%s" msg; Caml.exit 0 | () -> mapper let run_as_ppx_rewriter () = perform_checks := false; Ocaml_common.Ast_mapper.run_main as_ppx_rewriter_main; Caml.exit 0 let string_contains_binary_ast s = let test magic_number = String.is_prefix s ~prefix:(String.sub magic_number ~pos:0 ~len:9) in test Ast_magic.ast_intf_magic_number || test Ast_magic.ast_impl_magic_number type pp_error = { filename : string; command_line : string } exception Pp_error of pp_error let report_pp_error e = let buff = Buffer.create 128 in let ppf = Caml.Format.formatter_of_buffer buff in Caml.Format.fprintf ppf "Error while running external preprocessor@.\ Command line: %s@." e.command_line; Caml.Format.pp_print_flush ppf (); Buffer.contents buff let () = Location.Error.register_error_of_exn (function | Pp_error e -> Some (Location.Error.make ~loc:(Location.in_file e.filename) ~sub:[] (report_pp_error e)) | _ -> None) let remove_no_error fn = try Caml.Sys.remove fn with Sys_error _ -> () let protectx x ~f ~finally = match f x with | v -> finally x; v | exception e -> finally x; raise e ;; let with_preprocessed_file fn ~f = match !preprocessor with | None -> f fn | Some pp -> protectx (Caml.Filename.temp_file "ocamlpp" "") ~finally:remove_no_error ~f:(fun tmpfile -> let comm = Printf.sprintf "%s %s > %s" pp (if String.equal fn "-" then "" else Caml.Filename.quote fn) (Caml.Filename.quote tmpfile) in if Caml.Sys.command comm <> 0 then raise (Pp_error { filename = fn ; command_line = comm }); f tmpfile) let with_preprocessed_input fn ~f = with_preprocessed_file fn ~f:(fun fn -> if String.equal fn "-" then f stdin else In_channel.with_file fn ~f) ;; let relocate_mapper = object inherit [string * string] Ast_traverse.map_with_context method! position (old_fn, new_fn) pos = if String.equal pos.pos_fname old_fn then { pos with pos_fname = new_fn } else pos end (* Set the input name globally. This is used by some ppx rewriters such as bisect_ppx. *) let set_input_name name = Ocaml_common.Location.input_name := name let load_input (kind : Kind.t) fn input_name ~relocate ic = set_input_name input_name; match Migrate_parsetree.Ast_io.from_channel ic with | Ok (ast_input_name, ast) -> let ast = Intf_or_impl.of_ast_io ast in if not (Kind.equal kind (Intf_or_impl.kind ast)) then Location.raise_errorf ~loc:(Location.in_file fn) "File contains a binary %s AST but an %s was expected" (Kind.describe (Intf_or_impl.kind ast)) (Kind.describe kind); if String.equal ast_input_name input_name || not relocate then begin set_input_name ast_input_name; (ast_input_name, ast) end else (input_name, Intf_or_impl.map_with_context ast relocate_mapper (ast_input_name, input_name)) | Error (Unknown_version _) -> Location.raise_errorf ~loc:(Location.in_file fn) "File is a binary ast for an unknown version of OCaml" | Error (Not_a_binary_ast prefix_read_from_file) -> (* To test if a file is an AST file, we have to read the first few bytes of the file. If it is not, we have to parse these bytes and the rest of the file as source code. The compiler just does [seek_on 0] in this case, however this doesn't work when the input is a pipe. What we do instead is create a lexing buffer from the input channel and pre-fill it with what we read to do the test. *) let lexbuf = Lexing.from_channel ic in let len = String.length prefix_read_from_file in Bytes.From_string.blit ~src:prefix_read_from_file ~src_pos:0 ~dst:lexbuf.lex_buffer ~dst_pos:0 ~len; lexbuf.lex_buffer_len <- len; lexbuf.lex_curr_p <- { pos_fname = input_name ; pos_lnum = 1 ; pos_bol = 0 ; pos_cnum = 0 }; Lexer.skip_hash_bang lexbuf; match kind with | Intf -> input_name, Intf (Parse.interface lexbuf) | Impl -> input_name, Impl (Parse.implementation lexbuf) ;; let load_source_file fn = let s = In_channel.read_all fn in if string_contains_binary_ast s then Location.raise_errorf ~loc:(Location.in_file fn) "ppxlib_driver: cannot use -reconcile with binary AST files"; s ;; type output_mode = | Pretty_print | Dump_ast | Dparsetree | Reconcile of Reconcile.mode | Null (*$*) let extract_cookies_str st = match st with | { pstr_desc = Pstr_attribute {attr_name={txt = "ocaml.ppx.context"; _}; _}; _ } as prefix :: st -> let prefix = Ppxlib_ast.Selected_ast.to_ocaml Structure [prefix] in assert (List.is_empty (Ocaml_common.Ast_mapper.drop_ppx_context_str ~restore:true prefix)); st | _ -> st let add_cookies_str st = let prefix = Ocaml_common.Ast_mapper.add_ppx_context_str ~tool_name:"ppxlib_driver" [] |> Ppxlib_ast.Selected_ast.of_ocaml Structure in prefix @ st (*$ str_to_sig _last_text_block *) let extract_cookies_sig sg = match sg with | { psig_desc = Psig_attribute {attr_name={txt = "ocaml.ppx.context"; _}; _}; _ } as prefix :: sg -> let prefix = Ppxlib_ast.Selected_ast.to_ocaml Signature [prefix] in assert (List.is_empty (Ocaml_common.Ast_mapper.drop_ppx_context_sig ~restore:true prefix)); sg | _ -> sg let add_cookies_sig sg = let prefix = Ocaml_common.Ast_mapper.add_ppx_context_sig ~tool_name:"ppxlib_driver" [] |> Ppxlib_ast.Selected_ast.of_ocaml Signature in prefix @ sg (*$*) let extract_cookies (ast : Intf_or_impl.t) : Intf_or_impl.t = match ast with | Intf x -> Intf (extract_cookies_sig x) | Impl x -> Impl (extract_cookies_str x) let add_cookies (ast : Intf_or_impl.t) : Intf_or_impl.t = match ast with | Intf x -> Intf (add_cookies_sig x) | Impl x -> Impl (add_cookies_str x) let corrections = ref [] let add_to_list r x = r := x :: !r let register_correction ~loc ~repl = add_to_list corrections (Reconcile.Replacement.make_text () ~start:loc.loc_start ~stop:loc.loc_end ~repl) let process_file_hooks = ref [] let register_process_file_hook f = add_to_list process_file_hooks f module File_property = struct type 'a t = { name : string ; mutable data : 'a option ; sexp_of_t : 'a -> Sexp.t } type packed = T : _ t -> packed let all = ref [] let register t = add_to_list all (T t) let reset_all () = List.iter !all ~f:(fun (T t) -> t.data <- None) let dump_and_reset_all () = List.filter_map (List.rev !all) ~f:(fun (T t) -> match t.data with | None -> None | Some v -> t.data <- None; Some (t.name, t.sexp_of_t v)) end module Create_file_property(Name : sig val name : string end)(T : Sexpable.S) = struct let t : _ File_property.t = { name = Name.name ; data = None ; sexp_of_t = T.sexp_of_t } let () = File_property.register t let set x = t.data <- Some x end let process_file (kind : Kind.t) fn ~input_name ~relocate ~output_mode ~embed_errors ~output = File_property.reset_all (); List.iter (List.rev !process_file_hooks) ~f:(fun f -> f ()); corrections := []; let replacements = ref [] in let hook : Context_free.Generated_code_hook.t = match output_mode with | Reconcile (Using_line_directives | Delimiting_generated_blocks) -> { f = fun context (loc : Location.t) generated -> add_to_list replacements (Reconcile.Replacement.make () ~context:(Extension context) ~start:loc.loc_start ~stop:loc.loc_end ~repl:generated) } | _ -> Context_free.Generated_code_hook.nop in let expect_mismatch_handler : Context_free.Expect_mismatch_handler.t = { f = fun context (loc : Location.t) generated -> add_to_list corrections (Reconcile.Replacement.make () ~context:(Floating_attribute context) ~start:loc.loc_start ~stop:loc.loc_end ~repl:(Many generated)) } in let input_name, ast = try let input_name, ast = with_preprocessed_input fn ~f:(load_input kind fn input_name ~relocate) in let ast = extract_cookies ast in let config = config ~hook ~expect_mismatch_handler in match ast with | Intf x -> input_name, Some_intf_or_impl.Intf (map_signature_gen x ~config) | Impl x -> input_name, Some_intf_or_impl.Impl (map_structure_gen x ~config) with exn when embed_errors -> match Location.Error.of_exn exn with | None -> raise exn | Some error -> let loc = Location.none in let ext = Location.Error.to_extension error in let open Ast_builder.Default in let ast = match kind with | Intf -> Some_intf_or_impl.Intf (Sig ((module Ppxlib_ast.Selected_ast), [ psig_extension ~loc ext [] ])) | Impl -> Some_intf_or_impl.Impl (Str ((module Ppxlib_ast.Selected_ast), [ pstr_extension ~loc ext [] ])) in input_name, ast in Option.iter !output_metadata_filename ~f:(fun fn -> let metadata = File_property.dump_and_reset_all () in Out_channel.write_all fn ~data:( List.map metadata ~f:(fun (s, sexp) -> Sexp.to_string_hum (Sexp.List [Atom s; sexp]) ^ "\n") |> String.concat ~sep:"")); let input_contents = lazy (load_source_file fn) in let corrected = fn ^ !corrected_suffix in let mismatches_found = match !corrections with | [] -> if Caml.Sys.file_exists corrected then Caml.Sys.remove corrected; false | corrections -> Reconcile.reconcile corrections ~contents:(Lazy.force input_contents) ~output:(Some corrected) ~input_filename:fn ~input_name ~target:Corrected ?styler:!styler ~kind; true in (match output_mode with | Null -> () | Pretty_print -> with_output output ~binary:false ~f:(fun oc -> let ppf = Caml.Format.formatter_of_out_channel oc in let ast = Intf_or_impl.of_some_intf_or_impl ast in (match ast with | Intf ast -> Pprintast.signature ppf ast | Impl ast -> Pprintast.structure ppf ast); let null_ast = match ast with | Intf [] | Impl [] -> true | _ -> false in if not null_ast then Caml.Format.pp_print_newline ppf ()) | Dump_ast -> with_output output ~binary:true ~f:(fun oc -> let ast = Some_intf_or_impl.to_ast_io ast ~add_ppx_context:true in Migrate_parsetree.Ast_io.to_channel oc input_name ast) | Dparsetree -> with_output output ~binary:false ~f:(fun oc -> let ppf = Caml.Format.formatter_of_out_channel oc in let ast = Intf_or_impl.of_some_intf_or_impl ast in let ast = add_cookies ast in (match ast with | Intf ast -> Sexp.pp_hum ppf (Ast_traverse.sexp_of#signature ast) | Impl ast -> Sexp.pp_hum ppf (Ast_traverse.sexp_of#structure ast)); Caml.Format.pp_print_newline ppf ()) | Reconcile mode -> Reconcile.reconcile !replacements ~contents:(Lazy.force input_contents) ~output ~input_filename:fn ~input_name ~target:(Output mode) ?styler:!styler ~kind); if mismatches_found && (match !diff_command with | Some "-" -> false | _ -> true) then begin Ppxlib_print_diff.print () ~file1:fn ~file2:corrected ~use_color:!use_color ?diff_command:!diff_command; Caml.exit 1 end ;; let output_mode = ref Pretty_print let output = ref None let kind = ref None let input = ref None let embed_errors = ref false let set_input fn = match !input with | None -> input := Some fn | Some _ -> raise (Arg.Bad "too many input files") let set_kind k = match !kind with | Some k' when not (Kind.equal k k') -> raise (Arg.Bad "must specify at most one of -impl or -intf") | _ -> kind := Some k ;; let set_output_mode mode = match !output_mode, mode with | Pretty_print, _ -> output_mode := mode | _, Pretty_print -> assert false | Dump_ast , Dump_ast | Dparsetree , Dparsetree -> () | Reconcile a, Reconcile b when Poly.equal a b -> () | x, y -> let arg_of_output_mode = function | Pretty_print -> assert false | Dump_ast -> "-dump-ast" | Dparsetree -> "-dparsetree" | Reconcile Using_line_directives -> "-reconcile" | Reconcile Delimiting_generated_blocks -> "-reconcile-with-comments" | Null -> "-null" in raise (Arg.Bad (Printf.sprintf "%s and %s are incompatible" (arg_of_output_mode x) (arg_of_output_mode y))) ;; let print_transformations () = List.iter !Transform.all ~f:(fun (ct : Transform.t) -> printf "%s\n" ct.name); ;; let parse_apply_list s = let names = if String.equal s "" then [] else String.split s ~on:',' in List.iter names ~f:(fun name -> if not (List.exists !Transform.all ~f:(fun (ct : Transform.t) -> Transform.has_name ct name)) then raise (Caml.Arg.Bad (Printf.sprintf "code transformation '%s' does not exist" name))); names type mask = { mutable apply : string list option ; mutable dont_apply : string list option } let mask = { apply = None ; dont_apply = None } let handle_apply s = if Option.is_some mask.apply then raise (Arg.Bad "-apply called too many times"); (* This is not strictly necessary but it's more intuitive *) if Option.is_some mask.dont_apply then raise (Arg.Bad "-apply must be called before -dont-apply"); mask.apply <- Some (parse_apply_list s) let handle_dont_apply s = if Option.is_some mask.dont_apply then raise (Arg.Bad "-apply called too many times"); mask.dont_apply <- Some (parse_apply_list s) let interpret_mask () = if Option.is_some mask.apply || Option.is_some mask.dont_apply then begin let selected_transform_name ct = let is_candidate = match mask.apply with | None -> true | Some names -> List.exists names ~f:(Transform.has_name ct) in let is_selected = match mask.dont_apply with | None -> is_candidate | Some names -> is_candidate && not (List.exists names ~f:(Transform.has_name ct)) in if is_selected then Some ct.name else None in apply_list := Some (List.filter_map !Transform.all ~f:selected_transform_name) end let shared_args = [ "-loc-filename", Arg.String (fun s -> loc_fname := Some s), " File name to use in locations" ; "-reserve-namespace", Arg.String Name.Reserved_namespaces.reserve, " Mark the given namespace as reserved" ; "-no-check", Arg.Clear perform_checks, " Disable checks (unsafe)" ; "-check", Arg.Set perform_checks, " Enable checks" ; "-no-check-on-extensions", Arg.Clear perform_checks_on_extensions, " Disable checks on extension point only" ; "-check-on-extensions", Arg.Set perform_checks_on_extensions, " Enable checks on extension point only" ; "-no-locations-check", Arg.Clear perform_locations_check, " Disable locations check only" ; "-locations-check", Arg.Set perform_locations_check, " Enable locations check only" ; "-apply", Arg.String handle_apply, " Apply these transformations in order (comma-separated list)" ; "-dont-apply", Arg.String handle_dont_apply, " Exclude these transformations" ; "-no-merge", Arg.Set no_merge, " Do not merge context free transformations (better for debugging rewriters)" ] let () = List.iter shared_args ~f:(fun (key, spec, doc) -> add_arg key spec ~doc) let set_cookie s = match String.lsplit2 s ~on:'=' with | None -> raise (Arg.Bad "invalid cookie, must be of the form \"=\"") | Some (name, value) -> let lexbuf = Lexing.from_string value in lexbuf.Lexing.lex_curr_p <- { Lexing. pos_fname = "" ; pos_lnum = 1 ; pos_bol = 0 ; pos_cnum = 0 }; let expr = Parse.expression lexbuf in Migrate_parsetree.Driver.set_global_cookie name (module Ppxlib_ast.Selected_ast) expr let as_pp () = set_output_mode Dump_ast; embed_errors := true let standalone_args = [ "-as-ppx", Arg.Unit (fun () -> raise (Arg.Bad "-as-ppx must be the first argument")), " Run as a -ppx rewriter (must be the first argument)" ; "--as-ppx", Arg.Unit (fun () -> raise (Arg.Bad "--as-ppx must be the first argument")), " Same as -as-ppx" ; "-as-pp", Arg.Unit as_pp, " Shorthand for: -dump-ast -embed-errors" ; "--as-pp", Arg.Unit as_pp, " Same as -as-pp" ; "-o", Arg.String (fun s -> output := Some s), " Output file (use '-' for stdout)" ; "-", Arg.Unit (fun () -> set_input "-"), " Read input from stdin" ; "-dump-ast", Arg.Unit (fun () -> set_output_mode Dump_ast), " Dump the marshaled ast to the output file instead of pretty-printing it" ; "--dump-ast", Arg.Unit (fun () -> set_output_mode Dump_ast), " Same as -dump-ast" ; "-dparsetree", Arg.Unit (fun () -> set_output_mode Dparsetree), " Print the parsetree (same as ocamlc -dparsetree)" ; "-embed-errors", Arg.Set embed_errors, " Embed errors in the output AST (default: true when -dump-ast, false otherwise)" ; "-null", Arg.Unit (fun () -> set_output_mode Null), " Produce no output, except for errors" ; "-impl", Arg.Unit (fun () -> set_kind Impl), " Treat the input as a .ml file" ; "--impl", Arg.Unit (fun () -> set_kind Impl), " Same as -impl" ; "-intf", Arg.Unit (fun () -> set_kind Intf), " Treat the input as a .mli file" ; "--intf", Arg.Unit (fun () -> set_kind Intf), " Same as -intf" ; "-debug-attribute-drop", Arg.Set debug_attribute_drop, " Debug attribute dropping" ; "-print-transformations", Arg.Set request_print_transformations, " Print linked-in code transformations, in the order they are applied" ; "-print-passes", Arg.Set request_print_passes, " Print the actual passes over the whole AST in the order they are applied" ; "-ite-check", Arg.Unit (fun () -> eprintf "Warning: the -ite-check flag is deprecated \ and has no effect.\n%!"; Extra_warnings.care_about_ite_branch := true), " (no effect -- kept for compatibility)" ; "-pp", Arg.String (fun s -> preprocessor := Some s), " Pipe sources through preprocessor (incompatible with -as-ppx)" ; "-reconcile", Arg.Unit (fun () -> set_output_mode (Reconcile Using_line_directives)), " (WIP) Pretty print the output using a mix of the input source \ and the generated code" ; "-reconcile-with-comments", Arg.Unit (fun () -> set_output_mode (Reconcile Delimiting_generated_blocks)), " (WIP) same as -reconcile but uses comments to enclose the generated code" ; "-no-color", Arg.Clear use_color, " Don't use colors when printing errors" ; "-diff-cmd", Arg.String (fun s -> diff_command := Some s), " Diff command when using code expectations (use - to disable diffing)" ; "-pretty", Arg.Set pretty, " Instruct code generators to improve the prettiness of the generated code" ; "-styler", Arg.String (fun s -> styler := Some s), " Code styler" ; "-cookie", Arg.String set_cookie, "NAME=EXPR Set the cookie NAME to EXPR" ; "--cookie", Arg.String set_cookie, " Same as -cookie" ; "-output-metadata", Arg.String (fun s -> output_metadata_filename := Some s), "FILE Where to store the output metadata" ; "-corrected-suffix", Arg.Set_string corrected_suffix, "SUFFIX Suffix to happend to corrected files" ] ;; let get_args ?(standalone_args=standalone_args) () = let args = standalone_args @ List.rev !args in let my_arg_names = List.rev_map args ~f:(fun (name, _, _) -> name) |> Set.of_list (module String) in let omp_args = (* Filter out arguments that we override *) List.filter (Migrate_parsetree.Driver.registered_args ()) ~f:(fun (name, _, _) -> not (Set.mem my_arg_names name)) in args @ omp_args ;; let standalone_main () = let usage = Printf.sprintf "%s [extra_args] []" exe_name in let args = get_args () in Migrate_parsetree.Driver.reset_args (); Arg.parse (Arg.align args) set_input usage; interpret_mask (); if !request_print_transformations then begin print_transformations (); Caml.exit 0; end; if !request_print_passes then begin print_passes (); Caml.exit 0; end; match !input with | None -> eprintf "%s: no input file given\n%!" exe_name; Caml.exit 2 | Some fn -> let kind = match !kind with | Some k -> k | None -> match Kind.of_filename fn with | Some k -> k | None -> eprintf "%s: don't know what to do with '%s', use -impl or -intf.\n" exe_name fn; Caml.exit 2 in let input_name, relocate = match !loc_fname with | None -> fn, false | Some fn -> fn, true in process_file kind fn ~input_name ~relocate ~output_mode:!output_mode ~output:!output ~embed_errors:!embed_errors ;; let standalone_run_as_ppx_rewriter () = let n = Array.length Caml.Sys.argv in let usage = Printf.sprintf "%s -as-ppx [extra_args] " exe_name in if n < 4 then begin eprintf "Usage: %s\n%!" usage; Caml.exit 2 end; let argv = Array.create ~len:(n - 3) "" in argv.(0) <- Caml.Sys.argv.(0); for i = 1 to (n - 4) do argv.(i) <- Caml.Sys.argv.(i + 1) done; let standalone_args = List.map standalone_args ~f:(fun (arg, spec, _doc) -> (arg, spec, " Unused with -as-ppx")) in let args = get_args ~standalone_args () in Migrate_parsetree.Driver.reset_args (); match Arg.parse_argv argv (Arg.align args) (fun _ -> raise (Arg.Bad "anonymous arguments not accepted")) usage with | exception Arg.Bad msg -> eprintf "%s" msg; Caml.exit 2 | exception Arg.Help msg -> eprintf "%s" msg; Caml.exit 0 | () -> interpret_mask (); Ocaml_common.Ast_mapper.apply ~source:Caml.Sys.argv.(n - 2) ~target:Caml.Sys.argv.(n - 1) mapper ;; let standalone () = Compiler_specifics.read_clflags_from_env (); try if Array.length Caml.Sys.argv >= 2 && match Caml.Sys.argv.(1) with | "-as-ppx" | "--as-ppx" -> true | _ -> false then standalone_run_as_ppx_rewriter () else standalone_main (); Caml.exit 0 with exn -> Location.report_exception Caml.Format.err_formatter exn; Caml.exit 1 ;; let pretty () = !pretty let () = Migrate_parsetree.Driver.register ~name:"ppxlib_driver" (* This doesn't take arguments registered by rewriters. It's not worth supporting them, since [--cookie] is a much better replacement for passing parameters to individual rewriters. *) ~args:shared_args (module Ppxlib_ast.Selected_ast) (fun config cookies -> let module A = Ppxlib_ast.Selected_ast.Ast.Ast_mapper in let structure _ st = real_map_structure config cookies st in let signature _ sg = real_map_signature config cookies sg in { A.default_mapper with structure; signature }) let enable_checks () = (* We do not enable the locations check here, we currently require that one to be specifically enabled. *) perform_checks := true; perform_checks_on_extensions := true let enable_location_check () = perform_locations_check := true let disable_location_check () = perform_locations_check := false ppxlib-0.12.0/src/driver.mli000066400000000000000000000167111360512673700156750ustar00rootroot00000000000000open Import (** Add one argument to the command line *) val add_arg : Caml.Arg.key -> Caml.Arg.spec -> doc:string -> unit (** Error reported by linters *) module Lint_error : sig type t val of_string : Location.t -> string -> t end module Cookies : sig type t (** [get cookies name pattern] look for a cookie named [name] and parse it using [pattern]. *) val get : t -> string -> (expression, 'a -> 'a, 'b) Ast_pattern.t -> 'b option (** [set cookies name expr] set cookie [name] to [expr]. *) val set : t -> string -> expression -> unit (** Register a callback that is called before a rewriting. The handler is expected to lookup some cookies and set some global variables. This API is a temporary hack to allow to migrate from [add_arg] to the use of cookie, until ppxlib has been upgraded to pass cookies through. *) val add_handler : (t -> unit) -> unit (** Shorthand for: [add_handler (fun t -> f (get t name pattern))] *) val add_simple_handler : string -> (expression, 'a -> 'a, 'b) Ast_pattern.t -> f:('b option -> unit) -> unit (** Register a callback that is called after a rewriting. The handler is expected to set some cookies from some global variables. *) val add_post_handler : (t -> unit) -> unit end (** [register_transformation name] registers a code transformation. [name] is a logical name for the transformation (such as [sexp_conv] or [bin_prot]). It is mostly used for debugging purposes. [rules] is a list of context independent rewriting rules, such as extension point expanders. This is what most code transformation should use. Rules from all registered transformations are all applied at the same time, before any other transformations. Moreover they are applied in a top-down manner, giving more control to extensions on how they interpret their payload. For instance: - some extensions capture a pretty-print of the payload in their expansion and using top-down ensures that the payload is as close as possible to the original code - some extensions process other extension in a special way inside their payload. For instance [%here] (from ppx_here) will normally expand to a record of type [Lexing.position]. However when used inside [%sexp] (from ppx_sexp_value) it will expand to the human-readable sexp representation of a source code position. [extensions] is a special cases of [rules] and is deprecated. It is only kept for backward compatibility. [enclose_impl] and [enclose_intf] produces a header and footer for implementation/interface files. They are a special case of [impl] and [intf]. The header is placed after any initial module-level attributes; the footer is placed after everything else. Both functions receive a location that denotes all of the items between header and footer, or [None] if the that list of items is empty. [impl] is an optional function that is applied on implementation files and [intf] is an optional function that is applied on interface files. These two functions are applied on the AST of the whole file. They should only be used when the other mechanism are not enough. For instance if the transformation expands extension points that depend on the context. If no rewriter is using [impl] and [intf], then the whole transformation is completely independent of the order in which the various rewriter are specified. Moreover the resulting driver will be faster as it will do only one pass (excluding safety checks) on the whole AST. [lint_impl] and [lint_intf] are applied to the unprocessed source. Errors they return will be reported to the user as preprocessor warnings. Rewritings are applied in the following order: - linters ([lint_impl], [lint_intf]) - preprocessing ([preprocess_impl], [preprocess_intf]) - context-independent rules ([rules], [extensions]) - whole-file transformations ([impl], [intf], [enclose_impl], [enclose_intf]) *) val register_transformation : ?extensions : Extension.t list (* deprecated, use ~rules instead *) -> ?rules : Context_free.Rule.t list -> ?enclose_impl : (Location.t option -> structure * structure) -> ?enclose_intf : (Location.t option -> signature * signature) -> ?impl : (structure -> structure) -> ?intf : (signature -> signature) -> ?lint_impl : (structure -> Lint_error.t list) -> ?lint_intf : (signature -> Lint_error.t list) -> ?preprocess_impl : (structure -> structure) -> ?preprocess_intf : (signature -> signature) -> ?aliases : string list -> string -> unit (** Same as [register_transformation] except that it uses the same AST as the current ocaml compiler. This is not the intended way of using driver. This is only for ppx rewriters that are not written using ppxlib but want to export a driver compatible library. *) val register_transformation_using_ocaml_current_ast : ?impl : (Migrate_parsetree.OCaml_current.Ast.Parsetree.structure -> Migrate_parsetree.OCaml_current.Ast.Parsetree.structure) -> ?intf : (Migrate_parsetree.OCaml_current.Ast.Parsetree.signature -> Migrate_parsetree.OCaml_current.Ast.Parsetree.signature) -> ?aliases : string list -> string -> unit (** Same as: {[ register_transformation ~name ~impl ~intf () ]} *) val register_code_transformation : name:string -> ?aliases:string list -> impl:(structure -> structure) -> intf:(signature -> signature) -> unit [@@deprecated "[since 2015-11] use register_transformation instead"] (** Rewriters might call this function to suggest a correction to the code source. When they do this, the driver will generate a [file.ml.ppx-corrected] file with the suggested replacement. The build system will then show the diff to the user who is free to accept the correction or not. *) val register_correction : loc:Location.t -> repl:string -> unit (** Hook called before processing a file *) val register_process_file_hook : (unit -> unit) -> unit (** Create a new file property. A file property represent a piece of information about a file that can be set during preprocessing. If the [-output-metadata FILE] command line option was passed to the driver, then it will output this information to the given file. This mechanism is used to pass information gathered while preprocessing the file to the build system. For instance, this is used by ppx_inline_test to tell whether a file contains tests or not. In the future we could also use this to directly compute the dependencies and pass them here, to avoid calling ocamldep separately. *) module Create_file_property(Name : sig val name : string end)(T : Sexpable.S) : sig val set : T.t -> unit end (** Suitable for -pp and also usable as a standalone command line tool. If the first command line argument is [-as-ppx] then it will run as a ppx rewriter. *) val standalone : unit -> unit (** Suitable for -ppx. Used only for the public release. *) val run_as_ppx_rewriter : unit -> unit (** If [true], code transformations should avoid generating code that is not strictly necessary, such as extra type annotations. *) val pretty : unit -> bool (**/**) val map_structure : structure -> Migrate_parsetree.Driver.some_structure val enable_checks : unit -> unit val enable_location_check : unit -> unit val disable_location_check : unit -> unit ppxlib-0.12.0/src/dune000066400000000000000000000021451360512673700145510ustar00rootroot00000000000000(library (name ppxlib) (public_name ppxlib) (libraries ocaml-compiler-libs.common compiler-libs.common ocaml-compiler-libs.shadow ocaml-migrate-parsetree ppxlib_ast base stdio ppxlib_print_diff ppx_derivers ppxlib_traverse_builtins) (flags (:standard -open Ocaml_shadow -safe-string)) (ppx.driver (main Ppxlib.Driver.standalone) (replaces ocaml-migrate-parsetree) (flags (-corrected-suffix %{corrected-suffix} -diff-cmd - -dump-ast)) (lint_flags (-corrected-suffix %{corrected-suffix} -diff-cmd - -null )))) (cinaps (files *.ml *.mli) (libraries ppxlib_cinaps_helpers)) (rule (targets ast_pattern_generated.ml) (deps gen/gen_ast_pattern.exe) (action (run ./gen/gen_ast_pattern.exe %{lib:ppxlib.ast:ast.ml}))) (rule (targets ast_builder_generated.ml) (deps gen/gen_ast_builder.exe) (action (run ./gen/gen_ast_builder.exe %{lib:ppxlib.ast:ast.ml}))) ;; This is to make the code compatible with different versions of ;; OCaml (rule (targets compiler_specifics.ml) (deps gen-compiler_specifics) (action (run %{ocaml} %{deps} %{ocaml_version} %{targets}))) ppxlib-0.12.0/src/expansion_context.ml000066400000000000000000000026451360512673700200020ustar00rootroot00000000000000module Base = struct type t = { omp_config : Migrate_parsetree.Driver.config ; code_path : Code_path.t } let top_level ~omp_config ~file_path = let code_path = Code_path.top_level ~file_path in {omp_config; code_path} let enter_expr t = {t with code_path = Code_path.enter_expr t.code_path} let enter_module ~loc name t = {t with code_path = Code_path.enter_module ~loc name t.code_path} let enter_value ~loc name t = {t with code_path = Code_path.enter_value ~loc name t.code_path} end module Extension = struct type t = { extension_point_loc : Location.t ; base : Base.t } let make ~extension_point_loc ~base () = {extension_point_loc; base} let extension_point_loc t = t.extension_point_loc let code_path t = t.base.code_path let omp_config t = t.base.omp_config let with_loc_and_path f = fun ~ctxt -> f ~loc:ctxt.extension_point_loc ~path:(Code_path.to_string_path ctxt.base.code_path) end module Deriver = struct type t = { derived_item_loc : Location.t ; inline : bool ; base : Base.t } let make ~derived_item_loc ~inline ~base () = {derived_item_loc; base; inline} let derived_item_loc t = t.derived_item_loc let code_path t = t.base.code_path let omp_config t = t.base.omp_config let inline t = t.inline let with_loc_and_path f = fun ~ctxt -> f ~loc:ctxt.derived_item_loc ~path:(Code_path.to_string_path ctxt.base.code_path) end ppxlib-0.12.0/src/expansion_context.mli000066400000000000000000000043261360512673700201510ustar00rootroot00000000000000module Base : sig (** Type for the location independent parts of the expansion context *) type t (**/*) (** Undocumented section *) (** Build a new base context at the top level of the given file with the given ocaml-mirgate-parsetree configuration. *) val top_level : omp_config:Migrate_parsetree.Driver.config -> file_path:string -> t (** Proxy functions to update the wrapped code path. See code_path.mli for details. *) val enter_expr : t -> t val enter_module : loc:Location.t -> string -> t -> t val enter_value : loc:Location.t -> string -> t -> t end module Extension : sig (** Type of expansion contexts for extensions *) type t (** Return the location of the extension point being expanded *) val extension_point_loc : t -> Location.t (** Return the code path for the given context *) val code_path : t -> Code_path.t (** Return the ocaml-migrate-parsetree configuration for the given expansion context *) val omp_config : t -> Migrate_parsetree.Driver.config (** Wrap a [fun ~loc ~path] into a [fun ~ctxt] *) val with_loc_and_path : (loc:Location.t -> path:string -> 'a) -> (ctxt:t -> 'a) (**/**) (** Undocumented section *) (** Build a new expansion context with the given extension point location and base context *) val make : extension_point_loc:Location.t -> base:Base.t -> unit -> t end module Deriver : sig (** Type of expansion contexts for derivers *) type t (** Return the location of the item to which the deriver is being applied *) val derived_item_loc : t -> Location.t (** Return the code path for the given context *) val code_path : t -> Code_path.t (** Return the ocaml-migrate-parsetree configuration for the given expansion context *) val omp_config : t -> Migrate_parsetree.Driver.config (** Wrap a [fun ~loc ~path] into a [fun ~ctxt] *) val with_loc_and_path : (loc:Location.t -> path:string -> 'a) -> (ctxt:t -> 'a) (** Whether the derived code is going to be inlined in the source *) val inline : t -> bool (**/**) (** Undocumented section *) (** Build a new expansion context with the given item location and code path *) val make : derived_item_loc:Location.t -> inline:bool -> base:Base.t -> unit -> t end ppxlib-0.12.0/src/extension.ml000066400000000000000000000264561360512673700162540ustar00rootroot00000000000000open! Import open Common type (_, _) equality = Eq : ('a, 'a) equality | Ne : (_, _) equality module Context = struct type 'a t = | Class_expr : class_expr t | Class_field : class_field t | Class_type : class_type t | Class_type_field : class_type_field t | Core_type : core_type t | Expression : expression t | Module_expr : module_expr t | Module_type : module_type t | Pattern : pattern t | Signature_item : signature_item t | Structure_item : structure_item t type packed = T : _ t -> packed let class_expr = Class_expr let class_field = Class_field let class_type = Class_type let class_type_field = Class_type_field let core_type = Core_type let expression = Expression let module_expr = Module_expr let module_type = Module_type let pattern = Pattern let signature_item = Signature_item let structure_item = Structure_item let desc : type a. a t -> string = function | Class_expr -> "class expression" | Class_field -> "class field" | Class_type -> "class type" | Class_type_field -> "class type field" | Core_type -> "core type" | Expression -> "expression" | Module_expr -> "module expression" | Module_type -> "module type" | Pattern -> "pattern" | Signature_item -> "signature item" | Structure_item -> "structure item" let eq : type a b. a t -> b t -> (a, b) equality = fun a b -> match a, b with | Class_expr , Class_expr -> Eq | Class_field , Class_field -> Eq | Class_type , Class_type -> Eq | Class_type_field , Class_type_field -> Eq | Core_type , Core_type -> Eq | Expression , Expression -> Eq | Module_expr , Module_expr -> Eq | Module_type , Module_type -> Eq | Pattern , Pattern -> Eq | Signature_item , Signature_item -> Eq | Structure_item , Structure_item -> Eq | _ -> assert (Poly.(<>) (T a) (T b)); Ne let get_extension : type a. a t -> a -> (extension * attributes) option = fun t x -> match t, x with | Class_expr , {pcl_desc =Pcl_extension e; pcl_attributes =a;_} -> Some (e, a) | Class_field , {pcf_desc =Pcf_extension e; pcf_attributes =a;_} -> Some (e, a) | Class_type , {pcty_desc=Pcty_extension e; pcty_attributes=a;_} -> Some (e, a) | Class_type_field , {pctf_desc=Pctf_extension e; pctf_attributes=a;_} -> Some (e, a) | Core_type , {ptyp_desc=Ptyp_extension e; ptyp_attributes=a;_} -> Some (e, a) | Expression , {pexp_desc=Pexp_extension e; pexp_attributes=a;_} -> Some (e, a) | Module_expr , {pmod_desc=Pmod_extension e; pmod_attributes=a;_} -> Some (e, a) | Module_type , {pmty_desc=Pmty_extension e; pmty_attributes=a;_} -> Some (e, a) | Pattern , {ppat_desc=Ppat_extension e; ppat_attributes=a;_} -> Some (e, a) | Signature_item , {psig_desc=Psig_extension(e, a) ;_} -> Some (e, a) | Structure_item , {pstr_desc=Pstr_extension(e, a) ;_} -> Some (e, a) | _ -> None let merge_attributes : type a. a t -> a -> attributes -> a = fun t x attrs -> match t with | Class_expr -> { x with pcl_attributes = x.pcl_attributes @ attrs } | Class_field -> { x with pcf_attributes = x.pcf_attributes @ attrs } | Class_type -> { x with pcty_attributes = x.pcty_attributes @ attrs } | Class_type_field -> { x with pctf_attributes = x.pctf_attributes @ attrs } | Core_type -> { x with ptyp_attributes = x.ptyp_attributes @ attrs } | Expression -> { x with pexp_attributes = x.pexp_attributes @ attrs } | Module_expr -> { x with pmod_attributes = x.pmod_attributes @ attrs } | Module_type -> { x with pmty_attributes = x.pmty_attributes @ attrs } | Pattern -> { x with ppat_attributes = x.ppat_attributes @ attrs } | Signature_item -> assert_no_attributes attrs; x | Structure_item -> assert_no_attributes attrs; x end let registrar = Name.Registrar.create ~kind:"extension" ~current_file:__FILE__ ~string_of_context:(fun (Context.T ctx) -> Some (Context.desc ctx)) ;; module Make(Callback : sig type 'a t end) = struct type ('a, 'b) payload_parser = Payload_parser : ('a, 'b, 'c) Ast_pattern.t * 'b Callback.t -> ('a, 'c) payload_parser type ('context, 'payload) t = { name : Name.Pattern.t ; context : 'context Context.t ; payload : (payload, 'payload) payload_parser ; with_arg : bool } let declare ~with_arg name context pattern k = Name.Registrar.register ~kind:`Extension registrar (Context.T context) name; { name = Name.Pattern.make name ; context ; payload = Payload_parser (pattern, k) ; with_arg } ;; let find ts (ext : extension) = let { txt = name; loc } = fst ext in let name, arg = Name.split_path name in match List.filter ts ~f:(fun t -> Name.Pattern.matches t.name name) with | [] -> None | _ :: _ :: _ as l -> Location.raise_errorf ~loc "Multiple match for extensions: %s" (String.concat ~sep:", " (List.map l ~f:(fun t -> Name.Pattern.name t.name))) | [t] -> if not t.with_arg && Option.is_some arg then Location.raise_errorf ~loc "Extension %s doesn't expect a path argument" name; let arg = Option.map arg ~f:(fun s -> let shift = String.length name + 1 in let start = loc.loc_start in { txt = Longident.parse s ; loc = { loc with loc_start = { start with pos_cnum = start.pos_cnum + shift } } }) in Some (t, arg) ;; end module Expert = struct include Make(struct type 'a t = arg:Longident.t Loc.t option -> 'a end) let declare_with_path_arg name ctx patt f = declare ~with_arg:true name ctx patt f let declare name ctx patt f = declare ~with_arg:false name ctx patt (fun ~arg:_ -> f) let convert ts ~loc ext = match find ts ext with | None -> None | Some ({ payload = Payload_parser (pattern, f); _ }, arg) -> Some (Ast_pattern.parse pattern loc (snd ext) (f ~arg)) end module M = Make(struct type 'a t = ctxt:Expansion_context.Extension.t -> arg:Longident.t Loc.t option -> 'a end) type 'a expander_result = | Simple of 'a | Inline of 'a list module For_context = struct type 'a t = ('a, 'a expander_result) M.t let convert ts ~ctxt ext = let loc = Expansion_context.Extension.extension_point_loc ctxt in match M.find ts ext with | None -> None | Some ({ payload = M.Payload_parser (pattern, f); _ }, arg) -> match Ast_pattern.parse pattern loc (snd ext) (f ~ctxt ~arg) with | Simple x -> Some x | Inline _ -> failwith "Extension.convert" ;; let convert_inline ts ~ctxt ext = let loc = Expansion_context.Extension.extension_point_loc ctxt in match M.find ts ext with | None -> None | Some ({ payload = M.Payload_parser (pattern, f); _ }, arg) -> match Ast_pattern.parse pattern loc (snd ext) (f ~ctxt ~arg) with | Simple x -> Some [x] | Inline l -> Some l ;; end type t = T : _ For_context.t -> t let check_context_for_inline : type a. func:string -> a Context.t -> unit = fun ~func ctx -> match ctx with | Context.Class_field -> () | Context.Class_type_field -> () | Context.Signature_item -> () | Context.Structure_item -> () | context -> Printf.ksprintf invalid_arg "%s: %s can't be inlined" func (Context.desc context) ;; let rec filter_by_context : type a. a Context.t -> t list -> a For_context.t list = fun context expanders -> match expanders with | [] -> [] | T t :: rest -> match Context.eq context t.context with | Eq -> t :: filter_by_context context rest | Ne -> filter_by_context context rest ;; let fail ctx (name, _) = if not (Name.Whitelisted.is_whitelisted ~kind:`Extension name.txt || Name.ignore_checks name.txt) then Name.Registrar.raise_errorf registrar (Context.T ctx) "Extension `%s' was not translated" name ;; let check_unused = object inherit Ast_traverse.iter as super method! extension (name, _) = Location.raise_errorf ~loc:name.loc "extension not expected here, Ppxlib.Extension needs updating!" method! core_type_desc = function | Ptyp_extension ext -> fail Core_type ext | x -> super#core_type_desc x method! pattern_desc = function | Ppat_extension ext -> fail Pattern ext | x -> super#pattern_desc x method! expression_desc = function | Pexp_extension ext -> fail Expression ext | x -> super#expression_desc x method! class_type_desc = function | Pcty_extension ext -> fail Class_type ext | x -> super#class_type_desc x method! class_type_field_desc = function | Pctf_extension ext -> fail Class_type_field ext | x -> super#class_type_field_desc x method! class_expr_desc = function | Pcl_extension ext -> fail Class_expr ext | x -> super#class_expr_desc x method! class_field_desc = function | Pcf_extension ext -> fail Class_field ext | x -> super#class_field_desc x method! module_type_desc = function | Pmty_extension ext -> fail Module_type ext | x -> super#module_type_desc x method! signature_item_desc = function | Psig_extension (ext, _) -> fail Signature_item ext | x -> super#signature_item_desc x method! module_expr_desc = function | Pmod_extension ext -> fail Module_expr ext | x -> super#module_expr_desc x method! structure_item_desc = function | Pstr_extension (ext, _) -> fail Structure_item ext | x -> super#structure_item_desc x end module V3 = struct type nonrec t = t let declare name context pattern k = let pattern = Ast_pattern.map_result pattern ~f:(fun x -> Simple x) in T (M.declare ~with_arg:false name context pattern (fun ~ctxt ~arg:_ -> k ~ctxt)) let declare_inline name context pattern k = check_context_for_inline context ~func:"Extension.declare_inline"; let pattern = Ast_pattern.map_result pattern ~f:(fun x -> Inline x) in T (M.declare ~with_arg:false name context pattern (fun ~ctxt ~arg:_ -> k ~ctxt)) end let declare name context pattern f = V3.declare name context pattern (Expansion_context.Extension.with_loc_and_path f) let declare_inline name context pattern f = V3.declare_inline name context pattern (Expansion_context.Extension.with_loc_and_path f) let declare_with_path_arg name context pattern k = let k' = Expansion_context.Extension.with_loc_and_path k in let pattern = Ast_pattern.map_result pattern ~f:(fun x -> Simple x) in T (M.declare ~with_arg:true name context pattern k') ;; let declare_inline_with_path_arg name context pattern k = let k' = Expansion_context.Extension.with_loc_and_path k in check_context_for_inline context ~func:"Extension.declare_inline_with_path_arg"; let pattern = Ast_pattern.map_result pattern ~f:(fun x -> Inline x) in T (M.declare ~with_arg:true name context pattern k') ;; module V2 = struct type nonrec t = t let declare = declare let declare_inline = declare_inline end ppxlib-0.12.0/src/extension.mli000066400000000000000000000117631360512673700164200ustar00rootroot00000000000000open! Import type (_, _) equality = Eq : ('a, 'a) equality | Ne : (_, _) equality module Context : sig type 'a t = | Class_expr : class_expr t | Class_field : class_field t | Class_type : class_type t | Class_type_field : class_type_field t | Core_type : core_type t | Expression : expression t | Module_expr : module_expr t | Module_type : module_type t | Pattern : pattern t | Signature_item : signature_item t | Structure_item : structure_item t val class_expr : class_expr t val class_field : class_field t val class_type : class_type t val class_type_field : class_type_field t val core_type : core_type t val expression : expression t val module_expr : module_expr t val module_type : module_type t val pattern : pattern t val signature_item : signature_item t val structure_item : structure_item t val eq : 'a t -> 'b t -> ('a, 'b) equality val get_extension : 'a t -> 'a -> (extension * attributes) option val merge_attributes : 'a t -> 'a -> attributes -> 'a end type t (** Type of declared extensions. *) (** [declare name context pattern expander] declares the extension names [name] for [context]. [expander] is responsible for producing the code to replace the extension in the AST. It receives as argument: - [loc]: the location of the enclosing node. For instance for expression it is the [pexp_loc] field - [path]: the current module path *) val declare : string -> 'context Context.t -> (payload, 'a, 'context) Ast_pattern.t -> (loc:Location.t -> path:string -> 'a) -> t (** Same as [declare] except that the extension name takes an additional path argument. The path is the part of the name that start with a capitalized component. For instance in the following, the extension ["map"] would receive the path argument [Foo.Bar]: {[ let%map.Foo.Bar x = 1 in ... ]} *) val declare_with_path_arg : string -> 'context Context.t -> (payload, 'a, 'context) Ast_pattern.t -> (loc:Location.t -> path:string -> arg:Longident.t Asttypes.loc option -> 'a) -> t (** Inline the result of the expansion into its parent. Only works for these contexts: - [class_field] - [class_type_field] - [signature_item] - [structure_item] *) val declare_inline : string -> 'context Context.t -> (payload, 'a, 'context list) Ast_pattern.t -> (loc:Location.t -> path:string -> 'a) -> t val declare_inline_with_path_arg : string -> 'context Context.t -> (payload, 'a, 'context list) Ast_pattern.t -> (loc:Location.t -> path:string -> arg:Longident.t Asttypes.loc option -> 'a) -> t module For_context : sig (** This module is used to implement {!Context_free.V1.map_top_down} *) type 'a t val convert : 'a t list -> ctxt:Expansion_context.Extension.t -> extension -> 'a option val convert_inline : 'a t list -> ctxt:Expansion_context.Extension.t -> extension -> 'a list option end (** Given a context and a list of extension expander, returns all the ones that are for this context. *) val filter_by_context : 'a Context.t -> t list -> 'a For_context.t list module Expert : sig (** This module allows to declare extensions that do not produce a value of the context type. This is typically useful for extensions point that depends on more things from the context than the path and location. *) type ('context, 'payload) t (** Type of declared expert extensions. The ['context] type parameter describes where the extension is expected and the ['payload] one what its payload should contain. *) val declare : string -> 'context Context.t -> (payload, 'a, 'b) Ast_pattern.t -> 'a -> ('context, 'b) t val declare_with_path_arg : string -> 'context Context.t -> (payload, 'a, 'b) Ast_pattern.t -> (arg:Longident.t Loc.t option -> 'a) -> ('context, 'b) t val convert : (_, 'a) t list -> loc:Location.t -> extension -> 'a option end val check_unused : Ast_traverse.iter module V2 : sig type nonrec t = t val declare : string -> 'context Context.t -> (payload, 'a, 'context) Ast_pattern.t -> (loc:Location.t -> path:string -> 'a) -> t val declare_inline : string -> 'context Context.t -> (payload, 'a, 'context list) Ast_pattern.t -> (loc:Location.t -> path:string -> 'a) -> t end module V3 : sig type nonrec t = t val declare : string -> 'context Context.t -> (payload, 'a, 'context) Ast_pattern.t -> (ctxt:Expansion_context.Extension.t -> 'a) -> t val declare_inline : string -> 'context Context.t -> (payload, 'a, 'context list) Ast_pattern.t -> (ctxt:Expansion_context.Extension.t -> 'a) -> t end (**/**) val check_context_for_inline : func:string -> 'a Context.t -> unit ppxlib-0.12.0/src/file_path.ml000066400000000000000000000011201360512673700161500ustar00rootroot00000000000000open! Import let chop_prefix ~prefix x = if String.is_prefix ~prefix x then Some (String.drop_prefix x (String.length prefix)) else None ;; let get_default_path (loc : Location.t) = let fname = loc.loc_start.pos_fname in match chop_prefix ~prefix:"./" fname with | Some fname -> fname | None -> fname ;; let get_default_path_str : structure -> string = function | [] -> "" | { pstr_loc = loc; _ } :: _ -> get_default_path loc ;; let get_default_path_sig : signature -> string = function | [] -> "" | { psig_loc = loc; _ } :: _ -> get_default_path loc ;; ppxlib-0.12.0/src/file_path.mli000066400000000000000000000003151360512673700163260ustar00rootroot00000000000000open! Import (** Return the path used as root in a file *) val get_default_path : Location.t -> string val get_default_path_str : structure -> string val get_default_path_sig : signature -> string ppxlib-0.12.0/src/gen-compiler_specifics000066400000000000000000000010421360512673700202220ustar00rootroot00000000000000(* -*- tuareg -*- *) open Printf let () = let ver = Scanf.sscanf Sys.argv.(1) "%u.%u" (fun a b -> a, b) in let oc = open_out_bin Sys.argv.(2) in let pr fmt = fprintf oc (fmt ^^ "\n") in pr "module O = Ocaml_common"; if ver < (4, 08) then ( pr "let get_load_path () = !Ocaml_common.Config.load_path"; pr "let read_clflags_from_env () = ()" ) else ( pr "let get_load_path () = Ocaml_common.Load_path.get_paths ()"; pr "let read_clflags_from_env () = Ocaml_common.Compmisc.read_clflags_from_env ()" ); close_out oc ppxlib-0.12.0/src/gen/000077500000000000000000000000001360512673700144425ustar00rootroot00000000000000ppxlib-0.12.0/src/gen/dune000066400000000000000000000002761360512673700153250ustar00rootroot00000000000000(executables (names gen_ast_pattern gen_ast_builder) (flags (:standard -safe-string)) (libraries ppxlib_ast compiler-libs.common compiler-libs.bytecomp ppxlib_traverse_builtins)) ppxlib-0.12.0/src/gen/gen_ast_builder.ml000066400000000000000000000157541360512673700201360ustar00rootroot00000000000000open Import open Ast_helper open Printf let prefix_of_record lds = common_prefix (List.map lds ~f:(fun ld -> ld.pld_name.txt)) module Gen(Fixed_loc : sig val fixed_loc : bool end) = struct open Fixed_loc let gen_combinator_for_constructor ~wrapper:(wpath, wprefix, has_attrs, has_loc_stack) path ~prefix cd = match cd.pcd_args with | Pcstr_record _ -> (* TODO. *) failwith "Pcstr_record not supported" | Pcstr_tuple cd_args -> let args = List.mapi cd_args ~f:(fun i _ -> sprintf "x%d" i) in let exp = Exp.construct (Loc.mk (fqn_longident path cd.pcd_name.txt)) (match args with | [] -> None | [x] -> Some (evar x) | _ -> Some (Exp.tuple (List.map args ~f:evar))) in let body = let fields = [ ( Loc.mk (fqn_longident' wpath (wprefix ^ "loc")) , evar "loc" ) ; ( Loc.mk (fqn_longident' wpath (wprefix ^ "desc")) , exp ) ] in let fields = if has_attrs then ( Loc.mk (fqn_longident' wpath (wprefix ^ "attributes")) , M.expr "[]" ) :: fields else fields in let fields = if has_loc_stack then ( Loc.mk (fqn_longident' wpath (wprefix ^ "loc_stack")) , M.expr "[]" ) :: fields else fields in Exp.record fields None in let body = (* match args with | [] -> [%expr fun () -> [%e body]] | _ ->*) List.fold_right args ~init:body ~f:(fun arg acc -> M.expr "fun %a -> %a" A.patt (pvar arg) A.expr acc) in (* let body = if not has_attrs then body else [%expr fun ?(attrs=[]) -> [%e body]] in*) let body = if fixed_loc then body else M.expr "fun ~loc -> %a" A.expr body in M.stri "let %a = %a" A.patt (pvar (function_name_of_id ~prefix cd.pcd_name.txt)) A.expr body ;; let gen_combinator_for_record path ~prefix lds = let fields = List.map lds ~f:(fun ld -> fqn_longident path ld.pld_name.txt) in let funcs = List.map lds ~f:(fun ld -> map_keyword (without_prefix ~prefix ld.pld_name.txt)) in let body = Exp.record (List.map2 fields funcs ~f:(fun field func -> (Loc.mk field, if func = "attributes" then M.expr "[]" else evar func))) None in let body = let l = List.filter funcs ~f:(fun f -> f <> "loc" && f <> "attributes") in match l with | [x] -> Exp.fun_ Nolabel None (pvar x) body | _ -> List.fold_right l ~init:body ~f:(fun func acc -> Exp.fun_ (Labelled func) None (pvar func) acc ) in (* let body = if List.mem "attributes" ~set:funcs then [%expr fun ?(attrs=[]) -> [%e body]] else body in*) let body = if List.mem "loc" ~set:funcs && not fixed_loc then M.expr "fun ~loc -> %a" A.expr body else body in M.stri "let %a = %a" A.patt (pvar (function_name_of_path path)) A.expr body ;; let gen_td ?wrapper path td = if is_loc path then [] else match td.ptype_kind with | Ptype_variant cds -> begin match wrapper with | None -> [] | Some wrapper -> let prefix = common_prefix (List.map cds ~f:(fun cd -> cd.pcd_name.txt)) in List.map cds ~f:(fun cd -> gen_combinator_for_constructor ~wrapper path ~prefix cd) end | Ptype_record lds -> let prefix = prefix_of_record lds in [gen_combinator_for_record path ~prefix lds] | Ptype_abstract | Ptype_open -> [] ;; end let filter_labels ~prefix lds = List.filter lds ~f:(fun ld -> match without_prefix ~prefix ld.pld_name.txt with | "loc" | "loc_stack" | "attributes" -> false | _ -> true) ;; let is_abstract td = match td.ptype_kind with | Ptype_abstract -> true | _ -> false ;; let dump fn ~ext printer x = let oc = open_out (fn ^ ext) in let ppf = Format.formatter_of_out_channel oc in Format.fprintf ppf "%a@." printer x; close_out oc let generate filename = (* let fn = Misc.find_in_path_uncap !Config.load_path (unit ^ ".cmi") in*) let types = get_types ~filename in let types_with_wrapped = List.map types ~f:(fun (path, td) -> match td.ptype_kind with | Ptype_record lds -> let prefix = prefix_of_record lds in let lds' = filter_labels ~prefix lds in (match is_wrapper ~prefix lds' with | None -> (path, td, None) | Some p -> let has_attrs = List.exists lds ~f:(fun ld -> ld.pld_name.txt = prefix ^ "attributes") in let has_loc_stack = List.exists lds ~f:(fun ld -> ld.pld_name.txt = prefix ^ "loc_stack") in (path, td, Some (prefix, has_attrs, has_loc_stack, p.txt))) | _ -> (path, td, None)) in let wrapped = List.filter_map types_with_wrapped ~f:(fun (_, _, x) -> match x with | None -> None | Some (_, _, _, p) -> Some p) in let types = List.filter types_with_wrapped ~f:(fun (path, _, _) -> not (List.mem path ~set:wrapped)) |> List.map ~f:(fun (path, td, wrapped) -> match wrapped with | None -> (path, td, None) | Some (prefix, has_attrs, has_loc_stack, p) -> (path, td, Some (prefix, has_attrs, has_loc_stack, p, List.assoc p types))) in (* let all_types = List.map fst types in*) let types = List.sort types ~cmp:(fun (a, _, _) (b, _, _) -> compare a b) in let items fixed_loc = let module G = Gen(struct let fixed_loc = fixed_loc end) in List.map types ~f:(fun (path, td, wrapped) -> if is_abstract td then [] else match wrapped with | None -> G.gen_td path td | Some (prefix, has_attrs, has_loc_stack, path', td') -> G.gen_td ~wrapper:(path, prefix, has_attrs, has_loc_stack) path' td' ) |> List.flatten in let st = [ Str.open_ (Opn.mk (Mod.ident (Loc.lident "Import"))) ; Str.module_ (Mb.mk (Loc.mk "M") (Mod.structure (items false))) ; Str.module_ (Mb.mk (Loc.mk "Make") (Mod.functor_ (Loc.mk "Loc") (Some (Mty.signature [ Sig.value (Val.mk (Loc.mk "loc") (M.ctyp "Location.t")) ])) (Mod.structure (M.stri "let loc = Loc.loc" :: items true)))) ] in dump "ast_builder_generated" Pprintast.structure st ~ext:".ml" let args = [ ] let usage = Printf.sprintf "%s [options] <.ml files>\n" Sys.argv.(0) let () = let fns = ref [] in Arg.parse (Arg.align args) (fun fn -> fns := fn :: !fns) usage; try List.iter (List.rev !fns) ~f:generate with exn -> Errors.report_error Format.err_formatter exn; exit 2 ppxlib-0.12.0/src/gen/gen_ast_builder.mli000066400000000000000000000000141360512673700202660ustar00rootroot00000000000000(* empty *) ppxlib-0.12.0/src/gen/gen_ast_pattern.ml000066400000000000000000000203541360512673700201550ustar00rootroot00000000000000open Import open Ast_helper open Printf let apply_parsers funcs args types = List.fold_right2 (List.combine funcs args) types ~init:(M.expr "k", false) ~f:(fun (func, arg) typ (acc, needs_loc) -> match typ.ptyp_desc with | Ptyp_constr (path, _) when is_loc path.txt -> M.expr "let k = %a ctx %a.loc %a.txt k in %a" A.expr (evar func) A.expr arg A.expr arg A.expr acc, needs_loc | _ -> M.expr "let k = %a ctx loc %a k in %a" A.expr (evar func) A.expr arg A.expr acc, true) ;; let assert_no_attributes ~path ~prefix = M.expr "Common.assert_no_attributes x.%a" A.id (fqn_longident' path (prefix ^ "attributes")) let gen_combinator_for_constructor ?wrapper path ~prefix cd = match cd.pcd_args with | Pcstr_record _ -> failwith "Pcstr_record not supported" | Pcstr_tuple cd_args -> let args = List.mapi cd_args ~f:(fun i _ -> sprintf "x%d" i) in let funcs = List.mapi cd_args ~f:(fun i _ -> sprintf "f%d" i) in let pat = Pat.construct (Loc.mk (fqn_longident path cd.pcd_name.txt)) (match args with | [] -> None | [x] -> Some (pvar x) | _ -> Some (Pat.tuple (List.map args ~f:pvar))) in let exp, _ = apply_parsers funcs (List.map args ~f:evar) cd_args in let expected = without_prefix ~prefix cd.pcd_name.txt in let body = M.expr {|match x with | %a -> ctx.matched <- ctx.matched + 1; %a | _ -> fail loc %S|} A.patt pat A.expr exp expected in let body = match wrapper with | None -> body | Some (path, prefix, has_attrs) -> let body = M.expr {|let loc = x.%a in let x = x.%a in %a|} A.id (fqn_longident' path (prefix ^ "loc")) A.id (fqn_longident' path (prefix ^ "desc")) A.expr body in if has_attrs then Exp.sequence (assert_no_attributes ~path ~prefix) body else body in let body = let loc = match wrapper with | None -> M.patt "loc" | Some _ -> M.patt "_loc" in M.expr "T (fun ctx %a x k -> %a)" A.patt loc A.expr body in let body = List.fold_right funcs ~init:body ~f:(fun func acc -> M.expr "fun (T %a) -> %a" A.patt (pvar func) A.expr acc) in M.stri "let %a = %a" A.patt (pvar (function_name_of_id ~prefix cd.pcd_name.txt)) A.expr body ;; let gen_combinator_for_record path ~prefix ~has_attrs lds = let fields = List.map lds ~f:(fun ld -> fqn_longident path ld.pld_name.txt) in let funcs = List.map lds ~f:(fun ld -> map_keyword (without_prefix ~prefix ld.pld_name.txt)) in let body, needs_loc = apply_parsers funcs (List.map fields ~f:(fun field -> Exp.field (evar "x") (Loc.mk field))) (List.map lds ~f:(fun ld -> ld.pld_type)) in let body = if has_attrs then Exp.sequence (assert_no_attributes ~path ~prefix) body else body in let body = M.expr "T (fun ctx %s x k -> %a)" (if needs_loc then "loc" else "_loc") A.expr body in let body = List.fold_right funcs ~init:body ~f:(fun func acc -> Exp.fun_ (Labelled func) None (M.patt "T %a" A.patt (pvar func)) acc) in M.stri "let %a = %a" A.patt (pvar (function_name_of_path path)) A.expr body ;; let prefix_of_record lds = common_prefix (List.map lds ~f:(fun ld -> ld.pld_name.txt)) let filter_labels ~prefix lds = List.filter lds ~f:(fun ld -> match without_prefix ~prefix ld.pld_name.txt with | "loc" | "loc_stack" | "attributes" -> false | _ -> true) ;; let has_ld ~prefix lds label = List.exists lds ~f:(fun ld -> ld.pld_name.txt = prefix ^ label) ;; let attributes_parser ~prefix ~name ~has_loc = let field s = Lident (prefix ^ s) in let body = M.expr {|let k = f1 ctx loc x.%a k in let x = { x with %a = [] } in let k = f2 ctx loc x k in k|} A.id (field "attributes") A.id (field "attributes") in let body = if has_loc then M.expr "let loc = x.%a in %a" A.id (field "loc") A.expr body else body in let loc_patt = if has_loc then M.patt "_loc" else M.patt "loc" in M.stri "let %a (T f1) (T f2) = T (fun ctx %a x k -> %a)" A.patt (pvar name) A.patt loc_patt A.expr body let gen_td ?wrapper path td = if is_loc path then [] else match td.ptype_kind with | Ptype_variant cds -> begin let prefix = common_prefix (List.map cds ~f:(fun cd -> cd.pcd_name.txt)) in let items = List.map cds ~f:(fun cd -> gen_combinator_for_constructor ?wrapper path ~prefix cd) in match wrapper with | Some (_, prefix, has_attrs) -> let field s = Exp.field (evar "x") (Loc.lident @@ prefix ^ s) in let items = if has_attrs then attributes_parser ~has_loc:true ~prefix ~name:(prefix ^ "attributes") :: items else items in M.stri {|let %a = fun (T f1) (T f2) -> T (fun ctx _loc x k -> let loc = %a in let k = f1 ctx loc loc k in let k = f2 ctx loc x k in k )|} A.patt (pvar @@ prefix ^ "loc") A.expr (field "loc") :: items | _ -> items end | Ptype_record lds -> let prefix = prefix_of_record lds in let has_attrs = has_ld ~prefix lds "attributes" in let has_loc = has_ld ~prefix lds "loc" in let lds = filter_labels ~prefix lds in let items = [gen_combinator_for_record path ~prefix ~has_attrs lds] in if has_attrs then attributes_parser ~has_loc ~prefix ~name:(function_name_of_path path ^ "_attributes") :: items else items | Ptype_abstract | Ptype_open -> [] ;; let is_abstract td = match td.ptype_kind with | Ptype_abstract -> true | _ -> false ;; let dump fn ~ext printer x = let oc = open_out (fn ^ ext) in let ppf = Format.formatter_of_out_channel oc in Format.fprintf ppf "%a@." printer x; close_out oc let generate filename = let types = get_types ~filename in let types_with_wrapped = List.map types ~f:(fun (path, td) -> match td.ptype_kind with | Ptype_record lds -> let prefix = prefix_of_record lds in let lds' = filter_labels ~prefix lds in (match is_wrapper ~prefix lds' with | None -> (path, td, None) | Some p -> let has_attrs = has_ld ~prefix lds "attributes" in (path, td, Some (prefix, has_attrs, p.txt))) | _ -> (path, td, None)) in let wrapped = List.filter_map types_with_wrapped ~f:(fun (_, _, x) -> match x with | None -> None | Some (_, _, p) -> Some p) in let types = List.filter types_with_wrapped ~f:(fun (path, _, _) -> not (List.mem path ~set:wrapped)) |> List.map ~f:(fun (path, td, wrapped) -> match wrapped with | None -> (path, td, None) | Some (prefix, has_attrs, p) -> (path, td, Some (prefix, has_attrs, p, List.assoc p types))) in (* let all_types = List.map fst types in*) let types = List.sort types ~cmp:(fun (a, _, _) (b, _, _) -> compare a b) in let items = List.map types ~f:(fun (path, td, wrapped) -> if is_abstract td then [] else match wrapped with | None -> gen_td path td | Some (prefix, has_attrs, path', td') -> gen_td ~wrapper:(path, prefix, has_attrs) path' td' ) |> List.flatten in let st = Str.open_ (Opn.mk (Mod.ident (Loc.lident "Import"))) :: Str.open_ (Opn.mk (Mod.ident (Loc.lident "Ast_pattern0"))) :: items in dump "ast_pattern_generated" Pprintast.structure st ~ext:".ml" let args = [ ] let usage = Printf.sprintf "%s [options] <.ml files>\n" Sys.argv.(0) let () = let fns = ref [] in Arg.parse (Arg.align args) (fun fn -> fns := fn :: !fns) usage; try List.iter (List.rev !fns) ~f:generate with exn -> Errors.report_error Format.err_formatter exn; exit 2 ppxlib-0.12.0/src/gen/gen_ast_pattern.mli000066400000000000000000000000141360512673700203150ustar00rootroot00000000000000(* empty *) ppxlib-0.12.0/src/gen/import.ml000066400000000000000000000101731360512673700163100ustar00rootroot00000000000000include Ppxlib_ast include Ast open Ast_helper let loc = (* This is fine, because the location info is thrown away when the generated code written out to the .ml file *) Location.none let lident x = Longident.Lident x module Loc = struct let mk x = { Location.loc; txt = x } let lident x = mk (Longident.parse x) end module List = struct include ListLabels let rec filter_map l ~f = match l with | [] -> [] | x :: l -> match f x with | None -> filter_map l ~f | Some x -> x :: filter_map l ~f end module String = struct include StringLabels (* in OCaml 4.04, StringLabels doesn't define lowercase_ascii, so we need to explicitly redefine it here as long as we support 4.04. *) let lowercase_ascii = String.lowercase_ascii end module Array = ArrayLabels let evar v = Exp.ident (Loc.lident v) let pvar v = Pat.var (Loc.mk v) let common_prefix l = match l with | [] -> "" | x :: l -> match String.index x '_' with | i -> let plen = i + 1 in let prefix = String.sub x ~pos:0 ~len:plen in let has_prefix s = String.length s >= plen && String.sub s ~pos:0 ~len:plen = prefix in if List.for_all l ~f:has_prefix then prefix else "" | exception _ -> "" ;; let map_keyword = function | "open" | "private" | "downto" | "to" | "mutable" | "rec" | "nonrec" | "virtual" | "type" | "mod" | "begin" | "end" as s -> s ^ "_" | s -> s ;; let function_name_of_path path = match path with | Lident id -> id | _ -> assert false ;; let without_prefix ~prefix s = let plen = String.length prefix in String.sub s ~pos:plen ~len:(String.length s - plen) ;; let function_name_of_id ?(prefix="") id = let s = without_prefix ~prefix id in (* let prefix = if prefix <> "" && (prefix.[0] = 'p' || prefix.[0] = 'P') then String.sub prefix ~pos:1 ~len:(String.length prefix - 1) else prefix in*) match prefix ^ s with | "::" -> "cons" | "[]" -> "nil" | "true" -> "true_" | "false" -> "false_" | s -> String.lowercase_ascii s |> map_keyword ;; let fqn_longident' path s : Longident.t = match path with | Lident _ -> Lident s | Ldot (p, _) -> Ldot (p, s) | Lapply _ -> assert false ;; let fqn_longident path id : Longident.t = fqn_longident' path id let is_loc = function | Lident "loc" -> true | _ -> false ;; let get_types ~filename = (* Expand "longident_loc" into "longident loc" as it is preferable for what we do here. *) let map = object inherit Ast.map as super inherit Ppxlib_traverse_builtins.map method! core_type_desc = function | Ptyp_constr ({ txt = Lident "longident_loc"; loc }, []) -> Ptyp_constr ({ txt = Lident "loc"; loc}, [Typ.constr ~loc { loc; txt = Lident "longident" } []]) | ty -> super#core_type_desc ty end in let ic = open_in_bin filename in let lb = Lexing.from_channel ic in let st = Parse.implementation lb in close_in ic; List.map st ~f:(function | { pstr_desc = Pstr_type (_, tds); _} -> tds | _ -> []) |> List.concat |> List.map ~f:map#type_declaration |> List.map ~f:(fun td -> (Lident td.ptype_name.txt, td)) ;; let is_wrapper ~prefix lds = match lds with | [ { pld_name = { txt = s; _ } ; pld_type = { ptyp_desc = Ptyp_constr (p, _); _ }; _ } ] when s = prefix ^ "desc" -> Some p | _ -> None ;; (* Small metaquotation system *) module M = struct let parse f fmt = Format.kasprintf (fun s -> f (Lexing.from_string s)) fmt let expr fmt = parse Parse.expression fmt let patt fmt = parse Parse.pattern fmt let ctyp fmt = parse Parse.core_type fmt let str fmt = parse Parse.implementation fmt let stri fmt = Format.kasprintf (fun s -> match Parse.implementation (Lexing.from_string s) with | [x] -> x | _ -> assert false) fmt end (* Antiquotations *) module A = struct let expr = Pprintast.expression let patt = Pprintast.pattern let ctyp = Pprintast.core_type let str = Pprintast.structure let id ppf x = Format.pp_print_string ppf (Longident.flatten x |> String.concat ~sep:".") end ppxlib-0.12.0/src/ignore_unused_warning.ml000066400000000000000000000022111360512673700206120ustar00rootroot00000000000000open Import open Ast_builder.Default let underscore_binding exp = let loc = exp.pexp_loc in value_binding ~loc ~pat:(ppat_any ~loc) ~expr:exp let vars_of = object inherit [Longident.t Located.t list] Ast_traverse.fold as super method! pattern patt acc = match patt.ppat_desc with | Ppat_var v -> Located.map (fun var -> Longident.Lident var) v :: acc | _ -> super#pattern patt acc end (* For every [let x = ...] structure item, add a [let _ = x] *) let add_dummy_user_for_values = object inherit Ast_traverse.map as super method! structure st = let rec loop st acc = match st with | [] -> List.rev acc | { pstr_desc = Pstr_value (_, vbs); pstr_loc = loc } as item :: rest -> let vars = List.fold_left vbs ~init:[] ~f:(fun acc vb -> vars_of#pattern vb.pvb_pat acc) in let ign = pstr_value_list ~loc Nonrecursive (List.rev_map vars ~f:(fun v -> underscore_binding (pexp_ident ~loc:v.loc v))) in loop rest (ign @ (item :: acc)) | item :: rest -> loop rest (item :: acc) in loop (super#structure st) [] end ppxlib-0.12.0/src/ignore_unused_warning.mli000066400000000000000000000000611360512673700207640ustar00rootroot00000000000000val add_dummy_user_for_values : Ast_traverse.map ppxlib-0.12.0/src/import.ml000066400000000000000000000002561360512673700155400ustar00rootroot00000000000000include Base include Stdio include Ppxlib_ast (* This is not re-exported by Base and we can't use [%here] in ppxlib *) external __FILE__ : string = "%loc_FILE" include Ast ppxlib-0.12.0/src/loc.ml000066400000000000000000000002701360512673700147770ustar00rootroot00000000000000open! Import type 'a t = 'a loc = { txt : 'a ; loc : Location.t } let txt t = t.txt let loc t = t.loc let make ~loc txt = { loc; txt } let map t ~f = { t with txt = f t.txt } ppxlib-0.12.0/src/loc.mli000066400000000000000000000003421360512673700151500ustar00rootroot00000000000000(** Located items *) open! Import type 'a t = 'a loc = { txt : 'a ; loc : Location.t } val txt : 'a t -> 'a val loc : _ t -> Location.t val make : loc:Location.t -> 'a -> 'a t val map : 'a t -> f:('a -> 'b) -> 'b t ppxlib-0.12.0/src/location.ml000066400000000000000000000042501360512673700160340ustar00rootroot00000000000000open Import module L = Ocaml_common.Location type t = location = { loc_start : Lexing.position ; loc_end : Lexing.position ; loc_ghost : bool } let in_file name = let loc = { pos_fname = name ; pos_lnum = 1 ; pos_bol = 0 ; pos_cnum = -1 } in { loc_start = loc ; loc_end = loc ; loc_ghost = true } let none = in_file "_none_" let raise_errorf ?loc fmt = L.raise_errorf ?loc fmt let report_exception = L.report_exception let of_lexbuf (lexbuf : Lexing.lexbuf) = { loc_start = lexbuf.lex_start_p ; loc_end = lexbuf.lex_curr_p ; loc_ghost = false } let print ppf t = Caml.Format.fprintf ppf "File \"%s\", line %d, characters %d-%d:" t.loc_start.pos_fname t.loc_start.pos_lnum (t.loc_start.pos_cnum - t.loc_start.pos_bol) (t.loc_end.pos_cnum - t.loc_start.pos_bol) type nonrec 'a loc = 'a loc = { txt : 'a ; loc : t } let compare_pos p1 p2 = let open Lexing in let column p = (* Manual extract: The difference between pos_cnum and pos_bol is the character offset within the line (i.e. the column number, assuming each character is one column wide). *) p.pos_cnum - p.pos_bol in match Int.compare p1.pos_lnum p2.pos_lnum with | 0 -> Int.compare (column p1) (column p2) | n -> n let min_pos p1 p2 = if compare_pos p1 p2 <= 0 then p1 else p2 let max_pos p1 p2 = if compare_pos p1 p2 >= 0 then p1 else p2 let compare loc1 loc2 = match compare_pos loc1.loc_start loc2.loc_start with | 0 -> compare_pos loc1.loc_end loc2.loc_end | n -> n module Error = struct module Helpers = Selected_ast.Ast.Ast_mapper type t = Helpers.location_error let make = Helpers.make_error_of_message let createf ~loc fmt = Printf.ksprintf (fun str -> Helpers.make_error_of_message ~loc ~sub:[] str) fmt let message = Helpers.get_error_message let set_message = Helpers.set_error_message let register_error_of_exn = Helpers.register_error_of_exn let of_exn = Helpers.error_of_exn let to_extension = Helpers.extension_of_error end exception Error of Error.t let () = Caml.Printexc.register_printer (function | Error e -> Some (Error.message e) | _ -> None) ppxlib-0.12.0/src/location.mli000066400000000000000000000036301360512673700162060ustar00rootroot00000000000000(** Overrides the Location module of OCaml *) (** There are less functions in this module. However the API should be more stable than the Location module of OCaml. *) open! Import type t = location = { loc_start : Lexing.position ; loc_end : Lexing.position ; loc_ghost : bool } (** Return an empty ghost range located in a given file. *) val in_file : string -> t (** An arbitrary value of type [t]; describes an empty ghost range. *) val none : t (** Raise a located error. The exception is caught by driver and handled appropriately *) val raise_errorf : ?loc:t -> ('a, Caml.Format.formatter, unit, 'b) format4 -> 'a (** Return the location corresponding to the last matched regular expression *) val of_lexbuf : Lexing.lexbuf -> t (** Report an exception on the given formatter *) val report_exception : Caml.Format.formatter -> exn -> unit (** Prints [File "...", line ..., characters ...-...:] *) val print : Caml.Format.formatter -> t -> unit type nonrec 'a loc = 'a loc = { txt : 'a ; loc : t } val compare_pos : Lexing.position -> Lexing.position -> int val min_pos : Lexing.position -> Lexing.position -> Lexing.position val max_pos : Lexing.position -> Lexing.position -> Lexing.position val compare : t -> t -> int module Error : sig type location = t type t val make : loc:location -> string -> sub:(location * string) list -> t val createf : loc:location -> ('a, unit, string, t) format4 -> 'a val message : t -> string val set_message : t -> string -> t (** Register an exception handler. Exception registered this way will be properly displayed by [report_exception]. *) val register_error_of_exn: (exn -> t option) -> unit val of_exn : exn -> t option (** Convert an error to an extension point. The compiler recognizes this and displays the error properly. *) val to_extension : t -> extension end with type location := t exception Error of Error.t ppxlib-0.12.0/src/location_check.ml000066400000000000000000000654351360512673700172050ustar00rootroot00000000000000open! Import module Non_intersecting_ranges : sig type t val empty : t val insert : node_name:string -> Location.t -> t -> t val union : t -> t -> t val covered_by : t -> loc:Location.t -> bool (** [covered_by t ~loc = true] iff [t] is covered by [loc] *) val find_outside : Location.t -> t -> string * Location.t end = struct type t = { min_pos: Lexing.position option ; max_pos: Lexing.position option ; ranges : (string * Location.t) list } let empty = { min_pos = None; max_pos = None; ranges = [] } let rec insert ranges (node_name, node_loc as node) = match ranges with | [] -> [ node ] | (x_name, x_loc) as x :: xs -> let open Location in if compare_pos node_loc.loc_start x_loc.loc_end >= 0 then node :: x :: xs else if compare_pos x_loc.loc_start node_loc.loc_end >= 0 then x :: insert xs node else raise_errorf ~loc:node_loc "invalid output from ppx, %s overlaps with %s at location:@.%a" node_name x_name Location.print x_loc let min_pos p1 p2 = match p1, p2 with | None, None -> None | (Some _ as p), None | None, (Some _ as p) -> p | Some p1, Some p2 -> Some (Location.min_pos p1 p2) let max_pos p1 p2 = match p1, p2 with | None, None -> None | (Some _ as p), None | None, (Some _ as p) -> p | Some p1, Some p2 -> Some (Location.max_pos p1 p2) let longest_first l1 l2 ~stop_after = let rec loop xs ys n = match xs, ys, n with | [], _, _ | _, _, 0 -> l2, l1 | _, [], _ -> l1, l2 | _ :: xs, _ :: ys, n -> loop xs ys (n - 1) in loop l1 l2 stop_after let union t1 t2 = let init, l = longest_first t1.ranges t2.ranges ~stop_after:42 in let ranges = List.fold l ~init ~f:insert in { min_pos = min_pos t1.min_pos t2.min_pos ; max_pos = max_pos t1.max_pos t2.max_pos ; ranges } let insert ~node_name loc t = { min_pos = min_pos (Some loc.loc_start) t.min_pos ; max_pos = max_pos (Some loc.loc_end) t.max_pos ; ranges = insert t.ranges (node_name, loc) } let covered_by t ~loc = match t.min_pos, t.max_pos with | None, None -> true | Some min_pos, Some max_pos -> Location.compare_pos min_pos loc.loc_start >= 0 && Location.compare_pos max_pos loc.loc_end <= 0 | _, _ -> (* there are no open ranges *) assert false let find_outside loc t = List.find_exn t.ranges ~f:(fun (_, l) -> Location.compare_pos loc.loc_start l.loc_start > 0 || Location.compare_pos loc.loc_end l.loc_end < 0 ) end let reloc_pmty_functors x = let outmost_loc = x.pmty_loc in let rec aux x = match x.pmty_desc with | Pmty_functor (id, mty_opt, initial_res) -> let res = aux initial_res in if Location.compare outmost_loc res.pmty_loc = 0 then let loc_start = (match mty_opt with | None -> id.loc | Some mty -> mty.pmty_loc).loc_end in let res = { res with pmty_loc = { res.pmty_loc with loc_start } } in { x with pmty_desc = Pmty_functor (id, mty_opt, res) } else if phys_equal res initial_res then x else { x with pmty_desc = Pmty_functor (id, mty_opt, res) } | _ -> x in aux x let reloc_pmod_functors x = let outmost_loc = x.pmod_loc in let rec aux x = match x.pmod_desc with | Pmod_functor (id, mty_opt, initial_res) -> let res = aux initial_res in if Location.compare outmost_loc res.pmod_loc = 0 then let loc_start = (match mty_opt with | None -> id.loc | Some mty -> mty.pmty_loc).loc_end in let res = { res with pmod_loc = { res.pmod_loc with loc_start } } in { x with pmod_desc = Pmod_functor (id, mty_opt, res) } else if phys_equal res initial_res then x else { x with pmod_desc = Pmod_functor (id, mty_opt, res) } | _ -> x in aux x let all_payloads_inside_parent ~loc = List.for_all ~f:(fun attr -> Location.compare_pos loc.loc_end attr.attr_loc.loc_end >= 0) let file : string option ref = ref None let same_file_so_far = ref true let stayed_in_the_same_file = fun fname -> (* CR-soon trefis: remove uses of Location.none from the ppxes. *) if String.equal fname "_none_" then true (* do nothing for now. *) else match !file with | None -> file := Some fname; true | Some orig_fname -> String.equal orig_fname fname || (same_file_so_far := false; false) let should_ignore loc attrs = (* If the filename changed, then there were line directives, and the locations are all messed up. *) not (stayed_in_the_same_file loc.loc_start.pos_fname) || (* Ignore things explicitely marked. *) List.exists ~f:(fun attr -> String.equal attr.attr_name.txt Merlin_helpers.hide_attribute.attr_name.txt ) attrs let rec extract_constraint e = match e.pexp_desc with | Pexp_constraint (e, ct) | Pexp_coerce (e, None, ct) -> Some (e, ct) | Pexp_newtype (name, exp) -> Option.map (extract_constraint exp) ~f:(fun (exp, ct) -> { e with pexp_desc = Pexp_newtype (name, exp); pexp_loc = { e.pexp_loc with loc_ghost = true } }, ct ) | _ -> None let do_check ~node_name node_loc childrens_locs siblings_locs = if not !same_file_so_far then Non_intersecting_ranges.empty else if node_loc.loc_ghost then Non_intersecting_ranges.union childrens_locs siblings_locs else if Non_intersecting_ranges.covered_by childrens_locs ~loc:node_loc then Non_intersecting_ranges.insert ~node_name node_loc siblings_locs else let child_name, child_loc = Non_intersecting_ranges.find_outside node_loc childrens_locs in Location.raise_errorf ~loc:node_loc "invalid output from ppx:@ this %s is built from a%s whose location is outside \ of this node's.@.Child %s found at:@ %a" node_name ((match String.unsafe_get child_name 0 with | 'a' | 'e' | 'i' | 'o' | 'u' -> "n " | _ -> " ") ^ child_name) child_name Location.print child_loc let enforce_invariants fname = let () = file := fname in object(self) inherit [Non_intersecting_ranges.t] Ast_traverse.fold as super (* CR-someday trefis: we should generate a class which enforces the location invariant. And then we should only override the methods where we need an escape hatch because the parser isn't doing the right thing. That would ensure that we stay up to date as the AST changes. *) method! longident_loc x siblings = if x.loc.loc_ghost then siblings else Non_intersecting_ranges.insert ~node_name:"ident" x.loc siblings method! row_field x siblings_locs = if should_ignore x.prf_loc x.prf_attributes then siblings_locs else let childrens_locs = super#row_field x Non_intersecting_ranges.empty in do_check ~node_name:"row field" x.prf_loc childrens_locs siblings_locs method! object_field x siblings_locs = if should_ignore x.pof_loc x.pof_attributes then siblings_locs else let childrens_locs = super#object_field x Non_intersecting_ranges.empty in do_check ~node_name:"object field" x.pof_loc childrens_locs siblings_locs method! binding_op x siblings_locs = let childrens_locs = super#binding_op x Non_intersecting_ranges.empty in do_check ~node_name:"binding operator" x.pbop_loc childrens_locs siblings_locs method! value_description x siblings_locs = if should_ignore x.pval_loc x.pval_attributes then siblings_locs else let childrens_locs = super#value_description x Non_intersecting_ranges.empty in do_check ~node_name:"value description" x.pval_loc childrens_locs siblings_locs method! type_declaration x siblings_locs = if should_ignore x.ptype_loc x.ptype_attributes then siblings_locs else let childrens_locs = super#type_declaration x Non_intersecting_ranges.empty in do_check ~node_name:"type declaration" x.ptype_loc childrens_locs siblings_locs method! label_declaration x siblings_locs = if should_ignore x.pld_loc x.pld_attributes then siblings_locs else let childrens_locs = super#label_declaration x Non_intersecting_ranges.empty in do_check ~node_name:"label declaration" x.pld_loc childrens_locs siblings_locs method! constructor_declaration x siblings_locs = if should_ignore x.pcd_loc x.pcd_attributes then siblings_locs else let childrens_locs = super#constructor_declaration x Non_intersecting_ranges.empty in do_check ~node_name:"constructor declaration" x.pcd_loc childrens_locs siblings_locs method! type_extension x siblings_locs = if should_ignore x.ptyext_loc x.ptyext_attributes then siblings_locs else let childrens_locs = super#type_extension x Non_intersecting_ranges.empty in do_check ~node_name:"type extension" x.ptyext_loc childrens_locs siblings_locs method! extension_constructor x siblings_locs = if should_ignore x.pext_loc x.pext_attributes then siblings_locs else let childrens_locs = super#extension_constructor x Non_intersecting_ranges.empty in do_check ~node_name:"extension constructor" x.pext_loc childrens_locs siblings_locs method! class_type x siblings_locs = if should_ignore x.pcty_loc x.pcty_attributes then siblings_locs else let childrens_locs = super#class_type x Non_intersecting_ranges.empty in do_check ~node_name:"class type" x.pcty_loc childrens_locs siblings_locs method! class_type_field x siblings_locs = if should_ignore x.pctf_loc x.pctf_attributes then siblings_locs else let childrens_locs = super#class_type_field x Non_intersecting_ranges.empty in do_check ~node_name:"class type field" x.pctf_loc childrens_locs siblings_locs method! class_infos f x siblings_locs = if should_ignore x.pci_loc x.pci_attributes then siblings_locs else let childrens_locs = super#class_infos f x Non_intersecting_ranges.empty in do_check ~node_name:"class" x.pci_loc childrens_locs siblings_locs method! class_expr x siblings_locs = if should_ignore x.pcl_loc x.pcl_attributes then siblings_locs else let childrens_locs = super#class_expr x Non_intersecting_ranges.empty in do_check ~node_name:"class expression" x.pcl_loc childrens_locs siblings_locs method! class_field x siblings_locs = if should_ignore x.pcf_loc x.pcf_attributes then siblings_locs else let childrens_locs = super#class_field x Non_intersecting_ranges.empty in do_check ~node_name:"class field" x.pcf_loc childrens_locs siblings_locs method! signature_item x siblings_locs = if should_ignore x.psig_loc [] then siblings_locs else let childrens_locs = super#signature_item x Non_intersecting_ranges.empty in do_check ~node_name:"signature item" x.psig_loc childrens_locs siblings_locs method! module_declaration x siblings_locs = if should_ignore x.pmd_loc x.pmd_attributes then siblings_locs else let childrens_locs = super#module_declaration x Non_intersecting_ranges.empty in do_check ~node_name:"module declaration" x.pmd_loc childrens_locs siblings_locs method! module_substitution x siblings_locs = if should_ignore x.pms_loc x.pms_attributes then siblings_locs else let childrens_locs = super#module_substitution x Non_intersecting_ranges.empty in do_check ~node_name:"module substitution" x.pms_loc childrens_locs siblings_locs method! module_type_declaration x siblings_locs = if should_ignore x.pmtd_loc x.pmtd_attributes then siblings_locs else let childrens_locs = super#module_type_declaration x Non_intersecting_ranges.empty in do_check ~node_name:"module type declaration" x.pmtd_loc childrens_locs siblings_locs method! open_infos f x siblings_locs = if should_ignore x.popen_loc x.popen_attributes then siblings_locs else let childrens_locs = super#open_infos f x Non_intersecting_ranges.empty in do_check ~node_name:"open" x.popen_loc childrens_locs siblings_locs method! include_infos f x siblings_locs = if should_ignore x.pincl_loc x.pincl_attributes then siblings_locs else let childrens_locs = super#include_infos f x Non_intersecting_ranges.empty in do_check ~node_name:"include" x.pincl_loc childrens_locs siblings_locs method! structure_item x siblings_locs = if should_ignore x.pstr_loc [] then siblings_locs else let childrens_locs = super#structure_item x Non_intersecting_ranges.empty in do_check ~node_name:"structure item" x.pstr_loc childrens_locs siblings_locs method! module_binding x siblings_locs = if should_ignore x.pmb_loc x.pmb_attributes then siblings_locs else let childrens_locs = super#module_binding x Non_intersecting_ranges.empty in do_check ~node_name:"module binding" x.pmb_loc childrens_locs siblings_locs (******************************************) (* The following is special cased because *) (* the type constraint is duplicated. *) (******************************************) method! value_binding x siblings_locs = if should_ignore x.pvb_loc x.pvb_attributes then siblings_locs else let childrens_locs = match x.pvb_pat.ppat_desc, extract_constraint x.pvb_expr with | (* let x : type a b c. ct = e *) Ppat_constraint (pvb_pat, { ptyp_desc = Ptyp_poly (_ :: _, ctp); _ }), Some (pvb_expr, cte) | (* let x : ct = e let x :> ct = e *) Ppat_constraint (pvb_pat, { ptyp_desc = Ptyp_poly ([], ctp); _ }), Some (pvb_expr, cte) when Location.compare ctp.ptyp_loc cte.ptyp_loc = 0 -> let acc = Non_intersecting_ranges.empty in let acc = self#pattern pvb_pat acc in let _acc = self#core_type ctp acc in let acc = self#expression pvb_expr acc in let acc = self#attributes x.pvb_attributes acc in acc | _ -> super#value_binding x Non_intersecting_ranges.empty in do_check ~node_name:"value binding" x.pvb_loc childrens_locs siblings_locs (**********************************************) (* The following is special cased because of: *) (* MT [@attr payload] *) (* where the loc of payload is outside the *) (* loc of the module type.... *) (* and *) (* functor (A : S) (B : S) ... *) (* where the loc of [(B : S) ...] is the same *) (* as the loc of the outermost module type. *) (**********************************************) method! module_type x siblings_locs = if should_ignore x.pmty_loc x.pmty_attributes then siblings_locs else let x = reloc_pmty_functors x in let childrens_locs = if all_payloads_inside_parent ~loc:x.pmty_loc x.pmty_attributes then super#module_type x Non_intersecting_ranges.empty else let acc = self#module_type_desc x.pmty_desc Non_intersecting_ranges.empty in let _ = self#attributes x.pmty_attributes acc in acc in do_check ~node_name:"module type" x.pmty_loc childrens_locs siblings_locs (**********************************************) (* The following is special cased because of: *) (* ME [@attr payload] *) (* where the loc of payload is outside the *) (* loc of the module expr.... *) (* and *) (* functor (A : S) (B : S) ... *) (* where the loc of [(B : S) ...] is the same *) (* as the loc of the outermost module expr. *) (**********************************************) method! module_expr x siblings_locs = if should_ignore x.pmod_loc x.pmod_attributes then siblings_locs else let x = reloc_pmod_functors x in let childrens_locs = if all_payloads_inside_parent ~loc:x.pmod_loc x.pmod_attributes then super#module_expr x Non_intersecting_ranges.empty else let acc = self#module_expr_desc x.pmod_desc Non_intersecting_ranges.empty in let _ = self#attributes x.pmod_attributes acc in acc in do_check ~node_name:"module expression" x.pmod_loc childrens_locs siblings_locs (*********************) (* Same as above ... *) (*********************) method! core_type x siblings_locs = if should_ignore x.ptyp_loc x.ptyp_attributes then siblings_locs else let childrens_locs = if all_payloads_inside_parent ~loc:x.ptyp_loc x.ptyp_attributes then super#core_type x Non_intersecting_ranges.empty else let acc = self#core_type_desc x.ptyp_desc Non_intersecting_ranges.empty in let _ = self#attributes x.ptyp_attributes acc in acc in do_check ~node_name:"core type" x.ptyp_loc childrens_locs siblings_locs (*****************) (* And again ... *) (*****************) method! expression x siblings_locs = if should_ignore x.pexp_loc x.pexp_attributes then siblings_locs else let childrens_locs = if all_payloads_inside_parent ~loc:x.pexp_loc x.pexp_attributes then super#expression x Non_intersecting_ranges.empty else let acc = self#expression_desc x.pexp_desc Non_intersecting_ranges.empty in let _ = self#attributes x.pexp_attributes acc in acc in do_check ~node_name:"expression" x.pexp_loc childrens_locs siblings_locs (*****************) (* ... and again *) (*****************) method! pattern x siblings_locs = if should_ignore x.ppat_loc x.ppat_attributes then siblings_locs else let childrens_locs = if all_payloads_inside_parent ~loc:x.ppat_loc x.ppat_attributes then super#pattern x Non_intersecting_ranges.empty else let acc = self#pattern_desc x.ppat_desc Non_intersecting_ranges.empty in let _ = self#attributes x.ppat_attributes acc in acc in do_check ~node_name:"pattern" x.ppat_loc childrens_locs siblings_locs (***********************************************************) (* The following is special cased because the location of *) (* the construct equals the location of the type_exception *) (* (and so covers the location of the attributes). *) (***********************************************************) method! type_exception x siblings_locs = if should_ignore x.ptyexn_loc x.ptyexn_attributes then siblings_locs else let init = Non_intersecting_ranges.empty in let childs_locs = self#extension_constructor x.ptyexn_constructor init in let attrs_locs = self#attributes x.ptyexn_attributes init in ignore (do_check ~node_name:"exception" x.ptyexn_loc attrs_locs siblings_locs); do_check ~node_name:"exception" x.ptyexn_loc childs_locs siblings_locs (******************************************) (* The following is overriden because the *) (* lhs is sometimes included in the rhs. *) (******************************************) method! with_constraint x siblings_loc = match x with | Pwith_type (_, tdecl) | Pwith_typesubst (_, tdecl) -> self#type_declaration tdecl siblings_loc | _ -> super#with_constraint x siblings_loc (******************************************) (* The following is overriden because of: *) (* - Foo.{ bar; ... } *) (* - Foo.[ bar; ... ] *) (* - Foo.( bar; ... ) *) (* - method x : type a. ... = ... *) (* - foo.@(bar) *) (* - foo.@(bar) <- baz *) (* - foo.%.{bar} *) (* - foo.%.{bar} <- baz *) (* - foo.%.[bar] *) (* - foo.%.[bar] <- baz *) (******************************************) method! expression_desc x acc = match x with | Pexp_record (labels, expr_o) -> let acc = self#list (fun (lid, e) acc-> if Location.compare_pos lid.loc.loc_start e.pexp_loc.loc_start = 0 then if Location.compare lid.loc e.pexp_loc = 0 then (* punning. *) self#longident_loc lid acc else match e.pexp_desc with | Pexp_constraint (e, c) -> (* { foo : int } and { foo : int = x } ... *) let _ = self#core_type c acc in self#expression e acc | _ -> (* No idea what's going on there. *) self#expression e acc else let acc = self#longident_loc lid acc in let acc = self#expression e acc in acc) labels acc in self#option self#expression expr_o acc | Pexp_open ({ popen_expr = { pmod_desc = Pmod_ident lid; _ }; _ } as opn, e) when Location.compare_pos lid.loc.loc_start e.pexp_loc.loc_start = 0 && Location.compare_pos lid.loc.loc_end e.pexp_loc.loc_end <> 0 -> (* let's relocate ... *) let e_loc = { e.pexp_loc with loc_start = lid.loc.loc_end } in super#expression_desc (Pexp_open (opn, { e with pexp_loc = e_loc })) acc | Pexp_poly (e, Some { ptyp_desc = Ptyp_poly (_, ct); _ }) -> begin match extract_constraint e with | Some (e, cte) when Location.compare cte.ptyp_loc ct.ptyp_loc = 0 -> let acc = self#expression e acc in let acc = self#core_type ct acc in acc | _ -> super#expression_desc x acc end | Pexp_apply ({ pexp_desc = Pexp_ident { txt = lid; _ }; _ }, args) -> begin match Longident.last_exn lid with | id when String.is_prefix id ~prefix:"." && (String.is_suffix id ~suffix:"()" || String.is_suffix id ~suffix:"()<-" || String.is_suffix id ~suffix:"[]" || String.is_suffix id ~suffix:"[]<-" || String.is_suffix id ~suffix:"{}" || String.is_suffix id ~suffix:"{}<-") -> self#list (fun (_, e) -> self#expression e) args acc | exception _ -> super#expression_desc x acc | _ -> super#expression_desc x acc end | _ -> super#expression_desc x acc (*******************************************************) (* The following is overriden because of: *) (* - punning. *) (* - record field with type constraint. *) (* - unpack locations being incorrect when constrained *) (*******************************************************) method! pattern_desc x acc = match x with | Ppat_record (labels, _) -> self#list (fun (lid, pat) acc -> if Location.compare_pos lid.loc.loc_start pat.ppat_loc.loc_start = 0 then if Location.compare lid.loc pat.ppat_loc = 0 then (* simple punning! *) self#longident_loc lid acc else match pat.ppat_desc with | Ppat_constraint (p, c) -> (* { foo : int } and { foo : int = x } ... *) let _ = self#core_type c acc in self#pattern p acc | _ -> (* No idea what's going on there. *) self#pattern pat acc else let acc = self#longident_loc lid acc in let acc = self#pattern pat acc in acc) labels acc | Ppat_constraint ({ ppat_desc = Ppat_unpack a; _ }, b) -> let acc = self#loc self#string a acc in self#core_type b acc | _ -> super#pattern_desc x acc (**********************************************************) (* The following is overriden because the location of the *) (* fake structure for a generative argument covers the *) (* location of the functor. *) (**********************************************************) method! module_expr_desc x acc = match x with | Pmod_apply (m, { pmod_desc = Pmod_structure []; pmod_loc; _ }) when Location.compare_pos m.pmod_loc.loc_start pmod_loc.loc_start = 0 -> super#module_expr m acc | _ -> super#module_expr_desc x acc (**********************************************************) (* The following is overriden because the location of the *) (* open_infos for Pcl_open only covers the "open" keyword *) (* and not the module opened. *) (**********************************************************) method! class_expr_desc x acc = match x with | Pcl_open (od, ce) -> (* inline of open_description (which effectively makes that node disappear) *) let acc = self#longident_loc od.popen_expr acc in let acc = self#override_flag od.popen_override acc in let acc = self#location od.popen_loc acc in let acc = self#attributes od.popen_attributes acc in (* continue *) let acc = self#class_expr ce acc in acc | _ -> super#class_expr_desc x acc (*********************) (* Same as above ... *) (*********************) method! class_type_desc x acc = match x with | Pcty_open (od, ct) -> (* inline of open_description (which effectively makes that node disappear) *) let acc = self#longident_loc od.popen_expr acc in let acc = self#override_flag od.popen_override acc in let acc = self#location od.popen_loc acc in let acc = self#attributes od.popen_attributes acc in (* continue *) let acc = self#class_type ct acc in acc | _ -> super#class_type_desc x acc (**********************************************************) (* The following is overriden because docstrings have the *) (* same location as the item they get attached to. *) (**********************************************************) method! attribute x acc = match x.attr_name.txt with | "ocaml.doc" | "ocaml.text" -> acc | _ -> super#attribute x acc end ppxlib-0.12.0/src/location_check.mli000066400000000000000000000002501360512673700173360ustar00rootroot00000000000000open! Import module Non_intersecting_ranges : sig type t val empty : t end val enforce_invariants : string option -> Non_intersecting_ranges.t Ast_traverse.fold ppxlib-0.12.0/src/longident.ml000066400000000000000000000042201360512673700162040ustar00rootroot00000000000000open! Import module T = struct type t = longident = Lident of string | Ldot of t * string | Lapply of t * t let compare : t -> t -> int = Poly.compare let is_normal_ident_char = function | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' | '\'' -> true | _ -> false let is_normal_ident = function | "asr" | "land" | "lor" | "lsl" | "lsr" | "lxor" | "mod" | "or" -> false | string -> String.for_all string ~f:is_normal_ident_char let short_name string = if is_normal_ident string then string else "( " ^ string ^ " )" let rec name = function | Lident s -> short_name s | Ldot (a, b) -> name a ^ "." ^ short_name b | Lapply (a, b) -> Printf.sprintf "%s(%s)" (name a) (name b) let sexp_of_t t = Sexp.Atom (name t) end include T include Comparable.Make(T) let rec flat accu = function Lident s -> s :: accu | Ldot(lid, s) -> flat (s :: accu) lid | Lapply(_, _) -> invalid_arg "Ppxlib.Longident.flatten" let flatten_exn lid = flat [] lid let last_exn = function Lident s -> s | Ldot(_, s) -> s | Lapply(_, _) -> invalid_arg "Ppxlib.Longident.flatten" let unflatten ~init l = List.fold_left l ~init ~f:(fun acc s -> Ldot (acc, s)) (* for cases without dotted operators (e.g. [parse "A.B.C"]) *) let parse_simple s = match String.split s ~on:'.' with | [] -> assert false | s :: l -> unflatten ~init:(Lident s) l (* handle ["A.B.(+.+)"] or ["Vec.(.%.()<-)"] *) let parse s = let invalid () = invalid_arg (Printf.sprintf "Ppxlib.Longident.parse: %S" s) in match String.index s '(', String.rindex s ')' with | None, None -> parse_simple s | None, _ | _, None -> invalid () | Some l, Some r -> if Int.( r <> String.length s - 1 ) then invalid (); let group = if Int.(r = l + 1) then "()" else String.strip (String.sub s ~pos:(l+1) ~len:(r-l-1)) in if Int.(l = 0) then Lident group else if Char.(s.[l - 1] <> '.') then invalid () else let before = String.sub s ~pos:0 ~len:(l-1) in match String.split before ~on:'.' with | [] -> assert false | s :: l -> Ldot(unflatten ~init:(Lident s) l, group) ppxlib-0.12.0/src/longident.mli000066400000000000000000000010271360512673700163570ustar00rootroot00000000000000(** Overrides the Longident module of OCaml *) open! Import type t = longident = Lident of string | Ldot of t * string | Lapply of t * t include Comparable.S with type t := t val flatten_exn : t -> string list val last_exn : t -> string (** Parses the given string as a longident, properly handling infix operators which may contain '.'. Note that it does not parse [Lapply _] longidents and will raise [Invalid_argument _] if passed values such as ["A(B)"]. *) val parse : string -> t val name : t -> string ppxlib-0.12.0/src/merlin_helpers.ml000066400000000000000000000013001360512673700172250ustar00rootroot00000000000000open! Import let mk_attr_noloc txt = Ast_helper.Attr.mk Location.{ txt; loc = none } let hide_attribute : attribute = mk_attr_noloc "merlin.hide" (PStr []) let focus_attribute : attribute = mk_attr_noloc "merlin.focus" (PStr []) let hide_pattern ({ ppat_attributes ; _ } as p) = { p with ppat_attributes = hide_attribute :: ppat_attributes } let focus_pattern ({ ppat_attributes ; _ } as p) = { p with ppat_attributes = focus_attribute :: ppat_attributes } let hide_expression ({ pexp_attributes ; _ } as e) = { e with pexp_attributes = hide_attribute :: pexp_attributes } let focus_expression ({ pexp_attributes ; _ } as e) = { e with pexp_attributes = focus_attribute :: pexp_attributes } ppxlib-0.12.0/src/merlin_helpers.mli000066400000000000000000000016031360512673700174040ustar00rootroot00000000000000(** Some helpers to annotate the AST so merlin can decide which branches to look at and which branches to ignore. *) open! Import (** {2 Annotations merlin understand} *) (** Adding this [[@merlin.hide]] attribute on a piece of AST "hides" it from merlin: it tells merlin not to consider that branch if another piece of AST with the same location exist. *) val hide_attribute : attribute (** Adding this [[@merlin.focus]] attribute on a piece of AST tells merlin to prefer it to any other piece of AST when several have the same location. *) val focus_attribute : attribute (** {2 Helpers} The following functions add the corresponding attribute (defined above) to specific pieces of AST. *) val hide_pattern : pattern -> pattern val focus_pattern : pattern -> pattern val hide_expression : expression -> expression val focus_expression : expression -> expression ppxlib-0.12.0/src/name.ml000066400000000000000000000214061360512673700151460ustar00rootroot00000000000000open! Import module Format = Caml.Format let fold_dot_suffixes name ~init:acc ~f = let rec collapse_after_at = function | [] -> [] | part :: parts -> if not (String.is_empty part) && Char.equal part.[0] '@' then [String.concat (String.drop_prefix part 1 :: parts) ~sep:"."] else part :: collapse_after_at parts in let rec loop acc parts = match parts with | [] -> acc | part :: parts -> loop (f (String.concat (part :: parts) ~sep:".") acc) parts in String.split name ~on:'.' |> collapse_after_at |> loop acc ;; let dot_suffixes name = fold_dot_suffixes name ~init:[] ~f:(fun x acc -> x :: acc) let split_path = let rec loop s i = if i = String.length s then (s, None) else match s.[i] with | '.' -> after_dot s (i + 1) | _ -> loop s (i + 1) and after_dot s i = if i = String.length s then (s, None) else match s.[i] with | 'A'..'Z' -> (String.prefix s (i - 1), Some (String.drop_prefix s i)) | '.' -> after_dot s (i + 1) | _ -> loop s (i + 1) in fun s -> loop s 0 module Pattern = struct module Str = struct type t = string let sexp_of_t = String.sexp_of_t let compare a b = let d = Int.compare (String.length a) (String.length b) in if d <> 0 then d else String.compare a b include (val Comparator.make ~compare ~sexp_of_t) end type t = { name : string ; dot_suffixes : Set.M(Str).t } let make name = { name ; dot_suffixes = Set.of_list (module Str) (dot_suffixes name) } let name t = t.name let matches t matched = Set.mem t.dot_suffixes matched end let get_outer_namespace name = match String.index name '.' with | None -> None | Some i -> Some (String.sub name ~pos:0 ~len:i) module Whitelisted = struct (* White list the following attributes, as well as all their dot suffixes. Since these attributes are interpreted by the compiler itself, we cannot check at the level of a ppx rewriter that they have been properly interpreted, so we just accept them anywhere. Sadly, the compiler silently ignores them if they are misplaced... *) let create_set fully_qualified_names = List.fold_left ~f:(fun acc name -> fold_dot_suffixes name ~init:acc ~f:(fun x acc -> Set.add acc x)) ~init:(Set.empty (module String)) fully_qualified_names let attributes = create_set [ "ocaml.alert" ; "ocaml.boxed" ; "ocaml.deprecated" ; "ocaml.deprecated_mutable" ; "ocaml.doc" ; "ocaml.extension_constructor" ; "ocaml.immediate" ; "ocaml.immediate64" ; "ocaml.inline" ; "ocaml.inlined" ; "ocaml.local" ; "ocaml.noalloc" ; "ocaml.ppwarning" ; "ocaml.remove_aliases" ; "ocaml.specialise" ; "ocaml.specialised" ; "ocaml.tailcall" ; "ocaml.text" ; "ocaml.unboxed" ; "ocaml.unroll" ; "ocaml.unrolled" ; "ocaml.untagged" ; "ocaml.warn_on_literal_pattern" ; "ocaml.warnerror" ; "ocaml.warning" ] (* White list the following extensions. Since these extensions are interpreted by the compiler itself, we cannot check at the level of a ppx rewriter that they have been properly interpreted, so we just accept them anywhere. *) let extensions = create_set [ "ocaml.error" ; "ocaml.extension_constructor" ] let is_whitelisted ~kind name = match kind with | `Attribute -> Set.mem attributes name | `Extension -> Set.mem extensions name let get_attribute_list () = Set.elements attributes let get_extension_list () = Set.elements extensions end module Reserved_namespaces = struct let tbl : (string, unit) Hashtbl.t = Hashtbl.create (module String) let reserve ns = Hashtbl.add_exn tbl ~key:ns ~data:() let () = reserve "merlin" let () = reserve "reason" let () = reserve "refmt" let () = reserve "metaocaml" let () = reserve "ocamlformat" let is_in_reserved_namespaces name = match get_outer_namespace name with | Some ns -> Hashtbl.mem tbl ns | None -> Hashtbl.mem tbl name let check_not_reserved ~kind name = let kind, list = match kind with | `Attribute -> "attribute", Whitelisted.attributes | `Extension -> "extension", Whitelisted.extensions in if Set.mem list name then Printf.ksprintf failwith "Cannot register %s with name '%s' as it matches an \ %s reserved by the compiler" kind name kind else if is_in_reserved_namespaces name then Printf.ksprintf failwith "Cannot register %s with name '%s' as its namespace \ is marked as reserved" kind name end let ignore_checks name = Reserved_namespaces.is_in_reserved_namespaces name || String.is_prefix name ~prefix:"_" module Registrar = struct type element = { fully_qualified_name : string ; declared_at : Caller_id.t } type all_for_context = { mutable all : element Map.M(String).t } type 'a t = { all_by_context : ('a, all_for_context) Hashtbl.t ; skip : string list ; kind : string ; string_of_context : 'a -> string option } let create ~kind ~current_file ~string_of_context = { all_by_context = Hashtbl.Poly.create () ; skip = [current_file; __FILE__] ; kind ; string_of_context } let get_all_for_context t context = Hashtbl.find_or_add t.all_by_context context ~default:(fun () -> { all = Map.empty (module String) }) ;; let register ~kind t context name = Reserved_namespaces.check_not_reserved ~kind name; let caller = Caller_id.get ~skip:t.skip in let all = get_all_for_context t context in (match Map.find all.all name with | None -> () | Some e -> let declared_at = function | None -> "" | Some (loc : Caml.Printexc.location) -> Printf.sprintf " declared at %s:%d" loc.filename loc.line_number in let context = match t.string_of_context context with | None -> "" | Some s -> " on " ^ s ^ "s" in Printf.ksprintf failwith "%s '%s'%s%s matches %s '%s'%s" (String.capitalize t.kind) name context (declared_at caller) t.kind e.fully_qualified_name (declared_at e.declared_at) ); let t = { fully_qualified_name = name ; declared_at = caller } in all.all <- fold_dot_suffixes name ~init:all.all ~f:(fun name acc -> Map.set acc ~key:name ~data:t); ;; let spellcheck t context ?(white_list=[]) name = let all = let all = get_all_for_context t context in Map.fold all.all ~init:[] ~f:(fun ~key ~data:_ acc -> key :: acc) in match Spellcheck.spellcheck (all @ white_list) name with | Some _ as x -> x | None -> let other_contexts = Hashtbl.fold t.all_by_context ~init:[] ~f:(fun ~key:ctx ~data:{ all } acc -> if Poly.(<>) context ctx && Map.mem all name then match t.string_of_context ctx with | None -> acc | Some s -> (s ^ "s") :: acc else acc) in let pp_text = Format.pp_print_text in let current_context ppf = match t.string_of_context context with | None | Some "" -> () | Some s -> let a_or_an = match s.[0] with | 'a' | 'e' | 'i' | 'o' | 'u' | 'y' -> "an" | _ -> "a" in Format.fprintf ppf "@ but@ is@ used@ here@ in@ the@ context@ of@ %s@ %a" a_or_an pp_text s in match List.sort ~compare:(fun x y -> - (String.compare x y)) other_contexts with | [] -> None | [c] -> Some (Format.asprintf "@[Hint:@ `%s'@ is@ available@ for@ %a%t.@]@\n\ Did you put it at the wrong level?" name pp_text c current_context) | last :: rev_others -> let others = List.rev rev_others in Some (Format.asprintf "@[Hint:@ `%s'@ is@ available@ for@ %a@ and@ %a%t.@]@\n\ Did you put it at the wrong level?" name (Format.pp_print_list pp_text ~pp_sep:(fun ppf () -> Format.fprintf ppf ",@ ")) others pp_text last current_context) ;; (* TODO: hint spelling errors regarding reserved namespaces names and white listed names instead of taking an optional [white_list] parameter. *) let raise_errorf t context ?white_list fmt (name : string Loc.t) = Printf.ksprintf (fun msg -> match spellcheck t context name.txt ?white_list with | None -> Location.raise_errorf ~loc:name.loc "%s" msg | Some s -> Location.raise_errorf ~loc:name.loc "%s.\n%s" msg s) fmt name.txt ;; end ppxlib-0.12.0/src/name.mli000066400000000000000000000047771360512673700153330ustar00rootroot00000000000000open! Import module Pattern : sig type t (** Uses the rules described in [Attribute] *) val make : string -> t val name : t -> string (** [matches ~pattern name] returns [true] iff [name] matches [pattern]. For instance, the exact set of names such that [matches (make "foo.bar.@blah.x") name] is: - "foo.bar.blah.x" - "bar.blah.x" - "blah.x" *) val matches : t -> string -> bool end (** Split the path part of a name: [split_path "a.b.C.D" = "a.b", Some "C.D"] *) val split_path : string -> string * string option (** [fold_dot_suffixes "foo.@bar.blah" ~init ~f] is {[ ["bar.blah"; "foo.bar.blah"] ]} *) val dot_suffixes : string -> string list module Registrar : sig (** Names are organized by context. For instance contexts can be: expressions, patterns, types, ... *) type 'context t (** - [kind] is a description of the things registered. For instance: "extension", "attribute", ... - [current_file] is where this function is called. Must be [__FILE__]. - [string_of_context]: human readable description of a context *) val create : kind:string -> current_file:string (* must be [__FILE__] *) -> string_of_context:('context -> string option) -> 'context t val register : kind:[ `Attribute | `Extension ] -> 'context t -> 'context -> string -> unit val spellcheck : 'context t -> 'context -> ?white_list:string list -> string -> string option val raise_errorf : 'context t -> 'context -> ?white_list:string list -> (string -> 'a, unit, string, 'c) format4 -> string Loc.t -> 'a end module Whitelisted : sig val get_attribute_list : unit -> string list val get_extension_list : unit -> string list val is_whitelisted : kind:[ `Attribute | `Extension ] -> string -> bool end module Reserved_namespaces : sig (** [reserve "foo"] has two implications: - one can't then declare an attribute inside this namespace - attributes within this namespace won't be reported by [check_unused] This is here to insure that the rewriter cohabits well with other rewriter or tools (e.g. merlin) which might leave attribute on the AST. N.B. the "merlin" namespace is reserved by default. *) val reserve : string -> unit val is_in_reserved_namespaces : string -> bool end (** Returns [true] if checks should be ignored for the following name, for instance if it is reserved or starts with an underscore. *) val ignore_checks : string -> bool ppxlib-0.12.0/src/options.ml000066400000000000000000000006051360512673700157170ustar00rootroot00000000000000let perform_checks = false (* The checks on extensions are only to get better error messages since the compiler will choke on unknown extensions. We disable them externally to make it easier to use non ppxlib based rewriters with ppxlib *) let perform_checks_on_extensions = false let perform_locations_check = false let fail_on_duplicate_derivers = false let diff_command = None ppxlib-0.12.0/src/ppxlib.ml000066400000000000000000000036561360512673700155330ustar00rootroot00000000000000(** Standard library for ppx rewriters *) (** Make sure code using Ppxlib doesn't refer to compiler-libs without being explicit about it *) include struct [@@@warning "-3"] open Ocaml_shadow include (Ocaml_shadow : module type of struct include Ocaml_shadow end with module Ast_helper := Ast_helper with module Asttypes := Asttypes with module Docstrings := Docstrings with module Identifiable := Identifiable with module Lexer := Lexer with module Location := Location with module Longident := Longident with module Parse := Parse with module Parser := Parser with module Parsetree := Parsetree with module Pprintast := Pprintast with module Syntaxerr := Syntaxerr ) end (** @inline *) (** Includes the overrides from Ppxlib_ast, as well as all the Ast definitions since we need them in every single ppx *) include Ppxlib_ast include Ast module Ast_builder = Ast_builder module Ast_pattern = Ast_pattern module Ast_traverse = Ast_traverse module Attribute = Attribute module Code_path = Code_path module Caller_id = Caller_id module Context_free = Context_free module Deriving = Deriving module Driver = Driver module Expansion_context = Expansion_context module Extension = Extension module File_path = File_path module Loc = Loc module Location = Location module Longident = Longident module Merlin_helpers = Merlin_helpers module Reserved_namespaces = Name.Reserved_namespaces module Spellcheck = Spellcheck module Quoter = Quoter include Common (**/**) (* For tests and Ppx_core compatiblity layer *) module Ppxlib_private = struct module Common = Common module Name = Name end ppxlib-0.12.0/src/quoter.ml000066400000000000000000000014561360512673700155500ustar00rootroot00000000000000open Import type t = { mutable next_id : int ; mutable bindings : Parsetree.value_binding list } let create () = { next_id = 0 ; bindings = [] } let sanitize t e = match t.bindings with | [] -> e | bindings -> let (module Ast) = Ast_builder.make e.pexp_loc in Ast.pexp_let Recursive bindings e let quote t (e : expression) = let loc = e.pexp_loc in let (module Ast) = Ast_builder.make loc in let name = "__" ^ Int.to_string t.next_id in let binding = let pat = Ast.pvar name in let expr = Ast.pexp_fun Nolabel None (let unit = Ast_builder.Default.Located.lident ~loc "()" in Ast.ppat_construct unit None) e in Ast.value_binding ~pat ~expr in t.bindings <- binding :: t.bindings; t.next_id <- t.next_id + 1; Ast.evar name ppxlib-0.12.0/src/quoter.mli000066400000000000000000000014461360512673700157200ustar00rootroot00000000000000(** Generate expressions in a hygienic way. The idea is that whenever we want to refer to an expression in generated code we first quote it. The result will be an identifier that is guaranteed to refer to the expression it was created from. This way it is impossible for quoted fragments to refer to newly introduced expressions. *) open Import type t val create : unit -> t (** Creates a quoter. A quoter guarantees to give names that do not clash with any other names used before *) val quote : t -> expression -> expression (** [quote t e] returns the expression that is safe to use in place of [e] in generated code*) val sanitize : t -> expression -> expression (** [sanitize t e] Returns [e] wrapped with bindings for all quoted expressions in the quoter [t] *) ppxlib-0.12.0/src/reconcile.ml000066400000000000000000000237271360512673700162010ustar00rootroot00000000000000open Import open Utils module Context = struct type 'a t = | Extension of 'a Extension.Context.t | Floating_attribute of 'a Attribute.Floating.Context.t let paren pp ppf x = Caml.Format.fprintf ppf "(%a)" pp x let printer : type a. a t -> Caml.Format.formatter -> a -> unit = let open Extension.Context in let open Attribute.Floating.Context in function | Extension Class_expr -> Pprintast.class_expr | Extension Class_field -> Pprintast.class_field | Extension Class_type -> Pprintast.class_type | Extension Class_type_field -> Pprintast.class_type_field | Extension Core_type -> paren Pprintast.core_type | Extension Expression -> paren Pprintast.expression | Extension Module_expr -> Pprintast.module_expr | Extension Module_type -> Pprintast.module_type | Extension Pattern -> paren Pprintast.pattern | Extension Signature_item -> Pprintast.signature_item | Extension Structure_item -> Pprintast.structure_item | Floating_attribute Structure_item -> Pprintast.structure_item | Floating_attribute Signature_item -> Pprintast.signature_item | Floating_attribute Class_field -> Pprintast.class_field | Floating_attribute Class_type_field -> Pprintast.class_type_field end module Replacement = struct type data = | Values : 'a Context.t * 'a Context_free.Generated_code_hook.single_or_many -> data | Text of string type t = { start : Lexing.position ; stop : Lexing.position ; data : data } let make ~context ~start ~stop ~repl () = { start; stop; data = Values (context, repl) } let make_text ~start ~stop ~repl () = { start; stop; data = Text repl } let text block = match block.data with | Text s -> s | Values (context, generated) -> let s = let printer = Context.printer context in match generated with | Single x -> Caml.Format.asprintf "%a" printer x | Many l -> Caml.Format.asprintf "%a" (fun ppf l -> List.iter l ~f:(fun x -> printer ppf x; Caml.Format.pp_print_newline ppf ())) l in let is_ws = function (' '|'\t'|'\r') -> true | _ -> false in let strip_ws s i len = let len = ref len in while (!len > 0 && is_ws s.[i + !len - 1]) do len := !len - 1 done; String.sub s ~pos:i ~len:!len in let rec loop s pos = if pos >= String.length s then [] else let idx = match String.index_from s pos '\n' with | Some i -> i | None -> String.length s in strip_ws s pos (idx - pos) :: "\n" :: loop s (idx + 1) in String.concat ~sep:"" (loop s 0) end open Replacement module Replacements = struct type t = Replacement.t list (* Merge locations of the generated code. Overlapping locations are merged into one. The result is sorted from the beginning of the file to the end. *) let check_and_sort ~input_filename ~input_name repls = List.iter repls ~f:(fun repl -> if String.(<>) repl.start.pos_fname input_name || String.(<>) repl.stop .pos_fname input_name then Location.raise_errorf ~loc:(Location.in_file input_filename) "ppxlib_driver: the rewriting contains parts from another file.\n\ It is too complicated to reconcile it with the source"; assert (repl.start.pos_cnum <= repl.stop.pos_cnum)); let repls = List.sort repls ~compare:(fun a b -> let d = compare a.start.pos_cnum b.stop.pos_cnum in if d = 0 then (* Put the largest first, so that the following [filter] functions always picks up the lartest first when several generated repls start at the same position *) compare b.stop.pos_cnum a.stop.pos_cnum else d) in let rec filter prev repls ~acc = match repls with | [] -> List.rev (prev :: acc) | repl :: repls -> if prev.stop.pos_cnum > repl.start.pos_cnum then begin if prev.stop.pos_cnum >= repl.stop.pos_cnum then (* [repl] is included in [prev] => skip [repl] *) filter prev repls ~acc else Location.raise_errorf "ppxlib_driver: locations of generated code are overlapping, cannot reconcile" ~loc:{ loc_start = repl.start; loc_end = prev.stop; loc_ghost = false }; end else filter repl repls ~acc:(prev :: acc) in match repls with | [] -> [] | repl :: repls -> filter repl repls ~acc:[] ;; end let count_newlines s = let n = ref 0 in String.iter s ~f:(function | '\n' -> n := !n + 1 | _ -> ()); !n let generated_code_begin = "(* -----{ GENERATED CODE BEGIN }------------------------------------- *)" let generated_code_end = "(* -----{ GENERATED CODE END }------------------------------------- *)" type mode = | Using_line_directives | Delimiting_generated_blocks type target = | Output of mode | Corrected let skip_blank_eol contents (pos : Lexing.position) = let rec loop cnum = if cnum = String.length contents then { pos with pos_cnum = cnum } else match contents.[cnum] with | ' ' | '\t' | '\r' -> loop (cnum + 1) | '\n' -> { pos with pos_cnum = cnum + 1 ; pos_lnum = pos.pos_lnum + 1 ; pos_bol = cnum + 1 } | _ -> pos in loop pos.pos_cnum let with_output ~styler ~(kind:Kind.t) fn ~f = match styler with | None -> with_output fn ~binary:false ~f | Some cmd -> let tmp_fn, oc = Caml.Filename.open_temp_file "ppxlib_driver" (match kind with Impl -> ".ml" | Intf -> ".mli") in let cmd = Printf.sprintf "%s %s%s" cmd (Caml.Filename.quote tmp_fn) (match fn with | None -> "" | Some fn -> " > " ^ Caml.Filename.quote fn) in let n = Exn.protectx tmp_fn ~finally:Caml.Sys.remove ~f:(fun _ -> Exn.protectx oc ~finally:Out_channel.close ~f:f; Caml.Sys.command cmd) in if n <> 0 then begin eprintf "command exited with code %d: %s\n" n cmd; Caml.exit 1 end let reconcile ?styler (repls : Replacements.t) ~kind ~contents ~input_filename ~output ~input_name ~target = let repls = Replacements.check_and_sort ~input_filename ~input_name repls in let output_name = match output with | None -> "" | Some fn -> fn in with_output output ~styler ~kind ~f:(fun oc -> let copy_input pos ~up_to ~line ~last_is_text ~is_text = let pos = if last_is_text then pos else skip_blank_eol contents pos in if pos.pos_cnum < up_to then begin (match target with | Output Using_line_directives -> Out_channel.fprintf oc "# %d %S\n%*s" pos.pos_lnum input_name (pos.pos_cnum - pos.pos_bol) "" | Output Delimiting_generated_blocks | Corrected -> ()); Out_channel.output_substring oc ~buf:contents ~pos:pos.pos_cnum ~len:(up_to - pos.pos_cnum); let line = ref (line + 1) in for i = pos.pos_cnum to up_to - 1 do if Char.equal contents.[i] '\n' then line := !line + 1 done; let line = !line in if not is_text && Char.(<>) contents.[up_to - 1] '\n' then (Out_channel.output_char oc '\n'; line + 1) else line end else line in let rec loop line (pos : Lexing.position) repls ~last_is_text = match repls with | [] -> ignore (copy_input pos ~up_to:(String.length contents) ~line ~last_is_text ~is_text:false : int) | repl :: repls -> let is_text = match repl.data with | Text _ -> true | Values _ -> false in let line = copy_input pos ~up_to:repl.start.pos_cnum ~line ~last_is_text ~is_text in let s = Replacement.text repl in let line = match target with | Output Using_line_directives -> Out_channel.fprintf oc "# %d %S\n" (line + 1) output_name; line + 1 | Output Delimiting_generated_blocks -> Out_channel.fprintf oc "%s\n" generated_code_begin; line + 1 | Corrected -> line in Out_channel.output_string oc s; let line = line + count_newlines s in loop_consecutive_repls line repl.stop repls ~last_is_text:is_text and loop_consecutive_repls line (pos : Lexing.position) repls ~last_is_text = match repls with | [] -> end_consecutive_repls line pos repls ~last_is_text | repl :: repls' -> let pos = if last_is_text then pos else skip_blank_eol contents pos in if pos.pos_cnum < repl.start.pos_cnum then end_consecutive_repls line pos repls ~last_is_text else begin let s = Replacement.text repl in Out_channel.output_string oc s; let line = line + count_newlines s in let last_is_text = match repl.data with | Text _ -> true | Values _ -> false in loop_consecutive_repls line repl.stop repls' ~last_is_text end and end_consecutive_repls line pos repls ~last_is_text = (match target with | Output Using_line_directives | Corrected -> () | Output Delimiting_generated_blocks -> Out_channel.fprintf oc "%s\n" generated_code_end); loop line pos repls ~last_is_text in let pos = { Lexing. pos_fname = input_name ; pos_lnum = 1 ; pos_bol = 0 ; pos_cnum = 0 } in match repls with | { start = { pos_cnum = 0; _ }; _ } :: _ -> (match target with | Output Using_line_directives | Corrected -> () | Output Delimiting_generated_blocks -> Out_channel.fprintf oc "%s\n" generated_code_begin); loop_consecutive_repls 1 pos repls ~last_is_text:false | _ -> loop 1 pos repls ~last_is_text:false) ppxlib-0.12.0/src/reconcile.mli000066400000000000000000000014751360512673700163460ustar00rootroot00000000000000open Import open Utils module Context : sig type 'a t = | Extension of 'a Extension.Context.t | Floating_attribute of 'a Attribute.Floating.Context.t end module Replacement : sig type t val make : context:'a Context.t -> start:Lexing.position -> stop:Lexing.position -> repl:'a Context_free.Generated_code_hook.single_or_many -> unit -> t val make_text : start:Lexing.position -> stop:Lexing.position -> repl:string -> unit -> t end type mode = | Using_line_directives | Delimiting_generated_blocks type target = | Output of mode | Corrected val reconcile : ?styler:string -> Replacement.t list -> kind:Kind.t -> contents:string -> input_filename:string -> output:string option -> input_name:string -> target:target -> unit ppxlib-0.12.0/src/spellcheck.ml000066400000000000000000000017001360512673700163360ustar00rootroot00000000000000open! Import let spellcheck names name = let cutoff = match String.length name with | 1 | 2 -> 0 | 3 | 4 -> 1 | 5 | 6 -> 2 | _ -> 3 in let _, suggestions = List.fold_left names ~init:(Int.max_value, []) ~f:(fun ((best_distance, names_at_best_distance) as acc) registered_name -> match Ocaml_common.Misc.edit_distance name registered_name cutoff with | None -> acc | Some dist -> if dist < best_distance then (dist, [registered_name]) else if dist > best_distance then acc else (dist, registered_name :: names_at_best_distance)) in match List.rev suggestions |> List.filter ~f:(String.(<>) name) with | [] -> None | last :: rev_rest -> Some (Printf.sprintf "Hint: Did you mean %s%s%s?" (String.concat ~sep:", " (List.rev rev_rest)) (if List.is_empty rev_rest then "" else " or ") last) ;; ppxlib-0.12.0/src/utils.ml000066400000000000000000000063211360512673700153650ustar00rootroot00000000000000open Import let with_output fn ~binary ~f = match fn with | None | Some "-" -> f stdout | Some fn -> Out_channel.with_file fn ~binary ~f ;; module Kind = struct type t = Intf | Impl let of_filename fn : t option = if Caml.Filename.check_suffix fn ".ml" then Some Impl else if Caml.Filename.check_suffix fn ".mli" then Some Intf else None ;; let describe = function | Impl -> "implementation" | Intf -> "interface" ;; let equal : t -> t -> bool = Poly.equal end module Some_intf_or_impl = struct type t = | Intf of Migrate_parsetree.Driver.some_signature | Impl of Migrate_parsetree.Driver.some_structure let to_ast_io (ast : t) ~add_ppx_context = let open Migrate_parsetree in match ast with | Intf (Migrate_parsetree.Driver.Sig ((module Ver), sg)) -> let sg = (Migrate_parsetree.Versions.migrate (module Ver) (module Versions.OCaml_current)).copy_signature sg in let sg = if add_ppx_context then Ocaml_common.Ast_mapper.add_ppx_context_sig ~tool_name:"ppxlib_driver" sg else sg in Ast_io.Intf ((module Versions.OCaml_current), sg) | Impl (Migrate_parsetree.Driver.Str ((module Ver), st)) -> let st = (Migrate_parsetree.Versions.migrate (module Ver) (module Versions.OCaml_current)).copy_structure st in let st = if add_ppx_context then Ocaml_common.Ast_mapper.add_ppx_context_str ~tool_name:"ppxlib_driver" st else st in Ast_io.Impl ((module Versions.OCaml_current), st) end module Intf_or_impl = struct type t = | Intf of signature | Impl of structure let map t (map : Ast_traverse.map) = match t with | Impl x -> Impl (map#structure x) | Intf x -> Intf (map#signature x) ;; let map_with_context t (map : _ Ast_traverse.map_with_context) ctx = match t with | Impl x -> Impl (map#structure ctx x) | Intf x -> Intf (map#signature ctx x) ;; let kind : _ -> Kind.t = function | Intf _ -> Intf | Impl _ -> Impl let of_some_intf_or_impl ast : t = let open Some_intf_or_impl in match ast with | Intf (Migrate_parsetree.Driver.Sig ((module Ver), sg)) -> Intf ((Migrate_parsetree.Versions.migrate (module Ver) (module Ppxlib_ast.Selected_ast)).copy_signature sg) | Impl (Migrate_parsetree.Driver.Str ((module Ver), st)) -> Impl ((Migrate_parsetree.Versions.migrate (module Ver) (module Ppxlib_ast.Selected_ast)).copy_structure st) let of_ast_io ast : t = let open Migrate_parsetree in match ast with | Ast_io.Intf ((module Ver), sg) -> let module C = Versions.Convert(Ver)(Ppxlib_ast.Selected_ast) in Intf (C.copy_signature sg) | Ast_io.Impl ((module Ver), st) -> let module C = Versions.Convert(Ver)(Ppxlib_ast.Selected_ast) in Impl (C.copy_structure st) end (* let map_impl x ~(f : _ Intf_or_impl.t -> _ Intf_or_impl.t) = match f (Impl x) with | Impl x -> x | Intf _ -> assert false let map_intf x ~(f : _ Intf_or_impl.t -> _ Intf_or_impl.t) = match f (Intf x) with | Intf x -> x | Impl _ -> assert false *) ppxlib-0.12.0/test/000077500000000000000000000000001360512673700140615ustar00rootroot00000000000000ppxlib-0.12.0/test/base/000077500000000000000000000000001360512673700147735ustar00rootroot00000000000000ppxlib-0.12.0/test/base/dune000066400000000000000000000004261360512673700156530ustar00rootroot00000000000000(alias (name runtest) (deps (:test test.ml) (glob_files %{project_root}/src/.ppxlib.objs/byte/*.cmi)) (action (chdir %{project_root} (progn (ignore-outputs (run %{project_root}/test/expect/expect_test.exe %{test})) (diff? %{test} %{test}.corrected))))) ppxlib-0.12.0/test/base/test.ml000066400000000000000000000063521360512673700163120ustar00rootroot00000000000000#use "topfind";; #require "base";; #require "stdio";; let () = Printexc.record_backtrace false open Base open Stdio open Ppxlib module N = Ppxlib_private.Name [%%expect{| module N = Ppxlib.Ppxlib_private.Name |}] let dot_suffixes name = Caml.Printf.sprintf "%s" (Sexp.to_string_hum (List.sexp_of_t String.sexp_of_t (N.dot_suffixes name))) [%%expect{| val dot_suffixes : string -> string = |}] let _ = dot_suffixes "foo.bar.baz" [%%expect{| - : string = "(baz bar.baz foo.bar.baz)" |}] let _ = dot_suffixes "foo.@bar.baz" [%%expect{| - : string = "(bar.baz foo.bar.baz)" |}] let split_path name = let a, b = N.split_path name in Caml.Printf.sprintf "%s" (Sexp.to_string_hum (List [sexp_of_string a; Option.sexp_of_t sexp_of_string b])) [%%expect{| val split_path : string -> string = |}] let _ = split_path "a.b.c" [%%expect{| - : string = "(a.b.c ())" |}] let _ = split_path "a.b.c.D" [%%expect{| - : string = "(a.b.c (D))" |}] let _ = split_path ".D" [%%expect{| - : string = "(\"\" (D))" |}] let convert_longident string = let lident = Longident.parse string in let name = Longident.name lident in (name, lident) [%%expect{| val convert_longident : string -> string * longident = |}] let _ = convert_longident "x" [%%expect{| - : string * longident = ("x", Ppxlib.Longident.Lident "x") |}] let _ = convert_longident "(+)" [%%expect{| - : string * longident = ("( + )", Ppxlib.Longident.Lident "+") |}] let _ = convert_longident "( + )" [%%expect{| - : string * longident = ("( + )", Ppxlib.Longident.Lident "+") |}] let _ = convert_longident "Base.x" [%%expect{| - : string * longident = ("Base.x", Ppxlib.Longident.Ldot (Ppxlib.Longident.Lident "Base", "x")) |}] let _ = convert_longident "Base.(+)" [%%expect{| - : string * longident = ("Base.( + )", Ppxlib.Longident.Ldot (Ppxlib.Longident.Lident "Base", "+")) |}] let _ = convert_longident "Base.( + )" [%%expect{| - : string * longident = ("Base.( + )", Ppxlib.Longident.Ldot (Ppxlib.Longident.Lident "Base", "+")) |}] let _ = convert_longident "Base.( land )" [%%expect{| - : string * longident = ("Base.( land )", Ppxlib.Longident.Ldot (Ppxlib.Longident.Lident "Base", "land")) |}] let _ = convert_longident "A(B)" [%%expect{| Exception: Invalid_argument "Ppxlib.Longident.parse: \"A(B)\"". |}] let _ = convert_longident "A.B(C)" [%%expect{| Exception: Invalid_argument "Ppxlib.Longident.parse: \"A.B(C)\"". |}] let _ = convert_longident ")" [%%expect{| Exception: Invalid_argument "Ppxlib.Longident.parse: \")\"". |}] let _ = Ppxlib.Code_path.(file_path @@ top_level ~file_path:"dir/main.ml") [%%expect{| - : string = "dir/main.ml" |}] let _ = Ppxlib.Code_path.(fully_qualified_path @@ top_level ~file_path:"dir/main.ml") [%%expect{| - : string = "Main" |}] let complex_path = let open Ppxlib.Code_path in let loc = Ppxlib.Location.none in top_level ~file_path:"dir/main.ml" |> enter_module ~loc "Sub" |> enter_module ~loc "Sub_sub" |> enter_value ~loc "some_val" [%%expect{| val complex_path : Code_path.t = |}] let _ = Ppxlib.Code_path.fully_qualified_path complex_path [%%expect{| - : string = "Main.Sub.Sub_sub.some_val" |}] let _ = Ppxlib.Code_path.to_string_path complex_path [%%expect{| - : string = "dir/main.ml.Sub.Sub_sub" |}] ppxlib-0.12.0/test/code_path/000077500000000000000000000000001360512673700160075ustar00rootroot00000000000000ppxlib-0.12.0/test/code_path/dune000066400000000000000000000004601360512673700166650ustar00rootroot00000000000000(alias (name runtest) (deps (:test test.ml) (glob_files %{project_root}/src/.ppxlib.objs/byte/*.cmi)) (action (chdir %{project_root} (progn (ignore-outputs (run %{project_root}/test/expect/expect_test.exe %{test})) (diff? %{test} %{test}.corrected))))) ppxlib-0.12.0/test/code_path/test.ml000066400000000000000000000020131360512673700173140ustar00rootroot00000000000000#use "topfind";; #require "base";; open Ppxlib let () = Driver.register_transformation "test" ~extensions:[ Extension.V3.declare "code_path" Expression Ast_pattern.(pstr nil) (fun ~ctxt -> let loc = Expansion_context.Extension.extension_point_loc ctxt in let code_path = Expansion_context.Extension.code_path ctxt in Ast_builder.Default.estring ~loc (Code_path.fully_qualified_path code_path)) ] [%%expect{| |}] let s = let module A = struct module A' = struct let a = let module B = struct module B' = struct let b = let module C = struct module C' = struct let c = [%code_path] end end in C.C'.c end end in B.B'.b end end in A.A'.a ;; [%%expect{| val s : string = "Test.s" |}] let module M = struct let m = [%code_path] end in M.m [%%expect{| - : string = "Test" |}] ppxlib-0.12.0/test/deriving/000077500000000000000000000000001360512673700156705ustar00rootroot00000000000000ppxlib-0.12.0/test/deriving/dune000066400000000000000000000004601360512673700165460ustar00rootroot00000000000000(alias (name runtest) (deps (:test test.ml) (glob_files %{project_root}/src/.ppxlib.objs/byte/*.cmi)) (action (chdir %{project_root} (progn (ignore-outputs (run %{project_root}/test/expect/expect_test.exe %{test})) (diff? %{test} %{test}.corrected))))) ppxlib-0.12.0/test/deriving/inline/000077500000000000000000000000001360512673700171465ustar00rootroot00000000000000ppxlib-0.12.0/test/deriving/inline/example/000077500000000000000000000000001360512673700206015ustar00rootroot00000000000000ppxlib-0.12.0/test/deriving/inline/example/dune000066400000000000000000000002421360512673700214550ustar00rootroot00000000000000(library (name ppx_deriving_example) (preprocess (pps ppxlib ppx_foo_deriver ppxlib.runner)) ) (alias (name runtest) (deps ppx_deriving_example.cma) ) ppxlib-0.12.0/test/deriving/inline/example/ppx_deriving_example.ml000066400000000000000000000001371360512673700253450ustar00rootroot00000000000000type t = A [@@deriving_inline foo] let _ = fun (_ : t) -> () let _ = [%foo ] [@@@deriving.end] ppxlib-0.12.0/test/deriving/inline/foo-deriver/000077500000000000000000000000001360512673700213675ustar00rootroot00000000000000ppxlib-0.12.0/test/deriving/inline/foo-deriver/dune000066400000000000000000000001231360512673700222410ustar00rootroot00000000000000(library (kind ppx_deriver) (name ppx_foo_deriver) (libraries base ppxlib) ) ppxlib-0.12.0/test/deriving/inline/foo-deriver/ppx_foo_deriver.ml000066400000000000000000000032131360512673700251120ustar00rootroot00000000000000open Ppxlib (* [[@@deriving foo]] expands to: {[ let _ = [%foo] ]} and then [[%foo]] expands to ["foo"]. *) let add_deriver () = let str_type_decl = Deriving.Generator.make_noarg ( fun ~loc ~path:_ _ -> let expr desc : expression= { pexp_desc = desc; pexp_loc = loc; pexp_attributes = []; pexp_loc_stack = []; } in [ {pstr_loc = loc; pstr_desc = (Pstr_value (Nonrecursive, [{ pvb_pat = { ppat_desc = Ppat_any; ppat_loc = loc; ppat_attributes = []; ppat_loc_stack = []; } ; pvb_expr = expr ( Pexp_extension ({loc; txt = "foo"}, PStr [])); pvb_attributes = []; pvb_loc = loc; }])); } ] ) ~attributes:[] in let sig_type_decl = Deriving.Generator.make_noarg ( fun ~loc ~path decl -> ignore loc; ignore path; ignore decl; [ ] ) in Deriving.add "foo" ~str_type_decl ~sig_type_decl let () = Driver.register_transformation "foo" ~rules:[ Context_free.Rule.extension (Extension.declare "foo" Expression Ast_pattern.__ (fun ~loc ~path:_ _payload -> { pexp_desc = Pexp_constant (Pconst_string ("foo", None)); pexp_loc = loc; pexp_attributes = []; pexp_loc_stack = []; })) ] let (_ : Deriving.t) = add_deriver () ppxlib-0.12.0/test/deriving/test.ml000066400000000000000000000040411360512673700172000ustar00rootroot00000000000000#use "topfind";; #require "base";; #load "ppxlib_metaquot_lifters.cmo";; #load "ppxlib_metaquot.cmo";; open Ppxlib let foo = Deriving.add "foo" ~str_type_decl:(Deriving.Generator.make_noarg (fun ~loc ~path:_ _ -> [%str let x = 42])) ~sig_type_decl:(Deriving.Generator.make_noarg (fun ~loc ~path:_ _ -> [%sig: val y : int])) [%%expect{| val foo : Deriving.t = |}] let bar = Deriving.add "bar" ~str_type_decl:(Deriving.Generator.make_noarg ~deps:[foo] (fun ~loc ~path:_ _ -> [%str let () = Printf.printf "x = %d\n" x])) [%%expect{| val bar : Deriving.t = |}] let mtd = Deriving.add "mtd" ~sig_module_type_decl:( Deriving.Generator.make_noarg (fun ~loc ~path:_ _ -> [%sig: val y : int])) ~str_module_type_decl:( Deriving.Generator.make_noarg (fun ~loc ~path:_ _ -> [%str let y = 42])) [%%expect{| val mtd : Deriving.t = |}] type t = int [@@deriving bar] [%%expect{| Line _, characters 25-28: Error: Deriver foo is needed for bar, you need to add it before in the list |}] type t = int [@@deriving bar, foo] [%%expect{| Line _, characters 25-33: Error: Deriver foo is needed for bar, you need to add it before in the list |}] type nonrec int = int [@@deriving foo, bar] [%%expect{| type nonrec int = int val x : int = 42 |}] module Foo_sig : sig type t [@@deriving foo] end = struct type t end [%%expect{| Line _, characters 6-25: Error: Signature mismatch: Modules do not match: sig type t end is not included in sig type t val y : int end The value `y' is required but not provided File "test/deriving/test.ml", line 3, characters 2-25: Expected declaration |}] module type X = sig end [@@deriving mtd] [%%expect{| module type X = sig end val y : int = 42 |}] module Y : sig module type X = sig end [@@deriving mtd] end = struct module type X = sig end let y = 42 end [%%expect{| module Y : sig module type X = sig end val y : int end |}] ppxlib-0.12.0/test/driver/000077500000000000000000000000001360512673700153545ustar00rootroot00000000000000ppxlib-0.12.0/test/driver/attributes/000077500000000000000000000000001360512673700175425ustar00rootroot00000000000000ppxlib-0.12.0/test/driver/attributes/dune000066400000000000000000000004601360512673700204200ustar00rootroot00000000000000(alias (name runtest) (deps (:test test.ml) (glob_files %{project_root}/src/.ppxlib.objs/byte/*.cmi)) (action (chdir %{project_root} (progn (ignore-outputs (run %{project_root}/test/expect/expect_test.exe %{test})) (diff? %{test} %{test}.corrected))))) ppxlib-0.12.0/test/driver/attributes/test.ml000066400000000000000000000035601360512673700210570ustar00rootroot00000000000000#use "topfind";; #require "base";; open Base open Ppxlib let () = Driver.enable_checks () let x = 1 [@@foo] [%%expect{| Line _, characters 13-16: Error: Attribute `foo' was not used |}] let f x = 1 [@@deprecatd "..."] [%%expect{| Line _, characters 15-24: Error: Attribute `deprecatd' was not used. Hint: Did you mean deprecated? |}] let attr : _ Attribute.t = Attribute.declare "blah" Attribute.Context.type_declaration Ast_pattern.(__) ignore [%%expect{| val attr : (type_declaration, unit) Attribute.t = |}] type t = int [@blah] [%%expect{| Line _, characters 15-19: Error: Attribute `blah' was not used. Hint: `blah' is available for type declarations but is used here in the context of a core type. Did you put it at the wrong level? |}] let attr : _ Attribute.t = Attribute.declare "blah" Attribute.Context.expression Ast_pattern.(__) ignore [%%expect{| val attr : (expression, unit) Attribute.t = |}] type t = int [@blah] [%%expect{| Line _, characters 15-19: Error: Attribute `blah' was not used. Hint: `blah' is available for expressions and type declarations but is used here in the context of a core type. Did you put it at the wrong level? |}] (* Attribute drops *) let faulty_transformation = object inherit Ast_traverse.map as super method! expression e = match e.pexp_desc with | Pexp_constant c -> Ast_builder.Default.pexp_constant ~loc:e.pexp_loc c | _ -> super#expression e end [%%expect{| val faulty_transformation : Ast_traverse.map = |}] let () = Driver.register_transformation "faulty" ~impl:faulty_transformation#structure let x = (42 [@foo]) [%%expect{| Line _, characters 14-17: Error: Attribute `foo' was silently dropped |}] type t1 = < > type t2 = < t1 > type t3 = < (t1[@foo]) > [%%expect{| type t1 = < > type t2 = < > Line _, characters 17-20: Error: Attribute `foo' was not used |}] ppxlib-0.12.0/test/driver/non-compressible-suffix/000077500000000000000000000000001360512673700221355ustar00rootroot00000000000000ppxlib-0.12.0/test/driver/non-compressible-suffix/dune000066400000000000000000000004601360512673700230130ustar00rootroot00000000000000(alias (name runtest) (deps (:test test.ml) (glob_files %{project_root}/src/.ppxlib.objs/byte/*.cmi)) (action (chdir %{project_root} (progn (ignore-outputs (run %{project_root}/test/expect/expect_test.exe %{test})) (diff? %{test} %{test}.corrected))))) ppxlib-0.12.0/test/driver/non-compressible-suffix/test.ml000066400000000000000000000013501360512673700234450ustar00rootroot00000000000000#use "topfind";; #require "base";; #require "stdio";; open Ppxlib;; open Ast_builder.Default;; Driver.register_transformation "blah" ~rules:[ Context_free.Rule.extension (Extension.declare "foo" Expression Ast_pattern.(pstr nil) (fun ~loc ~path:_ -> eint ~loc 42)) ; Context_free.Rule.extension (Extension.declare "@foo.bar" Expression Ast_pattern.(pstr nil) (fun ~loc ~path:_ -> eint ~loc 42)) ] ;; [%%expect{| - : unit = () |}] [%foo];; [%%expect{| - : int = 42 |}] [%foo.bar];; [%%expect{| - : int = 42 |}] [%bar];; [%%expect{| Line _, characters 2-5: Error: Uninterpreted extension 'bar'. |}] ppxlib-0.12.0/test/driver/omp-integration/000077500000000000000000000000001360512673700204705ustar00rootroot00000000000000ppxlib-0.12.0/test/driver/omp-integration/omp-ppx/000077500000000000000000000000001360512673700220705ustar00rootroot00000000000000ppxlib-0.12.0/test/driver/omp-integration/omp-ppx/dune000066400000000000000000000002111360512673700227400ustar00rootroot00000000000000(library (name ppxlib_driver_omp_test_ppx) (kind ppx_rewriter) (flags (:standard -safe-string)) (libraries ocaml-migrate-parsetree)) ppxlib-0.12.0/test/driver/omp-integration/omp-ppx/main.ml000066400000000000000000000006751360512673700233560ustar00rootroot00000000000000open Migrate_parsetree open Ast_403 let mapper = let super = Ast_mapper.default_mapper in let expr self (e : Parsetree.expression) = match e.pexp_desc with | Pexp_extension ({ txt = "omp_test"; _ }, _) -> { e with pexp_desc = Pexp_constant (Pconst_integer ("42", None)) } | _ -> super.expr self e in { super with expr } let () = Driver.register ~name:"omp_test" (module OCaml_403) (fun _ _ -> mapper) ppxlib-0.12.0/test/driver/omp-integration/ppxlib-ppx/000077500000000000000000000000001360512673700225735ustar00rootroot00000000000000ppxlib-0.12.0/test/driver/omp-integration/ppxlib-ppx/dune000066400000000000000000000001471360512673700234530ustar00rootroot00000000000000(library (name ppxlib_ppx) (kind ppx_rewriter) (flags (:standard -safe-string)) (libraries ppxlib))ppxlib-0.12.0/test/driver/omp-integration/ppxlib-ppx/ppxlib_ppx.ml000066400000000000000000000006701360512673700253150ustar00rootroot00000000000000open Ppxlib let () = Driver.register_transformation "plop" ~rules:[ Context_free.Rule.extension (Extension.declare_with_path_arg "plop" Expression Ast_pattern.(pstr nil) (fun ~loc ~path:_ ~arg -> let open Ast_builder.Default in match arg with | None -> estring ~loc "-" | Some { loc; txt } -> estring ~loc (Longident.name txt)))] ppxlib-0.12.0/test/driver/omp-integration/test/000077500000000000000000000000001360512673700214475ustar00rootroot00000000000000ppxlib-0.12.0/test/driver/omp-integration/test/dune000066400000000000000000000001601360512673700223220ustar00rootroot00000000000000(test (name test) (flags (:standard -safe-string)) (preprocess (pps ppxlib_driver_omp_test_ppx ppxlib_ppx))) ppxlib-0.12.0/test/driver/omp-integration/test/test.expected000066400000000000000000000000121360512673700241420ustar00rootroot00000000000000Foobar 42 ppxlib-0.12.0/test/driver/omp-integration/test/test.ml000066400000000000000000000000761360512673700227630ustar00rootroot00000000000000let () = Printf.printf "%s %d\n" [%plop.Foobar] [%omp_test] ppxlib-0.12.0/test/driver/skip-hash-bang/000077500000000000000000000000001360512673700201505ustar00rootroot00000000000000ppxlib-0.12.0/test/driver/skip-hash-bang/dune000066400000000000000000000001271360512673700210260ustar00rootroot00000000000000(test (name test) (flags (:standard -safe-string)) (preprocess (pps ppxlib.runner)))ppxlib-0.12.0/test/driver/skip-hash-bang/test.expected000066400000000000000000000000031360512673700226430ustar00rootroot00000000000000OK ppxlib-0.12.0/test/driver/skip-hash-bang/test.ml000066400000000000000000000000541360512673700214600ustar00rootroot00000000000000#!ignored_line let () = print_endline "OK" ppxlib-0.12.0/test/driver/transformations/000077500000000000000000000000001360512673700206055ustar00rootroot00000000000000ppxlib-0.12.0/test/driver/transformations/dune000066400000000000000000000004601360512673700214630ustar00rootroot00000000000000(alias (name runtest) (deps (:test test.ml) (glob_files %{project_root}/src/.ppxlib.objs/byte/*.cmi)) (action (chdir %{project_root} (progn (ignore-outputs (run %{project_root}/test/expect/expect_test.exe %{test})) (diff? %{test} %{test}.corrected))))) ppxlib-0.12.0/test/driver/transformations/test.ml000066400000000000000000000032731360512673700221230ustar00rootroot00000000000000#use "topfind";; #require "base";; #require "ocaml-migrate-parsetree";; open Base open Ppxlib (* Linters *) let lint = object inherit [Driver.Lint_error.t list] Ast_traverse.fold as super method! type_declaration td acc = let acc = super#type_declaration td acc in match td.ptype_kind with | Ptype_record lds -> if Poly.(<>) (List.sort lds ~compare:(fun a b -> String.compare a.pld_name.txt b.pld_name.txt)) lds then Driver.Lint_error.of_string { td.ptype_loc with loc_ghost = true } "Fields are not sorted!" :: acc else acc | _ -> acc end let () = Driver.register_transformation "lint" ~lint_impl:(fun st -> lint#structure st []) [%%expect{| val lint : Driver.Lint_error.t list Ast_traverse.fold = |}] type t = { b : int ; a : int } [%%expect{| Line _, characters 0-36: Error (warning 22): Fields are not sorted! |}] (* Extension with a path argument *) let () = Driver.register_transformation "plop" ~rules:[Context_free.Rule.extension (Extension.declare_with_path_arg "plop" Expression Ast_pattern.(pstr nil) (fun ~loc ~path:_ ~arg -> let open Ast_builder.Default in match arg with | None -> estring ~loc "-" | Some { loc; txt } -> estring ~loc (Longident.name txt)))] [%%expect{| |}] let _ = Caml.Printf.sprintf "%s\n" [%plop] [%%expect{| - : string = "-\n" |}] let _ = Caml.Printf.sprintf "%s\n" [%plop.Truc] [%%expect{| - : string = "Truc\n" |}] let _ = Caml.Printf.sprintf "%s\n" [%plop.Truc.Bidule] [%%expect{| - : string = "Truc.Bidule\n" |}] ppxlib-0.12.0/test/expect/000077500000000000000000000000001360512673700153515ustar00rootroot00000000000000ppxlib-0.12.0/test/expect/dune000066400000000000000000000005541360512673700162330ustar00rootroot00000000000000(executable (name expect_test) (modules expect_test printers) (link_flags (-linkall)) (modes byte) (libraries unix compiler-libs.toplevel ppxlib ppxlib.traverse)) (rule (deps printers_lt_408.ml printers_ge_408.ml) (targets printers.ml) (action (with-stdout-to printers.ml (run %{ocaml} %{dep:gen-printers} %{ocaml_version})))) (ocamllex expect_test) ppxlib-0.12.0/test/expect/expect_test.mll000066400000000000000000000062301360512673700204070ustar00rootroot00000000000000{ open StdLabels let read_file file = let ic = open_in_bin file in let len = in_channel_length ic in let file_contents = really_input_string ic len in close_in ic; file_contents let run_expect_test file ~f = let file_contents = read_file file in let lexbuf = Lexing.from_string file_contents in lexbuf.lex_curr_p <- { pos_fname = file ; pos_cnum = 0 ; pos_lnum = 1 ; pos_bol = 0 }; let expected = f file_contents lexbuf in let corrected_file = file ^ ".corrected" in if file_contents <> expected then begin let oc = open_out_bin corrected_file in output_string oc expected; close_out oc; end else begin if Sys.file_exists corrected_file then Sys.remove corrected_file; exit 0 end } rule code txt start = parse | "[%%expect{|\n" { let pos = start.Lexing.pos_cnum in let len = Lexing.lexeme_start lexbuf - pos in let s = String.sub txt ~pos ~len in Lexing.new_line lexbuf; (start, s) :: expectation txt lexbuf } | [^'\n']*'\n' { Lexing.new_line lexbuf; code txt start lexbuf } | eof { let pos = start.Lexing.pos_cnum in let len = String.length txt - pos in if pos > 0 then begin let s = String.sub txt ~pos ~len in if String.trim s = "" then [] else [(start, s)] end else [] } and expectation txt = parse | "|}]\n" { Lexing.new_line lexbuf; code txt lexbuf.lex_curr_p lexbuf } | [^'\n']*'\n' { Lexing.new_line lexbuf; expectation txt lexbuf } { let apply_rewriters : (Parsetree.toplevel_phrase -> Parsetree.toplevel_phrase) = function | Ptop_dir _ as x -> x | Ptop_def s -> let s = Ppxlib.Selected_ast.of_ocaml Structure s in Ptop_def (Ppxlib.Driver.map_structure s |> Migrate_parsetree.Driver.migrate_some_structure (module Migrate_parsetree.OCaml_current)) ;; let main () = run_expect_test Sys.argv.(1) ~f:(fun file_contents lexbuf -> let chunks = code file_contents lexbuf.lex_curr_p lexbuf in Warnings.parse_options false "@a-4-29-40-41-42-44-45-48-58"; Clflags.real_paths := false; Toploop.initialize_toplevel_env (); List.iter [ "ast/.ppxlib_ast.objs" ; "src/.ppxlib.objs" ; "metaquot_lifters/.ppxlib_metaquot_lifters.objs" ; "metaquot/.ppxlib_metaquot.objs" ; "traverse/.ppxlib_traverse.objs" ] ~f:(fun d -> Topdirs.dir_directory (d ^ "/byte")); let buf = Buffer.create (String.length file_contents + 1024) in let ppf = Format.formatter_of_buffer buf in Printers.setup ppf; List.iter chunks ~f:(fun (pos, s) -> Format.fprintf ppf "%s[%%%%expect{|@." s; let lexbuf = Lexing.from_string s in lexbuf.lex_curr_p <- { pos with pos_lnum = 1; }; let phrases = !Toploop.parse_use_file lexbuf in List.iter phrases ~f:(fun phr -> try ignore (Toploop.execute_phrase true ppf (apply_rewriters phr) : bool) with exn -> Location.report_exception ppf exn ); Format.fprintf ppf "@?|}]@."); Buffer.contents buf) let () = try main () with exn -> Location.report_exception Format.err_formatter exn; exit 1 } ppxlib-0.12.0/test/expect/gen-printers000066400000000000000000000006561360512673700177200ustar00rootroot00000000000000(* -*- tuareg -*- *) let () = let ocaml_major, ocaml_minor = Scanf.sscanf Sys.argv.(1) "%u.%u" (fun a b -> (a, b)) in let file = if ocaml_major > 4 || ocaml_major = 4 && ocaml_minor >= 8 then "printers_ge_408.ml" else "printers_lt_408.ml" in let channel = open_in file in try while true do print_endline (input_line channel) done with End_of_file -> close_in_noerr channel ppxlib-0.12.0/test/expect/printers_ge_408.ml000066400000000000000000000013441360512673700206210ustar00rootroot00000000000000let print_loc _ _ ppf (loc : Location.t) = let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in Format.fprintf ppf "Line _"; if startchar >= 0 then Format.fprintf ppf ", characters %d-%d" startchar endchar; Format.fprintf ppf ":@."; ;; let report_printer () = let printer = Location.default_report_printer () in { printer with Location. pp_main_loc = print_loc; pp_submsg_loc = print_loc; } ;; let setup ppf = Location.formatter_for_warnings := ppf; Location.warning_reporter := Location.default_warning_reporter; Location.report_printer := report_printer; Location.alert_reporter := Location.default_alert_reporter; ;; ppxlib-0.12.0/test/expect/printers_lt_408.ml000066400000000000000000000020241360512673700206410ustar00rootroot00000000000000let print_loc ppf (loc : Location.t) = let startchar = loc.loc_start.pos_cnum - loc.loc_start.pos_bol in let endchar = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum + startchar in Format.fprintf ppf "Line _"; if startchar >= 0 then Format.fprintf ppf ", characters %d-%d" startchar endchar; Format.fprintf ppf ":@."; ;; let warning_printer loc ppf w = match Warnings.report w with | `Inactive -> () | `Active { Warnings. number; message; is_error; sub_locs = _ } -> print_loc ppf loc; if is_error then Format.fprintf ppf "Error (warning %d): %s@." number message else Format.fprintf ppf "Warning %d: %s@." number message ;; let rec error_reporter ppf {Location.loc; msg; sub; if_highlight=_} = print_loc ppf loc; Format.fprintf ppf "Error: %s" msg; List.iter (fun err -> Format.fprintf ppf "@\n@[<2>%a@]" error_reporter err) sub ;; let setup ppf = Location.formatter_for_warnings := ppf; Location.warning_printer := warning_printer; Location.error_reporter := error_reporter; ;; ppxlib-0.12.0/test/quoter/000077500000000000000000000000001360512673700154005ustar00rootroot00000000000000ppxlib-0.12.0/test/quoter/dune000066400000000000000000000004601360512673700162560ustar00rootroot00000000000000(alias (name runtest) (deps (:test test.ml) (glob_files %{project_root}/src/.ppxlib.objs/byte/*.cmi)) (action (chdir %{project_root} (progn (ignore-outputs (run %{project_root}/test/expect/expect_test.exe %{test})) (diff? %{test} %{test}.corrected))))) ppxlib-0.12.0/test/quoter/test.ml000066400000000000000000000245031360512673700167150ustar00rootroot00000000000000#use "topfind";; #require "base";; #load "ppxlib_metaquot_lifters.cmo";; #load "ppxlib_metaquot.cmo";; open Ppxlib module Ast = Ast_builder.Default [%%expect{| module Ast = Ppxlib.Ast_builder.Default |}] let quoter = Quoter.create ();; [%%expect{| val quoter : Quoter.t = |}] #install_printer Pprintast.expression;; let expr1 = Ast.evar "foo" ~loc:Location.none |> Quoter.quote quoter [%%expect{| val expr1 : expression = {Ppxlib__.Import.pexp_desc = Ppxlib__.Import.Pexp_ident {Ppxlib__.Import.txt = Ppxlib__.Import.Lident "__0"; loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_end = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_ghost = true}}; pexp_loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_end = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_ghost = true}; pexp_loc_stack = []; pexp_attributes = []} |}] Pprintast.string_of_expression expr1;; [%%expect{| - : string = "__0" |}] let expr2 = Ast_builder.Default.evar ~loc:Location.none "bar" |> Quoter.quote quoter [%%expect{| val expr2 : expression = {Ppxlib__.Import.pexp_desc = Ppxlib__.Import.Pexp_ident {Ppxlib__.Import.txt = Ppxlib__.Import.Lident "__1"; loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_end = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_ghost = true}}; pexp_loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_end = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_ghost = true}; pexp_loc_stack = []; pexp_attributes = []} |}] let quoted = let expr = Ast.elist ~loc:Location.none [expr1; expr2] in Quoter.sanitize quoter expr [%%expect{| val quoted : expression = {Ppxlib__.Import.pexp_desc = Ppxlib__.Import.Pexp_let (Ppxlib__.Import.Recursive, [{Ppxlib__.Import.pvb_pat = {Ppxlib__.Import.ppat_desc = Ppxlib__.Import.Ppat_var {Ppxlib__.Import.txt = "__1"; loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_end = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_ghost = true}}; ppat_loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_end = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_ghost = true}; ppat_loc_stack = []; ppat_attributes = []}; pvb_expr = {Ppxlib__.Import.pexp_desc = Ppxlib__.Import.Pexp_fun (Ppxlib__.Import.Nolabel, None, {Ppxlib__.Import.ppat_desc = Ppxlib__.Import.Ppat_construct ({Ppxlib__.Import.txt = Ppxlib__.Import.Lident "()"; loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_end = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_ghost = true}}, None); ppat_loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_end = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_ghost = true}; ppat_loc_stack = []; ppat_attributes = []}, {Ppxlib__.Import.pexp_desc = Ppxlib__.Import.Pexp_ident {Ppxlib__.Import.txt = Ppxlib__.Import.Lident "bar"; loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_end = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_ghost = true}}; pexp_loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_end = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_ghost = true}; pexp_loc_stack = []; pexp_attributes = []}); pexp_loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_end = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_ghost = true}; pexp_loc_stack = []; pexp_attributes = []}; pvb_attributes = []; pvb_loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_end = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_ghost = true}}; {Ppxlib__.Import.pvb_pat = {Ppxlib__.Import.ppat_desc = Ppxlib__.Import.Ppat_var {Ppxlib__.Import.txt = "__0"; loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_end = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_ghost = true}}; ppat_loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_end = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_ghost = true}; ppat_loc_stack = []; ppat_attributes = []}; pvb_expr = {Ppxlib__.Import.pexp_desc = Ppxlib__.Import.Pexp_fun (Ppxlib__.Import.Nolabel, None, {Ppxlib__.Import.ppat_desc = Ppxlib__.Import.Ppat_construct ({Ppxlib__.Import.txt = Ppxlib__.Import.Lident "()"; loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_end = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_ghost = true}}, None); ppat_loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_end = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_ghost = true}; ppat_loc_stack = []; ppat_attributes = []}, {Ppxlib__.Import.pexp_desc = Ppxlib__.Import.Pexp_ident {Ppxlib__.Import.txt = Ppxlib__.Import.Lident "foo"; loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_end = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_ghost = true}}; pexp_loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_end = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_ghost = true}; pexp_loc_stack = []; pexp_attributes = []}); pexp_loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_end = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_ghost = true}; pexp_loc_stack = []; pexp_attributes = []}; pvb_attributes = []; pvb_loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_end = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_ghost = true}}], {Ppxlib__.Import.pexp_desc = Ppxlib__.Import.Pexp_construct ({Ppxlib__.Import.txt = Ppxlib__.Import.Lident "::"; loc = {Ppxlib__.Import.loc_start = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_end = {Ppxlib__.Import.pos_fname = "_none_"; pos_lnum = 1; pos_bol = 0; pos_cnum = -1}; loc_ghost = true}}, Some {Ppxlib__.Import.pexp_desc = Ppxlib__.Import.Pexp_tuple [{Ppxlib__.Import.pexp_desc = Ppxlib__.Import.Pexp_ident ...; pexp_loc = ...; pexp_loc_stack = ...; pexp_attributes = ...}; ...]; pexp_loc = ...; pexp_loc_stack = ...; pexp_attributes = ...}); pexp_loc = ...; pexp_loc_stack = ...; pexp_attributes = ...}); pexp_loc = ...; pexp_loc_stack = ...; pexp_attributes = ...} |}] Pprintast.string_of_expression quoted;; [%%expect{| - : string = "let rec __1 () = bar\nand __0 () = foo in [__0; __1]" |}] ppxlib-0.12.0/test/traverse/000077500000000000000000000000001360512673700157145ustar00rootroot00000000000000ppxlib-0.12.0/test/traverse/dune000066400000000000000000000004601360512673700165720ustar00rootroot00000000000000(alias (name runtest) (deps (:test test.ml) (glob_files %{project_root}/src/.ppxlib.objs/byte/*.cmi)) (action (chdir %{project_root} (progn (ignore-outputs (run %{project_root}/test/expect/expect_test.exe %{test})) (diff? %{test} %{test}.corrected))))) ppxlib-0.12.0/test/traverse/test.ml000066400000000000000000000022001360512673700172170ustar00rootroot00000000000000#load "ppxlib_traverse.cmo";; type t = { x : int ; y : u } and u = A of int | B of t [@@deriving traverse] [%%expect{| type t = { x : int; y : u; } and u = A of int | B of t class virtual map : object method virtual int : int -> int method t : t -> t method u : u -> u end class virtual iter : object method virtual int : int -> unit method t : t -> unit method u : u -> unit end class virtual ['acc] fold : object method virtual int : int -> 'acc -> 'acc method t : t -> 'acc -> 'acc method u : u -> 'acc -> 'acc end class virtual ['acc] fold_map : object method virtual int : int -> 'acc -> int * 'acc method t : t -> 'acc -> t * 'acc method u : u -> 'acc -> u * 'acc end class virtual ['ctx] map_with_context : object method virtual int : 'ctx -> int -> int method t : 'ctx -> t -> t method u : 'ctx -> u -> u end class virtual ['res] lift : object method virtual constr : string -> 'res list -> 'res method virtual int : int -> 'res method virtual record : (string * 'res) list -> 'res method t : t -> 'res method u : u -> 'res end |}] ppxlib-0.12.0/traverse/000077500000000000000000000000001360512673700147355ustar00rootroot00000000000000ppxlib-0.12.0/traverse/dune000066400000000000000000000003061360512673700156120ustar00rootroot00000000000000(library (name ppxlib_traverse) (public_name ppxlib.traverse) (kind ppx_rewriter) (flags (:standard -safe-string)) (libraries ppxlib) (preprocess (pps ppxlib_metaquot ppxlib.runner))) ppxlib-0.12.0/traverse/ppxlib_traverse.ml000066400000000000000000000407001360512673700205010ustar00rootroot00000000000000open Base open Ppxlib open Ast_builder.Default let alphabet = Array.init (Char.to_int 'z' - Char.to_int 'a' + 1) ~f:(fun i -> String.make 1 (Char.of_int_exn (i + Char.to_int 'a'))) ;; let vars_of_list ~get_loc l = List.mapi l ~f:(fun i x -> { txt = alphabet.(i); loc = get_loc x }) let evar_of_var { txt; loc } = evar ~loc txt let pvar_of_var { txt; loc } = pvar ~loc txt let tvar_of_var { txt; loc } = ptyp_var ~loc txt let evars_of_vars = List.map ~f:evar_of_var let pvars_of_vars = List.map ~f:pvar_of_var let tvars_of_vars = List.map ~f:tvar_of_var module Backends = struct class reconstructors = object method record ~loc flds = pexp_record ~loc flds None method construct ~loc id args = pexp_construct ~loc id (match args with | [] -> None | _ -> Some (pexp_tuple ~loc args)) method tuple ~loc es = pexp_tuple ~loc es end class type what = object method name : string inherit reconstructors method class_params : loc:Location.t -> (core_type * variance) list method apply : loc:Location.t -> expression -> expression list -> expression method abstract : loc:Location.t -> pattern -> expression -> expression (* Basic combinator type *) method typ : loc:Location.t -> core_type -> core_type method any : loc:Location.t -> expression method combine : loc:Location.t -> (string loc * expression) list -> reconstruct:expression -> expression end let mapper : what = object method name = "map" inherit reconstructors method class_params ~loc:_ = [] method apply ~loc expr args = eapply ~loc expr args method abstract ~loc patt expr = pexp_fun ~loc Nolabel None patt expr method typ ~loc ty = ptyp_arrow ~loc Nolabel ty ty method any ~loc = [%expr fun x -> x] method combine ~loc combinators ~reconstruct = List.fold_right combinators ~init:reconstruct ~f:(fun (v, expr) acc -> pexp_let ~loc Nonrecursive [value_binding ~loc ~pat:(pvar_of_var v) ~expr] acc) end let iterator : what = object method name = "iter" inherit reconstructors method class_params ~loc:_ = [] method apply ~loc expr args = eapply ~loc expr args method abstract ~loc patt expr = pexp_fun ~loc Nolabel None patt expr method typ ~loc ty = [%type: [%t ty] -> unit] method any ~loc = [%expr fun _ -> ()] method combine ~loc combinators ~reconstruct:_ = match List.rev combinators with | [] -> [%expr ()] | (_, expr) :: rest -> List.fold_left rest ~init:expr ~f:(fun acc (_v, expr) -> pexp_sequence ~loc expr acc) end let folder : what = object method name = "fold" inherit reconstructors method class_params ~loc = [(ptyp_var ~loc "acc", Invariant)] method apply ~loc expr args = eapply ~loc expr (args @ [evar ~loc "acc"]) method abstract ~loc patt expr = eabstract ~loc [patt; pvar ~loc "acc"] expr method typ ~loc ty = [%type: [%t ty] -> 'acc -> 'acc] method any ~loc = [%expr fun _ acc -> acc] method combine ~loc combinators ~reconstruct:_ = match combinators with | [(_, expr)] -> expr | _ -> List.fold_right combinators ~init:[%expr acc] ~f:(fun (_v, expr) acc -> [%expr let acc = [%e expr] in [%e acc] ]) end let fold_mapper : what = object method name = "fold_map" inherit reconstructors method class_params ~loc = [(ptyp_var ~loc "acc", Invariant)] method apply ~loc expr args = eapply ~loc expr (args @ [evar ~loc "acc"]) method abstract ~loc patt expr = eabstract ~loc [patt; pvar ~loc "acc"] expr method typ ~loc ty = [%type: [%t ty] -> 'acc -> [%t ty] * 'acc] method any ~loc = [%expr fun x acc -> (x, acc)] method combine ~loc combinators ~reconstruct = List.fold_right combinators ~init:[%expr ([%e reconstruct], acc)] ~f:(fun (v, expr) acc -> [%expr let ([%p pvar_of_var v], acc) = [%e expr] in [%e acc] ]) end exception Found let uses_var var = let iter = object inherit Ast_traverse.iter as super method! expression_desc = function | Pexp_ident { txt = Lident id; _ } when String.equal id var -> Exn.raise_without_backtrace Found | e -> super#expression_desc e end in fun e -> try iter#expression e; false with Found -> true ;; let mapper_with_context : what = let uses_ctx = uses_var "ctx" in object method name = "map_with_context" inherit reconstructors method class_params ~loc = [(ptyp_var ~loc "ctx", Invariant)] method apply ~loc expr args = eapply ~loc expr (evar ~loc "ctx" :: args) method abstract ~loc patt expr = if uses_ctx expr then eabstract ~loc [pvar ~loc "ctx"; patt] expr else eabstract ~loc [pvar ~loc "_ctx"; patt] expr method typ ~loc ty = [%type: 'ctx -> [%t ty] -> [%t ty]] method any ~loc = [%expr fun _ctx x -> x] method combine ~loc combinators ~reconstruct = List.fold_right combinators ~init:reconstruct ~f:(fun (v, expr) acc -> [%expr let [%p pvar_of_var v] = [%e expr] in [%e acc] ]) end let string_of_lid id = String.concat ~sep:"." (Longident.flatten_exn id) let lifter : what = object method name = "lift" method class_params ~loc = [(ptyp_var ~loc "res", Invariant)] method apply ~loc expr args = eapply ~loc expr args method abstract ~loc patt expr = pexp_fun ~loc Nolabel None patt expr method typ ~loc ty = [%type: [%t ty] -> 'res] method any ~loc = [%expr self#other] method combine ~loc combinators ~reconstruct = List.fold_right combinators ~init:reconstruct ~f:(fun (v, expr) acc -> pexp_let ~loc Nonrecursive [value_binding ~loc ~pat:(pvar_of_var v) ~expr] acc) method record ~loc flds = let flds = elist ~loc (List.map flds ~f:(fun (lab, e) -> pexp_tuple ~loc:{ lab.loc with loc_end = e.pexp_loc.loc_end } [ estring ~loc:lab.loc (string_of_lid lab.txt) ; e ])) in [%expr self#record [%e flds]] method construct ~loc id args = let args = elist ~loc args in [%expr self#constr [%e estring ~loc:id.loc (string_of_lid id.txt)] [%e args]] method tuple ~loc es = [%expr self#tuple [%e elist ~loc es]] end let all = [mapper; iterator; folder; fold_mapper; mapper_with_context; lifter] end type what = Backends.what let mapper_type ~(what:what) ~loc type_name params = let vars = vars_of_list params ~get_loc:(fun t -> t.ptyp_loc) in let params = tvars_of_vars vars in let ty = ptyp_constr ~loc (Loc.map type_name ~f:lident) params in let ty = List.fold_right params ~init:(what#typ ~loc ty) ~f:(fun param ty -> let loc = param.ptyp_loc in ptyp_arrow ~loc Nolabel (what#typ ~loc param) ty) in ptyp_poly ~loc vars ty ;; let constrained_mapper ~(what:what) ?(is_gadt=false) mapper td = let vars = vars_of_list td.ptype_params ~get_loc:(fun (t, _) -> t.ptyp_loc) in let make_type params = let loc = td.ptype_loc in let ty = ptyp_constr ~loc (Loc.map td.ptype_name ~f:lident) params in List.fold_right params ~init:(what#typ ~loc:td.ptype_loc ty) ~f:(fun param ty -> let loc = param.ptyp_loc in ptyp_arrow ~loc Nolabel (what#typ ~loc param) ty) in let typ = let loc = td.ptype_loc in ptyp_poly ~loc vars (make_type (tvars_of_vars vars)) in let mapper = if false || is_gadt then let typs = List.map vars ~f:(fun v -> ptyp_constr ~loc:v.loc (Loc.map v ~f:lident) []) in List.fold_right vars ~init:(pexp_constraint ~loc:mapper.pexp_loc mapper (make_type typs)) ~f:(fun v e -> pexp_newtype ~loc:v.loc v e) else mapper in pexp_poly ~loc:mapper.pexp_loc mapper (Some typ) ;; let mapper_type_of_td ~what td = mapper_type ~what ~loc:td.ptype_loc td.ptype_name (List.map td.ptype_params ~f:fst) ;; let method_name = function | Lident s -> String.lowercase s | Ldot (_, b) -> b | Lapply _ -> assert false ;; let rec type_expr_mapper ~(what:what) te = let loc = te.ptyp_loc in match te.ptyp_desc with | Ptyp_var s -> evar ~loc ("_" ^ s) | Ptyp_tuple tes -> let vars = vars_of_list tes ~get_loc:(fun t -> t.ptyp_loc) in let deconstruct = ppat_tuple ~loc (pvars_of_vars vars) in let reconstruct = what#tuple ~loc (evars_of_vars vars) in let mappers = map_variables ~what vars tes in what#abstract ~loc deconstruct (what#combine ~loc mappers ~reconstruct) | Ptyp_constr (path, params) -> let map = pexp_send ~loc (evar ~loc "self") { txt = method_name path.txt; loc = path.loc; } in (match params with | [] -> map | _ -> eapply ~loc map (List.map params ~f:(fun te -> type_expr_mapper ~what te))) | _ -> what#any ~loc and map_variables ~(what:what) vars tes = List.map2_exn tes vars ~f:(fun te var -> (var, what#apply ~loc:te.ptyp_loc (type_expr_mapper ~what te) [evar_of_var var])) ;; let gen_record' ~(what:what) ~loc lds = let vars = List.map lds ~f:(fun ld -> ld.pld_name) in let deconstruct = ppat_record ~loc (List.map vars ~f:(fun v -> (Loc.map v ~f:lident, pvar_of_var v))) Closed in let reconstruct = what#record ~loc (List.map vars ~f:(fun v -> (Loc.map v ~f:lident, evar_of_var v))) in let mappers = map_variables ~what vars (List.map lds ~f:(fun ld -> ld.pld_type)) in deconstruct, reconstruct, mappers ;; let gen_record ~(what:what) ~loc lds = let deconstruct, reconstruct, mappers = gen_record' ~what lds ~loc in what#abstract ~loc deconstruct (what#combine ~loc mappers ~reconstruct) ;; let is_constant_constructor cd = match cd.pcd_args with | Pcstr_tuple [] -> true | _ -> false let erase_type_variables = object inherit Ast_traverse.map as super method! core_type_desc = function | Ptyp_var _ -> Ptyp_any | x -> super#core_type_desc x end let gen_variant ~(what:what) ~loc cds = if String.(<>) what#name "lift" && List.for_all cds ~f:is_constant_constructor then what#any ~loc else let cases = List.map cds ~f:(fun cd -> let cstr = Loc.map cd.pcd_name ~f:lident in let loc = cd.pcd_loc in let args = match cd.pcd_res with | None -> cd.pcd_args | Some _ -> (* This is a big sur-approximation but it's enough for our only use of GADTs in ppx_custom_format *) erase_type_variables#constructor_arguments cd.pcd_args in match args with | Pcstr_tuple args -> let vars = vars_of_list args ~get_loc:(fun t -> t.ptyp_loc) in let deconstruct = ppat_construct cstr ~loc (match vars with | [] -> None | _ -> Some (ppat_tuple ~loc (pvars_of_vars vars))) in let reconstruct = what#construct cstr ~loc (evars_of_vars vars) in let mappers = map_variables ~what vars args in case ~lhs:deconstruct ~rhs:(what#combine ~loc mappers ~reconstruct) ~guard:None | Pcstr_record labels -> let deconstruct, reconstruct, mappers = gen_record' ~loc ~what labels in let deconstruct = ppat_construct ~loc cstr (Some deconstruct) in let reconstruct = what#construct ~loc cstr [reconstruct] in case ~lhs:deconstruct ~rhs:(what#combine ~loc mappers ~reconstruct) ~guard:None) in what#abstract ~loc (pvar ~loc "x") (pexp_match ~loc (evar ~loc "x") cases) let gen_mapper ~(what:what) td = let body = let loc = td.ptype_loc in match td.ptype_kind with | Ptype_open -> what#any ~loc | Ptype_record lds -> gen_record ~what lds ~loc | Ptype_variant cds -> gen_variant ~what cds ~loc | Ptype_abstract -> match td.ptype_manifest with | None -> what#any ~loc | Some te -> type_expr_mapper ~what te in List.fold_right td.ptype_params ~init:body ~f:(fun (ty, _) acc -> let loc = ty.ptyp_loc in match ty.ptyp_desc with | Ptyp_var s -> pexp_fun ~loc Nolabel None (pvar ~loc ("_" ^ s)) acc | _ -> pexp_fun ~loc Nolabel None (ppat_any ~loc) acc) ;; let type_deps = let collect = object inherit [int Map.M(Longident).t] Ast_traverse.fold as super method! core_type t acc = let acc = match t.ptyp_desc with | Ptyp_constr (id, vars) -> Map.set acc ~key:id.txt ~data:(List.length vars) | _ -> acc in super#core_type t acc end in fun tds -> let empty = Map.empty (module Longident) in let map = List.fold_left tds ~init:empty ~f:(fun map td -> let map = collect#type_kind td.ptype_kind map in match td.ptype_kind, td.ptype_manifest with | Ptype_abstract, Some ty -> collect#core_type ty map | _ -> map) in let map = List.fold_left tds ~init:map ~f:(fun map td -> Map.remove map (Lident td.ptype_name.txt)) in Map.to_alist map let lift_virtual_methods ~loc methods = let collect = object inherit [Set.M(String).t] Ast_traverse.fold as super method! expression_desc x acc = match x with | Pexp_send (_, ({ txt = "tuple"|"record"|"constr"|"other" as s; loc = _; })) -> Set.add acc s | _ -> super#expression_desc x acc end in let used = collect#list collect#class_field methods (Set.empty (module String)) in let all_virtual_methods = match [%stri class virtual blah = object method virtual record : (string * 'res) list -> 'res method virtual constr : string -> 'res list -> 'rest method virtual tuple : 'res list -> 'res method virtual other : 'a. 'a -> 'res end ] with | { pstr_desc = Pstr_class [ { pci_expr = { pcl_desc = Pcl_structure { pcstr_fields = l; _ } ; _ } ; _ } ] ; _ } -> l | _ -> assert false in List.filter all_virtual_methods ~f:(fun m -> match m.pcf_desc with | Pcf_method (s, _, _) -> Set.mem used s.txt | _ -> false) let map_lident id ~f = match id with | Lident s -> Lident (f s) | Ldot (id, s) -> Ldot (id, f s) | Lapply _ -> assert false let class_constr ~what ~class_params id = pcl_constr ~loc:id.loc (Loc.map id ~f:(map_lident ~f:(fun s -> what#name ^ "_" ^ s))) (List.map class_params ~f:fst) let gen_class ~(what:what) ~loc tds = let class_params = what#class_params ~loc in let virtual_methods = List.map (type_deps tds) ~f:(fun (id, arity) -> let id = { txt = Longident.last_exn id; loc } in pcf_method ~loc (id, Public, Cfk_virtual (mapper_type ~what ~loc id (List.init arity ~f:(fun _ -> ptyp_any ~loc))))) in let methods = List.map tds ~f:(fun td -> let loc = td.ptype_loc in let mapper = gen_mapper ~what td in let is_gadt = match td.ptype_kind with | Ptype_variant cds -> List.exists cds ~f:(fun cd -> Option.is_some cd.pcd_res) | _ -> false in let mapper = constrained_mapper ~what ~is_gadt mapper td in pcf_method ~loc (td.ptype_name, Public, Cfk_concrete (Fresh, mapper))) in let virtual_methods = if String.equal what#name "lift" then lift_virtual_methods ~loc methods @ virtual_methods else virtual_methods in let virt = if List.is_empty virtual_methods then Concrete else Virtual in class_infos ~loc ~virt ~params:class_params ~name:{ loc; txt = what#name } ~expr:(pcl_structure ~loc (class_structure ~self:(ppat_var ~loc { txt = "self"; loc }) ~fields:(virtual_methods @ methods))) let gen_str ~(what:what)~loc ~path:_ (rf, tds) = (match rf with | Nonrecursive -> (* The method name would clash... *) Location.raise_errorf ~loc "ppxlib_traverse doesn't support nonrec" | Recursive -> ()); let cl = gen_class ~loc ~what tds in [ pstr_class ~loc:cl.pci_loc [cl] ] let () = let derivers = List.map Backends.all ~f:(fun what -> Deriving.add ("traverse_" ^ what#name) ~str_type_decl:(Deriving.Generator.make_noarg (gen_str ~what))) in Deriving.add_alias "traverse" (List.rev derivers) |> Deriving.ignore ppxlib-0.12.0/traverse_builtins/000077500000000000000000000000001360512673700166465ustar00rootroot00000000000000ppxlib-0.12.0/traverse_builtins/dune000066400000000000000000000001741360512673700175260ustar00rootroot00000000000000(library (name ppxlib_traverse_builtins) (public_name ppxlib.traverse_builtins) (flags (:standard -safe-string))) ppxlib-0.12.0/traverse_builtins/ppxlib_traverse_builtins.ml000066400000000000000000000142071360512673700243260ustar00rootroot00000000000000module T = struct type 'a map = 'a -> 'a type 'a iter = 'a -> unit type ('a, 'acc) fold = 'a -> 'acc -> 'acc type ('a, 'acc) fold_map = 'a -> 'acc -> ('a * 'acc) type ('ctx, 'a) map_with_context = 'ctx -> 'a -> 'a type ('a, 'res) lift = 'a -> 'res end class map = let any x = x in object method int : int T.map = any method string : string T.map = any method bool : bool T.map = any method char : char T.map = any method option : 'a. 'a T.map -> 'a option T.map = fun f x -> match x with | None -> None | Some x -> Some (f x) method list : 'a. 'a T.map -> 'a list T.map = List.map method array : 'a. 'a T.map -> 'a array T.map = Array.map end class iter = let any = ignore in object method int : int T.iter = any method string : string T.iter = any method bool : bool T.iter = any method char : char T.iter = any method option : 'a. 'a T.iter -> 'a option T.iter = fun f x -> match x with | None -> () | Some x -> f x method list : 'a. 'a T.iter -> 'a list T.iter = List.iter method array : 'a. 'a T.iter -> 'a array T.iter = Array.iter end class ['acc] fold = let any _ acc = acc in object method int : (int , 'acc) T.fold = any method string : (string , 'acc) T.fold = any method bool : (bool , 'acc) T.fold = any method char : (char , 'acc) T.fold = any method option : 'a. ('a, 'acc) T.fold -> ('a option, 'acc) T.fold = fun f x acc -> match x with | None -> acc | Some x -> f x acc method list : 'a. ('a, 'acc) T.fold -> ('a list, 'acc) T.fold = let rec loop f l acc = match l with | [] -> acc | x :: l -> loop f l (f x acc) in loop method array : 'a. ('a, 'acc) T.fold -> ('a array, 'acc) T.fold = fun f a acc -> let r = ref acc in for i = 0 to Array.length a - 1 do r := f (Array.unsafe_get a i) !r done; !r end class ['acc] fold_map = let any x acc = (x, acc) in object method int : (int , 'acc) T.fold_map = any method string : (string , 'acc) T.fold_map = any method bool : (bool , 'acc) T.fold_map = any method char : (char , 'acc) T.fold_map = any method option : 'a. ('a, 'acc) T.fold_map -> ('a option, 'acc) T.fold_map = fun f x acc -> match x with | None -> (None, acc) | Some x -> let x, acc = f x acc in (Some x, acc) method list : 'a. ('a, 'acc) T.fold_map -> ('a list, 'acc) T.fold_map = let rec loop f l acc = match l with | [] -> ([], acc) | x :: l -> let x, acc = f x acc in let l, acc = loop f l acc in (x :: l, acc) in loop method array : 'a. ('a, 'acc) T.fold_map -> ('a array, 'acc) T.fold_map = fun f a acc -> let len = Array.length a in if len = 0 then (a, acc) else begin let x, acc = f (Array.unsafe_get a 0) acc in let a' = Array.make len x in let r = ref acc in for i = 1 to len - 1 do let x, acc = f (Array.unsafe_get a i) !r in Array.unsafe_set a' i x; r := acc done; (a', !r) end end class ['ctx] map_with_context = let any _ x = x in object method int : ('ctx, int ) T.map_with_context = any method string : ('ctx, string) T.map_with_context = any method bool : ('ctx, bool ) T.map_with_context = any method char : ('ctx, char ) T.map_with_context = any method option : 'a. ('ctx, 'a) T.map_with_context -> ('ctx, 'a option) T.map_with_context = fun f ctx x -> match x with | None -> None | Some x -> Some (f ctx x) method list : 'a. ('ctx, 'a) T.map_with_context -> ('ctx, 'a list) T.map_with_context = fun f ctx l -> List.map (f ctx) l method array : 'a. ('ctx, 'a) T.map_with_context -> ('ctx, 'a array) T.map_with_context = fun f ctx a -> Array.map (f ctx) a end class virtual ['res] lift = object(self) method virtual other : 'a. ('a, 'res) T.lift method virtual int : (int , 'res) T.lift method virtual string : (string, 'res) T.lift method virtual bool : (bool , 'res) T.lift method virtual char : (char , 'res) T.lift method virtual array : 'a. ('a, 'res) T.lift -> ('a array, 'res) T.lift method virtual float : (float, 'res) T.lift method virtual int32 : (int32, 'res) T.lift method virtual int64 : (int64, 'res) T.lift method virtual nativeint : (nativeint, 'res) T.lift method virtual unit : (unit, 'res) T.lift method virtual record : (string * 'res) list -> 'res method virtual constr : string -> 'res list -> 'res method virtual tuple : 'res list -> 'res method option : 'a. ('a, 'res) T.lift -> ('a option, 'res) T.lift = fun f x -> match x with | None -> self#constr "None" [] | Some x -> self#constr "Some" [f x] method list : 'a. ('a, 'res) T.lift -> ('a list, 'res) T.lift = fun f l -> match l with | [] -> self#constr "[]" [] | x :: l -> self#constr "::" [f x; self#list f l] end class type ['res] std_lifters = object method other : 'a. ('a, 'res) T.lift method int : (int , 'res) T.lift method string : (string, 'res) T.lift method bool : (bool , 'res) T.lift method char : (char , 'res) T.lift method array : 'a. ('a, 'res) T.lift -> ('a array, 'res) T.lift method record : (string * 'res) list -> 'res method constr : string -> 'res list -> 'res method tuple : 'res list -> 'res method float : (float, 'res) T.lift method int32 : (int32, 'res) T.lift method int64 : (int64, 'res) T.lift method nativeint : (nativeint, 'res) T.lift method unit : (unit, 'res) T.lift method option : 'a. ('a, 'res) T.lift -> ('a option, 'res) T.lift method list : 'a. ('a, 'res) T.lift -> ('a list, 'res) T.lift end