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

Modify polymorphic type variables to include location. #64

Closed
wants to merge 1 commit into from
Closed

Modify polymorphic type variables to include location. #64

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
49 changes: 25 additions & 24 deletions src/ppx_deriving_yojson.cppo.ml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -253,6 +253,23 @@ let ser_str_of_record varname labels =
[%expr let fields = [] in [%e assoc]]


let poly_vars_of_type_decl td =
#if OCAML_VERSION >= (4, 05, 0)
let loc = { td.ptype_loc with loc_ghost = true } in
Ppx_deriving.fold_left_type_decl (fun acc name -> (mkloc name loc) :: acc) [] td
#else
Ppx_deriving.fold_left_type_decl (fun acc name -> name :: acc) [] td
#endif

let poly_fun_of_exp_and_type_decl init_exp td =
#if OCAML_VERSION >= (4, 05, 0)
let loc = { td.ptype_loc with loc_ghost = true } in
Ppx_deriving.fold_left_type_decl (fun exp name -> Exp.newtype (mkloc name loc) exp)
init_exp td
#else
Ppx_deriving.fold_left_type_decl (fun exp name -> Exp.newtype name exp) init_exp td
#endif
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I think that it would be nice if you could factor the similar parts of the two blocks out of the conditional (for the two functions above). The way I did it in my patch, but there may be a better way, is to define (conditionally) worker functions, so I would guess mkname for the first function and newtype for the second, and then have the "main" line call these functions: (fun acc name -> mkname name :: acc) and (fun exp name -> newtype name exp). I guess the definitions would look somewhat like:

#if OCAML_VERSION >= (4, 05, 0)
  let loc = ... in
  let mkname name = mkloc name loc in
#else
  let mkname name = name in
#endif

Copy link
Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I guess this is where my naive understanding of the AST will come out, but in your suggested approach wouldn't mkname's loc depend on the type_declaration that we're folding?

In that case, yes, I do think that we should change fold_left_type_decl to have a 'a -> str -> 'a function in 4.05.0 and 'a -> string -> 'a in < 4.05.0.


let ser_str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
ignore (parse_options options);
let polymorphize = Ppx_deriving.poly_fun_of_type_decl type_decl in
Expand All @@ -274,9 +291,7 @@ let ser_str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
| Some _ ->
raise_errorf ~loc "%s: extensible type manifest should be a type name" deriver
| None ->
let poly_vars = List.rev
(Ppx_deriving.fold_left_type_decl (fun acc name -> name :: acc) [] type_decl)
in
let poly_vars = List.rev (poly_vars_of_type_decl type_decl) in
let polymorphize_ser = Ppx_deriving.poly_arrow_of_type_decl
(fun var -> [%type: [%t var] -> Yojson.Safe.json]) type_decl
in
Expand All @@ -288,10 +303,7 @@ let ser_str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
invalid_arg ("to_yojson: Maybe a [@@deriving yojson] is missing when extending the type "^
[%e e_type_path])]
in
let poly_fun = polymorphize default_fun in
let poly_fun =
(Ppx_deriving.fold_left_type_decl (fun exp name -> Exp.newtype name exp) poly_fun type_decl)
in
let poly_fun = poly_fun_of_exp_and_type_decl (polymorphize default_fun) type_decl in
let mod_name = "M_"^to_yojson_name in
let typ = Type.mk ~kind:(Ptype_record [Type.field ~mut:Mutable (mknoloc "f") ty])
(mknoloc "t_to_yojson")
Expand Down Expand Up @@ -345,8 +357,7 @@ let ser_str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
raise_errorf ~loc "%s cannot be derived for fully abstract types" deriver
in
let ty = ser_type_of_decl ~options ~path type_decl in
let fv = Ppx_deriving.free_vars_in_core_type ty in
let poly_type = Typ.force_poly @@ Typ.poly fv @@ ty in
let poly_type = Ppx_deriving.strong_type_of_type ty in
let var = pvar (Ppx_deriving.mangle_type_decl (`Suffix "to_yojson") type_decl) in
([],
[Vb.mk (Pat.constraint_ var poly_type)
Expand Down Expand Up @@ -477,19 +488,14 @@ let desu_str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
| Some _ ->
raise_errorf ~loc "%s: extensible type manifest should be a type name" deriver
| None ->
let poly_vars = List.rev
(Ppx_deriving.fold_left_type_decl (fun acc name -> name :: acc) [] type_decl)
in
let poly_vars = List.rev (poly_vars_of_type_decl type_decl) in
let polymorphize_desu = Ppx_deriving.poly_arrow_of_type_decl
(fun var -> [%type: Yojson.Safe.json -> [%t error_or var]]) type_decl in
let ty = Typ.poly poly_vars
(polymorphize_desu [%type: Yojson.Safe.json -> [%t error_or typ]])
in
let default_fun = Exp.function_ [Exp.case [%pat? _] top_error] in
let poly_fun = polymorphize default_fun in
let poly_fun =
(Ppx_deriving.fold_left_type_decl (fun exp name -> Exp.newtype name exp) poly_fun type_decl)
in
let poly_fun = poly_fun_of_exp_and_type_decl (polymorphize default_fun) type_decl in
let mod_name = "M_"^of_yojson_name in
let typ = Type.mk ~kind:(Ptype_record [Type.field ~mut:Mutable (mknoloc "f") ty])
(mknoloc "t_of_yojson") in
Expand Down Expand Up @@ -539,8 +545,7 @@ let desu_str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
raise_errorf ~loc "%s cannot be derived for fully abstract types" deriver
in
let ty = desu_type_of_decl ~options ~path type_decl in
let fv = Ppx_deriving.free_vars_in_core_type ty in
let poly_type = Typ.force_poly @@ Typ.poly fv @@ ty in
let poly_type = Ppx_deriving.strong_type_of_type ty in
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Nice.

let var = pvar (Ppx_deriving.mangle_type_decl (`Suffix "of_yojson") type_decl) in
([],
[Vb.mk (Pat.constraint_ var poly_type)
Expand Down Expand Up @@ -603,9 +608,7 @@ let ser_sig_of_type ~options ~path type_decl =
let mod_name = Ppx_deriving.mangle_type_decl
(`PrefixSuffix ("M", "to_yojson")) type_decl
in
let poly_vars = List.rev
(Ppx_deriving.fold_left_type_decl (fun acc name -> name :: acc) [] type_decl)
in
let poly_vars = List.rev (poly_vars_of_type_decl type_decl) in
let typ = Ppx_deriving.core_type_of_type_decl type_decl in
let polymorphize_ser = Ppx_deriving.poly_arrow_of_type_decl
(fun var -> [%type: [%t var] -> Yojson.Safe.json]) type_decl
Expand Down Expand Up @@ -638,9 +641,7 @@ let desu_sig_of_type ~options ~path type_decl =
let mod_name = Ppx_deriving.mangle_type_decl
(`PrefixSuffix ("M", "of_yojson")) type_decl
in
let poly_vars = List.rev
(Ppx_deriving.fold_left_type_decl (fun acc name -> name :: acc) [] type_decl)
in
let poly_vars = List.rev (poly_vars_of_type_decl type_decl) in
let typ = Ppx_deriving.core_type_of_type_decl type_decl in
let polymorphize_desu = Ppx_deriving.poly_arrow_of_type_decl
(fun var -> [%type: Yojson.Safe.json -> [%t error_or var]]) type_decl in
Expand Down