Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Jump to bottom

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

Merged
merged 1 commit into from
Nov 17, 2017
Merged

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

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
1 commit
Select commit
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
86 changes: 71 additions & 15 deletions src/ppx_deriving.cppo.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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;
Expand Down Expand Up @@ -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
Expand All @@ -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
Expand All @@ -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 (
Expand All @@ -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
Expand All @@ -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)
Expand Down Expand Up @@ -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 =
Expand Down Expand Up @@ -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
Expand Down
16 changes: 11 additions & 5 deletions src/ppx_deriving.mli → src/ppx_deriving.cppo.mli
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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.
Expand Down Expand Up @@ -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.
Expand All @@ -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
Expand Down
11 changes: 9 additions & 2 deletions src_plugins/ppx_deriving_fold.cppo.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 () =
Expand Down