New upstream version 4.2.1

3 files changed, 173 insertions, 44 deletions

diff --git a/src/ppx_deriving.cppo.ml b/src/ppx_deriving.cppo.ml
index 63197f7..7ff7454 100644
--- a/src/ppx_deriving.cppo.ml
+++ b/src/ppx_deriving.cppo.ml
@@ -12,6 +12,12 @@ open Parsetree
 open Ast_helper
 open Ast_convenience
 
+#if OCAML_VERSION >= (4, 05, 0)
+type tyvar = string Location.loc
+#else
+type tyvar = string
+#endif
+
 type deriver = {
   name : string ;
   core_type : (core_type -> expression) option;
@@ -31,23 +37,38 @@ type deriver = {
                           module_type_declaration -> signature;
 }
 
-let registry : (string, deriver) Hashtbl.t
-             = Hashtbl.create 16
+type Ppx_derivers.deriver += T of deriver
+
+type internal_or_external =
+  | Internal of deriver
+  | External of string
 
 let hooks = Queue.create ()
 
 let add_register_hook f = Queue.add f hooks
 
 let register d =
-  Hashtbl.add registry d.name d;
+  Ppx_derivers.register d.name (T d);
   Queue.iter (fun f -> f d) hooks
 
 let derivers () =
-  Hashtbl.fold (fun _ v acc -> v::acc) registry []
+  List.fold_left
+    (fun acc (_name, drv) ->
+       match drv with
+       | T d -> d :: acc
+       | _ -> acc)
+    [] (Ppx_derivers.derivers ())
+
+let lookup_internal_or_external name =
+  match Ppx_derivers.lookup name with
+  | Some (T d) -> Some (Internal d)
+  | Some _ -> Some (External name)
+  | None -> None
 
 let lookup name =
-  try  Some (Hashtbl.find registry name)
-  with Not_found -> None
+  match lookup_internal_or_external name with
+  | Some (Internal d) -> Some d
+  | Some (External _) | None -> None
 
 let raise_errorf ?sub ?if_highlight ?loc message =
   message |> Printf.kprintf (fun str ->
@@ -164,6 +185,11 @@ module Arg = struct
     | Ok v -> v
 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]
+
 type quoter = {
   mutable next_id : int;
   mutable bindings : value_binding list;
@@ -180,7 +206,7 @@ let quote ~quoter expr =
 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"]]
+      ~attrs:[attr_warning [%expr "-A"]]
       Override { txt=module_; loc=(!Ast_helper.default_loc) } expr in
   match quoter.bindings with
   | [] -> body
@@ -238,11 +264,6 @@ let attr ~deriver name attrs =
   try Some (List.find (fun ({ txt }, _) -> txt = name) attrs)
   with Not_found -> None
 
-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]
-
 let attr_nobuiltin ~deriver attrs =
   attrs |> attr ~deriver "nobuiltin" |> Arg.get_flag ~deriver
 let rec remove_pervasive_lid = function
@@ -275,6 +296,9 @@ let fold_left_type_params fn accum params =
       match param with
       | { ptyp_desc = Ptyp_any } -> accum
       | { ptyp_desc = Ptyp_var name } ->
+#if OCAML_VERSION >= (4, 05, 0)
+        let name = mkloc name param.ptyp_loc in
+#endif
         fn accum name
       | _ -> assert false)
     accum params
@@ -290,6 +314,9 @@ let fold_right_type_params fn params accum =
       match param with
       | { ptyp_desc = Ptyp_any } -> accum
       | { ptyp_desc = Ptyp_var name } ->
+#if OCAML_VERSION >= (4, 05, 0)
+        let name = mkloc name param.ptyp_loc in
+#endif
         fn name accum
       | _ -> assert false)
     params accum
@@ -304,11 +331,22 @@ let free_vars_in_core_type typ =
   let rec free_in typ =
     match typ with
     | { ptyp_desc = Ptyp_any } -> []
-    | { ptyp_desc = Ptyp_var name } -> [name]
+    | { ptyp_desc = Ptyp_var name } ->
+#if OCAML_VERSION >= (4, 05, 0)
+      [mkloc name typ.ptyp_loc]
+#else
+      [name]
+#endif
     | { ptyp_desc = Ptyp_arrow (_, x, y) } -> free_in x @ free_in y
     | { ptyp_desc = (Ptyp_tuple xs | Ptyp_constr (_, xs)) } ->
       List.map free_in xs |> List.concat
