From 07ce9a37af1154130683921be55657e6114d373c Mon Sep 17 00:00:00 2001 From: Maxime Levillain Date: Mon, 7 Oct 2024 09:13:36 +0200 Subject: [PATCH] deriver for services --- src/ppx/dune | 2 +- src/ppx/ppx.ml | 3 +- src/ppx/ppx_client.ml | 3 +- src/ppx/ppx_common.ml | 173 ++++++++++++++++++++++++++++++--------- src/ppx/ppx_server.ml | 3 +- test/ppx/dune | 2 +- test/ppx/test_ppx_lib.ml | 7 ++ 7 files changed, 150 insertions(+), 43 deletions(-) diff --git a/src/ppx/dune b/src/ppx/dune index 9c5a5d7..889ad0d 100644 --- a/src/ppx/dune +++ b/src/ppx/dune @@ -4,7 +4,7 @@ (optional) (modules ppx_common) (preprocess (pps ppxlib.metaquot)) - (libraries ppxlib)) + (libraries ppx_deriving_encoding.lib)) (library (name ppx_client) diff --git a/src/ppx/ppx.ml b/src/ppx/ppx.ml index 3a66212..5372d38 100644 --- a/src/ppx/ppx.ml +++ b/src/ppx/ppx.ml @@ -9,4 +9,5 @@ (**************************************************************************) let () = - Ppxlib.Driver.register_transformation "ez_api" ~impl:Ppx_common.impl + Ppxlib.Driver.register_transformation "ez_api" ~impl:Ppx_common.impl; + Ppx_common.derivers () diff --git a/src/ppx/ppx_client.ml b/src/ppx/ppx_client.ml index 8766036..c69d7a6 100644 --- a/src/ppx/ppx_client.ml +++ b/src/ppx/ppx_client.ml @@ -9,4 +9,5 @@ (**************************************************************************) let () = - Ppxlib.Driver.register_transformation "ez_api_client" ~impl:(Ppx_common.impl ~kind:`client) + Ppxlib.Driver.register_transformation "ez_api_client" ~impl:(Ppx_common.impl ~kind:`client); + Ppx_common.derivers () diff --git a/src/ppx/ppx_common.ml b/src/ppx/ppx_common.ml index 5f1dbd5..ef5ecfb 100644 --- a/src/ppx/ppx_common.ml +++ b/src/ppx/ppx_common.ml @@ -45,29 +45,19 @@ type options = { service : expression option; } -let empty ~loc = pexp_construct ~loc (llid ~loc "EzAPI.Empty") None let raw e = let loc = e.pexp_loc in - let e = - eapply ~loc (evar ~loc "List.filter_map") [ evar ~loc "EzAPI.Mime.parse"; e ] in - pexp_construct ~loc (llid ~loc "EzAPI.Raw") @@ Some e -let json e = - let loc = e.pexp_loc in - pexp_construct ~loc (llid ~loc "EzAPI.Json") @@ Some e - -let options ?register ?name loc = - let register = match register with - | None -> pexp_construct ~loc (llid ~loc "true") None - | Some register -> register in - let name = match name with - | None -> [%expr None] - | Some name -> esome (estring ~loc name) in { - path = pexp_ident ~loc (llid ~loc "EzAPI.Path.root"); - input = empty ~loc; output = empty ~loc; errors = [%expr None]; params = [%expr None]; - section = [%expr None]; name; descr = [%expr None]; - security = [%expr None]; register; input_example = [%expr None]; hide = [%expr None]; - output_example = [%expr None]; error_type = ptyp_constr ~loc (llid ~loc "exn") []; - security_type = ptyp_constr ~loc (llid ~loc "EzAPI.no_security") []; + [%expr EzAPI.Raw (List.filter_map EzAPI.Mime.parse [%e e])] + +let options loc = { + path = [%expr EzAPI.Path.root]; + input = [%expr EzAPI.Empty]; + output = [%expr EzAPI.Empty]; + errors = [%expr None]; params = [%expr None]; + section = [%expr None]; name=[%expr None]; descr = [%expr None]; + security = [%expr None]; register=[%expr true]; input_example = [%expr None]; + hide = [%expr None]; output_example = [%expr None]; error_type = [%type: exn]; + security_type = [%type: EzAPI.no_security]; debug = false; directory = None; service = None } @@ -100,13 +90,12 @@ let string_literal = function | Ppxlib.Pconst_string (s, _, _) -> Some s | _ -> None -let get_options ~loc ?name ?(client=false) p = - let register = if not client then None else Some (pexp_construct ~loc (llid ~loc "false") None) in +let get_options ~loc ?(options=options loc) ?name p = match p with | PStr [ {pstr_desc=Pstr_eval ({pexp_desc=Pexp_record (l, _); _}, _); _} ] -> let l = List.filter_map (function ({txt=Lident s; loc}, e) -> Some (s, loc, e) | _ -> None) l in List.fold_left (fun (name, acc) (s, loc, e) -> match s with - | "path" -> begin match e.pexp_desc with + | "path" | "p" -> begin match e.pexp_desc with | Pexp_constant cst -> begin match string_literal cst with | Some s -> name, { acc with path = parse_path ~loc:e.pexp_loc s } @@ -114,9 +103,9 @@ let get_options ~loc ?name ?(client=false) p = end | _ -> Format.eprintf "path should be a literal"; name, acc end - | "input" -> name, { acc with input = json e } + | "input" -> name, { acc with input = [%expr EzAPI.Json [%e e]] } | "raw_input" -> name, { acc with input = raw e } - | "output" -> name, { acc with output = json e } + | "output" -> name, { acc with output = [%expr EzAPI.Json [%e e]] } | "raw_output" -> name, { acc with output = raw e } | "params" -> name, { acc with params = esome e } | "errors" -> name, { acc with errors = esome e; error_type = ptyp_any ~loc } @@ -130,8 +119,9 @@ let get_options ~loc ?name ?(client=false) p = | _ -> Format.eprintf "name should be a string literal"; name, acc end | _ -> - Format.eprintf "name should be a literal"; - name, acc + match name with + | Some n -> Some n, { acc with name = [%expr Some [%e estring ~loc n]] } + | _ -> name, acc end | "descr" -> name, { acc with descr = esome e } | "security" -> name, { acc with security = esome e; security_type = ptyp_any ~loc } @@ -150,20 +140,21 @@ let get_options ~loc ?name ?(client=false) p = end | "service" -> name, { acc with service = Some e; error_type = ptyp_any ~loc; security_type = ptyp_any ~loc } - | _ -> name, acc) (name, options ?register ?name loc) l + | _ -> name, acc) (name, options) l | PStr [ {pstr_desc=Pstr_eval ({pexp_desc=Pexp_ident _; _} as e, _); _} ] -> - let o = options ?register ?name loc in - name, { o with service = Some e; error_type = ptyp_any ~loc; security_type = ptyp_any ~loc } + name, { options with service = Some e; error_type = ptyp_any ~loc; security_type = ptyp_any ~loc } + | PStr [ {pstr_desc=Pstr_eval ({pexp_desc=Pexp_constant Pconst_string (s, loc, _); _}, _); _} ] -> + name, { options with path = parse_path ~loc s } | PStr s -> Format.eprintf "attribute not understood %a@." Pprintast.structure s; - name, options ?register ?name loc + name, options | _ -> Format.eprintf "attribute not understood@."; - name, options ?register ?name loc + name, options -let service_value ?name ?client ~meth ~loc p = +let service_value ?name ?options ~meth ~loc p = let meth = pexp_variant ~loc (String.uppercase_ascii meth) None in - let name, options = get_options ~loc ?name ?client p in + let name, options = get_options ?name ?options ~loc p in match name with | None -> Location.raise_errorf ~loc "service doesn't have a name" | Some name -> @@ -344,6 +335,8 @@ let server ~loc p = [%expr EzLwtSys.run (fun () -> [%e server_aux e])] | _ -> Location.raise_errorf ~loc "server options not understood" +(** main mapper *) + let deprecate = let t : (string, unit) Hashtbl.t = Hashtbl.create 10 in fun s -> @@ -442,14 +435,52 @@ let transform ?kind () = (* client service *) | Pstr_attribute a when List.mem a.attr_name.txt methods -> deprecate a.attr_name.txt; - let service, _, _ = service_value ~client:true ~meth:a.attr_name.txt ~loc:a.attr_loc a.attr_payload in + let loc = a.attr_loc in + let options = { (options loc) with register = [%expr false] } in + let service, _, _ = service_value ~options ~meth:a.attr_name.txt ~loc:a.attr_loc a.attr_payload in service :: acc | Pstr_extension (({txt; loc}, PStr [ { pstr_desc = Pstr_value (_, [ { pvb_expr; pvb_pat= {ppat_desc=Ppat_var {txt=name; _}; _}; _} ]); _} ]), _) when List.mem txt methods -> - let service, _, _ = service_value ~name ~client:true ~meth:txt ~loc @@ PStr [ pstr_eval ~loc pvb_expr [] ] in + let options = { (options loc) with register = [%expr false] } in + let service, _, _ = service_value ~name ~options ~meth:txt ~loc @@ PStr [ pstr_eval ~loc pvb_expr [] ] in service :: acc | Pstr_extension (({txt; loc}, p), _) when List.mem txt methods -> - let service, _, _ = service_value ~client:true ~meth:txt ~loc p in + let options = { (options loc) with register = [%expr false] } in + let service, _, _ = service_value ~options ~meth:txt ~loc p in service :: acc + | Pstr_type (_rec_flag, [ t ]) -> + let loc = t.ptype_loc in + begin match List.find_opt (fun a -> List.mem a.attr_name.txt methods) t.ptype_attributes with + | None -> (super#structure_item it) :: acc + | Some a -> + let meth = a.attr_name.txt in + let enc = + let open Ppx_deriving_encoding_lib.Encoding in + let {enc; _} = expressions t in + enc in + let input, output = match meth with + | "get" | "put" -> [%expr Some EzAPI.Empty], [%expr EzAPI.Json [%e enc]] + | _ -> [%expr EzAPI.Json [%e enc]], [%expr Some EzAPI.Empty] in + let options = { (options loc) with register = [%expr false]; input; output } in + let name = t.ptype_name.txt ^ "_s" in + let service, _, _ = service_value ~name ~options ~meth ~loc a.attr_payload in + service :: it :: acc + end + | Pstr_type (_rec_flag, [ t_input; t_output ]) -> + let loc = t_input.ptype_loc in + begin match List.find_opt (fun a -> List.mem a.attr_name.txt methods) t_output.ptype_attributes with + | None -> (super#structure_item it) :: acc + | Some a -> + let meth = a.attr_name.txt in + let input, output = + let open Ppx_deriving_encoding_lib.Encoding in + let {enc=enc_input; _} = expressions t_input in + let {enc=enc_output; _} = expressions t_output in + [%expr EzAPI.Json [%e enc_input]], [%expr EzAPI.Json [%e enc_output]] in + let options = { (options loc) with register = [%expr false]; input; output } in + let name = t_input.ptype_name.txt ^ "_s" in + let service, _, _ = service_value ~name ~options ~meth ~loc a.attr_payload in + service :: it :: acc + end | _ -> (self#structure_item it) :: acc ) [] str @@ -460,3 +491,69 @@ let transform ?kind () = end let impl ?kind str = (transform ?kind ())#structure str + +let deriver_str_gen meth ~loc ~path:_ (_rec_flag, l) path input output errors params section name + descr security register hide input_example output_example debug = + let options = options loc in + let sname = match l with t :: _ -> Some (t.ptype_name.txt ^ "_s") | [] -> None in + let input, output = match meth, l with + | _, [ t_input; t_output ] -> + [%expr EzAPI.Json ([%e evar ~loc (t_input.ptype_name.txt ^ "_enc")] ())], + [%expr EzAPI.Json ([%e evar ~loc (t_output.ptype_name.txt ^ "_enc")] ())] + | ("get" | "put"), t :: _ -> + Option.value ~default:options.input input, + [%expr EzAPI.Json [%e evar ~loc (t.ptype_name.txt ^ "_enc")]] + | _, t :: _ -> + [%expr EzAPI.Json [%e evar ~loc (t.ptype_name.txt ^ "_enc")]], + Option.value ~default:options.output output + | _ -> Option.value ~default:options.input input, Option.value ~default:options.output output in + let path = match path with + | Some { pexp_desc = Pexp_constant cst; pexp_loc=loc; _ } -> + begin match string_literal cst with + | Some s -> parse_path ~loc s + | _ -> Format.eprintf "path should be a string literal"; options.path + end + | _ -> options.path in + let security_type, security = match security with + | None -> options.security_type, options.security + | Some e -> [%type: _], e in + let options = { + options with + path; input; output; + errors = Option.value ~default:options.errors errors; + params = Option.value ~default:options.params params; + section = Option.value ~default:options.section section; + name = Option.value ~default:options.name name; + descr = Option.value ~default:options.descr descr; + security; security_type; + register = Option.value ~default:[%expr false] register; + hide = Option.value ~default:options.hide hide; + input_example = Option.value ~default:options.input_example input_example; + output_example = Option.value ~default:options.output_example output_example; + debug; + } in + let s, _, _ = service_value ~meth ~loc ~options ?name:sname (PStr []) in + [ s ] + +let derivers () = + let open Ppxlib.Deriving in + List.iter (fun meth -> + let args_str = Args.( + empty + +> arg "path" __ + +> arg "input" __ + +> arg "output" __ + +> arg "errors" __ + +> arg "params" __ + +> arg "section" __ + +> arg "name" __ + +> arg "descr" __ + +> arg "security" __ + +> arg "register" __ + +> arg "hide" __ + +> arg "input_example" __ + +> arg "output_example" __ + +> flag "debug" + ) in + let str_type_decl = Generator.make args_str (deriver_str_gen meth) in + ignore @@ add meth ~str_type_decl) methods diff --git a/src/ppx/ppx_server.ml b/src/ppx/ppx_server.ml index fc0838f..3929f12 100644 --- a/src/ppx/ppx_server.ml +++ b/src/ppx/ppx_server.ml @@ -9,4 +9,5 @@ (**************************************************************************) let () = - Ppxlib.Driver.register_transformation "ez_api_server" ~impl:(Ppx_common.impl ~kind:`server) + Ppxlib.Driver.register_transformation "ez_api_server" ~impl:(Ppx_common.impl ~kind:`server); + Ppx_common.derivers () diff --git a/test/ppx/dune b/test/ppx/dune index f536fa1..33cef47 100644 --- a/test/ppx/dune +++ b/test/ppx/dune @@ -1,7 +1,7 @@ (library (name test_ppx_lib) (modules test_ppx_lib) - (preprocess (pps ez_api.ppx))) + (preprocess (pps ez_api.ppx ppx_deriving_encoding))) (executable (name test_ppx_server) diff --git a/test/ppx/test_ppx_lib.ml b/test/ppx/test_ppx_lib.ml index 85cdc62..5d79a45 100644 --- a/test/ppx/test_ppx_lib.ml +++ b/test/ppx/test_ppx_lib.ml @@ -1,3 +1,10 @@ +type nonrec test_derive_input = { + foo: string; + bar: int; +} +and test_derive_output = int +[@@post {path="/test/getter"; debug}] + let%post echo_input = { path="/echo_input"; raw_input=["text/plain"]; output=Json_encoding.(obj1 (req "test" string))