New upstream version 4.5

6 files changed, 163 insertions, 96 deletions

diff --git a/src/api/dune b/src/api/dune
index 352c371..b71dff2 100644
--- a/src/api/dune
+++ b/src/api/dune
@@ -10,7 +10,8 @@
    ppx_tools
    result
    ppx_derivers
-   ocaml-migrate-parsetree))
+   ocaml-migrate-parsetree
+   ppx_deriving.runtime))
 
 (rule
  (deps ppx_deriving.cppo.ml)
diff --git a/src/api/ppx_deriving.cppo.ml b/src/api/ppx_deriving.cppo.ml
index e8feafe..95df77e 100644
--- a/src/api/ppx_deriving.cppo.ml
+++ b/src/api/ppx_deriving.cppo.ml
@@ -27,12 +27,19 @@
 #define Rinherit_patt(typ) {prf_desc = Rinherit(typ); _}
 #endif
 
+#if OCAML_VERSION < (4, 11, 0)
+#define Pconst_string_patt(s, loc) Pconst_string (s, loc)
+#else
+#define Pconst_string_patt(s, loc) Pconst_string (s, loc, _)
+#endif
+
 open Longident
 open Location
 open Asttypes
 open Parsetree
 open Ast_helper
 open Ast_convenience
+open Ppx_deriving_runtime
 
 #if OCAML_VERSION >= (4, 05, 0)
 type tyvar = string Location.loc
@@ -142,6 +149,39 @@ let create =
 let string_of_core_type typ =
   Format.asprintf "%a" Pprintast.core_type { typ with ptyp_attributes = [] }
 
+type constant =
+  #if OCAML_VERSION >= (4, 03, 0)
+    Parsetree.constant
+  #else
+    Asttypes.constant
+  #endif
+
+let string_of_constant_opt (constant : constant) : string option =
+  match constant with
+  | Pconst_string_patt(s, _) -> Some s
+  | _ -> None
+
+let string_of_expression_opt (e : Parsetree.expression) : string option =
+  match e with
+  | { pexp_desc = Pexp_constant constant } ->
+      string_of_constant_opt constant
+  | _ -> None
+
+#if OCAML_VERSION >= (4, 03, 0)
+  module Const = Ast_helper.Const
+#else
+  module Const = struct
+    let integer ?suffix:_ i = Const_int (int_of_string i)
+    let int ?suffix:_ i = Const_int i
+    let int32 ?suffix:_ i = Const_int (Int32.to_int i)
+    let int64 ?suffix:_ i = Const_int (Int64.to_int i)
+    let nativeint ?suffix:_ i = Const_int (Nativeint.to_int i)
+    let float ?suffix:_ f = Const_float f
+    let char c = Const_char c
+    let string ?quotation_delimiter s = Const_string (s, quotation_delimiter)
+  end
+#endif
+
 module Arg = struct
   type 'a conv = expression -> ('a, string) Result.result
 
@@ -164,9 +204,7 @@ module Arg = struct
     | _ -> Error "boolean"
 
   let string expr =
-    match expr with
-    | { pexp_desc = Pexp_constant (Pconst_string (n, None)) } -> Ok n
-    | _ -> Error "string"
+    Option.to_result ~none:"string" (string_of_expression_opt expr)
 
   let char = function
     | { pexp_desc = Pexp_constant (Pconst_char c) } -> Ok c
diff --git a/src/api/ppx_deriving.cppo.mli b/src/api/ppx_deriving.cppo.mli
index 172a132..3c06cd8 100644
--- a/src/api/ppx_deriving.cppo.mli
+++ b/src/api/ppx_deriving.cppo.mli
@@ -82,9 +82,45 @@ val lookup : string -> deriver option
 val raise_errorf : ?sub:Location.error list ->
                    ?loc:Location.t -> ('a, unit, string, 'b) format4 -> 'a
 
