Commit f6178005 authored by Stephane Glondu's avatar Stephane Glondu

Imported Upstream version 4.0

parent 57e55b9a
B _build/**
S src*/**
PKG compiler-libs.common ppx_tools.metaquot oUnit cppo_ocamlbuild
PKG compiler-libs.common ppx_tools.metaquot oUnit cppo_ocamlbuild result
Changelog
=========
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
---
......
Copyright (c) 2014 Peter Zotov <whitequark@whitequark.org>
Copyright (c) 2014-2016 whitequark <whitequark@whitequark.org>
Permission is hereby granted, free of charge, to any person obtaining a copy
of this software and associated documentation files (the "Software"), to deal
......
......@@ -54,14 +54,14 @@ It's possible to pass options to a plugin by appending a record to plugin's name
``` ocaml
type t = string
[@@deriving ord { affix = true }]
[@@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 json { optional = true }]
[@@deriving yojson { optional = true }]
```
It's also possible for many plugins to derive a function directly from a type, without declaring it first.
......@@ -116,7 +116,7 @@ It is expected that all _deriving_ plugins will follow the same conventions, thu
* 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; 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.
* 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.
......@@ -274,7 +274,7 @@ Currently, the resulting ppx driver still depends on Dynlink as well as retains
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.ml) or [show](src_plugins/ppx_deriving_show.ml).
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
......
......@@ -2,11 +2,12 @@ true: warn(@5@8@10@11@12@14@23@24@26@29@40), bin_annot, safe_string, debug, cppo
"data": -traverse
"src": include
<src/*.{ml,mli,byte,native}>: package(dynlink), package(compiler-libs.common), package(ppx_tools.metaquot)
<src/*.{ml,mli,byte,native}>: package(dynlink), package(compiler-libs.common), package(ppx_tools.metaquot), package(result)
<src/ppx_deriving_main.{ml,mli,byte,native}>: package(findlib.dynload), predicate(ppx_driver)
<src/ppx_deriving_main.{byte,native}>: linkall
<src_plugins/*.{ml,mli}>: package(compiler-libs.common), package(ppx_tools.metaquot)
<src_test/*.{ml,byte,native}>: debug, package(oUnit ppx_tools compiler-libs.common), use_deriving
<src_test/*.{ml,byte,native}>: 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)
......
opam-version: "1.2"
name: "ppx_deriving"
version: "3.3"
version: "4.0"
maintainer: "whitequark <whitequark@whitequark.org>"
authors: [ "whitequark <whitequark@whitequark.org>" ]
license: "MIT"
......@@ -23,9 +23,10 @@ build-doc: [
]
depends: [
"ocamlbuild" {build}
"ocamlfind" {build & >= "1.5.4"}
"ocamlfind" {build & >= "1.6.0"}
"cppo" {build}
"ppx_tools" {>= "0.99.3"}
"ppx_tools" {>= "4.02.3"}
"result"
"ounit" {test}
]
available: [ ocaml-version >= "4.02.1" & opam-version >= "1.2" ]
version = "%{version}%"
description = "Type-driven code generation"
ppx = "./ppx_deriving"
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"
......@@ -14,7 +15,7 @@ package "runtime" (
package "api" (
version = "%{version}%"
description = "Plugin API for ppx_deriving"
requires = "dynlink compiler-libs.common ppx_tools"
requires = "dynlink compiler-libs.common ppx_tools result"
archive(byte) = "ppx_deriving.cma"
archive(native) = "ppx_deriving.cmxa"
exists_if = "ppx_deriving.cma"
......@@ -41,7 +42,7 @@ package "show" (
version = "%{version}%"
description = "[@@deriving show]"
requires(-ppx_driver) = "ppx_deriving"
ppxopt(-ppx_driver) = "ppx_deriving,./ppx_deriving_show.cma"
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"
......@@ -52,7 +53,7 @@ package "eq" (
version = "%{version}%"
description = "[@@deriving eq]"
requires(-ppx_driver) = "ppx_deriving"
ppxopt(-ppx_driver) = "ppx_deriving,./ppx_deriving_eq.cma"
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"
......@@ -63,7 +64,7 @@ package "ord" (
version = "%{version}%"
description = "[@@deriving ord]"
requires(-ppx_driver) = "ppx_deriving"
ppxopt(-ppx_driver) = "ppx_deriving,./ppx_deriving_ord.cma"
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"
......@@ -74,7 +75,7 @@ package "enum" (
version = "%{version}%"
description = "[@@deriving enum]"
requires(-ppx_driver) = "ppx_deriving"
ppxopt(-ppx_driver) = "ppx_deriving,./ppx_deriving_enum.cma"
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"
......@@ -85,7 +86,7 @@ package "iter" (
version = "%{version}%"
description = "[@@deriving iter]"
requires(-ppx_driver) = "ppx_deriving"
ppxopt(-ppx_driver) = "ppx_deriving,./ppx_deriving_iter.cma"
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"
......@@ -96,7 +97,7 @@ package "map" (
version = "%{version}%"
description = "[@@deriving map]"
requires(-ppx_driver) = "ppx_deriving"
ppxopt(-ppx_driver) = "ppx_deriving,./ppx_deriving_map.cma"
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"
......@@ -107,7 +108,7 @@ package "fold" (
version = "%{version}%"
description = "[@@deriving fold]"
requires(-ppx_driver) = "ppx_deriving"
ppxopt(-ppx_driver) = "ppx_deriving,./ppx_deriving_fold.cma"
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"
......@@ -118,7 +119,7 @@ package "create" (
version = "%{version}%"
description = "[@@deriving create]"
requires(-ppx_driver) = "ppx_deriving"
ppxopt(-ppx_driver) = "ppx_deriving,./ppx_deriving_create.cma"
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"
......@@ -129,7 +130,7 @@ package "make" (
version = "%{version}%"
description = "[@@deriving make]"
requires(-ppx_driver) = "ppx_deriving"
ppxopt(-ppx_driver) = "ppx_deriving,./ppx_deriving_make.cma"
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"
......
......@@ -19,10 +19,16 @@ type deriver = {
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
......@@ -52,64 +58,76 @@ let create =
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 ;
type_decl_sig ; type_ext_sig ;
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
let expr expr =
`Ok expr
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
| { pexp_desc = Pexp_constant (Const_int n) } -> Ok n
#else
| { pexp_desc = Pexp_constant (Pconst_integer (sn, _)) } -> `Ok (int_of_string sn)
| { pexp_desc = Pexp_constant (Pconst_integer (sn, _)) } -> Ok (int_of_string sn)
#endif
| _ -> `Error "integer"
| _ -> Error "integer"
let bool expr =
match expr with
| [%expr true] -> `Ok true
| [%expr false] -> `Ok false
| _ -> `Error "boolean"
| [%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"
| { 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"
| { 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"
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 []] -> 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)
| Ok v -> loop (v::acc) xs
| Error e -> Error ("list:" ^ e)
end
| _ -> `Error "list"
| _ -> Error "list"
in loop []
let get_attr ~deriver conv attr =
......@@ -117,8 +135,8 @@ module Arg = struct
| None -> None
| Some ({ txt = name }, PStr [{ pstr_desc = Pstr_eval (expr, []) }]) ->
begin match conv expr with
| `Ok v -> Some v
| `Error desc ->
| 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 }, _) ->
......@@ -133,8 +151,8 @@ module Arg = struct
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
| Error desc -> raise_errorf ~loc:expr.pexp_loc "%s: %s expected" deriver desc
| Ok v -> v
end
type quoter = {
......@@ -150,8 +168,11 @@ let quote ~quoter expr =
quoter.next_id <- quoter.next_id + 1;
[%expr [%e evar name] ()]
let sanitize ?(quoter=create_quoter ()) expr =
let body = [%expr (let open! Ppx_deriving_runtime in [%e expr]) [@ocaml.warning "-A"]] in
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
......@@ -213,6 +234,33 @@ let attr_warning expr =
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
......@@ -261,13 +309,10 @@ let free_vars_in_core_type typ =
) rows |> List.concat |> List.concat
| _ -> assert false
in
let rec uniq acc lst =
match lst with
| a :: b :: lst when a = b -> uniq acc (b :: lst)
| x :: lst -> uniq (x :: acc) lst
| [] -> acc
in
List.rev (uniq [] (free_in typ))
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
......@@ -399,6 +444,10 @@ 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//" -> []
......@@ -452,6 +501,13 @@ let mapper =
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 (
......@@ -486,6 +542,13 @@ let mapper =
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 (
......
......@@ -27,10 +27,16 @@ type deriver = {
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. *)
......@@ -48,6 +54,12 @@ val create :
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]. *)
......@@ -72,35 +84,42 @@ val string_of_core_type : Parsetree.core_type -> string
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 -> [> `Ok of expression ]
val expr : expression conv
(** [bool expr] extracts a boolean constant from [expr], or returns
[`Error "boolean"] if [expr] does not contain a boolean literal. *)
val bool : expression -> [ `Ok of bool | `Error of string ]
[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
[`Error "integer"] if [expr] does not contain an integer literal. *)
val int : expression -> [ `Ok of int | `Error of string ]
[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
[`Error "string"] if [expr] does not contain a string literal. *)
val string : expression -> [ `Ok of string | `Error of string ]
[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
[`Error "char"] if [expr] does not contain a char literal. *)
val char : expression -> [ `Ok of char | `Error of string ]
[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 [`Error "one of: `a, `b, ..."] if [expr] does not contain
a polymorphic variant constructor included in [values]. *)
val enum : string list -> expression -> [ `Ok of string | `Error of string ]
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 [`Error "list:..."] where [...] is the error returned
by [f], or returns [`Error "list"] if [expr] does not contain a list. *)
val list : (expression -> [`Ok of 'a | `Error of string]) ->
expression -> [`Ok of 'a list | `Error of string]
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
......@@ -118,8 +137,7 @@ let deriver = "index"
| Some "flat" -> `flat | Some "nested" -> `nested | None -> `default
in ..
]} *)
val get_attr : deriver:string -> (expression -> [ `Ok of 'a | `Error of string ]) ->
attribute option -> 'a option
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
......@@ -132,8 +150,7 @@ let deriver = "index"
[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 -> (expression -> [ `Ok of 'a | `Error of string ]) ->
expression -> 'a
val get_expr : deriver:string -> 'a conv -> expression -> 'a
end
(** {2 Hygiene} *)
......@@ -149,10 +166,12 @@ val create_quoter : unit -> quoter
that [sanitize] provides. *)
val quote : quoter:quoter -> expression -> expression
(** [sanitize quoter expr] wraps [expr] in a way that ensures that the contents of
{!Ppx_deriving_runtime} and {!Pervasives}, as well as the identifiers in
expressions returned by [quote] are in scope, and returns the wrapped expression. *)
val sanitize : ?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)] *)
......@@ -199,6 +218,14 @@ val attr_warning: expression -> attribute
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
......
......@@ -15,6 +15,26 @@ let dynlink ?(loc=Location.none) 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 } ->
......@@ -28,13 +48,13 @@ let get_plugins () =
let add_plugins plugins =
let loaded = get_plugins () in
let plugins = List.filter (fun file -> not (List.mem file loaded)) plugins in
List.iter dynlink plugins;
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 dynlink;
get_plugins () |> List.iter load_plugin;
add_plugins argv;
let structure mapper = function
| [%stri [@@@findlib.ppxopt [%e? { pexp_desc = Pexp_tuple (
......
......@@ -54,5 +54,6 @@ module Weak = Weak
module Printf = Printf
module Format = Format
module Buffer = Buffer
module Result = Result
include Pervasives
......@@ -91,6 +91,11 @@ 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} *)
......
......@@ -49,6 +49,7 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
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
......@@ -99,6 +100,7 @@ let sig_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
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 ->
......
......@@ -60,6 +60,7 @@ and exprl quoter typs =
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
......@@ -97,6 +98,12 @@ and expr_of_typ quoter typ =
| 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) } ->
......@@ -142,7 +149,8 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
| Ptype_abstract, Some manifest -> expr_of_typ quoter manifest
| Ptype_variant constrs, _ ->
let cases =
(constrs |> List.map (fun { pcd_name = { txt = name }; pcd_args } ->
(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 |>
......@@ -162,7 +170,8 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
[%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 } ->
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
......
......@@ -31,18 +31,24 @@ 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 x -> [%e expr_of_typ typ] !x]
| 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]]