Merge pull request #159 from gasche/4.1-maintenance

free_vars_in_core_type and fold_{left,right}_type_decl now use `string loc`

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;
@@ -292,6 +298,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
@@ -307,6 +316,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
@@ -321,15 +333,23 @@ 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_poly (bound, x) } ->
+    | { ptyp_desc = Ptyp_alias (x, name) } ->
 #if OCAML_VERSION >= (4, 05, 0)
-      let bound = List.map (fun y -> y.txt) bound in
+      [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, _, _) } ->
       List.map (
@@ -340,8 +360,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
@@ -359,30 +390,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)
@@ -422,11 +476,6 @@ let binop_reduce x a b =
 
 let strong_type_of_type ty =
   let free_vars = free_vars_in_core_type ty in
-#if OCAML_VERSION >= (4, 05, 0)
-  (* give the location of the whole type to the introduced variables *)
-  let loc = { ty.ptyp_loc with loc_ghost = true } in
-  let free_vars = List.map (fun v -> mkloc v loc) free_vars in
-#endif
   Typ.force_poly @@ Typ.poly free_vars ty
 
 type deriver_options =
@@ -499,7 +548,14 @@ 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

src/ppx_deriving.mli → 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.
@@ -229,7 +235,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.
@@ -245,19 +251,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

src_plugins/ppx_deriving_fold.cppo.ml

@@ -133,11 +133,18 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
 
 let sig_of_type ~options ~path type_decl =
   parse_options options;
+  let loc = type_decl.ptype_loc in
   let typ = Ppx_deriving.core_type_of_type_decl type_decl in
-  let acc = Typ.var Ppx_deriving.(fresh_var (free_vars_in_core_type typ)) in
+  let vars =
+#if OCAML_VERSION >= (4, 05, 0)
+    (List.map (fun tyvar -> tyvar.txt))
+#endif
+      (Ppx_deriving.free_vars_in_core_type typ)
+  in
+  let acc = Typ.var ~loc Ppx_deriving.(fresh_var vars) in
   let polymorphize = Ppx_deriving.poly_arrow_of_type_decl
                         (fun var -> [%type: [%t acc] -> [%t var] -> [%t acc]]) type_decl in
-  [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl))
+  [Sig.value ~loc (Val.mk (mkloc (Ppx_deriving.mangle_type_decl (`Prefix deriver) type_decl) loc)
               (polymorphize [%type: [%t acc] -> [%t typ] -> [%t acc]]))]
 
 let () =