-    | { ptyp_desc = Ptyp_alias (x, name) } -> [name] @ free_in x
+    | { ptyp_desc = Ptyp_alias (x, name) } ->
+#if OCAML_VERSION >= (4, 05, 0)
+      [mkloc name typ.ptyp_loc]
+#else
+      [name]
+#endif
+      @ free_in x
     | { ptyp_desc = Ptyp_poly (bound, x) } ->
       List.filter (fun y -> not (List.mem y bound)) (free_in x)
     | { ptyp_desc = Ptyp_variant (rows, _, _) } ->
@@ -320,8 +358,19 @@ let free_vars_in_core_type typ =
   in
   let uniq lst =
     let module StringSet = Set.Make(String) in
-    lst |> StringSet.of_list |> StringSet.elements in
-  free_in typ |> uniq
+    let add name (names, txts) =
+      let txt =
+#if OCAML_VERSION >= (4, 05, 0)
+        name.txt
+#else
+        name
+#endif
+      in
+      if StringSet.mem txt txts
+      then (names, txts)
+      else (name :: names, StringSet.add txt txts)
+    in fst (List.fold_right add lst ([], StringSet.empty))
+  in free_in typ |> uniq
 
 let var_name_of_int i =
   let letter = "abcdefghijklmnopqrstuvwxyz" in
@@ -339,30 +388,53 @@ let fresh_var bound =
 
 let poly_fun_of_type_decl type_decl expr =
   fold_right_type_decl (fun name expr ->
+#if OCAML_VERSION >= (4, 05, 0)
+    let name = name.txt in
+#endif
     Exp.fun_ Label.nolabel None (pvar ("poly_"^name)) expr) type_decl expr
 
 let poly_fun_of_type_ext type_ext expr =
   fold_right_type_ext (fun name expr ->
+#if OCAML_VERSION >= (4, 05, 0)
+    let name = name.txt in
+#endif
     Exp.fun_ Label.nolabel None (pvar ("poly_"^name)) expr) type_ext expr
 
 let poly_apply_of_type_decl type_decl expr =
   fold_left_type_decl (fun expr name ->
+#if OCAML_VERSION >= (4, 05, 0)
+    let name = name.txt in
+#endif
     Exp.apply expr [Label.nolabel, evar ("poly_"^name)]) expr type_decl
 
 let poly_apply_of_type_ext type_ext expr =
   fold_left_type_ext (fun expr name ->
+#if OCAML_VERSION >= (4, 05, 0)
+    let name = name.txt in
+#endif
     Exp.apply expr [Label.nolabel, evar ("poly_"^name)]) expr type_ext
 
 let poly_arrow_of_type_decl fn type_decl typ =
   fold_right_type_decl (fun name typ ->
+#if OCAML_VERSION >= (4, 05, 0)
+    let name = name.txt in
+#endif
     Typ.arrow Label.nolabel (fn (Typ.var name)) typ) type_decl typ
 
 let poly_arrow_of_type_ext fn type_ext typ =
   fold_right_type_ext (fun name typ ->
-    Typ.arrow Label.nolabel (fn (Typ.var name)) typ) type_ext typ
+    let var =
+#if OCAML_VERSION >= (4, 05, 0)
+      Typ.var ~loc:name.loc name.txt
+#else
+      Typ.var name
+#endif
+    in
+    Typ.arrow Label.nolabel (fn var) typ) type_ext typ
 
-let core_type_of_type_decl { ptype_name = { txt = name }; ptype_params } =
-  Typ.constr (mknoloc (Lident name)) (List.map fst ptype_params)
+let core_type_of_type_decl { ptype_name = name; ptype_params } =
+  let name = mkloc (Lident name.txt) name.loc in
+  Typ.constr name (List.map fst ptype_params)
 
 let core_type_of_type_ext { ptyext_path ; ptyext_params } =
   Typ.constr ptyext_path (List.map fst ptyext_params)
@@ -404,6 +476,10 @@ let strong_type_of_type ty =
   let free_vars = free_vars_in_core_type ty in
   Typ.force_poly @@ Typ.poly free_vars ty
 
+type deriver_options =
+  | Options of (string * expression) list
+  | Unknown_syntax
+
 let derive path pstr_loc item attributes fn arg =
   let deriving = find_attr "deriving" attributes in
   let deriver_exprs, loc =
@@ -420,27 +496,37 @@ let derive path pstr_loc item attributes fn arg =
       let name, options =
         match deriver_expr with
         | { pexp_desc = Pexp_ident name } ->
-          name, []
+          name, Options []
         | { pexp_desc = Pexp_apply ({ pexp_desc = Pexp_ident name }, [label,
             { pexp_desc = Pexp_record (options, None) }]) }
               when label = Label.nolabel ->