+(** {2 Compatibility module Const} *)
+
+(** [Ast_helper.Const] is not defined in OCaml <4.03. *)
+
+type constant =
+  #if OCAML_VERSION >= (4, 03, 0)
+    Parsetree.constant
+  #else
+    Asttypes.constant
+  #endif
+
+#if OCAML_VERSION >= (4, 03, 0)
+  module Const = Ast_helper.Const
+#else
+  module Const : sig
+    val char : char -> constant
+    val string : ?quotation_delimiter:string -> string -> constant
+    val integer : ?suffix:char -> string -> constant
+    val int : ?suffix:char -> int -> constant
+    val int32 : ?suffix:char -> int32 -> constant
+    val int64 : ?suffix:char -> int64 -> constant
+    val nativeint : ?suffix:char -> nativeint -> constant
+    val float : ?suffix:char -> string -> constant
+  end
+#endif
+
+(** {2 Coercions} *)
+
 (** [string_of_core_type typ] unparses [typ], omitting any attributes. *)
 val string_of_core_type : Parsetree.core_type -> string
 
+(** [string_of_constant_opt c] returns [Some s] if the constant [c]
+    is a string [s], [None] otherwise. *)
+val string_of_constant_opt : constant -> string option
+
+(** [string_of_expression_opt e] returns [Some s] if the expression [e]
+    is a string constant [s], [None] otherwise. *)
+val string_of_expression_opt : Parsetree.expression -> string option
+
 (** {2 Option parsing} *)
 
 (** {!Arg} contains convenience functions that extract constants from
diff --git a/src/ppx_deriving_main.cppo.ml b/src/ppx_deriving_main.cppo.ml
index e145a02..bb2489b 100644
--- a/src/ppx_deriving_main.cppo.ml
+++ b/src/ppx_deriving_main.cppo.ml
@@ -1,12 +1,8 @@
-#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
+open Ppx_deriving
+open Ppx_deriving_runtime
 
 let dynlink ?(loc=Location.none) filename =
   let filename = Dynlink.adapt_filename filename in
@@ -41,10 +37,7 @@ let load_plugin ?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)
+    exprs |> List.map (fun expr -> Option.get (string_of_expression_opt expr))
   | Some _ -> assert false
   | None -> []
 
@@ -54,7 +47,7 @@ let add_plugins 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))
+    (Exp.tuple (List.map (fun file -> Exp.constant (Const.string file)) loaded))
 
 let mapper argv =
   get_plugins () |> List.iter load_plugin;
@@ -64,10 +57,7 @@ let mapper argv =
     | [%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) |>
+        List.map (fun elem -> Option.get (string_of_expression_opt elem)) |>
         add_plugins;
         mapper.Ast_mapper.structure mapper rest
     | items -> omp_mapper.Ast_mapper.structure mapper items in
diff --git a/src/runtime/ppx_deriving_runtime.cppo.ml b/src/runtime/ppx_deriving_runtime.cppo.ml
index 3b90e68..a191b09 100644
--- a/src/runtime/ppx_deriving_runtime.cppo.ml
+++ b/src/runtime/ppx_deriving_runtime.cppo.ml
@@ -14,22 +14,25 @@ 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. *)
+#if OCAML_VERSION >= (4, 07, 0)
 module Stdlib = Stdlib
 
 include Stdlib
 
 module Result = struct
-  type ('a, 'b) t = ('a, 'b) Result.t =
+  (* Type manifest shoud be [('a, 'b) result]:
+     - it can't be [Result.t] because [Result] is not defined in 4.07 std-lib
+       and the result package just exposes [Result.t] as an alias to [result]
+       without re-exporting the constructors
+     - it can't be [Result.result] because the [include Stdlib] above makes
+       [Result] be [Stdlib.Result] (shadowing the [Result] module from the
+       result package), and [Stdlib.Result] does not define [result] (that's
+       why we override the [Result] module as the first place. *)
+  type ('a, 'b) t = ('a, 'b) result =
     | Ok of 'a
     | Error of 'b
 
-  type ('a, 'b) result = ('a, 'b) Result.t =
+  type ('a, 'b) result = ('a, 'b) t =
     | Ok of 'a
     | Error of 'b
 end
@@ -58,9 +61,12 @@ module Weak = Weak
 module Printf = Printf
 module Format = Format
 module Buffer = Buffer
+
+include Pervasives
+
 module Result = struct
-  (* the "result" compatibility module defines Result.result,
-     not Result.t as the 4.08 stdlib *)
+  (* the "result" compatibility module defines Result.result as a variant
+     and Result.t as an alias *)
   type ('a, 'b) t = ('a, 'b) Result.result =
     | Ok of 'a
     | Error of 'b
@@ -70,6 +76,20 @@ module Result = struct
     | Ok of 'a
     | Error of 'b
 end
+#endif
 
-include Pervasives
+#if OCAML_VERSION < (4, 08, 0)
+module Option = struct
+  type 'a t = 'a option
+
+  let get o =
+    match o with
+    | None -> invalid_arg "get"
+    | Some x -> x
+
+  let to_result ~none o =
+    match o with
+    | None -> Result.Error none
+    | Some x -> Result.Ok x
+end
 #endif
diff --git a/src/runtime/ppx_deriving_runtime.cppo.mli b/src/runtime/ppx_deriving_runtime.cppo.mli
index bdd8e0a..05e9ab8 100644
--- a/src/runtime/ppx_deriving_runtime.cppo.mli
+++ b/src/runtime/ppx_deriving_runtime.cppo.mli
@@ -21,98 +21,80 @@ 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
-)
+#if OCAML_VERSION >= (4, 07, 0)
+include module type of struct
+  include Stdlib
+end
 
 module Result : sig
