pax_global_header00006660000000000000000000000064127333163240014516gustar00rootroot0000000000000052 comment=b380f900fa09636aacff727f9ca8c99386dcc8b6 ppx_deriving-4.0/000077500000000000000000000000001273331632400140575ustar00rootroot00000000000000ppx_deriving-4.0/.gitignore000066400000000000000000000001021273331632400160400ustar00rootroot00000000000000*.native *.byte *.docdir _build *.install pkg/META src_test/_tags ppx_deriving-4.0/.merlin000066400000000000000000000001371273331632400153470ustar00rootroot00000000000000B _build/** S src*/** PKG compiler-libs.common ppx_tools.metaquot oUnit cppo_ocamlbuild result ppx_deriving-4.0/.travis.yml000066400000000000000000000006641273331632400161760ustar00rootroot00000000000000language: c script: - echo "yes" | sudo add-apt-repository ppa:avsm/ocaml42+opam12 - sudo apt-get update -qq - sudo apt-get install -qq opam ocaml-native-compilers - export OPAMYES=1 - opam init - eval `opam config env` - opam pin add -n ppx_tools git://github.com/alainfrisch/ppx_tools#4.02 - opam pin add -n -k path ppx_deriving . - opam install --deps-only -d -t ppx_deriving - opam install -d -t -v ppx_deriving ppx_deriving-4.0/CHANGELOG.md000066400000000000000000000056021273331632400156730ustar00rootroot00000000000000Changelog ========= 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. 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.0/LICENSE.txt000066400000000000000000000021001273331632400156730ustar00rootroot00000000000000Copyright (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.0/Makefile000066400000000000000000000034321273331632400155210ustar00rootroot00000000000000include $(shell ocamlc -where)/Makefile.config OCAMLBUILD=ocamlbuild -j 0 -use-ocamlfind -classic-display \ -plugin-tag 'package(cppo_ocamlbuild)' build: cp pkg/META.in pkg/META ocaml pkg/build.ml native=true native-dynlink=true test: build rm -rf _build/src_test/ $(OCAMLBUILD) src_test/test_ppx_deriving.byte -- examples: build rm -rf _build/src_examples/ $(OCAMLBUILD) src_examples/print_test.byte doc: $(OCAMLBUILD) doc/api.docdir/index.html \ -docflags -t -docflag "API reference for ppx_deriving" \ -docflags '-colorize-code -short-functors -charset utf-8' \ -docflags '-css-style style.css' cp doc/style.css api.docdir/ clean: ocamlbuild -clean .PHONY: build test doc clean examples 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/ api.docdir/* 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 VERSION := $$(opam query --version) NAME_VERSION := $$(opam query --name-version) ARCHIVE := $$(opam query --archive) release: git tag -a v$(VERSION) -m "Version $(VERSION)." git push origin v$(VERSION) opam publish prepare $(NAME_VERSION) $(ARCHIVE) cp -t $(NAME_VERSION) descr grep -Ev '^(name|version):' opam >$(NAME_VERSION)/opam opam publish submit $(NAME_VERSION) rm -rf $(NAME_VERSION) install: ocamlfind remove ppx_deriving grep -E '^[[:space:]]+' ppx_deriving.install | \ awk '{ print $$1 }' | \ sed -e 's:"?*::g' | \ xargs ocamlfind install ppx_deriving mv `ocamlfind query ppx_deriving -suffix /ppx_deriving_main.native` `ocamlfind query ppx_deriving -suffix /ppx_deriving$(EXE)` .PHONY: gh-pages release ppx_deriving-4.0/README.md000066400000000000000000000457401273331632400153500ustar00rootroot00000000000000[@@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/whitequark/ppx_deriving_yojson#usage [protobuf]: https://github.com/whitequark/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 -> bytes end # M.show_myfpclass FP_normal;; - : bytes = "FP_normal" ``` The module is used to demonstrate that `show_myfpclass` really accepts `Pervasives.fpclass`, and not just `M.myfpclass`. The need to repeat the type definition may look tedious, but consider this: if the definition was automatically imported from the declaration point, how would you attach attributes to refine the behavior of the deriving plugin? Nevertheless, for the case where no attributes need to be attached, it is possible to use [ppx_import](https://github.com/whitequark/ppx_import#usage) to automatically pull in the type definition. 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 ] -> bytes = # show (`B 1);; - : bytes = "`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 };; - : bytes = "{ 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. 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 is 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 ``` 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. ### 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://whitequark.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://whitequark.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://whitequark.github.io/ppx_deriving/Ppx_deriving.html#VALmangle_type_decl) and [Ppx_deriving.mangle_lid](http://whitequark.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://whitequark.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://whitequark.github.io/ppx_deriving/Ppx_deriving.html#VALpoly_fun_of_type_decl) for derived functions, [Ppx_deriving.poly_arrow_of_type_decl](http://whitequark.github.io/ppx_deriving/Ppx_deriving.html#VALpoly_arrow_of_type_decl) for signatures, and [Ppx_deriving.poly_apply_of_type_decl](http://whitequark.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://whitequark.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://whitequark.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.0/_tags000066400000000000000000000021741273331632400151030ustar00rootroot00000000000000true: warn(@5@8@10@11@12@14@23@24@26@29@40), bin_annot, safe_string, debug, cppo_V_OCAML "data": -traverse "src": include : package(dynlink), package(compiler-libs.common), package(ppx_tools.metaquot), package(result) : package(findlib.dynload), predicate(ppx_driver) : linkall : package(compiler-libs.common), package(ppx_tools.metaquot) : debug, package(oUnit ppx_tools compiler-libs.common result), use_deriving "src_test/test_deriving_show.ml": deriving(show) "src_test/test_deriving_eq.ml": deriving(eq) "src_test/test_deriving_ord.ml": deriving(ord) "src_test/test_deriving_enum.ml": deriving(show,enum) "src_test/test_deriving_iter.ml": deriving(iter) "src_test/test_deriving_map.ml": deriving(show,map) "src_test/test_deriving_fold.ml": deriving(fold) "src_test/test_deriving_create.ml": deriving(show,create) "src_test/test_deriving_make.ml": deriving(show,make) "src_test/test_ppx_deriving.ml": deriving(show,ord,eq) "src_examples/print_test.ml": deriving(show), ppx_native ppx_deriving-4.0/descr000066400000000000000000000002671273331632400151070ustar00rootroot00000000000000Type-driven code generation for OCaml >=4.02 ppx_deriving provides common infrastructure for generating code based on type definitions, and a set of useful plugins for common tasks. ppx_deriving-4.0/doc/000077500000000000000000000000001273331632400146245ustar00rootroot00000000000000ppx_deriving-4.0/doc/api.odocl000066400000000000000000000000521273331632400164140ustar00rootroot00000000000000src/Ppx_deriving src/Ppx_deriving_runtime ppx_deriving-4.0/doc/style.css000066400000000000000000000064421273331632400165040ustar00rootroot00000000000000/* A style for ocamldoc. Daniel C. Buenzli */ /* Reset a few things. */ html,body,div,span,applet,object,iframe,h1,h2,h3,h4,h5,h6,p,blockquote,pre, a,abbr,acronym,address,big,cite,code,del,dfn,em,font,img,ins,kbd,q,s,samp, small,strike,strong,sub,sup,tt,var,b,u,i,center,dl,dt,dd,ol,ul,li,fieldset, form,label,legend,table,caption,tbody,tfoot,thead,tr,th,td { margin: 0; padding: 0; border: 0 none; outline: 0; font-size: 100%; font-weight: inherit; font-style:inherit; font-family:inherit; line-height: inherit; vertical-align: baseline; text-align:inherit; color:inherit; background: transparent; } table { border-collapse: collapse; border-spacing: 0; } /* Basic page layout */ body { font: normal 10pt/1.375em helvetica, arial, sans-serif; text-align:left; margin: 1.375em 10%; min-width: 40ex; max-width: 72ex; color: black; background: transparent /* url(line-height-22.gif) */; } b { font-weight: bold } em { font-style: italic } tt, code, pre { font-family: WorkAroundWebKitAndMozilla, monospace; font-size: 1em; } pre code { font-size : inherit; } .codepre { margin-bottom:1.375em /* after code example we introduce space. */ } .superscript,.subscript { font-size : 0.813em; line-height:0; margin-left:0.4ex;} .superscript { vertical-align: super; } .subscript { vertical-align: sub; } /* ocamldoc markup workaround hacks */ hr, hr + br, div + br, center + br, span + br, ul + br, ol + br, pre + br { display: none } /* annoying */ div.info + br { display:block} .codepre br + br { display: none } h1 + pre { margin-bottom:1.375em} /* Toplevel module description */ /* Sections and document divisions */ /* .navbar { margin-bottom: -1.375em } */ h1 { font-weight: bold; font-size: 1.5em; /* margin-top:1.833em; */ margin-top:0.917em; padding-top:0.875em; border-top-style:solid; border-width:1px; border-color:#AAA; } h2 { font-weight: bold; font-size: 1.313em; margin-top: 1.048em } h3 { font-weight: bold; font-size: 1.125em; margin-top: 1.222em } h3 { font-weight: bold; font-size: 1em; margin-top: 1.375em} h4 { font-style: italic; } /* Used by OCaml's own library documentation. */ h6 { font-weight: bold; font-size: 1.125em; margin-top: 1.222em } .h7 { font-weight: bold; font-size: 1em; margin-top: 1.375em } p { margin-top: 1.375em } pre { margin-top: 1.375em } .info { margin: 0.458em 0em -0.458em 2em;}/* Description of types values etc. */ td .info { margin:0; padding:0; margin-left: 2em;} /* Description in indexes */ ul, ol { margin-top:0.688em; padding-bottom:0.687em; list-style-position:outside} ul + p, ol + p { margin-top: 0em } ul { list-style-type: square } /* h2 + ul, h3 + ul, p + ul { } */ ul > li { margin-left: 1.375em; } ol > li { margin-left: 1.7em; } /* Links */ a, a:link, a:visited, a:active, a:hover { color : #00B; text-decoration: none } a:hover { text-decoration : underline } *:target {background-color: #FFFF99;} /* anchor highlight */ /* Code */ .keyword { font-weight: bold; } .comment { color : red } .constructor { color : green } .string { color : brown } .warning { color : red ; font-weight : bold } /* Functors */ .paramstable { border-style : hidden ; padding-bottom:1.375em} .paramstable code { margin-left: 1ex; margin-right: 1ex } .sig_block {margin-left: 1em} /* Images */ img { margin-top: 1.375em } ppx_deriving-4.0/myocamlbuild.ml000066400000000000000000000020541273331632400170730ustar00rootroot00000000000000open Ocamlbuild_plugin let split delim str = let rec loop i last acc = if i = String.length str then String.sub str last (i - last) :: acc else if ((String.get str i) = delim) then loop (i + 1) (i + 1) (String.sub str last (i - last) :: acc) else loop (i + 1) last acc in List.rev (loop 0 0 []) let plugin_cmas names = split ',' names |> List.map (fun name -> "src_plugins/ppx_deriving_" ^ name ^ ".cma") |> String.concat " " let () = dispatch (fun phase -> Ocamlbuild_cppo.dispatcher phase; match phase with | After_rules -> pflag ["ocaml"; "compile"; "ppx_byte"] "deriving" (fun names -> S[A"-ppx"; A("src/ppx_deriving_main.byte " ^ (plugin_cmas names))]); pflag ["ocaml"; "compile"; "ppx_native"] "deriving" (fun names -> S[A"-ppx"; A("src/ppx_deriving_main.native " ^ (plugin_cmas names))]); flag ["ocaml"; "link"; "byte"; "use_deriving"] & A"src/ppx_deriving_runtime.cma"; flag ["ocaml"; "link"; "native"; "use_deriving"] & A"src/ppx_deriving_runtime.cmxa"; | _ -> ()) ppx_deriving-4.0/opam000066400000000000000000000017531273331632400147440ustar00rootroot00000000000000opam-version: "1.2" name: "ppx_deriving" version: "4.0" maintainer: "whitequark " authors: [ "whitequark " ] license: "MIT" homepage: "https://github.com/whitequark/ppx_deriving" doc: "https://whitequark.github.io/ppx_deriving" bug-reports: "https://github.com/whitequark/ppx_deriving/issues" dev-repo: "https://github.com/whitequark/ppx_deriving.git" tags: [ "syntax" ] substs: [ "pkg/META" ] build: [ # If there is no native dynlink, we can't use native builds "ocaml" "pkg/build.ml" "native=%{ocaml-native-dynlink}%" "native-dynlink=%{ocaml-native-dynlink}%" ] build-test: [ "ocamlbuild" "-classic-display" "-use-ocamlfind" "src_test/test_ppx_deriving.byte" "--" ] build-doc: [ make "doc" ] depends: [ "ocamlbuild" {build} "ocamlfind" {build & >= "1.6.0"} "cppo" {build} "ppx_tools" {>= "4.02.3"} "result" "ounit" {test} ] available: [ ocaml-version >= "4.02.1" & opam-version >= "1.2" ] ppx_deriving-4.0/pkg/000077500000000000000000000000001273331632400146405ustar00rootroot00000000000000ppx_deriving-4.0/pkg/META.in000066400000000000000000000111641273331632400157210ustar00rootroot00000000000000version = "%{version}%" description = "Type-driven code generation" ppx(-custom_ppx) = "./ppx_deriving" requires = "ppx_deriving.runtime" package "runtime" ( version = "%{version}%" requires = "result" description = "Runtime component of built-in derivers" archive(byte) = "ppx_deriving_runtime.cma" archive(native) = "ppx_deriving_runtime.cmxa" exists_if = "ppx_deriving_runtime.cma" ) package "api" ( version = "%{version}%" description = "Plugin API for ppx_deriving" requires = "dynlink compiler-libs.common ppx_tools result" archive(byte) = "ppx_deriving.cma" archive(native) = "ppx_deriving.cmxa" exists_if = "ppx_deriving.cma" ) package "main" ( version = "%{version}%" description = "Runner for ppx_deriving" requires = "ppx_deriving.api" archive(byte) = "ppx_deriving_main.cma" archive(native) = "ppx_deriving_main.cmxa" exists_if = "ppx_deriving_main.cma" ) package "std" ( version = "%{version}%" description = "Meta-package for all built-in derivers" requires = "ppx_deriving.show ppx_deriving.eq ppx_deriving.ord" requires += "ppx_deriving.enum ppx_deriving.iter ppx_deriving.map" requires += "ppx_deriving.fold ppx_deriving.create ppx_deriving.make" ) package "show" ( version = "%{version}%" description = "[@@deriving show]" requires(-ppx_driver) = "ppx_deriving" ppxopt(-ppx_driver,-custom_ppx) = "ppx_deriving,./ppx_deriving_show.cma" requires(ppx_driver) = "ppx_deriving.api" archive(ppx_driver, byte) = "ppx_deriving_show.cma" archive(ppx_driver, native) = "ppx_deriving_show.cmxa" exists_if = "ppx_deriving_show.cma" ) package "eq" ( version = "%{version}%" description = "[@@deriving eq]" requires(-ppx_driver) = "ppx_deriving" ppxopt(-ppx_driver,-custom_ppx) = "ppx_deriving,./ppx_deriving_eq.cma" requires(ppx_driver) = "ppx_deriving.api" archive(ppx_driver, byte) = "ppx_deriving_eq.cma" archive(ppx_driver, native) = "ppx_deriving_eq.cmxa" exists_if = "ppx_deriving_eq.cma" ) package "ord" ( version = "%{version}%" description = "[@@deriving ord]" requires(-ppx_driver) = "ppx_deriving" ppxopt(-ppx_driver,-custom_ppx) = "ppx_deriving,./ppx_deriving_ord.cma" requires(ppx_driver) = "ppx_deriving.api" archive(ppx_driver, byte) = "ppx_deriving_ord.cma" archive(ppx_driver, native) = "ppx_deriving_ord.cmxa" exists_if = "ppx_deriving_ord.cma" ) package "enum" ( version = "%{version}%" description = "[@@deriving enum]" requires(-ppx_driver) = "ppx_deriving" ppxopt(-ppx_driver,-custom_ppx) = "ppx_deriving,./ppx_deriving_enum.cma" requires(ppx_driver) = "ppx_deriving.api" archive(ppx_driver, byte) = "ppx_deriving_enum.cma" archive(ppx_driver, native) = "ppx_deriving_enum.cmxa" exists_if = "ppx_deriving_enum.cma" ) package "iter" ( version = "%{version}%" description = "[@@deriving iter]" requires(-ppx_driver) = "ppx_deriving" ppxopt(-ppx_driver,-custom_ppx) = "ppx_deriving,./ppx_deriving_iter.cma" requires(ppx_driver) = "ppx_deriving.api" archive(ppx_driver, byte) = "ppx_deriving_iter.cma" archive(ppx_driver, native) = "ppx_deriving_iter.cmxa" exists_if = "ppx_deriving_iter.cma" ) package "map" ( version = "%{version}%" description = "[@@deriving map]" requires(-ppx_driver) = "ppx_deriving" ppxopt(-ppx_driver,-custom_ppx) = "ppx_deriving,./ppx_deriving_map.cma" requires(ppx_driver) = "ppx_deriving.api" archive(ppx_driver, byte) = "ppx_deriving_map.cma" archive(ppx_driver, native) = "ppx_deriving_map.cmxa" exists_if = "ppx_deriving_map.cma" ) package "fold" ( version = "%{version}%" description = "[@@deriving fold]" requires(-ppx_driver) = "ppx_deriving" ppxopt(-ppx_driver,-custom_ppx) = "ppx_deriving,./ppx_deriving_fold.cma" requires(ppx_driver) = "ppx_deriving.api" archive(ppx_driver, byte) = "ppx_deriving_fold.cma" archive(ppx_driver, native) = "ppx_deriving_fold.cmxa" exists_if = "ppx_deriving_fold.cma" ) package "create" ( version = "%{version}%" description = "[@@deriving create]" requires(-ppx_driver) = "ppx_deriving" ppxopt(-ppx_driver,-custom_ppx) = "ppx_deriving,./ppx_deriving_create.cma" requires(ppx_driver) = "ppx_deriving.api" archive(ppx_driver, byte) = "ppx_deriving_create.cma" archive(ppx_driver, native) = "ppx_deriving_create.cmxa" exists_if = "ppx_deriving_create.cma" ) package "make" ( version = "%{version}%" description = "[@@deriving make]" requires(-ppx_driver) = "ppx_deriving" ppxopt(-ppx_driver,-custom_ppx) = "ppx_deriving,./ppx_deriving_make.cma" requires(ppx_driver) = "ppx_deriving.api" archive(ppx_driver, byte) = "ppx_deriving_make.cma" archive(ppx_driver, native) = "ppx_deriving_make.cmxa" exists_if = "ppx_deriving_make.cma" ) ppx_deriving-4.0/pkg/build.ml000077500000000000000000000024741273331632400163030ustar00rootroot00000000000000#!/usr/bin/env ocaml #directory "pkg" #use "topkg.ml" let () = let oc = open_out "src_test/_tags" in output_string oc (if Env.native then "<*.ml>: ppx_native" else "<*.ml>: ppx_byte"); close_out oc let ocamlbuild = "ocamlbuild -use-ocamlfind -classic-display -plugin-tag 'package(cppo_ocamlbuild)'" let () = Pkg.describe "ppx_deriving" ~builder:(`Other (ocamlbuild, "_build")) [ Pkg.lib "pkg/META"; Pkg.bin ~auto:true "src/ppx_deriving_main" ~dst:"../lib/ppx_deriving/ppx_deriving"; Pkg.lib ~exts:Exts.module_library "src/ppx_deriving"; Pkg.lib ~exts:Exts.library "src/ppx_deriving_main"; Pkg.lib ~exts:Exts.module_library "src/ppx_deriving_runtime"; Pkg.lib ~exts:Exts.library "src_plugins/ppx_deriving_show"; Pkg.lib ~exts:Exts.library "src_plugins/ppx_deriving_eq"; Pkg.lib ~exts:Exts.library "src_plugins/ppx_deriving_ord"; Pkg.lib ~exts:Exts.library "src_plugins/ppx_deriving_enum"; Pkg.lib ~exts:Exts.library "src_plugins/ppx_deriving_iter"; Pkg.lib ~exts:Exts.library "src_plugins/ppx_deriving_map"; Pkg.lib ~exts:Exts.library "src_plugins/ppx_deriving_fold"; Pkg.lib ~exts:Exts.library "src_plugins/ppx_deriving_create"; Pkg.lib ~exts:Exts.library "src_plugins/ppx_deriving_make"; Pkg.doc "README.md"; Pkg.doc "LICENSE.txt"; Pkg.doc "CHANGELOG.md"; ] ppx_deriving-4.0/pkg/topkg.ml000066400000000000000000000265401273331632400163250ustar00rootroot00000000000000(*--------------------------------------------------------------------------- Copyright (c) 2014 Daniel C. Bünzli. All rights reserved. Distributed under the BSD3 license, see license at the end of the file. %%NAME%% release %%VERSION%% ---------------------------------------------------------------------------*) (* Public api *) (** Build environment access *) module type Env = sig val bool : string -> bool (** [bool key] declares [key] as being a boolean key in the environment. Specifing key=(true|false) on the command line becomes mandatory. *) val native : bool (** [native] is [bool "native"]. *) val native_dynlink : bool (** [native_dylink] is [bool "native-dynlink"] *) end (** Exts defines sets of file extensions. *) module type Exts = sig val interface : string list (** [interface] is [[".mli"; ".cmi"; ".cmti"]] *) val interface_opt : string list (** [interface_opt] is [".cmx" :: interface] *) val c_library : string list (** [c_library] is the extension for C libraries, [".a"] for unices and [".lib"] for win32 *) val c_dll_library : string list (** [c_dll_library] is the extension for C dynamic libraries [".so"] for unices and [".dll"] for win32 *) val library : string list (** [library] is [[".cma"; ".cmxa"; ".cmxs"] @ c_library] *) val module_library : string list (** [module_library] is [(interface_opt @ library)]. *) end (** Package description. *) module type Pkg = sig type builder = [ `OCamlbuild | `Other of string * string ] (** The type for build tools. Either [`OCamlbuild] or an [`Other (tool, bdir)] tool [tool] that generates its build artefacts in [bdir]. *) type moves (** The type for install moves. *) type field = ?cond:bool -> ?exts:string list -> ?dst:string -> string -> moves (** The type for field install functions. A call [field cond exts dst path] generates install moves as follows: {ul {- If [cond] is [false] (defaults to [true]), no move is generated.} {- If [exts] is present, generates a move for each path in the list [List.map (fun e -> path ^ e) exts].} {- If [dst] is present this path is used as the move destination (allows to install in subdirectories). If absent [dst] is [Filename.basename path].} *) val lib : field val bin : ?auto:bool -> field (** If [auto] is true (defaults to false) generates [path ^ ".native"] if {!Env.native} is [true] and [path ^ ".byte"] if {!Env.native} is [false]. *) val sbin : ?auto:bool -> field (** See {!bin}. *) val libexec : ?auto:bool -> field (** See {!bin}. *) val toplevel : field val share : field val share_root : field val etc : field val doc : field val misc : field val stublibs : field val man : field val describe : string -> builder:builder -> moves list -> unit (** [describe name builder moves] describes a package named [name] with builder [builder] and install moves [moves]. *) end (* Implementation *) module Topkg : sig val cmd : [`Build | `Explain | `Help ] val env : (string * bool) list val err_parse : string -> 'a val err_mdef : string -> 'a val err_miss : string -> 'a val err_file : string -> string -> 'a val warn_unused : string -> unit end = struct (* Parses the command line. The actual cmd execution occurs in the call to Pkg.describe. *) let err fmt = let k _ = exit 1 in Format.kfprintf k Format.err_formatter ("%s: " ^^ fmt ^^ "@.") Sys.argv.(0) let err_parse a = err "argument `%s' is not of the form key=(true|false)" a let err_mdef a = err "bool `%s' is defined more than once" a let err_miss a = err "argument `%s=(true|false)' is missing" a let err_file f e = err "%s: %s" f e let warn_unused k = Format.eprintf "%s: warning: environment key `%s` unused.@." Sys.argv.(0) k let cmd, env = let rec parse_env acc = function (* not t.r. *) | arg :: args -> begin try (* String.cut ... *) let len = String.length arg in let eq = String.index arg '=' in let bool = bool_of_string (String.sub arg (eq + 1) (len - eq - 1)) in let key = String.sub arg 0 eq in if key = "" then raise Exit else try ignore (List.assoc key acc); err_mdef key with | Not_found -> parse_env ((key, bool) :: acc) args with | Invalid_argument _ | Not_found | Exit -> err_parse arg end | [] -> acc in match List.tl (Array.to_list Sys.argv) with | "explain" :: args -> `Explain, parse_env [] args | ("help" | "-h" | "--help" | "-help") :: args -> `Help, parse_env [] args | args -> `Build, parse_env [] args end module Env : sig include Env val get : unit -> (string * bool) list end = struct let env = ref [] let get () = !env let add_bool key b = env := (key, b) :: !env let bool key = let b = try List.assoc key Topkg.env with | Not_found -> if Topkg.cmd = `Build then Topkg.err_miss key else true in add_bool key b; b let native = bool "native" let native_dynlink = bool "native-dynlink" end module Exts : Exts = struct let interface = [".mli"; ".cmi"; ".cmti"] let interface_opt = ".cmx" :: interface let c_library = if Sys.win32 then [".lib"] else [".a"] let c_dll_library = if Sys.win32 then [".dll"] else [".so"] let library = [".cma"; ".cmxa"; ".cmxs"] @ c_library let module_library = (interface_opt @ library) end module Pkg : Pkg = struct type builder = [ `OCamlbuild | `Other of string * string ] type moves = (string * (string * string)) list type field = ?cond:bool -> ?exts:string list -> ?dst:string -> string -> moves let str = Printf.sprintf let warn_unused () = let keys = List.map fst Topkg.env in let keys_used = List.map fst (Env.get ()) in let unused = List.find_all (fun k -> not (List.mem k keys_used)) keys in List.iter Topkg.warn_unused unused let has_suffix = Filename.check_suffix let build_strings ?(exec_sep = " ") btool bdir mvs = let no_build = [ ".cmti"; ".cmt" ] in let install = Buffer.create 1871 in let exec = Buffer.create 1871 in let rec add_mvs current = function | (field, (src, dst)) :: mvs when field = current -> if List.exists (has_suffix src) no_build then Buffer.add_string install (str "\n \"?%s/%s\" {\"%s\"}" bdir src dst) else begin Buffer.add_string exec (str "%s%s" exec_sep src); Buffer.add_string install (str "\n \"%s/%s\" {\"%s\"}" bdir src dst); end; add_mvs current mvs | (((field, _) :: _) as mvs) -> if current <> "" (* first *) then Buffer.add_string install " ]\n"; Buffer.add_string install (str "%s: [" field); add_mvs field mvs | [] -> () in Buffer.add_string exec btool; add_mvs "" mvs; Buffer.add_string install " ]\n"; Buffer.contents install, Buffer.contents exec let pr = Format.printf let pr_explanation btool bdir pkg mvs = let env = Env.get () in let install, exec = build_strings ~exec_sep:" \\\n " btool bdir mvs in pr "@["; pr "Package name: %s@," pkg; pr "Build tool: %s@," btool; pr "Build directory: %s@," bdir; pr "Environment:@, "; List.iter (fun (k,v) -> pr "%s=%b@, " k v) (List.sort compare env); pr "@,Build invocation:@,"; pr " %s@,@," exec; pr "Install file:@,"; pr "%s@," install; pr "@]"; () let pr_help () = pr "Usage example:@\n %s" Sys.argv.(0); List.iter (fun (k,v) -> pr " %s=%b" k v) (List.sort compare (Env.get ())); pr "@." let build btool bdir pkg mvs = let install, exec = build_strings btool bdir mvs in let e = Sys.command exec in if e <> 0 then exit e else let install_file = pkg ^ ".install" in try let oc = open_out install_file in output_string oc install; flush oc; close_out oc with Sys_error e -> Topkg.err_file install_file e let mvs ?(drop_exts = []) field ?(cond = true) ?(exts = []) ?dst src = if not cond then [] else let mv src dst = (field, (src, dst)) in let expand exts s d = List.map (fun e -> mv (s ^ e) (d ^ e)) exts in let dst = match dst with None -> Filename.basename src | Some dst -> dst in let files = if exts = [] then [mv src dst] else expand exts src dst in let keep (_, (src, _)) = not (List.exists (has_suffix src) drop_exts) in List.find_all keep files let lib = let drop_exts = if Env.native && not Env.native_dynlink then [ ".cmxs" ] else if not Env.native then Exts.c_library @ [".cmx"; ".cmxa"; ".cmxs" ] else [] in mvs ~drop_exts "lib" let share = mvs "share" let share_root = mvs "share_root" let etc = mvs "etc" let toplevel = mvs "toplevel" let doc = mvs "doc" let misc = mvs "misc" let stublibs = mvs "stublibs" let man = mvs "man" let bin_drops = if not Env.native then [ ".native" ] else [] let bin_mvs field ?(auto = false) ?cond ?exts ?dst src = let src, dst = if not auto then src, dst else let dst = match dst with | None -> Some (Filename.basename src) | Some _ as dst -> dst in let src = if Env.native then src ^ ".native" else src ^ ".byte" in src, dst in mvs ~drop_exts:bin_drops field ?cond ?dst src let bin = bin_mvs "bin" let sbin = bin_mvs "sbin" let libexec = bin_mvs "libexec" let describe pkg ~builder mvs = let mvs = List.sort compare (List.flatten mvs) in let btool, bdir = match builder with | `OCamlbuild -> "ocamlbuild -use-ocamlfind -classic-display", "_build" | `Other (btool, bdir) -> btool, bdir in match Topkg.cmd with | `Explain -> pr_explanation btool bdir pkg mvs | `Help -> pr_help () | `Build -> warn_unused (); build btool bdir pkg mvs end (*--------------------------------------------------------------------------- Copyright (c) 2014 Daniel C. Bünzli. All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. 3. Neither the name of Daniel C. Bünzli nor the names of contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. ---------------------------------------------------------------------------*) ppx_deriving-4.0/src/000077500000000000000000000000001273331632400146465ustar00rootroot00000000000000ppx_deriving-4.0/src/ppx_deriving.cppo.ml000066400000000000000000000524671273331632400206540ustar00rootroot00000000000000#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 open Longident open Location open Asttypes open Parsetree open Ast_helper open Ast_convenience 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; } let registry : (string, deriver) Hashtbl.t = Hashtbl.create 16 let register d = Hashtbl.add registry d.name d let lookup name = try Some (Hashtbl.find registry name) with Not_found -> None let raise_errorf ?sub ?if_highlight ?loc message = message |> Printf.kprintf (fun str -> let err = Location.error ?sub ?if_highlight ?loc str in raise (Location.Error err)) 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 declaratons 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 ({ txt = 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 ({ txt = name; loc }, _) -> raise_errorf ~loc "%s: invalid [@%s]: value expected" deriver name let get_flag ~deriver attr = match attr with | None -> false | Some ({ txt = name }, PStr []) -> true | Some ({ txt = name; loc }, _) -> raise_errorf ~loc "%s: invalid [@%s]: empty structure expected" deriver name let get_expr ~deriver conv expr = match conv expr with | Error desc -> raise_errorf ~loc:expr.pexp_loc "%s: %s expected" deriver desc | Ok v -> v end 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 = Exp.open_ ~attrs:[mkloc "ocaml.warning" !Ast_helper.default_loc, PStr [%str "-A"]] Override { txt=module_; loc=(!Ast_helper.default_loc) } 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 str prefix = String.length str >= String.length prefix && String.sub str 0 (String.length prefix) = prefix in let try_prefix prefix f = if List.exists (fun ({ txt }, _) -> starts txt 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 (fun ({ txt }, _) -> txt = name) attrs) with Not_found -> None let attr_warning expr = let loc = !default_loc in let structure = {pstr_desc = Pstr_eval (expr, []); pstr_loc = loc} in {txt = "ocaml.warning"; loc}, PStr [structure] 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 (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 } -> 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 } -> 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 } -> [name] | { 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) } -> [name] @ 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 (_,_,_,ts) -> List.map free_in ts | Rinherit t -> [free_in t] ) rows |> List.concat |> List.concat | _ -> assert false in let uniq lst = let module StringSet = Set.Make(String) in lst |> StringSet.of_list |> StringSet.elements 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 -> 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 -> 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 -> 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 -> 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 -> 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 -> Typ.arrow Label.nolabel (fn (Typ.var name)) typ) type_ext typ let core_type_of_type_decl { ptype_name = { txt = name }; ptype_params } = Typ.constr (mknoloc (Lident 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 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, [] | { pexp_desc = Pexp_apply ({ pexp_desc = Pexp_ident name }, [label, { pexp_desc = Pexp_record (options, None) }]) } when label = Label.nolabel -> name, options |> List.map (fun ({ txt }, expr) -> String.concat "." (Longident.flatten txt), expr) | { pexp_loc } -> raise_errorf ~loc:pexp_loc "Unrecognized [@@deriving] option syntax" in let name, loc = String.concat "_" (Longident.flatten name.txt), name.loc in let is_optional, options = match List.assoc "optional" options with | exception Not_found -> false, options | expr -> Arg.(get_expr ~deriver:name bool) expr, List.remove_assoc "optional" options in match lookup name with | Some deriver -> items @ ((fn deriver) ~options ~path:(!path) arg) | 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 -> [String.capitalize (Filename.(basename (chop_suffix filename ".ml")))] 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 name with | Some { 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 name with | Some { 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); 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 ppx_deriving-4.0/src/ppx_deriving.mli000066400000000000000000000344041273331632400200540ustar00rootroot00000000000000(** Public API of [ppx_deriving] executable. *) open Parsetree (** {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 (** 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} *) (** [raise_error] is a shorthand for raising [Location.Error] with the result of [Location.errorf]. *) val raise_errorf : ?sub:Location.error list -> ?if_highlight:string -> ?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 -> string 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 -> string -> '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 : (string -> '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 -> string -> '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 : (string -> '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.0/src/ppx_deriving_main.cppo.ml000066400000000000000000000044301273331632400216430ustar00rootroot00000000000000#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; Fl_dynload.load_packages [pkg] 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 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 -> Ppx_deriving.mapper.Ast_mapper.structure mapper items in { Ppx_deriving.mapper with Ast_mapper.structure } let () = Ast_mapper.register "ppx_deriving" mapper ppx_deriving-4.0/src/ppx_deriving_main.mllib000066400000000000000000000000221273331632400213630ustar00rootroot00000000000000ppx_deriving_main ppx_deriving-4.0/src/ppx_deriving_runtime.ml000066400000000000000000000024651273331632400214500ustar00rootroot00000000000000module Predef = struct type _int = int type _char = char type _string = string type _float = float type _bool = bool type _unit = unit type _exn = exn type 'a _array = 'a array type 'a _list = 'a list type 'a _option = 'a option = None | Some of 'a type _nativeint = nativeint type _int32 = int32 type _int64 = int64 type 'a _lazy_t = 'a lazy_t type _bytes = bytes end type int = Predef._int type char = Predef._char type string = Predef._string type float = Predef._float type bool = Predef._bool type unit = Predef._unit type exn = Predef._exn type 'a array = 'a Predef._array type 'a list = 'a Predef._list type 'a option = 'a Predef._option = None | Some of 'a type nativeint = Predef._nativeint type int32 = Predef._int32 type int64 = Predef._int64 type 'a lazy_t = 'a Predef._lazy_t type bytes = Predef._bytes module Pervasives = 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 = Result include Pervasives ppx_deriving-4.0/src/ppx_deriving_runtime.mli000066400000000000000000000071571273331632400216240ustar00rootroot00000000000000(** 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} *) (** The {!Predef} module is necessary in absence of a [type nonrec] construct. *) module Predef : sig type _int = int type _char = char type _string = string type _float = float type _bool = bool (* = false | true *) (* see PR5936, GPR76, GPR234 *) type _unit = unit (* = () *) type _exn = exn type 'a _array = 'a array type 'a _list = 'a list (* = [] | 'a :: 'a list *) type 'a _option = 'a option = None | Some of 'a type _nativeint = nativeint type _int32 = int32 type _int64 = int64 type 'a _lazy_t = 'a lazy_t type _bytes = bytes end type int = Predef._int type char = Predef._char type string = Predef._string type float = Predef._float type bool = Predef._bool type unit = Predef._unit type exn = Predef._exn type 'a array = 'a Predef._array type 'a list = 'a Predef._list type 'a option = 'a Predef._option = None | Some of 'a type nativeint = Predef._nativeint type int32 = Predef._int32 type int64 = Predef._int64 type 'a lazy_t = 'a Predef._lazy_t type bytes = Predef._bytes (** {2 Predefined modules} {3 Operations on predefined types} *) 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) 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) 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) ppx_deriving-4.0/src_examples/000077500000000000000000000000001273331632400165445ustar00rootroot00000000000000ppx_deriving-4.0/src_examples/print_test.ml000066400000000000000000000403161273331632400212750ustar00rootroot00000000000000 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.0/src_plugins/000077500000000000000000000000001273331632400164075ustar00rootroot00000000000000ppx_deriving-4.0/src_plugins/ppx_deriving_create.cppo.ml000066400000000000000000000132451273331632400237270ustar00rootroot00000000000000open 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.0/src_plugins/ppx_deriving_create.mllib000066400000000000000000000000241273331632400234450ustar00rootroot00000000000000ppx_deriving_create ppx_deriving-4.0/src_plugins/ppx_deriving_enum.cppo.ml000066400000000000000000000116031273331632400234240ustar00rootroot00000000000000#if OCAML_VERSION < (4, 03, 0) #define Pcstr_tuple(core_types) core_types #endif 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 -> (* TODO: use row_field location instead of ptyp_loc when fixed in Parsetree *) match row_field with | Rinherit _ -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for inherited variant cases" deriver | Rtag (name, attrs, true, []) -> map acc mappings attrs { txt = name; loc = ptyp_loc } | Rtag _ -> raise_errorf ~loc:ptyp_loc "%s can be derived only for argumentless constructors" deriver) (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.0/src_plugins/ppx_deriving_enum.mllib000066400000000000000000000000221273331632400231440ustar00rootroot00000000000000ppx_deriving_enum ppx_deriving-4.0/src_plugins/ppx_deriving_eq.cppo.ml000066400000000000000000000210231273331632400230620ustar00rootroot00000000000000#if OCAML_VERSION < (4, 03, 0) #define Pcstr_tuple(core_types) core_types #endif 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_type = typ } -> app (expr_of_typ quoter typ) [evar (argl `lhs n); evar (argl `rhs n)]) 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 _ _ -> 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.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 match field with | Rtag (label, _, true (*empty*), []) -> Exp.case (pdup (fun _ -> Pat.variant label None)) [%expr true] | Rtag (label, _, false, [typ]) -> Exp.case (pdup (fun var -> Pat.variant label (Some (pvar var)))) (app (expr_of_typ typ) [evar "lhs"; evar "rhs"]) | Rinherit ({ ptyp_desc = Ptyp_constr (tname, _) } as typ) -> Exp.case (pdup (fun var -> Pat.alias (Pat.type_ tname) (mknoloc var))) (app (expr_of_typ typ) [evar "lhs"; evar "rhs"]) | _ -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ))) @ [Exp.case (pvar "_") [%expr false]] in [%expr fun lhs rhs -> [%e Exp.match_ [%expr lhs, rhs] cases]] | { ptyp_desc = Ptyp_var name } -> evar ("poly_"^name) | { ptyp_desc = Ptyp_alias (typ, _) } -> expr_of_typ typ | { ptyp_loc } -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ) let str_of_type ~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_name = { txt = name }; pld_type; pld_attributes; pld_loc } -> with_default_loc pld_loc @@ fun () -> (* combine attributes of type and label *) let attrs = pld_type.ptyp_attributes @ pld_attributes in let pld_type = {pld_type with ptyp_attributes=attrs} in let field obj = Exp.field obj (mknoloc (Lident name)) in app (expr_of_typ quoter pld_type) [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 (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.0/src_plugins/ppx_deriving_eq.mllib000066400000000000000000000000201273331632400226030ustar00rootroot00000000000000ppx_deriving_eq ppx_deriving-4.0/src_plugins/ppx_deriving_fold.cppo.ml000066400000000000000000000141311273331632400234030ustar00rootroot00000000000000#if OCAML_VERSION < (4, 03, 0) #define Pcstr_tuple(core_types) core_types #endif 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.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 -> match field with | Rtag (label, _, true (*empty*), []) -> Exp.case (Pat.variant label None) [%expr acc] | Rtag (label, _, false, [typ]) -> Exp.case (Pat.variant label (Some [%pat? x])) [%expr [%e expr_of_typ typ] acc x] | Rinherit ({ ptyp_desc = Ptyp_constr (tname, _) } as typ) -> Exp.case [%pat? [%p Pat.type_ tname] as x] [%expr [%e expr_of_typ typ] acc x] | _ -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ)) in Exp.function_ cases | { ptyp_desc = Ptyp_var name } -> evar ("poly_"^name) | { ptyp_desc = Ptyp_alias (typ, name) } -> [%expr fun acc x -> [%e evar ("poly_"^name)] ([%e expr_of_typ typ] acc x) x] | { ptyp_loc } -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ) 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 }; pld_type = typ } -> [%expr [%e expr_of_typ typ] 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 }; pld_type } -> [%expr [%e expr_of_typ pld_type] 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 (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 = Ppx_deriving.core_type_of_type_decl type_decl in let acc = Typ.var Ppx_deriving.(fresh_var (free_vars_in_core_type typ)) in let polymorphize = Ppx_deriving.poly_arrow_of_type_decl (fun var -> [%type: [%t acc] -> [%t var] -> [%t acc]]) type_decl in [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl)) (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.0/src_plugins/ppx_deriving_fold.mllib000066400000000000000000000000221273331632400231240ustar00rootroot00000000000000ppx_deriving_fold ppx_deriving-4.0/src_plugins/ppx_deriving_iter.cppo.ml000066400000000000000000000135111273331632400234230ustar00rootroot00000000000000#if OCAML_VERSION < (4, 03, 0) #define Pcstr_tuple(core_types) core_types #endif 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 -> match field with | Rtag (label, _, true (*empty*), []) -> Exp.case (Pat.variant label None) [%expr ()] | Rtag (label, _, false, [typ]) -> Exp.case (Pat.variant label (Some [%pat? x])) [%expr [%e expr_of_typ typ] x] | Rinherit ({ ptyp_desc = Ptyp_constr (tname, _) } as typ) -> Exp.case [%pat? [%p Pat.type_ tname] as x] [%expr [%e expr_of_typ typ] x] | _ -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ)) in Exp.function_ cases | { ptyp_desc = Ptyp_var name } -> [%expr ([%e evar ("poly_"^name)] : [%t Typ.var name] -> unit)] | { ptyp_desc = Ptyp_alias (typ, name) } -> [%expr fun x -> [%e evar ("poly_"^name)] x; [%e expr_of_typ typ] x] | { ptyp_loc } -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ) 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 }; pld_type = typ } -> [%expr [%e expr_of_typ typ] [%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 }; pld_type } -> [%expr [%e expr_of_typ pld_type] [%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 (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.0/src_plugins/ppx_deriving_iter.mllib000066400000000000000000000000221273331632400231430ustar00rootroot00000000000000ppx_deriving_iter ppx_deriving-4.0/src_plugins/ppx_deriving_make.cppo.ml000066400000000000000000000143411273331632400233770ustar00rootroot00000000000000open 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.0/src_plugins/ppx_deriving_make.mllib000066400000000000000000000000241273331632400231170ustar00rootroot00000000000000ppx_deriving_create ppx_deriving-4.0/src_plugins/ppx_deriving_map.cppo.ml000066400000000000000000000133551273331632400232430ustar00rootroot00000000000000#if OCAML_VERSION < (4, 03, 0) #define Pcstr_tuple(core_types) core_types #endif 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 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 typ]] | true, [%type: [%t? typ] array] -> [%expr Ppx_deriving_runtime.Array.map [%e expr_of_typ typ]] | true, [%type: [%t? typ] option] -> [%expr function None -> None | Some x -> Some ([%e expr_of_typ typ] x)] | true, [%type: ([%t? ok_t], [%t? err_t]) Result.result] -> [%expr function | Result.Ok ok -> Result.Ok ([%e expr_of_typ ok_t] ok) | Result.Error err -> Result.Error ([%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 tuple (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 -> match field with | Rtag (label, _, true (*empty*), []) -> Exp.case (Pat.variant label None) (Exp.variant label None) | Rtag (label, _, false, [typ]) -> Exp.case (Pat.variant label (Some [%pat? x])) (Exp.variant label (Some [%expr [%e expr_of_typ typ] x])) | Rinherit ({ ptyp_desc = Ptyp_constr (tname, _) } as typ) -> Exp.case [%pat? [%p Pat.type_ tname] as x] [%expr [%e expr_of_typ typ] x] | _ -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ)) in Exp.function_ cases | { ptyp_desc = Ptyp_var name } -> evar ("poly_"^name) | { ptyp_desc = Ptyp_alias (typ, name) } -> [%expr fun x -> [%e evar ("poly_"^name)] ([%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) 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, _ -> 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 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 }; pld_type = typ } -> n, [%expr [%e expr_of_typ typ] [%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 }; pld_type } -> name, [%expr [%e expr_of_typ pld_type] [%e Exp.field (evar "x") (mknoloc (Lident name))]]) in [%expr fun x -> [%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 (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 ~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.0/src_plugins/ppx_deriving_map.mllib000066400000000000000000000000211273331632400227540ustar00rootroot00000000000000ppx_deriving_map ppx_deriving-4.0/src_plugins/ppx_deriving_ord.cppo.ml000066400000000000000000000231271273331632400232500ustar00rootroot00000000000000#if OCAML_VERSION < (4, 03, 0) #define Pcstr_tuple(core_types) core_types #endif 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 = function | [] -> [%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 Pervasives.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 }; pld_type = typ } -> app (expr_of_typ quoter typ) [evar (argl `lhs n); evar (argl `rhs n)]) 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: _] | [%type: unit]) -> [%expr fun _ _ -> 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]) -> [%expr Pervasives.compare] | 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 Pervasives.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.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 |> List.rev |> reduce_compare]] | { ptyp_desc = Ptyp_variant (fields, _, _); ptyp_loc } -> let cases = fields |> List.map (fun field -> let pdup f = ptuple [f "lhs"; f "rhs"] in match field with | Rtag (label, _, true (*empty*), []) -> Exp.case (pdup (fun _ -> Pat.variant label None)) [%expr 0] | Rtag (label, _, false, [typ]) -> Exp.case (pdup (fun var -> Pat.variant label (Some (pvar var)))) (app (expr_of_typ typ) [evar "lhs"; evar "rhs"]) | Rinherit ({ ptyp_desc = Ptyp_constr (tname, _) } as typ) -> Exp.case (pdup (fun var -> Pat.alias (Pat.type_ tname) (mknoloc var))) (app (expr_of_typ typ) [evar "lhs"; evar "rhs"]) | _ -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ)) in let int_cases = fields |> List.mapi (fun i field -> match field with | Rtag (label, _, true (*empty*), []) -> Exp.case (Pat.variant label None) (int i) | Rtag (label, _, false, [typ]) -> Exp.case (Pat.variant label (Some [%pat? _])) (int i) | Rinherit { ptyp_desc = Ptyp_constr (tname, []) } -> Exp.case (Pat.type_ tname) (int i) | _ -> assert false) in [%expr fun lhs rhs -> [%e Exp.match_ [%expr lhs, rhs] (cases @ [wildcard_case int_cases])]] | { ptyp_desc = Ptyp_var name } -> evar ("poly_"^name) | { ptyp_desc = Ptyp_alias (typ, _) } -> expr_of_typ typ | { ptyp_loc } -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ) let core_type_of_decl ~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 |> List.rev |> 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 |> List.rev |> 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 }; pld_type; pld_attributes } -> let attrs = pld_attributes @ pld_type.ptyp_attributes in let pld_type = {pld_type with ptyp_attributes=attrs} in let field obj = Exp.field obj (mknoloc (Lident name)) in app (expr_of_typ quoter pld_type) [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 (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.0/src_plugins/ppx_deriving_ord.mllib000066400000000000000000000000211273331632400227630ustar00rootroot00000000000000ppx_deriving_ord ppx_deriving-4.0/src_plugins/ppx_deriving_show.cppo.ml000066400000000000000000000320671273331632400234470ustar00rootroot00000000000000#if OCAML_VERSION < (4, 03, 0) #define Pcstr_tuple(core_types) core_types #endif open Longident open Location open Asttypes open Parsetree open Ast_helper open Ast_convenience let deriver = "show" 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_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 = Format.fprintf in [%e printer]) [@ocaml.warning "-26"]] let pp_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: Format.formatter -> [%t var] -> Ppx_deriving_runtime.unit]) type_decl [%type: Format.formatter -> [%t typ] -> Ppx_deriving_runtime.unit] let show_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: 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 = parse_options options; [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 _ -> Format.pp_print_string fmt ""] else let format x = [%expr Format.fprintf fmt [%e str x]] in let seq start finish fold typ = [%expr fun x -> Format.fprintf fmt [%e str start]; ignore ([%e fold] (fun sep x -> if sep then Format.fprintf fmt ";@ "; [%e expr_of_typ typ] x; true) false x); Format.fprintf fmt [%e str finish];] in let typ = Ppx_deriving.remove_pervasives ~deriver typ in match typ with | [%type: _] -> [%expr fun _ -> Format.pp_print_string fmt "_"] | { ptyp_desc = Ptyp_arrow _ } -> [%expr fun _ -> 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 () -> 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 -> Format.fprintf fmt "%S" (Bytes.to_string x)] | true, [%type: [%t? typ] ref] -> [%expr fun x -> Format.pp_print_string fmt "ref ("; [%e expr_of_typ typ] !x; 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 -> Format.pp_print_string fmt "None" | Some x -> Format.pp_print_string fmt "(Some "; [%e expr_of_typ typ] x; Format.pp_print_string fmt ")"] | true, [%type: ([%t? ok_t],[%t? err_t]) Result.result] -> [%expr function | Result.Ok ok -> Format.pp_print_string fmt "(Ok "; [%e expr_of_typ ok_t] ok; Format.pp_print_string fmt ")" | Result.Error e -> Format.pp_print_string fmt "(Error "; [%e expr_of_typ err_t] e; 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 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)] -> Format.fprintf fmt "(@["; [%e args |> Ppx_deriving.(fold_exprs (seq_reduce ~sep:[%expr Format.fprintf fmt ",@ "]))]; Format.fprintf fmt "@])"] | { ptyp_desc = Ptyp_variant (fields, _, _); ptyp_loc } -> let cases = fields |> List.map (fun field -> match field with | Rtag (label, _, true (*empty*), []) -> Exp.case (Pat.variant label None) [%expr Format.pp_print_string fmt [%e str ("`" ^ label)]] | Rtag (label, _, false, [typ]) -> Exp.case (Pat.variant label (Some [%pat? x])) [%expr Format.fprintf fmt [%e str ("`" ^ label ^ " (@[")]; [%e expr_of_typ typ] x; Format.fprintf fmt "@])"] | Rinherit ({ ptyp_desc = Ptyp_constr (tname, _) } as typ) -> Exp.case [%pat? [%p Pat.type_ tname] as x] [%expr [%e expr_of_typ typ] x] | _ -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ)) in Exp.function_ cases | { ptyp_desc = Ptyp_var name } -> [%expr [%e evar ("poly_"^name)] fmt] | { ptyp_desc = Ptyp_alias (typ, _) } -> expr_of_typ typ | { ptyp_loc } -> raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s" deriver (Ppx_deriving.string_of_core_type typ) let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = parse_options options; 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 = Ppx_deriving.expand_path ~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 Format.pp_print_string fmt [%e str constr_name]] | [arg] -> [%expr Format.fprintf fmt [%e str ("(@[<2>" ^ constr_name ^ "@ ")]; [%e arg]; Format.fprintf fmt "@])"] | args -> [%expr Format.fprintf fmt [%e str ("@[<2>" ^ constr_name ^ " (@,")]; [%e args |> Ppx_deriving.(fold_exprs (seq_reduce ~sep:[%expr Format.fprintf fmt ",@ "]))]; 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 }; pld_type = typ } -> [%expr Format.fprintf fmt "@[%s =@ " [%e str n]; [%e expr_of_typ quoter typ] [%e evar (argl n)]; Format.fprintf fmt "@]" ]) in let printer = [%expr Format.fprintf fmt [%e str ("@[<2>" ^ constr_name ^ " {@,")]; [%e args |> Ppx_deriving.(fold_exprs (seq_reduce ~sep:[%expr Format.fprintf fmt ";@ "]))]; 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 }; pld_type; pld_attributes } -> let field_name = if i = 0 then Ppx_deriving.expand_path ~path name else name in let pld_type = {pld_type with ptyp_attributes=pld_attributes@pld_type.ptyp_attributes} in [%expr Format.fprintf fmt "@[%s =@ " [%e str field_name]; [%e expr_of_typ quoter pld_type] [%e Exp.field (evar "x") (mknoloc (Lident name))]; Format.fprintf fmt "@]" ]) in [%expr fun fmt x -> Format.fprintf fmt "@[<2>{ "; [%e fields |> Ppx_deriving.(fold_exprs (seq_reduce ~sep:[%expr Format.fprintf fmt ";@ "]))]; 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 -> 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 [Vb.mk (Pat.constraint_ pp_var pp_type) (Ppx_deriving.sanitize ~quoter (polymorphize prettyprinter)); Vb.mk (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 -> 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.0/src_plugins/ppx_deriving_show.mllib000066400000000000000000000000221273331632400231600ustar00rootroot00000000000000ppx_deriving_show ppx_deriving-4.0/src_test/000077500000000000000000000000001273331632400157055ustar00rootroot00000000000000ppx_deriving-4.0/src_test/test_deriving_create.ml000066400000000000000000000027711273331632400224370ustar00rootroot00000000000000open 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; ] ppx_deriving-4.0/src_test/test_deriving_enum.ml000066400000000000000000000034451273331632400221370ustar00rootroot00000000000000open 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.0/src_test/test_deriving_eq.cppo.ml000066400000000000000000000113141273331632400225320ustar00rootroot00000000000000open 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 [@@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] let test_result ctxt = let eq = [%eq: (string, int) Result.result] in let open Result in assert_equal ~printer true (eq (Ok "ttt") (Ok "ttt")); assert_equal ~printer false (eq (Ok "123") (Error 123)); assert_equal ~printer false (eq (Error 123) (Error 0)) let suite = "Test deriving(eq)" >::: [ "test_simple" >:: test_simple; "test_array" >:: test_arr; "test_ref1" >:: test_ref1; "test_ref2" >:: test_ref2; "test_custom" >:: test_custom; "test_placeholder" >:: test_placeholder; "test_mrec" >:: test_mrec; "test_mut_rec" >:: test_mut_rec; "test_std_shadowing" >:: test_std_shadowing; "test_poly_app" >:: test_poly_app; "test_result" >:: test_result ] ppx_deriving-4.0/src_test/test_deriving_fold.cppo.ml000066400000000000000000000017641273331632400230610ustar00rootroot00000000000000open 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 [@@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] type ('a, 'b) res = ('a, 'b) Result.result [@@deriving fold] let test_result ctxt = let f = fold_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; "test_result" >:: test_result; "test_reflist" >:: test_reflist; ] ppx_deriving-4.0/src_test/test_deriving_iter.cppo.ml000066400000000000000000000036621273331632400230770ustar00rootroot00000000000000open 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 [@@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 [@@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 ] ppx_deriving-4.0/src_test/test_deriving_make.ml000066400000000000000000000034151273331632400221050ustar00rootroot00000000000000open 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 ] ppx_deriving-4.0/src_test/test_deriving_map.cppo.ml000066400000000000000000000115671273331632400227140ustar00rootroot00000000000000open 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] 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] 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 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 = assert_equal ~printer:(show_record3 fmt_int fmt_str) {a3=5;b3=false;c3="ABC"} (map_record3 ((+)1) String.uppercase {a3=4;b3=false;c3="abc"}); assert_equal ~printer:(show_record3 fmt_int fmt_flt) {a3=97;b3=false;c3=4.} (map_record3 Char.code float_of_int {a3='a';b3=false;c3=4}) type 'a result0 = ('a, bool) Result.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 (Result.Ok 10) (f (Result.Ok 9)); assert_equal ~printer (Result.Error true) (f (Result.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_map_result" >:: test_map_result ] ppx_deriving-4.0/src_test/test_deriving_ord.cppo.ml000066400000000000000000000132611273331632400227140ustar00rootroot00000000000000open 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) let test_ord_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 [@@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 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_ref1" >:: test_ref1; "test_ref2" >:: test_ref2; "test_std_shadowing" >:: test_std_shadowing; "test_poly_app" >:: test_poly_app; "test_ord_result" >:: test_ord_result ] ppx_deriving-4.0/src_test/test_deriving_show.cppo.ml000066400000000000000000000201231273331632400231030ustar00rootroot00000000000000open 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 [@@deriving show] type r3 = int Pervasives.ref ref [@@deriving show] type l = int list [@@deriving show] type a = int array [@@deriving show] type o = int option [@@deriving show] type f = int -> int [@@deriving show] type y = int lazy_t [@@deriving show] let test_alias ctxt = assert_equal ~printer "1" (show_a1 1); assert_equal ~printer "1l" (show_a2 1l); assert_equal ~printer "1L" (show_a3 1L); assert_equal ~printer "1n" (show_a4 1n); assert_equal ~printer "1." (show_a5 1.); assert_equal ~printer "true" (show_a6 true); assert_equal ~printer "'a'" (show_a7 'a'); assert_equal ~printer "\"foo\"" (show_a8 "foo"); assert_equal ~printer "\"foo\"" (show_a9 (Bytes.of_string "foo")); assert_equal ~printer "ref (1)" (show_r (ref 1)); assert_equal ~printer "ref (1)" (show_r2 (ref 1)); assert_equal ~printer "ref (ref (1))" (show_r3 (ref (ref 1))); assert_equal ~printer "[1; 2; 3]" (show_l [1;2;3]); assert_equal ~printer "[|1; 2; 3|]" (show_a [|1;2;3|]); assert_equal ~printer "(Some 1)" (show_o (Some 1)); assert_equal ~printer "" (show_f (fun x -> x)); let y = lazy (1 + 1) in assert_equal ~printer "" (show_y y); ignore (Lazy.force y); assert_equal ~printer "2" (show_y y) type v = Foo | Bar of int * string | Baz of string [@@deriving show] let test_variant ctxt = assert_equal ~printer "Test_deriving_show.Foo" (show_v Foo); assert_equal ~printer "Test_deriving_show.Bar (1, \"foo\")" (show_v (Bar (1, "foo"))); assert_equal ~printer "(Test_deriving_show.Baz \"foo\")" (show_v (Baz "foo")) #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 }) module M : sig type t = A [@@deriving show] end = struct type t = A [@@deriving show] end let test_module ctxt = assert_equal ~printer "Test_deriving_show.M.A" (M.show M.A) type z = M.t [@@deriving show] let test_abstr ctxt = assert_equal ~printer "Test_deriving_show.M.A" (show_z M.A) type file = { name : string; perm : int [@printer fun fmt -> Format.fprintf fmt "0o%03o"]; } [@@deriving show] let test_custom ctxt = assert_equal ~printer "{ Test_deriving_show.name = \"dir\"; perm = 0o755 }" (show_file { name = "dir"; perm = 0o755 }) type 'a pt = { v : 'a } [@@deriving show] let test_parametric ctxt = assert_equal ~printer "{ Test_deriving_show.v = 1 }" (show_pt (fun fmt -> Format.fprintf fmt "%d") { v = 1 }) type 'a btree = Node of 'a btree * 'a * 'a btree | Leaf [@@deriving show] module M' = struct type t = M.t = A [@@deriving show] end let test_alias_path ctxt = assert_equal ~printer "M.A" (M'.show M'.A) let print_hi = fun fmt _ -> Format.fprintf fmt "hi!" type polypr = (string [@printer print_hi]) btree [@polyprinter pp_btree] [@@deriving show] let test_polypr ctxt = assert_equal ~printer "Test_deriving_show.Node (Test_deriving_show.Leaf, hi!,\n\ \ Test_deriving_show.Leaf)" (show_polypr (Node (Leaf, "x", Leaf))) let test_placeholder ctxt = assert_equal ~printer "_" ([%show: _] 1) module rec RecFoo : sig type ('a,'b) t = ('b, 'a) RecBar.t [@@deriving show] end = struct type ('a,'b) t = ('b,'a) RecBar.t [@@deriving show] end and RecBar : sig type ('b, 'a) t = 'b * 'a [@@deriving show] end = struct type ('b,'a) t = 'b * 'a [@@deriving show] end type foo = F of int | B of int bar | C of float bar and 'a bar = { x : 'a ; r : foo } [@@deriving show] let test_mrec ctxt = let e1 = B { x = 12; r = F 16 } in assert_equal ~printer "(Test_deriving_show.B\n { Test_deriving_show.x = 12; r = (Test_deriving_show.F 16) })" (show_foo e1) type i_has_result = I_has of (bool, string) Result.result [@@deriving show] let test_result ctxt = assert_equal ~printer "(Ok 100)" ([%show: (int, bool) Result.result] (Result.Ok 100)); assert_equal ~printer "(Test_deriving_show.I_has (Ok true))" (show_i_has_result (I_has (Result.Ok true))); assert_equal ~printer "(Test_deriving_show.I_has (Error \"err\"))" (show_i_has_result (I_has (Result.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))) 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_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_result" >:: test_result ] ppx_deriving-4.0/src_test/test_ppx_deriving.ml000066400000000000000000000022441273331632400217760ustar00rootroot00000000000000open 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_deriving_show.suite; Test_deriving_eq.suite; Test_deriving_ord.suite; Test_deriving_enum.suite; Test_deriving_iter.suite; Test_deriving_map.suite; Test_deriving_fold.suite; Test_deriving_create.suite; Test_deriving_make.suite; "test_inline" >:: test_inline; "test_inline_shorthand" >:: test_inline_shorthand; ] let _ = run_test_tt_main suite