Merge pull request #222 from thierry-martinez/411

Tentative lightning update for OCaml 4.11.0 before introducing ppxlib

.travis.yml

@@ -13,6 +13,8 @@ env:
   - OCAML_VERSION=4.07
   - OCAML_VERSION=4.08
   - OCAML_VERSION=4.09
-  - OCAML_VERSION=4.10.0+rc2 OCAML_BETA=enable
+  - OCAML_VERSION=4.10
+  - OCAML_VERSION=4.11.0+trunk OCAML_BETA=enable
+    PINS="ppx_tools:https://github.com/kit-ty-kate/ppx_tools.git#411"
 os:
   - linux

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)

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

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

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

src/runtime/ppx_deriving_runtime.cppo.ml

@@ -70,6 +70,19 @@ module Result = struct
     | Ok of 'a
     | Error of 'b
 end
+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
 
 include Pervasives
 #endif

src/runtime/ppx_deriving_runtime.cppo.mli

@@ -107,6 +107,13 @@ module Result : sig
     | Ok of 'a
     | Error of 'b
 end
+module Option : sig
+  type 'a t = 'a option
+
+  val get : 'a t -> 'a
+
+  val to_result : none:'e -> 'a option -> ('a, 'e) Result.result
+end
 
 (** {3 Formatting} *)