-  type ('a, 'b) t = ('a, 'b) Result.t =
+  (* Type manifest shoud be [('a, 'b) result]:
+     - it can't be [Result.t] because [Result] is not defined in 4.07 std-lib
+       and the result package just exposes [Result.t] as an alias to [result]
+       without re-exporting the constructors
+     - it can't be [Result.result] because the [include Stdlib] above makes
+       [Result] be [Stdlib.Result] (shadowing the [Result] module from the
+       result package), and [Stdlib.Result] does not define [result] (that's
+       why we override the [Result] module as the first place. *)
+  type ('a, 'b) t = ('a, 'b) result =
     | 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 =
+  type ('a, 'b) result = ('a, 'b) t =
     | Ok of 'a
     | Error of 'b
 end
 #else
-module Pervasives : (module type of Pervasives with
-  type fpclass = Pervasives.fpclass and
-  type in_channel = Pervasives.in_channel and
-  type out_channel = Pervasives.out_channel and
-  type open_flag = Pervasives.open_flag and
-  type 'a ref = 'a Pervasives.ref and
-  type ('a, 'b, 'c, 'd, 'e, 'f) format6 = ('a, 'b, 'c, 'd, 'e, 'f) Pervasives.format6 and
-  type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'd) Pervasives.format4 and
-  type ('a, 'b, 'c) format = ('a, 'b, 'c) Pervasives.format)
+module Pervasives = Pervasives
 
 module Stdlib = Pervasives
 
-include (module type of Pervasives with
-  type fpclass = Pervasives.fpclass and
-  type in_channel = Pervasives.in_channel and
-  type out_channel = Pervasives.out_channel and
-  type open_flag = Pervasives.open_flag and
-  type 'a ref = 'a Pervasives.ref and
-  type ('a, 'b, 'c, 'd, 'e, 'f) format6 = ('a, 'b, 'c, 'd, 'e, 'f) Pervasives.format6 and
-  type ('a, 'b, 'c, 'd) format4 = ('a, 'b, 'c, 'd) Pervasives.format4 and
-  type ('a, 'b, 'c) format = ('a, 'b, 'c) Pervasives.format)
+include module type of struct
+  include Pervasives
+end
 
-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)
+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
 
-(** {3 Data structures} *)
+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 Hashtbl : (module type of Hashtbl with
-  type ('a, 'b) t = ('a, 'b) Hashtbl.t and
-  type statistics = Hashtbl.statistics)
-module Queue : (module type of Queue with
-  type 'a t = 'a Queue.t)
-module Stack : (module type of Stack with
-  type 'a t = 'a Stack.t)
-module Set : (module type of Set)
-module Map : (module type of Map)
-module Weak : (module type of Weak with
-  type 'a t = 'a Weak.t)
-module Buffer : (module type of Buffer with
-  type t = Buffer.t)
 module Result : sig
   type ('a, 'b) t = ('a, 'b) Result.result =
     | Ok of 'a
     | Error of 'b
 
-  (* we also expose Result.result for backward-compatibility *)
+  (* we also expose Result.result for backward-compatibility
+     with the Result package! *)
   type ('a, 'b) result = ('a, 'b) Result.result =
     | Ok of 'a
     | Error of 'b
 end
+#endif
 
-(** {3 Formatting} *)
+#if OCAML_VERSION < (4, 08, 0)
+module Option : sig
+  type 'a t = 'a option
 
-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)
+  val get : 'a t -> 'a
+
+  val to_result : none:'e -> 'a option -> ('a, 'e) Result.result
+end
 #endif