diff --git a/ppx_deriving_yojson.opam b/ppx_deriving_yojson.opam index 0c20454..e7ef03b 100644 --- a/ppx_deriving_yojson.opam +++ b/ppx_deriving_yojson.opam @@ -17,7 +17,7 @@ depends: [ "dune" {>= "1.0"} "yojson" {>= "1.6.0"} "ppx_deriving" {>= "5.1"} - "ppxlib" {>= "0.26.0"} + "ppxlib" {>= "0.30.0"} "ounit2" {with-test} ] synopsis: diff --git a/src/ppx_deriving_yojson.ml b/src/ppx_deriving_yojson.ml index c331167..052874a 100644 --- a/src/ppx_deriving_yojson.ml +++ b/src/ppx_deriving_yojson.ml @@ -29,30 +29,30 @@ let deriver = "yojson" let raise_errorf = Ppx_deriving.raise_errorf let argn = Printf.sprintf "arg%d" - -let attr_int_encoding attrs = - match Ppx_deriving.attr ~deriver "encoding" attrs |> - Ppx_deriving.Arg.(get_attr ~deriver (enum ["string"; "number"])) with - | Some "string" -> `String - | Some "number" | None -> `Int - | _ -> assert false - -let attr_string name default attrs = - match Ppx_deriving.attr ~deriver name attrs |> - Ppx_deriving.Arg.(get_attr ~deriver string) with - | Some x -> x - | None -> default - -let attr_key = attr_string "key" -let attr_name = attr_string "name" -let attr_ser attrs = - Ppx_deriving.(attrs |> attr ~deriver "to_yojson" |> Arg.(get_attr ~deriver expr)) -let attr_desu attrs = - Ppx_deriving.(attrs |> attr ~deriver "of_yojson" |> Arg.(get_attr ~deriver expr)) - -let attr_default attrs = - Ppx_deriving.attr ~deriver "default" attrs |> - Ppx_deriving.Arg.(get_attr ~deriver expr) +let ct_attr_int_encoding = Attribute.declare "deriving.yojson.encoding" Attribute.Context.core_type + Ast_pattern.(single_expr_payload (pexp_variant (map0 (string "string") ~f:`String) (none) ||| pexp_variant (map0 (string "number") ~f:`Int) (none))) (fun enc -> enc) + +let label_attr_key = Attribute.declare "deriving.yojson.key" Attribute.Context.label_declaration + Ast_pattern.(single_expr_payload (estring __)) (fun s -> s) +let attr_name context = Attribute.declare "deriving.yojson.name" context + Ast_pattern.(single_expr_payload (estring __)) (fun s -> s) +let rtag_attr_name = attr_name Attribute.Context.rtag +let constr_attr_name = attr_name Attribute.Context.constructor_declaration +let ext_attr_name = attr_name Attribute.Context.extension_constructor + +let ct_attr_ser = Attribute.declare "deriving.yojson.to_yojson" Attribute.Context.core_type + Ast_pattern.(single_expr_payload __) (fun e -> e) +let ct_attr_desu = Attribute.declare "deriving.yojson.of_yojson" Attribute.Context.core_type + Ast_pattern.(single_expr_payload __) (fun e -> e) + +let attr_default context = Attribute.declare "deriving.yojson.default" context + Ast_pattern.(single_expr_payload __) (fun e -> e) +let attr_default = (attr_default Attribute.Context.label_declaration, attr_default Attribute.Context.core_type) + +let get_label_attribute (label_attr, ct_attr) label = + match Attribute.get label_attr label with + | Some _ as v -> v + | None -> Attribute.get ct_attr label.pld_type type options = { is_strict: bool; @@ -60,22 +60,7 @@ type options = { want_exn: bool; } -let parse_options options = - let strict = ref true in - let meta = ref false in - let exn = ref false in - let get_bool = Ppx_deriving.Arg.(get_expr ~deriver bool) in - options |> List.iter (fun (name, expr) -> - match name with - | "strict" -> strict := get_bool expr - | "meta" -> meta := get_bool expr - | "exn" -> exn := get_bool expr - | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name); - { - is_strict = !strict; - want_meta = !meta; - want_exn = !exn; - } +let args () = Deriving.Args.(empty +> arg "strict" (ebool __) +> arg "meta" (ebool __) +> arg "exn" (ebool __)) let poly_fun names expr = List.fold_right (fun name expr -> @@ -88,13 +73,13 @@ let type_add_attrs typ attributes = { typ with ptyp_attributes = typ.ptyp_attributes @ attributes } let rec ser_expr_of_typ ~quoter typ = - match attr_ser typ.ptyp_attributes with + match Attribute.get ct_attr_ser typ with | Some e -> Ppx_deriving.quote ~quoter e | None -> ser_expr_of_only_typ ~quoter typ and ser_expr_of_only_typ ~quoter typ = let loc = typ.ptyp_loc in let attr_int_encoding typ = - match attr_int_encoding typ with `String -> "String" | `Int -> "Intlit" + match Attribute.get ct_attr_int_encoding typ with Some `String -> "String" | Some `Int | None -> "Intlit" in let ser_expr_of_typ = ser_expr_of_typ ~quoter in match typ with @@ -110,10 +95,10 @@ and ser_expr_of_only_typ ~quoter typ = | [%type: int32] | [%type: Int32.t] -> [%expr fun x -> `Intlit (Int32.to_string x)] | [%type: int64] | [%type: Int64.t] -> - [%expr fun x -> [%e Exp.variant (attr_int_encoding typ.ptyp_attributes) + [%expr fun x -> [%e Exp.variant (attr_int_encoding typ) (Some [%expr (Int64.to_string x)])]] | [%type: nativeint] | [%type: Nativeint.t] -> - [%expr fun x -> [%e Exp.variant (attr_int_encoding typ.ptyp_attributes) + [%expr fun x -> [%e Exp.variant (attr_int_encoding typ) (Some [%expr (Nativeint.to_string x)])]] | [%type: [%t? typ] array] -> [%expr fun x -> `List (Array.to_list (Array.map [%e ser_expr_of_typ typ] x))] @@ -137,21 +122,21 @@ and ser_expr_of_only_typ ~quoter typ = match field.prf_desc with | Rtag(label, true (*empty*), []) -> let label = label.txt in - let attrs = field.prf_attributes in + let name = match Attribute.get rtag_attr_name field with Some s -> s | None -> label in Exp.case (Pat.variant label None) - [%expr `List [`String [%e str (attr_name label attrs)]]] + [%expr `List [`String [%e str name]]] | Rtag(label, false, [{ ptyp_desc = Ptyp_tuple typs }]) -> let label = label.txt in - let attrs = field.prf_attributes in + let name = match Attribute.get rtag_attr_name field with Some s -> s | None -> label in Exp.case (Pat.variant label (Some (ptuple (List.mapi (fun i _ -> pvar (argn i)) typs)))) - [%expr `List ((`String [%e str (attr_name label attrs)]) :: [%e + [%expr `List ((`String [%e str name]) :: [%e list (List.mapi (fun i typ -> app (ser_expr_of_typ typ) [evar (argn i)]) typs)])] | Rtag(label, false, [typ]) -> let label = label.txt in - let attrs = field.prf_attributes in + let name = match Attribute.get rtag_attr_name field with Some s -> s | None -> label in Exp.case (Pat.variant label (Some [%pat? x])) - [%expr `List [`String [%e str (attr_name label attrs)]; + [%expr `List [`String [%e str name]; [%e ser_expr_of_typ typ] x]] | Rinherit ({ ptyp_desc = Ptyp_constr (tname, _) } as typ) -> Exp.case [%pat? [%p Pat.type_ tname] as x] @@ -179,7 +164,7 @@ let rec desu_fold ~quoter ~loc ~path f typs = [%expr [%e y] >>= fun [%p pvar (argn i)] -> [%e x]]) [%expr Ok [%e f (List.mapi (fun i _ -> evar (argn i)) typs)]] and desu_expr_of_typ ~quoter ~path typ = - match attr_desu typ.ptyp_attributes with + match Attribute.get ct_attr_desu typ with | Some e -> Ppx_deriving.quote ~quoter e | None -> desu_expr_of_only_typ ~quoter ~path typ and desu_expr_of_only_typ ~quoter ~path typ = @@ -208,18 +193,18 @@ and desu_expr_of_only_typ ~quoter ~path typ = decode' [[%pat? `Int x], [%expr Ok (Int32.of_int x)]; [%pat? `Intlit x], [%expr Ok (Int32.of_string x)]] | [%type: int64] | [%type: Int64.t] -> - begin match attr_int_encoding typ.ptyp_attributes with - | `String -> + begin match Attribute.get ct_attr_int_encoding typ with + | Some `String -> decode [%pat? `String x] [%expr Ok (Int64.of_string x)] - | `Int -> + | Some `Int | None -> decode' [[%pat? `Int x], [%expr Ok (Int64.of_int x)]; [%pat? `Intlit x], [%expr Ok (Int64.of_string x)]] end | [%type: nativeint] | [%type: Nativeint.t] -> - begin match attr_int_encoding typ.ptyp_attributes with - | `String -> + begin match Attribute.get ct_attr_int_encoding typ with + | Some `String -> decode [%pat? `String x] [%expr Ok (Nativeint.of_string x)] - | `Int -> + | Some `Int | None -> decode' [[%pat? `Int x], [%expr Ok (Nativeint.of_int x)]; [%pat? `Intlit x], [%expr Ok (Nativeint.of_string x)]] end @@ -250,19 +235,19 @@ and desu_expr_of_only_typ ~quoter ~path typ = match field.prf_desc with | Rtag(label, true (*empty*), []) -> let label = label.txt in - let attrs = field.prf_attributes in - Exp.case [%pat? `List [`String [%p pstr (attr_name label attrs)]]] + let name = match Attribute.get rtag_attr_name field with Some s -> s | None -> label in + Exp.case [%pat? `List [`String [%p pstr name]]] [%expr Ok [%e Exp.variant label None]] | Rtag(label, false, [{ ptyp_desc = Ptyp_tuple typs }]) -> let label = label.txt in - let attrs = field.prf_attributes in - Exp.case [%pat? `List ((`String [%p pstr (attr_name label attrs)]) :: [%p + let name = match Attribute.get rtag_attr_name field with Some s -> s | None -> label in + Exp.case [%pat? `List ((`String [%p pstr name]) :: [%p plist (List.mapi (fun i _ -> pvar (argn i)) typs)])] (desu_fold ~quoter ~loc ~path (fun x -> (Exp.variant label (Some (tuple x)))) typs) | Rtag(label, false, [typ]) -> let label = label.txt in - let attrs = field.prf_attributes in - Exp.case [%pat? `List [`String [%p pstr (attr_name label attrs)]; x]] + let name = match Attribute.get rtag_attr_name field with Some s -> s | None -> label in + Exp.case [%pat? `List [`String [%p pstr name]; x]] [%expr [%e desu_expr_of_typ ~path typ] x >>= fun x -> Ok [%e Exp.variant label (Some [%expr x])]] | Rinherit ({ ptyp_desc = Ptyp_constr (tname, _) } as typ) -> @@ -304,8 +289,7 @@ and desu_expr_of_only_typ ~quoter ~path typ = let sanitize ~quoter decls = Ppx_deriving.sanitize ~quoter ~module_:(Lident "Ppx_deriving_yojson_runtime") decls -let ser_type_of_decl ~options ~path:_ type_decl = - ignore (parse_options options); +let ser_type_of_decl ~options:_ ~path:_ type_decl = let loc = type_decl.ptype_loc in let typ = Ppx_deriving.core_type_of_type_decl type_decl in let polymorphize = Ppx_deriving.poly_arrow_of_type_decl @@ -314,11 +298,12 @@ let ser_type_of_decl ~options ~path:_ type_decl = let ser_str_of_record ~quoter ~loc varname labels = let fields = - labels |> List.mapi (fun _i { pld_loc = loc; pld_name = { txt = name }; pld_type; pld_attributes } -> + labels |> List.mapi (fun _i ({ pld_loc = loc; pld_name = { txt = name }; pld_type; pld_attributes } as label) -> let field = Exp.field (evar varname) (mknoloc (Lident name)) in - let result = [%expr [%e str (attr_key name pld_attributes)], + let key = match Attribute.get label_attr_key label with Some s -> s | None -> name in + let result = [%expr [%e str key], [%e ser_expr_of_typ ~quoter @@ type_add_attrs pld_type pld_attributes] [%e field]] in - match attr_default (pld_type.ptyp_attributes @ pld_attributes) with + match get_label_attribute attr_default label with | None -> [%expr [%e result] :: fields] | Some default -> @@ -336,7 +321,6 @@ let ser_str_of_record ~quoter ~loc varname labels = let ser_str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = - ignore (parse_options options); let quoter = Ppx_deriving.create_quoter () in let polymorphize = Ppx_deriving.poly_fun_of_type_decl type_decl in let typ = Ppx_deriving.core_type_of_type_decl type_decl in @@ -401,8 +385,8 @@ let ser_str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = | Ptype_abstract, Some manifest -> ser_expr_of_typ ~quoter manifest | Ptype_variant constrs, _ -> constrs - |> List.map (fun { pcd_name = { txt = name' }; pcd_args; pcd_attributes } -> - let json_name = attr_name name' pcd_attributes in + |> List.map (fun ({ pcd_name = { txt = name' }; pcd_args; _ } as constr) -> + let json_name = match Attribute.get constr_attr_name constr with Some s -> s | None -> name' in match pcd_args with | Pcstr_tuple([]) -> Exp.case @@ -440,19 +424,18 @@ let ser_str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = [Str.value Nonrecursive [Vb.mk (pvar "_") [%expr [%e evar var_s]]] ] ) -let ser_str_of_type_ext ~options ~path:_ ({ ptyext_path = { loc }} as type_ext) = - ignore (parse_options options); +let ser_str_of_type_ext ~options:_ ~path:_ ({ ptyext_path = { loc }} as type_ext) = let quoter = Ppx_deriving.create_quoter () in let serializer = let pats = - List.fold_right (fun { pext_name = { txt = name' }; pext_kind; pext_attributes } acc_cases -> + List.fold_right (fun ({ pext_name = { txt = name' }; pext_kind; _ } as ext) acc_cases -> match pext_kind with | Pext_rebind _ -> (* nothing to do, since the constructor must be handled in original constructor declaration *) acc_cases | Pext_decl (_, pext_args, _) -> - let json_name = attr_name name' pext_attributes in + let json_name = match Attribute.get ext_attr_name ext with Some s -> s | None -> name' in let case = match pext_args with | Pcstr_tuple([]) -> @@ -496,8 +479,7 @@ let error_or typ = let loc = typ.ptyp_loc in [%type: [%t typ] Ppx_deriving_yojson_runtime.error_or] -let desu_type_of_decl_poly ~options ~path:_ type_decl type_ = - ignore (parse_options options); +let desu_type_of_decl_poly ~options:_ ~path:_ type_decl type_ = let loc = type_decl.ptype_loc in let polymorphize = Ppx_deriving.poly_arrow_of_type_decl (fun var -> [%type: Yojson.Safe.t -> [%t error_or var]]) type_decl in @@ -526,19 +508,20 @@ let desu_str_of_record ~quoter ~loc ~is_strict ~error ~path wrap_record labels = (labels |> List.mapi (fun i _ -> i)) in let default_case = if is_strict then top_error else [%expr loop xs _state] in let cases = - (labels |> List.mapi (fun i { pld_loc = loc; pld_name = { txt = name }; pld_type; pld_attributes } -> + (labels |> List.mapi (fun i ({ pld_loc = loc; pld_name = { txt = name }; pld_type; pld_attributes } as label) -> let path = path @ [name] in let thunks = labels |> List.mapi (fun j _ -> if i = j then app (desu_expr_of_typ ~quoter ~path @@ type_add_attrs pld_type pld_attributes) [evar "x"] else evar (argn j)) in - Exp.case [%pat? ([%p pstr (attr_key name pld_attributes)], x) :: xs] + let key = match Attribute.get label_attr_key label with Some s -> s | None -> name in + Exp.case [%pat? ([%p pstr key], x) :: xs] [%expr loop xs [%e tuple thunks]])) @ [Exp.case [%pat? []] record; Exp.case [%pat? _ :: xs] default_case] and thunks = - labels |> List.map (fun { pld_name = { txt = name }; pld_type; pld_attributes } -> - match attr_default (pld_type.ptyp_attributes @ pld_attributes) with + labels |> List.map (fun ({ pld_name = { txt = name }; pld_type; _ } as label) -> + match get_label_attribute attr_default label with | None -> error (path @ [name]) | Some default -> let default = [%expr ([%e default] : [%t pld_type])] in @@ -554,7 +537,7 @@ let desu_str_of_record ~quoter ~loc ~is_strict ~error ~path wrap_record labels = let desu_str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = - let { is_strict; want_exn; _ } = parse_options options in + let { is_strict; want_exn; _ } = options in let quoter = Ppx_deriving.create_quoter () in let path = path @ [type_decl.ptype_name.txt] in let error path = [%expr Error [%e str (String.concat "." path)]] in @@ -616,19 +599,21 @@ let desu_str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = | Ptype_abstract, Some manifest -> desu_expr_of_typ ~quoter ~path manifest | Ptype_variant constrs, _ -> - let cases = List.map (fun { pcd_loc = loc; pcd_name = { txt = name' }; pcd_args; pcd_attributes } -> + let cases = List.map (fun ({ pcd_loc = loc; pcd_name = { txt = name' }; pcd_args; _ } as constr') -> match pcd_args with | Pcstr_tuple(args) -> + let name = match Attribute.get constr_attr_name constr' with Some s -> s | None -> name' in Exp.case - [%pat? `List ((`String [%p pstr (attr_name name' pcd_attributes)]) :: + [%pat? `List ((`String [%p pstr name]) :: [%p plist (List.mapi (fun i _ -> pvar (argn i)) args)])] (desu_fold ~quoter ~loc ~path (fun x -> constr name' x) args) | Pcstr_record labels -> let wrap_record r = constr name' [r] in let sub = desu_str_of_record ~quoter ~loc ~is_strict ~error ~path wrap_record labels in + let name = match Attribute.get constr_attr_name constr' with Some s -> s | None -> name' in Exp.case - [%pat? `List ((`String [%p pstr (attr_name name' pcd_attributes)]) :: + [%pat? `List ((`String [%p pstr name]) :: [%p plist [pvar (argn 0)]])] [%expr [%e sub] [%e evar (argn 0)] ] ) constrs @@ -667,12 +652,11 @@ let desu_str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) = ;Str.value Nonrecursive [Vb.mk (pvar "_") [%expr [%e evar var_s_exn]]]]) ) -let desu_str_of_type_ext ~options ~path ({ ptyext_path = { loc } } as type_ext) = - ignore(parse_options options); +let desu_str_of_type_ext ~options:_ ~path ({ ptyext_path = { loc } } as type_ext) = let quoter = Ppx_deriving.create_quoter () in let desurializer = let pats = - List.fold_right (fun { pext_name = { txt = name' }; pext_kind; pext_attributes } acc_cases -> + List.fold_right (fun ({ pext_name = { txt = name' }; pext_kind; _ } as ext) acc_cases -> match pext_kind with | Pext_rebind _ -> (* nothing to do since it must have been handled in the original @@ -682,8 +666,9 @@ let desu_str_of_type_ext ~options ~path ({ ptyext_path = { loc } } as type_ext) let case = match pext_args with | Pcstr_tuple(args) -> + let name = match Attribute.get ext_attr_name ext with Some s -> s | None -> name' in Exp.case - [%pat? `List ((`String [%p pstr (attr_name name' pext_attributes)]) :: + [%pat? `List ((`String [%p pstr name]) :: [%p plist (List.mapi (fun i _ -> pvar (argn i)) args)])] (desu_fold ~quoter ~loc ~path (fun x -> constr name' x) args) | Pcstr_record _ -> @@ -750,7 +735,7 @@ let ser_sig_of_type ~options ~path type_decl = let ser_sig_of_type_ext ~options:_ ~path:_ _type_ext = [] let desu_sig_of_type ~options ~path type_decl = - let { want_exn; _ } = parse_options options in + let { want_exn; _ } = options in let of_yojson = Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Suffix "of_yojson") type_decl)) (desu_type_of_decl ~options ~path type_decl)) @@ -794,7 +779,7 @@ let desu_sig_of_type ~options ~path type_decl = let desu_sig_of_type_ext ~options:_ ~path:_ _type_ext = [] let yojson_str_fields ~options ~path:_ type_decl = - let { want_meta; _ } = parse_options options in + let { want_meta; _ } = options in match want_meta, type_decl.ptype_kind with | false, _ | true, Ptype_open -> [] | true, kind -> @@ -802,8 +787,9 @@ let yojson_str_fields ~options ~path:_ type_decl = | Ptype_record labels, _ -> let loc = !Ast_helper.default_loc in let fields = - labels |> List.map (fun { pld_name = { txt = name }; pld_attributes } -> - [%expr [%e str (attr_key name pld_attributes)]]) + labels |> List.map (fun ({ pld_name = { txt = name }; _ } as label) -> + let key = match Attribute.get label_attr_key label with Some s -> s | None -> name in + [%expr [%e str key]]) in let flist = List.fold_right (fun n acc -> [%expr [%e n] :: [%e acc]]) fields [%expr []] @@ -818,7 +804,7 @@ let yojson_str_fields ~options ~path:_ type_decl = | _ -> [] let yojson_sig_fields ~options ~path:_ type_decl = - let { want_meta; _ } = parse_options options in + let { want_meta; _ } = options in match want_meta, type_decl.ptype_kind with | false, _ | true, Ptype_open -> [] | true, kind -> @@ -897,30 +883,90 @@ let desu_core_expr_of_typ typ = let typ = Ppx_deriving.strong_type_of_type typ in sanitize ~quoter (desu_expr_of_typ ~quoter ~path:[] typ) -let () = - Ppx_deriving.(register - (create "yojson" - ~type_decl_str:(structure (on_str_decls str_of_type)) - ~type_ext_str:str_of_type_ext - ~type_decl_sig:(on_sig_decls sig_of_type) - ~type_ext_sig:sig_of_type_ext - () - )); - Ppx_deriving.(register - (create "to_yojson" - ~core_type:ser_core_expr_of_typ - ~type_decl_str:(structure (on_str_decls str_of_type_to_yojson)) - ~type_ext_str:ser_str_of_type_ext - ~type_decl_sig:(on_sig_decls sig_of_type_to_yojson) - ~type_ext_sig:ser_sig_of_type_ext - () - )); - Ppx_deriving.(register - (create "of_yojson" - ~core_type:desu_core_expr_of_typ - ~type_decl_str:(structure (on_str_decls str_of_type_of_yojson)) - ~type_ext_str:desu_str_of_type_ext - ~type_decl_sig:(on_sig_decls sig_of_type_of_yojson) - ~type_ext_sig:desu_sig_of_type_ext - () - )) +let make_gen f = + let f' ~ctxt x strict meta exn = + let is_strict = match strict with + | Some strict -> strict + | None -> true (* by default *) + in + let want_meta = match meta with + | Some meta -> meta + | None -> false (* by default *) + in + let want_exn = match exn with + | Some exn -> exn + | None -> false (* by default *) + in + let options = { is_strict; want_meta; want_exn } in + let path = + let code_path = Expansion_context.Deriver.code_path ctxt in + (* Cannot use main_module_name from code_path because that contains .cppo suffix (via line directives), so it's actually not the module name. *) + (* Ppx_deriving.module_from_input_name ported to ppxlib. *) + let main_module_path = match Expansion_context.Deriver.input_name ctxt with + | "" + | "_none_" -> [] + | input_name -> + match Filename.chop_suffix input_name ".ml" with + | exception _ -> + (* see https://github.com/ocaml-ppx/ppx_deriving/pull/196 *) + [] + | path -> + [String.capitalize_ascii (Filename.basename path)] + in + main_module_path @ Code_path.submodule_path code_path + in + f ~options ~path x + in + Deriving.Generator.V2.make (args ()) f' + +let _to_deriving: Deriving.t = + Deriving.add + "to_yojson" + ~str_type_decl:(make_gen (fun ~options ~path (_, type_decls) -> + structure (on_str_decls str_of_type_to_yojson) ~options ~path type_decls + )) + ~sig_type_decl:(make_gen (fun ~options ~path (_, type_decls) -> + on_sig_decls sig_of_type_to_yojson ~options ~path type_decls + )) + ~str_type_ext:(make_gen ser_str_of_type_ext) + ~sig_type_ext:(make_gen ser_sig_of_type_ext) + +let _of_deriving: Deriving.t = + Deriving.add + "of_yojson" + ~str_type_decl:(make_gen (fun ~options ~path (_, type_decls) -> + structure (on_str_decls str_of_type_of_yojson) ~options ~path type_decls + )) + ~sig_type_decl:(make_gen (fun ~options ~path (_, type_decls) -> + on_sig_decls sig_of_type_of_yojson ~options ~path type_decls + )) + ~str_type_ext:(make_gen desu_str_of_type_ext) + ~sig_type_ext:(make_gen desu_sig_of_type_ext) + +(* Not just alias because yojson also has meta (without its own deriver name) *) +let _deriving: Deriving.t = + Deriving.add + "yojson" + ~str_type_decl:(make_gen (fun ~options ~path (_, type_decls) -> + structure (on_str_decls str_of_type) ~options ~path type_decls + )) + ~sig_type_decl:(make_gen (fun ~options ~path (_, type_decls) -> + on_sig_decls sig_of_type ~options ~path type_decls + )) + ~str_type_ext:(make_gen str_of_type_ext) + ~sig_type_ext:(make_gen sig_of_type_ext) + +(* custom extensions such that "derive"-prefixed also works *) +let to_derive_extension = + Extension.V3.declare "ppx_deriving_yojson.derive.to_yojson" Extension.Context.expression + Ast_pattern.(ptyp __) (fun ~ctxt:_ -> ser_core_expr_of_typ) +let of_derive_extension = + Extension.V3.declare "ppx_deriving_yojson.derive.of_yojson" Extension.Context.expression + Ast_pattern.(ptyp __) (fun ~ctxt:_ -> desu_core_expr_of_typ) +let _derive_transformation = + Driver.register_transformation + deriver + ~rules:[ + Context_free.Rule.extension to_derive_extension; + Context_free.Rule.extension of_derive_extension; + ] diff --git a/src/ppx_deriving_yojson.mli b/src/ppx_deriving_yojson.mli new file mode 100644 index 0000000..e69de29 diff --git a/src_test/test_ppx_yojson.ml b/src_test/test_ppx_yojson.ml index 5c46702..b596deb 100644 --- a/src_test/test_ppx_yojson.ml +++ b/src_test/test_ppx_yojson.ml @@ -19,6 +19,9 @@ let show_error_or = end in M.show_error_or +let show_keys keys = + Format.asprintf "[%a]" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.pp_print_string fmt "; ") Format.pp_print_string) keys + let assert_roundtrip pp_obj to_json of_json obj str = let json = Yojson.Safe.from_string str in let cleanup json = Yojson.Safe.(json |> to_string |> from_string) in @@ -64,7 +67,7 @@ type pvd = [ pva | pvb | int pvc ] type v = A | B of int | C of int * string [@@deriving show, yojson] type r = { x : int; y : string } -[@@deriving show, yojson] +[@@deriving show, yojson { meta = true }] type rv = RA | RB of int | RC of int * string | RD of { z : string } [@@deriving show, yojson] @@ -204,7 +207,8 @@ let test_var _ctxt = let test_rec _ctxt = assert_roundtrip pp_r r_to_yojson r_of_yojson - {x=42; y="foo"} "{\"x\":42,\"y\":\"foo\"}" + {x=42; y="foo"} "{\"x\":42,\"y\":\"foo\"}"; + assert_equal ~printer:show_keys ["x"; "y"] Yojson_meta_r.keys let test_recvar _ctxt = assert_roundtrip pp_rv rv_to_yojson rv_of_yojson @@ -220,11 +224,12 @@ type geo = { lat : float [@key "Latitude"] ; lon : float [@key "Longitude"] ; } -[@@deriving yojson, show] +[@@deriving yojson { meta = true }, show] let test_key _ctxt = assert_roundtrip pp_geo geo_to_yojson geo_of_yojson {lat=35.6895; lon=139.6917} - "{\"Latitude\":35.6895,\"Longitude\":139.6917}" + "{\"Latitude\":35.6895,\"Longitude\":139.6917}"; + assert_equal ~printer:show_keys ["Latitude"; "Longitude"] Yojson_meta_geo.keys let test_field_err _ctxt = assert_equal ~printer:(show_error_or pp_geo)