Commit d8ec95e2 authored by Stephane Glondu's avatar Stephane Glondu

New upstream version 4.4

parent 5c3452d8
......@@ -5,4 +5,5 @@ _build
*.install
pkg/META
src_test/_tags
.merlin
\ No newline at end of file
.merlin
_opam
......@@ -10,5 +10,6 @@ env:
- OCAML_VERSION=4.05
- OCAML_VERSION=4.06
- OCAML_VERSION=4.07
- OCAML_VERSION=4.08
os:
- linux
Changelog
=========
4.4
---
* Restore support for OCaml 4.02.3
#188
(ELLIOTTCABLE)
* workaround Location.input_filename being empty
when using reason-language-server
#196
(Ryan Artecona)
* Add support for OCaml 4.08.0
#193, #197, #200
(Gabriel Scherer)
4.3
---
......
......@@ -275,6 +275,19 @@ val make_record :
record
```
The deriving runtime
--------------------
_deriving_ comes with a small runtime library, the
`Ppx_deriving_runtime` module, whose purpose is to re-export the
modules and types of the standard library that code producers rely
on -- ensuring hygienic code generation.
By emitting code that references to `Ppx_deriving_runtime.Array`
module instead of just `Array`, plugins ensure that they can be used
in environments where the `Array` module is redefined with
incompatible types.
Building ppx drivers
--------------------
......
(env
(_
(flags -w -9)))
(copy_files# src_plugins/compat_macros.cppo)
......@@ -22,9 +22,9 @@ depends: [
"ppx_tools" {>= "4.02.3"}
"result"
"ounit" {with-test}
"ocaml" {>= "4.02"}
"ocaml" {>= "4.02.2"}
]
synopsis: "Type-driven code generation for OCaml >=4.02"
synopsis: "Type-driven code generation for OCaml >=4.02.2"
description: """
ppx_deriving provides common infrastructure for generating
code based on type definitions, and a set of useful plugins
......
(library
(name ppx_deriving_api)
(public_name ppx_deriving.api)
(synopsis "Plugin API for ppx_deriving")
(preprocess (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file})))
(wrapped false)
(ppx_runtime_libraries ppx_deriving_runtime)
(libraries
compiler-libs.common
ppx_tools
result
ppx_derivers
ocaml-migrate-parsetree))
(rule
(deps ppx_deriving.cppo.ml)
(targets ppx_deriving.ml)
(action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
(rule
(deps ppx_deriving.cppo.mli)
(targets ppx_deriving.mli)
(action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
......@@ -5,6 +5,28 @@
#define Psig_type(rec_flag, type_decls) Psig_type(type_decls)
#endif
#if OCAML_VERSION < (4, 08, 0)
#define Attribute_expr(loc_, txt_, payload) ({txt = txt_; loc = loc_}, payload)
#define Attribute_patt(loc_, txt_, payload) ({txt = txt_; loc = loc_}, payload)
#else
#define Attribute_expr(loc_, txt_, payload) { attr_name = \
{ txt = txt_; loc = loc_ }; \
attr_payload = payload; \
attr_loc = loc_ }
#define Attribute_patt(loc_, txt_, payload) { attr_name = \
{ txt = txt_; loc = loc_ }; \
attr_payload = payload; \
attr_loc = _ }
#endif
#if OCAML_VERSION < (4, 08, 0)
#define Rtag_patt(label, constant, args) Rtag(label, _, constant, args)
#define Rinherit_patt(typ) Rinherit(typ)
#else
#define Rtag_patt(label, constant, args) {prf_desc = Rtag(label, constant, args); _}
#define Rinherit_patt(typ) {prf_desc = Rinherit(typ); _}
#endif
open Longident
open Location
open Asttypes
......@@ -70,10 +92,18 @@ let lookup name =
| Some (Internal d) -> Some d
| Some (External _) | None -> 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 raise_errorf ?sub ?loc fmt =
let raise_msg str =
#if OCAML_VERSION >= (4, 08, 0)
let sub =
let msg_of_error err =
{ txt = (fun fmt -> Location.print_report fmt err);
loc = err.Location.main.loc } in
Option.map (List.map msg_of_error) sub in
#endif
let err = Location.error ?sub ?loc str in
raise (Location.Error err) in
Printf.kprintf raise_msg fmt
let create =
let def_ext_str name ~options ~path typ_ext =
......@@ -163,20 +193,21 @@ module Arg = struct
let get_attr ~deriver conv attr =
match attr with
| None -> None
| Some ({ txt = name }, PStr [{ pstr_desc = Pstr_eval (expr, []) }]) ->
| Some (Attribute_patt(loc, name,
PStr [{ pstr_desc = Pstr_eval (expr, []) }])) ->
begin match conv expr with
| Ok v -> Some v
| Error desc ->
raise_errorf ~loc:expr.pexp_loc "%s: invalid [@%s]: %s expected" deriver name desc
end
| Some ({ txt = name; loc }, _) ->
| Some (Attribute_patt(loc, name, _)) ->
raise_errorf ~loc "%s: invalid [@%s]: value expected" deriver name
let get_flag ~deriver attr =
match attr with
| None -> false
| Some ({ txt = name }, PStr []) -> true
| Some ({ txt = name; loc }, _) ->
| Some (Attribute_patt(_loc, name, PStr [])) -> true
| Some (Attribute_patt(loc, name, _)) ->
raise_errorf ~loc "%s: invalid [@%s]: empty structure expected" deriver name
let get_expr ~deriver conv expr =
......@@ -188,7 +219,7 @@ end
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]
Attribute_expr(loc, "ocaml.warning", PStr [structure])
type quoter = {
mutable next_id : int;
......@@ -205,9 +236,16 @@ let quote ~quoter expr =
let sanitize ?(module_=Lident "Ppx_deriving_runtime") ?(quoter=create_quoter ()) expr =
let body =
Exp.open_
~attrs:[attr_warning [%expr "-A"]]
Override { txt=module_; loc=(!Ast_helper.default_loc) } expr in
let loc = !Ast_helper.default_loc in
let attrs = [attr_warning [%expr "-A"]] in
let modname = { txt = module_; loc } in
Exp.open_ ~loc ~attrs
#if OCAML_VERSION < (4, 08, 0)
Override modname
#else
(Opn.mk ~loc ~attrs ~override:Override (Mod.ident ~loc ~attrs modname))
#endif
expr in
match quoter.bindings with
| [] -> body
| bindings -> Exp.let_ Nonrecursive bindings body
......@@ -247,12 +285,14 @@ let mangle_lid ?fixpoint affix lid =
| Lapply _ -> assert false
let attr ~deriver name attrs =
let starts str prefix =
let starts prefix str =
String.length str >= String.length prefix &&
String.sub str 0 (String.length prefix) = prefix
in
let attr_starts prefix (Attribute_patt(_loc, txt, _)) = starts prefix txt in
let attr_is name (Attribute_patt(_loc, txt, _)) = name = txt in
let try_prefix prefix f =
if List.exists (fun ({ txt }, _) -> starts txt prefix) attrs
if List.exists (attr_starts prefix) attrs
then prefix ^ name
else f ()
in
......@@ -261,14 +301,16 @@ let attr ~deriver name attrs =
try_prefix (deriver^".") (fun () ->
name))
in
try Some (List.find (fun ({ txt }, _) -> txt = name) attrs)
try Some (List.find (attr_is name) attrs)
with Not_found -> None
let attr_nobuiltin ~deriver attrs =
attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver
let rec remove_pervasive_lid = function
| Lident _ as lid -> lid
| Ldot (Lident "Pervasives", s) -> Lident s
| Ldot (Lident "Stdlib", s) -> Lident s
| Ldot (lid, s) -> Ldot (remove_pervasive_lid lid, s)
| Lapply (lid, lid2) ->
Lapply (remove_pervasive_lid lid, remove_pervasive_lid lid2)
......@@ -351,8 +393,8 @@ let free_vars_in_core_type typ =
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]
function Rtag_patt(_,_,ts) -> List.map free_in ts
| Rinherit_patt(t) -> [free_in t]
) rows |> List.concat |> List.concat
| _ -> assert false
in
......@@ -545,6 +587,7 @@ let derive_module_type_decl path module_type_decl pstr_loc item fn =
let module_from_input_name () =
match !Location.input_name with
| ""
| "//toplevel//" -> []
| filename ->
let capitalize =
......@@ -553,7 +596,13 @@ let module_from_input_name () =
#else
String.capitalize
#endif
in [capitalize (Filename.(basename (chop_suffix filename ".ml")))]
in
match Filename.chop_suffix filename ".ml" with
| exception _ ->
(* see https://github.com/ocaml-ppx/ppx_deriving/pull/196 *)
[]
| path ->
[capitalize (Filename.basename path)]
let pstr_desc_rec_flag pstr =
match pstr with
......
......@@ -79,10 +79,7 @@ val create :
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 ->
val raise_errorf : ?sub:Location.error list ->
?loc:Location.t -> ('a, unit, string, 'b) format4 -> 'a
(** [string_of_core_type typ] unparses [typ], omitting any attributes. *)
......
(rule
(deps ppx_deriving.cppo.ml)
(targets ppx_deriving.ml)
(action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
(rule
(deps ppx_deriving.cppo.mli)
(targets ppx_deriving.mli)
(action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
(rule
(deps ppx_deriving_main.cppo.ml)
(targets ppx_deriving_main.ml)
(action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
(library
(name ppx_deriving_runtime)
(public_name ppx_deriving.runtime)
(wrapped false)
(synopsis "Type-driven code generation")
(libraries result)
(modules ppx_deriving_runtime))
(library
(name ppx_deriving_api)
(public_name ppx_deriving.api)
(synopsis "Plugin API for ppx_deriving")
(preprocess (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file})))
(wrapped false)
(modules ppx_deriving)
(ppx_runtime_libraries ppx_deriving_runtime)
(libraries
compiler-libs.common
ppx_tools
result
ppx_derivers
ocaml-migrate-parsetree))
(executable
(name ppx_deriving_main)
(modules ppx_deriving_main)
(libraries ppx_deriving_api findlib.dynload compiler-libs.common)
(link_flags :standard -linkall)
(preprocess (action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file}))))
......
module 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
(library
(name ppx_deriving_runtime)
(public_name ppx_deriving.runtime)
(wrapped false)
(synopsis "Type-driven code generation")
(libraries result))
(rule
(deps ppx_deriving_runtime.cppo.ml)
(targets ppx_deriving_runtime.ml)
(action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
(rule
(deps ppx_deriving_runtime.cppo.mli)
(targets ppx_deriving_runtime.mli)
(action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
type nonrec int = int
type nonrec char = char
type nonrec string = string
type nonrec float = float
type nonrec bool = bool
type nonrec unit = unit
type nonrec exn = exn
type nonrec 'a array = 'a array
type nonrec 'a list = 'a list
type nonrec 'a option = 'a option
type nonrec nativeint = nativeint
type nonrec int32 = int32
type nonrec int64 = int64
type nonrec 'a lazy_t = 'a lazy_t
type nonrec bytes = bytes
#if OCAML_VERSION >= (4, 08, 0)
(* We require 4.08 while 4.07 already has a Stdlib module.
In 4.07, the type equalities on Stdlib.Pervasives
are not strong enough for the 'include Stdlib'
below to satisfy the signature constraints on
Ppx_deriving_runtime.Pervasives. *)
module Stdlib = Stdlib
include Stdlib
module Result = struct
type ('a, 'b) t = ('a, 'b) Result.t =
| Ok of 'a
| Error of 'b
type ('a, 'b) result = ('a, 'b) Result.t =
| Ok of 'a
| Error of 'b
end
#else
module Pervasives = Pervasives
module Stdlib = Pervasives
module Char = Char
module String = String
module Printexc = Printexc
module Array = Array
module List = List
module Nativeint = Nativeint
module Int32 = Int32
module Int64 = Int64
module Lazy = Lazy
module Bytes = Bytes
module Hashtbl = Hashtbl
module Queue = Queue
module Stack = Stack
module Set = Set
module Map = Map
module Weak = Weak
module Printf = Printf
module Format = Format
module Buffer = Buffer
module Result = struct
(* the "result" compatibility module defines Result.result,
not Result.t as the 4.08 stdlib *)
type ('a, 'b) t = ('a, 'b) Result.result =
| Ok of 'a
| Error of 'b
(* ... and we also expose Result.result for backward-compatibility *)
type ('a, 'b) result = ('a, 'b) Result.result =
| Ok of 'a
| Error of 'b
end
include Pervasives
#endif
......@@ -3,46 +3,49 @@
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
type nonrec int = int
type nonrec char = char
type nonrec string = string
type nonrec float = float
type nonrec bool = bool
type nonrec unit = unit
type nonrec exn = exn
type nonrec 'a array = 'a array
type nonrec 'a list = 'a list
type nonrec 'a option = 'a option
type nonrec nativeint = nativeint
type nonrec int32 = int32
type nonrec int64 = int64
type nonrec 'a lazy_t = 'a lazy_t
type nonrec bytes = bytes
(** {2 Predefined modules}
{3 Operations on predefined types} *)
#if OCAML_VERSION >= (4, 08, 0)
include (module type of Stdlib with
type fpclass = Stdlib.fpclass and
type in_channel = Stdlib.in_channel and
type out_channel = Stdlib.out_channel and
type open_flag = Stdlib.open_flag and
type 'a ref = 'a Stdlib.ref and
type ('a, 'b, 'c, 'd, 'e, 'f) format6 = ('a, 'b, 'c, 'd, 'e, 'f) Stdlib.format6 and
type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'd) Stdlib.format4 and
type ('a, 'b, 'c) format = ('a, 'b, 'c) Stdlib.format
)
module Result : sig
type ('a, 'b) t = ('a, 'b) Result.t =
| Ok of 'a
| Error of 'b
(* we also expose Result.result for backward-compatibility
with the Result package! *)
type ('a, 'b) result = ('a, 'b) Result.t =
| Ok of 'a
| Error of 'b
end
#else
module Pervasives : (module type of Pervasives with
type fpclass = Pervasives.fpclass and
type in_channel = Pervasives.in_channel and
......@@ -52,6 +55,9 @@ module Pervasives : (module type of Pervasives with
type ('a, 'b, 'c, 'd, 'e, 'f) format6 = ('a, 'b, 'c, 'd, 'e, 'f) Pervasives.format6 and
type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'd) Pervasives.format4 and
type ('a, 'b, 'c) format = ('a, 'b, 'c) Pervasives.format)
module Stdlib = Pervasives
include (module type of Pervasives with
type fpclass = Pervasives.fpclass and
type in_channel = Pervasives.in_channel and
......@@ -92,6 +98,11 @@ module Weak : (module type of Weak with
module Buffer : (module type of Buffer with
type t = Buffer.t)
module Result : sig
type ('a, 'b) t = ('a, 'b) Result.result =
| Ok of 'a
| Error of 'b
(* we also expose Result.result for backward-compatibility *)
type ('a, 'b) result = ('a, 'b) Result.result =
| Ok of 'a
| Error of 'b
......@@ -104,3 +115,4 @@ module Format : (module type of Format with
type formatter_out_functions = Format.formatter_out_functions and
type formatter_tag_functions = Format.formatter_tag_functions and
type formatter = Format.formatter)
#endif
#if OCAML_VERSION < (4, 03, 0)
#define Pcstr_tuple(core_types) core_types
#endif
#if OCAML_VERSION < (4, 08, 0)
#define Rtag_patt(label, constant, args) Rtag(label, _, constant, args)
#define Rinherit_patt(typ) Rinherit(typ)
#else
#define Rtag_patt(label, constant, args) {prf_desc = Rtag(label, constant, args); _}
#define Rinherit_patt(typ) {prf_desc = Rinherit(typ); _}
#endif
(rule
(deps ../compat_macros.cppo)
(targets ppx_deriving_create.ml)
(action (run %{bin:cppo} -V OCAML:%{ocaml_version}
%{dep:ppx_deriving_create.cppo.ml} -o %{targets})))
(library
(name ppx_deriving_create)
(public_name ppx_deriving.create)
(synopsis "[@@deriving create]")
(preprocess
(action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file})))
(libraries compiler-libs.common ppx_tools ppx_deriving.api)
(kind ppx_deriver))
#include "../compat_macros.cppo"
open Longident
open Location
open Asttypes
......
(rule
(deps ppx_deriving_show.cppo.ml)
(targets ppx_deriving_show.ml)
(action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
(library
(name ppx_deriving_show)
(public_name ppx_deriving.show)
(synopsis "[@@deriving show]")
(modules ppx_deriving_show)
(preprocess
(action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file})))
(libraries compiler-libs.common ppx_tools ppx_deriving.api)
(kind ppx_deriver))
(rule
(deps ppx_deriving_create.cppo.ml)
(targets ppx_deriving_create.ml)
(action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
(library
(name ppx_deriving_create)
(public_name ppx_deriving.create)
(synopsis "[@@deriving create]")
(modules ppx_deriving_create)
(preprocess
(action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file})))
(libraries compiler-libs.common ppx_tools ppx_deriving.api)
(kind ppx_deriver))
(rule
(deps ppx_deriving_enum.cppo.ml)
(targets ppx_deriving_enum.ml)
(action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
(library
(name ppx_deriving_enum)
(public_name ppx_deriving.enum)
(synopsis "[@@deriving enum]")
(modules ppx_deriving_enum)
(preprocess
(action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file})))
(libraries compiler-libs.common ppx_tools ppx_deriving.api)
(kind ppx_deriver))
(rule
(deps ppx_deriving_eq.cppo.ml)
(targets ppx_deriving_eq.ml)
(action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
(library
(name ppx_deriving_eq)
(public_name ppx_deriving.eq)
(synopsis "[@@deriving eq]")
(modules ppx_deriving_eq)
(preprocess
(action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file})))
(libraries compiler-libs.common ppx_tools ppx_deriving.api)
(kind ppx_deriver))
(rule
(deps ppx_deriving_fold.cppo.ml)
(targets ppx_deriving_fold.ml)
(action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
(library
(name ppx_deriving_fold)
(public_name ppx_deriving.fold)
(synopsis "[@@deriving fold]")
(modules ppx_deriving_fold)
(preprocess
(action (run ppxfind -legacy ppx_tools.metaquot --as-pp %{input-file})))
(libraries compiler-libs.common ppx_tools ppx_deriving.api)
(kind ppx_deriver))
(rule
(deps ppx_deriving_iter.cppo.ml)
(targets ppx_deriving_iter.ml)
(action (run %{bin:cppo} -V OCAML:%{ocaml_version} %{deps} -o %{targets})))
(library
(name ppx_deriving_iter)
(public_name ppx_deriving.iter)
(synopsis "[@@deriving iter]")
(modules ppx_deriving_iter)