pax_global_header00006660000000000000000000000064135106335510014514gustar00rootroot0000000000000052 comment=03fb717fb2a6fbddddc317da24b1deb51f438431 ppx_deriving-4.4/000077500000000000000000000000001351063355100140615ustar00rootroot00000000000000ppx_deriving-4.4/.gitignore000066400000000000000000000001201351063355100160420ustar00rootroot00000000000000*.native *.byte *.docdir _build *.install pkg/META src_test/_tags .merlin _opam ppx_deriving-4.4/.travis.yml000066400000000000000000000005131351063355100161710ustar00rootroot00000000000000language: 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: matrix: - OCAML_VERSION=4.03 - OCAML_VERSION=4.04 - OCAML_VERSION=4.05 - OCAML_VERSION=4.06 - OCAML_VERSION=4.07 - OCAML_VERSION=4.08 os: - linux ppx_deriving-4.4/CHANGELOG.md000066400000000000000000000111671351063355100157000ustar00rootroot00000000000000Changelog ========= 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-4.4/LICENSE.txt000066400000000000000000000021001351063355100156750ustar00rootroot00000000000000Copyright (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-4.4/META.ppx_deriving.template000066400000000000000000000001751351063355100210440ustar00rootroot00000000000000description = "Type-driven code generation" ppx(-custom_ppx) = "./ppx_deriving" requires = "ppx_deriving.runtime" # DUNE_GENppx_deriving-4.4/Makefile000066400000000000000000000012031351063355100155150ustar00rootroot00000000000000build: 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 -t .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-4.4/README.md000066400000000000000000000514471351063355100153530ustar00rootroot00000000000000[@@deriving] ============ _deriving_ is a library simplifying type-driven code generation on OCaml >=4.02. _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 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) 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 `Pervasives.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 `Pervasives.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 `Pervasives.(=)` and `Pervasives.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 ``` 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/ppx_deriving_eq.cppo.ml) or [show](src_plugins/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.html). #### 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.html#VALraise_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.html#VALmangle_type_decl) and [Ppx_deriving.mangle_lid](http://ocaml-ppx.github.io/ppx_deriving/Ppx_deriving.html#VALmangle_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.html#VALattr)); 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.html#VALpoly_fun_of_type_decl) for derived functions, [Ppx_deriving.poly_arrow_of_type_decl](http://ocaml-ppx.github.io/ppx_deriving/Ppx_deriving.html#VALpoly_arrow_of_type_decl) for signatures, and [Ppx_deriving.poly_apply_of_type_decl](http://ocaml-ppx.github.io/ppx_deriving/Ppx_deriving.html#VALpoly_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.html#VALpath_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.html#VALfold_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-4.4/dune000066400000000000000000000001111351063355100147300ustar00rootroot00000000000000(env (_ (flags -w -9))) (copy_files# src_plugins/compat_macros.cppo) ppx_deriving-4.4/dune-project000066400000000000000000000000451351063355100164020ustar00rootroot00000000000000(lang dune 1.0) (name ppx_deriving) ppx_deriving-4.4/dune-workspace.dev000066400000000000000000000002561351063355100175130ustar00rootroot00000000000000(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-4.4/ppx_deriving.opam000066400000000000000000000017721351063355100174440ustar00rootroot00000000000000opam-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"] {pinned} ["dune" "build" "-p" name "-j" jobs] ["dune" "runtest" "-p" name "-j" jobs] {with-test} ["dune" "build" "@doc" "-p" name "-j" jobs] {with-doc} ] depends: [ "dune" {build >= "1.6.3"} "cppo" {build} "ppxfind" {build} "ocaml-migrate-parsetree" "ppx_derivers" "ppx_tools" {>= "4.02.3"} "result" "ounit" {with-test} "ocaml" {>= "4.02.2"} ] synopsis: "Type-driven code generation for OCaml >=4.02.2" description: """ ppx_deriving provides common infrastructure for generating code based on type definitions, and a set of useful plugins for common tasks. """ ppx_deriving-4.4/src/000077500000000000000000000000001351063355100146505ustar00rootroot00000000000000ppx_deriving-4.4/src/api/000077500000000000000000000000001351063355100154215ustar00rootroot00000000000000ppx_deriving-4.4/src/api/dune000066400000000000000000000012031351063355100162730ustar00rootroot00000000000000(library (name ppx_deriving_api) (public_name ppx_deriving.api) (synopsis "Plugin API for ppx_deriving") (preprocess (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file}))) (wrapped false) (ppx_runtime_libraries ppx_deriving_runtime) (libraries compiler-libs.common ppx_tools result ppx_derivers ocaml-migrate-parsetree)) (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-4.4/src/api/ppx_deriving.cppo.ml000066400000000000000000000645071351063355100214250ustar00rootroot00000000000000#if OCAML_VERSION < (4, 03, 0) #define Pconst_char Const_char #define Pconst_string Const_string #define Pstr_type(rec_flag, type_decls) Pstr_type(type_decls) #define Psig_type(rec_flag, type_decls) Psig_type(type_decls) #endif #if OCAML_VERSION < (4, 08, 0) #define Attribute_expr(loc_, txt_, payload) ({txt = txt_; loc = loc_}, payload) #define Attribute_patt(loc_, txt_, payload) ({txt = txt_; loc = loc_}, payload) #else #define Attribute_expr(loc_, txt_, payload) { attr_name = \ { txt = txt_; loc = loc_ }; \ attr_payload = payload; \ attr_loc = loc_ } #define Attribute_patt(loc_, txt_, payload) { attr_name = \ { txt = txt_; loc = loc_ }; \ attr_payload = payload; \ attr_loc = _ } #endif #if OCAML_VERSION < (4, 08, 0) #define Rtag_patt(label, constant, args) Rtag(label, _, constant, args) #define Rinherit_patt(typ) Rinherit(typ) #else #define Rtag_patt(label, constant, args) {prf_desc = Rtag(label, constant, args); _} #define Rinherit_patt(typ) {prf_desc = Rinherit(typ); _} #endif open Longident open Location open Asttypes open Parsetree open Ast_helper open Ast_convenience #if OCAML_VERSION >= (4, 05, 0) type tyvar = string Location.loc #else type tyvar = string #endif 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 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.kprintf 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 = [] } module Arg = struct type 'a conv = expression -> ('a, string) Result.result open Result let expr expr = Ok expr let int expr = match expr with #if OCAML_VERSION < (4, 03, 0) | { pexp_desc = Pexp_constant (Const_int n) } -> Ok n #else | { pexp_desc = Pexp_constant (Pconst_integer (sn, _)) } -> Ok (int_of_string sn) #endif | _ -> 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 (Attribute_patt(loc, name, PStr [{ pstr_desc = Pstr_eval (expr, []) }])) -> 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 (Attribute_patt(loc, name, _)) -> raise_errorf ~loc "%s: invalid [@%s]: value expected" deriver name let get_flag ~deriver attr = match attr with | None -> false | Some (Attribute_patt(_loc, name, PStr [])) -> true | Some (Attribute_patt(loc, name, _)) -> 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 Attribute_expr(loc, "ocaml.warning", PStr [structure]) type quoter = { mutable next_id : int; mutable bindings : value_binding list; } let create_quoter () = { next_id = 0; bindings = [] } let quote ~quoter expr = let name = "__" ^ string_of_int quoter.next_id in quoter.bindings <- (Vb.mk (pvar name) [%expr fun () -> [%e expr]]) :: quoter.bindings; quoter.next_id <- quoter.next_id + 1; [%expr [%e evar name] ()] let sanitize ?(module_=Lident "Ppx_deriving_runtime") ?(quoter=create_quoter ()) expr = let body = let loc = !Ast_helper.default_loc in let attrs = [attr_warning [%expr "-A"]] in let modname = { txt = module_; loc } in Exp.open_ ~loc ~attrs #if OCAML_VERSION < (4, 08, 0) Override modname #else (Opn.mk ~loc ~attrs ~override:Override (Mod.ident ~loc ~attrs modname)) #endif expr in match quoter.bindings with | [] -> body | bindings -> Exp.let_ Nonrecursive bindings body 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, _) -> 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 (Attribute_patt(_loc, txt, _)) = starts prefix txt in let attr_is name (Attribute_patt(_loc, txt, _)) = 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 open Ast_mapper in let map_typ mapper typ = match typ.ptyp_desc with | Ptyp_constr (lid, l) -> let lid = {lid with txt = remove_pervasive_lid lid.txt} in {typ with ptyp_desc = Ptyp_constr (lid, List.map (mapper.typ mapper) l)} | Ptyp_class (lid, l) -> let lid = {lid with txt = remove_pervasive_lid lid.txt} in {typ with ptyp_desc = Ptyp_class (lid, List.map (mapper.typ mapper) l)} | _ -> default_mapper.typ mapper typ in let m = { default_mapper with typ = map_typ} in m.typ m typ 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 } -> #if OCAML_VERSION >= (4, 05, 0) let name = mkloc name param.ptyp_loc in #endif 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 } -> #if OCAML_VERSION >= (4, 05, 0) let name = mkloc name param.ptyp_loc in #endif 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 } -> #if OCAML_VERSION >= (4, 05, 0) [mkloc name typ.ptyp_loc] #else [name] #endif | { 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) } -> #if OCAML_VERSION >= (4, 05, 0) [mkloc name typ.ptyp_loc] #else [name] #endif @ 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 Rtag_patt(_,_,ts) -> List.map free_in ts | Rinherit_patt(t) -> [free_in t] ) rows |> List.concat |> List.concat | _ -> assert false in let uniq lst = let module StringSet = Set.Make(String) in let add name (names, txts) = let txt = #if OCAML_VERSION >= (4, 05, 0) name.txt #else name #endif in if StringSet.mem txt txts then (names, txts) else (name :: names, StringSet.add txt txts) in fst (List.fold_right add lst ([], StringSet.empty)) 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 -> #if OCAML_VERSION >= (4, 05, 0) let name = name.txt in #endif 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 -> #if OCAML_VERSION >= (4, 05, 0) let name = name.txt in #endif 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 -> #if OCAML_VERSION >= (4, 05, 0) let name = name.txt in #endif 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 -> #if OCAML_VERSION >= (4, 05, 0) let name = name.txt in #endif 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 -> #if OCAML_VERSION >= (4, 05, 0) let name = name.txt in #endif 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 = #if OCAML_VERSION >= (4, 05, 0) Typ.var ~loc:name.loc name.txt #else Typ.var name #endif 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 = match sep with | Some x -> [%expr [%e a]; [%e x]; [%e b]] | None -> [%expr [%e a]; [%e b]] let binop_reduce x a b = [%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 "." (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 "_" (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 !Location.input_name with | "" | "//toplevel//" -> [] | filename -> let capitalize = #if OCAML_VERSION >= (4, 03, 0) String.capitalize_ascii #else String.capitalize #endif 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) -> #if OCAML_VERSION < (4, 03, 0) begin if List.exists (fun ty -> has_attr "nonrec" ty.ptype_attributes) typ_decls then Nonrecursive else Recursive end #else rec_flag #endif | _ -> assert false let mapper = let module_nesting = ref [] in let with_module name f = let old_nesting = !module_nesting in module_nesting := !module_nesting @ [name]; let result = f () in module_nesting := old_nesting; result in let expression mapper 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) | _ -> Ast_mapper.(default_mapper.expr) mapper expr end | _ -> Ast_mapper.(default_mapper.expr) mapper expr in let structure mapper 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 @ mapper.Ast_mapper.structure mapper 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 @ mapper.Ast_mapper.structure mapper 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 @ mapper.Ast_mapper.structure mapper 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 () -> mapper.Ast_mapper.module_binding mapper mb)) } in derived :: mapper.Ast_mapper.structure mapper 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 () -> mapper.Ast_mapper.module_binding mapper mb))) } in derived :: mapper.Ast_mapper.structure mapper rest | { pstr_loc } as item :: rest -> let derived = mapper.Ast_mapper.structure_item mapper item in derived :: mapper.Ast_mapper.structure mapper rest | [] -> [] in let signature mapper 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 @ mapper.Ast_mapper.signature mapper 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 @ mapper.Ast_mapper.signature mapper 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 @ mapper.Ast_mapper.signature mapper 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 () -> mapper.Ast_mapper.module_declaration mapper md)) } in derived :: mapper.Ast_mapper.signature mapper 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 () -> mapper.Ast_mapper.module_declaration mapper md))) } in derived :: mapper.Ast_mapper.signature mapper rest | { psig_loc } as item :: rest -> let derived = mapper.Ast_mapper.signature_item mapper item in derived :: mapper.Ast_mapper.signature mapper rest | [] -> [] in Ast_mapper.{default_mapper with expr = expression; structure = (fun mapper items -> module_nesting := module_from_input_name (); structure { mapper with structure; signature } items); signature = (fun mapper items -> module_nesting := module_from_input_name (); signature { mapper with structure; signature } items) } 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 () = Migrate_parsetree.Driver.register ~name:"ppx_deriving" (module Migrate_parsetree.OCaml_current) (fun _ _ -> mapper) ppx_deriving-4.4/src/api/ppx_deriving.cppo.mli000066400000000000000000000347331351063355100215740ustar00rootroot00000000000000(** Public API of [ppx_deriving] executable. *) open Parsetree #if OCAML_VERSION >= (4, 05, 0) type tyvar = string Location.loc #else type tyvar = string #endif (** {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:Location.error list -> ?loc:Location.t -> ('a, unit, string, 'b) format4 -> 'a (** [string_of_core_type typ] unparses [typ], omitting any attributes. *) val string_of_core_type : Parsetree.core_type -> string (** {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 [Result.Error "error"] if conversion fails. *) type 'a conv = expression -> ('a, string) Result.result (** [expr] returns the input expression as-is. *) val expr : expression conv (** [bool expr] extracts a boolean constant from [expr], or returns [Result.Error "boolean"] if [expr] does not contain a boolean literal. *) val bool : bool conv (** [int expr] extracts an integer constant from [expr], or returns [Result.Error "integer"] if [expr] does not contain an integer literal. *) val int : int conv (** [string expr] extracts a string constant from [expr], or returns [Result.Error "string"] if [expr] does not contain a string literal. *) val string : string conv (** [char expr] extracts a char constant from [expr], or returns [Result.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 [Result.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 [Result.Error "list:..."] where [...] is the error returned by [f], or returns [Result.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 {!Pervasives}, 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." 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. *) val mapper : Ast_mapper.mapper (** {2 Miscellanea} *) (** [hash_variant x] ≡ [Btype.hash_variant x]. *) val hash_variant : string -> int ppx_deriving-4.4/src/dune000066400000000000000000000007061351063355100155310ustar00rootroot00000000000000(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 (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file})))) (install (section libexec) (files (ppx_deriving_main.exe as ppx_deriving))) ppx_deriving-4.4/src/ppx_deriving_main.cppo.ml000066400000000000000000000046751351063355100216600ustar00rootroot00000000000000#if OCAML_VERSION < (4, 03, 0) #define Pconst_string Const_string #endif open Asttypes open Parsetree open Ast_helper 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 | Some { pexp_desc = Pexp_tuple exprs } -> exprs |> List.map (fun expr -> match expr with | { pexp_desc = Pexp_constant (Pconst_string (file, None)) } -> file | _ -> assert false) | Some _ -> assert false | None -> [] 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" (Exp.tuple (List.map (fun file -> Exp.constant (Pconst_string (file, None))) loaded)) let mapper argv = get_plugins () |> List.iter load_plugin; add_plugins argv; let omp_mapper = Migrate_parsetree.Driver.run_as_ast_mapper [] in let structure mapper = function | [%stri [@@@findlib.ppxopt [%e? { pexp_desc = Pexp_tuple ( [%expr "ppx_deriving"] :: elems) }]]] :: rest -> elems |> List.map (fun elem -> match elem with | { pexp_desc = Pexp_constant (Pconst_string (file, None))} -> file | _ -> assert false) |> add_plugins; mapper.Ast_mapper.structure mapper rest | items -> omp_mapper.Ast_mapper.structure mapper items in { omp_mapper with Ast_mapper.structure } let () = Ast_mapper.register "ppx_deriving" mapper ppx_deriving-4.4/src/runtime/000077500000000000000000000000001351063355100163335ustar00rootroot00000000000000ppx_deriving-4.4/src/runtime/dune000066400000000000000000000007241351063355100172140ustar00rootroot00000000000000(library (name ppx_deriving_runtime) (public_name ppx_deriving.runtime) (wrapped false) (synopsis "Type-driven code generation") (libraries result)) (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-4.4/src/runtime/ppx_deriving_runtime.cppo.ml000066400000000000000000000033641351063355100240740ustar00rootroot00000000000000type 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, 08, 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.t = | Ok of 'a | Error of 'b type ('a, 'b) result = ('a, 'b) Result.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 (* the "result" compatibility module defines Result.result, not Result.t as the 4.08 stdlib *) type ('a, 'b) t = ('a, 'b) Result.result = | Ok of 'a | Error of 'b (* ... and we also expose Result.result for backward-compatibility *) type ('a, 'b) result = ('a, 'b) Result.result = | Ok of 'a | Error of 'b end include Pervasives #endif ppx_deriving-4.4/src/runtime/ppx_deriving_runtime.cppo.mli000066400000000000000000000076471351063355100242550ustar00rootroot00000000000000(** 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, 08, 0) include (module type of Stdlib with type fpclass = Stdlib.fpclass and type in_channel = Stdlib.in_channel and type out_channel = Stdlib.out_channel and type open_flag = Stdlib.open_flag and type 'a ref = 'a Stdlib.ref and type ('a, 'b, 'c, 'd, 'e, 'f) format6 = ('a, 'b, 'c, 'd, 'e, 'f) Stdlib.format6 and type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'd) Stdlib.format4 and type ('a, 'b, 'c) format = ('a, 'b, 'c) Stdlib.format ) module Result : sig type ('a, 'b) t = ('a, 'b) Result.t = | Ok of 'a | Error of 'b (* we also expose Result.result for backward-compatibility with the Result package! *) type ('a, 'b) result = ('a, 'b) Result.t = | Ok of 'a | Error of 'b end #else module Pervasives : (module type of Pervasives with type fpclass = Pervasives.fpclass and type in_channel = Pervasives.in_channel and type out_channel = Pervasives.out_channel and type open_flag = Pervasives.open_flag and type 'a ref = 'a Pervasives.ref and type ('a, 'b, 'c, 'd, 'e, 'f) format6 = ('a, 'b, 'c, 'd, 'e, 'f) Pervasives.format6 and type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'd) Pervasives.format4 and type ('a, 'b, 'c) format = ('a, 'b, 'c) Pervasives.format) module Stdlib = Pervasives include (module type of Pervasives with type fpclass = Pervasives.fpclass and type in_channel = Pervasives.in_channel and type out_channel = Pervasives.out_channel and type open_flag = Pervasives.open_flag and type 'a ref = 'a Pervasives.ref and type ('a, 'b, 'c, 'd, 'e, 'f) format6 = ('a, 'b, 'c, 'd, 'e, 'f) Pervasives.format6 and type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'd) Pervasives.format4 and type ('a, 'b, 'c) format = ('a, 'b, 'c) Pervasives.format) module Char : (module type of Char) module String : (module type of String) module Printexc : (module type of Printexc with type raw_backtrace = Printexc.raw_backtrace and type backtrace_slot = Printexc.backtrace_slot and type location = Printexc.location) module Array : (module type of Array) module List : (module type of List) module Nativeint : (module type of Nativeint) module Int32 : (module type of Int32) module Int64 : (module type of Int64) module Lazy : (module type of Lazy) module Bytes : (module type of Bytes) (** {3 Data structures} *) module Hashtbl : (module type of Hashtbl with type ('a, 'b) t = ('a, 'b) Hashtbl.t and type statistics = Hashtbl.statistics) module Queue : (module type of Queue with type 'a t = 'a Queue.t) module Stack : (module type of Stack with type 'a t = 'a Stack.t) module Set : (module type of Set) module Map : (module type of Map) module Weak : (module type of Weak with type 'a t = 'a Weak.t) module Buffer : (module type of Buffer with type t = Buffer.t) module Result : sig type ('a, 'b) t = ('a, 'b) Result.result = | Ok of 'a | Error of 'b (* we also expose Result.result for backward-compatibility *) type ('a, 'b) result = ('a, 'b) Result.result = | Ok of 'a | Error of 'b end (** {3 Formatting} *) module Printf : (module type of Printf) module Format : (module type of Format with type formatter_out_functions = Format.formatter_out_functions and type formatter_tag_functions = Format.formatter_tag_functions and type formatter = Format.formatter) #endif ppx_deriving-4.4/src_examples/000077500000000000000000000000001351063355100165465ustar00rootroot00000000000000ppx_deriving-4.4/src_examples/dune000066400000000000000000000001671351063355100174300ustar00rootroot00000000000000(executable (name print_test) (preprocess (pps ppx_deriving.show))) (alias (name examples) (deps print_test.exe)) ppx_deriving-4.4/src_examples/print_test.ml000066400000000000000000000403161351063355100212770ustar00rootroot00000000000000 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-4.4/src_plugins/000077500000000000000000000000001351063355100164115ustar00rootroot00000000000000ppx_deriving-4.4/src_plugins/compat_macros.cppo000066400000000000000000000005751351063355100221320ustar00rootroot00000000000000#if OCAML_VERSION < (4, 03, 0) #define Pcstr_tuple(core_types) core_types #endif #if OCAML_VERSION < (4, 08, 0) #define Rtag_patt(label, constant, args) Rtag(label, _, constant, args) #define Rinherit_patt(typ) Rinherit(typ) #else #define Rtag_patt(label, constant, args) {prf_desc = Rtag(label, constant, args); _} #define Rinherit_patt(typ) {prf_desc = Rinherit(typ); _} #endif ppx_deriving-4.4/src_plugins/create/000077500000000000000000000000001351063355100176545ustar00rootroot00000000000000ppx_deriving-4.4/src_plugins/create/dune000066400000000000000000000007211351063355100205320ustar00rootroot00000000000000(rule (deps ../compat_macros.cppo) (targets ppx_deriving_create.ml) (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{dep:ppx_deriving_create.cppo.ml} -o %{targets}))) (library (name ppx_deriving_create) (public_name ppx_deriving.create) (synopsis "[@@deriving create]") (preprocess (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file}))) (libraries compiler-libs.common ppx_tools ppx_deriving.api) (kind ppx_deriver)) ppx_deriving-4.4/src_plugins/create/ppx_deriving_create.cppo.ml000066400000000000000000000133071351063355100251730ustar00rootroot00000000000000#include "../compat_macros.cppo" open Longident open Location open Asttypes open Parsetree open Ast_helper open Ast_convenience let deriver = "create" let raise_errorf = Ppx_deriving.raise_errorf let parse_options options = options |> List.iter (fun (name, expr) -> match name with | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name) let attr_default attrs = Ppx_deriving.(attrs |> attr ~deriver "default" |> Arg.(get_attr ~deriver expr)) let attr_split attrs = Ppx_deriving.(attrs |> attr ~deriver "split" |> Arg.get_flag ~deriver) let find_main labels = List.fold_left (fun (main, labels) ({ pld_type; pld_loc; pld_attributes } as label) -> if Ppx_deriving.(pld_type.ptyp_attributes @ pld_attributes |> attr ~deriver "main" |> Arg.get_flag ~deriver) 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 ~options ~path ({ ptype_loc = loc } as type_decl) = parse_options options; 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 } -> let attrs = pld_attributes @ pld_type.ptyp_attributes in let pld_type = Ppx_deriving.remove_pervasives ~deriver pld_type in match attr_default attrs with | Some default -> Exp.fun_ (Label.optional name) (Some (Ppx_deriving.quote ~quoter default)) (pvar name) accum | None -> if attr_split attrs 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 = #if OCAML_VERSION < (4, 03, 0) let predef_option = mknoloc (Ldot (Lident "*predef*", "option")) in Typ.constr predef_option [typ] #else typ #endif let sig_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = parse_options options; 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 } -> let attrs = pld_type.ptyp_attributes @ pld_attributes in let pld_type = Ppx_deriving.remove_pervasives ~deriver pld_type in match attr_default attrs with | Some _ -> Typ.arrow (Label.optional name) (wrap_predef_option pld_type) accum | None -> if attr_split attrs 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 () = Ppx_deriving.(register (create deriver ~type_decl_str: (fun ~options ~path type_decls -> [Str.value Nonrecursive (List.concat (List.map (str_of_type ~options ~path) type_decls))]) ~type_decl_sig: (fun ~options ~path type_decls -> List.concat (List.map (sig_of_type ~options ~path) type_decls)) () )) ppx_deriving-4.4/src_plugins/dune000066400000000000000000000000001351063355100172550ustar00rootroot00000000000000ppx_deriving-4.4/src_plugins/enum/000077500000000000000000000000001351063355100173555ustar00rootroot00000000000000ppx_deriving-4.4/src_plugins/enum/dune000066400000000000000000000007071351063355100202370ustar00rootroot00000000000000(rule (deps ../compat_macros.cppo) (targets ppx_deriving_enum.ml) (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{dep:ppx_deriving_enum.cppo.ml} -o %{targets}))) (library (name ppx_deriving_enum) (public_name ppx_deriving.enum) (synopsis "[@@deriving enum]") (preprocess (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file}))) (libraries compiler-libs.common ppx_tools ppx_deriving.api) (kind ppx_deriver)) ppx_deriving-4.4/src_plugins/enum/ppx_deriving_enum.cppo.ml000066400000000000000000000125361351063355100244000ustar00rootroot00000000000000#include "../compat_macros.cppo" open Longident open Location open Asttypes open Parsetree open Ast_helper open Ast_convenience let deriver = "enum" let raise_errorf = Ppx_deriving.raise_errorf let parse_options options = options |> List.iter (fun (name, expr) -> match name with | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name) let attr_value attrs = Ppx_deriving.(attrs |> attr ~deriver "value" |> Arg.(get_attr ~deriver int)) let mappings_of_type type_decl = let map acc mappings attrs constr_name = let value = match attr_value attrs 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 } -> if pcd_args <> Pcstr_tuple([]) then raise_errorf ~loc:pcd_loc "%s can be derived only for argumentless constructors" deriver; map acc mappings pcd_attributes 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 #if OCAML_VERSION < (4, 08, 0) let loc = ptyp_loc in match row_field with | Rinherit _ -> error_inherit loc | Rtag (name, attrs, true, []) -> #if OCAML_VERSION < (4, 06, 0) let name = mkloc name loc in #endif map acc mappings attrs name | Rtag _ -> error_arguments loc #else let loc = row_field.prf_loc in let attrs = row_field.prf_attributes in match row_field.prf_desc with | Rinherit _ -> error_inherit loc | Rtag (name, true, []) -> map acc mappings attrs name | Rtag _ -> error_arguments loc #endif ) (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 = [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 ~options ~path ({ ptype_loc = loc } as type_decl) = parse_options options; 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 ~options ~path type_decl = parse_options options; 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 () = Ppx_deriving.(register (create deriver ~type_decl_str: (fun ~options ~path type_decls -> [Str.value Nonrecursive (List.concat (List.map (str_of_type ~options ~path) type_decls))]) ~type_decl_sig: (fun ~options ~path type_decls -> List.concat (List.map (sig_of_type ~options ~path) type_decls)) () )) ppx_deriving-4.4/src_plugins/eq/000077500000000000000000000000001351063355100170165ustar00rootroot00000000000000ppx_deriving-4.4/src_plugins/eq/dune000066400000000000000000000006751351063355100177040ustar00rootroot00000000000000(rule (deps ../compat_macros.cppo) (targets ppx_deriving_eq.ml) (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{dep:ppx_deriving_eq.cppo.ml} -o %{targets}))) (library (name ppx_deriving_eq) (public_name ppx_deriving.eq) (synopsis "[@@deriving eq]") (preprocess (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file}))) (libraries compiler-libs.common ppx_tools ppx_deriving.api) (kind ppx_deriver)) ppx_deriving-4.4/src_plugins/eq/ppx_deriving_eq.cppo.ml000066400000000000000000000215721351063355100235020ustar00rootroot00000000000000#include "../compat_macros.cppo" open Longident open Location open Asttypes open Parsetree open Ast_helper open Ast_convenience let deriver = "eq" let raise_errorf = Ppx_deriving.raise_errorf let parse_options options = options |> List.iter (fun (name, expr) -> match name with | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name) let attr_nobuiltin attrs = Ppx_deriving.(attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver) let attr_equal attrs = Ppx_deriving.(attrs |> attr ~deriver "equal" |> Arg.(get_attr ~deriver expr)) 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 ~options ~path type_decl = parse_options options; 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 ~options ~path type_decl = parse_options options; [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "equal") type_decl)) (core_type_of_decl ~options ~path 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 typ = Ppx_deriving.remove_pervasives ~deriver typ in let expr_of_typ = expr_of_typ quoter in match attr_equal typ.ptyp_attributes with | Some fn -> Ppx_deriving.quote quoter fn | None -> match typ with | [%type: _] -> [%expr fun _ _ -> true] | { ptyp_desc = Ptyp_constr _ } -> let builtin = not (attr_nobuiltin typ.ptyp_attributes) 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 | Result.Ok a, Result.Ok b -> [%e expr_of_typ ok_t] a b | Result.Error a, Result.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 let fwd = app (Ppx_deriving.quote quoter equal_fn) (List.map expr_of_typ args) in (* eta-expansion is necessary for recursive groups *) [%expr fun x -> [%e fwd] x] | _ -> 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 = #if OCAML_VERSION < (4, 06, 0) Pat.variant label popt #else Pat.variant label.txt popt #endif in match field with | Rtag_patt(label, true (*empty*), []) -> Exp.case (pdup (fun _ -> variant label None)) [%expr true] | Rtag_patt(label, false, [typ]) -> Exp.case (pdup (fun var -> variant label (Some (pvar var)))) (app (expr_of_typ typ) [evar "lhs"; evar "rhs"]) | Rinherit_patt({ 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 ~options ~path ({ ptype_loc = loc } as type_decl) = parse_options options; 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)]) #if OCAML_VERSION >= (4, 03, 0) | 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)]) #endif )) @ [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 out_type = Ppx_deriving.strong_type_of_type @@ core_type_of_decl ~options ~path 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 (polymorphize comparator))] let () = Ppx_deriving.(register (create deriver ~core_type: (Ppx_deriving.with_quoter expr_of_typ) ~type_decl_str: (fun ~options ~path type_decls -> [Str.value Recursive (List.concat (List.map (str_of_type ~options ~path) type_decls))]) ~type_decl_sig: (fun ~options ~path type_decls -> List.concat (List.map (sig_of_type ~options ~path) type_decls)) () )) ppx_deriving-4.4/src_plugins/fold/000077500000000000000000000000001351063355100173355ustar00rootroot00000000000000ppx_deriving-4.4/src_plugins/fold/dune000066400000000000000000000006711351063355100202170ustar00rootroot00000000000000(rule (deps ../compat_macros.cppo) (targets ppx_deriving_fold.ml) (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{dep:ppx_deriving_fold.cppo.ml} -o %{targets}))) (library (name ppx_deriving_fold) (public_name ppx_deriving.fold) (synopsis "[@@deriving fold]") (preprocess (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file}))) (libraries compiler-libs.common ppx_tools ppx_deriving.api) (kind ppx_deriver)) ppx_deriving-4.4/src_plugins/fold/ppx_deriving_fold.cppo.ml000066400000000000000000000152511351063355100243350ustar00rootroot00000000000000#include "../compat_macros.cppo" open Longident open Location open Asttypes open Parsetree open Ast_helper open Ast_convenience let deriver = "fold" let raise_errorf = Ppx_deriving.raise_errorf let parse_options options = options |> List.iter (fun (name, expr) -> match name with | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name) let attr_nobuiltin attrs = Ppx_deriving.(attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver) 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 = [%expr let acc = [%e a] in [%e b]] let rec expr_of_typ typ = 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 (attr_nobuiltin typ.ptyp_attributes) 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 | Result.Ok ok -> [%e expr_of_typ ok_t] acc ok | Result.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 = #if OCAML_VERSION < (4, 06, 0) Pat.variant label popt #else Pat.variant label.txt popt #endif in match field with | Rtag_patt(label, true (*empty*), []) -> Exp.case (variant label None) [%expr acc] | Rtag_patt(label, false, [typ]) -> Exp.case (variant label (Some [%pat? x])) [%expr [%e expr_of_typ typ] acc x] | Rinherit_patt({ 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 ~options ~path ({ ptype_loc = loc } as type_decl) = parse_options options; 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) #if OCAML_VERSION >= (4, 03, 0) | 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) #endif ) 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 ~options ~path type_decl = parse_options options; let loc = type_decl.ptype_loc in let typ = Ppx_deriving.core_type_of_type_decl type_decl in let vars = #if OCAML_VERSION >= (4, 05, 0) (List.map (fun tyvar -> tyvar.txt)) #endif (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 () = Ppx_deriving.(register (create deriver ~core_type: expr_of_typ ~type_decl_str: (fun ~options ~path type_decls -> [Str.value Recursive (List.concat (List.map (str_of_type ~options ~path) type_decls))]) ~type_decl_sig: (fun ~options ~path type_decls -> List.concat (List.map (sig_of_type ~options ~path) type_decls)) () )) ppx_deriving-4.4/src_plugins/iter/000077500000000000000000000000001351063355100173545ustar00rootroot00000000000000ppx_deriving-4.4/src_plugins/iter/dune000066400000000000000000000006711351063355100202360ustar00rootroot00000000000000(rule (deps ../compat_macros.cppo) (targets ppx_deriving_iter.ml) (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{dep:ppx_deriving_iter.cppo.ml} -o %{targets}))) (library (name ppx_deriving_iter) (public_name ppx_deriving.iter) (synopsis "[@@deriving iter]") (preprocess (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file}))) (libraries compiler-libs.common ppx_tools ppx_deriving.api) (kind ppx_deriver)) ppx_deriving-4.4/src_plugins/iter/ppx_deriving_iter.cppo.ml000066400000000000000000000142501351063355100243710ustar00rootroot00000000000000#include "../compat_macros.cppo" open Longident open Location open Asttypes open Parsetree open Ast_helper open Ast_convenience let deriver = "iter" let raise_errorf = Ppx_deriving.raise_errorf let parse_options options = options |> List.iter (fun (name, expr) -> match name with | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name) let attr_nobuiltin attrs = Ppx_deriving.(attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver) 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 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 (attr_nobuiltin typ.ptyp_attributes) 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.result] -> [%expr function | Result.Ok ok -> ignore ([%e expr_of_typ ok_t] ok) | Result.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 = #if OCAML_VERSION < (4, 06, 0) Pat.variant label popt #else Pat.variant label.txt popt #endif in match field with | Rtag_patt(label, true (*empty*), []) -> Exp.case (variant label None) [%expr ()] | Rtag_patt(label, false, [typ]) -> Exp.case (variant label (Some [%pat? x])) [%expr [%e expr_of_typ typ] x] | Rinherit_patt({ 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 ~options ~path ({ ptype_loc = loc } as type_decl) = parse_options options; 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 #if OCAML_VERSION >= (4, 03, 0) | 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) #endif ) |> 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 ~options ~path type_decl = parse_options options; 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 () = Ppx_deriving.(register (create deriver ~core_type: expr_of_typ ~type_decl_str: (fun ~options ~path type_decls -> [Str.value Recursive (List.concat (List.map (str_of_type ~options ~path) type_decls))]) ~type_decl_sig: (fun ~options ~path type_decls -> List.concat (List.map (sig_of_type ~options ~path) type_decls)) () )) ppx_deriving-4.4/src_plugins/make/000077500000000000000000000000001351063355100173265ustar00rootroot00000000000000ppx_deriving-4.4/src_plugins/make/dune000066400000000000000000000006711351063355100202100ustar00rootroot00000000000000(rule (deps ../compat_macros.cppo) (targets ppx_deriving_make.ml) (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{dep:ppx_deriving_make.cppo.ml} -o %{targets}))) (library (name ppx_deriving_make) (public_name ppx_deriving.make) (synopsis "[@@deriving make]") (preprocess (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file}))) (libraries compiler-libs.common ppx_tools ppx_deriving.api) (kind ppx_deriver)) ppx_deriving-4.4/src_plugins/make/ppx_deriving_make.cppo.ml000066400000000000000000000144031351063355100243150ustar00rootroot00000000000000#include "../compat_macros.cppo" open Longident open Location open Asttypes open Parsetree open Ast_helper open Ast_convenience let deriver = "make" let raise_errorf = Ppx_deriving.raise_errorf let parse_options options = options |> List.iter (fun (name, expr) -> match name with | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name) let attr_default attrs = Ppx_deriving.(attrs |> attr ~deriver "default" |> Arg.(get_attr ~deriver expr)) let attr_split attrs = Ppx_deriving.(attrs |> attr ~deriver "split" |> Arg.get_flag ~deriver) let find_main labels = List.fold_left (fun (main, labels) ({ pld_type; pld_loc; pld_attributes } as label) -> if Ppx_deriving.(pld_type.ptyp_attributes @ pld_attributes |> attr ~deriver "main" |> Arg.get_flag ~deriver) 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 is_optional { pld_name = { txt = name }; pld_type; pld_attributes } = let attrs = pld_attributes @ pld_type.ptyp_attributes in match attr_default attrs with | Some _ -> true | None -> attr_split attrs || (match Ppx_deriving.remove_pervasives ~deriver pld_type with | [%type: [%t? _] list] | [%type: [%t? _] option] -> true | _ -> false) let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = parse_options options; 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 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 List.fold_left (fun accum { pld_name = { txt = name }; pld_type; pld_attributes } -> let attrs = pld_attributes @ pld_type.ptyp_attributes in let pld_type = Ppx_deriving.remove_pervasives ~deriver pld_type in match attr_default attrs with | Some default -> Exp.fun_ (Label.optional name) (Some (Ppx_deriving.quote ~quoter default)) (pvar name) accum | None -> if attr_split attrs 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 = #if OCAML_VERSION < (4, 03, 0) let predef_option = mknoloc (Ldot (Lident "*predef*", "option")) in Typ.constr predef_option [typ] #else typ #endif let sig_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = parse_options options; 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 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 List.fold_left (fun accum { pld_name = { txt = name; loc }; pld_type; pld_attributes } -> let attrs = pld_type.ptyp_attributes @ pld_attributes in let pld_type = Ppx_deriving.remove_pervasives ~deriver pld_type in match attr_default attrs with | Some _ -> Typ.arrow (Label.optional name) (wrap_predef_option pld_type) accum | None -> if attr_split attrs 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 () = Ppx_deriving.(register (create deriver ~type_decl_str: (fun ~options ~path type_decls -> [Str.value Nonrecursive (List.concat (List.map (str_of_type ~options ~path) type_decls))]) ~type_decl_sig: (fun ~options ~path type_decls -> List.concat (List.map (sig_of_type ~options ~path) type_decls)) () )) ppx_deriving-4.4/src_plugins/map/000077500000000000000000000000001351063355100171665ustar00rootroot00000000000000ppx_deriving-4.4/src_plugins/map/dune000066400000000000000000000006371351063355100200520ustar00rootroot00000000000000(rule (deps ppx_deriving_map.cppo.ml) (targets ppx_deriving_map.ml) (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets}))) (library (name ppx_deriving_map) (public_name ppx_deriving.map) (synopsis "[@@deriving map]") (preprocess (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file}))) (libraries compiler-libs.common ppx_tools ppx_deriving.api) (kind ppx_deriver)) ppx_deriving-4.4/src_plugins/map/ppx_deriving_map.cppo.ml000066400000000000000000000154261351063355100240230ustar00rootroot00000000000000#include "../compat_macros.cppo" open Longident open Location open Asttypes open Parsetree open Ast_helper open Ast_convenience let deriver = "map" let raise_errorf = Ppx_deriving.raise_errorf let parse_options options = options |> List.iter (fun (name, expr) -> match name with | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name) let attr_nobuiltin attrs = Ppx_deriving.(attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver) 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 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 (attr_nobuiltin typ.ptyp_attributes) 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 | Result.Ok ok -> Result.Ok ([%e expr_of_typ ?decl ok_t] ok) | Result.Error err -> Result.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 = #if OCAML_VERSION < (4, 06, 0) Pat.variant label popt #else Pat.variant label.txt popt #endif in let exp_variant label popt = #if OCAML_VERSION < (4, 06, 0) Exp.variant label popt #else Exp.variant label.txt popt #endif in match field with | Rtag_patt(label, true (*empty*), []) -> Exp.case (pat_variant label None) (exp_variant label None) | Rtag_patt(label, false, [typ]) -> Exp.case (pat_variant label (Some [%pat? x])) (exp_variant label (Some [%expr [%e expr_of_typ ?decl typ] x])) | Rinherit_patt({ 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 ~options ~path ({ ptype_loc = loc } as type_decl) = parse_options options; 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) #if OCAML_VERSION >= (4, 03, 0) | 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) #endif ) |> 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 ~options ~path type_decl = parse_options options; 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 () = Ppx_deriving.(register (create deriver ~core_type: (expr_of_typ ?decl:None) ~type_decl_str: (fun ~options ~path type_decls -> [Str.value Recursive (List.concat (List.map (str_of_type ~options ~path) type_decls))]) ~type_decl_sig: (fun ~options ~path type_decls -> List.concat (List.map (sig_of_type ~options ~path) type_decls)) () )) ppx_deriving-4.4/src_plugins/ord/000077500000000000000000000000001351063355100171755ustar00rootroot00000000000000ppx_deriving-4.4/src_plugins/ord/dune000066400000000000000000000007021351063355100200520ustar00rootroot00000000000000(rule (deps ../compat_macros.cppo) (targets ppx_deriving_ord.ml) (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{dep:ppx_deriving_ord.cppo.ml} -o %{targets}))) (library (name ppx_deriving_ord) (public_name ppx_deriving.ord) (synopsis "[@@deriving ord]") (preprocess (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file}))) (libraries compiler-libs.common ppx_tools ppx_deriving.api) (kind ppx_deriver)) ppx_deriving-4.4/src_plugins/ord/ppx_deriving_ord.cppo.ml000066400000000000000000000240141351063355100240320ustar00rootroot00000000000000#include "../compat_macros.cppo" open Longident open Location open Asttypes open Parsetree open Ast_helper open Ast_convenience let deriver = "ord" let raise_errorf = Ppx_deriving.raise_errorf let parse_options options = options |> List.iter (fun (name, expr) -> match name with | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name) let attr_nobuiltin attrs = Ppx_deriving.(attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver) let attr_compare attrs = Ppx_deriving.(attrs |> attr ~deriver "compare" |> Arg.(get_attr ~deriver expr)) 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 = [%expr match [%e expr] with 0 -> [%e acc] | x -> x] let reduce_compare l = match List.rev l with | [] -> [%expr 0] | x :: xs -> List.fold_left compare_reduce x xs let wildcard_case int_cases = 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 expr_of_typ = expr_of_typ quoter in match attr_compare typ.ptyp_attributes 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 (attr_nobuiltin typ.ptyp_attributes) 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 | Result.Error a, Result.Error b -> [%e expr_of_typ err_t] a b | Result.Ok a, Result.Ok b -> [%e expr_of_typ ok_t] a b | Result.Ok _ , Result.Error _ -> -1 | Result.Error _ , Result.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 let fwd = app (Ppx_deriving.quote quoter compare_fn) (List.map expr_of_typ args) in (* eta-expansion is necessary for recursive groups *) [%expr fun x -> [%e fwd] x] | _ -> 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 = #if OCAML_VERSION < (4, 06, 0) Pat.variant label popt #else Pat.variant label.txt popt #endif in let cases = fields |> List.map (fun field -> let pdup f = ptuple [f "lhs"; f "rhs"] in match field with | Rtag_patt(label, true (*empty*), []) -> Exp.case (pdup (fun _ -> variant label None)) [%expr 0] | Rtag_patt(label, false, [typ]) -> Exp.case (pdup (fun var -> variant label (Some (pvar var)))) (app (expr_of_typ typ) [evar "lhs"; evar "rhs"]) | Rinherit_patt({ 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 with | Rtag_patt(label, true (*empty*), []) -> Exp.case (variant label None) (int i) | Rtag_patt(label, false, [typ]) -> Exp.case (variant label (Some [%pat? _])) (int i) | Rinherit_patt({ 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 ~options ~path type_decl = parse_options options; 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 ~options ~path type_decl = [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "compare") type_decl)) (core_type_of_decl ~options ~path type_decl))] let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = parse_options options; 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)]) #if OCAML_VERSION >= (4, 03, 0) | Pcstr_record(labels) -> exprl quoter labels |> reduce_compare |> Exp.case (ptuple [pconstrrec name (pattl `lhs labels); pconstrrec name (pattl `rhs labels)]) #endif ) 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 out_type = Ppx_deriving.strong_type_of_type @@ core_type_of_decl ~options ~path 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 (polymorphize comparator))] let () = Ppx_deriving.(register (create deriver ~core_type: (Ppx_deriving.with_quoter expr_of_typ) ~type_decl_str: (fun ~options ~path type_decls -> [Str.value Recursive (List.concat (List.map (str_of_type ~options ~path) type_decls))]) ~type_decl_sig: (fun ~options ~path type_decls -> List.concat (List.map (sig_of_type ~options ~path) type_decls)) () )) ppx_deriving-4.4/src_plugins/show/000077500000000000000000000000001351063355100173715ustar00rootroot00000000000000ppx_deriving-4.4/src_plugins/show/dune000066400000000000000000000007071351063355100202530ustar00rootroot00000000000000(rule (deps ../compat_macros.cppo) (targets ppx_deriving_show.ml) (action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{dep:ppx_deriving_show.cppo.ml} -o %{targets}))) (library (name ppx_deriving_show) (public_name ppx_deriving.show) (synopsis "[@@deriving show]") (preprocess (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file}))) (libraries compiler-libs.common ppx_tools ppx_deriving.api) (kind ppx_deriver)) ppx_deriving-4.4/src_plugins/show/ppx_deriving_show.cppo.ml000066400000000000000000000360641351063355100244320ustar00rootroot00000000000000#include "../compat_macros.cppo" open Longident open Location open Asttypes open Parsetree open Ast_helper open Ast_convenience let deriver = "show" let raise_errorf = Ppx_deriving.raise_errorf type options = { with_path : bool } (* 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 show_opts ~path name = let path = if show_opts.with_path then path else [] in Ppx_deriving.expand_path ~path name let parse_options options = let with_path = ref true in options |> List.iter (fun (name, expr) -> match name with | "with_path" -> with_path := Ppx_deriving.Arg.(get_expr ~deriver bool) expr | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name); { with_path = !with_path } let attr_nobuiltin attrs = Ppx_deriving.(attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver) let attr_printer attrs = Ppx_deriving.(attrs |> attr ~deriver "printer" |> Arg.(get_attr ~deriver expr)) let attr_polyprinter attrs = Ppx_deriving.(attrs |> attr ~deriver "polyprinter" |> Arg.(get_attr ~deriver expr)) let attr_opaque attrs = Ppx_deriving.(attrs |> attr ~deriver "opaque" |> Arg.get_flag ~deriver) 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 = Ppx_deriving.quote quoter [%expr (let fprintf = Ppx_deriving_runtime.Format.fprintf in [%e printer]) [@ocaml.warning "-26"]] let pp_type_of_decl ~options ~path type_decl = let _ = parse_options options 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 ~options ~path type_decl = let _ = parse_options options 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 ~options ~path type_decl = let _ = parse_options options in [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "pp") type_decl)) (pp_type_of_decl ~options ~path type_decl)); Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "show") type_decl)) (show_type_of_decl ~options ~path type_decl))] let rec expr_of_typ quoter typ = let expr_of_typ = expr_of_typ quoter in match attr_printer typ.ptyp_attributes with | Some printer -> [%expr [%e wrap_printer quoter printer] fmt] | None -> if attr_opaque typ.ptyp_attributes 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 (attr_nobuiltin typ.ptyp_attributes) 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 | Result.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 ")" | Result.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 attr_polyprinter typ.ptyp_attributes 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 with | Rtag_patt(label, true (*empty*), []) -> #if OCAML_VERSION >= (4, 06, 0) let label = label.txt in #endif Exp.case (Pat.variant label None) [%expr Ppx_deriving_runtime.Format.pp_print_string fmt [%e str ("`" ^ label)]] | Rtag_patt(label, false, [typ]) -> #if OCAML_VERSION >= (4, 06, 0) let label = label.txt in #endif 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_patt({ 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 ~options ~path ({ ptype_loc = loc } as type_decl) = let show_opts = parse_options options in 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 } -> let constr_name = expand_path show_opts ~path name' in match attr_printer pcd_attributes, 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]] #if OCAML_VERSION >= (4, 03, 0) | 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)) #endif | 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 #if OCAML_VERSION >= (4, 03, 0) | 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 #endif ) 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 show_opts ~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 ~options ~path type_decl in let show_type = Ppx_deriving.strong_type_of_type @@ show_type_of_decl ~options ~path 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 () = Ppx_deriving.(register (create deriver ~core_type: (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])) ~type_decl_str: (fun ~options ~path type_decls -> [Str.value Recursive (List.concat (List.map (str_of_type ~options ~path) type_decls))]) ~type_decl_sig: (fun ~options ~path type_decls -> List.concat (List.map (sig_of_type ~options ~path) type_decls)) () )) ppx_deriving-4.4/src_plugins/std/000077500000000000000000000000001351063355100172035ustar00rootroot00000000000000ppx_deriving-4.4/src_plugins/std/dune000066400000000000000000000005241351063355100200620ustar00rootroot00000000000000(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-4.4/src_plugins/std/ppx_deriving_std.ml000066400000000000000000000000761351063355100231100ustar00rootroot00000000000000(* dummy module to appease dune and older version of OCaml *) ppx_deriving-4.4/src_test/000077500000000000000000000000001351063355100157075ustar00rootroot00000000000000ppx_deriving-4.4/src_test/create/000077500000000000000000000000001351063355100171525ustar00rootroot00000000000000ppx_deriving-4.4/src_test/create/dune000066400000000000000000000002061351063355100200260ustar00rootroot00000000000000(test (name test_deriving_create) (libraries oUnit ppx_deriving.runtime) (preprocess (pps ppx_deriving.create ppx_deriving.show))) ppx_deriving-4.4/src_test/create/test_deriving_create.ml000066400000000000000000000030311351063355100236720ustar00rootroot00000000000000open 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-4.4/src_test/deriving/000077500000000000000000000000001351063355100175165ustar00rootroot00000000000000ppx_deriving-4.4/src_test/deriving/dune000066400000000000000000000002411351063355100203710ustar00rootroot00000000000000(test (name test_ppx_deriving) (libraries oUnit compiler-libs.common ppx_deriving.api) (preprocess (pps ppx_deriving.ord ppx_deriving.show ppx_deriving.eq))) ppx_deriving-4.4/src_test/deriving/test_ppx_deriving.ml000066400000000000000000000016301351063355100236050ustar00rootroot00000000000000open 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)]) 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-4.4/src_test/enum/000077500000000000000000000000001351063355100166535ustar00rootroot00000000000000ppx_deriving-4.4/src_test/enum/dune000066400000000000000000000002021351063355100175230ustar00rootroot00000000000000(test (name test_deriving_enum) (libraries oUnit ppx_deriving.runtime) (preprocess (pps ppx_deriving.enum ppx_deriving.show))) ppx_deriving-4.4/src_test/enum/test_deriving_enum.ml000066400000000000000000000034451351063355100231050ustar00rootroot00000000000000open 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-4.4/src_test/eq/000077500000000000000000000000001351063355100163145ustar00rootroot00000000000000ppx_deriving-4.4/src_test/eq/dune000066400000000000000000000004221351063355100171700ustar00rootroot00000000000000(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 oUnit ppx_deriving.runtime) (preprocess (pps ppx_deriving.eq ppx_deriving.show))) ppx_deriving-4.4/src_test/eq/test_deriving_eq.cppo.ml000066400000000000000000000121601351063355100231410ustar00rootroot00000000000000open 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 Pervasives.ref [@@ocaml.warning "-3"][@@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] #if OCAML_VERSION >= (4, 03, 0) type rv = RFoo | RBar of { x: int; y: string; } [@@deriving eq] #endif 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) module List = struct type 'a t = [`Cons of 'a | `Nil] [@@deriving eq] end type 'a std_clash = 'a List.t option [@@deriving eq] #if OCAML_VERSION >= (4, 03, 0) 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)) #endif let test_result_result ctxt = let open Result in 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; #if OCAML_VERSION >= (4, 03, 0) "test_result" >:: test_result; #endif "test_result_result" >:: test_result_result; ] let _ = run_test_tt_main suite ppx_deriving-4.4/src_test/fold/000077500000000000000000000000001351063355100166335ustar00rootroot00000000000000ppx_deriving-4.4/src_test/fold/dune000066400000000000000000000004101351063355100175040ustar00rootroot00000000000000(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 oUnit ppx_deriving.runtime) (preprocess (pps ppx_deriving.fold))) ppx_deriving-4.4/src_test/fold/test_deriving_fold.cppo.ml000066400000000000000000000026331351063355100240030ustar00rootroot00000000000000open 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 Pervasives.ref list [@@ocaml.warning "-3"] [@@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) #if OCAML_VERSION >= (4, 03, 0) type 'a btreer = Node of { lft: 'a btree; elt: 'a; rgt: 'a btree } | Leaf [@@deriving fold] #endif type 'a ty = 'a * int list [@@deriving fold] #if OCAML_VERSION >= (4, 03, 0) 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)) #endif type ('a, 'b) result_res = ('a, 'b) Result.result [@@deriving fold] let test_result_result ctxt = let f = fold_result_res (+) (-) in assert_equal ~printer:string_of_int 1 (f 0 (Result.Ok 1)); assert_equal ~printer:string_of_int (-1) (f 0 (Result.Error 1)) let suite = "Test deriving(fold)" >::: [ "test_btree" >:: test_btree; #if OCAML_VERSION >= (4, 03, 0) "test_result" >:: test_result; #endif "test_result_result" >:: test_result_result; "test_reflist" >:: test_reflist; ] let _ = run_test_tt_main suite ppx_deriving-4.4/src_test/iter/000077500000000000000000000000001351063355100166525ustar00rootroot00000000000000ppx_deriving-4.4/src_test/iter/dune000066400000000000000000000004321351063355100175270ustar00rootroot00000000000000(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 oUnit ppx_deriving.runtime) (preprocess (pps ppx_deriving.iter ppx_deriving.show))) ppx_deriving-4.4/src_test/iter/test_deriving_iter.cppo.ml000066400000000000000000000040041351063355100240330ustar00rootroot00000000000000open 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 Pervasives.ref list [@@ocaml.warning "-3"] [@@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 Pervasives.ref list [@@ocaml.warning "-3"] [@@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 #if OCAML_VERSION >= (4, 03, 0) type 'a btreer = Node of { lft: 'a btree; elt: 'a; rgt: 'a btree } | Leaf [@@deriving iter] #endif type 'a ty = 'a * int list [@@deriving iter] type 'a res0 = ('a, char) Result.result [@@deriving iter] let test_iter_res ctxt = let has_ok = ref false in iter_res0 (fun _ -> has_ok := true) (Result.Ok "xxx"); assert_bool "set ok" !has_ok; iter_res0 (fun _ -> has_ok := false) (Result.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-4.4/src_test/make/000077500000000000000000000000001351063355100166245ustar00rootroot00000000000000ppx_deriving-4.4/src_test/make/dune000066400000000000000000000002021351063355100174740ustar00rootroot00000000000000(test (name test_deriving_make) (libraries oUnit ppx_deriving.runtime) (preprocess (pps ppx_deriving.make ppx_deriving.show))) ppx_deriving-4.4/src_test/make/test_deriving_make.ml000066400000000000000000000034551351063355100230300ustar00rootroot00000000000000open 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] 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] 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 suite = "Test deriving(make)" >::: [ "test_no_main" >:: test_no_main; "test_main" >:: test_main; "test_no_unit" >:: test_no_unit ] let _ = run_test_tt_main suite ppx_deriving-4.4/src_test/map/000077500000000000000000000000001351063355100164645ustar00rootroot00000000000000ppx_deriving-4.4/src_test/map/dune000066400000000000000000000004261351063355100173440ustar00rootroot00000000000000(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 oUnit ppx_deriving.runtime) (preprocess (pps ppx_deriving.map ppx_deriving.show))) ppx_deriving-4.4/src_test/map/test_deriving_map.cppo.ml000066400000000000000000000151551351063355100234700ustar00rootroot00000000000000open OUnit2 module T : sig type 'a btree = Node of 'a btree * 'a * 'a btree | Leaf [@@deriving map, show] #if OCAML_VERSION >= (4, 03, 0) type 'a btreer = Noder of { lft: 'a btree; elt: 'a; rgt: 'a btree } | Leafr [@@deriving map] #endif 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] #if OCAML_VERSION >= (4, 03, 0) type 'a btreer = Noder of { lft: 'a btree; elt: 'a; rgt: 'a btree } | Leafr [@@deriving map] #endif 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 [@warning "-3"] 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 [@warning "-3"] 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) #if OCAML_VERSION >= (4, 03, 0) 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)) #endif type 'a result_result0 = ('a, bool) Result.result [@@deriving show,map] let test_map_result_result ctxt = let open Result in 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; #if OCAML_VERSION >= (4, 03, 0) "test_map_result" >:: test_map_result; #endif "test_map_result_result" >:: test_map_result_result; ] let _ = run_test_tt_main suite ppx_deriving-4.4/src_test/ord/000077500000000000000000000000001351063355100164735ustar00rootroot00000000000000ppx_deriving-4.4/src_test/ord/dune000066400000000000000000000004041351063355100173470ustar00rootroot00000000000000(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 oUnit ppx_deriving.runtime) (preprocess (pps ppx_deriving.ord))) ppx_deriving-4.4/src_test/ord/test_deriving_ord.cppo.ml000066400000000000000000000147441351063355100235110ustar00rootroot00000000000000open 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 "")) #if OCAML_VERSION >= (4, 03, 0) type rv = RFoo | RBar of { x: int; y: string; } [@@deriving ord] #endif 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) #if OCAML_VERSION >= (4, 03, 0) 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 ())) #endif let test_ord_result_result ctx = let compare_res0 = [%ord: (unit, unit) Result.result] in let open 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 Pervasives.ref [@@ocaml.warning "-3"] [@@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) 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; #if OCAML_VERSION >= (4, 03, 0) "test_ord_result" >:: test_ord_result; #endif "test_ord_result_result" >:: test_ord_result_result; ] let _ = run_test_tt_main suite ppx_deriving-4.4/src_test/runtime/000077500000000000000000000000001351063355100173725ustar00rootroot00000000000000ppx_deriving-4.4/src_test/runtime/dune000066400000000000000000000004061351063355100202500ustar00rootroot00000000000000(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 oUnit ppx_deriving.runtime) (preprocess (pps ppx_deriving.eq ppx_deriving.show))) ppx_deriving-4.4/src_test/runtime/test_runtime.cppo.ml000066400000000000000000000014261351063355100234110ustar00rootroot00000000000000let test_ref_included (x : 'a ref) = (x : 'a Ppx_deriving_runtime.ref) let test_ref_qualified (x : 'a ref) = (x : 'a Ppx_deriving_runtime.Pervasives.ref[@ocaml.warning "-3"]) 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.result) = (x : ('a, 'b) Ppx_deriving_runtime.Result.t) #if OCAML_VERSION >= (4, 06, 0) let test_result_included (x : ('a, 'b) result) = (x : ('a, 'b) Ppx_deriving_runtime.Result.t) #endif #if OCAML_VERSION >= (4, 07, 0) let test_result_in_stdlib (x : ('a, 'b) Stdlib.result) = (x : ('a, 'b) Ppx_deriving_runtime.Result.t) #endif ppx_deriving-4.4/src_test/show/000077500000000000000000000000001351063355100166675ustar00rootroot00000000000000ppx_deriving-4.4/src_test/show/dune000066400000000000000000000004101351063355100175400ustar00rootroot00000000000000(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 oUnit ppx_deriving.runtime) (preprocess (pps ppx_deriving.show))) ppx_deriving-4.4/src_test/show/test_deriving_show.cppo.ml000066400000000000000000000231071351063355100240720ustar00rootroot00000000000000open 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 Pervasives.ref [@@ocaml.warning "-3"] [@@deriving show] type r3 = int Pervasives.ref ref [@@ocaml.warning "-3"] [@@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")) #if OCAML_VERSION >= (4, 03, 0) type rv = RFoo | RBar of { x: int; y: string } | RBaz of { z: string } [@@deriving show] let test_variant_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"})) #endif 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) #if OCAML_VERSION >= (4, 03, 0) 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"))) #endif type i_has_result_result = I_has of (bool, string) Result.result [@@deriving show] let test_result_result ctxt = let open Result in assert_equal ~printer "(Ok 100)" ([%show: (int, bool) result] (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_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; #if OCAML_VERSION >= (4, 03, 0) "test_result" >:: test_result; #endif "test_result_result" >:: test_result_result; ] let _ = run_test_tt_main suite