diff --git a/src/ppx_deriving.cppo.ml b/src/ppx_deriving.cppo.ml index bb8bbb6d..288d3583 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; @@ -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 diff --git a/src/ppx_deriving.mli b/src/ppx_deriving.cppo.mli similarity index 96% rename from src/ppx_deriving.mli rename to src/ppx_deriving.cppo.mli index 14480444..cac2c7fe 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. @@ -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 diff --git a/src_plugins/ppx_deriving_fold.cppo.ml b/src_plugins/ppx_deriving_fold.cppo.ml index 0ec67540..c3b8d6f5 100644 --- a/src_plugins/ppx_deriving_fold.cppo.ml +++ b/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 () =