-          name, options |> List.map (fun ({ txt }, expr) ->
-            String.concat "." (Longident.flatten txt), expr)
+          name,
+          Options
+            (options |> List.map (fun ({ txt }, expr) ->
+               String.concat "." (Longident.flatten txt), expr))
+        | { pexp_desc = Pexp_apply ({ pexp_desc = Pexp_ident name }, _) } ->
+          name, Unknown_syntax
         | { pexp_loc } ->
-          raise_errorf ~loc:pexp_loc "Unrecognized [@@deriving] option syntax"
+          raise_errorf ~loc:pexp_loc "Unrecognized [@@deriving] syntax"
       in
       let name, loc = String.concat "_" (Longident.flatten name.txt), name.loc in
       let is_optional, options =
-        match List.assoc "optional" options with
-        | exception Not_found -> false, options
-        | expr ->
-          Arg.(get_expr ~deriver:name bool) expr,
-          List.remove_assoc "optional" options
+        match options with
+        | Unknown_syntax -> false, options
+        | Options options' ->
+          match List.assoc "optional" options' with
+          | exception Not_found -> false, options
+          | expr ->
+            Arg.(get_expr ~deriver:name bool) expr,
+            Options (List.remove_assoc "optional" options')
       in
-      match lookup name with
-      | Some deriver ->
+      match lookup_internal_or_external name, options with
+      | Some (Internal deriver), Options options ->
         items @ ((fn deriver) ~options ~path:(!path) arg)
-      | None ->
+      | Some (Internal _), Unknown_syntax ->
+        raise_errorf ~loc:deriver_expr.pexp_loc "Unrecognized [@@deriving] option syntax"
+      | Some (External _), _ -> items
+      | None, _ ->
         if is_optional then items
         else raise_errorf ~loc "Cannot locate deriver %s" name)
     [item] deriver_exprs
@@ -460,7 +546,29 @@ 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 -> [String.capitalize (Filename.(basename (chop_suffix filename ".ml")))]
+  | filename ->
+    let capitalize =
+#if OCAML_VERSION >= (4, 03, 0)
+      String.capitalize_ascii
+#else
+      String.capitalize
+#endif
+    in [capitalize (Filename.(basename (chop_suffix filename ".ml")))]
+
+let pstr_desc_rec_flag pstr =
+  match pstr with
+  | Pstr_type(rec_flag, typ_decls) ->
+#if OCAML_VERSION < (4, 03, 0)
+    begin
+      if List.exists (fun ty -> has_attr "nonrec" ty.ptype_attributes) typ_decls then
+        Nonrecursive
+      else
+        Recursive
+    end
+#else
+    rec_flag
+#endif
+  | _ -> assert false
 
 let mapper =
   let module_nesting = ref [] in
@@ -477,8 +585,8 @@ let mapper =
         when String.(length name >= 7 && sub name 0 7 = "derive.") ->
       let name = String.sub name 7 ((String.length name) - 7) in
       let deriver =
-        match lookup name with
-        | Some { core_type = Some deriver } -> deriver
+        match lookup_internal_or_external name with
+        | Some (Internal { core_type = Some deriver }) -> deriver
         | Some _ -> raise_errorf ~loc "Deriver %s does not support inline notation" name
         | None -> raise_errorf ~loc "Cannot locate deriver %s" name
       in
@@ -487,8 +595,8 @@ let mapper =
       | _ -> raise_errorf ~loc "Unrecognized [%%derive.*] syntax"
       end
     | { pexp_desc = Pexp_extension ({ txt = name; loc }, PTyp typ) } ->
-      begin match lookup name with
-      | Some { core_type = Some deriver } ->
+      begin match lookup_internal_or_external name with
+      | Some (Internal { core_type = Some deriver }) ->
         Ast_helper.with_default_loc typ.ptyp_loc (fun () -> deriver typ)
       | _ -> Ast_mapper.(default_mapper.expr) mapper expr
       end
@@ -496,6 +604,10 @@ let mapper =
   in
   let structure mapper items =
     match items with
+    | { pstr_desc = Pstr_type(_, typ_decls) as pstr_desc ; pstr_loc } :: rest when
+        List.exists (fun ty -> has_attr "deriving" ty.ptype_attributes) typ_decls
+        && pstr_desc_rec_flag pstr_desc = Nonrecursive ->
+      raise_errorf ~loc:pstr_loc "The nonrec flag is not supported by ppx_deriving"
     | { pstr_desc = Pstr_type(_, typ_decls); pstr_loc } as item :: rest when
         List.exists (fun ty -> has_attr "deriving" ty.ptype_attributes) typ_decls ->
       let derived =
@@ -596,3 +708,10 @@ let hash_variant s =
   accu := !accu land (1 lsl 31 - 1);
   (* make it signed for 64 bits architectures *)
   if !accu > 0x3FFFFFFF then !accu - (1 lsl 31) else !accu
