New upstream version 4.4

8 files changed, 230 insertions, 151 deletions

diff --git a/src/api/dune b/src/api/dune
new file mode 100644
index 0000000..352c371
--- /dev/null
+++ b/src/api/dune
@@ -0,0 +1,23 @@
+(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})))
diff --git a/src/ppx_deriving.cppo.ml b/src/api/ppx_deriving.cppo.ml
index 6862a80..f8173c7 100644
--- a/src/ppx_deriving.cppo.ml
+++ b/src/api/ppx_deriving.cppo.ml
@@ -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
diff --git a/src/ppx_deriving.cppo.mli b/src/api/ppx_deriving.cppo.mli
index c2f42bd..172a132 100644
--- a/src/ppx_deriving.cppo.mli
+++ b/src/api/ppx_deriving.cppo.mli
@@ -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. *)
diff --git a/src/dune b/src/dune
index 7fd6c82..3063a50 100644
--- a/src/dune
+++ b/src/dune
@@ -1,44 +1,10 @@
 (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}))))
diff --git a/src/ppx_deriving_runtime.ml b/src/ppx_deriving_runtime.ml
deleted file mode 100644
index 930d814..0000000
--- a/src/ppx_deriving_runtime.ml
+++ /dev/null
@@ -1,59 +0,0 @@
-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
diff --git a/src/runtime/dune b/src/runtime/dune
new file mode 100644
index 0000000..c8462bb
--- /dev/null
+++ b/src/runtime/dune
@@ -0,0 +1,16 @@
+(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})))
diff --git a/src/runtime/ppx_deriving_runtime.cppo.ml b/src/runtime/ppx_deriving_runtime.cppo.ml
new file mode 100644
index 0000000..3b90e68
--- /dev/null
+++ b/src/runtime/ppx_deriving_runtime.cppo.ml
@@ -0,0 +1,75 @@
+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
diff --git a/src/ppx_deriving_runtime.mli b/src/runtime/ppx_deriving_runtime.cppo.mli
index 3c653b4..bdd8e0a 100644
--- a/src/ppx_deriving_runtime.mli
+++ b/src/runtime/ppx_deriving_runtime.cppo.mli
@@ -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