Imported Upstream version 4.0

5 files changed, 175 insertions, 59 deletions

diff --git a/src/ppx_deriving.cppo.ml b/src/ppx_deriving.cppo.ml
index d12c8b4..4f8e939 100644
--- a/src/ppx_deriving.cppo.ml
+++ b/src/ppx_deriving.cppo.ml
@@ -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 (
diff --git a/src/ppx_deriving.mli b/src/ppx_deriving.mli
index 8714e66..bde079b 100644
--- a/src/ppx_deriving.mli
+++ b/src/ppx_deriving.mli
@@ -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
diff --git a/src/ppx_deriving_main.cppo.ml b/src/ppx_deriving_main.cppo.ml
index 1922a81..96916f3 100644
--- a/src/ppx_deriving_main.cppo.ml
+++ b/src/ppx_deriving_main.cppo.ml
@@ -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 (
diff --git a/src/ppx_deriving_runtime.ml b/src/ppx_deriving_runtime.ml
index c4c240e..930d814 100644
--- a/src/ppx_deriving_runtime.ml
+++ b/src/ppx_deriving_runtime.ml
@@ -54,5 +54,6 @@ module Weak = Weak
 module Printf = Printf
 module Format = Format
 module Buffer = Buffer
+module Result = Result
 
 include Pervasives
diff --git a/src/ppx_deriving_runtime.mli b/src/ppx_deriving_runtime.mli
index 4481952..a859e1f 100644
--- a/src/ppx_deriving_runtime.mli
+++ b/src/ppx_deriving_runtime.mli
@@ -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} *)