+1 -67

hermes-cli/bin/main.ml

reviewed

··· 5 5 {|(library 6 6 (name %s) 7 7 (libraries hermes yojson lwt) 8 8 - (preprocess (pps ppx_deriving_yojson)))|} 9 9 - 10 10 - let util_file = 11 11 - Printf.sprintf 12 12 - {|let query_string_list_of_yojson = function 13 13 - | `List l -> 14 14 - Ok (List.filter_map (function `String s -> Some s | _ -> None) l) 15 15 - | `String s -> 16 16 - Ok [s] 17 17 - | `Null -> 18 18 - Ok [] 19 19 - | _ -> 20 20 - Error "expected string or string list" 21 21 - 22 22 - let query_string_list_to_yojson l = `List (List.map (fun s -> `String s) l) 23 23 - 24 24 - let query_int_list_of_yojson = function 25 25 - | `List l -> 26 26 - Ok (List.filter_map (function `Int i -> Some i | _ -> None) l) 27 27 - | `Int i -> 28 28 - Ok [i] 29 29 - | `Null -> 30 30 - Ok [] 31 31 - | _ -> 32 32 - Error "expected int or int list" 33 33 - 34 34 - let query_int_list_to_yojson l = `List (List.map (fun i -> `Int i) l) 35 35 - 36 36 - let query_string_list_option_of_yojson = function 37 37 - | `List l -> 38 38 - Ok (Some (List.filter_map (function `String s -> Some s | _ -> None) l)) 39 39 - | `String s -> 40 40 - Ok (Some [s]) 41 41 - | `Null -> 42 42 - Ok None 43 43 - | _ -> 44 44 - Error "expected string or string list" 45 45 - 46 46 - let query_string_list_option_to_yojson = function 47 47 - | Some l -> 48 48 - `List (List.map (fun s -> `String s) l) 49 49 - | None -> 50 50 - `Null 51 51 - 52 52 - let query_int_list_option_of_yojson = function 53 53 - | `List l -> 54 54 - Ok (Some (List.filter_map (function `Int i -> Some i | _ -> None) l)) 55 55 - | `Int i -> 56 56 - Ok (Some [i]) 57 57 - | `Null -> 58 58 - Ok None 59 59 - | _ -> 60 60 - Error "expected int or int list" 61 61 - 62 62 - let query_int_list_option_to_yojson = function 63 63 - | Some l -> 64 64 - `List (List.map (fun i -> `Int i) l) 65 65 - | None -> 66 66 - `Null|} 8 8 + (preprocess (pps hermes_ppx ppx_deriving_yojson)))|} 67 9 68 10 (* recursively find all json files in a path (file or directory) *) 69 11 let find_json_files path = ··· 199 141 Out_channel.output_string oc (dune_file (String.lowercase_ascii module_name)) ; 200 142 close_out oc ; 201 143 Printf.printf "Generated dune file\n" ; 202 202 - (* generate util file *) 203 203 - let util_path = Filename.concat output_dir "hermes_util.ml" in 204 204 - let oc = open_out util_path in 205 205 - Printf.fprintf oc "(* %s - generated from atproto lexicons *)\n\n" module_name ; 206 206 - (* export each lexicon as a module alias *) 207 207 - Out_channel.output_string oc util_file ; 208 208 - close_out oc ; 209 209 - Printf.printf "Generated util file: %s\n" util_path ; 210 144 Printf.printf "Done! Generated %d modules\n" (List.length lexicons) 211 145 212 146 let inputs =

+46 -72

hermes-cli/lib/codegen.ml

reviewed

··· 72 72 let def_name = String.sub ref_str 1 (String.length ref_str - 1) in 73 73 Naming.type_name def_name 74 74 end 75 75 - else begin 75 75 + else 76 76 (* external ref: com.example.defs#someDef *) 77 77 - match String.split_on_char '#' ref_str with 77 77 + begin match String.split_on_char '#' ref_str with 78 78 | [ext_nsid; def_name] -> 79 79 if ext_nsid = nsid then 80 80 (* ref to same nsid, treat as local *) ··· 94 94 end 95 95 | _ -> 96 96 "invalid_ref" 97 97 - end 97 97 + end 98 98 99 99 and gen_union_type_name refs = Naming.union_type_name refs 100 100 ··· 298 298 299 299 let is_bytes_encoding encoding = 300 300 encoding <> "" && encoding <> "application/json" 301 301 - 302 302 - (* generate custom of_yojson/to_yojson attrs for query param array types *) 303 303 - let gen_query_array_yojson_attrs ~is_required (type_def : type_def) = 304 304 - match type_def with 305 305 - | Array {items; _} -> ( 306 306 - match items with 307 307 - | String _ -> 308 308 - if is_required then 309 309 - ( " [@of_yojson Hermes_util.query_string_list_of_yojson]" 310 310 - , " [@to_yojson Hermes_util.query_string_list_to_yojson]" ) 311 311 - else 312 312 - ( " [@of_yojson Hermes_util.query_string_list_option_of_yojson]" 313 313 - , " [@to_yojson Hermes_util.query_string_list_option_to_yojson]" ) 314 314 - | Integer _ -> 315 315 - if is_required then 316 316 - ( " [@of_yojson Hermes_util.query_int_list_of_yojson]" 317 317 - , " [@to_yojson Hermes_util.query_int_list_to_yojson]" ) 318 318 - else 319 319 - ( " [@of_yojson Hermes_util.query_int_list_option_of_yojson]" 320 320 - , " [@to_yojson Hermes_util.query_int_list_option_to_yojson]" ) 321 321 - | _ -> 322 322 - ("", "") ) 323 323 - | _ -> 324 324 - ("", "") 325 301 326 302 (* generate params type for query/procedure *) 327 303 let gen_params_type nsid out (spec : params_spec) = ··· 336 312 let type_str = if is_required then base_type else base_type ^ " option" in 337 313 let key_attr = Naming.key_annotation prop_name ocaml_name in 338 314 let default_attr = if is_required then "" else " [@default None]" in 339 339 - let of_yojson_attr, to_yojson_attr = 340 340 - gen_query_array_yojson_attrs ~is_required prop.type_def 341 341 - in 342 315 emitln out 343 343 - (Printf.sprintf " %s: %s%s%s%s%s;" ocaml_name type_str key_attr 344 344 - default_attr of_yojson_attr to_yojson_attr ) ) 316 316 + (Printf.sprintf " %s: %s%s%s;" ocaml_name type_str key_attr 317 317 + default_attr ) ) 345 318 spec.properties ; 346 319 emitln out " }" ; 347 347 - emitln out "[@@deriving yojson {strict= false}]" ; 320 320 + emitln out "[@@xrpc_query]" ; 348 321 emit_newline out 349 322 350 323 (* generate output type for query/procedure *) ··· 633 606 | _ -> 634 607 emitln out " let params = () in" ) ; 635 608 (* generate the call based on input/output types *) 636 636 - if input_is_bytes then begin 609 609 + if input_is_bytes then 637 610 (* bytes input - choose between procedure_blob and procedure_bytes *) 638 638 - if output_is_bytes then 611 611 + begin if output_is_bytes then 639 612 (* bytes-in, bytes-out: use procedure_bytes *) 640 613 emitln out 641 614 (Printf.sprintf ··· 659 632 (Bytes.of_string (Option.value input ~default:\"\")) \ 660 633 ~content_type:\"%s\" output_of_yojson" 661 634 input_content_type ) 662 662 - end 635 635 + end 663 636 else begin 664 637 (* json input - build input and use procedure *) 665 638 ( match spec.input with ··· 1135 1108 let def_name = String.sub ref_str 1 (String.length ref_str - 1) in 1136 1109 get_unique_type_name current_nsid def_name 1137 1110 end 1138 1138 - else begin 1139 1139 - match String.split_on_char '#' ref_str with 1111 1111 + else 1112 1112 + begin match String.split_on_char '#' ref_str with 1140 1113 | [ext_nsid; def_name] -> 1141 1114 if List.mem ext_nsid merged_nsids then 1142 1115 (* ref to another nsid in the merged group - use unique name *) ··· 1156 1129 end 1157 1130 | _ -> 1158 1131 "invalid_ref" 1159 1159 - end 1132 1132 + end 1160 1133 in 1161 1134 (* generate converter expression for reading a type from json *) 1162 1135 (* returns (converter_expr, needs_result_unwrap) - if needs_result_unwrap is true, caller should apply Result.get_ok *) ··· 1377 1350 (* local ref: #foo -> current_nsid#foo *) 1378 1351 let def_name = String.sub ref_ 1 (String.length ref_ - 1) in 1379 1352 (current_nsid ^ "#" ^ def_name) :: acc 1380 1380 - else begin 1381 1381 - match String.split_on_char '#' ref_ with 1353 1353 + else 1354 1354 + begin match String.split_on_char '#' ref_ with 1382 1355 | [ext_nsid; def_name] when List.mem ext_nsid merged_nsids -> 1383 1356 (* cross-nsid ref within merged group *) 1384 1357 (ext_nsid ^ "#" ^ def_name) :: acc 1385 1358 | _ -> 1386 1359 acc 1387 1387 - end 1360 1360 + end 1388 1361 | Union {refs; _} -> 1389 1362 List.fold_left 1390 1363 (fun a r -> ··· 1823 1796 let is_required = List.mem prop_name required in 1824 1797 let is_nullable = List.mem prop_name nullable in 1825 1798 let is_optional = (not is_required) || is_nullable in 1826 1826 - if is_optional then begin 1827 1827 - if needs_unwrap then 1799 1799 + if is_optional then 1800 1800 + begin if needs_unwrap then 1828 1801 emitln out 1829 1802 (Printf.sprintf 1830 1803 " let %s = json |> member \"%s\" |> to_option (fun x \ ··· 1836 1809 (Printf.sprintf 1837 1810 " let %s = json |> member \"%s\" |> to_option %s in" 1838 1811 ocaml_name prop_name conv_expr ) 1839 1839 - end 1840 1840 - else begin 1841 1841 - if needs_unwrap then 1812 1812 + end 1813 1813 + else 1814 1814 + begin if needs_unwrap then 1842 1815 emitln out 1843 1816 (Printf.sprintf 1844 1817 " let %s = json |> member \"%s\" |> %s |> \ ··· 1848 1821 emitln out 1849 1822 (Printf.sprintf " let %s = json |> member \"%s\" |> %s in" 1850 1823 ocaml_name prop_name conv_expr ) 1851 1851 - end ) 1824 1824 + end ) 1852 1825 spec.properties ; 1853 1826 emit out " Ok { " ; 1854 1827 emit out ··· 1950 1923 let regular_defs_in_scc = 1951 1924 List.filter_map (function `RegularDef x -> Some x | _ -> None) scc 1952 1925 in 1953 1953 - if inline_unions_in_scc = [] then begin 1926 1926 + if inline_unions_in_scc = [] then 1954 1927 (* no inline unions - use standard generation with [@@deriving yojson] *) 1955 1955 - if regular_defs_in_scc <> [] then gen_merged_scc regular_defs_in_scc 1956 1956 - end 1928 1928 + begin if regular_defs_in_scc <> [] then 1929 1929 + gen_merged_scc regular_defs_in_scc 1930 1930 + end 1957 1931 else begin 1958 1932 (* has inline unions - generate all types first, then all converters *) 1959 1933 (* register inline union names *) ··· 1969 1943 @ List.map (fun x -> `Regular x) regular_defs_in_scc 1970 1944 in 1971 1945 let n = List.length all_items in 1972 1972 - if n = 1 then begin 1946 1946 + if n = 1 then 1973 1947 (* single item - generate normally *) 1974 1974 - match List.hd all_items with 1948 1948 + begin match List.hd all_items with 1975 1949 | `Inline (nsid, name, refs, spec) -> 1976 1950 let unique_name = get_unique_inline_union_name nsid name in 1977 1951 gen_inline_union_type_only nsid unique_name refs spec ; ··· 1991 1965 gen_object_converters nsid def.name rspec.record 1992 1966 | _ -> 1993 1967 gen_merged_scc [(nsid, def)] ) 1994 1994 - end 1968 1968 + end 1995 1969 else begin 1996 1970 (* multiple items - generate as mutually recursive types *) 1997 1971 (* first pass: register inline unions from objects *) ··· 2312 2286 let def_name = String.sub ref_str 1 (String.length ref_str - 1) in 2313 2287 get_shared_type_name current_nsid def_name 2314 2288 end 2315 2315 - else begin 2316 2316 - match String.split_on_char '#' ref_str with 2289 2289 + else 2290 2290 + begin match String.split_on_char '#' ref_str with 2317 2291 | [ext_nsid; def_name] -> 2318 2292 if List.mem ext_nsid shared_nsids then 2319 2293 (* ref to another nsid in the shared group *) ··· 2333 2307 end 2334 2308 | _ -> 2335 2309 "invalid_ref" 2336 2336 - end 2310 2310 + end 2337 2311 in 2338 2312 (* generate type uri for shared context *) 2339 2313 let gen_shared_type_uri current_nsid ref_str = ··· 2559 2533 (* local ref: #foo -> current_nsid#foo *) 2560 2534 let def_name = String.sub ref_ 1 (String.length ref_ - 1) in 2561 2535 (current_nsid ^ "#" ^ def_name) :: acc 2562 2562 - else begin 2563 2563 - match String.split_on_char '#' ref_ with 2536 2536 + else 2537 2537 + begin match String.split_on_char '#' ref_ with 2564 2538 | [ext_nsid; def_name] when List.mem ext_nsid shared_nsids -> 2565 2539 (* cross-nsid ref within shared group *) 2566 2540 (ext_nsid ^ "#" ^ def_name) :: acc 2567 2541 | _ -> 2568 2542 acc 2569 2569 - end 2543 2543 + end 2570 2544 | Union {refs; _} -> 2571 2545 List.fold_left 2572 2546 (fun a r -> ··· 2748 2722 let is_required = List.mem prop_name required in 2749 2723 let is_nullable = List.mem prop_name nullable in 2750 2724 let is_optional = (not is_required) || is_nullable in 2751 2751 - if is_optional then begin 2752 2752 - if needs_unwrap then 2725 2725 + if is_optional then 2726 2726 + begin if needs_unwrap then 2753 2727 emitln out 2754 2728 (Printf.sprintf 2755 2729 " let %s = json |> member \"%s\" |> to_option (fun x \ ··· 2761 2735 (Printf.sprintf 2762 2736 " let %s = json |> member \"%s\" |> to_option %s in" 2763 2737 ocaml_name prop_name conv_expr ) 2764 2764 - end 2765 2765 - else begin 2766 2766 - if needs_unwrap then 2738 2738 + end 2739 2739 + else 2740 2740 + begin if needs_unwrap then 2767 2741 emitln out 2768 2742 (Printf.sprintf 2769 2743 " let %s = json |> member \"%s\" |> %s |> \ ··· 2773 2747 emitln out 2774 2748 (Printf.sprintf " let %s = json |> member \"%s\" |> %s in" 2775 2749 ocaml_name prop_name conv_expr ) 2776 2776 - end ) 2750 2750 + end ) 2777 2751 spec.properties ; 2778 2752 emit out " Ok { " ; 2779 2753 emit out ··· 3016 2990 let regular_defs_in_scc = 3017 2991 List.filter_map (function `RegularDef x -> Some x | _ -> None) scc 3018 2992 in 3019 3019 - if inline_unions_in_scc = [] then begin 2993 2993 + if inline_unions_in_scc = [] then 3020 2994 (* no inline unions - check if we still need mutual recursion *) 3021 3021 - match regular_defs_in_scc with 2995 2995 + begin match regular_defs_in_scc with 3022 2996 | [] -> 3023 2997 () 3024 2998 | [(nsid, def)] -> ··· 3104 3078 () ) 3105 3079 obj_defs 3106 3080 end 3107 3107 - end 3081 3081 + end 3108 3082 else begin 3109 3083 (* has inline unions - generate all types first, then all converters *) 3110 3084 List.iter ··· 3117 3091 @ List.map (fun x -> `Regular x) regular_defs_in_scc 3118 3092 in 3119 3093 let n = List.length all_items in 3120 3120 - if n = 1 then begin 3121 3121 - match List.hd all_items with 3094 3094 + if n = 1 then 3095 3095 + begin match List.hd all_items with 3122 3096 | `Inline (nsid, name, refs, spec) -> 3123 3097 gen_shared_inline_union_type_only nsid name refs spec ; 3124 3098 emit_newline out ; ··· 3137 3111 gen_shared_object_converters nsid def.name rspec.record 3138 3112 | _ -> 3139 3113 gen_shared_single_def (nsid, def) ) 3140 3140 - end 3114 3114 + end 3141 3115 else begin 3142 3116 (* multiple items - generate as mutually recursive types *) 3143 3117 List.iter

+6 -6

hermes-cli/lib/scc.ml

reviewed

··· 80 80 (* local ref: #foo *) 81 81 let def_name = String.sub ref_ 1 (String.length ref_ - 1) in 82 82 def_name :: acc 83 83 - else begin 83 83 + else 84 84 (* check if it's a self-reference: nsid#foo *) 85 85 - match String.split_on_char '#' ref_ with 85 85 + begin match String.split_on_char '#' ref_ with 86 86 | [ext_nsid; def_name] when ext_nsid = nsid -> 87 87 def_name :: acc 88 88 | _ -> 89 89 acc 90 90 - end 90 90 + end 91 91 | Union {refs; _} -> 92 92 List.fold_left 93 93 (fun a r -> ··· 168 168 | Array {items; _} -> 169 169 collect_from_type items 170 170 | Ref {ref_; _} -> 171 171 - if String.length ref_ > 0 && ref_.[0] <> '#' then begin 172 172 - match String.split_on_char '#' ref_ with 171 171 + if String.length ref_ > 0 && ref_.[0] <> '#' then 172 172 + begin match String.split_on_char '#' ref_ with 173 173 | ext_nsid :: _ -> 174 174 add_nsid ext_nsid 175 175 | [] -> 176 176 () 177 177 - end 177 177 + end 178 178 | Union {refs; _} -> 179 179 List.iter 180 180 (fun r ->

+36 -7

hermes/README.md

reviewed

··· 25 25 - [Union Types](#union-types) 26 26 - [hermes_ppx](#hermes-ppx) 27 27 - [Setup](#setup) 28 28 - - [Usage](#ppx-usage) 28 28 + - [`[%xrpc ...]`](#ppx-xrpc) 29 29 + - [`[@@xrpc_query]`](#ppx-xrpc-query) 29 30 30 31 ## quick start 31 32 ··· 242 243 module Main = struct 243 244 type params = { 244 245 actor: string; 245 245 - } [@@deriving yojson] 246 246 + limit: int option [@default None]; 247 247 + } [@@xrpc_query] 246 248 247 249 type output = { 248 250 did: string; ··· 253 255 254 256 let nsid = "app.bsky.actor.getProfile" 255 257 256 256 - let call ~actor (client : Hermes.client) : output Lwt.t = 257 257 - let params = { actor } in 258 258 + let call ~actor ?limit (client : Hermes.client) : output Lwt.t = 259 259 + let params = { actor; limit } in 258 260 Hermes.query client nsid (params_to_yojson params) output_of_yojson 259 261 end 262 262 + ``` 263 263 + 264 264 + The generated `dune` file pulls in the required preprocessors: 265 265 + 266 266 + ```lisp 267 267 + (library 268 268 + (name lexicons) 269 269 + (libraries hermes yojson lwt) 270 270 + (preprocess (pps hermes_ppx ppx_deriving_yojson))) 260 271 ``` 261 272 262 273 ### type mappings ··· 294 305 295 306 <h2 id="hermes-ppx">hermes_ppx (PPX extension)</h2> 296 307 297 297 - transforms `[%xrpc ...]` into generated module calls. 308 308 + provides two rewrites: `[%xrpc ...]` for ergonomic API calls, and `[@@xrpc_query]` for XRPC server implementations. 298 309 299 310 ### setup 300 311 ··· 302 313 (library 303 314 (name my_app) 304 315 (libraries hermes hermes_ppx lwt) 305 305 - (preprocess (pps hermes_ppx))) 316 316 + (preprocess (pps hermes_ppx ppx_deriving_yojson))) 306 317 ``` 307 318 308 308 - <h3 id="ppx-usage">usage</h3> 319 319 + If you use `[@@xrpc_query]`, you must include the `ppx_deriving_yojson` preprocessor after the `hermes_ppx` preprocessor. 320 320 + 321 321 + <h3 id="ppx-xrpc"><code>[%xrpc ...]</code></h3> 322 322 + 323 323 + transforms `[%xrpc ...]` into generated module calls. 309 324 310 325 ```ocaml 311 326 let get_followers ~actor ~limit client = ··· 326 341 ]) 327 342 client 328 343 ``` 344 344 + 345 345 + <h3 id="ppx-xrpc-query"><code>[@@xrpc_query]</code></h3> 346 346 + 347 347 + allows parsing query strings to yojson. 348 348 + 349 349 + ```ocaml 350 350 + type params = { 351 351 + actor: string; 352 352 + limit: int option [@default None]; 353 353 + collections: string list option [@default None]; 354 354 + } [@@xrpc_query] 355 355 + ``` 356 356 + 357 357 + Under the hood, the PPX assigns custom to_yojson/of_yojson functions to the record's fields, allowing for correctly parsing from an `Assoc` containing string or string list entries to the types specified in the record.

+1

hermes/lib/hermes.ml

reviewed

··· 62 62 module Jwt = Jwt 63 63 module Http_backend = Http_backend 64 64 module Client = Client 65 65 + module Query = Query 65 66 module Credential_manager = Credential_manager

+30

hermes/lib/hermes.mli

reviewed

··· 181 181 module Make (_ : Http_backend.S) : S 182 182 end 183 183 184 184 + module Query : sig 185 185 + val query_int_of_yojson : Yojson.Safe.t -> (int, string) result 186 186 + 187 187 + val query_int_option_of_yojson : Yojson.Safe.t -> (int option, string) result 188 188 + 189 189 + val query_bool_of_yojson : Yojson.Safe.t -> (bool, string) result 190 190 + 191 191 + val query_bool_option_of_yojson : 192 192 + Yojson.Safe.t -> (bool option, string) result 193 193 + 194 194 + val query_string_list_of_yojson : 195 195 + Yojson.Safe.t -> (string list, string) result 196 196 + 197 197 + val query_string_list_to_yojson : string list -> Yojson.Safe.t 198 198 + 199 199 + val query_int_list_of_yojson : Yojson.Safe.t -> (int list, string) result 200 200 + 201 201 + val query_int_list_to_yojson : int list -> Yojson.Safe.t 202 202 + 203 203 + val query_string_list_option_of_yojson : 204 204 + Yojson.Safe.t -> (string list option, string) result 205 205 + 206 206 + val query_string_list_option_to_yojson : string list option -> Yojson.Safe.t 207 207 + 208 208 + val query_int_list_option_of_yojson : 209 209 + Yojson.Safe.t -> (int list option, string) result 210 210 + 211 211 + val query_int_list_option_to_yojson : int list option -> Yojson.Safe.t 212 212 + end 213 213 + 184 214 module Credential_manager : sig 185 215 type t = credential_manager 186 216

+83

hermes/lib/query.ml

reviewed

··· 1 1 + let query_int_of_yojson = function 2 2 + | `Int n -> 3 3 + Ok n 4 4 + | `Intlit s | `String s -> ( 5 5 + match int_of_string_opt s with 6 6 + | Some n -> 7 7 + Ok n 8 8 + | None -> 9 9 + Error "expected integer" ) 10 10 + | _ -> 11 11 + Error "expected integer" 12 12 + 13 13 + let query_int_option_of_yojson = function 14 14 + | `Null -> 15 15 + Ok None 16 16 + | j -> 17 17 + Result.map Option.some (query_int_of_yojson j) 18 18 + 19 19 + let query_bool_of_yojson = function 20 20 + | `Bool b -> 21 21 + Ok b 22 22 + | `String "true" -> 23 23 + Ok true 24 24 + | `String "false" -> 25 25 + Ok false 26 26 + | _ -> 27 27 + Error "expected boolean" 28 28 + 29 29 + let query_bool_option_of_yojson = function 30 30 + | `Null -> 31 31 + Ok None 32 32 + | j -> 33 33 + Result.map Option.some (query_bool_of_yojson j) 34 34 + 35 35 + let query_string_list_of_yojson = function 36 36 + | `List l -> 37 37 + Ok (List.filter_map (function `String s -> Some s | _ -> None) l) 38 38 + | `String s -> 39 39 + Ok [s] 40 40 + | `Null -> 41 41 + Ok [] 42 42 + | _ -> 43 43 + Error "expected string or string list" 44 44 + 45 45 + let query_string_list_to_yojson l = `List (List.map (fun s -> `String s) l) 46 46 + 47 47 + let query_int_list_of_yojson = function 48 48 + | `List l -> 49 49 + Ok (List.filter_map (fun j -> Result.to_option (query_int_of_yojson j)) l) 50 50 + | `Null -> 51 51 + Ok [] 52 52 + | j -> 53 53 + Result.map (fun i -> [i]) (query_int_of_yojson j) 54 54 + 55 55 + let query_int_list_to_yojson l = `List (List.map (fun i -> `Int i) l) 56 56 + 57 57 + let query_string_list_option_of_yojson = function 58 58 + | `List l -> 59 59 + Ok (Some (List.filter_map (function `String s -> Some s | _ -> None) l)) 60 60 + | `String s -> 61 61 + Ok (Some [s]) 62 62 + | `Null -> 63 63 + Ok None 64 64 + | _ -> 65 65 + Error "expected string or string list" 66 66 + 67 67 + let query_string_list_option_to_yojson = function 68 68 + | Some l -> 69 69 + `List (List.map (fun s -> `String s) l) 70 70 + | None -> 71 71 + `Null 72 72 + 73 73 + let query_int_list_option_of_yojson = function 74 74 + | `Null -> 75 75 + Ok None 76 76 + | j -> 77 77 + Result.map Option.some (query_int_list_of_yojson j) 78 78 + 79 79 + let query_int_list_option_to_yojson = function 80 80 + | Some l -> 81 81 + `List (List.map (fun i -> `Int i) l) 82 82 + | None -> 83 83 + `Null

+136 -1

hermes_ppx/lib/hermes_ppx.ml

reviewed

··· 57 57 58 58 let rule = Context_free.Rule.extension xrpc_extension 59 59 60 60 - let () = Driver.register_transformation "hermes_ppx" ~rules:[rule] 60 60 + (* rewrite record types annotated with [@@deriving xrpc_query] by injecting 61 61 + Hermes_util [@of_yojson]/[@to_yojson] attrs on fields that need query string 62 62 + coercion, then swaps the deriving to [@@deriving yojson {strict = false}]. *) 63 63 + 64 64 + let hermes_query name ~loc = 65 65 + Ast_builder.Default.pexp_ident ~loc 66 66 + (Loc.make ~loc (Longident.Ldot (Ldot (Lident "Hermes", "Query"), name))) 67 67 + 68 68 + let make_attr ~loc name expr = 69 69 + { attr_name= Loc.make ~loc name 70 70 + ; attr_payload= PStr [Ast_builder.Default.pstr_eval ~loc expr []] 71 71 + ; attr_loc= loc } 72 72 + 73 73 + (* classify a core_type and return attrs to inject *) 74 74 + let query_attrs_for_type (ct : core_type) = 75 75 + let loc = ct.ptyp_loc in 76 76 + let of_ n = make_attr ~loc "of_yojson" (hermes_query n ~loc) in 77 77 + let to_ n = make_attr ~loc "to_yojson" (hermes_query n ~loc) in 78 78 + match ct.ptyp_desc with 79 79 + (* int *) 80 80 + | Ptyp_constr ({txt= Lident "int"; _}, []) -> 81 81 + [of_ "query_int_of_yojson"] 82 82 + (* bool *) 83 83 + | Ptyp_constr ({txt= Lident "bool"; _}, []) -> 84 84 + [of_ "query_bool_of_yojson"] 85 85 + (* T option -> inspect T *) 86 86 + | Ptyp_constr ({txt= Lident "option"; _}, [inner]) -> ( 87 87 + match inner.ptyp_desc with 88 88 + | Ptyp_constr ({txt= Lident "int"; _}, []) -> 89 89 + [of_ "query_int_option_of_yojson"] 90 90 + | Ptyp_constr ({txt= Lident "bool"; _}, []) -> 91 91 + [of_ "query_bool_option_of_yojson"] 92 92 + (* T list option -> inspect T *) 93 93 + | Ptyp_constr ({txt= Lident "list"; _}, [list_inner]) -> ( 94 94 + match list_inner.ptyp_desc with 95 95 + | Ptyp_constr ({txt= Lident "string"; _}, []) -> 96 96 + [ of_ "query_string_list_option_of_yojson" 97 97 + ; to_ "query_string_list_option_to_yojson" ] 98 98 + | Ptyp_constr ({txt= Lident "int"; _}, []) -> 99 99 + [ of_ "query_int_list_option_of_yojson" 100 100 + ; to_ "query_int_list_option_to_yojson" ] 101 101 + | _ -> 102 102 + [] ) 103 103 + | _ -> 104 104 + [] ) 105 105 + (* T list -> inspect T *) 106 106 + | Ptyp_constr ({txt= Lident "list"; _}, [inner]) -> ( 107 107 + match inner.ptyp_desc with 108 108 + | Ptyp_constr ({txt= Lident "string"; _}, []) -> 109 109 + [of_ "query_string_list_of_yojson"; to_ "query_string_list_to_yojson"] 110 110 + | Ptyp_constr ({txt= Lident "int"; _}, []) -> 111 111 + [of_ "query_int_list_of_yojson"; to_ "query_int_list_to_yojson"] 112 112 + | _ -> 113 113 + [] ) 114 114 + | _ -> 115 115 + [] 116 116 + 117 117 + let transform_label_decl (ld : label_declaration) : label_declaration = 118 118 + let extra_attrs = query_attrs_for_type ld.pld_type in 119 119 + {ld with pld_attributes= ld.pld_attributes @ extra_attrs} 120 120 + 121 121 + (* build the [@@deriving yojson {strict = false}] attribute *) 122 122 + let yojson_deriving_attr ~loc = 123 123 + let strict_false = 124 124 + ( Loc.make ~loc (Lident "strict") 125 125 + , Ast_builder.Default.pexp_construct ~loc 126 126 + (Loc.make ~loc (Lident "false")) 127 127 + None ) 128 128 + in 129 129 + let yojson_expr = 130 130 + Ast_builder.Default.pexp_apply ~loc 131 131 + (Ast_builder.Default.pexp_ident ~loc (Loc.make ~loc (Lident "yojson"))) 132 132 + [(Nolabel, Ast_builder.Default.pexp_record ~loc [strict_false] None)] 133 133 + in 134 134 + { attr_name= Loc.make ~loc "deriving" 135 135 + ; attr_payload= PStr [Ast_builder.Default.pstr_eval ~loc yojson_expr []] 136 136 + ; attr_loc= loc } 137 137 + 138 138 + let is_xrpc_query (attr : attribute) = attr.attr_name.txt = "xrpc_query" 139 139 + 140 140 + let transform_type_decl (td : type_declaration) = 141 141 + let has_xrpc_query = List.exists is_xrpc_query td.ptype_attributes in 142 142 + if not has_xrpc_query then td 143 143 + else 144 144 + let kind = 145 145 + match td.ptype_kind with 146 146 + | Ptype_record fields -> 147 147 + Ptype_record (List.map transform_label_decl fields) 148 148 + | other -> 149 149 + other 150 150 + in 151 151 + let attrs = 152 152 + List.map 153 153 + (fun attr -> 154 154 + if is_xrpc_query attr then yojson_deriving_attr ~loc:attr.attr_loc 155 155 + else attr ) 156 156 + td.ptype_attributes 157 157 + in 158 158 + {td with ptype_kind= kind; ptype_attributes= attrs} 159 159 + 160 160 + let rec transform_structure str = 161 161 + List.map 162 162 + (fun (si : structure_item) -> 163 163 + match si.pstr_desc with 164 164 + | Pstr_type (rf, tds) -> 165 165 + {si with pstr_desc= Pstr_type (rf, List.map transform_type_decl tds)} 166 166 + | Pstr_module mb -> 167 167 + { si with 168 168 + pstr_desc= 169 169 + Pstr_module {mb with pmb_expr= transform_module_expr mb.pmb_expr} 170 170 + } 171 171 + | Pstr_recmodule mbs -> 172 172 + { si with 173 173 + pstr_desc= 174 174 + Pstr_recmodule 175 175 + (List.map 176 176 + (fun mb -> 177 177 + {mb with pmb_expr= transform_module_expr mb.pmb_expr} ) 178 178 + mbs ) } 179 179 + | _ -> 180 180 + si ) 181 181 + str 182 182 + 183 183 + and transform_module_expr (me : module_expr) = 184 184 + match me.pmod_desc with 185 185 + | Pmod_structure str -> 186 186 + {me with pmod_desc= Pmod_structure (transform_structure str)} 187 187 + | _ -> 188 188 + me 189 189 + 190 190 + let () = 191 191 + Driver.register_transformation "hermes_ppx" ~rules:[rule] 192 192 + ~instrument: 193 193 + (Driver.Instrument.V2.make 194 194 + (fun _ctx str -> transform_structure str) 195 195 + ~position:Before )