pax_global_header00006660000000000000000000000064146240636350014523gustar00rootroot0000000000000052 comment=32f7c31ecfcbca6d53f3655a00e8852f4751123e ppx_deriving-6.0.2/000077500000000000000000000000001462406363500142265ustar00rootroot00000000000000ppx_deriving-6.0.2/.gitignore000066400000000000000000000001201462406363500162070ustar00rootroot00000000000000*.native *.byte *.docdir _build *.install pkg/META src_test/_tags .merlin _opam ppx_deriving-6.0.2/.travis.yml000066400000000000000000000012221462406363500163340ustar00rootroot00000000000000language: c sudo: false dist: xenial install: wget https://raw.githubusercontent.com/ocaml/ocaml-ci-scripts/master/.travis-opam.sh script: bash -ex .travis-opam.sh env: global: - REVDEPS="ppx_deriving_hardcaml ppx_deriving_crowbar ppx_deriving_yojson ppx_deriving_madcast ppx_deriving_protocol ppx_deriving_rpc ppx_deriving_argparse ppx_deriving_cmdliner ppx_deriving_protobuf ppx_deriving_morphism visitors" matrix: - OCAML_VERSION=4.11 - OCAML_VERSION=4.10 - OCAML_VERSION=4.09 - OCAML_VERSION=4.08 - OCAML_VERSION=4.07 - OCAML_VERSION=4.06 - OCAML_VERSION=4.05 os: - linux ppx_deriving-6.0.2/CHANGELOG.md000066400000000000000000000163351462406363500160470ustar00rootroot000000000000006.0.2 ----- * Fix ordering of derived `make`'s arguments #285 (@NathanReb) 6.0.1 (17/04/2024) (aborted, not on opam) ----------------------------------------- * Fix the unintentional removal of `Ppx_deriving_runtime.Result` in #279 #282 (@NathanReb) 6.0.0 (15/04/2024) (aborted, not on opam) ---------------------------- * Fix a bug in `[@@deriving make]` that caused errors when it was used on a set of type declarations containing at least one non record type. #281 (@NathanReb) * Embed errors instead of raising exceptions when generating code with `ppx_deriving.make` #281 (@NathanReb) * Remove `[%derive.iter ...]`, `[%derive.map ...]` and `[%derive.fold ...]` extensions #278 (Simmo Saan) * Port standard plugins to ppxlib registration and attributes #263 (Simmo Saan) * Optimize forwarding in eq and ord plugins #252 (Simmo Saan) * Delegate quoter to ppxlib #263 (Simmo Saan) * Introduce `Ppx_deriving_runtime.Stdlib` with OCaml >= 4.07. This module already exists in OCaml < 4.07 but was missing otherwise. #258 (Kate Deplaix) 5.2.1 (02/02/2021) ------------------ * Allow Ast_convenience's functions to be given a full path ident (e.g. M.ident) #248 (Kate Deplaix) * Add a deprecation notice of the API in the README. The next step of the deprecation is going to be in the form of a [@@@ocaml.deprecated ...] alert on the API module and the reimplementation of the individual plugins using the ppxlib API. (Kate Deplaix and Gabriel Scherer) 5.2 (25/11/2020) ---------------- * Update to ppxlib 0.20.0 #237 #239 #243 #245 (Kate Deplaix, Jérémie Dimino, Thierry Martinez, Gabriel Scherer) * Upgrade testsuite from ounit to ounit2 #241 (Kate Deplaix) * (almost) use the set of standard flags from dune #246 (Kate Deplaix) 5.1 (26/10/2020) ---------------- * Update to ppxlib 0.15.0 #235 (Kate Deplaix) 5.0 (26/10/2020) ---------------- * Migrate to ppxlib #206, #210 (Anton Kochkov, Gabriel Scherer, Thierry Martinez) 4.5 --- * Add support for OCaml 4.11. - `Ppx_deriving.string_of_{constant,expression}_opt` to destruct `Pconst_string` in a version-independent way #220, #222 (Kate Deplaix, Thierry Martinez, review by Gabriel Scherer) * Stronger type equalities in `Ppx_deriving_runtime` (for instance, `Ppx_deriving_runtime.result` and `Result.result` are now compatible with all OCaml versions) #223, #225 (Thierry Martinez, review by Gabriel Scherer) * `Ppx_deriving_runtime.Option` compatibility module #222 (Thierry Martinez, review by Gabriel Scherer) 4.4.1 ----- * Add support for OCaml 4.10 #211 (Kate Deplaix, review by Gabriel Scherer) 4.4 --- * Restore support for OCaml 4.02.3 #188 (ELLIOTTCABLE) * workaround Location.input_filename being empty when using reason-language-server #196 (Ryan Artecona) * Add support for OCaml 4.08.0 #193, #197, #200 (Gabriel Scherer) 4.3 --- * use Format through Ppx_deriving_runtime to avoid deprecation warning for users of JaneStreet Base (Stephen Bastians and Gabriel Scherer, review by whitequark) * silence a ambiguous-field warning (41) in generated code #163 (Étienne Millon, review by Gabriel Scherer) * use dune #170 (Rudi Grinberg, Jérémie Dimino) * silence an unused-value warning for show #179 (Nathan Rebours) 4.2.1 ----- * Add support for OCaml 4.06.0 #154, #155, #156, #159 (Gabriel Scherer, Fabian, Leonid Rozenberg) * Consider { with_path = false } when printing record fields #157 (François Pottier) 4.2 --- * Add support for OCaml 4.05.0. * Use the `ocaml-migrate-parsetree` library to support multiple versions of OCaml. * Fix comparison order of fields in records (#136). * Silence an `unused rec flag` warning in generated code (#137). * Monomorphize comparison function for builtin types (#115) * Raise an error when `type nonrec` is encountered (#116). * Display an error message when dynamic package loading fails. * Add a `with_path` option to `@@deriving` to skip the module path in generated code (#120). The homepage for the project has now moved to: 4.1 --- * Fix type error with inheritied polymorphic variant type in [@@deriving map]. * Fix incorrect handling of multi-argument constructors in [@@deriving show]. * Add API hooks for ppx_type_conv. 4.0 --- * Show, eq, ord, map, iter, fold: add support for `Result.result`. * Ppx_deriving.Arg: use Result.result instead of polymorphic variants. * Ppx_deriving.sanitize: parameterize over an opened module. * Add support for `[@@deriving]` in module type declarations. * Add support for loading findlib packages instead of just files in ppx_deriving_main. * Treat types explicitly qualified with Pervasives also as builtin. * Compatibility with statically linked ppx drivers. 3.1 --- * Show, eq, ord: hygienically invoke functions from referenced modules (such as X.pp for X.t when deriving show) to coexist with modules shadowing ones from standard library. * Iter, map, fold: hygienically invoke List and Array functions. 3.0 --- * Implement hygiene: Ppx_deriving.{create_quoter,quote,sanitize,with_quoter}. * Show, eq, ord: add support for `lazy_t`. * Add support for `[@nobuiltin]` attribute. * Add Ppx_deriving.hash_variant. * Remove allow_std_type_shadowing option. * Remove Ppx_deriving.extract_typename_of_type_group. 2.1 --- * Fix breakage occurring with 4.02.2 w.r.t record labels * Fix prefixed attribute names (`[@deriving.foo.attr]` and `[@foo.attr]`). * Add allow_std_type_shadowing option for eq and show. 2.0 --- * Add support for open types. 1.1 --- * New plugin: create. * Show, eq, ord: handle `_`. * Show, eq, ord, map, iter, fold: handle inheriting from a parametric polymorphic variant type. * Make `Ppx_deriving.poly_{fun,arrow}_of_type_decl` construct functions in correct order. This also fixes all derivers with types with more than one parameter. * Add `Ppx_deriving.fold_{left,right}_type_decl`. 1.0 --- * Make deriver names lowercase. * Remove Findlib+dynlink integration. All derivers must now be explicitly required. * Allow shortening [%derive.x:] to [%x:] when deriver x exists. * Make `Ppx_deriving.core_type` field optional to allow ignoring unsupported [%x:] shorthands. * Add support for [@@deriving foo { optional = true }] that does not error out if foo is missing, useful for optional dependencies. * Rename ~name and ~prefix of `Ppx_deriving.attr` and `Ppx_deriving.Arg.payload` to `~deriver`. * Renamed `Ppx_deriving.Arg.payload` to `get_attr`. * Add `Ppx_deriving.Arg.get_expr` and `get_flag`. 0.3 --- * Show, Eq, Ord, Iter, Fold: handle ref. * Show: handle functions. * Show: include break hints in format strings. * Show: pull fprintf into local environment. * Show: add `[@polyprinter]` and `[@opaque]`. * Add `Ppx_deriving.Arg.expr`. 0.2 --- * New plugins: Enum, Iter, Map, Fold. * All plugins: don't concatenate affix if type is named `t`. * Add `[%derive.Foo:]` shorthand. * Show, Eq, Ord: add support for list, array, option. * Show: include full module path in output, including for types with manifest. * A lot of changes in `Ppx_deriving interface`. 0.1 --- * Initial release. ppx_deriving-6.0.2/LICENSE.txt000066400000000000000000000021001462406363500160420ustar00rootroot00000000000000Copyright (c) 2014-2016 whitequark Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions: The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software. THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ppx_deriving-6.0.2/META.ppx_deriving.template000066400000000000000000000001751462406363500212110ustar00rootroot00000000000000description = "Type-driven code generation" ppx(-custom_ppx) = "./ppx_deriving" requires = "ppx_deriving.runtime" # DUNE_GENppx_deriving-6.0.2/Makefile000066400000000000000000000012041462406363500156630ustar00rootroot00000000000000build: dune build test: dune runtest examples: dune build @examples doc: dune build @doc clean: dune clean gh-pages: doc git clone `git config --get remote.origin.url` .gh-pages --reference . git -C .gh-pages checkout --orphan gh-pages git -C .gh-pages reset git -C .gh-pages clean -dxf cp -rt .gh-pages/ _build/default/_doc/_html/* git -C .gh-pages add . git -C .gh-pages commit -m "Update Pages" git -C .gh-pages push origin gh-pages -f rm -rf .gh-pages all-supported-ocaml-versions: dune build @install @runtest --workspace dune-workspace.dev .PHONY: build test doc clean examples all-supported-ocaml-versions gh-pages ppx_deriving-6.0.2/README.md000066400000000000000000000544461462406363500155220ustar00rootroot00000000000000[@@deriving] ============ _deriving_ is a library simplifying type-driven code generation on OCaml. _deriving_ includes a set of useful plugins: [show][], [eq][], [ord][eq], [enum][], [iter][], [map][iter], [fold][iter], [make][], [yojson][], [protobuf][]. Sponsored by [Evil Martians](http://evilmartians.com). [show]: #plugin-show [eq]: #plugins-eq-and-ord [enum]: #plugin-enum [iter]: #plugins-iter-map-and-fold [make]: #plugin-make (`create` also exists, but it remains solely for backwards compatibility) [yojson]: https://github.com/ocaml-ppx/ppx_deriving_yojson#usage [protobuf]: https://github.com/ocaml-ppx/ppx_deriving_protobuf#usage **Note:** since _deriving_ was released by whitequark in 2014, the OCaml ppx ecosystem has changed a lot. For new projects wishing to create a new deriving plugin, we recommend using [ppxlib](https://github.com/ocaml-ppx/ppxlib) directly. The module [Ppxlib.Deriving](https://ocaml-ppx.github.io/ppxlib/ppxlib/Ppxlib/Deriving/index.html) provide functionality similar to _deriving_, better integrated with ppxlib, and offers a nicer API in some places. _deriving_ is still maintained to keep existing plugins working as well as possible. Although note that the above deprecation note only covers the API and not the plugins (e.g. `ppx_deriving.show`, `ppx_deriving.eq`, ...). Installation ------------ _deriving_ can be installed via [OPAM](https://opam.ocaml.org): opam install ppx_deriving Buildsystem integration ----------------------- To use _deriving_, only one modification is needed: you need to require via ocamlfind the package corresponding to the _deriving_ plugin. This will both engage the syntax extension and link in the runtime components of the _deriving_ plugin, if any. For example, if you are using ocamlbuild, add the following to `_tags` to use the default _deriving_ plugins: : package(ppx_deriving.std) With Dune, you should add a `preprocess` directive to your target: (executable (libraries whatever) (preprocess (pps ppx_deriving.show ppx_deriving.ord)) (name blah)) Dune's `pps` directive allows faster preprocessing by linking the specified preprocessors into a single executable (documented [here](https://readthedocs.org/projects/dune/downloads/pdf/latest/#subsection.5.7.2)). This can significantly speed up compilation on large projects which use many derivers. If you are using another buildsystem, just make sure it passes `-package ppx_deriving.whatever` to ocamlfind. Usage ----- From a user's perspective, _deriving_ is triggered by a `[@@deriving plugin]` annotation attached to a type declaration in structure or signature: ``` ocaml type point2d = float * float [@@deriving show] ``` It's possible to invoke several plugins by separating their names with commas: ``` ocaml type point3d = float * float * float [@@deriving show, eq] ``` It's possible to pass options to a plugin by appending a record to plugin's name: ``` ocaml type t = string [@@deriving yojson { strict = true }] ``` It's possible to make _deriving_ ignore a missing plugin rather than raising an error by passing an `optional = true` option, for example, to enable conditional compilation: ``` ocaml type addr = string * int [@@deriving yojson { optional = true }] ``` It's also possible for many plugins to derive a function directly from a type, without declaring it first. ``` ocaml open OUnit2 let test_list_sort ctxt = let sort = List.sort [%derive.ord: int * int] in assert_equal ~printer:[%derive.show: (int * int) list] [(1,1);(2,0);(3,5)] (sort [(2,0);(3,5);(1,1)]) ``` The `[%derive.x:]` syntax can be shortened to `[%x:]`, given that the deriver `x` exists and the payload is a type. If these conditions are not satisfied, the extension node will be left uninterpreted to minimize potential conflicts with other rewriters. ### Working with existing types At first, it may look like _deriving_ requires complete control of the type declaration. However, a lesser-known OCaml feature allows to derive functions for any existing type. Using `Stdlib.fpclass` as an example, _show_ can be derived as follows: ``` ocaml # module M = struct type myfpclass = fpclass = FP_normal | FP_subnormal | FP_zero | FP_infinite | FP_nan [@@deriving show] end;; module M : sig type myfpclass = fpclass = FP_normal | FP_subnormal | FP_zero | FP_infinite | FP_nan val pp_myfpclass : Format.formatter -> fpclass -> unit val show_myfpclass : fpclass -> string end # M.show_myfpclass FP_normal;; - : string = "FP_normal" ``` The module is used to demonstrate that `show_myfpclass` really accepts `Stdlib.fpclass`, and not just `M.myfpclass`. To avoid the need to repeat the type definition, it is possible to use [ppx_import](https://github.com/ocaml-ppx/ppx_import#usage) to automatically pull in the type definition. Attributes can be attached using its `[@with]` replacement feature. Plugin conventions ------------------ It is expected that all _deriving_ plugins will follow the same conventions, thus simplifying usage. * By default, the functions generated by a plugin for a `type foo` are called `fn_foo` or `foo_fn`. However, if the type is called `type t`, the function will be named `foo`. The defaults can be overridden by an `affix = true|false` plugin option. * There may be additional attributes attached to the AST. In case of a plugin named `eq` and attributes named `compare` and `skip`, the plugin must recognize all of `compare`, `skip`, `eq.compare`, `eq.skip`, `deriving.eq.compare` and `deriving.eq.skip` annotations. However, if it detects that at least one namespaced (e.g. `eq.compare` or `deriving.eq.compare`) attribute is present, it must not look at any attributes located within a different namespace. As a result, different ppx rewriters can avoid interference even if the attribute names they use overlap. * A typical plugin should handle tuples, records, normal and polymorphic variants; builtin types: `int`, `int32`, `int64`, `nativeint`, `float`, `bool`, `char`, `string`, `bytes`, `ref`, `list`, `array`, `option`, `lazy_t` and their `Mod.t` aliases; `Result.result` available since 4.03 or in the `result` opam package; abstract types; and `_`. For builtin types, it should have customizable, sensible default behavior. This default behavior should not be used if a type has a `[@nobuiltin]` attribute attached to it, and the type should be treated as abstract. For abstract types, it should expect to find the functions it would derive itself for that type. * If a type is parametric, the generated functions accept an argument for every type variable before all other arguments. Plugin: show ------------ _show_ derives a function that inspects a value; that is, pretty-prints it with OCaml syntax. However, _show_ offers more insight into the structure of values than the Obj-based pretty printers (e.g. `Printexc`), and more flexibility than the toplevel printer. ``` ocaml # type t = [ `A | `B of int ] [@@deriving show];; type t = [ `A | `B of i ] val pp : Format.formatter -> [< `A | `B of i ] -> unit = val show : [< `A | `B of i ] -> string = # show (`B 1);; - : string = "`B (1)" ``` For an abstract type `ty`, _show_ expects to find a `pp_ty` function in the corresponding module. _show_ allows to specify custom formatters for types to override default behavior. A formatter for type `t` has a type `Format.formatter -> t -> unit`: ``` ocaml # type file = { name : string; perm : int [@printer fun fmt -> fprintf fmt "0o%03o"]; } [@@deriving show];; # show_file { name = "dir"; perm = 0o755 };; - : string = "{ name = \"dir\"; perm = 0o755 }" ``` It is also possible to use `[@polyprinter]`. The difference is that for a type `int list`, `[@printer]` should have a signature `formatter -> int list -> unit`, and for `[@polyprinter]` it's `('a -> formatter -> unit) -> formatter -> 'a list -> unit`. `[@opaque]` is a shorthand for `[@printer fun fmt _ -> Format.pp_print_string fmt ""]`. The function `fprintf` is locally defined in the printer. By default all constructors are printed with prefix which is dot-separated filename and module path. For example ``` ocaml # module X = struct type t = C [@@deriving show] end;; ... # X.(show C);; - : string = "X.C" ``` This code will create printers which return the string `X.C`, `X` is a module path and `C` is a constructor name. File's name is omitted in the toplevel. To skip all module paths the one needs to derive show with option `with_path` (which defaults to `true`) ``` ocaml # module X = struct type t = C [@@deriving show { with_path = false }] end;; ... # X.(show C);; - : string = "C" ``` Plugins: eq and ord ------------------- _eq_ derives a function comparing values by semantic equality; structural or physical depending on context. _ord_ derives a function defining a total order for values, returning a negative value if lower, `0` if equal or a positive value if greater. They're similar to `Stdlib.(=)` and `Stdlib.compare`, but are faster, allow to customize the comparison rules, and never raise at runtime. _eq_ and _ord_ are short-circuiting. ``` ocaml # type t = [ `A | `B of int ] [@@deriving eq, ord];; type t = [ `A | `B of int ] val equal : [> `A | `B of int ] -> [> `A | `B of int ] -> bool = val compare : [ `A | `B of int ] -> [ `A | `B of int ] -> int = # equal `A `A;; - : bool = true # equal `A (`B 1);; - : bool = false # compare `A `A;; - : int = 0 # compare (`B 1) (`B 2);; - : int = -1 ``` For variants, _ord_ uses the definition order. For builtin types, properly monomorphized `(=)` is used for _eq_, or corresponding `Mod.compare` function (e.g. `String.compare` for `string`) for _ord_. For an abstract type `ty`, _eq_ and _ord_ expect to find an `equal_ty` or `compare_ty` function in the corresponding module. _eq_ and _ord_ allow to specify custom comparison functions for types to override default behavior. A comparator for type `t` has a type `t -> t -> bool` for _eq_ or `t -> t -> int` for _ord_. If an _ord_ comparator returns a value outside -1..1 range, the behavior is unspecified. ``` ocaml # type file = { name : string [@equal fun a b -> String.(lowercase a = lowercase b)]; perm : int [@compare fun a b -> compare b a] } [@@deriving eq, ord];; type file = { name : bytes; perm : int; } val equal_file : file -> file -> bool = val compare_file : file -> file -> int = # equal_file { name = "foo"; perm = 0o644 } { name = "Foo"; perm = 0o644 };; - : bool = true # compare_file { name = "a"; perm = 0o755 } { name = "a"; perm = 0o644 };; - : int = -1 ``` Plugin: enum ------------ _enum_ is a plugin that treats variants with argument-less constructors as enumerations with an integer value assigned to every constructor. _enum_ derives functions to convert the variants to and from integers, and minimal and maximal integer value. ``` ocaml # type insn = Const | Push | Pop | Add [@@deriving enum];; type insn = Const | Push | Pop | Add val insn_to_enum : insn -> int = val insn_of_enum : int -> insn option = val min_insn : int = 0 val max_insn : int = 3 # insn_to_enum Pop;; - : int = 2 # insn_of_enum 3;; - : insn option = Some Add ``` By default, the integer value associated is `0` for lexically first constructor, and increases by one for every next one. It is possible to set the value explicitly with `[@value 42]`; it will keep increasing from the specified value. Plugins: iter, map and fold --------------------------- _iter_, _map_ and _fold_ are three closely related plugins that generate code for traversing polymorphic data structures in lexical order and applying a user-specified action to all values corresponding to type variables. ``` ocaml # type 'a btree = Node of 'a btree * 'a * 'a btree | Leaf [@@deriving iter, map, fold];; type 'a btree = Node of 'a btree * 'a * 'a btree | Leaf val iter_btree : ('a -> unit) -> 'a btree -> unit = val map_btree : ('a -> 'b) -> 'a btree -> 'b btree = val fold_btree : ('a -> 'b -> 'a) -> 'a -> 'b btree -> 'a = # let tree = (Node (Node (Leaf, 0, Leaf), 1, Node (Leaf, 2, Leaf)));; val tree : int btree = Node (Node (Leaf, 0, Leaf), 1, Node (Leaf, 2, Leaf)) # iter_btree (Printf.printf "%d\n") tree;; 0 1 2 - : unit = () # map_btree ((+) 1) tree;; - : int btree = Node (Node (Leaf, 1, Leaf), 2, Node (Leaf, 3, Leaf)) # fold_btree (+) 0 tree;; - : int = 3 ``` Plugin: make -------------- _make_ is a plugin that generates record constructors. Given a record, a function is generated that accepts all fields as labelled arguments and `()`; alternatively, if one field is specified as `[@main]`, it is accepted last. The fields which have a default value (fields of types `'a option`, `'a list`, and fields with `[@default]` annotation) are mapped to optional arguments; the rest are mandatory. A field of form `xs: ('a * 'a list) [@split]` corresponds to two arguments: mandatory argument `x` and optional argument `xs` with types `'a` and `'a list` correspondingly. ``` ocaml type record = { opt : int option; lst : int list; def : int [@default 42]; args : (int * int list) [@split]; norm : int; } [@@deriving make];; val make_record : ?opt:int -> ?lst:int list -> ?def:int -> arg:int -> ?args:int list -> norm:int -> unit -> record ``` To use _make_ with a set of mutually recursive type definitions, simply attach a single `[@@deriving make]` attribute and it will derive a `make_*` function for each record type in the set. The deriving runtime -------------------- _deriving_ comes with a small runtime library, the `Ppx_deriving_runtime` module, whose purpose is to re-export the modules and types of the standard library that code producers rely on -- ensuring hygienic code generation. By emitting code that references to `Ppx_deriving_runtime.Array` module instead of just `Array`, plugins ensure that they can be used in environments where the `Array` module is redefined with incompatible types. Building ppx drivers -------------------- By default, _deriving_ dynlinks every plugin, whether invoked as a part of a batch compilation or from the toplevel. If this is unsuitable for you for some reason, it is possible to precompile a ppx rewriter executable that includes several _deriving_ plugins: ``` $ ocamlfind opt -predicates ppx_driver -package ppx_deriving_foo -package ppx_deriving_bar \ -package ppx_deriving.main -linkpkg -linkall -o ppx_driver ``` Currently, the resulting ppx driver still depends on Dynlink as well as retains the ability to load more plugins. Developing plugins ------------------ This section only explains the tooling and best practices. Anyone aiming to implement their own _deriving_ plugin is encouraged to explore the existing ones, e.g. [eq](src_plugins/eq/ppx_deriving_eq.cppo.ml) or [show](src_plugins/show/ppx_deriving_show.cppo.ml). ### Tooling and environment A _deriving_ plugin is packaged as a Findlib library; this library should include a peculiar META file. As an example, let's take a look at a description of a _yojson_ plugin: ``` version = "1.0" description = "[@@deriving yojson]" exists_if = "ppx_deriving_yojson.cma" # The following part affects batch compilation and toplevel. # The plugin package may require any runtime component it needs. requires(-ppx_driver) = "ppx_deriving yojson" ppxopt(-ppx_driver) = "ppx_deriving,./ppx_deriving_yojson.cma" # The following part affects ppx driver compilation. requires(ppx_driver) = "ppx_deriving.api" archive(ppx_driver, byte) = "ppx_deriving_yojson.cma" archive(ppx_driver, native) = "ppx_deriving_yojson.cmxa" ``` The module(s) provided by the package in the `ppxopt` variable must register the derivers using `Ppx_deriving.register "foo"` during loading. Any number of derivers may be registered; careful registration would allow a _yojson_ deriver to support all three of `[@@deriving yojson]`, `[@@deriving of_yojson]` and `[@@deriving to_yojson]`, as well as `[%derive.of_yojson:]` and `[%derive.to_yojson:]`. It is possible to test the plugin without installing it by instructing _deriving_ to load it directly; the compiler should be invoked as `ocamlfind c -package ppx_deriving -ppxopt ppx_deriving,src/ppx_deriving_foo.cma ...`. The file extension is replaced with `.cmxs` automatically for native builds. This can be integrated with buildsystem, e.g. for ocamlbuild: ``` ocaml let () = dispatch ( function | After_rules -> (* Assuming files tagged with deriving_foo are already tagged with package(ppx_deriving) or anything that uses it, e.g. package(ppx_deriving.std). *) flag ["ocaml"; "compile"; "deriving_foo"] & S[A"-ppxopt"; A"ppx_deriving,src/ppx_deriving_foo.cma"] | _ -> () ``` Alternatively, you can quickly check the code generated by a ppx rewriter packaged with ocamlfind by running the toplevel as `ocaml -dsource` or `utop -dsource`, which will unparse the rewritten syntax tree into OCaml code and print it before executing. ### Testing plugins The main ppx_deriving binary can be used to output preprocessed source code in a human-readable form: ``` $ cat test.ml type foo = A of int | B of float [@@deriving show] $ ocamlfind ppx_deriving/ppx_deriving \ -deriving-plugin `ocamlfind query ppx_deriving`/ppx_deriving_show.cma \ test.ml ``` ``` ocaml type foo = | A of int | B of float [@@deriving show] let rec (pp_foo : Format.formatter -> foo -> Ppx_deriving_runtime.unit) = ((let open! Ppx_deriving_runtime in fun fmt -> function | A a0 -> (Format.fprintf fmt "(@[<2>T.A@ "; (Format.fprintf fmt "%d") a0; Format.fprintf fmt "@])") | B a0 -> (Format.fprintf fmt "(@[<2>T.B@ "; (Format.fprintf fmt "%F") a0; Format.fprintf fmt "@])")) [@ocaml.warning "-A"]) and show_foo : foo -> Ppx_deriving_runtime.string = fun x -> Format.asprintf "%a" pp_foo x ``` ### Goals of the API _deriving_ is a thin wrapper over the ppx rewriter system. Indeed, it includes very little logic; the goal of the project is 1) to provide common reusable abstractions required by most, if not all, deriving plugins, and 2) encourage the deriving plugins to cooperate and to have as consistent user interface as possible. As such, _deriving_: * Completely defines the syntax of `[@@deriving]` annotation and unifies the plugin discovery mechanism; * Provides an unified, strict option parsing API to plugins; * Provides helpers for parsing annotations to ensure that the plugins interoperate with each other and the rest of the ecosystem. ### Using the API Complete API documentation is available [online](http://ocaml-ppx.github.io/ppx_deriving/ppx_deriving/Ppx_deriving). #### Hygiene A very important aspect of a syntax extension is **hygiene**. Consider a case where a _deriving_ plugin makes assumptions about the interface provided by the `List` module: it will normally work as expected, but not in case where someone shadows the `List` identifier! This happens quite often in the OCaml ecosystem, e.g. the Jane Street [Core] library encourages developers to use `open Core.Std`. Additionally, if your _deriving_ plugin inserts user-provided expressions into the generated code, a name you are using internally may accidentally collide with a user-defined name. With _deriving_, both of these problems are solved in three easy steps: * Create a _quoter_: ``` ocaml let quoter = Ppx_deriving.create_quoter () in ... ``` * Pass the user-provided expressions, if any, through the quoter, such as by using a helper function: ```ocaml let attr_custom_fn attrs = Ppx_deriving.(attrs |> attr ~deriver "custom_fn" |> Arg.(get_attr ~deriver expr) |> quote ~quoter) ``` * Wrap the generated code: ```ocaml let expr_of_typ typ = let quoter = ... and expr = ... in Ppx_deriving.sanitize ~quoter expr ``` If the plugin does not accept user-provided expressions, `sanitize expr` could be used instead. #### FAQ The following is a list of tips for developers trying to use the ppx interface: * Module paths overwhelm you? Open all of the following modules, they don't conflict with each other: `Longident`, `Location`, `Asttypes`, `Parsetree`, `Ast_helper`, `Ast_convenience`. * Need to insert some ASTs? See [ppx_metaquot](https://github.com/alainfrisch/ppx_tools/blob/master/ppx_metaquot.ml); it is contained in the `ppx_tools.metaquot` package. * Need to display an error? Use `Ppx_deriving.raise_errorf ~loc "Cannot derive Foo: (error description)"` ([doc](http://ocaml-ppx.github.io/ppx_deriving/ppx_deriving/Ppx_deriving/index.html#val-raise_errorf)); keep it clear which deriving plugin raised the error! * Need to derive a function name from a type name? Use [Ppx_deriving.mangle_type_decl](http://ocaml-ppx.github.io/ppx_deriving/ppx_deriving/Ppx_deriving/index.html#val-mangle_type_decl) and [Ppx_deriving.mangle_lid](http://ocaml-ppx.github.io/ppx_deriving/ppx_deriving/Ppx_deriving/index.html#val-mangle_lid). * Need to fetch an attribute from a node? Use `Ppx_deriving.attr ~prefix "foo" nod.nod_attributes` ([doc](http://ocaml-ppx.github.io/ppx_deriving/ppx_deriving/Ppx_deriving/index.html#val-attr)); this takes care of interoperability. * Put all functions derived from a set of type declarations into a single `let rec` block; this reflects the always-recursive nature of type definitions. * Need to handle polymorphism? Use [Ppx_deriving.poly_fun_of_type_decl](http://ocaml-ppx.github.io/ppx_deriving/ppx_deriving/Ppx_deriving/index.html#val-poly_fun_of_type_decl) for derived functions, [Ppx_deriving.poly_arrow_of_type_decl](http://ocaml-ppx.github.io/ppx_deriving/ppx_deriving/Ppx_deriving/index.html#val-poly_arrow_of_type_decl) for signatures, and [Ppx_deriving.poly_apply_of_type_decl](http://ocaml-ppx.github.io/ppx_deriving/ppx_deriving/Ppx_deriving/index.html#val-poly_apply_of_type_decl) for "forwarding" the arguments corresponding to type variables to another generated function. * Need to display a full path to a type, e.g. for an error message? Use [Ppx_deriving.path_of_type_decl](http://ocaml-ppx.github.io/ppx_deriving/ppx_deriving/Ppx_deriving/index.html#val-path_of_type_decl). * Need to apply a sequence or a binary operator to variant, tuple or record elements? Use [Ppx_deriving.fold_exprs](http://ocaml-ppx.github.io/ppx_deriving/ppx_deriving/Ppx_deriving/index.html#val-fold_exprs). * Don't forget to display an error message if your plugin doesn't parse any options. License ------- _deriving_ is distributed under the terms of [MIT license](LICENSE.txt). ppx_deriving-6.0.2/dune000066400000000000000000000001141462406363500151000ustar00rootroot00000000000000(env (_ (flags :standard -w -27-9))) ; TODO: Use the full standard flags ppx_deriving-6.0.2/dune-project000066400000000000000000000000651462406363500165510ustar00rootroot00000000000000(lang dune 1.0) (name ppx_deriving) (version 5.2.1) ppx_deriving-6.0.2/dune-workspace.dev000066400000000000000000000002561462406363500176600ustar00rootroot00000000000000(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)))ppx_deriving-6.0.2/ppx_deriving.opam000066400000000000000000000016671462406363500176140ustar00rootroot00000000000000opam-version: "2.0" maintainer: "whitequark " authors: [ "whitequark " ] license: "MIT" homepage: "https://github.com/ocaml-ppx/ppx_deriving" doc: "https://ocaml-ppx.github.io/ppx_deriving/" bug-reports: "https://github.com/ocaml-ppx/ppx_deriving/issues" dev-repo: "git+https://github.com/ocaml-ppx/ppx_deriving.git" tags: [ "syntax" ] build: [ ["dune" "subst"] {dev} ["dune" "build" "-p" name "-j" jobs] ["dune" "runtest" "-p" name "-j" jobs] {with-test} ["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc} ] depends: [ "ocaml" {>= "4.05.0"} "dune" {>= "1.6.3"} "cppo" {>= "1.1.0" & build} "ocamlfind" "ppx_derivers" "ppxlib" {>= "0.32.0"} "ounit2" {with-test} ] synopsis: "Type-driven code generation for OCaml" description: """ ppx_deriving provides common infrastructure for generating code based on type definitions, and a set of useful plugins for common tasks. """ ppx_deriving-6.0.2/src/000077500000000000000000000000001462406363500150155ustar00rootroot00000000000000ppx_deriving-6.0.2/src/api/000077500000000000000000000000001462406363500155665ustar00rootroot00000000000000ppx_deriving-6.0.2/src/api/dune000066400000000000000000000010401462406363500164370ustar00rootroot00000000000000(library (name ppx_deriving_api) (public_name ppx_deriving.api) (synopsis "Plugin API for ppx_deriving") (preprocess (pps ppxlib.metaquot)) (wrapped false) (ppx_runtime_libraries ppx_deriving_runtime) (libraries compiler-libs.common ppxlib ppx_derivers)) (rule (deps ppx_deriving.cppo.ml) (targets ppx_deriving.ml) (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets}))) (rule (deps ppx_deriving.cppo.mli) (targets ppx_deriving.mli) (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets}))) ppx_deriving-6.0.2/src/api/ppx_deriving.cppo.ml000066400000000000000000000653221462406363500215660ustar00rootroot00000000000000open Ppxlib open Asttypes open Ast_helper module Ast_convenience = struct (* Formerly defined in Ppx_tools.Ast_convenience. Ppx_tools is not compatible with Ppxlib. *) let mkloc txt loc = { txt; loc } let mknoloc txt = mkloc txt !Ast_helper.default_loc let str_of_string s = mknoloc s let lid_of_string s = mknoloc (Longident.parse s) let unit () = let loc = !Ast_helper.default_loc in [%expr ()] let punit () = let loc = !Ast_helper.default_loc in [%pat? ()] let str s = Ast_helper.Exp.constant (Ast_helper.Const.string s) let int i = Ast_helper.Exp.constant (Ast_helper.Const.int i) let pint i = Ast_helper.Pat.constant (Ast_helper.Const.int i) let evar name = Ast_helper.Exp.ident (lid_of_string name) let pvar name = Ast_helper.Pat.var (str_of_string name) let app f args = match args with | [] -> f | _ -> let args = List.map (fun e -> (Nolabel, e)) args in Ast_helper.Exp.apply f args let constr name args = let args = match args with | [] -> None | [arg] -> Some arg | _ -> Some (Ast_helper.Exp.tuple args) in Ast_helper.Exp.construct (lid_of_string name) args let pconstr name args = let args = match args with | [] -> None | [arg] -> Some arg | _ -> Some (Ast_helper.Pat.tuple args) in Ast_helper.Pat.construct (lid_of_string name) args let tconstr name args = Ast_helper.Typ.constr (lid_of_string name) args let record fields = let fields = List.map (fun (name, value) -> (lid_of_string name, value)) fields in Ast_helper.Exp.record fields None let precord ~closed fields = let fields = List.map (fun (name, value) -> (lid_of_string name, value)) fields in Ast_helper.Pat.record fields closed let tuple items = match items with | [] -> unit () | [item] -> item | _ -> Ast_helper.Exp.tuple items let ptuple items = match items with | [] -> punit () | [item] -> item | _ -> Ast_helper.Pat.tuple items let attribute_has_name name attribute = attribute.attr_name.txt = name let has_attr name attributes = List.exists (attribute_has_name name) attributes let find_attr name attributes = match List.find (attribute_has_name name) attributes with | exception Not_found -> None | attribute -> Some attribute.attr_payload module Label = struct let nolabel = Nolabel let labelled s = Labelled s let optional s = Optional s end end open Ast_convenience type tyvar = string Location.loc type deriver = { name : string ; core_type : (core_type -> expression) option; type_decl_str : options:(string * expression) list -> path:string list -> type_declaration list -> structure; type_ext_str : options:(string * expression) list -> path:string list -> type_extension -> structure; module_type_decl_str : options:(string * expression) list -> path:string list -> module_type_declaration -> structure; type_decl_sig : options:(string * expression) list -> path:string list -> type_declaration list -> signature; type_ext_sig : options:(string * expression) list -> path:string list -> type_extension -> signature; module_type_decl_sig : options:(string * expression) list -> path:string list -> module_type_declaration -> signature; } type Ppx_derivers.deriver += T of deriver type internal_or_external = | Internal of deriver | External of string let hooks = Queue.create () let add_register_hook f = Queue.add f hooks let register d = Ppx_derivers.register d.name (T d); Queue.iter (fun f -> f d) hooks let derivers () = List.fold_left (fun acc (_name, drv) -> match drv with | T d -> d :: acc | _ -> acc) [] (Ppx_derivers.derivers ()) let lookup_internal_or_external name = match Ppx_derivers.lookup name with | Some (T d) -> Some (Internal d) | Some _ -> Some (External name) | None -> None let lookup name = match lookup_internal_or_external name with | Some (Internal d) -> Some d | Some (External _) | None -> None let raise_errorf ?sub ?loc fmt = let module Location = Ocaml_common.Location in let raise_msg str = #if OCAML_VERSION >= (4, 08, 0) let sub = let msg_of_error err = { txt = (fun fmt -> Location.print_report fmt err); loc = err.Location.main.loc } in Option.map (List.map msg_of_error) sub in #endif let err = Location.error ?sub ?loc str in raise (Location.Error err) in Printf.ksprintf raise_msg fmt let create = let def_ext_str name ~options ~path typ_ext = raise_errorf "Extensible types in structures not supported by deriver %s" name in let def_ext_sig name ~options ~path typ_ext = raise_errorf "Extensible types in signatures not supported by deriver %s" name in let def_decl_str name ~options ~path typ_decl = raise_errorf "Type declarations in structures not supported by deriver %s" name in let def_decl_sig name ~options ~path typ_decl = raise_errorf "Type declarations in signatures not supported by deriver %s" name in let def_module_type_decl_str name ~options ~path module_type_decl = raise_errorf "Module type declarations in structures not supported by \ deriver %s" name in let def_module_type_decl_sig name ~options ~path module_type_decl = raise_errorf "Module type declarations in signatures not supported by \ deriver %s" name in fun name ?core_type ?(type_ext_str=def_ext_str name) ?(type_ext_sig=def_ext_sig name) ?(type_decl_str=def_decl_str name) ?(type_decl_sig=def_decl_sig name) ?(module_type_decl_str=def_module_type_decl_str name) ?(module_type_decl_sig=def_module_type_decl_sig name) () -> { name ; core_type ; type_decl_str ; type_ext_str ; module_type_decl_str ; type_decl_sig ; type_ext_sig ; module_type_decl_sig ; } let string_of_core_type typ = Format.asprintf "%a" Pprintast.core_type { typ with ptyp_attributes = [] } let string_of_constant_opt (constant : Parsetree.constant) : string option = match constant with | Pconst_string (s, _, _) -> Some s | _ -> None let string_of_expression_opt (e : Parsetree.expression) : string option = match e with | { pexp_desc = Pexp_constant constant } -> string_of_constant_opt constant | _ -> None module Arg = struct type 'a conv = expression -> ('a, string) result let expr expr = Ok expr let int expr = match expr with | { pexp_desc = Pexp_constant (Pconst_integer (sn, _)) } -> Ok (int_of_string sn) | _ -> Error "integer" let bool expr = match expr with | [%expr true] -> Ok true | [%expr false] -> Ok false | _ -> Error "boolean" let string expr = match expr with | { pexp_desc = Pexp_constant (Pconst_string (n, _, None)) } -> Ok n | _ -> Error "string" let char = function | { pexp_desc = Pexp_constant (Pconst_char c) } -> Ok c | _ -> Error "char" let enum values expr = match expr with | { pexp_desc = Pexp_variant (name, None) } when List.mem name values -> Ok name | _ -> Error (Printf.sprintf "one of: %s" (String.concat ", " (List.map (fun s -> "`"^s) values))) let list expr = let rec loop acc = function | [%expr []] -> Ok (List.rev acc) | [%expr [%e? x]::[%e? xs]] -> begin match expr x with | Ok v -> loop (v::acc) xs | Error e -> Error ("list:" ^ e) end | _ -> Error "list" in loop [] let get_attr ~deriver conv attr = match attr with | None -> None | Some { attr_name = {txt = name; loc = _}; attr_payload = PStr [{ pstr_desc = Pstr_eval (expr, []) }]; attr_loc = _ } -> begin match conv expr with | Ok v -> Some v | Error desc -> raise_errorf ~loc:expr.pexp_loc "%s: invalid [@%s]: %s expected" deriver name desc end | Some { attr_name = {txt = name; loc}; attr_payload = _; attr_loc = _ } -> raise_errorf ~loc "%s: invalid [@%s]: value expected" deriver name let get_flag ~deriver attr = match attr with | None -> false | Some { attr_name = _; attr_payload = PStr []; attr_loc = _ } -> true | Some { attr_name = {txt = name; loc}; attr_payload = _; attr_loc = _ } -> raise_errorf ~loc "%s: invalid [@%s]: empty structure expected" deriver name let get_expr ~deriver conv expr = match conv expr with | Error desc -> raise_errorf ~loc:expr.pexp_loc "%s: %s expected" deriver desc | Ok v -> v end let attr_warning expr = let loc = !default_loc in let structure = {pstr_desc = Pstr_eval (expr, []); pstr_loc = loc} in { attr_name = { txt = "ocaml.warning"; loc; }; attr_payload = PStr [structure]; attr_loc = loc; } type quoter = Expansion_helpers.Quoter.t let create_quoter () = Expansion_helpers.Quoter.create () let quote ~quoter expr = Expansion_helpers.Quoter.quote quoter expr let sanitize ?(module_=Lident "Ppx_deriving_runtime") ?(quoter=create_quoter ()) expr = let loc = !Ast_helper.default_loc in let body = let attrs = [attr_warning [%expr "-A"]] in let modname = { txt = module_; loc } in Exp.open_ ~loc ~attrs (Opn.mk ~loc ~attrs ~override:Override (Mod.ident ~loc ~attrs modname)) expr in let sanitized = Expansion_helpers.Quoter.sanitize quoter body in (* ppxlib quoter uses Recursive, ppx_deriving's used Nonrecursive - silence warning *) { sanitized with pexp_attributes = attr_warning [%expr "-39"] :: sanitized.pexp_attributes} let with_quoter fn a = let quoter = create_quoter () in sanitize ~quoter (fn quoter a) let expand_path ~path ident = String.concat "." (path @ [ident]) let path_of_type_decl ~path type_decl = match type_decl.ptype_manifest with | Some { ptyp_desc = Ptyp_constr ({ txt = lid }, _) } -> begin match lid with | Lident _ -> [] | Ldot (lid, _) -> Ocaml_common.Longident.flatten lid | Lapply _ -> assert false end | _ -> path let mangle ?(fixpoint="t") affix name = match name = fixpoint, affix with | true, (`Prefix x | `Suffix x) -> x | true, `PrefixSuffix (p, s) -> p ^ "_" ^ s | false, `PrefixSuffix (p, s) -> p ^ "_" ^ name ^ "_" ^ s | false, `Prefix x -> x ^ "_" ^ name | false, `Suffix x -> name ^ "_" ^ x let mangle_type_decl ?fixpoint affix { ptype_name = { txt = name } } = mangle ?fixpoint affix name let mangle_lid ?fixpoint affix lid = match lid with | Lident s -> Lident (mangle ?fixpoint affix s) | Ldot (p, s) -> Ldot (p, mangle ?fixpoint affix s) | Lapply _ -> assert false let attr ~deriver name attrs = let starts prefix str = String.length str >= String.length prefix && String.sub str 0 (String.length prefix) = prefix in let attr_starts prefix attr = starts prefix attr.attr_name.txt in let attr_is name attr = name = attr.attr_name.txt in let try_prefix prefix f = if List.exists (attr_starts prefix) attrs then prefix ^ name else f () in let name = try_prefix ("deriving."^deriver^".") (fun () -> try_prefix (deriver^".") (fun () -> name)) in try Some (List.find (attr_is name) attrs) with Not_found -> None let attr_nobuiltin ~deriver attrs = attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver let rec remove_pervasive_lid = function | Lident _ as lid -> lid | Ldot (Lident "Pervasives", s) -> Lident s | Ldot (Lident "Stdlib", s) -> Lident s | Ldot (lid, s) -> Ldot (remove_pervasive_lid lid, s) | Lapply (lid, lid2) -> Lapply (remove_pervasive_lid lid, remove_pervasive_lid lid2) let remove_pervasives ~deriver typ = if attr_nobuiltin ~deriver typ.ptyp_attributes then typ else let mapper = object inherit Ppxlib.Ast_traverse.map as super method! core_type typ = match super#core_type typ with | { ptyp_desc = Ptyp_constr (lid, l)} -> let lid = {lid with txt = remove_pervasive_lid lid.txt} in {typ with ptyp_desc = Ptyp_constr (lid, l)} | { ptyp_desc = Ptyp_class (lid, l)} -> let lid = {lid with txt = remove_pervasive_lid lid.txt} in {typ with ptyp_desc = Ptyp_class (lid, l)} | typ -> typ end in mapper#core_type typ let mkloc = Ocaml_common.Location.mkloc let fold_left_type_params fn accum params = List.fold_left (fun accum (param, _) -> match param with | { ptyp_desc = Ptyp_any } -> accum | { ptyp_desc = Ptyp_var name } -> let name = mkloc name param.ptyp_loc in fn accum name | _ -> assert false) accum params let fold_left_type_decl fn accum { ptype_params } = fold_left_type_params fn accum ptype_params let fold_left_type_ext fn accum { ptyext_params } = fold_left_type_params fn accum ptyext_params let fold_right_type_params fn params accum = List.fold_right (fun (param, _) accum -> match param with | { ptyp_desc = Ptyp_any } -> accum | { ptyp_desc = Ptyp_var name } -> let name = mkloc name param.ptyp_loc in fn name accum | _ -> assert false) params accum let fold_right_type_decl fn { ptype_params } accum = fold_right_type_params fn ptype_params accum let fold_right_type_ext fn { ptyext_params } accum = fold_right_type_params fn ptyext_params accum let free_vars_in_core_type typ = let rec free_in typ = match typ with | { ptyp_desc = Ptyp_any } -> [] | { ptyp_desc = Ptyp_var name } -> [mkloc name typ.ptyp_loc] | { ptyp_desc = Ptyp_arrow (_, x, y) } -> free_in x @ free_in y | { ptyp_desc = (Ptyp_tuple xs | Ptyp_constr (_, xs)) } -> List.map free_in xs |> List.concat | { ptyp_desc = Ptyp_alias (x, name) } -> [mkloc name typ.ptyp_loc] @ free_in x | { ptyp_desc = Ptyp_poly (bound, x) } -> List.filter (fun y -> not (List.mem y bound)) (free_in x) | { ptyp_desc = Ptyp_variant (rows, _, _) } -> List.map ( function { prf_desc = Rtag(_,_,ts) } -> List.map free_in ts | { prf_desc = Rinherit(t) } -> [free_in t] ) rows |> List.concat |> List.concat | _ -> assert false in let uniq lst = let module StringSet = Set.Make(String) in let add (rev_names, txts) name = let txt = name.txt in if StringSet.mem txt txts then (rev_names, txts) else (name :: rev_names, StringSet.add txt txts) in List.rev (fst (List.fold_left add ([], StringSet.empty) lst)) in free_in typ |> uniq let var_name_of_int i = let letter = "abcdefghijklmnopqrstuvwxyz" in let rec loop i = if i < 26 then [letter.[i]] else letter.[i mod 26] :: loop (i / 26) in String.concat "" (List.map (String.make 1) (loop i)) let fresh_var bound = let rec loop i = let var_name = var_name_of_int i in if List.mem var_name bound then loop (i + 1) else var_name in loop 0 let poly_fun_of_type_decl type_decl expr = fold_right_type_decl (fun name expr -> let name = name.txt in Exp.fun_ Label.nolabel None (pvar ("poly_"^name)) expr) type_decl expr let poly_fun_of_type_ext type_ext expr = fold_right_type_ext (fun name expr -> let name = name.txt in Exp.fun_ Label.nolabel None (pvar ("poly_"^name)) expr) type_ext expr let poly_apply_of_type_decl type_decl expr = fold_left_type_decl (fun expr name -> let name = name.txt in Exp.apply expr [Label.nolabel, evar ("poly_"^name)]) expr type_decl let poly_apply_of_type_ext type_ext expr = fold_left_type_ext (fun expr name -> let name = name.txt in Exp.apply expr [Label.nolabel, evar ("poly_"^name)]) expr type_ext let poly_arrow_of_type_decl fn type_decl typ = fold_right_type_decl (fun name typ -> let name = name.txt in Typ.arrow Label.nolabel (fn (Typ.var name)) typ) type_decl typ let poly_arrow_of_type_ext fn type_ext typ = fold_right_type_ext (fun name typ -> let var = Typ.var ~loc:name.loc name.txt in Typ.arrow Label.nolabel (fn var) typ) type_ext typ let core_type_of_type_decl { ptype_name = name; ptype_params } = let name = mkloc (Lident name.txt) name.loc in Typ.constr name (List.map fst ptype_params) let core_type_of_type_ext { ptyext_path ; ptyext_params } = Typ.constr ptyext_path (List.map fst ptyext_params) let instantiate bound type_decl = let vars, bound = List.fold_right (fun _ (vars, bound) -> let v = fresh_var bound in (v :: vars, v :: bound)) (free_vars_in_core_type (core_type_of_type_decl type_decl)) ([], bound) in let vars = List.rev vars in let core_type = core_type_of_type_decl { type_decl with ptype_params = List.map2 (fun v (_, variance) -> Typ.var v, variance) vars type_decl.ptype_params } in core_type, vars, bound let fold_exprs ?unit fn exprs = match exprs with | [a] -> a | hd::tl -> List.fold_left fn hd tl | [] -> match unit with | Some x -> x | None -> raise (Invalid_argument "Ppx_deriving.fold_exprs") let seq_reduce ?sep a b = let loc = !Ast_helper.default_loc in match sep with | Some x -> [%expr [%e a]; [%e x]; [%e b]] | None -> [%expr [%e a]; [%e b]] let binop_reduce x a b = let loc = !Ast_helper.default_loc in [%expr [%e x] [%e a] [%e b]] let strong_type_of_type ty = let free_vars = free_vars_in_core_type ty in Typ.force_poly @@ Typ.poly free_vars ty type deriver_options = | Options of (string * expression) list | Unknown_syntax let derive path pstr_loc item attributes fn arg = let deriving = find_attr "deriving" attributes in let deriver_exprs, loc = match deriving with | Some (PStr [{ pstr_desc = Pstr_eval ( { pexp_desc = Pexp_tuple exprs }, []); pstr_loc }]) -> exprs, pstr_loc | Some (PStr [{ pstr_desc = Pstr_eval ( { pexp_desc = (Pexp_ident _ | Pexp_apply _) } as expr, []); pstr_loc }]) -> [expr], pstr_loc | _ -> raise_errorf ~loc:pstr_loc "Unrecognized [@@deriving] annotation syntax" in List.fold_left (fun items deriver_expr -> let name, options = match deriver_expr with | { pexp_desc = Pexp_ident name } -> name, Options [] | { pexp_desc = Pexp_apply ({ pexp_desc = Pexp_ident name }, [label, { pexp_desc = Pexp_record (options, None) }]) } when label = Label.nolabel -> name, Options (options |> List.map (fun ({ txt }, expr) -> String.concat "." (Ocaml_common.Longident.flatten txt), expr)) | { pexp_desc = Pexp_apply ({ pexp_desc = Pexp_ident name }, _) } -> name, Unknown_syntax | { pexp_loc } -> raise_errorf ~loc:pexp_loc "Unrecognized [@@deriving] syntax" in let name, loc = String.concat "_" (Ocaml_common.Longident.flatten name.txt), name.loc in let is_optional, options = match options with | Unknown_syntax -> false, options | Options options' -> match List.assoc "optional" options' with | exception Not_found -> false, options | expr -> Arg.(get_expr ~deriver:name bool) expr, Options (List.remove_assoc "optional" options') in match lookup_internal_or_external name, options with | Some (Internal deriver), Options options -> items @ ((fn deriver) ~options ~path:(!path) arg) | Some (Internal _), Unknown_syntax -> raise_errorf ~loc:deriver_expr.pexp_loc "Unrecognized [@@deriving] option syntax" | Some (External _), _ -> items | None, _ -> if is_optional then items else raise_errorf ~loc "Cannot locate deriver %s" name) [item] deriver_exprs let derive_type_decl path typ_decls pstr_loc item fn = let attributes = List.concat (List.map (fun { ptype_attributes = attrs } -> attrs) typ_decls) in derive path pstr_loc item attributes fn typ_decls let derive_type_ext path typ_ext pstr_loc item fn = let attributes = typ_ext.ptyext_attributes in derive path pstr_loc item attributes fn typ_ext let derive_module_type_decl path module_type_decl pstr_loc item fn = let attributes = module_type_decl.pmtd_attributes in derive path pstr_loc item attributes fn module_type_decl let module_from_input_name () = match !Ocaml_common.Location.input_name with | "" | "//toplevel//" -> [] | filename -> let capitalize = String.capitalize_ascii in match Filename.chop_suffix filename ".ml" with | exception _ -> (* see https://github.com/ocaml-ppx/ppx_deriving/pull/196 *) [] | path -> [capitalize (Filename.basename path)] let pstr_desc_rec_flag pstr = match pstr with | Pstr_type(rec_flag, typ_decls) -> rec_flag | _ -> assert false let module_nesting = ref [] let with_module name f = let old_nesting = !module_nesting in begin match name with | Some name -> module_nesting := !module_nesting @ [name] | None -> () end; let result = f () in module_nesting := old_nesting; result class mapper = object (self) inherit Ast_traverse.map as super method! expression expr = match expr with | { pexp_desc = Pexp_extension ({ txt = name; loc }, payload) } when String.(length name >= 7 && sub name 0 7 = "derive.") -> let name = String.sub name 7 ((String.length name) - 7) in let deriver = match lookup_internal_or_external name with | Some (Internal { core_type = Some deriver }) -> deriver | Some _ -> raise_errorf ~loc "Deriver %s does not support inline notation" name | None -> raise_errorf ~loc "Cannot locate deriver %s" name in begin match payload with | PTyp typ -> deriver typ | _ -> raise_errorf ~loc "Unrecognized [%%derive.*] syntax" end | { pexp_desc = Pexp_extension ({ txt = name; loc }, PTyp typ) } -> begin match lookup_internal_or_external name with | Some (Internal { core_type = Some deriver }) -> Ast_helper.with_default_loc typ.ptyp_loc (fun () -> deriver typ) | _ -> super#expression expr end | _ -> super#expression expr method! structure items = match items with | { pstr_desc = Pstr_type(_, typ_decls) as pstr_desc ; pstr_loc } :: rest when List.exists (fun ty -> has_attr "deriving" ty.ptype_attributes) typ_decls && pstr_desc_rec_flag pstr_desc = Nonrecursive -> raise_errorf ~loc:pstr_loc "The nonrec flag is not supported by ppx_deriving" | { pstr_desc = Pstr_type(_, typ_decls); pstr_loc } as item :: rest when List.exists (fun ty -> has_attr "deriving" ty.ptype_attributes) typ_decls -> let derived = Ast_helper.with_default_loc pstr_loc (fun () -> derive_type_decl module_nesting typ_decls pstr_loc item (fun deriver -> deriver.type_decl_str)) in derived @ self#structure rest | { pstr_desc = Pstr_typext typ_ext; pstr_loc } as item :: rest when has_attr "deriving" typ_ext.ptyext_attributes -> let derived = Ast_helper.with_default_loc pstr_loc (fun () -> derive_type_ext module_nesting typ_ext pstr_loc item (fun deriver -> deriver.type_ext_str)) in derived @ self#structure rest | { pstr_desc = Pstr_modtype modtype; pstr_loc } as item :: rest when has_attr "deriving" modtype.pmtd_attributes -> let derived = Ast_helper.with_default_loc pstr_loc (fun () -> derive_module_type_decl module_nesting modtype pstr_loc item (fun deriver -> deriver.module_type_decl_str)) in derived @ self#structure rest | { pstr_desc = Pstr_module ({ pmb_name = { txt = name } } as mb) } as item :: rest -> let derived = { item with pstr_desc = Pstr_module ( with_module name (fun () -> self#module_binding mb)) } in derived :: self#structure rest | { pstr_desc = Pstr_recmodule mbs } as item :: rest -> let derived = { item with pstr_desc = Pstr_recmodule ( mbs |> List.map (fun ({ pmb_name = { txt = name } } as mb) -> with_module name (fun () -> self#module_binding mb))) } in derived :: self#structure rest | { pstr_loc } as item :: rest -> let derived = self#structure_item item in derived :: self#structure rest | [] -> [] method! signature items = match items with | { psig_desc = Psig_type(_, typ_decls); psig_loc } as item :: rest when List.exists (fun ty -> has_attr "deriving" ty.ptype_attributes) typ_decls -> let derived = Ast_helper.with_default_loc psig_loc (fun () -> derive_type_decl module_nesting typ_decls psig_loc item (fun deriver -> deriver.type_decl_sig)) in derived @ self#signature rest | { psig_desc = Psig_typext typ_ext; psig_loc } as item :: rest when has_attr "deriving" typ_ext.ptyext_attributes -> let derived = Ast_helper.with_default_loc psig_loc (fun () -> derive_type_ext module_nesting typ_ext psig_loc item (fun deriver -> deriver.type_ext_sig)) in derived @ self#signature rest | { psig_desc = Psig_modtype modtype; psig_loc } as item :: rest when has_attr "deriving" modtype.pmtd_attributes -> let derived = Ast_helper.with_default_loc psig_loc (fun () -> derive_module_type_decl module_nesting modtype psig_loc item (fun deriver -> deriver.module_type_decl_sig)) in derived @ self#signature rest | { psig_desc = Psig_module ({ pmd_name = { txt = name } } as md) } as item :: rest -> let derived = { item with psig_desc = Psig_module ( with_module name (fun () -> self#module_declaration md)) } in derived :: self#signature rest | { psig_desc = Psig_recmodule mds } as item :: rest -> let derived = { item with psig_desc = Psig_recmodule ( mds |> List.map (fun ({ pmd_name = { txt = name } } as md) -> with_module name (fun () -> self#module_declaration md))) } in derived :: self#signature rest | { psig_loc } as item :: rest -> let derived = self#signature_item item in derived :: self#signature rest | [] -> [] end let map_structure s = module_nesting := module_from_input_name (); (new mapper)#structure s let map_signature s = module_nesting := module_from_input_name (); (new mapper)#signature s let hash_variant s = let accu = ref 0 in for i = 0 to String.length s - 1 do accu := 223 * !accu + Char.code s.[i] done; (* reduce to 31 bits *) accu := !accu land (1 lsl 31 - 1); (* make it signed for 64 bits architectures *) if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu (* This is only used when ppx_deriving is linked as part of an ocaml-migrate-parsetre driver. *) let () = Ppxlib.Driver.register_transformation "ppx_deriving" ~impl:map_structure ~intf:map_signature ppx_deriving-6.0.2/src/api/ppx_deriving.cppo.mli000066400000000000000000000373471462406363500217450ustar00rootroot00000000000000(** Public API of [ppx_deriving] executable. *) open Ppxlib type tyvar = string Location.loc (** {2 Registration} *) (** A type of deriving plugins. A structure or signature deriving function accepts a list of [~options], a [~path] of modules for the type declaration currently being processed (with [[]] for toplevel phrases), and a type declaration item ([type t = .. and t' = ..]), and returns a list of items to be appended after the type declaration item in structure and signature. It is invoked by [[\@\@deriving]] annotations. A type deriving function accepts a type and returns a corresponding derived expression. It is invoked by [[%derive.foo:]] and [[%foo:]] annotations. If this function is missing, the corresponding [[%foo:]] annotation is ignored. The structure and signature deriving functions are invoked in the order in which they appear in the source code. *) type deriver = { name : string ; core_type : (core_type -> expression) option; type_decl_str : options:(string * expression) list -> path:string list -> type_declaration list -> structure; type_ext_str : options:(string * expression) list -> path:string list -> type_extension -> structure; module_type_decl_str : options:(string * expression) list -> path:string list -> module_type_declaration -> structure; type_decl_sig : options:(string * expression) list -> path:string list -> type_declaration list -> signature; type_ext_sig : options:(string * expression) list -> path:string list -> type_extension -> signature; module_type_decl_sig : options:(string * expression) list -> path:string list -> module_type_declaration -> signature; } (** [register deriver] registers [deriver] according to its [name] field. *) val register : deriver -> unit (** [add_register_hook hook] adds [hook] to be executed whenever a new deriver is registered. *) val add_register_hook : (deriver -> unit) -> unit (** [derivers ()] returns all currently registered derivers. *) val derivers : unit -> deriver list (** Creating {!deriver} structure. *) val create : string -> ?core_type: (core_type -> expression) -> ?type_ext_str: (options:(string * expression) list -> path:string list -> type_extension -> structure) -> ?type_ext_sig: (options:(string * expression) list -> path:string list -> type_extension -> signature) -> ?type_decl_str: (options:(string * expression) list -> path:string list -> type_declaration list -> structure) -> ?type_decl_sig: (options:(string * expression) list -> path:string list -> type_declaration list -> signature) -> ?module_type_decl_str: (options:(string * expression) list -> path:string list -> module_type_declaration -> structure) -> ?module_type_decl_sig: (options:(string * expression) list -> path:string list -> module_type_declaration -> signature) -> unit -> deriver (** [lookup name] looks up a deriver called [name]. *) val lookup : string -> deriver option (** {2 Error handling} *) val raise_errorf : ?sub:Ocaml_common.Location.error list -> ?loc:Location.t -> ('a, unit, string, 'b) format4 -> 'a (** {2 Coercions} *) (** [string_of_core_type typ] unparses [typ], omitting any attributes. *) val string_of_core_type : Parsetree.core_type -> string (** [string_of_constant_opt c] returns [Some s] if the constant [c] is a string [s], [None] otherwise. *) val string_of_constant_opt : Parsetree.constant -> string option (** [string_of_expression_opt e] returns [Some s] if the expression [e] is a string constant [s], [None] otherwise. *) val string_of_expression_opt : Parsetree.expression -> string option (** {2 Option parsing} *) (** {!Arg} contains convenience functions that extract constants from AST fragments, to be used when parsing options or [[\@attributes]] attached to types, fields or constructors. The [~name] argument is used in error messages and should receive the name of the deriving plugin, e.g. ["show"]. *) module Arg : sig (** A type of conversion functions. A conversion function of type ['a conv] converts a raw expression into an argument of type ['a]. Or returns [Error "error"] if conversion fails. *) type 'a conv = expression -> ('a, string) result (** [expr] returns the input expression as-is. *) val expr : expression conv (** [bool expr] extracts a boolean constant from [expr], or returns [Error "boolean"] if [expr] does not contain a boolean literal. *) val bool : bool conv (** [int expr] extracts an integer constant from [expr], or returns [Error "integer"] if [expr] does not contain an integer literal. *) val int : int conv (** [string expr] extracts a string constant from [expr], or returns [Error "string"] if [expr] does not contain a string literal. *) val string : string conv (** [char expr] extracts a char constant from [expr], or returns [Error "char"] if [expr] does not contain a char literal. *) val char : char conv (** [enum values expr] extracts a polymorphic variant constant from [expr], or returns [Error "one of: `a, `b, ..."] if [expr] does not contain a polymorphic variant constructor included in [values]. *) val enum : string list -> string conv (** [list f expr] extracts a list constant from [expr] and maps every element through [f], or returns [Error "list:..."] where [...] is the error returned by [f], or returns [Error "list"] if [expr] does not contain a list. *) val list : 'a conv -> 'a list conv (** [get_attr ~deriver conv attr] extracts the expression from [attr] and converts it with [conv], raising [Location.Error] if [attr] is not a structure with a single expression or [conv] fails; or returns [None] if [attr] is [None]. The name of the deriving plugin should be passed as [deriver]; it is used in error messages. Example usage: {[ let deriver = "index" (* ... *) let kind = match Ppx_deriving.attr ~deriver "kind" pcd_attributes |> Ppx_deriving.Arg.(get_attr ~deriver (enum ["flat"; "nested"])) with | Some "flat" -> `flat | Some "nested" -> `nested | None -> `default in .. ]} *) val get_attr : deriver:string -> 'a conv -> attribute option -> 'a option (** [get_flag ~deriver attr] returns [true] if [attr] is an empty attribute or [false] if it is absent, raising [Location.Error] if [attr] is not a structure. The name of the deriving plugin should be passed as [deriver]; it is used in error messages. *) val get_flag : deriver:string -> attribute option -> bool (** [get_expr ~deriver conv exp] converts expression [exp] with [conv], raising [Location.Error] if [conv] fails. The name of the deriving plugin should be passed as [deriver]; it is used in error messages. *) val get_expr : deriver:string -> 'a conv -> expression -> 'a end (** {2 Hygiene} *) (** A [quoter] remembers a set of expressions. *) type quoter (** [quoter ()] creates an empty quoter. *) val create_quoter : unit -> quoter (** [quote quoter expr] records a pure expression [expr] within [quoter] and returns an expression which has the same value as [expr] in the context that [sanitize] provides. *) val quote : quoter:quoter -> expression -> expression (** [sanitize module_ quoter expr] wraps [expr] in a way that ensures that the contents of [module_] and {!Stdlib}, as well as the identifiers in expressions returned by [quote] are in scope, and returns the wrapped expression. [module_] defaults to {!Ppx_deriving_runtime} if it's not provided*) val sanitize : ?module_:Longident.t -> ?quoter:quoter -> expression -> expression (** [with_quoter fn] ≡ [fun fn a -> let quoter = create_quoter () in sanitize ~quoter (fn quoter a)] *) val with_quoter : (quoter -> 'a -> expression) -> 'a -> expression (** {2 AST manipulation} *) (** [expand_path name] returns [name] with the [path] module path prepended, e.g. [expand_path ["Foo";"M"] "t"] = ["Foo.M.t"] and [expand_path [] "t"] = ["t"] *) val expand_path : path:string list -> string -> string (** [path_of_type_decl ~path type_] returns [path] if [type_] does not have a manifest or the manifest is not a constructor, and the module path of manifest otherwise. [path_of_type_decl] is useful when determining the canonical path location of fields and constructors; e.g. for [type bar = M.foo = A | B], it will return [["M"]]. *) val path_of_type_decl : path:string list -> type_declaration -> string list (** [mangle_type_decl ~fixpoint affix type_] derives a function name from [type_] name by doing nothing if [type_] is named [fixpoint] (["t"] by default), or appending and/or prepending [affix] via an underscore. *) val mangle_type_decl : ?fixpoint:string -> [ `Prefix of string | `Suffix of string | `PrefixSuffix of string * string ] -> type_declaration -> string (** [mangle_lid ~fixpoint affix lid] does the same as {!mangle_type_decl}, but for the last component of [lid]. *) val mangle_lid : ?fixpoint:string -> [ `Prefix of string | `Suffix of string | `PrefixSuffix of string * string] -> Longident.t -> Longident.t (** [attr ~deriver name attrs] searches for an attribute [\[\@deriving.deriver.attr\]] in [attrs] if any attribute with name starting with [\@deriving.deriver] exists, or [\[\@deriver.attr\]] if any attribute with name starting with [\@deriver] exists, or [\[\@attr\]] otherwise. *) val attr : deriver:string -> string -> attributes -> attribute option (** [attr_warning expr] builds the attribute [\@ocaml.warning expr] *) val attr_warning: expression -> attribute (** [free_vars_in_core_type typ] returns unique free variables in [typ] in lexical order. *) val free_vars_in_core_type : core_type -> tyvar list (** [remove_pervasives ~deriver typ] removes the leading "Pervasives." and "Stdlib." module name in longidents. Type expressions marked with [\[\@nobuiltin\]] are ignored. The name of the deriving plugin should be passed as [deriver]; it is used in error messages. *) val remove_pervasives : deriver:string -> core_type -> core_type (** [fresh_var bound] returns a fresh variable name not present in [bound]. The name is selected in alphabetical succession. *) val fresh_var : string list -> string (** [fold_left_type_decl fn accum type_] performs a left fold over all type variable (i.e. not wildcard) parameters in [type_]. *) val fold_left_type_decl : ('a -> tyvar -> 'a) -> 'a -> type_declaration -> 'a (** [fold_right_type_decl fn accum type_] performs a right fold over all type variable (i.e. not wildcard) parameters in [type_]. *) val fold_right_type_decl : (tyvar -> 'a -> 'a) -> type_declaration -> 'a -> 'a (** [fold_left_type_ext fn accum type_] performs a left fold over all type variable (i.e. not wildcard) parameters in [type_]. *) val fold_left_type_ext : ('a -> tyvar -> 'a) -> 'a -> type_extension -> 'a (** [fold_right_type_ext fn accum type_] performs a right fold over all type variable (i.e. not wildcard) parameters in [type_]. *) val fold_right_type_ext : (tyvar -> 'a -> 'a) -> type_extension -> 'a -> 'a (** [poly_fun_of_type_decl type_ expr] wraps [expr] into [fun poly_N -> ...] for every type parameter ['N] present in [type_]. For example, if [type_] refers to [type ('a, 'b) map], [expr] will be wrapped into [fun poly_a poly_b -> [%e expr]]. [_] parameters are ignored. *) val poly_fun_of_type_decl : type_declaration -> expression -> expression (** Same as {!poly_fun_of_type_decl} but for type extension. *) val poly_fun_of_type_ext : type_extension -> expression -> expression (** [poly_apply_of_type_decl type_ expr] wraps [expr] into [expr poly_N] for every type parameter ['N] present in [type_]. For example, if [type_] refers to [type ('a, 'b) map], [expr] will be wrapped into [[%e expr] poly_a poly_b]. [_] parameters are ignored. *) val poly_apply_of_type_decl : type_declaration -> expression -> expression (** Same as {!poly_apply_of_type_decl} but for type extension. *) val poly_apply_of_type_ext : type_extension -> expression -> expression (** [poly_arrow_of_type_decl fn type_ typ] wraps [typ] in an arrow with [fn [%type: 'N]] as argument for every type parameter ['N] present in [type_]. For example, if [type_] refers to [type ('a, 'b) map] and [fn] is [fun var -> [%type: [%t var] -> string]], [typ] will be wrapped into [('a -> string) -> ('b -> string) -> [%t typ]]. [_] parameters are ignored. *) val poly_arrow_of_type_decl : (core_type -> core_type) -> type_declaration -> core_type -> core_type (** Same as {!poly_arrow_of_type_decl} but for type extension. *) val poly_arrow_of_type_ext : (core_type -> core_type) -> type_extension -> core_type -> core_type (** [core_type_of_type_decl type_] constructs type [('a, 'b, ...) t] for type declaration [type ('a, 'b, ...) t = ...]. *) val core_type_of_type_decl : type_declaration -> core_type (** Same as {!core_type_of_type_decl} but for type extension. *) val core_type_of_type_ext : type_extension -> core_type (** [instantiate bound type_] returns [typ, vars, bound'] where [typ] is a type instantiated from type declaration [type_], [vars] ≡ [free_vars_in_core_type typ] and [bound'] ≡ [bound @ vars]. *) val instantiate : string list -> type_declaration -> core_type * string list * string list (** [fold_exprs ~unit fn exprs] folds [exprs] using head of [exprs] as initial accumulator value, or [unit] if [exprs = []]. See also {!seq_reduce} and {!binop_reduce}. *) val fold_exprs : ?unit:expression -> (expression -> expression -> expression) -> expression list -> expression (** When [sep] is present: [seq_reduce] ≡ [fun x a b -> [%expr [%e a]; [%e x]; [%e b]]]. When [sep] is missing: [seq_reduce] ≡ [fun a b -> [%expr [%e a]; [%e b]]]. *) val seq_reduce : ?sep:expression -> expression -> expression -> expression (** [binop_reduce] ≡ [fun x a b -> [%expr [%e x] [%e a] [%e b]]]. *) val binop_reduce : expression -> expression -> expression -> expression (** [strong_type_of_type ty] transform a type ty to [freevars . ty], giving a strong polymorphic type *) val strong_type_of_type: core_type -> core_type (** The mapper for the currently loaded deriving plugins. It is useful for recursively processing expression-valued attributes. *) class mapper : Ast_traverse.map (** {2 Miscellanea} *) (** [hash_variant x] ≡ [Btype.hash_variant x]. *) val hash_variant : string -> int module Ast_convenience : sig val mkloc : 'a -> Location.t -> 'a loc val mknoloc : 'a -> 'a loc val unit : unit -> expression val punit : unit -> pattern val int : int -> expression val pint : int -> pattern val str : string -> expression val evar : string -> expression val pvar : string -> pattern val app : expression -> expression list -> expression val constr : string -> expression list -> expression val pconstr : string -> pattern list -> pattern val tconstr : string -> core_type list -> core_type val record : (string * expression) list -> expression val precord : closed:closed_flag -> (string * pattern) list -> pattern val tuple : expression list -> expression val ptuple : pattern list -> pattern val has_attr : string -> attributes -> bool val find_attr : string -> attributes -> payload option module Label : sig val nolabel : arg_label val labelled : string -> arg_label val optional : string -> arg_label end end ppx_deriving-6.0.2/src/dune000066400000000000000000000006241462406363500156750ustar00rootroot00000000000000(rule (deps ppx_deriving_main.cppo.ml) (targets ppx_deriving_main.ml) (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets}))) (executable (name ppx_deriving_main) (libraries ppx_deriving_api findlib.dynload compiler-libs.common) (link_flags :standard -linkall) (preprocess (pps ppxlib.metaquot))) (install (section libexec) (files (ppx_deriving_main.exe as ppx_deriving))) ppx_deriving-6.0.2/src/ppx_deriving_main.cppo.ml000066400000000000000000000057751462406363500220270ustar00rootroot00000000000000open Ppxlib open Asttypes open Parsetree open Ast_helper module Ast_mapper = Ocaml_common.Ast_mapper module From_current = Ppxlib_ast.Selected_ast.Of_ocaml module To_current = Ppxlib_ast.Selected_ast.To_ocaml let raise_errorf = Ppx_deriving.raise_errorf let dynlink ?(loc=Location.none) filename = let filename = Dynlink.adapt_filename filename in try Dynlink.loadfile filename with Dynlink.Error error -> raise_errorf ~loc "Cannot load %s: %s" filename (Dynlink.error_message error) let init_findlib = lazy ( Findlib.init (); Findlib.record_package Findlib.Record_core "ppx_deriving.api"; ) let load_ocamlfind_package ?loc pkg = Lazy.force init_findlib; try Fl_dynload.load_packages [pkg] with Dynlink.Error error -> raise_errorf ?loc "Cannot load %s: %s" pkg (Dynlink.error_message error) let load_plugin ?loc plugin = let len = String.length plugin in let pkg_prefix = "package:" in let pkg_prefix_len = String.length pkg_prefix in if len >= pkg_prefix_len && String.sub plugin 0 pkg_prefix_len = pkg_prefix then let pkg = String.sub plugin pkg_prefix_len (len - pkg_prefix_len) in load_ocamlfind_package ?loc pkg else dynlink ?loc plugin let get_plugins () = match Ast_mapper.get_cookie "ppx_deriving" with | None -> [] | Some expr -> match From_current.copy_expression expr with | { pexp_desc = Pexp_tuple exprs } -> exprs |> List.map (fun expr -> match expr with | { pexp_desc = Pexp_constant (Pconst_string (file, _, None)) } -> file | _ -> assert false) | _ -> assert false let add_plugins plugins = let loaded = get_plugins () in let plugins = List.filter (fun file -> not (List.mem file loaded)) plugins in List.iter load_plugin plugins; let loaded = loaded @ plugins in Ast_mapper.set_cookie "ppx_deriving" (To_current.copy_expression (Exp.tuple (List.map (Ast_builder.Default.estring ~loc:Location.none) loaded))) let mapper argv = get_plugins () |> List.iter load_plugin; add_plugins argv; let module Current_ast = Ppxlib_ast.Selected_ast in let structure s = match s with | [] -> [] | hd :: tl -> match hd with | ([%stri [@@@findlib.ppxopt [%e? { pexp_desc = Pexp_tuple ( [%expr "ppx_deriving"] :: elems) }]]]) -> elems |> List.map (fun elem -> match elem with | { pexp_desc = Pexp_constant (Pconst_string (file, _, None))} -> file | _ -> assert false) |> add_plugins; Ppxlib.Driver.map_structure tl | _ -> Ppxlib.Driver.map_structure s in let structure _ st = Current_ast.of_ocaml Structure st |> structure |> Current_ast.to_ocaml Structure in let signature _ si = Current_ast.of_ocaml Signature si |> Ppxlib.Driver.map_signature |> Current_ast.to_ocaml Signature in { Ast_mapper.default_mapper with structure; signature } let () = Ast_mapper.register "ppx_deriving" mapper ppx_deriving-6.0.2/src/runtime/000077500000000000000000000000001462406363500165005ustar00rootroot00000000000000ppx_deriving-6.0.2/src/runtime/dune000066400000000000000000000007001462406363500173530ustar00rootroot00000000000000(library (name ppx_deriving_runtime) (public_name ppx_deriving.runtime) (wrapped false) (synopsis "Type-driven code generation")) (rule (deps ppx_deriving_runtime.cppo.ml) (targets ppx_deriving_runtime.ml) (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets}))) (rule (deps ppx_deriving_runtime.cppo.mli) (targets ppx_deriving_runtime.mli) (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets}))) ppx_deriving-6.0.2/src/runtime/ppx_deriving_runtime.cppo.ml000066400000000000000000000034251462406363500242370ustar00rootroot00000000000000type nonrec int = int type nonrec char = char type nonrec string = string type nonrec float = float type nonrec bool = bool type nonrec unit = unit type nonrec exn = exn type nonrec 'a array = 'a array type nonrec 'a list = 'a list type nonrec 'a option = 'a option type nonrec nativeint = nativeint type nonrec int32 = int32 type nonrec int64 = int64 type nonrec 'a lazy_t = 'a lazy_t type nonrec bytes = bytes #if OCAML_VERSION >= (4, 07, 0) (* We require 4.08 while 4.07 already has a Stdlib module. In 4.07, the type equalities on Stdlib.Pervasives are not strong enough for the 'include Stdlib' below to satisfy the signature constraints on Ppx_deriving_runtime.Pervasives. *) module Stdlib = Stdlib include Stdlib module Result = struct type ('a, 'b) t = ('a, 'b) result = | Ok of 'a | Error of 'b type ('a, 'b) result = ('a, 'b) t = | Ok of 'a | Error of 'b end #else module Pervasives = Pervasives module Stdlib = Pervasives module Char = Char module String = String module Printexc = Printexc module Array = Array module List = List module Nativeint = Nativeint module Int32 = Int32 module Int64 = Int64 module Lazy = Lazy module Bytes = Bytes module Hashtbl = Hashtbl module Queue = Queue module Stack = Stack module Set = Set module Map = Map module Weak = Weak module Printf = Printf module Format = Format module Buffer = Buffer module Result = struct type ('a, 'b) t = ('a, 'b) result = | Ok of 'a | Error of 'b type nonrec ('a, 'b) result = ('a, 'b) result = | Ok of 'a | Error of 'b end module Option = struct type 'a t = 'a option let get o = match o with | None -> invalid_arg "get" | Some x -> x let to_result ~none o = match o with | None -> Error none | Some x -> Ok x end include Pervasives #endif ppx_deriving-6.0.2/src/runtime/ppx_deriving_runtime.cppo.mli000066400000000000000000000036621462406363500244130ustar00rootroot00000000000000(** A module collecting all predefined OCaml types, exceptions and modules operating on them, so that ppx_deriving plugins operate in a well-defined environment. *) (** {2 Predefined types} *) type nonrec int = int type nonrec char = char type nonrec string = string type nonrec float = float type nonrec bool = bool type nonrec unit = unit type nonrec exn = exn type nonrec 'a array = 'a array type nonrec 'a list = 'a list type nonrec 'a option = 'a option type nonrec nativeint = nativeint type nonrec int32 = int32 type nonrec int64 = int64 type nonrec 'a lazy_t = 'a lazy_t type nonrec bytes = bytes (** {2 Predefined modules} {3 Operations on predefined types} *) #if OCAML_VERSION >= (4, 07, 0) include module type of struct include Stdlib end module Stdlib = Stdlib module Result : sig type ('a, 'b) t = ('a, 'b) result = | Ok of 'a | Error of 'b (* we also expose Result.result for backward-compatibility with the Result package! *) type ('a, 'b) result = ('a, 'b) t = | Ok of 'a | Error of 'b end #else module Pervasives = Pervasives module Stdlib = Pervasives include module type of struct include Pervasives end module Char = Char module String = String module Printexc = Printexc module Array = Array module List = List module Nativeint = Nativeint module Int32 = Int32 module Int64 = Int64 module Lazy = Lazy module Bytes = Bytes module Hashtbl = Hashtbl module Queue = Queue module Stack = Stack module Set = Set module Map = Map module Weak = Weak module Printf = Printf module Format = Format module Buffer = Buffer module Result : sig type ('a, 'b) t = ('a, 'b) result = | Ok of 'a | Error of 'b (* we also expose Result.result for backward-compatibility *) type nonrec ('a, 'b) result = ('a, 'b) result = | Ok of 'a | Error of 'b end module Option : sig type 'a t = 'a option val get : 'a t -> 'a val to_result : none:'e -> 'a option -> ('a, 'e) result end #endif ppx_deriving-6.0.2/src_examples/000077500000000000000000000000001462406363500167135ustar00rootroot00000000000000ppx_deriving-6.0.2/src_examples/dune000066400000000000000000000001671462406363500175750ustar00rootroot00000000000000(executable (name print_test) (preprocess (pps ppx_deriving.show))) (alias (name examples) (deps print_test.exe)) ppx_deriving-6.0.2/src_examples/print_test.ml000066400000000000000000000403161462406363500214440ustar00rootroot00000000000000 type t = | Leaf of int | Node of t list [@@deriving show] let test_case = (Node [(Node [(Node [(Node [(Node [(Node [(Node [(Leaf 81)])]); (Node [(Node [(Leaf 43); (Node [(Leaf 71); (Leaf 75); (Leaf 92)]); (Node [(Node [(Leaf 63); (Leaf 82); (Leaf 69); (Leaf 95)])])])])]); (Node [(Node [(Leaf 30); (Leaf 63); (Leaf 36); (Leaf 67)])])]); (Node [(Leaf 15); (Node [(Leaf 94); (Leaf 93); (Node [(Leaf 62); (Leaf 76); (Leaf 4); (Leaf 37)])])]); (Node [(Node [(Node [(Node [(Leaf 23); (Node [(Node [(Leaf 59); (Leaf 58)]); (Leaf 4)]); (Leaf 9); (Leaf 90)]); (Node [(Leaf 42); (Node [(Leaf 54); (Node [(Leaf 49); (Leaf 96); (Leaf 64); (Leaf 96)])])]); (Leaf 16); (Node [(Leaf 23); (Leaf 11); (Node [(Leaf 66); (Leaf 4); (Leaf 29); (Leaf 92)]); (Leaf 45)])]); (Node [(Leaf 73); (Node [(Leaf 83)]); (Leaf 49)])]); (Node [(Node [(Leaf 80); (Leaf 43)]); (Leaf 50); (Node [(Leaf 87)])]); (Node [(Leaf 48)]); (Node [(Node [(Leaf 79); (Leaf 73); (Leaf 8); (Leaf 24)]); (Leaf 49); (Leaf 53)])]); (Node [(Node [(Node [(Node [(Node [(Node [(Node [(Leaf 61); (Leaf 20)])]); (Leaf 27); (Leaf 30); (Node [(Leaf 4)])])])]); (Node [(Node [(Node [(Node [(Node [(Node [(Leaf 6); (Leaf 33); (Leaf 80)]); (Leaf 19)]); (Leaf 28)])])]); (Leaf 4); (Leaf 65); (Leaf 1)]); (Node [(Leaf 22); (Leaf 93)]); (Leaf 65)])])]); (Node [(Node [(Node [(Node [(Leaf 63); (Node [(Node [(Node [(Node [(Leaf 79); (Leaf 2); (Node [(Leaf 66); (Leaf 53)]); (Node [(Leaf 7); (Leaf 42); (Leaf 31); (Node [(Leaf 58); (Leaf 87); (Leaf 52)])])]); (Node [(Leaf 37); (Leaf 74); (Node [(Leaf 43); (Leaf 98); (Leaf 28); (Leaf 52)]); (Leaf 50)])])]); (Leaf 98)]); (Node [(Leaf 77); (Node [(Leaf 79)]); (Node [(Node [(Leaf 17); (Leaf 4); (Leaf 21); (Leaf 34)]); (Leaf 64); (Node [(Node [(Node [(Leaf 31); (Leaf 60); (Node [(Node [(Node [(Node [(Leaf 14); (Leaf 11); (Leaf 27); (Leaf 43)]); (Leaf 21)]); (Leaf 3)])])])])]); (Node [(Leaf 93); (Leaf 3); (Leaf 37)])])])]); (Node [(Node [(Node [(Node [(Leaf 37); (Node [(Node [(Node [(Leaf 59); (Leaf 37)])]); (Leaf 98)])])]); (Node [(Node [(Leaf 54); (Leaf 72); (Leaf 21)]); (Node [(Leaf 87); (Leaf 25)])]); (Node [(Leaf 45); (Node [(Node [(Leaf 35); (Leaf 72); (Leaf 14)]); (Leaf 93); (Node [(Node [(Leaf 75)])])]); (Node [(Leaf 30); (Node [(Leaf 21)]); (Node [(Leaf 0); (Leaf 5); (Node [(Leaf 97); (Leaf 15)])]); (Node [(Leaf 55)])])])])]); (Leaf 34); (Node [(Node [(Node [(Node [(Node [(Leaf 90); (Leaf 54); (Node [(Leaf 34); (Node [(Leaf 80); (Leaf 45)])])])]); (Node [(Node [(Leaf 87); (Leaf 92); (Node [(Node [(Leaf 61); (Node [(Leaf 96); (Leaf 19)])]); (Leaf 25)]); (Leaf 32)])])])]); (Node [(Node [(Node [(Leaf 80); (Leaf 4); (Leaf 15)]); (Node [(Leaf 37); (Node [(Leaf 77)]); (Leaf 74); (Leaf 52)]); (Leaf 98)])])])]); (Node [(Node [(Node [(Leaf 53); (Leaf 56); (Node [(Leaf 21); (Leaf 48); (Leaf 63); (Leaf 58)]); (Leaf 12)]); (Node [(Leaf 43); (Leaf 11); (Node [(Leaf 84); (Leaf 50)])]); (Node [(Node [(Leaf 6); (Node [(Leaf 13); (Leaf 28); (Leaf 80)]); (Node [(Leaf 5); (Leaf 37)])]); (Leaf 5); (Leaf 31); (Leaf 51)]); (Leaf 59)]); (Node [(Node [(Leaf 15); (Node [(Leaf 55); (Leaf 25); (Leaf 58); (Leaf 0)]); (Leaf 88)]); (Node [(Node [(Leaf 37)]); (Node [(Node [(Leaf 0); (Leaf 40); (Node [(Leaf 28); (Leaf 24); (Node [(Leaf 99); (Leaf 70)]); (Node [(Leaf 86); (Leaf 52); (Leaf 72); (Leaf 41)])])]); (Node [(Node [(Leaf 16); (Node [(Leaf 87); (Leaf 16); (Leaf 61)])])])]); (Node [(Node [(Leaf 13); (Leaf 51); (Leaf 78); (Node [(Leaf 69); (Leaf 8); (Leaf 70)])]); (Leaf 8); (Leaf 13); (Leaf 22)]); (Node [(Leaf 98); (Leaf 25); (Leaf 14); (Leaf 28)])])]); (Node [(Node [(Leaf 62); (Node [(Leaf 65); (Node [(Leaf 13); (Leaf 78); (Leaf 52)]); (Leaf 26); (Leaf 64)])])])])]); (Node [(Leaf 18); (Node [(Leaf 50)]); (Leaf 84)]); (Node [(Node [(Node [(Leaf 2); (Leaf 18); (Node [(Leaf 75)])]); (Leaf 15)]); (Node [(Leaf 69); (Leaf 66)]); (Node [(Leaf 59); (Node [(Leaf 84)])]); (Node [(Leaf 57); (Node [(Node [(Node [(Node [(Leaf 40); (Leaf 9); (Leaf 1)])]); (Node [(Leaf 81); (Leaf 82); (Node [(Leaf 86); (Leaf 14); (Leaf 67); (Leaf 58)])]); (Node [(Leaf 25)]); (Node [(Leaf 53); (Node [(Leaf 97); (Leaf 48); (Leaf 90)])])]); (Leaf 97); (Node [(Node [(Leaf 80); (Leaf 28)])]); (Node [(Leaf 61); (Leaf 79); (Leaf 60); (Leaf 81)])]); (Node [(Node [(Node [(Leaf 5)])]); (Node [(Node [(Node [(Leaf 89)]); (Node [(Leaf 41); (Leaf 79); (Leaf 47)]); (Leaf 78); (Node [(Leaf 20); (Leaf 39); (Node [(Leaf 54)])])])]); (Node [(Node [(Leaf 55)]); (Node [(Leaf 64); (Leaf 45); (Leaf 92); (Leaf 45)])])])])]); (Node [(Node [(Node [(Leaf 58)]); (Node [(Leaf 63); (Leaf 47); (Node [(Leaf 34); (Node [(Leaf 39); (Node [(Leaf 69); (Leaf 10); (Leaf 24)]); (Node [(Leaf 20); (Leaf 32); (Leaf 12); (Leaf 9)])]); (Leaf 46)])]); (Leaf 29); (Node [(Leaf 78); (Leaf 35); (Leaf 15)])]); (Node [(Node [(Node [(Leaf 27); (Leaf 56); (Leaf 21); (Leaf 89)]); (Node [(Leaf 69); (Node [(Node [(Leaf 94)]); (Leaf 21)]); (Node [(Leaf 76); (Leaf 35); (Node [(Leaf 39); (Leaf 40); (Leaf 52)]); (Leaf 21)])])]); (Leaf 97); (Node [(Leaf 30); (Leaf 93)])]); (Node [(Leaf 38)]); (Node [(Leaf 34); (Node [(Leaf 13); (Leaf 1); (Node [(Leaf 44); (Leaf 93)])])])])])])]) let () = Format.printf "tree: %a@." pp test_case; () ppx_deriving-6.0.2/src_plugins/000077500000000000000000000000001462406363500165565ustar00rootroot00000000000000ppx_deriving-6.0.2/src_plugins/create/000077500000000000000000000000001462406363500200215ustar00rootroot00000000000000ppx_deriving-6.0.2/src_plugins/create/dune000066400000000000000000000003371462406363500207020ustar00rootroot00000000000000(library (name ppx_deriving_create) (public_name ppx_deriving.create) (synopsis "[@@deriving create]") (preprocess (pps ppxlib.metaquot)) (libraries compiler-libs.common ppxlib ppx_deriving.api) (kind ppx_deriver)) ppx_deriving-6.0.2/src_plugins/create/ppx_deriving_create.ml000066400000000000000000000137461462406363500244070ustar00rootroot00000000000000open Ppxlib open Asttypes open Parsetree open Ast_helper open Ppx_deriving.Ast_convenience let deriver = "create" let raise_errorf = Ppx_deriving.raise_errorf let attr_default context = Attribute.declare "deriving.create.default" context Ast_pattern.(single_expr_payload __) (fun e -> e) let attr_default = (attr_default Attribute.Context.label_declaration, attr_default Attribute.Context.core_type) let attr_split context = Attribute.declare_flag "deriving.create.split" context let ct_attr_split = attr_split Attribute.Context.core_type let label_attr_split = attr_split Attribute.Context.label_declaration let attr_main context = Attribute.declare_flag "deriving.create.main" context let ct_attr_main = attr_main Attribute.Context.core_type let label_attr_main = attr_main Attribute.Context.label_declaration let get_label_attribute (label_attr, ct_attr) label = match Attribute.get label_attr label with | Some _ as v -> v | None -> Attribute.get ct_attr label.pld_type let find_main labels = List.fold_left (fun (main, labels) ({ pld_type; pld_loc; pld_attributes } as label) -> if Attribute.has_flag ct_attr_main pld_type || Attribute.has_flag label_attr_main label then match main with | Some _ -> raise_errorf ~loc:pld_loc "Duplicate [@deriving.%s.main] annotation" deriver | None -> Some label, labels else main, label :: labels) (None, []) labels let str_of_type ({ ptype_loc = loc } as type_decl) = let quoter = Ppx_deriving.create_quoter () in let creator = match type_decl.ptype_kind with | Ptype_record labels -> let fields = labels |> List.map (fun { pld_name = { txt = name; loc } } -> name, evar name) in let main, labels = find_main labels in let fn = match main with | Some { pld_name = { txt = name }} -> Exp.fun_ Label.nolabel None (pvar name) (record fields) | None -> Exp.fun_ Label.nolabel None (punit ()) (record fields) in List.fold_left (fun accum ({ pld_name = { txt = name }; pld_type; pld_attributes } as label) -> match get_label_attribute attr_default label with | Some default -> Exp.fun_ (Label.optional name) (Some (Ppx_deriving.quote ~quoter default)) (pvar name) accum | None -> let pld_type = Ppx_deriving.remove_pervasives ~deriver pld_type in if Attribute.has_flag label_attr_split label || Attribute.has_flag ct_attr_split pld_type then match pld_type with | [%type: [%t? lhs] * [%t? rhs] list] when name.[String.length name - 1] = 's' -> let name' = String.sub name 0 (String.length name - 1) in Exp.fun_ (Label.labelled name') None (pvar name') (Exp.fun_ (Label.optional name) (Some [%expr []]) (pvar name) [%expr let [%p pvar name] = [%e evar name'], [%e evar name] in [%e accum]]) | _ -> raise_errorf ~loc "[@deriving.%s.split] annotation requires a type of form \ 'a * 'b list and label name ending with `s'" deriver else match pld_type with | [%type: [%t? _] list] -> Exp.fun_ (Label.optional name) (Some [%expr []]) (pvar name) accum | [%type: [%t? _] option] -> Exp.fun_ (Label.optional name) None (pvar name) accum | _ -> Exp.fun_ (Label.labelled name) None (pvar name) accum) fn labels | _ -> raise_errorf ~loc "%s can be derived only for record types" deriver in [Vb.mk (pvar (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl)) (Ppx_deriving.sanitize ~quoter creator)] let wrap_predef_option typ = typ let sig_of_type ({ ptype_loc = loc } as type_decl) = let typ = Ppx_deriving.core_type_of_type_decl type_decl in let typ = match type_decl.ptype_kind with | Ptype_record labels -> let main, labels = find_main labels in let typ = match main with | Some { pld_name = { txt = name }; pld_type } -> Typ.arrow Label.nolabel pld_type typ | None -> Typ.arrow Label.nolabel (tconstr "unit" []) typ in List.fold_left (fun accum ({ pld_name = { txt = name; loc }; pld_type; pld_attributes } as label) -> match get_label_attribute attr_default label with | Some _ -> Typ.arrow (Label.optional name) (wrap_predef_option pld_type) accum | None -> let pld_type = Ppx_deriving.remove_pervasives ~deriver pld_type in if Attribute.has_flag ct_attr_split pld_type || Attribute.has_flag label_attr_split label then match pld_type with | [%type: [%t? lhs] * [%t? rhs] list] when name.[String.length name - 1] = 's' -> let name' = String.sub name 0 (String.length name - 1) in Typ.arrow (Label.labelled name') lhs (Typ.arrow (Label.optional name) (wrap_predef_option [%type: [%t rhs] list]) accum) | _ -> raise_errorf ~loc "[@deriving.%s.split] annotation requires a type of form \ 'a * 'b list and label name ending with `s'" deriver else match pld_type with | [%type: [%t? _] list] -> Typ.arrow (Label.optional name) (wrap_predef_option pld_type) accum | [%type: [%t? opt] option] -> Typ.arrow (Label.optional name) (wrap_predef_option opt) accum | _ -> Typ.arrow (Label.labelled name) pld_type accum) typ labels | _ -> raise_errorf ~loc "%s can only be derived for record types" deriver in [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl)) typ)] let impl_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> [Str.value Nonrecursive (List.concat (List.map str_of_type type_decls))]) let intf_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> List.concat (List.map sig_of_type type_decls)) let deriving: Deriving.t = Deriving.add deriver ~str_type_decl:impl_generator ~sig_type_decl:intf_generator ppx_deriving-6.0.2/src_plugins/dune000066400000000000000000000000001462406363500174220ustar00rootroot00000000000000ppx_deriving-6.0.2/src_plugins/enum/000077500000000000000000000000001462406363500175225ustar00rootroot00000000000000ppx_deriving-6.0.2/src_plugins/enum/dune000066400000000000000000000003311462406363500203750ustar00rootroot00000000000000(library (name ppx_deriving_enum) (public_name ppx_deriving.enum) (synopsis "[@@deriving enum]") (preprocess (pps ppxlib.metaquot)) (libraries compiler-libs.common ppxlib ppx_deriving.api) (kind ppx_deriver)) ppx_deriving-6.0.2/src_plugins/enum/ppx_deriving_enum.ml000066400000000000000000000120121462406363500235720ustar00rootroot00000000000000open Ppxlib open Asttypes open Parsetree open Ast_helper open Ppx_deriving.Ast_convenience let deriver = "enum" let raise_errorf = Ppx_deriving.raise_errorf let attr_value context = Attribute.declare "deriving.enum.value" context Ast_pattern.(single_expr_payload (eint __)) (fun i -> i) let constr_attr_value = attr_value Attribute.Context.constructor_declaration let rtag_attr_value = attr_value Attribute.Context.rtag let mappings_of_type type_decl = let map acc mappings attr_value x constr_name = let value = match Attribute.get attr_value x with | Some idx -> idx | None -> acc in (value + 1, (value, constr_name) :: mappings) in let kind, (_, mappings) = match type_decl.ptype_kind, type_decl.ptype_manifest with | Ptype_variant constrs, _ -> `Regular, List.fold_left (fun (acc, mappings) ({ pcd_name; pcd_args; pcd_attributes; pcd_loc } as constr) -> if pcd_args <> Pcstr_tuple([]) then raise_errorf ~loc:pcd_loc "%s can be derived only for argumentless constructors" deriver; map acc mappings constr_attr_value constr pcd_name) (0, []) constrs | Ptype_abstract, Some { ptyp_desc = Ptyp_variant (constrs, Closed, None); ptyp_loc } -> `Polymorphic, List.fold_left (fun (acc, mappings) row_field -> let error_inherit loc = raise_errorf ~loc:ptyp_loc "%s cannot be derived for inherited variant cases" deriver in let error_arguments loc = raise_errorf ~loc:ptyp_loc "%s can be derived only for argumentless constructors" deriver in let loc = row_field.prf_loc in match row_field.prf_desc with | Rinherit _ -> error_inherit loc | Rtag (name, true, []) -> map acc mappings rtag_attr_value row_field name | Rtag _ -> error_arguments loc ) (0, []) constrs | _ -> raise_errorf ~loc:type_decl.ptype_loc "%s can be derived only for variants" deriver in let rec check_dup mappings = match mappings with | (a, { txt=atxt; loc=aloc }) :: (b, { txt=btxt; loc=bloc }) :: _ when a = b -> let sigil = match kind with `Regular -> "" | `Polymorphic -> "`" in let sub = [Ocaml_common.Location.errorf ~loc:bloc "Same as for %s%s" sigil btxt] in raise_errorf ~sub ~loc:aloc "%s: duplicate value %d for constructor %s%s" deriver a sigil atxt | _ :: rest -> check_dup rest | [] -> () in mappings |> List.stable_sort (fun (a,_) (b,_) -> compare a b) |> check_dup; kind, mappings let str_of_type ({ ptype_loc = loc } as type_decl) = let kind, mappings = mappings_of_type type_decl in let patt name = match kind with | `Regular -> Pat.construct (mknoloc (Lident name)) None | `Polymorphic -> Pat.variant name None and expr name = match kind with | `Regular -> Exp.construct (mknoloc (Lident name)) None | `Polymorphic -> Exp.variant name None in let to_enum_cases = List.map (fun (value, { txt = name }) -> Exp.case (patt name) (int value)) mappings and from_enum_cases = List.map (fun (value, { txt = name }) -> Exp.case (pint value) (constr "Some" [expr name])) mappings @ [Exp.case (Pat.any ()) (constr "None" [])] and indexes = List.map fst mappings in [Vb.mk (pvar (Ppx_deriving.mangle_type_decl (`Prefix "min") type_decl)) (int (List.fold_left min max_int indexes)); Vb.mk (pvar (Ppx_deriving.mangle_type_decl (`Prefix "max") type_decl)) (int (List.fold_left max min_int indexes)); Vb.mk (pvar (Ppx_deriving.mangle_type_decl (`Suffix "to_enum") type_decl)) (Exp.function_ to_enum_cases); Vb.mk (pvar (Ppx_deriving.mangle_type_decl (`Suffix "of_enum") type_decl)) (Exp.function_ from_enum_cases)] let sig_of_type type_decl = let loc = type_decl.ptype_loc in let typ = Ppx_deriving.core_type_of_type_decl type_decl in [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "min") type_decl)) [%type: Ppx_deriving_runtime.int]); Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "max") type_decl)) [%type: Ppx_deriving_runtime.int]); Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Suffix "to_enum") type_decl)) [%type: [%t typ] -> Ppx_deriving_runtime.int]); Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Suffix "of_enum") type_decl)) [%type: Ppx_deriving_runtime.int -> [%t typ] Ppx_deriving_runtime.option])] let impl_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> [Str.value Nonrecursive (List.concat (List.map str_of_type type_decls))]) let intf_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> List.concat (List.map sig_of_type type_decls)) let deriving: Deriving.t = Deriving.add deriver ~str_type_decl:impl_generator ~sig_type_decl:intf_generator ppx_deriving-6.0.2/src_plugins/eq/000077500000000000000000000000001462406363500171635ustar00rootroot00000000000000ppx_deriving-6.0.2/src_plugins/eq/dune000066400000000000000000000003231462406363500200370ustar00rootroot00000000000000(library (name ppx_deriving_eq) (public_name ppx_deriving.eq) (synopsis "[@@deriving eq]") (preprocess (pps ppxlib.metaquot)) (libraries compiler-libs.common ppxlib ppx_deriving.api) (kind ppx_deriver)) ppx_deriving-6.0.2/src_plugins/eq/ppx_deriving_eq.ml000066400000000000000000000220261462406363500227020ustar00rootroot00000000000000open Ppxlib open Asttypes open Parsetree open Ast_helper open Ppx_deriving.Ast_convenience let deriver = "eq" let raise_errorf = Ppx_deriving.raise_errorf let ct_attr_nobuiltin = Attribute.declare_flag "deriving.eq.nobuiltin" Attribute.Context.core_type let ct_attr_equal = Attribute.declare "deriving.eq.equal" Attribute.Context.core_type Ast_pattern.(single_expr_payload __) (fun e -> e) let argn kind = Printf.sprintf (match kind with `lhs -> "lhs%d" | `rhs -> "rhs%d") let argl kind = Printf.sprintf (match kind with `lhs -> "lhs%s" | `rhs -> "rhs%s") let pattn side typs = List.mapi (fun i _ -> pvar (argn side i)) typs let pattl side labels = List.map (fun { pld_name = { txt = n } } -> n, pvar (argl side n)) labels let pconstrrec name fields = pconstr name [precord ~closed:Closed fields] let core_type_of_decl type_decl = let loc = !Ast_helper.default_loc in let typ = Ppx_deriving.core_type_of_type_decl type_decl in Ppx_deriving.poly_arrow_of_type_decl (fun var -> [%type: [%t var] -> [%t var] -> Ppx_deriving_runtime.bool]) type_decl [%type: [%t typ] -> [%t typ] -> Ppx_deriving_runtime.bool] let sig_of_type type_decl = [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "equal") type_decl)) (core_type_of_decl type_decl))] let rec exprn quoter typs = typs |> List.mapi (fun i typ -> app (expr_of_typ quoter typ) [evar (argn `lhs i); evar (argn `rhs i)]) and exprl quoter typs = typs |> List.map (fun ({ pld_name = { txt = n }; pld_loc; _ } as pld) -> with_default_loc pld_loc @@ fun () -> app (expr_of_label_decl quoter pld) [evar (argl `lhs n); evar (argl `rhs n)]) and expr_of_label_decl quoter { pld_type; pld_attributes } = let attrs = pld_type.ptyp_attributes @ pld_attributes in expr_of_typ quoter { pld_type with ptyp_attributes = attrs } and expr_of_typ quoter typ = let loc = !Ast_helper.default_loc in let typ = Ppx_deriving.remove_pervasives ~deriver typ in let expr_of_typ = expr_of_typ quoter in match Attribute.get ct_attr_equal typ with | Some fn -> Ppx_deriving.quote ~quoter fn | None -> match typ with | [%type: _] -> [%expr fun _ _ -> true] | { ptyp_desc = Ptyp_constr _ } -> let builtin = not (Attribute.has_flag ct_attr_nobuiltin typ) in begin match builtin, typ with | true, [%type: unit] -> [%expr fun (_:unit) (_:unit) -> true] | true, ([%type: int] | [%type: int32] | [%type: Int32.t] | [%type: int64] | [%type: Int64.t] | [%type: nativeint] | [%type: Nativeint.t] | [%type: float] | [%type: bool] | [%type: char] | [%type: string] | [%type: bytes]) -> [%expr (fun (a:[%t typ]) b -> a = b)] | true, [%type: [%t? typ] ref] -> [%expr fun a b -> [%e expr_of_typ typ] !a !b] | true, [%type: [%t? typ] list] -> [%expr let rec loop x y = match x, y with | [], [] -> true | a :: x, b :: y -> [%e expr_of_typ typ] a b && loop x y | _ -> false in (fun x y -> loop x y)] | true, [%type: [%t? typ] array] -> [%expr fun x y -> let rec loop i = i = Array.length x || ([%e expr_of_typ typ] x.(i) y.(i) && loop (i + 1)) in Array.length x = Array.length y && loop 0] | true, [%type: [%t? typ] option] -> [%expr fun x y -> match x, y with | None, None -> true | Some a, Some b -> [%e expr_of_typ typ] a b | _ -> false] | true, ([%type: ([%t? ok_t], [%t? err_t]) result] | [%type: ([%t? ok_t], [%t? err_t]) Result.result]) -> [%expr fun x y -> match x, y with | Ok a, Ok b -> [%e expr_of_typ ok_t] a b | Error a, Error b -> [%e expr_of_typ err_t] a b | _ -> false] | true, ([%type: [%t? typ] lazy_t] | [%type: [%t? typ] Lazy.t]) -> [%expr fun (lazy x) (lazy y) -> [%e expr_of_typ typ] x y] | _, { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } -> let equal_fn = Exp.ident (mknoloc (Ppx_deriving.mangle_lid (`Prefix "equal") lid)) in app (Ppx_deriving.quote ~quoter equal_fn) (List.map expr_of_typ args) | _ -> assert false end | { ptyp_desc = Ptyp_tuple typs } -> [%expr fun [%p ptuple (pattn `lhs typs)] [%p ptuple (pattn `rhs typs)] -> [%e exprn quoter typs |> Ppx_deriving.(fold_exprs (binop_reduce [%expr (&&)]))]] | { ptyp_desc = Ptyp_variant (fields, _, _); ptyp_loc } -> let cases = (fields |> List.map (fun field -> let pdup f = ptuple [f "lhs"; f "rhs"] in let variant label popt = Pat.variant label.txt popt in match field.prf_desc with | Rtag(label, true (*empty*), []) -> Exp.case (pdup (fun _ -> variant label None)) [%expr true] | Rtag(label, false, [typ]) -> Exp.case (pdup (fun var -> variant label (Some (pvar var)))) (app (expr_of_typ typ) [evar "lhs"; evar "rhs"]) | Rinherit({ ptyp_desc = Ptyp_constr (tname, _) } as typ) -> Exp.case (pdup (fun var -> Pat.alias (Pat.type_ tname) (mknoloc var))) (app (expr_of_typ typ) [evar "lhs"; evar "rhs"]) | _ -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ))) @ [Exp.case (pvar "_") [%expr false]] in [%expr fun lhs rhs -> [%e Exp.match_ [%expr lhs, rhs] cases]] | { ptyp_desc = Ptyp_var name } -> evar ("poly_"^name) | { ptyp_desc = Ptyp_alias (typ, _) } -> expr_of_typ typ | { ptyp_loc } -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ) let str_of_type ({ ptype_loc = loc } as type_decl) = let quoter = Ppx_deriving.create_quoter () in let comparator = match type_decl.ptype_kind, type_decl.ptype_manifest with | Ptype_abstract, Some manifest -> expr_of_typ quoter manifest | Ptype_variant constrs, _ -> let cases = (constrs |> List.map (fun { pcd_name = { txt = name }; pcd_args; pcd_loc } -> with_default_loc pcd_loc @@ fun () -> match pcd_args with | Pcstr_tuple(typs) -> exprn quoter typs |> Ppx_deriving.(fold_exprs ~unit:[%expr true] (binop_reduce [%expr (&&)])) |> Exp.case (ptuple [pconstr name (pattn `lhs typs); pconstr name (pattn `rhs typs)]) | Pcstr_record(labels) -> exprl quoter labels |> Ppx_deriving.(fold_exprs ~unit:[%expr true] (binop_reduce [%expr (&&)])) |> Exp.case (ptuple [pconstrrec name (pattl `lhs labels); pconstrrec name (pattl `rhs labels)]) )) @ [Exp.case (pvar "_") [%expr false]] in [%expr fun lhs rhs -> [%e Exp.match_ [%expr lhs, rhs] cases]] | Ptype_record labels, _ -> let exprs = labels |> List.map (fun ({ pld_loc; pld_name = { txt = name }; _ } as pld) -> with_default_loc pld_loc @@ fun () -> (* combine attributes of type and label *) let field obj = Exp.field obj (mknoloc (Lident name)) in app (expr_of_label_decl quoter pld) [field (evar "lhs"); field (evar "rhs")]) in [%expr fun lhs rhs -> [%e exprs |> Ppx_deriving.(fold_exprs (binop_reduce [%expr (&&)]))]] | Ptype_abstract, None -> raise_errorf ~loc "%s cannot be derived for fully abstract types" deriver | Ptype_open, _ -> raise_errorf ~loc "%s cannot be derived for open types" deriver in let polymorphize = Ppx_deriving.poly_fun_of_type_decl type_decl in let eta_expand expr = (* Ensure expr is statically constructive by eta-expanding non-funs. See https://github.com/ocaml-ppx/ppx_deriving/pull/252. *) match expr with | { pexp_desc = Pexp_fun _; _ } -> expr | _ -> [%expr fun x -> [%e expr] x] in let out_type = Ppx_deriving.strong_type_of_type @@ core_type_of_decl type_decl in let eq_var = pvar (Ppx_deriving.mangle_type_decl (`Prefix "equal") type_decl) in [Vb.mk ~attrs:[Ppx_deriving.attr_warning [%expr "-39"]] (Pat.constraint_ eq_var out_type) (Ppx_deriving.sanitize ~quoter (eta_expand (polymorphize comparator)))] let impl_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> [Str.value Recursive (List.concat (List.map str_of_type type_decls))]) let intf_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> List.concat (List.map sig_of_type type_decls)) let deriving: Deriving.t = Deriving.add deriver ~str_type_decl:impl_generator ~sig_type_decl:intf_generator (* custom extension such that "derive"-prefixed also works *) let derive_extension = Extension.V3.declare "derive.eq" Extension.Context.expression Ast_pattern.(ptyp __) (fun ~ctxt:_ -> Ppx_deriving.with_quoter expr_of_typ) let derive_transformation = Driver.register_transformation deriver ~rules:[Context_free.Rule.extension derive_extension] ppx_deriving-6.0.2/src_plugins/fold/000077500000000000000000000000001462406363500175025ustar00rootroot00000000000000ppx_deriving-6.0.2/src_plugins/fold/dune000066400000000000000000000003311462406363500203550ustar00rootroot00000000000000(library (name ppx_deriving_fold) (public_name ppx_deriving.fold) (synopsis "[@@deriving fold]") (preprocess (pps ppxlib.metaquot)) (libraries compiler-libs.common ppxlib ppx_deriving.api) (kind ppx_deriver)) ppx_deriving-6.0.2/src_plugins/fold/ppx_deriving_fold.ml000066400000000000000000000145161462406363500235450ustar00rootroot00000000000000open Ppxlib open Asttypes open Parsetree open Ast_helper open Ppx_deriving.Ast_convenience let deriver = "fold" let raise_errorf = Ppx_deriving.raise_errorf let ct_attr_nobuiltin = Attribute.declare_flag "deriving.fold.nobuiltin" Attribute.Context.core_type let argn = Printf.sprintf "a%d" let argl = Printf.sprintf "a%s" let pattn typs = List.mapi (fun i _ -> pvar (argn i)) typs let pattl labels = List.map (fun { pld_name = { txt = n } } -> n, pvar (argl n)) labels let pconstrrec name fields = pconstr name [precord ~closed:Closed fields] let reduce_acc a b = let loc = !Ast_helper.default_loc in [%expr let acc = [%e a] in [%e b]] let rec expr_of_typ typ = let loc = typ.ptyp_loc in let typ = Ppx_deriving.remove_pervasives ~deriver typ in match typ with | _ when Ppx_deriving.free_vars_in_core_type typ = [] -> [%expr fun acc _ -> acc] | { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } -> let builtin = not (Attribute.has_flag ct_attr_nobuiltin typ) in begin match builtin, typ with | true, [%type: [%t? typ] ref] -> [%expr fun acc x -> [%e expr_of_typ typ] acc !x] | true, [%type: [%t? typ] list] -> [%expr Ppx_deriving_runtime.List.fold_left [%e expr_of_typ typ]] | true, [%type: [%t? typ] array] -> [%expr Ppx_deriving_runtime.Array.fold_left [%e expr_of_typ typ]] | true, [%type: [%t? typ] option] -> [%expr fun acc -> function None -> acc | Some x -> [%e expr_of_typ typ] acc x] | true, ([%type: ([%t? ok_t], [%t? err_t]) result] | [%type: ([%t? ok_t], [%t? err_t]) Result.result]) -> [%expr fun acc -> function | Ok ok -> [%e expr_of_typ ok_t] acc ok | Error err -> [%e expr_of_typ err_t] acc err] | _, { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } -> app (Exp.ident (mknoloc (Ppx_deriving.mangle_lid (`Prefix deriver) lid))) (List.map expr_of_typ args) | _ -> assert false end | { ptyp_desc = Ptyp_tuple typs } -> let args = typs |> List.mapi (fun i typ -> [%expr [%e expr_of_typ typ] acc [%e evar (argn i)]]) in [%expr fun acc [%p ptuple (List.mapi (fun i _ -> pvar (argn i)) typs)] -> [%e Ppx_deriving.(fold_exprs ~unit:[%expr acc] reduce_acc args)]]; | { ptyp_desc = Ptyp_variant (fields, _, _); ptyp_loc } -> let cases = fields |> List.map (fun field -> let variant label popt = Pat.variant label.txt popt in match field.prf_desc with | Rtag(label, true (*empty*), []) -> Exp.case (variant label None) [%expr acc] | Rtag(label, false, [typ]) -> Exp.case (variant label (Some [%pat? x])) [%expr [%e expr_of_typ typ] acc x] | Rinherit({ ptyp_desc = Ptyp_constr (tname, _) } as typ) -> Exp.case [%pat? [%p Pat.type_ tname] as x] [%expr [%e expr_of_typ typ] acc x] | _ -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ)) in Exp.function_ cases | { ptyp_desc = Ptyp_var name } -> evar ("poly_"^name) | { ptyp_desc = Ptyp_alias (typ, name) } -> [%expr fun acc x -> [%e evar ("poly_"^name)] ([%e expr_of_typ typ] acc x) x] | { ptyp_loc } -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ) and expr_of_label_decl { pld_type; pld_attributes } = let attrs = pld_type.ptyp_attributes @ pld_attributes in expr_of_typ { pld_type with ptyp_attributes = attrs } let str_of_type ({ ptype_loc = loc } as type_decl) = let mapper = match type_decl.ptype_kind, type_decl.ptype_manifest with | Ptype_abstract, Some manifest -> expr_of_typ manifest | Ptype_variant constrs, _ -> let cases = constrs |> List.map (fun { pcd_name = { txt = name' }; pcd_args } -> match pcd_args with | Pcstr_tuple(typs) -> let args = typs |> List.mapi (fun i typ -> [%expr [%e expr_of_typ typ] acc [%e evar (argn i)]]) in Exp.case (pconstr name' (pattn typs)) Ppx_deriving.(fold_exprs ~unit:[%expr acc] reduce_acc args) | Pcstr_record(labels) -> let args = labels |> List.map (fun ({ pld_name = { txt = n }; _ } as pld) -> [%expr [%e expr_of_label_decl pld] acc [%e evar (argl n)]]) in Exp.case (pconstrrec name' (pattl labels)) Ppx_deriving.(fold_exprs ~unit:[%expr acc] reduce_acc args) ) in [%expr fun acc -> [%e Exp.function_ cases]] | Ptype_record labels, _ -> let fields = labels |> List.mapi (fun i ({ pld_name = { txt = name }; _ } as pld) -> [%expr [%e expr_of_label_decl pld] acc [%e Exp.field (evar "x") (mknoloc (Lident name))]]) in [%expr fun acc x -> [%e Ppx_deriving.(fold_exprs ~unit:[%expr acc] reduce_acc fields)]] | Ptype_abstract, None -> raise_errorf ~loc "%s cannot be derived for fully abstract types" deriver | Ptype_open, _ -> raise_errorf ~loc "%s cannot be derived for open types" deriver in let polymorphize = Ppx_deriving.poly_fun_of_type_decl type_decl in [Vb.mk ~attrs:[Ppx_deriving.attr_warning [%expr "-39"]] (pvar (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl)) (polymorphize mapper)] let sig_of_type type_decl = let loc = type_decl.ptype_loc in let typ = Ppx_deriving.core_type_of_type_decl type_decl in let vars = (List.map (fun tyvar -> tyvar.txt)) (Ppx_deriving.free_vars_in_core_type typ) in let acc = Typ.var ~loc Ppx_deriving.(fresh_var vars) in let polymorphize = Ppx_deriving.poly_arrow_of_type_decl (fun var -> [%type: [%t acc] -> [%t var] -> [%t acc]]) type_decl in [Sig.value ~loc (Val.mk (mkloc (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl) loc) (polymorphize [%type: [%t acc] -> [%t typ] -> [%t acc]]))] let impl_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> [Str.value Recursive (List.concat (List.map str_of_type type_decls))]) let intf_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> List.concat (List.map sig_of_type type_decls)) let deriving: Deriving.t = Deriving.add deriver ~str_type_decl:impl_generator ~sig_type_decl:intf_generator ppx_deriving-6.0.2/src_plugins/iter/000077500000000000000000000000001462406363500175215ustar00rootroot00000000000000ppx_deriving-6.0.2/src_plugins/iter/dune000066400000000000000000000003311462406363500203740ustar00rootroot00000000000000(library (name ppx_deriving_iter) (public_name ppx_deriving.iter) (synopsis "[@@deriving iter]") (preprocess (pps ppxlib.metaquot)) (libraries compiler-libs.common ppxlib ppx_deriving.api) (kind ppx_deriver)) ppx_deriving-6.0.2/src_plugins/iter/ppx_deriving_iter.ml000066400000000000000000000136631462406363500236050ustar00rootroot00000000000000open Ppxlib open Asttypes open Parsetree open Ast_helper open Ppx_deriving.Ast_convenience let deriver = "iter" let raise_errorf = Ppx_deriving.raise_errorf let ct_attr_nobuiltin = Attribute.declare_flag "deriving.iter.nobuiltin" Attribute.Context.core_type let argn = Printf.sprintf "a%d" let argl = Printf.sprintf "a%s" let pattn typs = List.mapi (fun i _ -> pvar (argn i)) typs let pattl labels = List.map (fun { pld_name = { txt = n } } -> n, pvar (argl n)) labels let pconstrrec name fields = pconstr name [precord ~closed:Closed fields] let rec expr_of_typ typ = let loc = !Ast_helper.default_loc in let typ = Ppx_deriving.remove_pervasives ~deriver typ in match typ with | _ when Ppx_deriving.free_vars_in_core_type typ = [] -> [%expr fun _ -> ()] | { ptyp_desc = Ptyp_constr _ } -> let builtin = not (Attribute.has_flag ct_attr_nobuiltin typ) in begin match builtin, typ with | true, [%type: [%t? typ] ref] -> [%expr fun x -> [%e expr_of_typ typ] !x] | true, [%type: [%t? typ] list] -> [%expr Ppx_deriving_runtime.List.iter [%e expr_of_typ typ]] | true, [%type: [%t? typ] array] -> [%expr Ppx_deriving_runtime.Array.iter [%e expr_of_typ typ]] | true, [%type: [%t? typ] option] -> [%expr function None -> () | Some x -> [%e expr_of_typ typ] x] | true, [%type: ([%t? ok_t], [%t? err_t]) result] | true, [%type: ([%t? ok_t], [%t? err_t]) Result.result] -> [%expr function | Ok ok -> ignore ([%e expr_of_typ ok_t] ok) | Error err -> ignore ([%e expr_of_typ err_t] err)] | _, { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } -> app (Exp.ident (mknoloc (Ppx_deriving.mangle_lid (`Prefix deriver) lid))) (List.map expr_of_typ args) | _ -> assert false end | { ptyp_desc = Ptyp_tuple typs } -> [%expr fun [%p ptuple (List.mapi (fun i _ -> pvar (argn i)) typs)] -> [%e Ppx_deriving.(fold_exprs seq_reduce (List.mapi (fun i typ -> app (expr_of_typ typ) [evar (argn i)]) typs))]]; | { ptyp_desc = Ptyp_variant (fields, _, _); ptyp_loc } -> let cases = fields |> List.map (fun field -> let variant label popt = Pat.variant label.txt popt in match field.prf_desc with | Rtag(label, true (*empty*), []) -> Exp.case (variant label None) [%expr ()] | Rtag(label, false, [typ]) -> Exp.case (variant label (Some [%pat? x])) [%expr [%e expr_of_typ typ] x] | Rinherit({ ptyp_desc = Ptyp_constr (tname, _) } as typ) -> Exp.case [%pat? [%p Pat.type_ tname] as x] [%expr [%e expr_of_typ typ] x] | _ -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ)) in Exp.function_ cases | { ptyp_desc = Ptyp_var name } -> [%expr ([%e evar ("poly_"^name)] : [%t Typ.var name] -> unit)] | { ptyp_desc = Ptyp_alias (typ, name) } -> [%expr fun x -> [%e evar ("poly_"^name)] x; [%e expr_of_typ typ] x] | { ptyp_loc } -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ) and expr_of_label_decl { pld_type; pld_attributes } = let attrs = pld_type.ptyp_attributes @ pld_attributes in expr_of_typ { pld_type with ptyp_attributes = attrs } let str_of_type ({ ptype_loc = loc } as type_decl) = let iterator = match type_decl.ptype_kind, type_decl.ptype_manifest with | Ptype_abstract, Some manifest -> expr_of_typ manifest | Ptype_variant constrs, _ -> constrs |> List.map (fun { pcd_name = { txt = name' }; pcd_args } -> match pcd_args with | Pcstr_tuple(typs) -> let args = List.mapi (fun i typ -> app (expr_of_typ typ) [evar (argn i)]) typs in let result = match args with | [] -> [%expr ()] | args -> Ppx_deriving.(fold_exprs seq_reduce) args in Exp.case (pconstr name' (pattn typs)) result | Pcstr_record(labels) -> let args = labels |> List.map (fun ({ pld_name = { txt = n }; _ } as pld) -> [%expr [%e expr_of_label_decl pld] [%e evar (argl n)]]) in Exp.case (pconstrrec name' (pattl labels)) (Ppx_deriving.(fold_exprs seq_reduce) args) ) |> Exp.function_ | Ptype_record labels, _ -> let fields = labels |> List.mapi (fun i ({ pld_name = { txt = name }; _ } as pld) -> [%expr [%e expr_of_label_decl pld] [%e Exp.field (evar "x") (mknoloc (Lident name))]]) in [%expr fun x -> [%e Ppx_deriving.(fold_exprs seq_reduce) fields]] | Ptype_abstract, None -> raise_errorf ~loc "%s cannot be derived for fully abstract types" deriver | Ptype_open, _ -> raise_errorf ~loc "%s cannot be derived for open types" deriver in let polymorphize = Ppx_deriving.poly_fun_of_type_decl type_decl in [Vb.mk ~attrs:[Ppx_deriving.attr_warning [%expr "-39"]] (pvar (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl)) (polymorphize iterator)] let sig_of_type type_decl = let loc = !Ast_helper.default_loc in let typ = Ppx_deriving.core_type_of_type_decl type_decl in let polymorphize = Ppx_deriving.poly_arrow_of_type_decl (fun var -> [%type: [%t var] -> Ppx_deriving_runtime.unit]) type_decl in [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl)) (polymorphize [%type: [%t typ] -> Ppx_deriving_runtime.unit]))] let impl_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> [Str.value Recursive (List.concat (List.map str_of_type type_decls))]) let intf_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> List.concat (List.map sig_of_type type_decls)) let deriving: Deriving.t = Deriving.add deriver ~str_type_decl:impl_generator ~sig_type_decl:intf_generator ppx_deriving-6.0.2/src_plugins/make/000077500000000000000000000000001462406363500174735ustar00rootroot00000000000000ppx_deriving-6.0.2/src_plugins/make/dune000066400000000000000000000003311462406363500203460ustar00rootroot00000000000000(library (name ppx_deriving_make) (public_name ppx_deriving.make) (synopsis "[@@deriving make]") (preprocess (pps ppxlib.metaquot)) (libraries compiler-libs.common ppxlib ppx_deriving.api) (kind ppx_deriver)) ppx_deriving-6.0.2/src_plugins/make/ppx_deriving_make.ml000066400000000000000000000207141462406363500235240ustar00rootroot00000000000000open Ppxlib open Asttypes open Parsetree open Ast_helper open Ppx_deriving.Ast_convenience let deriver = "make" let raise_errorf = Ppx_deriving.raise_errorf let attr_default context = Attribute.declare "deriving.make.default" context Ast_pattern.(single_expr_payload __) (fun e -> e) let attr_default = (attr_default Attribute.Context.label_declaration, attr_default Attribute.Context.core_type) let mk_attr_split context = Attribute.declare_flag "deriving.make.split" context let ct_attr_split = mk_attr_split Attribute.Context.core_type let label_attr_split = mk_attr_split Attribute.Context.label_declaration let attr_split = (label_attr_split, ct_attr_split) let mk_attr_main context = Attribute.declare_flag "deriving.make.main" context let ct_attr_main = mk_attr_main Attribute.Context.core_type let label_attr_main = mk_attr_main Attribute.Context.label_declaration let attr_main = (label_attr_main, ct_attr_main) let get_label_attribute (label_attr, ct_attr) label = match Attribute.get label_attr label with | Some _ as v -> v | None -> Attribute.get ct_attr label.pld_type let has_label_flag (label_flag, ct_flag) ({pld_type; _} as label) = Attribute.has_flag ct_flag pld_type || Attribute.has_flag label_flag label let find_main labels = let mains, regulars = List.partition (has_label_flag attr_main) labels in match mains, regulars with | [], labels -> Ok (None, labels) | [main], labels -> Ok (Some main, labels) | _::{pld_loc; _}::_ , _ -> Error (Location.error_extensionf ~loc:pld_loc "Duplicate [@deriving.%s.main] annotation" deriver) let is_optional ({ pld_name = { txt = name }; pld_type; _ } as label) = match get_label_attribute attr_default label with | Some _ -> true | None -> has_label_flag attr_split label || (match Ppx_deriving.remove_pervasives ~deriver pld_type with | [%type: [%t? _] list] | [%type: [%t? _] option] -> true | _ -> false) let add_str_label_arg ~quoter ~loc accum ({pld_name = {txt = name}; pld_type; _} as label) = match get_label_attribute attr_default label with | Some default -> Exp.fun_ (Label.optional name) (Some (Ppx_deriving.quote ~quoter default)) (pvar name) accum | None -> let pld_type = Ppx_deriving.remove_pervasives ~deriver pld_type in if has_label_flag attr_split label then match pld_type with | [%type: [%t? lhs] * [%t? rhs] list] when name.[String.length name - 1] = 's' -> let name' = String.sub name 0 (String.length name - 1) in Exp.fun_ (Label.labelled name') None (pvar name') (Exp.fun_ (Label.optional name) (Some [%expr []]) (pvar name) [%expr let [%p pvar name] = [%e evar name'], [%e evar name] in [%e accum]]) | _ -> Ast_builder.Default.pexp_extension ~loc (Location.error_extensionf ~loc "[@deriving.%s.split] annotation requires a type of form \ 'a * 'a list and label name ending with `s'" deriver) else match pld_type with | [%type: [%t? _] list] -> Exp.fun_ (Label.optional name) (Some [%expr []]) (pvar name) accum | [%type: [%t? _] option] -> Exp.fun_ (Label.optional name) None (pvar name) accum | _ -> Exp.fun_ (Label.labelled name) None (pvar name) accum let str_of_record_type ~quoter ~loc labels = let fields = labels |> List.map (fun { pld_name = { txt = name; loc } } -> name, evar name) in match find_main labels with | Error extension -> Ast_builder.Default.pexp_extension ~loc extension | Ok (main, labels) -> let has_option = List.exists is_optional labels in let fn = match main with | Some { pld_name = { txt = name }} -> Exp.fun_ Label.nolabel None (pvar name) (record fields) | None when has_option -> Exp.fun_ Label.nolabel None (punit ()) (record fields) | None -> record fields in (* The labels list must be reversed here so that the arguments are in the same order as the record fields. *) List.fold_left (add_str_label_arg ~quoter ~loc) fn (List.rev labels) let str_of_type ({ ptype_loc = loc } as type_decl) = let quoter = Ppx_deriving.create_quoter () in match type_decl.ptype_kind with | Ptype_record labels -> let creator = str_of_record_type ~quoter ~loc labels in Ok (Vb.mk (pvar (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl)) (Ppx_deriving.sanitize ~quoter creator)) | _ -> Error (Location.error_extensionf ~loc "%s can be derived only for record types" deriver) let wrap_predef_option typ = typ let add_sig_label_arg accum ({pld_name = {txt = name; loc}; pld_type; _} as label) = match get_label_attribute attr_default label with | Some _ -> Typ.arrow (Label.optional name) (wrap_predef_option pld_type) accum | None -> let pld_type = Ppx_deriving.remove_pervasives ~deriver pld_type in if has_label_flag attr_split label then match pld_type with | [%type: [%t? lhs] * [%t? rhs] list] when name.[String.length name - 1] = 's' -> let name' = String.sub name 0 (String.length name - 1) in Typ.arrow (Label.labelled name') lhs (Typ.arrow (Label.optional name) (wrap_predef_option [%type: [%t rhs] list]) accum) | _ -> Ast_builder.Default.ptyp_extension ~loc (Location.error_extensionf ~loc "[@deriving.%s.split] annotation requires a type of form \ 'a * 'a list and label name ending with `s'" deriver) else match pld_type with | [%type: [%t? _] list] -> Typ.arrow (Label.optional name) (wrap_predef_option pld_type) accum | [%type: [%t? opt] option] -> Typ.arrow (Label.optional name) (wrap_predef_option opt) accum | _ -> Typ.arrow (Label.labelled name) pld_type accum let sig_of_record_type ~loc ~typ labels = match find_main labels with | Error extension -> Ast_builder.Default.ptyp_extension ~loc extension | Ok (main, labels) -> let has_option = List.exists is_optional labels in let typ = match main with | Some { pld_name = { txt = name }; pld_type } -> Typ.arrow Label.nolabel pld_type typ | None when has_option -> Typ.arrow Label.nolabel (tconstr "unit" []) typ | None -> typ in (* The labels list must be reversed here so that the arguments are in the same order as the record fields. *) List.fold_left add_sig_label_arg typ (List.rev labels) let sig_of_type ({ ptype_loc = loc } as type_decl) = let typ = Ppx_deriving.core_type_of_type_decl type_decl in match type_decl.ptype_kind with | Ptype_record labels -> let typ = sig_of_record_type ~loc ~typ labels in let val_name = Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl in Ok (Sig.value (Val.mk (mknoloc val_name) typ)) | _ -> Error (Location.error_extensionf ~loc "%s can only be derived for record types" deriver) (* Ppxlib does not keep track of which type the attribute was attached to in a set of type declarations and does not provide a nice and reliable way to manually check it. Until we have something better, we have to assume that the [[@@deriving make]] attribute was meant for the whole set and properly placed. That means that if there is at least one type declaration in the set for which we can derive make, we will ignore errors from the rest. *) let partition_result l = let errors, oks = List.fold_left (fun (errors, oks) res -> match res with | Ok x -> (errors, x :: oks) | Error e -> (e :: errors, oks)) ([], []) l in List.rev errors, List.rev oks let impl_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt (_, type_decls) -> match partition_result (List.map str_of_type type_decls) with | _, (_::_ as vbs) -> [Str.value Nonrecursive vbs] | errors, [] -> let loc = Expansion_context.Deriver.derived_item_loc ctxt in List.map (fun ext -> Ast_builder.Default.pstr_extension ~loc ext []) errors) let intf_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt (_, type_decls) -> match partition_result (List.map sig_of_type type_decls) with | _, (_::_ as vds) -> vds | errors, [] -> let loc = Expansion_context.Deriver.derived_item_loc ctxt in List.map (fun ext -> Ast_builder.Default.psig_extension ~loc ext []) errors) let deriving: Deriving.t = Deriving.add deriver ~str_type_decl:impl_generator ~sig_type_decl:intf_generator ppx_deriving-6.0.2/src_plugins/map/000077500000000000000000000000001462406363500173335ustar00rootroot00000000000000ppx_deriving-6.0.2/src_plugins/map/dune000066400000000000000000000003261462406363500202120ustar00rootroot00000000000000(library (name ppx_deriving_map) (public_name ppx_deriving.map) (synopsis "[@@deriving map]") (preprocess (pps ppxlib.metaquot)) (libraries compiler-libs.common ppxlib ppx_deriving.api) (kind ppx_deriver)) ppx_deriving-6.0.2/src_plugins/map/ppx_deriving_map.ml000066400000000000000000000145621462406363500232300ustar00rootroot00000000000000open Ppxlib open Asttypes open Parsetree open Ast_helper open Ppx_deriving.Ast_convenience let deriver = "map" let raise_errorf = Ppx_deriving.raise_errorf let ct_attr_nobuiltin = Attribute.declare_flag "deriving.map.nobuiltin" Attribute.Context.core_type let argn = Printf.sprintf "a%d" let argl = Printf.sprintf "a%s" let pattn typs = List.mapi (fun i _ -> pvar (argn i)) typs let pattl labels = List.map (fun { pld_name = { txt = n } } -> n, pvar (argl n)) labels let pconstrrec name fields = pconstr name [precord ~closed:Closed fields] let constrrec name fields = constr name [ record fields] let rec expr_of_typ ?decl typ = let loc = typ.ptyp_loc in let typ = Ppx_deriving.remove_pervasives ~deriver typ in match typ with | _ when Ppx_deriving.free_vars_in_core_type typ = [] -> [%expr fun x -> x] | { ptyp_desc = Ptyp_constr _ } -> let builtin = not (Attribute.has_flag ct_attr_nobuiltin typ) in begin match builtin, typ with | true, [%type: [%t? typ] list] -> [%expr Ppx_deriving_runtime.List.map [%e expr_of_typ ?decl typ]] | true, [%type: [%t? typ] array] -> [%expr Ppx_deriving_runtime.Array.map [%e expr_of_typ ?decl typ]] | true, [%type: [%t? typ] option] -> [%expr function None -> None | Some x -> Some ([%e expr_of_typ ?decl typ] x)] | true, ([%type: ([%t? ok_t], [%t? err_t]) result] | [%type: ([%t? ok_t], [%t? err_t]) Result.result]) -> [%expr function | Ok ok -> Ok ([%e expr_of_typ ?decl ok_t] ok) | Error err -> Error ([%e expr_of_typ ?decl err_t] err)] | _, { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } -> app (Exp.ident (mknoloc (Ppx_deriving.mangle_lid (`Prefix deriver) lid))) (List.map (expr_of_typ ?decl) args) | _ -> assert false end | { ptyp_desc = Ptyp_tuple typs } -> [%expr fun [%p ptuple (List.mapi (fun i _ -> pvar (argn i)) typs)] -> [%e tuple (List.mapi (fun i typ -> app (expr_of_typ ?decl typ) [evar (argn i)]) typs)]]; | { ptyp_desc = Ptyp_variant (fields, _, _); ptyp_loc } -> let cases = fields |> List.map (fun field -> let pat_variant label popt = Pat.variant label.txt popt in let exp_variant label popt = Exp.variant label.txt popt in match field.prf_desc with | Rtag(label, true (*empty*), []) -> Exp.case (pat_variant label None) (exp_variant label None) | Rtag(label, false, [typ]) -> Exp.case (pat_variant label (Some [%pat? x])) (exp_variant label (Some [%expr [%e expr_of_typ ?decl typ] x])) | Rinherit({ ptyp_desc = Ptyp_constr (tname, _) } as typ) -> begin match decl with | None -> raise_errorf "inheritance of polymorphic variants not supported" | Some(d) -> Exp.case [%pat? [%p Pat.type_ tname] as x] [%expr ([%e expr_of_typ ?decl typ] x :> [%t Ppx_deriving.core_type_of_type_decl d])] end | _ -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ)) in Exp.function_ cases | { ptyp_desc = Ptyp_var name } -> evar ("poly_"^name) | { ptyp_desc = Ptyp_alias (typ, name) } -> [%expr fun x -> [%e evar ("poly_"^name)] ([%e expr_of_typ ?decl typ] x)] | { ptyp_loc } -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ) and expr_of_label_decl ?decl { pld_type; pld_attributes } = let attrs = pld_type.ptyp_attributes @ pld_attributes in expr_of_typ ?decl { pld_type with ptyp_attributes = attrs } let str_of_type ({ ptype_loc = loc } as type_decl) = let mapper = match type_decl.ptype_kind, type_decl.ptype_manifest with | Ptype_abstract, Some manifest -> expr_of_typ ~decl:type_decl manifest | Ptype_variant constrs, _ -> constrs |> List.map (fun { pcd_name = { txt = name' }; pcd_args } -> match pcd_args with | Pcstr_tuple(typs) -> let args = List.mapi (fun i typ -> app (expr_of_typ ~decl:type_decl typ) [evar (argn i)]) typs in Exp.case (pconstr name' (pattn typs)) (constr name' args) | Pcstr_record(labels) -> let args = labels |> List.map (fun ({ pld_name = { txt = n }; _ } as pld) -> n, [%expr [%e expr_of_label_decl ~decl:type_decl pld] [%e evar (argl n)]]) in Exp.case (pconstrrec name' (pattl labels)) (constrrec name' args) ) |> Exp.function_ | Ptype_record labels, _ -> let fields = labels |> List.mapi (fun i ({ pld_name = { txt = name }; _ } as pld) -> name, [%expr [%e expr_of_label_decl ~decl:type_decl pld] [%e Exp.field (evar "x") (mknoloc (Lident name))]]) in let annot_typ = Ppx_deriving.core_type_of_type_decl type_decl in [%expr fun (x:[%t annot_typ]) -> [%e record fields]] | Ptype_abstract, None -> raise_errorf ~loc "%s cannot be derived for fully abstract types" deriver | Ptype_open, _ -> raise_errorf ~loc "%s cannot be derived for open types" deriver in let polymorphize = Ppx_deriving.poly_fun_of_type_decl type_decl in [Vb.mk ~attrs:[Ppx_deriving.attr_warning [%expr "-39"]] (pvar (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl)) (polymorphize mapper)] let sig_of_type type_decl = let loc = type_decl.ptype_loc in let typ_arg, var_arg, bound = Ppx_deriving.instantiate [] type_decl in let typ_ret, var_ret, _ = Ppx_deriving.instantiate bound type_decl in let arrow = Typ.arrow Label.nolabel in let poly_fns = List.map2 (fun a r -> [%type: [%t Typ.var a] -> [%t Typ.var r]]) var_arg var_ret in let typ = List.fold_right arrow poly_fns (arrow typ_arg typ_ret) in [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl)) typ)] let impl_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> [Str.value Recursive (List.concat (List.map str_of_type type_decls))]) let intf_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> List.concat (List.map sig_of_type type_decls)) let deriving: Deriving.t = Deriving.add deriver ~str_type_decl:impl_generator ~sig_type_decl:intf_generator ppx_deriving-6.0.2/src_plugins/ord/000077500000000000000000000000001462406363500173425ustar00rootroot00000000000000ppx_deriving-6.0.2/src_plugins/ord/dune000066400000000000000000000003261462406363500202210ustar00rootroot00000000000000(library (name ppx_deriving_ord) (public_name ppx_deriving.ord) (synopsis "[@@deriving ord]") (preprocess (pps ppxlib.metaquot)) (libraries compiler-libs.common ppxlib ppx_deriving.api) (kind ppx_deriver)) ppx_deriving-6.0.2/src_plugins/ord/ppx_deriving_ord.ml000066400000000000000000000244371462406363500232500ustar00rootroot00000000000000open Ppxlib open Longident open Asttypes open Parsetree open Ast_helper open Ppx_deriving.Ast_convenience let deriver = "ord" let raise_errorf = Ppx_deriving.raise_errorf let ct_attr_nobuiltin = Attribute.declare_flag "deriving.ord.nobuiltin" Attribute.Context.core_type let ct_attr_compare = Attribute.declare "deriving.ord.compare" Attribute.Context.core_type Ast_pattern.(single_expr_payload __) (fun e -> e) let argn kind = Printf.sprintf (match kind with `lhs -> "lhs%d" | `rhs -> "rhs%d") let argl kind = Printf.sprintf (match kind with `lhs -> "lhs%s" | `rhs -> "rhs%s") let compare_reduce acc expr = let loc = !Ast_helper.default_loc in [%expr match [%e expr] with 0 -> [%e acc] | x -> x] let reduce_compare l = let loc = !Ast_helper.default_loc in match List.rev l with | [] -> [%expr 0] | x :: xs -> List.fold_left compare_reduce x xs let wildcard_case int_cases = let loc = !Ast_helper.default_loc in Exp.case [%pat? _] [%expr let to_int = [%e Exp.function_ int_cases] in Ppx_deriving_runtime.compare (to_int lhs) (to_int rhs)] let pattn side typs = List.mapi (fun i _ -> pvar (argn side i)) typs let pattl side labels = List.map (fun { pld_name = { txt = n } } -> n, pvar (argl side n)) labels let pconstrrec name fields = pconstr name [precord ~closed:Closed fields] let rec exprn quoter typs = typs |> List.mapi (fun i typ -> app (expr_of_typ quoter typ) [evar (argn `lhs i); evar (argn `rhs i)]) and exprl quoter typs = typs |> List.map (fun ({ pld_name = { txt = n }; _ } as pld) -> app (expr_of_label_decl quoter pld) [evar (argl `lhs n); evar (argl `rhs n)]) and expr_of_label_decl quoter { pld_type; pld_attributes } = let attrs = pld_type.ptyp_attributes @ pld_attributes in expr_of_typ quoter { pld_type with ptyp_attributes = attrs } and expr_of_typ quoter typ = let loc = typ.ptyp_loc in let expr_of_typ = expr_of_typ quoter in match Attribute.get ct_attr_compare typ with | Some fn -> Ppx_deriving.quote ~quoter fn | None -> let typ = Ppx_deriving.remove_pervasives ~deriver typ in match typ with | [%type: _] -> [%expr fun _ _ -> 0] | { ptyp_desc = Ptyp_constr _ } -> let builtin = not (Attribute.has_flag ct_attr_nobuiltin typ) in begin match builtin, typ with | true, [%type: _] -> [%expr fun _ _ -> 0] | true, [%type: unit] -> [%expr fun (_:unit) (_:unit) -> 0] | true, ([%type: int] | [%type: int32] | [%type: Int32.t] | [%type: int64] | [%type: Int64.t] | [%type: nativeint] | [%type: Nativeint.t] | [%type: float] | [%type: bool] | [%type: char] | [%type: string] | [%type: bytes]) -> let compare_fn = [%expr fun (a:[%t typ]) b -> Ppx_deriving_runtime.compare a b] in Ppx_deriving.quote ~quoter compare_fn | true, [%type: [%t? typ] ref] -> [%expr fun a b -> [%e expr_of_typ typ] !a !b] | true, [%type: [%t? typ] list] -> [%expr let rec loop x y = match x, y with | [], [] -> 0 | [], _ -> -1 | _, [] -> 1 | a :: x, b :: y -> [%e compare_reduce [%expr loop x y] [%expr [%e expr_of_typ typ] a b]] in (fun x y -> loop x y)] | true, [%type: [%t? typ] array] -> [%expr fun x y -> let rec loop i = if i = Array.length x then 0 else [%e compare_reduce [%expr loop (i + 1)] [%expr [%e expr_of_typ typ] x.(i) y.(i)]] in [%e compare_reduce [%expr loop 0] [%expr Ppx_deriving_runtime.compare (Array.length x) (Array.length y)]]] | true, [%type: [%t? typ] option] -> [%expr fun x y -> match x, y with | None, None -> 0 | Some a, Some b -> [%e expr_of_typ typ] a b | None, Some _ -> -1 | Some _, None -> 1] | true, ([%type: ([%t? ok_t], [%t? err_t]) result] | [%type: ([%t? ok_t], [%t? err_t]) Result.result]) -> [%expr fun x y -> match x, y with | Error a, Error b -> [%e expr_of_typ err_t] a b | Ok a, Ok b -> [%e expr_of_typ ok_t] a b | Ok _ , Error _ -> -1 | Error _ , Ok _ -> 1] | true, ([%type: [%t? typ] lazy_t] | [%type: [%t? typ] Lazy.t]) -> [%expr fun (lazy x) (lazy y) -> [%e expr_of_typ typ] x y] | _, { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } -> let compare_fn = Exp.ident (mknoloc (Ppx_deriving.mangle_lid (`Prefix "compare") lid)) in app (Ppx_deriving.quote ~quoter compare_fn) (List.map expr_of_typ args) | _ -> assert false end | { ptyp_desc = Ptyp_tuple typs } -> [%expr fun [%p ptuple (pattn `lhs typs)] [%p ptuple (pattn `rhs typs)] -> [%e exprn quoter typs |> reduce_compare]] | { ptyp_desc = Ptyp_variant (fields, _, _); ptyp_loc } -> let variant label popt = Pat.variant label.txt popt in let cases = fields |> List.map (fun field -> let pdup f = ptuple [f "lhs"; f "rhs"] in match field.prf_desc with | Rtag(label, true (*empty*), []) -> Exp.case (pdup (fun _ -> variant label None)) [%expr 0] | Rtag(label, false, [typ]) -> Exp.case (pdup (fun var -> variant label (Some (pvar var)))) (app (expr_of_typ typ) [evar "lhs"; evar "rhs"]) | Rinherit({ ptyp_desc = Ptyp_constr (tname, _) } as typ) -> Exp.case (pdup (fun var -> Pat.alias (Pat.type_ tname) (mknoloc var))) (app (expr_of_typ typ) [evar "lhs"; evar "rhs"]) | _ -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ)) in let int_cases = fields |> List.mapi (fun i field -> match field.prf_desc with | Rtag(label, true (*empty*), []) -> Exp.case (variant label None) (int i) | Rtag(label, false, [typ]) -> Exp.case (variant label (Some [%pat? _])) (int i) | Rinherit({ ptyp_desc = Ptyp_constr (tname, []) }) -> Exp.case (Pat.type_ tname) (int i) | _ -> assert false) in [%expr fun lhs rhs -> [%e Exp.match_ [%expr lhs, rhs] (cases @ [wildcard_case int_cases])]] | { ptyp_desc = Ptyp_var name } -> evar ("poly_"^name) | { ptyp_desc = Ptyp_alias (typ, _) } -> expr_of_typ typ | { ptyp_loc } -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ) let core_type_of_decl type_decl = let loc = type_decl.ptype_loc in let typ = Ppx_deriving.core_type_of_type_decl type_decl in let polymorphize = Ppx_deriving.poly_arrow_of_type_decl (fun var -> [%type: [%t var] -> [%t var] -> Ppx_deriving_runtime.int]) type_decl in (polymorphize [%type: [%t typ] -> [%t typ] -> Ppx_deriving_runtime.int]) let sig_of_type type_decl = [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "compare") type_decl)) (core_type_of_decl type_decl))] let str_of_type ({ ptype_loc = loc } as type_decl) = let quoter = Ppx_deriving.create_quoter () in let comparator = match type_decl.ptype_kind, type_decl.ptype_manifest with | Ptype_abstract, Some manifest -> expr_of_typ quoter manifest | Ptype_variant constrs, _ -> let int_cases = constrs |> List.mapi (fun i { pcd_name = { txt = name }; pcd_args } -> match pcd_args with | Pcstr_tuple([]) -> Exp.case (pconstr name []) (int i) | _ -> Exp.case (pconstr name [[%pat? _]]) (int i)) and cases = constrs |> List.map (fun { pcd_name = { txt = name }; pcd_args } -> match pcd_args with | Pcstr_tuple(typs) -> exprn quoter typs |> reduce_compare |> Exp.case (ptuple [pconstr name (pattn `lhs typs); pconstr name (pattn `rhs typs)]) | Pcstr_record(labels) -> exprl quoter labels |> reduce_compare |> Exp.case (ptuple [pconstrrec name (pattl `lhs labels); pconstrrec name (pattl `rhs labels)]) ) in [%expr fun lhs rhs -> [%e Exp.match_ [%expr lhs, rhs] (cases @ [wildcard_case int_cases])]] | Ptype_record labels, _ -> let exprs = labels |> List.map (fun ({ pld_name = { txt = name }; _ } as pld) -> let field obj = Exp.field obj (mknoloc (Lident name)) in app (expr_of_label_decl quoter pld) [field (evar "lhs"); field (evar "rhs")]) in [%expr fun lhs rhs -> [%e reduce_compare exprs]] | Ptype_abstract, None -> raise_errorf ~loc "%s cannot be derived for fully abstract types" deriver | Ptype_open, _ -> raise_errorf ~loc "%s cannot be derived for open types" deriver in let polymorphize = Ppx_deriving.poly_fun_of_type_decl type_decl in let eta_expand expr = (* Ensure expr is statically constructive by eta-expanding non-funs. See https://github.com/ocaml-ppx/ppx_deriving/pull/252. *) match expr with | { pexp_desc = Pexp_fun _; _ } -> expr | _ -> [%expr fun x -> [%e expr] x] in let out_type = Ppx_deriving.strong_type_of_type @@ core_type_of_decl type_decl in let out_var = pvar (Ppx_deriving.mangle_type_decl (`Prefix "compare") type_decl) in [Vb.mk ~attrs:[Ppx_deriving.attr_warning [%expr "-39"]] (Pat.constraint_ out_var out_type) (Ppx_deriving.sanitize ~quoter (eta_expand (polymorphize comparator)))] let impl_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> [Str.value Recursive (List.concat (List.map str_of_type type_decls))]) let intf_generator = Deriving.Generator.V2.make_noarg (fun ~ctxt:_ (_, type_decls) -> List.concat (List.map sig_of_type type_decls)) let deriving: Deriving.t = Deriving.add deriver ~str_type_decl:impl_generator ~sig_type_decl:intf_generator (* custom extension such that "derive"-prefixed also works *) let derive_extension = Extension.V3.declare "derive.ord" Extension.Context.expression Ast_pattern.(ptyp __) (fun ~ctxt:_ -> Ppx_deriving.with_quoter expr_of_typ) let derive_transformation = Driver.register_transformation deriver ~rules:[Context_free.Rule.extension derive_extension] ppx_deriving-6.0.2/src_plugins/show/000077500000000000000000000000001462406363500175365ustar00rootroot00000000000000ppx_deriving-6.0.2/src_plugins/show/dune000066400000000000000000000003311462406363500204110ustar00rootroot00000000000000(library (name ppx_deriving_show) (public_name ppx_deriving.show) (synopsis "[@@deriving show]") (preprocess (pps ppxlib.metaquot)) (libraries compiler-libs.common ppxlib ppx_deriving.api) (kind ppx_deriver)) ppx_deriving-6.0.2/src_plugins/show/ppx_deriving_show.ml000066400000000000000000000402241462406363500236300ustar00rootroot00000000000000open Ppxlib open Asttypes open Parsetree open Ast_helper open Ppx_deriving.Ast_convenience let deriver = "show" let raise_errorf = Ppx_deriving.raise_errorf (* The option [with_path] controls whether a full path should be displayed as part of data constructor names and record field names. (In the case of record fields, it is displayed only as part of the name of the first field.) By default, this option is [true], which means that full paths are shown. *) let expand_path ~with_path ~path name = let path = if with_path then path else [] in Ppx_deriving.expand_path ~path name let ct_attr_nobuiltin = Attribute.declare_flag "deriving.show.nobuiltin" Attribute.Context.core_type let attr_printer context = Attribute.declare "deriving.show.printer" context Ast_pattern.(single_expr_payload __) (fun e -> e) let ct_attr_printer = attr_printer Attribute.Context.core_type let constr_attr_printer = attr_printer Attribute.Context.constructor_declaration let ct_attr_polyprinter = Attribute.declare "deriving.show.polyprinter" Attribute.Context.core_type Ast_pattern.(single_expr_payload __) (fun e -> e) let ct_attr_opaque = Attribute.declare_flag "deriving.show.opaque" Attribute.Context.core_type let argn = Printf.sprintf "a%d" let argl = Printf.sprintf "a%s" let pattn typs = List.mapi (fun i _ -> pvar (argn i)) typs let pattl labels = List.map (fun { pld_name = { txt = n } } -> n, pvar (argl n)) labels let pconstrrec name fields = pconstr name [precord ~closed:Closed fields] let wrap_printer quoter printer = let loc = !Ast_helper.default_loc in Ppx_deriving.quote ~quoter [%expr (let fprintf = Ppx_deriving_runtime.Format.fprintf in [%e printer]) [@ocaml.warning "-26"]] let pp_type_of_decl type_decl = let loc = type_decl.ptype_loc in let typ = Ppx_deriving.core_type_of_type_decl type_decl in Ppx_deriving.poly_arrow_of_type_decl (fun var -> [%type: Ppx_deriving_runtime.Format.formatter -> [%t var] -> Ppx_deriving_runtime.unit]) type_decl [%type: Ppx_deriving_runtime.Format.formatter -> [%t typ] -> Ppx_deriving_runtime.unit] let show_type_of_decl type_decl = let loc = type_decl.ptype_loc in let typ = Ppx_deriving.core_type_of_type_decl type_decl in Ppx_deriving.poly_arrow_of_type_decl (fun var -> [%type: Ppx_deriving_runtime.Format.formatter -> [%t var] -> Ppx_deriving_runtime.unit]) type_decl [%type: [%t typ] -> Ppx_deriving_runtime.string] let sig_of_type type_decl = [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "pp") type_decl)) (pp_type_of_decl type_decl)); Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "show") type_decl)) (show_type_of_decl type_decl))] let rec expr_of_typ quoter typ = let loc = typ.ptyp_loc in let expr_of_typ = expr_of_typ quoter in match Attribute.get ct_attr_printer typ with | Some printer -> [%expr [%e wrap_printer quoter printer] fmt] | None -> if Attribute.has_flag ct_attr_opaque typ then [%expr fun _ -> Ppx_deriving_runtime.Format.pp_print_string fmt ""] else let format x = [%expr Ppx_deriving_runtime.Format.fprintf fmt [%e str x]] in let seq start finish fold typ = [%expr fun x -> Ppx_deriving_runtime.Format.fprintf fmt [%e str start]; ignore ([%e fold] (fun sep x -> if sep then Ppx_deriving_runtime.Format.fprintf fmt ";@ "; [%e expr_of_typ typ] x; true) false x); Ppx_deriving_runtime.Format.fprintf fmt [%e str finish];] in let typ = Ppx_deriving.remove_pervasives ~deriver typ in match typ with | [%type: _] -> [%expr fun _ -> Ppx_deriving_runtime.Format.pp_print_string fmt "_"] | { ptyp_desc = Ptyp_arrow _ } -> [%expr fun _ -> Ppx_deriving_runtime.Format.pp_print_string fmt ""] | { ptyp_desc = Ptyp_constr _ } -> let builtin = not (Attribute.has_flag ct_attr_nobuiltin typ) in begin match builtin, typ with | true, [%type: unit] -> [%expr fun () -> Ppx_deriving_runtime.Format.pp_print_string fmt "()"] | true, [%type: int] -> format "%d" | true, [%type: int32] | true, [%type: Int32.t] -> format "%ldl" | true, [%type: int64] | true, [%type: Int64.t] -> format "%LdL" | true, [%type: nativeint] | true, [%type: Nativeint.t] -> format "%ndn" | true, [%type: float] -> format "%F" | true, [%type: bool] -> format "%B" | true, [%type: char] -> format "%C" | true, [%type: string] | true, [%type: String.t] -> format "%S" | true, [%type: bytes] | true, [%type: Bytes.t] -> [%expr fun x -> Ppx_deriving_runtime.Format.fprintf fmt "%S" (Bytes.to_string x)] | true, [%type: [%t? typ] ref] -> [%expr fun x -> Ppx_deriving_runtime.Format.pp_print_string fmt "ref ("; [%e expr_of_typ typ] !x; Ppx_deriving_runtime.Format.pp_print_string fmt ")"] | true, [%type: [%t? typ] list] -> seq "@[<2>[" "@,]@]" [%expr List.fold_left] typ | true, [%type: [%t? typ] array] -> seq "@[<2>[|" "@,|]@]" [%expr Array.fold_left] typ | true, [%type: [%t? typ] option] -> [%expr function | None -> Ppx_deriving_runtime.Format.pp_print_string fmt "None" | Some x -> Ppx_deriving_runtime.Format.pp_print_string fmt "(Some "; [%e expr_of_typ typ] x; Ppx_deriving_runtime.Format.pp_print_string fmt ")"] | true, ([%type: ([%t? ok_t], [%t? err_t]) result] | [%type: ([%t? ok_t], [%t? err_t]) Result.result]) -> [%expr function | Ok ok -> Ppx_deriving_runtime.Format.pp_print_string fmt "(Ok "; [%e expr_of_typ ok_t] ok; Ppx_deriving_runtime.Format.pp_print_string fmt ")" | Error e -> Ppx_deriving_runtime.Format.pp_print_string fmt "(Error "; [%e expr_of_typ err_t] e; Ppx_deriving_runtime.Format.pp_print_string fmt ")"] | true, ([%type: [%t? typ] lazy_t] | [%type: [%t? typ] Lazy.t]) -> [%expr fun x -> if Lazy.is_val x then [%e expr_of_typ typ] (Lazy.force x) else Ppx_deriving_runtime.Format.pp_print_string fmt ""] | _, { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } -> let args_pp = List.map (fun typ -> [%expr fun fmt -> [%e expr_of_typ typ]]) args in let printer = match Attribute.get ct_attr_polyprinter typ with | Some printer -> wrap_printer quoter printer | None -> let printer = Exp.ident (mknoloc (Ppx_deriving.mangle_lid (`Prefix "pp") lid)) in Ppx_deriving.quote ~quoter printer in app printer (args_pp @ [[%expr fmt]]) | _ -> assert false end | { ptyp_desc = Ptyp_tuple typs } -> let args = List.mapi (fun i typ -> app (expr_of_typ typ) [evar (argn i)]) typs in [%expr fun [%p ptuple (List.mapi (fun i _ -> pvar (argn i)) typs)] -> Ppx_deriving_runtime.Format.fprintf fmt "(@["; [%e args |> Ppx_deriving.(fold_exprs (seq_reduce ~sep:[%expr Ppx_deriving_runtime.Format.fprintf fmt ",@ "]))]; Ppx_deriving_runtime.Format.fprintf fmt "@])"] | { ptyp_desc = Ptyp_variant (fields, _, _); ptyp_loc } -> let cases = fields |> List.map (fun field -> match field.prf_desc with | Rtag(label, true (*empty*), []) -> let label = label.txt in Exp.case (Pat.variant label None) [%expr Ppx_deriving_runtime.Format.pp_print_string fmt [%e str ("`" ^ label)]] | Rtag(label, false, [typ]) -> let label = label.txt in Exp.case (Pat.variant label (Some [%pat? x])) [%expr Ppx_deriving_runtime.Format.fprintf fmt [%e str ("`" ^ label ^ " (@[")]; [%e expr_of_typ typ] x; Ppx_deriving_runtime.Format.fprintf fmt "@])"] | Rinherit({ ptyp_desc = Ptyp_constr (tname, _) } as typ) -> Exp.case [%pat? [%p Pat.type_ tname] as x] [%expr [%e expr_of_typ typ] x] | _ -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ)) in Exp.function_ cases | { ptyp_desc = Ptyp_var name } -> [%expr [%e evar ("poly_"^name)] fmt] | { ptyp_desc = Ptyp_alias (typ, _) } -> expr_of_typ typ | { ptyp_loc } -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ) and expr_of_label_decl quoter { pld_type; pld_attributes } = let attrs = pld_type.ptyp_attributes @ pld_attributes in expr_of_typ quoter { pld_type with ptyp_attributes = attrs } let str_of_type ~with_path ~path ({ ptype_loc = loc } as type_decl) = let quoter = Ppx_deriving.create_quoter () in let path = Ppx_deriving.path_of_type_decl ~path type_decl in let prettyprinter = match type_decl.ptype_kind, type_decl.ptype_manifest with | Ptype_abstract, Some manifest -> [%expr fun fmt -> [%e expr_of_typ quoter manifest]] | Ptype_variant constrs, _ -> let cases = constrs |> List.map (fun ({ pcd_name = { txt = name' }; pcd_args; pcd_attributes } as constr) -> let constr_name = expand_path ~with_path ~path name' in match Attribute.get constr_attr_printer constr, pcd_args with | Some printer, Pcstr_tuple(args) -> let rec range from_idx to_idx = if from_idx = to_idx then [] else from_idx::(range (from_idx+1) to_idx) in let indices = range 0 (List.length args) in let pattern_vars = List.map (fun i -> pvar ("a" ^ string_of_int i)) indices in let expr_vars = List.map (fun i -> evar ("a" ^ string_of_int i)) indices in Exp.case (pconstr name' pattern_vars) [%expr [%e wrap_printer quoter printer] fmt [%e tuple expr_vars]] | Some printer, Pcstr_record(labels) -> let args = labels |> List.map (fun { pld_name = { txt = n } } -> evar (argl n)) in Exp.case (pconstrrec name' (pattl labels)) (app (wrap_printer quoter printer) ([%expr fmt] :: args)) | None, Pcstr_tuple(typs) -> let args = List.mapi (fun i typ -> app (expr_of_typ quoter typ) [evar (argn i)]) typs in let printer = match args with | [] -> [%expr Ppx_deriving_runtime.Format.pp_print_string fmt [%e str constr_name]] | [arg] -> [%expr Ppx_deriving_runtime.Format.fprintf fmt [%e str ("(@[<2>" ^ constr_name ^ "@ ")]; [%e arg]; Ppx_deriving_runtime.Format.fprintf fmt "@])"] | args -> [%expr Ppx_deriving_runtime.Format.fprintf fmt [%e str ("(@[<2>" ^ constr_name ^ " (@,")]; [%e args |> Ppx_deriving.(fold_exprs (seq_reduce ~sep:[%expr Ppx_deriving_runtime.Format.fprintf fmt ",@ "]))]; Ppx_deriving_runtime.Format.fprintf fmt "@,))@]"] in Exp.case (pconstr name' (pattn typs)) printer | None, Pcstr_record(labels) -> let args = labels |> List.map (fun ({ pld_name = { txt = n }; _ } as pld) -> [%expr Ppx_deriving_runtime.Format.fprintf fmt "@[%s =@ " [%e str n]; [%e expr_of_label_decl quoter pld] [%e evar (argl n)]; Ppx_deriving_runtime.Format.fprintf fmt "@]" ]) in let printer = [%expr Ppx_deriving_runtime.Format.fprintf fmt [%e str ("@[<2>" ^ constr_name ^ " {@,")]; [%e args |> Ppx_deriving.(fold_exprs (seq_reduce ~sep:[%expr Ppx_deriving_runtime.Format.fprintf fmt ";@ "]))]; Ppx_deriving_runtime.Format.fprintf fmt "@]}"] in Exp.case (pconstrrec name' (pattl labels)) printer ) in [%expr fun fmt -> [%e Exp.function_ cases]] | Ptype_record labels, _ -> let fields = labels |> List.mapi (fun i ({ pld_name = { txt = name }; _} as pld) -> let field_name = if i = 0 then expand_path ~with_path ~path name else name in [%expr Ppx_deriving_runtime.Format.fprintf fmt "@[%s =@ " [%e str field_name]; [%e expr_of_label_decl quoter pld] [%e Exp.field (evar "x") (mknoloc (Lident name))]; Ppx_deriving_runtime.Format.fprintf fmt "@]" ]) in [%expr fun fmt x -> Ppx_deriving_runtime.Format.fprintf fmt "@[<2>{ "; [%e fields |> Ppx_deriving.(fold_exprs (seq_reduce ~sep:[%expr Ppx_deriving_runtime.Format.fprintf fmt ";@ "]))]; Ppx_deriving_runtime.Format.fprintf fmt "@ }@]"] | Ptype_abstract, None -> raise_errorf ~loc "%s cannot be derived for fully abstract types" deriver | Ptype_open, _ -> raise_errorf ~loc "%s cannot be derived for open types" deriver in let pp_poly_apply = Ppx_deriving.poly_apply_of_type_decl type_decl (evar (Ppx_deriving.mangle_type_decl (`Prefix "pp") type_decl)) in let stringprinter = [%expr fun x -> Ppx_deriving_runtime.Format.asprintf "%a" [%e pp_poly_apply] x] in let polymorphize = Ppx_deriving.poly_fun_of_type_decl type_decl in let pp_type = Ppx_deriving.strong_type_of_type @@ pp_type_of_decl type_decl in let show_type = Ppx_deriving.strong_type_of_type @@ show_type_of_decl type_decl in let pp_var = pvar (Ppx_deriving.mangle_type_decl (`Prefix "pp") type_decl) in let show_var = pvar (Ppx_deriving.mangle_type_decl (`Prefix "show") type_decl) in let no_warn_32 = Ppx_deriving.attr_warning [%expr "-32"] in [Vb.mk (Pat.constraint_ pp_var pp_type) (Ppx_deriving.sanitize ~quoter (polymorphize prettyprinter)); Vb.mk ~attrs:[no_warn_32] (Pat.constraint_ show_var show_type) (polymorphize stringprinter);] let impl_args = Deriving.Args.(empty +> arg "with_path" (Ast_pattern.ebool __)) (* TODO: add arg_default to ppxlib? *) let impl_generator = Deriving.Generator.V2.make impl_args (fun ~ctxt (_, type_decls) with_path -> let path = let code_path = Expansion_context.Deriver.code_path ctxt in (* Cannot use main_module_name from code_path because that contains .cppo suffix (via line directives), so it's actually not the module name. *) (* Ppx_deriving.module_from_input_name ported to ppxlib. *) let main_module_path = match Expansion_context.Deriver.input_name ctxt with | "" | "_none_" -> [] | input_name -> match Filename.chop_suffix input_name ".ml" with | exception _ -> (* see https://github.com/ocaml-ppx/ppx_deriving/pull/196 *) [] | path -> [String.capitalize_ascii (Filename.basename path)] in main_module_path @ Code_path.submodule_path code_path in let with_path = match with_path with | Some with_path -> with_path | None -> true (* true by default *) in [Str.value Recursive (List.concat (List.map (str_of_type ~with_path ~path) type_decls))]) let intf_args = Deriving.Args.(empty +> arg "with_path" (Ast_pattern.ebool __)) let intf_generator = Deriving.Generator.V2.make intf_args (fun ~ctxt:_ (_, type_decls) _with_path -> List.concat (List.map sig_of_type type_decls)) let deriving: Deriving.t = Deriving.add deriver ~str_type_decl:impl_generator ~sig_type_decl:intf_generator (* custom extension such that "derive"-prefixed also works *) let derive_extension = Extension.V3.declare "derive.show" Extension.Context.expression Ast_pattern.(ptyp __) (fun ~ctxt -> let loc = Expansion_context.Extension.extension_point_loc ctxt in Ppx_deriving.with_quoter (fun quoter typ -> [%expr fun x -> Ppx_deriving_runtime.Format.asprintf "%a" (fun fmt -> [%e expr_of_typ quoter typ]) x])) let derive_transformation = Driver.register_transformation deriver ~rules:[Context_free.Rule.extension derive_extension] ppx_deriving-6.0.2/src_plugins/std/000077500000000000000000000000001462406363500173505ustar00rootroot00000000000000ppx_deriving-6.0.2/src_plugins/std/dune000066400000000000000000000005241462406363500202270ustar00rootroot00000000000000(library (name ppx_deriving_std) (public_name ppx_deriving.std) (synopsis "Meta-package for all built-in derivers") (libraries ppx_deriving_ord ppx_deriving_map ppx_deriving_iter ppx_deriving_enum ppx_deriving_show ppx_deriving_eq ppx_deriving_make ppx_deriving_create ppx_deriving_fold) (kind ppx_deriver)) ppx_deriving-6.0.2/src_plugins/std/ppx_deriving_std.ml000066400000000000000000000000761462406363500232550ustar00rootroot00000000000000(* dummy module to appease dune and older version of OCaml *) ppx_deriving-6.0.2/src_test/000077500000000000000000000000001462406363500160545ustar00rootroot00000000000000ppx_deriving-6.0.2/src_test/api/000077500000000000000000000000001462406363500166255ustar00rootroot00000000000000ppx_deriving-6.0.2/src_test/api/dune000066400000000000000000000003721462406363500175050ustar00rootroot00000000000000(rule (deps test_api.cppo.ml) (targets test_api.ml) (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets}))) (test (name test_api) (libraries ounit2 compiler-libs.common ppx_deriving.api) (preprocess (pps ppxlib.metaquot))) ppx_deriving-6.0.2/src_test/api/test_api.cppo.ml000066400000000000000000000013161462406363500217300ustar00rootroot00000000000000open OUnit2 let string_of_tyvar tyvar = tyvar.Location.txt let test_free_vars ctxt = let loc = !Ast_helper.default_loc in let free_vars = Ppx_deriving.free_vars_in_core_type in let (!!) li = List.map string_of_tyvar li in let printer li = List.map (Printf.sprintf "%S") li |> String.concat ", " in assert_equal ~printer !!(free_vars [%type: int]) []; assert_equal ~printer !!(free_vars [%type: 'a option]) ["a"]; assert_equal ~printer !!(free_vars [%type: ('a, 'b) result]) ["a"; "b"]; assert_equal ~printer !!(free_vars [%type: ('a, 'b * 'a) result]) ["a"; "b"]; () let suite = "Test API" >::: [ "test_free_vars" >:: test_free_vars; ] let () = run_test_tt_main suite ppx_deriving-6.0.2/src_test/create/000077500000000000000000000000001462406363500173175ustar00rootroot00000000000000ppx_deriving-6.0.2/src_test/create/dune000066400000000000000000000002071462406363500201740ustar00rootroot00000000000000(test (name test_deriving_create) (libraries ounit2 ppx_deriving.runtime) (preprocess (pps ppx_deriving.create ppx_deriving.show))) ppx_deriving-6.0.2/src_test/create/test_deriving_create.ml000066400000000000000000000030311462406363500240370ustar00rootroot00000000000000open OUnit2 module M : sig type a = { a1 : int option; a2 : int list; a3 : int [@default 42]; a4s : (int * int list) [@split]; a5 : int; } [@@deriving show, create] type b = { b1 : int option; b2 : int list; b3 : int [@default 42]; b4s : (int * int list) [@split]; b5 : int [@main]; } [@@deriving show, create] end = struct type a = { a1 : int option; a2 : int list; a3 : int [@default 42]; a4s : (int * int list) [@split]; a5 : int; } [@@deriving show, create] type b = { b1 : int option; b2 : int list; b3 : int [@default 42]; b4s : (int * int list) [@split]; b5 : int [@main]; } [@@deriving show, create] end let test_no_main ctxt = assert_equal ~printer:M.show_a { M.a1 = None; a2 = []; a3 = 42; a4s = 2, []; a5 = 1 } (M.create_a ~a4:2 ~a5:1 ()); assert_equal ~printer:M.show_a { M.a1 = Some 1; a2 = [2]; a3 = 3; a4s = 4, [5]; a5 = 6 } (M.create_a ~a1:1 ~a2:[2] ~a3:3 ~a4:4 ~a4s:[5] ~a5:6 ()) let test_main ctxt = assert_equal ~printer:M.show_b { M.b1 = None; b2 = []; b3 = 42; b4s = 2, []; b5 = 1 } (M.create_b ~b4:2 1); assert_equal ~printer:M.show_b { M.b1 = Some 1; b2 = [2]; b3 = 3; b4s = 4, [5]; b5 = 6 } (M.create_b ~b1:1 ~b2:[2] ~b3:3 ~b4:4 ~b4s:[5] 6) let suite = "Test deriving(create)" >::: [ "test_no_main" >:: test_no_main; "test_main" >:: test_main; ] let _ = run_test_tt_main suite ppx_deriving-6.0.2/src_test/deriving/000077500000000000000000000000001462406363500176635ustar00rootroot00000000000000ppx_deriving-6.0.2/src_test/deriving/dune000066400000000000000000000002421462406363500205370ustar00rootroot00000000000000(test (name test_ppx_deriving) (libraries ounit2 compiler-libs.common ppx_deriving.api) (preprocess (pps ppx_deriving.ord ppx_deriving.show ppx_deriving.eq))) ppx_deriving-6.0.2/src_test/deriving/test_ppx_deriving.ml000066400000000000000000000020161462406363500237510ustar00rootroot00000000000000open OUnit2 let test_inline ctxt = let sort = List.sort [%derive.ord: int * int] in assert_equal ~printer:[%derive.show: (int * int) list] [(1,1);(2,0);(3,5)] (sort [(2,0);(3,5);(1,1)]) let test_inline_shorthand ctxt = assert_equal ~printer:(fun x -> x) "[(1, 1); (2, 0)]" ([%show: (int * int) list] [(1,1); (2,0)]) (* TODO: optional is incompatible with ppxlib derivers: https://github.com/ocaml-ppx/ppx_deriving/issues/247 *) (* type optional_deriver = string [@@deriving missing { optional = true }] *) type prefix = { field : int [@deriving.eq.compare fun _ _ -> true] } [@@deriving eq] let test_prefix ctxt = assert_equal true (equal_prefix {field=1} {field=2}) let test_hash_variant ctxt = ["a"; "b"; "c"; "Dd"] |> List.iter (fun x -> assert_equal (Btype.hash_variant x) (Ppx_deriving.hash_variant x)) let suite = "Test ppx_deriving" >::: [ "test_inline" >:: test_inline; "test_inline_shorthand" >:: test_inline_shorthand; ] let _ = run_test_tt_main suite ppx_deriving-6.0.2/src_test/enum/000077500000000000000000000000001462406363500170205ustar00rootroot00000000000000ppx_deriving-6.0.2/src_test/enum/dune000066400000000000000000000002031462406363500176710ustar00rootroot00000000000000(test (name test_deriving_enum) (libraries ounit2 ppx_deriving.runtime) (preprocess (pps ppx_deriving.enum ppx_deriving.show))) ppx_deriving-6.0.2/src_test/enum/test_deriving_enum.ml000066400000000000000000000034451462406363500232520ustar00rootroot00000000000000open OUnit2 let get o = match o with Some v -> v | None -> assert false type va = Aa | Ba | Ca [@@deriving enum, show] let test_auto ctxt = assert_equal ~printer:string_of_int 0 (va_to_enum Aa); assert_equal ~printer:string_of_int 1 (va_to_enum Ba); assert_equal ~printer:string_of_int 2 (va_to_enum Ca); assert_equal ~printer:show_va Aa (get (va_of_enum 0)); assert_equal ~printer:show_va Ba (get (va_of_enum 1)); assert_equal ~printer:show_va Ca (get (va_of_enum 2)); assert_equal ~printer:string_of_int 0 min_va; assert_equal ~printer:string_of_int 2 max_va type vm = Am [@value 1] | Bm [@value 3] | Cm [@@deriving enum, show] let test_manual ctxt = assert_equal ~printer:string_of_int 1 (vm_to_enum Am); assert_equal ~printer:string_of_int 3 (vm_to_enum Bm); assert_equal ~printer:string_of_int 4 (vm_to_enum Cm); assert_equal ~printer:show_vm Am (get (vm_of_enum 1)); assert_equal ~printer:show_vm Bm (get (vm_of_enum 3)); assert_equal ~printer:show_vm Cm (get (vm_of_enum 4)); assert_equal ~printer:string_of_int 1 min_vm; assert_equal ~printer:string_of_int 4 max_vm type pv = [ `A | `B | `C ] [@@deriving enum, show] let test_poly ctxt = assert_equal ~printer:string_of_int 0 (pv_to_enum `A); assert_equal ~printer:string_of_int 1 (pv_to_enum `B); assert_equal ~printer:string_of_int 2 (pv_to_enum `C); assert_equal ~printer:show_pv `A (get (pv_of_enum 0)); assert_equal ~printer:show_pv `B (get (pv_of_enum 1)); assert_equal ~printer:show_pv `C (get (pv_of_enum 2)); assert_equal ~printer:string_of_int 0 min_pv; assert_equal ~printer:string_of_int 2 max_pv let suite = "Test deriving(enum)" >::: [ "test_auto" >:: test_auto; "test_manual" >:: test_manual; "test_poly" >:: test_poly; ] ppx_deriving-6.0.2/src_test/eq/000077500000000000000000000000001462406363500164615ustar00rootroot00000000000000ppx_deriving-6.0.2/src_test/eq/dune000066400000000000000000000004231462406363500173360ustar00rootroot00000000000000(rule (deps test_deriving_eq.cppo.ml) (targets test_deriving_eq.ml) (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets}))) (test (name test_deriving_eq) (libraries ounit2 ppx_deriving.runtime) (preprocess (pps ppx_deriving.eq ppx_deriving.show))) ppx_deriving-6.0.2/src_test/eq/test_deriving_eq.cppo.ml000066400000000000000000000121111462406363500233020ustar00rootroot00000000000000open OUnit2 (* Mostly it is sufficient to test that the derived code compiles. *) let printer = string_of_bool type a1 = int [@@deriving eq] type a2 = int32 [@@deriving eq] type a3 = int64 [@@deriving eq] type a4 = nativeint [@@deriving eq] type a5 = float [@@deriving eq] type a6 = bool [@@deriving eq] type a7 = char [@@deriving eq] type a8 = string [@@deriving eq] type a9 = bytes [@@deriving eq] type r1 = int ref [@@deriving eq] type r2 = int Stdlib.ref [@@deriving eq] type l = int list [@@deriving eq] type a = int array [@@deriving eq] type o = int option [@@deriving eq] type y = int lazy_t [@@deriving eq] let test_simple ctxt = assert_equal ~printer true (equal_a1 1 1); assert_equal ~printer false (equal_a1 1 2) let test_arr ctxt = assert_equal ~printer true (equal_a [||] [||]); assert_equal ~printer true (equal_a [|1|] [|1|]); assert_equal ~printer false (equal_a [||] [|1|]); assert_equal ~printer false (equal_a [|2|] [|1|]) let test_ref1 ctxt = assert_equal ~printer true (equal_r1 (ref 0) (ref 0)) let test_ref2 ctxt = assert_equal ~printer true (equal_r2 (ref 0) (ref 0)) type v = Foo | Bar of int * string | Baz of string [@@deriving eq] type rv = RFoo | RBar of { x: int; y: string; } [@@deriving eq] type pv1 = [ `Foo | `Bar of int * string ] [@@deriving eq] type pv2 = [ `Baz | pv1 ] [@@deriving eq] type ty = int * string [@@deriving eq] type re = { f1 : int; f2 : string; } [@@deriving eq] module M : sig type t = int [@@deriving eq] end = struct type t = int [@@deriving eq] end type z = M.t [@@deriving eq] type file = { name : string; perm : int [@equal (<>)]; } [@@deriving eq] let test_custom ctxt = assert_equal ~printer false (equal_file { name = ""; perm = 1 } { name = ""; perm = 1 }); assert_equal ~printer true (equal_file { name = ""; perm = 1 } { name = ""; perm = 2 }) type 'a pt = { v : 'a } [@@deriving eq] let test_placeholder ctxt = assert_equal ~printer true ([%eq: _] 1 2) type mrec_variant = | MrecFoo of string | MrecBar of int and mrec_variant_list = mrec_variant list [@@deriving eq] let test_mrec ctxt = assert_equal ~printer true (equal_mrec_variant_list [MrecFoo "foo"; MrecBar 1] [MrecFoo "foo"; MrecBar 1]); assert_equal ~printer false (equal_mrec_variant_list [MrecFoo "foo"; MrecBar 1] [MrecFoo "bar"; MrecBar 1]) type e = Bool of be | Plus of e * e | IfE of (be, e) if_e | Unit and be = True | False | And of be * be | IfB of (be, be) if_e and ('cond, 'a) if_e = 'cond * 'a * 'a [@@deriving eq] let test_mut_rec ctxt = let e1 = IfE (And (False, True), Unit, Plus (Unit, Unit)) in let e2 = Plus (Unit, Bool False) in assert_equal ~printer true (equal_e e1 e1); assert_equal ~printer true (equal_e e2 e2); assert_equal ~printer false (equal_e e1 e2); assert_equal ~printer false (equal_e e2 e1) type es = | ESBool of (bool [@nobuiltin]) | ESString of (string [@nobuiltin]) and bool = | Bfoo of int * ((int -> int) [@equal fun _ _ -> true]) and string = | Sfoo of (String.t [@equal (=)]) * ((int -> int) [@equal fun _ _ -> true]) [@@deriving eq] let test_std_shadowing ctxt = let e1 = ESBool (Bfoo (1, (+) 1)) in let e2 = ESString (Sfoo ("lalala", (+) 3)) in assert_equal ~printer false (equal_es e1 e2); assert_equal ~printer false (equal_es e2 e1); assert_equal ~printer true (equal_es e1 e1); assert_equal ~printer true (equal_es e2 e2) type poly_app = float poly_abs and 'a poly_abs = 'a [@@deriving eq] let test_poly_app ctxt = assert_equal ~printer true (equal_poly_app 1.0 1.0); assert_equal ~printer false (equal_poly_app 1.0 2.0) type poly_app_custom = float poly_abs_custom [@equal equal_poly_abs_custom (=)] and 'a poly_abs_custom = 'a [@@deriving eq] module List = struct type 'a t = [`Cons of 'a | `Nil] [@@deriving eq] end type 'a std_clash = 'a List.t option [@@deriving eq] let test_result ctxt = let eq = [%eq: (string, int) result] in assert_equal ~printer true (eq (Ok "ttt") (Ok "ttt")); assert_equal ~printer false (eq (Ok "123") (Error 123)); assert_equal ~printer false (eq (Error 123) (Error 0)) let test_result_result ctxt = let eq = [%eq: (string, int) result] in assert_equal ~printer true (eq (Ok "ttt") (Ok "ttt")); assert_equal ~printer false (eq (Ok "123") (Error 123)); assert_equal ~printer false (eq (Error 123) (Error 0)) let suite = "Test deriving(eq)" >::: [ "test_simple" >:: test_simple; "test_array" >:: test_arr; "test_ref1" >:: test_ref1; "test_ref2" >:: test_ref2; "test_custom" >:: test_custom; "test_placeholder" >:: test_placeholder; "test_mrec" >:: test_mrec; "test_mut_rec" >:: test_mut_rec; "test_std_shadowing" >:: test_std_shadowing; "test_poly_app" >:: test_poly_app; "test_result" >:: test_result; "test_result_result" >:: test_result_result; ] let _ = run_test_tt_main suite ppx_deriving-6.0.2/src_test/fold/000077500000000000000000000000001462406363500170005ustar00rootroot00000000000000ppx_deriving-6.0.2/src_test/fold/dune000066400000000000000000000004111462406363500176520ustar00rootroot00000000000000(rule (deps test_deriving_fold.cppo.ml) (targets test_deriving_fold.ml) (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets}))) (test (name test_deriving_fold) (libraries ounit2 ppx_deriving.runtime) (preprocess (pps ppx_deriving.fold))) ppx_deriving-6.0.2/src_test/fold/test_deriving_fold.cppo.ml000066400000000000000000000023661462406363500241530ustar00rootroot00000000000000open OUnit2 type 'a btree = Node of 'a btree * 'a * 'a btree | Leaf [@@deriving fold] let test_btree ctxt = let btree = (Node (Node (Leaf, 3, Leaf), 1, Node (Leaf, 2, Leaf))) in assert_equal ~printer:string_of_int 6 (fold_btree (+) 0 btree) type 'a reflist = 'a Stdlib.ref list [@@deriving fold] let test_reflist ctxt = let reflist = [ ref 3 ; ref 2 ; ref 1 ] in assert_equal ~printer:string_of_int 6 (fold_reflist (+) 0 reflist) type 'a btreer = Node of { lft: 'a btree; elt: 'a; rgt: 'a btree } | Leaf [@@deriving fold] type 'a ty = 'a * int list [@@deriving fold] type ('a, 'b) res = ('a, 'b) result [@@deriving fold] let test_result ctxt = let f = fold_res (+) (-) in assert_equal ~printer:string_of_int 1 (f 0 (Ok 1)); assert_equal ~printer:string_of_int (-1) (f 0 (Error 1)) type ('a, 'b) result_res = ('a, 'b) result [@@deriving fold] let test_result_result ctxt = let f = fold_result_res (+) (-) in assert_equal ~printer:string_of_int 1 (f 0 (Ok 1)); assert_equal ~printer:string_of_int (-1) (f 0 (Error 1)) let suite = "Test deriving(fold)" >::: [ "test_btree" >:: test_btree; "test_result" >:: test_result; "test_result_result" >:: test_result_result; "test_reflist" >:: test_reflist; ] let _ = run_test_tt_main suite ppx_deriving-6.0.2/src_test/iter/000077500000000000000000000000001462406363500170175ustar00rootroot00000000000000ppx_deriving-6.0.2/src_test/iter/dune000066400000000000000000000004331462406363500176750ustar00rootroot00000000000000(rule (deps test_deriving_iter.cppo.ml) (targets test_deriving_iter.ml) (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets}))) (test (name test_deriving_iter) (libraries ounit2 ppx_deriving.runtime) (preprocess (pps ppx_deriving.iter ppx_deriving.show))) ppx_deriving-6.0.2/src_test/iter/test_deriving_iter.cppo.ml000066400000000000000000000036161462406363500242100ustar00rootroot00000000000000open OUnit2 module T : sig type 'a btree = Node of 'a btree * 'a * 'a btree | Leaf [@@deriving iter] (* test for #82: iter_record : ('a -> unit) -> ('b -> unit) -> ('a,'b) record -> unit) *) type ('a,'b) record = { a : 'a; b : 'b } [@@deriving iter] type 'a reflist = 'a Stdlib.ref list [@@deriving iter] end = struct type 'a btree = Node of 'a btree * 'a * 'a btree | Leaf [@@deriving iter] type ('a,'b) record = { a : 'a; b : 'b } [@@deriving iter] type 'a reflist = 'a Stdlib.ref list [@@deriving iter] end open T let test_btree ctxt = let lst = ref [] in iter_btree (fun x -> lst := x :: !lst) (Node (Node (Leaf, 0, Leaf), 1, Node (Leaf, 2, Leaf))); assert_equal [2;1;0] !lst let test_record ctxt = let lst : string list ref = ref [] in lst := []; iter_record (fun a -> lst := string_of_int a :: !lst) (fun b -> lst := string_of_float b :: ! lst) {a=1; b=1.2}; assert_equal ["1.2"; "1"] !lst; lst := []; iter_record (fun a -> lst := string_of_int (a+1) :: !lst) (fun b -> lst := Int64.to_string b :: ! lst) {a=3; b=4L}; assert_equal ["4"; "4"] !lst let test_reflist ctxt = let lst = ref [] in iter_reflist (fun x -> lst := x :: !lst) [ ref 0 ; ref 1 ; ref 2 ] ; assert_equal [2;1;0] !lst type 'a btreer = Node of { lft: 'a btree; elt: 'a; rgt: 'a btree } | Leaf [@@deriving iter] type 'a ty = 'a * int list [@@deriving iter] type 'a res0 = ('a, char) result [@@deriving iter] let test_iter_res ctxt = let has_ok = ref false in iter_res0 (fun _ -> has_ok := true) (Ok "xxx"); assert_bool "set ok" !has_ok; iter_res0 (fun _ -> has_ok := false) (Error 'c'); assert_bool "set ok" !has_ok let suite = "Test deriving(iter)" >::: [ "test_btree" >:: test_btree; "test_record" >:: test_record; "test_reflist" >:: test_reflist; "test_iter_res" >:: test_iter_res ] let _ = run_test_tt_main suite ppx_deriving-6.0.2/src_test/make/000077500000000000000000000000001462406363500167715ustar00rootroot00000000000000ppx_deriving-6.0.2/src_test/make/dune000066400000000000000000000002031462406363500176420ustar00rootroot00000000000000(test (name test_deriving_make) (libraries ounit2 ppx_deriving.runtime) (preprocess (pps ppx_deriving.make ppx_deriving.show))) ppx_deriving-6.0.2/src_test/make/test_deriving_make.ml000066400000000000000000000057131462406363500231740ustar00rootroot00000000000000open OUnit2 module M : sig type a = { a1 : int option; a2 : int list; a3 : int [@default 42]; a4s : (int * int list) [@split]; a5 : int; } [@@deriving show, make] type b = { b1 : int option; b2 : int list; b3 : int [@default 42]; b4s : (int * int list) [@split]; b5 : int [@main]; } [@@deriving show, make] type c = { c1 : int; c2 : string } [@@deriving show, make] type principle_recursive_type = { prt1 : int ; prt2 : secondary_recursive_type } [@@deriving show, make] and secondary_recursive_type = string [@@deriving show] end = struct type a = { a1 : int option; a2 : int list; a3 : int [@default 42]; a4s : (int * int list) [@split]; a5 : int; } [@@deriving show, make] type b = { b1 : int option; b2 : int list; b3 : int [@default 42]; b4s : (int * int list) [@split]; b5 : int [@main]; } [@@deriving show, make] type c = { c1 : int; c2 : string } [@@deriving show, make] (* Generate make for a record that is part of a mutually recursive type declaration. Generation should succeed, and not try to generate `make` for non-annotated types. Regression test for https://github.com/ocaml-ppx/ppx_deriving/issues/272 *) type principle_recursive_type = { prt1 : int ; prt2 : secondary_recursive_type } [@@deriving show, make] and secondary_recursive_type = string [@@deriving show] end (* This module is here to test that the ordering of the arguments match the order of the record fields declarations. *) module M2 : sig type t = { first : int ; second : int } val make : first: int -> second: int -> t end = struct type t = { first : int ; second : int } [@@deriving make] end let test_no_main ctxt = assert_equal ~printer:M.show_a { M.a1 = None; a2 = []; a3 = 42; a4s = 2, []; a5 = 1 } (M.make_a ~a4:2 ~a5:1 ()); assert_equal ~printer:M.show_a { M.a1 = Some 1; a2 = [2]; a3 = 3; a4s = 4, [5]; a5 = 6 } (M.make_a ~a1:1 ~a2:[2] ~a3:3 ~a4:4 ~a4s:[5] ~a5:6 ()) let test_main ctxt = assert_equal ~printer:M.show_b { M.b1 = None; b2 = []; b3 = 42; b4s = 2, []; b5 = 1 } (M.make_b ~b4:2 1); assert_equal ~printer:M.show_b { M.b1 = Some 1; b2 = [2]; b3 = 3; b4s = 4, [5]; b5 = 6 } (M.make_b ~b1:1 ~b2:[2] ~b3:3 ~b4:4 ~b4s:[5] 6) let test_no_unit ctxt = assert_equal ~printer:M.show_c { M.c1 = 0; M.c2 = "" } (M.make_c ~c1:0 ~c2:"") let test_recursive_types ctxt = assert_equal ~printer:M.show_principle_recursive_type { M.prt1 = 0; M.prt2 = "" } (M.make_principle_recursive_type ~prt1:0 ~prt2:"") let suite = "Test deriving(make)" >::: [ "test_no_main" >:: test_no_main; "test_main" >:: test_main; "test_no_unit" >:: test_no_unit; "test_recursive_types" >:: test_recursive_types; ] let _ = run_test_tt_main suite ppx_deriving-6.0.2/src_test/map/000077500000000000000000000000001462406363500166315ustar00rootroot00000000000000ppx_deriving-6.0.2/src_test/map/dune000066400000000000000000000004271462406363500175120ustar00rootroot00000000000000(rule (deps test_deriving_map.cppo.ml) (targets test_deriving_map.ml) (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets}))) (test (name test_deriving_map) (libraries ounit2 ppx_deriving.runtime) (preprocess (pps ppx_deriving.map ppx_deriving.show))) ppx_deriving-6.0.2/src_test/map/test_deriving_map.cppo.ml000066400000000000000000000147221462406363500236340ustar00rootroot00000000000000open OUnit2 module T : sig type 'a btree = Node of 'a btree * 'a * 'a btree | Leaf [@@deriving map, show] type 'a btreer = Noder of { lft: 'a btree; elt: 'a; rgt: 'a btree } | Leafr [@@deriving map] type 'a ty = 'a * int list [@@deriving map] type var0 = A0 of int [@@deriving map,show] type 'a var1 = A1 of 'a [@@deriving map,show] type 'a var2 = A2 of 'a | B2 of int [@@deriving map,show] type ('a,'b) var3 = A3 of 'a | B3 of bool | C3 of 'b * ('a,'b) var3 [@@deriving map,show] type record0 = { a0 : int } [@@deriving map,show] type 'a record1 = { a1 : 'a } [@@deriving map,show] type 'a record2 = { a2 : 'a; b2 : int } [@@deriving map,show] type ('a,'b) record3 = { a3 : 'a; b3 : bool; c3 : 'b } [@@deriving map,show] type ('a,'b) pvar0 = [ `A of 'a | `B of ('a,'b) pvar0 | `C of 'b ] [@@deriving map,show] type ('a,'b,'c) pvar1 = [ ('a,'b) pvar0 | `D of 'c | `E of ('b,'c) pvar0 ] [@@deriving map,show] type pvar2 = [ `F | `G ] [@@deriving map,show] type ('a,'b,'c) pvar3 = [ pvar2 | ('a,'b,'c) pvar1 ] [@@deriving map,show] end = struct type 'a btree = Node of 'a btree * 'a * 'a btree | Leaf [@@deriving map, show] type 'a btreer = Noder of { lft: 'a btree; elt: 'a; rgt: 'a btree } | Leafr [@@deriving map] type 'a ty = 'a * int list [@@deriving map] (* variants and records with mixtures of poly/nonpoly fields *) type var0 = A0 of int [@@deriving map,show] type 'a var1 = A1 of 'a [@@deriving map,show] type 'a var2 = A2 of 'a | B2 of int [@@deriving map,show] type ('a,'b) var3 = A3 of 'a | B3 of bool | C3 of 'b * ('a,'b) var3 [@@deriving map,show] type record0 = { a0 : int } [@@deriving map,show] type 'a record1 = { a1 : 'a } [@@deriving map,show] type 'a record2 = { a2 : 'a; b2 : int } [@@deriving map,show] type ('a,'b) record3 = { a3 : 'a; b3 : bool; c3 : 'b } [@@deriving map,show] type ('a,'b) pvar0 = [ `A of 'a | `B of ('a,'b) pvar0 | `C of 'b ] [@@deriving map,show] type ('a,'b,'c) pvar1 = [ ('a,'b) pvar0 | `D of 'c | `E of ('b,'c) pvar0 ] [@@deriving map,show] type pvar2 = [ `F | `G ] [@@deriving map,show] type ('a,'b,'c) pvar3 = [ pvar2 | ('a,'b,'c) pvar1 ] [@@deriving map,show] end open T let fmt_chr fmt = Format.fprintf fmt "%c" let fmt_flt fmt = Format.fprintf fmt "%f" let fmt_int fmt = Format.fprintf fmt "%d" let fmt_str fmt = Format.fprintf fmt "%s" let test_btree ctxt = let btree = (Node (Node (Leaf, 0, Leaf), 1, Node (Leaf, 2, Leaf))) in let btree' = map_btree (fun x -> x + 1) btree in assert_equal ~printer:(show_btree fmt_int) (Node (Node (Leaf, 1, Leaf), 2, Node (Leaf, 3, Leaf))) btree' (* tests for #81 and #82 - allow non-poly fields in records and variants and provide more general type for map signature: ('a -> 'x) -> ... -> ('a,...) t -> ('x,...) t *) let test_var0 ctxt = assert_equal ~printer:show_var0 (A0 10) (map_var0 (A0 10)) let test_var1 ctxt = assert_equal ~printer:(show_var1 fmt_int) (A1 1) (map_var1 ((+)1) (A1 0)); assert_equal ~printer:(show_var1 fmt_str) (A1 "2") (map_var1 string_of_int (A1 2)) let test_var2 ctxt = assert_equal ~printer:(show_var2 fmt_int) (B2 7) (map_var2 ((+)1) (B2 7)); assert_equal ~printer:(show_var2 fmt_int) (A2 5) (map_var2 ((+)1) (A2 4)); assert_equal ~printer:(show_var2 fmt_int) (A2 5) (map_var2 int_of_float (A2 5.)) let test_var3 ctxt = let show,map = show_var3 fmt_int fmt_str, map_var3 ((+)1) String.uppercase_ascii in assert_equal ~printer:show (A3 2) (map (A3 1)); assert_equal ~printer:show (B3 false) (map (B3 false)); assert_equal ~printer:show (C3("ABC", A3 3)) (map (C3("abc", A3 2))); assert_equal ~printer:show (C3("XYZ", B3 true)) (map (C3("xyz", B3 true))); let show,map = show_var3 fmt_int fmt_flt, map_var3 Char.code float_of_int in assert_equal ~printer:show (A3 97) (map (A3 'a')); assert_equal ~printer:show (B3 false) (map (B3 false)); assert_equal ~printer:show (C3(4., A3 98)) (map (C3(4, A3 'b'))); assert_equal ~printer:show (C3(5., B3 true)) (map (C3(5, B3 true))) let test_record0 ctxt = assert_equal ~printer:show_record0 {a0=10} (map_record0 {a0=10}) let test_record1 ctxt = assert_equal ~printer:(show_record1 fmt_int) {a1=1} (map_record1 ((+)1) {a1=0}); assert_equal ~printer:(show_record1 fmt_str) {a1="2"} (map_record1 string_of_int {a1=2}) let test_record2 ctxt = assert_equal ~printer:(show_record2 fmt_int) {a2=5;b2=7} (map_record2 ((+)1) {a2=4;b2=7}); assert_equal ~printer:(show_record2 fmt_int) {a2=5;b2=0} (map_record2 int_of_float {a2=5.;b2=0}) let test_record3 ctxt = let show,map = show_record3 fmt_int fmt_str, map_record3 ((+)1) String.uppercase_ascii in assert_equal ~printer:show {a3=5;b3=false;c3="ABC"} (map {a3=4;b3=false;c3="abc"}); let show,map = show_record3 fmt_int fmt_flt, map_record3 Char.code float_of_int in assert_equal ~printer:show {a3=97;b3=false;c3=4.} (map {a3='a';b3=false;c3=4}) let test_pvar3 ctxt = let show,map = show_pvar3 fmt_str fmt_int fmt_int, map_pvar3 string_of_int Char.code int_of_string in assert_equal ~printer:show (`A "1") (map (`A 1)); assert_equal ~printer:show (`B (`A "1")) (map (`B (`A 1))); assert_equal ~printer:show (`B (`C 97)) (map (`B (`C 'a'))); assert_equal ~printer:show (`D 1) (map (`D "1")); assert_equal ~printer:show (`E (`A 97)) (map (`E (`A 'a'))); assert_equal ~printer:show (`E (`C 9)) (map (`E (`C "9"))); assert_equal ~printer:show `F (map `F); assert_equal ~printer:show `G (map `G) type 'a result0 = ('a, bool) result [@@deriving show,map] let test_map_result ctxt = let f = map_result0 succ in let printer = show_result0 fmt_int in assert_equal ~printer (Ok 10) (f (Ok 9)); assert_equal ~printer (Error true) (f (Error true)) type 'a result_result0 = ('a, bool) result [@@deriving show,map] let test_map_result_result ctxt = let f = map_result_result0 succ in let printer = show_result_result0 fmt_int in assert_equal ~printer (Ok 10) (f (Ok 9)); assert_equal ~printer (Error true) (f (Error true)) let suite = "Test deriving(map)" >::: [ "test_btree" >:: test_btree; "test_var0" >:: test_var0; "test_var1" >:: test_var1; "test_var2" >:: test_var2; "test_var3" >:: test_var3; "test_record0" >:: test_record0; "test_record1" >:: test_record1; "test_record2" >:: test_record2; "test_record3" >:: test_record3; "test_pvar3" >:: test_pvar3; "test_map_result" >:: test_map_result; "test_map_result_result" >:: test_map_result_result; ] let _ = run_test_tt_main suite ppx_deriving-6.0.2/src_test/ord/000077500000000000000000000000001462406363500166405ustar00rootroot00000000000000ppx_deriving-6.0.2/src_test/ord/dune000066400000000000000000000004051462406363500175150ustar00rootroot00000000000000(rule (deps test_deriving_ord.cppo.ml) (targets test_deriving_ord.ml) (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets}))) (test (name test_deriving_ord) (libraries ounit2 ppx_deriving.runtime) (preprocess (pps ppx_deriving.ord))) ppx_deriving-6.0.2/src_test/ord/test_deriving_ord.cppo.ml000066400000000000000000000147051462406363500236530ustar00rootroot00000000000000open OUnit2 (* Mostly it is sufficient to test that the derived code compiles. *) let printer = string_of_int type a1 = int [@@deriving ord] type a2 = int32 [@@deriving ord] type a3 = int64 [@@deriving ord] type a4 = nativeint [@@deriving ord] type a5 = float [@@deriving ord] type a6 = bool [@@deriving ord] type a7 = char [@@deriving ord] type a8 = string [@@deriving ord] type a9 = bytes [@@deriving ord] type l = int list [@@deriving ord] type a = int array [@@deriving ord] type o = int option [@@deriving ord] type y = int lazy_t [@@deriving ord] let test_simple ctxt = assert_equal ~printer (1) (compare_a1 1 0); assert_equal ~printer (0) (compare_a1 1 1); assert_equal ~printer (-1) (compare_a1 1 2) type v = Foo | Bar of int * string | Baz of string [@@deriving ord] let test_variant ctxt = assert_equal ~printer (1) (compare_v (Baz "b") (Baz "a")); assert_equal ~printer (1) (compare_v (Bar (1, "")) Foo); assert_equal ~printer (1) (compare_v (Baz "") (Bar (1, ""))); assert_equal ~printer (-1) (compare_v Foo (Baz "")) type rv = RFoo | RBar of { x: int; y: string; } [@@deriving ord] type pv1 = [ `Foo | `Bar of int * string ] [@@deriving ord] type pv2 = [ `Baz | pv1 ] [@@deriving ord] type ty = int * string [@@deriving ord] let test_complex ctxt = assert_equal ~printer (0) (compare_ty (0, "a") (0, "a")); assert_equal ~printer (1) (compare_ty (1, "a") (0, "a")); assert_equal ~printer (-1) (compare_ty (0, "a") (1, "a")); assert_equal ~printer (-1) (compare_ty (0, "a") (0, "b")); assert_equal ~printer (1) (compare_ty (0, "b") (0, "a")) type re = { f1 : int; f2 : string; } [@@deriving ord] module M : sig type t = int [@@deriving ord] end = struct type t = int [@@deriving ord] end type z = M.t [@@deriving ord] type file = { name : string; perm : int [@compare fun a b -> compare b a]; } [@@deriving ord] let test_custom ctxt = assert_equal ~printer (-1) (compare_file { name = ""; perm = 2 } { name = ""; perm = 1 }); assert_equal ~printer (1) (compare_file { name = ""; perm = 1 } { name = ""; perm = 2 }) type 'a pt = { v : 'a } [@@deriving ord] let test_placeholder ctxt = assert_equal ~printer 0 ([%ord: _] 1 2) type mrec_variant = | MrecFoo of string | MrecBar of int and mrec_variant_list = mrec_variant list [@@deriving ord] let test_mrec ctxt = assert_equal ~printer (0) (compare_mrec_variant_list [MrecFoo "foo"; MrecBar 1;] [MrecFoo "foo"; MrecBar 1;]); assert_equal ~printer (-1) (compare_mrec_variant_list [MrecFoo "foo"; MrecBar 1;] [MrecFoo "foo"; MrecBar 2;]); assert_equal ~printer (1) (compare_mrec_variant_list [MrecFoo "foo"; MrecBar 2;] [MrecFoo "foo"; MrecBar 1;]) type e = Bool of be | Plus of e * e | IfE of (be, e) if_e and be = True | False | And of be * be | IfB of (be, be) if_e and ('cond, 'a) if_e = 'cond * 'a * 'a [@@deriving ord] let test_mrec2 ctxt = let ce1 = Bool (IfB (True, False, True)) in let ce2 = Bool (IfB (True, False, False)) in assert_equal ~printer (0) (compare_e ce1 ce1); assert_equal ~printer (-1) (compare_e ce1 ce2); assert_equal ~printer (1) (compare_e ce2 ce1) let test_ord_result ctx = let compare_res0 = [%ord: (unit, unit) result] in assert_equal ~printer 0 (compare_res0 (Ok ()) (Ok ())); assert_equal ~printer (-1) (compare_res0 (Ok ()) (Error ())); assert_equal ~printer 1 (compare_res0 (Error ()) (Ok ())) let test_ord_result_result ctx = let compare_res0 = [%ord: (unit, unit) result] in assert_equal ~printer 0 (compare_res0 (Ok ()) (Ok ())); assert_equal ~printer (-1) (compare_res0 (Ok ()) (Error ())); assert_equal ~printer 1 (compare_res0 (Error ()) (Ok ())) type r1 = int ref [@@deriving ord] let test_ref1 ctxt = assert_equal ~printer (-1) (compare_r1 (ref 0) (ref 1)); assert_equal ~printer (0) (compare_r1 (ref 0) (ref 0)); assert_equal ~printer (1) (compare_r1 (ref 1) (ref 0)) type r2 = int Stdlib.ref [@@deriving ord] let test_ref2 ctxt = assert_equal ~printer (-1) (compare_r2 (ref 0) (ref 1)); assert_equal ~printer (0) (compare_r2 (ref 0) (ref 0)); assert_equal ~printer (1) (compare_r2 (ref 1) (ref 0)) type es = | ESBool of bool | ESString of string and bool = | Bfoo of int * ((int -> int) [@compare fun _ _ -> 0]) and string = | Sfoo of String.t * ((int -> int) [@compare fun _ _ -> 0]) [@@deriving ord] let test_std_shadowing ctxt = let e1 = ESBool (Bfoo (1, (+) 1)) in let e2 = ESString (Sfoo ("lalala", (+) 3)) in assert_equal ~printer (-1) (compare_es e1 e2); assert_equal ~printer (1) (compare_es e2 e1); assert_equal ~printer 0 (compare_es e1 e1); assert_equal ~printer 0 (compare_es e2 e2) type poly_app = float poly_abs and 'a poly_abs = 'a [@@deriving ord] let test_poly_app ctxt = assert_equal ~printer 0 (compare_poly_app 1.0 1.0); assert_equal ~printer (-1) (compare_poly_app 1.0 2.0) type poly_app_custom = float poly_abs_custom [@compare compare_poly_abs_custom Stdlib.compare] and 'a poly_abs_custom = 'a [@@deriving ord] module List = struct type 'a t = [`Cons of 'a | `Nil] [@@deriving ord] end type 'a std_clash = 'a List.t option [@@deriving ord] module Warnings = struct module W4 = struct [@@@ocaml.warning "@4"] type t = | A of int | B [@@deriving ord] end end type ab = { a : int; b : int } [@@deriving ord] let test_record_order ctxt = assert_equal ~printer (-1) (compare_ab { a = 1; b = 2; } { a = 2; b = 1; }); assert_equal ~printer (0) (compare_ab { a = 1; b = 2; } { a = 1; b = 2; }); assert_equal ~printer (1) (compare_ab { a = 2; b = 2; } { a = 1; b = 2; }) let suite = "Test deriving(ord)" >::: [ "test_simple" >:: test_simple; "test_variant" >:: test_variant; "test_complex" >:: test_complex; "test_custom" >:: test_custom; "test_placeholder" >:: test_placeholder; "test_mrec" >:: test_mrec; "test_mrec2" >:: test_mrec2; "test_record_order" >:: test_record_order; "test_ref1" >:: test_ref1; "test_ref2" >:: test_ref2; "test_std_shadowing" >:: test_std_shadowing; "test_poly_app" >:: test_poly_app; "test_ord_result" >:: test_ord_result; "test_ord_result_result" >:: test_ord_result_result; ] let _ = run_test_tt_main suite ppx_deriving-6.0.2/src_test/runtime/000077500000000000000000000000001462406363500175375ustar00rootroot00000000000000ppx_deriving-6.0.2/src_test/runtime/dune000066400000000000000000000004071462406363500204160ustar00rootroot00000000000000(rule (deps test_runtime.cppo.ml) (targets test_runtime.ml) (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets}))) (test (name test_runtime) (libraries ounit2 ppx_deriving.runtime) (preprocess (pps ppx_deriving.eq ppx_deriving.show))) ppx_deriving-6.0.2/src_test/runtime/test_runtime.cppo.ml000066400000000000000000000012611462406363500235530ustar00rootroot00000000000000let test_ref_included (x : 'a ref) = (x : 'a Ppx_deriving_runtime.ref) let test_ref_qualified (x : 'a ref) = (x : 'a Ppx_deriving_runtime.Stdlib.ref) let test_backtrace (x : Printexc.raw_backtrace) = (x : Ppx_deriving_runtime.Printexc.raw_backtrace) let test_hashtbl (x : ('a, 'b) Hashtbl.t) = (x : ('a, 'b) Ppx_deriving_runtime.Hashtbl.t) let test_result_qualified (x : ('a, 'b) result) = (x : ('a, 'b) result) #if OCAML_VERSION >= (4, 06, 0) let test_result_included (x : ('a, 'b) result) = (x : ('a, 'b) result) #endif #if OCAML_VERSION >= (4, 07, 0) let test_result_in_stdlib (x : ('a, 'b) Stdlib.result) = (x : ('a, 'b) result) #endif ppx_deriving-6.0.2/src_test/show/000077500000000000000000000000001462406363500170345ustar00rootroot00000000000000ppx_deriving-6.0.2/src_test/show/dune000066400000000000000000000004111462406363500177060ustar00rootroot00000000000000(rule (deps test_deriving_show.cppo.ml) (targets test_deriving_show.ml) (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets}))) (test (name test_deriving_show) (libraries ounit2 ppx_deriving.runtime) (preprocess (pps ppx_deriving.show))) ppx_deriving-6.0.2/src_test/show/test_deriving_show.cppo.ml000066400000000000000000000226421462406363500242420ustar00rootroot00000000000000open OUnit2 let printer = fun x -> x type a1 = int [@@deriving show] type a2 = int32 [@@deriving show] type a3 = int64 [@@deriving show] type a4 = nativeint [@@deriving show] type a5 = float [@@deriving show] type a6 = bool [@@deriving show] type a7 = char [@@deriving show] type a8 = string [@@deriving show] type a9 = bytes [@@deriving show] type r = int ref [@@deriving show] type r2 = int Stdlib.ref [@@deriving show] type r3 = int Stdlib.ref ref [@@deriving show] type l = int list [@@deriving show] type a = int array [@@deriving show] type o = int option [@@deriving show] type f = int -> int [@@deriving show] type y = int lazy_t [@@deriving show] let test_alias ctxt = assert_equal ~printer "1" (show_a1 1); assert_equal ~printer "1l" (show_a2 1l); assert_equal ~printer "1L" (show_a3 1L); assert_equal ~printer "1n" (show_a4 1n); assert_equal ~printer "1." (show_a5 1.); assert_equal ~printer "true" (show_a6 true); assert_equal ~printer "'a'" (show_a7 'a'); assert_equal ~printer "\"foo\"" (show_a8 "foo"); assert_equal ~printer "\"foo\"" (show_a9 (Bytes.of_string "foo")); assert_equal ~printer "ref (1)" (show_r (ref 1)); assert_equal ~printer "ref (1)" (show_r2 (ref 1)); assert_equal ~printer "ref (ref (1))" (show_r3 (ref (ref 1))); assert_equal ~printer "[1; 2; 3]" (show_l [1;2;3]); assert_equal ~printer "[|1; 2; 3|]" (show_a [|1;2;3|]); assert_equal ~printer "(Some 1)" (show_o (Some 1)); assert_equal ~printer "" (show_f (fun x -> x)); let y = lazy (1 + 1) in assert_equal ~printer "" (show_y y); ignore (Lazy.force y); assert_equal ~printer "2" (show_y y) type v = Foo | Bar of int * string | Baz of string [@@deriving show] let test_variant ctxt = assert_equal ~printer "Test_deriving_show.Foo" (show_v Foo); assert_equal ~printer "(Test_deriving_show.Bar (1, \"foo\"))" (show_v (Bar (1, "foo"))); assert_equal ~printer "(Test_deriving_show.Baz \"foo\")" (show_v (Baz "foo")) type rv = RFoo | RBar of { x: int; y: string } | RBaz of { z: string } [@@deriving show] let test_rv_record ctxt = assert_equal ~printer "Test_deriving_show.RFoo" (show_rv RFoo); assert_equal ~printer "Test_deriving_show.RBar {x = 1; y = \"foo\"}" (show_rv (RBar {x=1; y="foo"})); assert_equal ~printer "Test_deriving_show.RBaz {z = \"foo\"}" (show_rv (RBaz {z="foo"})) type vn = Foo of int option [@@deriving show] let test_variant_nest ctxt = assert_equal ~printer "(Test_deriving_show.Foo (Some 1))" (show_vn (Foo (Some 1))) type pv1 = [ `Foo | `Bar of int * string ] [@@deriving show] let test_poly ctxt = assert_equal ~printer "`Foo" (show_pv1 `Foo); assert_equal ~printer "`Bar ((1, \"foo\"))" (show_pv1 (`Bar (1, "foo"))) type pv2 = [ `Baz | pv1 ] [@@deriving show] let test_poly_inherit ctxt = assert_equal ~printer "`Foo" (show_pv2 `Foo); assert_equal ~printer "`Baz" (show_pv2 `Baz) type ty = int * string [@@deriving show] let test_tuple ctxt = assert_equal ~printer "(1, \"foo\")" (show_ty (1, "foo")) type re = { f1 : int; f2 : string; f3 : float [@opaque]; } [@@deriving show] let test_record ctxt = assert_equal ~printer "{ Test_deriving_show.f1 = 1; f2 = \"foo\"; f3 = }" (show_re { f1 = 1; f2 = "foo"; f3 = 1.0 }) type variant = Foo of { f1 : int; f2 : string; f3 : float [@opaque]; } [@@deriving show] let test_variant_record ctxt = assert_equal ~printer "Test_deriving_show.Foo {f1 = 1; f2 = \"foo\"; f3 = }" (show_variant (Foo { f1 = 1; f2 = "foo"; f3 = 1.0 })) module M : sig type t = A [@@deriving show] end = struct type t = A [@@deriving show] end let test_module ctxt = assert_equal ~printer "Test_deriving_show.M.A" (M.show M.A) type z = M.t [@@deriving show] let test_abstr ctxt = assert_equal ~printer "Test_deriving_show.M.A" (show_z M.A) type file = { name : string; perm : int [@printer fun fmt -> Format.fprintf fmt "0o%03o"]; } [@@deriving show] let test_custom ctxt = assert_equal ~printer "{ Test_deriving_show.name = \"dir\"; perm = 0o755 }" (show_file { name = "dir"; perm = 0o755 }) type 'a pt = { v : 'a } [@@deriving show] let test_parametric ctxt = assert_equal ~printer "{ Test_deriving_show.v = 1 }" (show_pt (fun fmt -> Format.fprintf fmt "%d") { v = 1 }) type 'a btree = Node of 'a btree * 'a * 'a btree | Leaf [@@deriving show] module M' = struct type t = M.t = A [@@deriving show] end let test_alias_path ctxt = assert_equal ~printer "M.A" (M'.show M'.A) let print_hi = fun fmt _ -> Format.fprintf fmt "hi!" type polypr = (string [@printer print_hi]) btree [@polyprinter pp_btree] [@@deriving show] let test_polypr ctxt = assert_equal ~printer "(Test_deriving_show.Node (Test_deriving_show.Leaf, hi!,\n\ \ Test_deriving_show.Leaf))" (show_polypr (Node (Leaf, "x", Leaf))) let test_placeholder ctxt = assert_equal ~printer "_" ([%show: _] 1) module rec RecFoo : sig type ('a,'b) t = ('b, 'a) RecBar.t [@@deriving show] end = struct type ('a,'b) t = ('b,'a) RecBar.t [@@deriving show] end and RecBar : sig type ('b, 'a) t = 'b * 'a [@@deriving show] end = struct type ('b,'a) t = 'b * 'a [@@deriving show] end type foo = F of int | B of int bar | C of float bar and 'a bar = { x : 'a ; r : foo } [@@deriving show] let test_mrec ctxt = let e1 = B { x = 12; r = F 16 } in assert_equal ~printer "(Test_deriving_show.B\n { Test_deriving_show.x = 12; r = (Test_deriving_show.F 16) })" (show_foo e1) type i_has_result = I_has of (bool, string) result [@@deriving show] let test_result ctxt = assert_equal ~printer "(Ok 100)" ([%show: (int, bool) result] (Ok 100)); assert_equal ~printer "(Test_deriving_show.I_has (Ok true))" (show_i_has_result (I_has (Ok true))); assert_equal ~printer "(Test_deriving_show.I_has (Error \"err\"))" (show_i_has_result (I_has (Error "err"))) type i_has_result_result = I_has of (bool, string) result [@@deriving show] let test_result_result ctxt = assert_equal ~printer "(Ok 100)" ([%show: (int, bool) result] (Ok 100)); assert_equal ~printer "(Test_deriving_show.I_has (Ok true))" (show_i_has_result_result (I_has (Ok true))); assert_equal ~printer "(Test_deriving_show.I_has (Error \"err\"))" (show_i_has_result_result (I_has (Error "err"))) type es = | ESBool of (bool [@nobuiltin]) | ESString of (string [@nobuiltin]) and bool = | Bfoo of int * (int -> int) and string = | Sfoo of String.t * (int -> int) [@@deriving show] let test_std_shadowing ctxt = let e1 = ESBool (Bfoo (1, (+) 1)) in let e2 = ESString (Sfoo ("lalala", (+) 3)) in assert_equal ~printer "(Test_deriving_show.ESBool (Test_deriving_show.Bfoo (1, )))" (show_es e1); assert_equal ~printer "(Test_deriving_show.ESString (Test_deriving_show.Sfoo (\"lalala\", )))" (show_es e2) type poly_app = float poly_abs and 'a poly_abs = 'a [@@deriving show] let test_poly_app ctxt = assert_equal ~printer "1." (show_poly_app 1.0) module List = struct type 'a t = [`Cons of 'a | `Nil] [@@deriving show] end type 'a std_clash = 'a List.t option [@@deriving show] type variant_printer = | First [@printer fun fmt _ -> Format.pp_print_string fmt "first"] | Second of int [@printer fun fmt i -> fprintf fmt "second: %d" i] | Third | Fourth of int * int [@printer fun fmt (a,b) -> fprintf fmt "fourth: %d %d" a b] [@@deriving show] let test_variant_printer ctxt = assert_equal ~printer "first" (show_variant_printer First); assert_equal ~printer "second: 42" (show_variant_printer (Second 42)); assert_equal ~printer "Test_deriving_show.Third" (show_variant_printer Third); assert_equal ~printer "fourth: 8 4" (show_variant_printer (Fourth(8,4))) type no_full = NoFull of int [@@deriving show { with_path = false }] type with_full = WithFull of int [@@deriving show { with_path = true }] module WithFull = struct type t = A of int [@@deriving show ] end let test_paths_printer ctxt = assert_equal ~printer "(NoFull 1)" (show_no_full (NoFull 1)); assert_equal ~printer "(Test_deriving_show.WithFull 1)" (show_with_full (WithFull 1)); assert_equal ~printer "(Test_deriving_show.WithFull.A 1)" (WithFull.show (WithFull.A 1)); () let suite = "Test deriving(show)" >::: [ "test_alias" >:: test_alias; "test_variant" >:: test_variant; "test_rv_record" >:: test_rv_record; "test_variant_nest" >:: test_variant_nest; "test_tuple" >:: test_tuple; "test_poly" >:: test_poly; "test_poly_inherit" >:: test_poly_inherit; "test_record" >:: test_record; "test_variant_record" >:: test_variant_record; "test_abstr" >:: test_abstr; "test_custom" >:: test_custom; "test_parametric" >:: test_parametric; "test_alias_path" >:: test_alias_path; "test_polypr" >:: test_polypr; "test_placeholder" >:: test_placeholder; "test_mrec" >:: test_mrec; "test_std_shadowing" >:: test_std_shadowing; "test_poly_app" >:: test_poly_app; "test_variant_printer" >:: test_variant_printer; "test_paths" >:: test_paths_printer; "test_result" >:: test_result; "test_result_result" >:: test_result_result; ] let _ = run_test_tt_main suite