+
+(* This is only used when ppx_deriving is linked as part of an ocaml-migrate-parsetre
+   driver. *)
+let () =
+  Migrate_parsetree.Driver.register ~name:"ppx_deriving"
+    (module Migrate_parsetree.OCaml_current)
+    (fun _ _ -> mapper)
diff --git a/src/ppx_deriving.mli b/src/ppx_deriving.cppo.mli
index f4d3878..2e8ce03 100644
--- a/src/ppx_deriving.mli
+++ b/src/ppx_deriving.cppo.mli
@@ -2,6 +2,12 @@
 
 open Parsetree
 
+#if OCAML_VERSION >= (4, 05, 0)
+type tyvar = string Location.loc
+#else
+type tyvar = string
+#endif
+
 (** {2 Registration} *)
 
 (** A type of deriving plugins.
@@ -223,7 +229,7 @@ val attr_warning: expression -> attribute
 
 (** [free_vars_in_core_type typ] returns unique free variables in [typ] in
     lexical order. *)
-val free_vars_in_core_type : core_type -> string list
+val free_vars_in_core_type : core_type -> tyvar list
 
 (** [remove_pervasives ~deriver typ] removes the leading "Pervasives."
     module name in longidents.
@@ -239,19 +245,19 @@ val fresh_var : string list -> string
 
 (** [fold_left_type_decl fn accum type_] performs a left fold over all type variable
     (i.e. not wildcard) parameters in [type_]. *)
-val fold_left_type_decl : ('a -> string -> 'a) -> 'a -> type_declaration -> 'a
+val fold_left_type_decl : ('a -> tyvar -> 'a) -> 'a -> type_declaration -> 'a
 
 (** [fold_right_type_decl fn accum type_] performs a right fold over all type variable
     (i.e. not wildcard) parameters in [type_]. *)
-val fold_right_type_decl : (string -> 'a -> 'a) -> type_declaration -> 'a -> 'a
+val fold_right_type_decl : (tyvar -> 'a -> 'a) -> type_declaration -> 'a -> 'a
 
 (** [fold_left_type_ext fn accum type_] performs a left fold over all type variable (i.e. not
     wildcard) parameters in [type_]. *)
-val fold_left_type_ext : ('a -> string -> 'a) -> 'a -> type_extension -> 'a
+val fold_left_type_ext : ('a -> tyvar -> 'a) -> 'a -> type_extension -> 'a
 
 (** [fold_right_type_ext fn accum type_] performs a right fold over all type variable (i.e. not
     wildcard) parameters in [type_]. *)
-val fold_right_type_ext : (string -> 'a -> 'a) -> type_extension -> 'a -> 'a
+val fold_right_type_ext : (tyvar -> 'a -> 'a) -> type_extension -> 'a -> 'a
 
 (** [poly_fun_of_type_decl type_ expr] wraps [expr] into [fun poly_N -> ...] for every
     type parameter ['N] present in [type_]. For example, if [type_] refers to
diff --git a/src/ppx_deriving_main.cppo.ml b/src/ppx_deriving_main.cppo.ml
index 96916f3..e145a02 100644
--- a/src/ppx_deriving_main.cppo.ml
+++ b/src/ppx_deriving_main.cppo.ml
@@ -22,7 +22,10 @@ let init_findlib = lazy (
 
 let load_ocamlfind_package ?loc pkg =
   Lazy.force init_findlib;
-  Fl_dynload.load_packages [pkg]
+  try
+    Fl_dynload.load_packages [pkg]
+  with Dynlink.Error error ->
+    raise_errorf ?loc "Cannot load %s: %s" pkg (Dynlink.error_message error)
 
 let load_plugin ?loc plugin =
   let len = String.length plugin in
@@ -56,6 +59,7 @@ let add_plugins plugins =
 let mapper argv =
   get_plugins () |> List.iter load_plugin;
   add_plugins argv;
+  let omp_mapper = Migrate_parsetree.Driver.run_as_ast_mapper [] in
   let structure mapper = function
     | [%stri [@@@findlib.ppxopt [%e? { pexp_desc = Pexp_tuple (
           [%expr "ppx_deriving"] :: elems) }]]] :: rest ->
@@ -66,8 +70,8 @@ let mapper argv =
           | _ -> assert false) |>
         add_plugins;
         mapper.Ast_mapper.structure mapper rest
-    | items -> Ppx_deriving.mapper.Ast_mapper.structure mapper items in
-  { Ppx_deriving.mapper with Ast_mapper.structure }
+    | items -> omp_mapper.Ast_mapper.structure mapper items in
+  { omp_mapper with Ast_mapper.structure }
 
 let () =
   Ast_mapper.register "ppx_deriving" mapper