objective categorical abstract machine language personal data server
1open Lexicon_types
2
3(* use Emitter module for output buffer management *)
4type output = Emitter.t
5
6let make_output = Emitter.make
7
8let add_import = Emitter.add_import
9
10let mark_union_generated = Emitter.mark_union_generated
11
12let is_union_generated = Emitter.is_union_generated
13
14let register_union_name = Emitter.register_union_name
15
16let lookup_union_name = Emitter.lookup_union_name
17
18let emit = Emitter.emit
19
20let emitln = Emitter.emitln
21
22let emit_newline = Emitter.emit_newline
23
24(* generate ocaml type for a primitive type *)
25let rec gen_type_ref nsid out (type_def : type_def) : string =
26 match type_def with
27 | String _ ->
28 "string"
29 | Integer {maximum; _} -> (
30 (* use int64 for large integers *)
31 match maximum with
32 | Some m when m > 1073741823 ->
33 "int64"
34 | _ ->
35 "int" )
36 | Boolean _ ->
37 "bool"
38 | Bytes _ ->
39 "bytes"
40 | Blob _ ->
41 "Hermes.blob"
42 | CidLink _ ->
43 "Cid.t"
44 | Array {items; _} ->
45 let item_type = gen_type_ref nsid out items in
46 item_type ^ " list"
47 | Object _ ->
48 (* objects should be defined separately *)
49 "object_todo"
50 | Ref {ref_; _} ->
51 gen_ref_type nsid out ref_
52 | Union {refs; _} -> (
53 (* generate inline union reference, using registered name if available *)
54 match lookup_union_name out refs with
55 | Some name ->
56 name
57 | None ->
58 gen_union_type_name refs )
59 | Token _ ->
60 "string"
61 | Unknown _ ->
62 "Yojson.Safe.t"
63 | Query _ | Procedure _ | Subscription _ | Record _ ->
64 "unit (* primary type *)"
65 | PermissionSet _ ->
66 "unit (* permission-set type *)"
67
68(* generate reference to another type *)
69and gen_ref_type nsid out ref_str : string =
70 if String.length ref_str > 0 && ref_str.[0] = '#' then begin
71 (* local ref: #someDef -> someDef *)
72 let def_name = String.sub ref_str 1 (String.length ref_str - 1) in
73 Naming.type_name def_name
74 end
75 else
76 (* external ref: com.example.defs#someDef *)
77 begin match String.split_on_char '#' ref_str with
78 | [ext_nsid; def_name] ->
79 if ext_nsid = nsid then
80 (* ref to same nsid, treat as local *)
81 Naming.type_name def_name
82 else begin
83 (* use flat module names for include_subdirs unqualified *)
84 let flat_module = Naming.flat_module_name_of_nsid ext_nsid in
85 add_import out flat_module ;
86 flat_module ^ "." ^ Naming.type_name def_name
87 end
88 | [ext_nsid] ->
89 if ext_nsid = nsid then Naming.type_name "main"
90 else begin
91 (* just nsid, refers to main def *)
92 let flat_module = Naming.flat_module_name_of_nsid ext_nsid in
93 add_import out flat_module ; flat_module ^ ".main"
94 end
95 | _ ->
96 "invalid_ref"
97 end
98
99and gen_union_type_name refs = Naming.union_type_name refs
100
101(* generate full type uri for a ref *)
102let gen_type_uri nsid ref_str =
103 if String.length ref_str > 0 && ref_str.[0] = '#' then
104 (* local ref *)
105 nsid ^ ref_str
106 else
107 (* external ref, use as-is *)
108 ref_str
109
110(* collect inline union specs from object properties with context *)
111let rec collect_inline_unions_with_context context acc type_def =
112 match type_def with
113 | Union spec ->
114 (context, spec.refs, spec) :: acc
115 | Array {items; _} ->
116 (* for array items, append _item to context *)
117 collect_inline_unions_with_context (context ^ "_item") acc items
118 | _ ->
119 acc
120
121let collect_inline_unions_from_properties properties =
122 List.fold_left
123 (fun acc (prop_name, (prop : property)) ->
124 collect_inline_unions_with_context prop_name acc prop.type_def )
125 [] properties
126
127(* generate inline union types that appear in object properties *)
128let gen_inline_unions nsid out properties =
129 let inline_unions = collect_inline_unions_from_properties properties in
130 List.iter
131 (fun (context, refs, spec) ->
132 (* register and use context-based name *)
133 let context_name = Naming.type_name context in
134 register_union_name out refs context_name ;
135 let type_name = context_name in
136 (* skip if already generated *)
137 if not (is_union_generated out type_name) then begin
138 mark_union_generated out type_name ;
139 let is_closed = Option.value spec.closed ~default:false in
140 emitln out (Printf.sprintf "type %s =" type_name) ;
141 List.iter
142 (fun ref_str ->
143 let variant_name = Naming.variant_name_of_ref ref_str in
144 let payload_type = gen_ref_type nsid out ref_str in
145 emitln out (Printf.sprintf " | %s of %s" variant_name payload_type) )
146 refs ;
147 if not is_closed then emitln out " | Unknown of Yojson.Safe.t" ;
148 emit_newline out ;
149 (* generate of_yojson function *)
150 emitln out (Printf.sprintf "let %s_of_yojson json =" type_name) ;
151 emitln out " let open Yojson.Safe.Util in" ;
152 emitln out " try" ;
153 emitln out " match json |> member \"$type\" |> to_string with" ;
154 List.iter
155 (fun ref_str ->
156 let variant_name = Naming.variant_name_of_ref ref_str in
157 let full_type_uri = gen_type_uri nsid ref_str in
158 let payload_type = gen_ref_type nsid out ref_str in
159 emitln out (Printf.sprintf " | \"%s\" ->" full_type_uri) ;
160 emitln out
161 (Printf.sprintf " (match %s_of_yojson json with"
162 payload_type ) ;
163 emitln out
164 (Printf.sprintf " | Ok v -> Ok (%s v)" variant_name) ;
165 emitln out " | Error e -> Error e)" )
166 refs ;
167 if is_closed then
168 emitln out " | t -> Error (\"unknown union type: \" ^ t)"
169 else emitln out " | _ -> Ok (Unknown json)" ;
170 emitln out " with _ -> Error \"failed to parse union\"" ;
171 emit_newline out ;
172 (* generate to_yojson function *)
173 emitln out (Printf.sprintf "let %s_to_yojson = function" type_name) ;
174 List.iter
175 (fun ref_str ->
176 let variant_name = Naming.variant_name_of_ref ref_str in
177 let full_type_uri = gen_type_uri nsid ref_str in
178 let payload_type = gen_ref_type nsid out ref_str in
179 emitln out (Printf.sprintf " | %s v ->" variant_name) ;
180 emitln out
181 (Printf.sprintf " (match %s_to_yojson v with" payload_type) ;
182 emitln out
183 (Printf.sprintf
184 " | `Assoc fields -> `Assoc ((\"$type\", `String \
185 \"%s\") :: fields)"
186 full_type_uri ) ;
187 emitln out " | other -> other)" )
188 refs ;
189 if not is_closed then emitln out " | Unknown j -> j" ;
190 emit_newline out
191 end )
192 inline_unions
193
194(* generate object type definition *)
195(* ~first: use "type" if true, "and" if false *)
196(* ~last: add [@@deriving yojson] if true *)
197let gen_object_type ?(first = true) ?(last = true) nsid out name
198 (spec : object_spec) =
199 let required = Option.value spec.required ~default:[] in
200 let nullable = Option.value spec.nullable ~default:[] in
201 let keyword = if first then "type" else "and" in
202 (* handle empty objects as unit *)
203 if spec.properties = [] then begin
204 emitln out (Printf.sprintf "%s %s = unit" keyword (Naming.type_name name)) ;
205 if last then begin
206 emitln out
207 (Printf.sprintf "let %s_of_yojson _ = Ok ()" (Naming.type_name name)) ;
208 emitln out
209 (Printf.sprintf "let %s_to_yojson () = `Assoc []"
210 (Naming.type_name name) ) ;
211 emit_newline out
212 end
213 end
214 else begin
215 (* generate inline union types first, but only if this is the first type *)
216 if first then gen_inline_unions nsid out spec.properties ;
217 emitln out (Printf.sprintf "%s %s =" keyword (Naming.type_name name)) ;
218 emitln out " {" ;
219 List.iter
220 (fun (prop_name, (prop : property)) ->
221 let ocaml_name = Naming.field_name prop_name in
222 let base_type = gen_type_ref nsid out prop.type_def in
223 let is_required = List.mem prop_name required in
224 let is_nullable = List.mem prop_name nullable in
225 let type_str =
226 if is_required && not is_nullable then base_type
227 else base_type ^ " option"
228 in
229 let key_attr = Naming.key_annotation prop_name ocaml_name in
230 let default_attr =
231 if is_required && not is_nullable then "" else " [@default None]"
232 in
233 emitln out
234 (Printf.sprintf " %s: %s%s%s;" ocaml_name type_str key_attr
235 default_attr ) )
236 spec.properties ;
237 emitln out " }" ;
238 if last then begin
239 emitln out "[@@deriving yojson {strict= false}]" ;
240 emit_newline out
241 end
242 end
243
244(* generate union type definition *)
245let gen_union_type nsid out name (spec : union_spec) =
246 let type_name = Naming.type_name name in
247 let is_closed = Option.value spec.closed ~default:false in
248 emitln out (Printf.sprintf "type %s =" type_name) ;
249 List.iter
250 (fun ref_str ->
251 let variant_name = Naming.variant_name_of_ref ref_str in
252 let payload_type = gen_ref_type nsid out ref_str in
253 emitln out (Printf.sprintf " | %s of %s" variant_name payload_type) )
254 spec.refs ;
255 if not is_closed then emitln out " | Unknown of Yojson.Safe.t" ;
256 emit_newline out ;
257 (* generate of_yojson function *)
258 emitln out (Printf.sprintf "let %s_of_yojson json =" type_name) ;
259 emitln out " let open Yojson.Safe.Util in" ;
260 emitln out " try" ;
261 emitln out " match json |> member \"$type\" |> to_string with" ;
262 List.iter
263 (fun ref_str ->
264 let variant_name = Naming.variant_name_of_ref ref_str in
265 let full_type_uri = gen_type_uri nsid ref_str in
266 let payload_type = gen_ref_type nsid out ref_str in
267 emitln out (Printf.sprintf " | \"%s\" ->" full_type_uri) ;
268 emitln out
269 (Printf.sprintf " (match %s_of_yojson json with" payload_type) ;
270 emitln out (Printf.sprintf " | Ok v -> Ok (%s v)" variant_name) ;
271 emitln out " | Error e -> Error e)" )
272 spec.refs ;
273 if is_closed then emitln out " | t -> Error (\"unknown union type: \" ^ t)"
274 else emitln out " | _ -> Ok (Unknown json)" ;
275 emitln out " with _ -> Error \"failed to parse union\"" ;
276 emit_newline out ;
277 (* generate to_yojson function - inject $type field *)
278 emitln out (Printf.sprintf "let %s_to_yojson = function" type_name) ;
279 List.iter
280 (fun ref_str ->
281 let variant_name = Naming.variant_name_of_ref ref_str in
282 let full_type_uri = gen_type_uri nsid ref_str in
283 let payload_type = gen_ref_type nsid out ref_str in
284 emitln out (Printf.sprintf " | %s v ->" variant_name) ;
285 emitln out
286 (Printf.sprintf " (match %s_to_yojson v with" payload_type) ;
287 emitln out
288 (Printf.sprintf
289 " | `Assoc fields -> `Assoc ((\"$type\", `String \"%s\") :: \
290 fields)"
291 full_type_uri ) ;
292 emitln out " | other -> other)" )
293 spec.refs ;
294 if not is_closed then emitln out " | Unknown j -> j" ;
295 emit_newline out
296
297let is_json_encoding encoding = encoding = "application/json" || encoding = ""
298
299let is_bytes_encoding encoding =
300 encoding <> "" && encoding <> "application/json"
301
302(* generate params type for query/procedure *)
303let gen_params_type nsid out (spec : params_spec) =
304 let required = Option.value spec.required ~default:[] in
305 emitln out "type params =" ;
306 emitln out " {" ;
307 List.iter
308 (fun (prop_name, (prop : property)) ->
309 let ocaml_name = Naming.field_name prop_name in
310 let base_type = gen_type_ref nsid out prop.type_def in
311 let is_required = List.mem prop_name required in
312 let type_str = if is_required then base_type else base_type ^ " option" in
313 let key_attr = Naming.key_annotation prop_name ocaml_name in
314 let default_attr = if is_required then "" else " [@default None]" in
315 emitln out
316 (Printf.sprintf " %s: %s%s%s;" ocaml_name type_str key_attr
317 default_attr ) )
318 spec.properties ;
319 emitln out " }" ;
320 emitln out "[@@xrpc_query]" ;
321 emit_newline out
322
323(* generate output type for query/procedure *)
324let gen_output_type nsid out (body : body_def) =
325 match body.schema with
326 | Some (Object spec) ->
327 (* handle empty objects as unit *)
328 if spec.properties = [] then begin
329 emitln out "type output = unit" ;
330 emitln out "let output_of_yojson _ = Ok ()" ;
331 emitln out "let output_to_yojson () = `Assoc []" ;
332 emit_newline out
333 end
334 else begin
335 (* generate inline union types first *)
336 gen_inline_unions nsid out spec.properties ;
337 let required = Option.value spec.required ~default:[] in
338 let nullable = Option.value spec.nullable ~default:[] in
339 emitln out "type output =" ;
340 emitln out " {" ;
341 List.iter
342 (fun (prop_name, (prop : property)) ->
343 let ocaml_name = Naming.field_name prop_name in
344 let base_type = gen_type_ref nsid out prop.type_def in
345 let is_required = List.mem prop_name required in
346 let is_nullable = List.mem prop_name nullable in
347 let type_str =
348 if is_required && not is_nullable then base_type
349 else base_type ^ " option"
350 in
351 let key_attr = Naming.key_annotation prop_name ocaml_name in
352 let default_attr =
353 if is_required && not is_nullable then "" else " [@default None]"
354 in
355 emitln out
356 (Printf.sprintf " %s: %s%s%s;" ocaml_name type_str key_attr
357 default_attr ) )
358 spec.properties ;
359 emitln out " }" ;
360 emitln out "[@@deriving yojson {strict= false}]" ;
361 emit_newline out
362 end
363 | Some other_type ->
364 let type_str = gen_type_ref nsid out other_type in
365 emitln out (Printf.sprintf "type output = %s" type_str) ;
366 emitln out "[@@deriving yojson {strict= false}]" ;
367 emit_newline out
368 | None ->
369 emitln out "type output = unit" ;
370 emitln out "let output_of_yojson _ = Ok ()" ;
371 emitln out "let output_to_yojson () = `Null" ;
372 emit_newline out
373
374(* generate query module *)
375let gen_query nsid out name (spec : query_spec) =
376 (* check if output is bytes *)
377 let output_is_bytes =
378 match spec.output with
379 | Some body ->
380 is_bytes_encoding body.encoding
381 | None ->
382 false
383 in
384 emitln out
385 (Printf.sprintf "(** %s *)" (Option.value spec.description ~default:name)) ;
386 emitln out (Printf.sprintf "module %s = struct" (Naming.def_module_name name)) ;
387 emitln out (Printf.sprintf " let nsid = \"%s\"" nsid) ;
388 emit_newline out ;
389 (* generate params type *)
390 ( match spec.parameters with
391 | Some params when params.properties <> [] ->
392 emit out " " ;
393 gen_params_type nsid out params
394 | _ ->
395 emitln out " type params = unit" ;
396 emitln out " let params_to_yojson () = `Assoc []" ;
397 emit_newline out ) ;
398 (* generate output type *)
399 ( if output_is_bytes then begin
400 emitln out " (** raw bytes output with content type *)" ;
401 emitln out " type output = bytes * string" ;
402 emit_newline out
403 end
404 else
405 match spec.output with
406 | Some body ->
407 emit out " " ;
408 gen_output_type nsid out body
409 | None ->
410 emitln out " type output = unit" ;
411 emitln out " let output_of_yojson _ = Ok ()" ;
412 emit_newline out ) ;
413 (* generate call function *)
414 emitln out " let call" ;
415 ( match spec.parameters with
416 | Some params when params.properties <> [] ->
417 let required = Option.value params.required ~default:[] in
418 List.iter
419 (fun (prop_name, _) ->
420 let ocaml_name = Naming.field_name prop_name in
421 let is_required = List.mem prop_name required in
422 if is_required then emitln out (Printf.sprintf " ~%s" ocaml_name)
423 else emitln out (Printf.sprintf " ?%s" ocaml_name) )
424 params.properties
425 | _ ->
426 () ) ;
427 emitln out " (client : Hermes.client) : output Lwt.t =" ;
428 ( match spec.parameters with
429 | Some params when params.properties <> [] ->
430 emit out " let params : params = {" ;
431 let fields =
432 List.map
433 (fun (prop_name, _) -> Naming.field_name prop_name)
434 params.properties
435 in
436 emit out (String.concat "; " fields) ;
437 emitln out "} in" ;
438 if output_is_bytes then
439 emitln out
440 " Hermes.query_bytes client nsid (params_to_yojson params)"
441 else
442 emitln out
443 " Hermes.query client nsid (params_to_yojson params) \
444 output_of_yojson"
445 | _ ->
446 if output_is_bytes then
447 emitln out " Hermes.query_bytes client nsid (`Assoc [])"
448 else
449 emitln out " Hermes.query client nsid (`Assoc []) output_of_yojson"
450 ) ;
451 emitln out "end" ; emit_newline out
452
453(* generate procedure module *)
454let gen_procedure nsid out name (spec : procedure_spec) =
455 (* check if input/output are bytes *)
456 let input_is_bytes =
457 match spec.input with
458 | Some body ->
459 is_bytes_encoding body.encoding
460 | None ->
461 false
462 in
463 let output_is_bytes =
464 match spec.output with
465 | Some body ->
466 is_bytes_encoding body.encoding
467 | None ->
468 false
469 in
470 let input_content_type =
471 match spec.input with
472 | Some body when is_bytes_encoding body.encoding ->
473 body.encoding
474 | _ ->
475 "application/json"
476 in
477 emitln out
478 (Printf.sprintf "(** %s *)" (Option.value spec.description ~default:name)) ;
479 emitln out (Printf.sprintf "module %s = struct" (Naming.def_module_name name)) ;
480 emitln out (Printf.sprintf " let nsid = \"%s\"" nsid) ;
481 emit_newline out ;
482 (* generate params type *)
483 ( match spec.parameters with
484 | Some params when params.properties <> [] ->
485 emit out " " ;
486 gen_params_type nsid out params
487 | _ ->
488 emitln out " type params = unit" ;
489 emitln out " let params_to_yojson () = `Assoc []" ;
490 emit_newline out ) ;
491 (* generate input type; only for json input with schema *)
492 ( if not input_is_bytes then
493 match spec.input with
494 | Some body when body.schema <> None ->
495 emit out " " ;
496 ( match body.schema with
497 | Some (Object spec) ->
498 if spec.properties = [] then begin
499 (* empty object input *)
500 emitln out "type input = unit" ;
501 emitln out " let input_of_yojson _ = Ok ()" ;
502 emitln out " let input_to_yojson () = `Assoc []"
503 end
504 else begin
505 (* generate inline union types first *)
506 gen_inline_unions nsid out spec.properties ;
507 let required = Option.value spec.required ~default:[] in
508 emitln out "type input =" ;
509 emitln out " {" ;
510 List.iter
511 (fun (prop_name, (prop : property)) ->
512 let ocaml_name = Naming.field_name prop_name in
513 let base_type = gen_type_ref nsid out prop.type_def in
514 let is_required = List.mem prop_name required in
515 let type_str =
516 if is_required then base_type else base_type ^ " option"
517 in
518 let key_attr = Naming.key_annotation prop_name ocaml_name in
519 let default_attr =
520 if is_required then "" else " [@default None]"
521 in
522 emitln out
523 (Printf.sprintf " %s: %s%s%s;" ocaml_name type_str
524 key_attr default_attr ) )
525 spec.properties ;
526 emitln out " }" ;
527 emitln out " [@@deriving yojson {strict= false}]"
528 end
529 | Some other_type ->
530 emitln out
531 (Printf.sprintf "type input = %s"
532 (gen_type_ref nsid out other_type) ) ;
533 emitln out " [@@deriving yojson {strict= false}]"
534 | None ->
535 () ) ;
536 emit_newline out
537 | _ ->
538 () ) ;
539 (* generate output type *)
540 ( if output_is_bytes then begin
541 emitln out " (** raw bytes output with content type *)" ;
542 emitln out " type output = (bytes * string) option" ;
543 emit_newline out
544 end
545 else
546 match spec.output with
547 | Some body ->
548 emit out " " ;
549 gen_output_type nsid out body
550 | None ->
551 emitln out " type output = unit" ;
552 emitln out " let output_of_yojson _ = Ok ()" ;
553 emit_newline out ) ;
554 (* generate call function *)
555 emitln out " let call" ;
556 (* add labeled arguments for parameters *)
557 ( match spec.parameters with
558 | Some params when params.properties <> [] ->
559 let required = Option.value params.required ~default:[] in
560 List.iter
561 (fun (prop_name, _) ->
562 let ocaml_name = Naming.field_name prop_name in
563 let is_required = List.mem prop_name required in
564 if is_required then emitln out (Printf.sprintf " ~%s" ocaml_name)
565 else emitln out (Printf.sprintf " ?%s" ocaml_name) )
566 params.properties
567 | _ ->
568 () ) ;
569 (* add labeled arguments for input *)
570 ( if input_is_bytes then
571 (* for bytes input, take raw string *)
572 emitln out " ?input"
573 else
574 match spec.input with
575 | Some body -> (
576 match body.schema with
577 | Some (Object obj_spec) ->
578 let required = Option.value obj_spec.required ~default:[] in
579 List.iter
580 (fun (prop_name, _) ->
581 let ocaml_name = Naming.field_name prop_name in
582 let is_required = List.mem prop_name required in
583 if is_required then
584 emitln out (Printf.sprintf " ~%s" ocaml_name)
585 else emitln out (Printf.sprintf " ?%s" ocaml_name) )
586 obj_spec.properties
587 | Some _ ->
588 (* non-object input, take as single argument *)
589 emitln out " ~input"
590 | None ->
591 () )
592 | None ->
593 () ) ;
594 emitln out " (client : Hermes.client) : output Lwt.t =" ;
595 (* build params record *)
596 ( match spec.parameters with
597 | Some params when params.properties <> [] ->
598 emit out " let params = {" ;
599 let fields =
600 List.map
601 (fun (prop_name, _) -> Naming.field_name prop_name)
602 params.properties
603 in
604 emit out (String.concat "; " fields) ;
605 emitln out "} in"
606 | _ ->
607 emitln out " let params = () in" ) ;
608 (* generate the call based on input/output types *)
609 if input_is_bytes then
610 (* bytes input - choose between procedure_blob and procedure_bytes *)
611 begin if output_is_bytes then
612 (* bytes-in, bytes-out: use procedure_bytes *)
613 emitln out
614 (Printf.sprintf
615 " Hermes.procedure_bytes client nsid (params_to_yojson params) \
616 input ~content_type:\"%s\""
617 input_content_type )
618 else if spec.output = None then
619 (* bytes-in, no output: use procedure_bytes and map to unit *)
620 emitln out
621 (Printf.sprintf
622 " let open Lwt.Syntax in\n\
623 \ let* _ = Hermes.procedure_bytes client nsid (params_to_yojson \
624 params) input ~content_type:\"%s\" in\n\
625 \ Lwt.return ()"
626 input_content_type )
627 else
628 (* bytes-in, json-out: use procedure_blob *)
629 emitln out
630 (Printf.sprintf
631 " Hermes.procedure_blob client nsid (params_to_yojson params) \
632 (Bytes.of_string (Option.value input ~default:\"\")) \
633 ~content_type:\"%s\" output_of_yojson"
634 input_content_type )
635 end
636 else begin
637 (* json input - build input and use procedure *)
638 ( match spec.input with
639 | Some body -> (
640 match body.schema with
641 | Some (Object obj_spec) ->
642 if obj_spec.properties = [] then
643 (* empty object uses unit *)
644 emitln out " let input = Some (input_to_yojson ()) in"
645 else begin
646 emit out " let input = Some ({" ;
647 let fields =
648 List.map
649 (fun (prop_name, _) -> Naming.field_name prop_name)
650 obj_spec.properties
651 in
652 emit out (String.concat "; " fields) ;
653 emitln out "} |> input_to_yojson) in"
654 end
655 | Some _ ->
656 emitln out " let input = Some (input_to_yojson input) in"
657 | None ->
658 emitln out " let input = None in" )
659 | None ->
660 emitln out " let input = None in" ) ;
661 emitln out
662 " Hermes.procedure client nsid (params_to_yojson params) input \
663 output_of_yojson"
664 end ;
665 emitln out "end" ;
666 emit_newline out
667
668(* generate token constant *)
669let gen_token nsid out name (spec : token_spec) =
670 let full_uri = nsid ^ "#" ^ name in
671 emitln out
672 (Printf.sprintf "(** %s *)" (Option.value spec.description ~default:name)) ;
673 emitln out (Printf.sprintf "let %s = \"%s\"" (Naming.type_name name) full_uri) ;
674 emit_newline out
675
676(* generate permission set module *)
677let gen_permission_set_module nsid out name (_spec : permission_set_spec) =
678 let type_name = Naming.type_name name in
679 (* generate permission type *)
680 emitln out (Printf.sprintf "(** %s *)" nsid) ;
681 emitln out "type permission =" ;
682 emitln out " { resource: string" ;
683 emitln out " ; lxm: string list option [@default None]" ;
684 emitln out " ; aud: string option [@default None]" ;
685 emitln out
686 " ; inherit_aud: bool option [@key \"inheritAud\"] [@default None]" ;
687 emitln out " ; collection: string list option [@default None]" ;
688 emitln out " ; action: string list option [@default None]" ;
689 emitln out " ; accept: string list option [@default None] }" ;
690 emitln out "[@@deriving yojson {strict= false}]" ;
691 emit_newline out ;
692 (* generate main type *)
693 emitln out (Printf.sprintf "type %s =" type_name) ;
694 emitln out " { title: string option [@default None]" ;
695 emitln out " ; detail: string option [@default None]" ;
696 emitln out " ; permissions: permission list }" ;
697 emitln out "[@@deriving yojson {strict= false}]" ;
698 emit_newline out
699
700(* generate string type alias (for strings with knownValues) *)
701let gen_string_type out name (spec : string_spec) =
702 let type_name = Naming.type_name name in
703 emitln out
704 (Printf.sprintf "(** string type with known values%s *)"
705 (match spec.description with Some d -> ": " ^ d | None -> "") ) ;
706 emitln out (Printf.sprintf "type %s = string" type_name) ;
707 emitln out (Printf.sprintf "let %s_of_yojson = function" type_name) ;
708 emitln out " | `String s -> Ok s" ;
709 emitln out (Printf.sprintf " | _ -> Error \"%s: expected string\"" type_name) ;
710 emitln out (Printf.sprintf "let %s_to_yojson s = `String s" type_name) ;
711 emit_newline out
712
713let find_sccs = Scc.find_def_sccs
714
715(* helper to check if a def generates a type (vs token/query/procedure) *)
716let is_type_def def =
717 match def.type_def with
718 | Object _ | Union _ | Record _ ->
719 true
720 | String spec when spec.known_values <> None ->
721 true
722 | _ ->
723 false
724
725(* helper to check if a def is an object type (can use [@@deriving yojson]) *)
726let is_object_def def =
727 match def.type_def with Object _ | Record _ -> true | _ -> false
728
729(* generate a single definition *)
730let gen_single_def ?(first = true) ?(last = true) nsid out def =
731 match def.type_def with
732 | Object spec ->
733 gen_object_type ~first ~last nsid out def.name spec
734 | Union spec ->
735 (* unions always generate their own converters, so they're always "complete" *)
736 gen_union_type nsid out def.name spec
737 | Token spec ->
738 gen_token nsid out def.name spec
739 | Query spec ->
740 gen_query nsid out def.name spec
741 | Procedure spec ->
742 gen_procedure nsid out def.name spec
743 | Record spec ->
744 gen_object_type ~first ~last nsid out def.name spec.record
745 | PermissionSet spec ->
746 gen_permission_set_module nsid out def.name spec
747 | String spec when spec.known_values <> None ->
748 gen_string_type out def.name spec
749 | String _
750 | Integer _
751 | Boolean _
752 | Bytes _
753 | Blob _
754 | CidLink _
755 | Array _
756 | Ref _
757 | Unknown _
758 | Subscription _ ->
759 ()
760
761(* generate a group of mutually recursive definitions (SCC) *)
762let gen_scc nsid out scc =
763 match scc with
764 | [] ->
765 ()
766 | [def] ->
767 (* single definition, no cycle *)
768 gen_single_def nsid out def
769 | defs ->
770 (* multiple definitions forming a cycle *)
771 (* first, collect and generate all inline unions from all objects in the SCC *)
772 List.iter
773 (fun def ->
774 match def.type_def with
775 | Object spec ->
776 gen_inline_unions nsid out spec.properties
777 | Record spec ->
778 gen_inline_unions nsid out spec.record.properties
779 | _ ->
780 () )
781 defs ;
782 (* separate object-like types from others *)
783 let obj_defs = List.filter is_object_def defs in
784 let other_defs = List.filter (fun d -> not (is_object_def d)) defs in
785 (* generate other types first (unions, etc.) - they define their own converters *)
786 List.iter (fun def -> gen_single_def nsid out def) other_defs ;
787 (* generate object types as mutually recursive *)
788 let n = List.length obj_defs in
789 List.iteri
790 (fun i def ->
791 let first = i = 0 in
792 let last = i = n - 1 in
793 match def.type_def with
794 | Object spec ->
795 (* skip inline unions since we already generated them above *)
796 let required = Option.value spec.required ~default:[] in
797 let nullable = Option.value spec.nullable ~default:[] in
798 let keyword = if first then "type" else "and" in
799 if spec.properties = [] then begin
800 emitln out
801 (Printf.sprintf "%s %s = unit" keyword
802 (Naming.type_name def.name) ) ;
803 if last then begin
804 (* for empty objects in a recursive group, we still need deriving *)
805 emitln out "[@@deriving yojson {strict= false}]" ;
806 emit_newline out
807 end
808 end
809 else begin
810 emitln out
811 (Printf.sprintf "%s %s =" keyword (Naming.type_name def.name)) ;
812 emitln out " {" ;
813 List.iter
814 (fun (prop_name, (prop : property)) ->
815 let ocaml_name = Naming.field_name prop_name in
816 let base_type = gen_type_ref nsid out prop.type_def in
817 let is_required = List.mem prop_name required in
818 let is_nullable = List.mem prop_name nullable in
819 let type_str =
820 if is_required && not is_nullable then base_type
821 else base_type ^ " option"
822 in
823 let key_attr = Naming.key_annotation prop_name ocaml_name in
824 let default_attr =
825 if is_required && not is_nullable then ""
826 else " [@default None]"
827 in
828 emitln out
829 (Printf.sprintf " %s: %s%s%s;" ocaml_name type_str
830 key_attr default_attr ) )
831 spec.properties ;
832 emitln out " }" ;
833 if last then begin
834 emitln out "[@@deriving yojson {strict= false}]" ;
835 emit_newline out
836 end
837 end
838 | Record spec ->
839 let obj_spec = spec.record in
840 let required = Option.value obj_spec.required ~default:[] in
841 let nullable = Option.value obj_spec.nullable ~default:[] in
842 let keyword = if first then "type" else "and" in
843 if obj_spec.properties = [] then begin
844 emitln out
845 (Printf.sprintf "%s %s = unit" keyword
846 (Naming.type_name def.name) ) ;
847 if last then begin
848 emitln out "[@@deriving yojson {strict= false}]" ;
849 emit_newline out
850 end
851 end
852 else begin
853 emitln out
854 (Printf.sprintf "%s %s =" keyword (Naming.type_name def.name)) ;
855 emitln out " {" ;
856 List.iter
857 (fun (prop_name, (prop : property)) ->
858 let ocaml_name = Naming.field_name prop_name in
859 let base_type = gen_type_ref nsid out prop.type_def in
860 let is_required = List.mem prop_name required in
861 let is_nullable = List.mem prop_name nullable in
862 let type_str =
863 if is_required && not is_nullable then base_type
864 else base_type ^ " option"
865 in
866 let key_attr = Naming.key_annotation prop_name ocaml_name in
867 let default_attr =
868 if is_required && not is_nullable then ""
869 else " [@default None]"
870 in
871 emitln out
872 (Printf.sprintf " %s: %s%s%s;" ocaml_name type_str
873 key_attr default_attr ) )
874 obj_spec.properties ;
875 emitln out " }" ;
876 if last then begin
877 emitln out "[@@deriving yojson {strict= false}]" ;
878 emit_newline out
879 end
880 end
881 | _ ->
882 () )
883 obj_defs
884
885(* generate complete lexicon module *)
886let gen_lexicon_module (doc : lexicon_doc) : string =
887 let out = make_output () in
888 let nsid = doc.id in
889 (* header *)
890 emitln out (Printf.sprintf "(* generated from %s *)" nsid) ;
891 emit_newline out ;
892 (* find strongly connected components *)
893 let sccs = find_sccs nsid doc.defs in
894 (* generate each SCC *)
895 List.iter (gen_scc nsid out) sccs ;
896 Emitter.contents out
897
898(* get all imports needed for a lexicon *)
899let get_imports (doc : lexicon_doc) : string list =
900 let out = make_output () in
901 let nsid = doc.id in
902 (* traverse all definitions to collect imports *)
903 let rec collect_from_type = function
904 | Array {items; _} ->
905 collect_from_type items
906 | Ref {ref_; _} ->
907 let _ = gen_ref_type nsid out ref_ in
908 ()
909 | Union {refs; _} ->
910 List.iter
911 (fun r ->
912 let _ = gen_ref_type nsid out r in
913 () )
914 refs
915 | Object {properties; _} ->
916 List.iter
917 (fun (_, (prop : property)) -> collect_from_type prop.type_def)
918 properties
919 | Query {parameters; output; _} ->
920 Option.iter
921 (fun p ->
922 List.iter
923 (fun (_, (prop : property)) -> collect_from_type prop.type_def)
924 p.properties )
925 parameters ;
926 Option.iter (fun o -> Option.iter collect_from_type o.schema) output
927 | Procedure {parameters; input; output; _} ->
928 Option.iter
929 (fun p ->
930 List.iter
931 (fun (_, (prop : property)) -> collect_from_type prop.type_def)
932 p.properties )
933 parameters ;
934 Option.iter (fun i -> Option.iter collect_from_type i.schema) input ;
935 Option.iter (fun o -> Option.iter collect_from_type o.schema) output
936 | Record {record; _} ->
937 List.iter
938 (fun (_, (prop : property)) -> collect_from_type prop.type_def)
939 record.properties
940 | _ ->
941 ()
942 in
943 List.iter (fun def -> collect_from_type def.type_def) doc.defs ;
944 Emitter.get_imports out
945
946(* get external nsid dependencies - delegated to Scc module *)
947let get_external_nsids = Scc.get_external_nsids
948
949(* generate a merged lexicon module from multiple lexicons *)
950let gen_merged_lexicon_module (docs : lexicon_doc list) : string =
951 let out = make_output () in
952 (* collect all nsids in this merged group for local ref detection *)
953 let merged_nsids = List.map (fun d -> d.id) docs in
954 (* header *)
955 emitln out
956 (Printf.sprintf "(* generated from lexicons: %s *)"
957 (String.concat ", " merged_nsids) ) ;
958 emit_newline out ;
959 (* collect all defs from all docs *)
960 let all_defs =
961 List.concat_map
962 (fun doc -> List.map (fun def -> (doc.id, def)) doc.defs)
963 docs
964 in
965 (* collect all inline unions as pseudo-defs for proper ordering *)
966 let rec collect_inline_unions_from_type nsid context acc type_def =
967 match type_def with
968 | Union spec ->
969 (* found an inline union - create pseudo-def entry *)
970 let union_name = Naming.type_name context in
971 (nsid, union_name, spec.refs, spec) :: acc
972 | Array {items; _} ->
973 collect_inline_unions_from_type nsid (context ^ "_item") acc items
974 | Object {properties; _} ->
975 List.fold_left
976 (fun a (prop_name, (prop : property)) ->
977 collect_inline_unions_from_type nsid prop_name a prop.type_def )
978 acc properties
979 | _ ->
980 acc
981 in
982 let all_inline_unions =
983 List.concat_map
984 (fun (nsid, def) ->
985 match def.type_def with
986 | Object spec ->
987 List.fold_left
988 (fun acc (prop_name, (prop : property)) ->
989 collect_inline_unions_from_type nsid prop_name acc prop.type_def )
990 [] spec.properties
991 | Record spec ->
992 List.fold_left
993 (fun acc (prop_name, (prop : property)) ->
994 collect_inline_unions_from_type nsid prop_name acc prop.type_def )
995 [] spec.record.properties
996 | _ ->
997 [] )
998 all_defs
999 in
1000 (* create a lookup for inline unions by their name *)
1001 let inline_union_map = Hashtbl.create 64 in
1002 List.iter
1003 (fun (nsid, name, refs, spec) ->
1004 Hashtbl.add inline_union_map
1005 (nsid ^ "#__inline__" ^ name)
1006 (nsid, name, refs, spec) )
1007 all_inline_unions ;
1008 (* detect inline union name collisions - same name but different refs *)
1009 let inline_union_name_map = Hashtbl.create 64 in
1010 List.iter
1011 (fun (nsid, name, refs, _spec) ->
1012 let sorted_refs = List.sort String.compare refs in
1013 let existing = Hashtbl.find_opt inline_union_name_map name in
1014 match existing with
1015 | None ->
1016 Hashtbl.add inline_union_name_map name [(nsid, sorted_refs)]
1017 | Some entries ->
1018 (* check if this is a different union (different refs) *)
1019 if not (List.exists (fun (_, r) -> r = sorted_refs) entries) then
1020 Hashtbl.replace inline_union_name_map name
1021 ((nsid, sorted_refs) :: entries) )
1022 all_inline_unions ;
1023 let colliding_inline_union_names =
1024 Hashtbl.fold
1025 (fun name entries acc ->
1026 if List.length entries > 1 then name :: acc else acc )
1027 inline_union_name_map []
1028 in
1029 (* the "host" nsid is the first one - types from here keep short names *)
1030 let host_nsid = List.hd merged_nsids in
1031 (* function to get unique inline union name *)
1032 (* only prefix names from "visiting" nsids, not the host *)
1033 let get_unique_inline_union_name nsid name =
1034 if List.mem name colliding_inline_union_names && nsid <> host_nsid then
1035 Naming.flat_name_of_nsid nsid ^ "_" ^ name
1036 else name
1037 in
1038 (* detect name collisions - names that appear in multiple nsids *)
1039 let name_counts = Hashtbl.create 64 in
1040 List.iter
1041 (fun (nsid, def) ->
1042 let existing = Hashtbl.find_opt name_counts def.name in
1043 match existing with
1044 | None ->
1045 Hashtbl.add name_counts def.name [nsid]
1046 | Some nsids when not (List.mem nsid nsids) ->
1047 Hashtbl.replace name_counts def.name (nsid :: nsids)
1048 | _ ->
1049 () )
1050 all_defs ;
1051 let colliding_names =
1052 Hashtbl.fold
1053 (fun name nsids acc -> if List.length nsids > 1 then name :: acc else acc)
1054 name_counts []
1055 in
1056 (* function to get unique type name, adding nsid prefix for collisions *)
1057 (* only prefix names from "visiting" nsids, not the host *)
1058 let get_unique_type_name nsid def_name =
1059 if List.mem def_name colliding_names && nsid <> host_nsid then
1060 (* use full nsid as prefix to guarantee uniqueness *)
1061 (* app.bsky.feed.defs#viewerState -> app_bsky_feed_defs_viewer_state *)
1062 let prefix = Naming.flat_name_of_nsid nsid ^ "_" in
1063 Naming.type_name (prefix ^ def_name)
1064 else Naming.type_name def_name
1065 in
1066 (* for merged modules, we need to handle refs differently:
1067 - refs to other nsids in the merged group become local refs
1068 - refs within same nsid stay as local refs *)
1069 (* custom ref type generator that treats merged nsids as local *)
1070 let rec gen_merged_type_ref current_nsid type_def =
1071 match type_def with
1072 | String _ ->
1073 "string"
1074 | Integer {maximum; _} -> (
1075 match maximum with Some m when m > 1073741823 -> "int64" | _ -> "int" )
1076 | Boolean _ ->
1077 "bool"
1078 | Bytes _ ->
1079 "bytes"
1080 | Blob _ ->
1081 "Hermes.blob"
1082 | CidLink _ ->
1083 "Cid.t"
1084 | Array {items; _} ->
1085 let item_type = gen_merged_type_ref current_nsid items in
1086 item_type ^ " list"
1087 | Object _ ->
1088 "object_todo"
1089 | Ref {ref_; _} ->
1090 gen_merged_ref_type current_nsid ref_
1091 | Union {refs; _} -> (
1092 match lookup_union_name out refs with
1093 | Some name ->
1094 name
1095 | None ->
1096 gen_union_type_name refs )
1097 | Token _ ->
1098 "string"
1099 | Unknown _ ->
1100 "Yojson.Safe.t"
1101 | Query _ | Procedure _ | Subscription _ | Record _ ->
1102 "unit (* primary type *)"
1103 | PermissionSet _ ->
1104 "unit (* permission-set type *)"
1105 and gen_merged_ref_type current_nsid ref_str =
1106 if String.length ref_str > 0 && ref_str.[0] = '#' then begin
1107 (* local ref within same nsid *)
1108 let def_name = String.sub ref_str 1 (String.length ref_str - 1) in
1109 get_unique_type_name current_nsid def_name
1110 end
1111 else
1112 begin match String.split_on_char '#' ref_str with
1113 | [ext_nsid; def_name] ->
1114 if List.mem ext_nsid merged_nsids then
1115 (* ref to another nsid in the merged group - use unique name *)
1116 get_unique_type_name ext_nsid def_name
1117 else begin
1118 (* truly external ref *)
1119 let flat_module = Naming.flat_module_name_of_nsid ext_nsid in
1120 add_import out flat_module ;
1121 flat_module ^ "." ^ Naming.type_name def_name
1122 end
1123 | [ext_nsid] ->
1124 if List.mem ext_nsid merged_nsids then
1125 get_unique_type_name ext_nsid "main"
1126 else begin
1127 let flat_module = Naming.flat_module_name_of_nsid ext_nsid in
1128 add_import out flat_module ; flat_module ^ ".main"
1129 end
1130 | _ ->
1131 "invalid_ref"
1132 end
1133 in
1134 (* generate converter expression for reading a type from json *)
1135 (* returns (converter_expr, needs_result_unwrap) - if needs_result_unwrap is true, caller should apply Result.get_ok *)
1136 let gen_of_yojson_expr current_nsid type_def =
1137 match type_def with
1138 | String _ | Token _ ->
1139 ("to_string", false)
1140 | Integer {maximum; _} -> (
1141 match maximum with
1142 | Some m when m > 1073741823 ->
1143 ("(fun j -> Int64.of_int (to_int j))", false)
1144 | _ ->
1145 ("to_int", false) )
1146 | Boolean _ ->
1147 ("to_bool", false)
1148 | Bytes _ ->
1149 ("(fun j -> Bytes.of_string (to_string j))", false)
1150 | Blob _ ->
1151 ("Hermes.blob_of_yojson", true)
1152 | CidLink _ ->
1153 ("Cid.of_yojson", true)
1154 | Array {items; _} ->
1155 let item_type = gen_merged_type_ref current_nsid items in
1156 ( Printf.sprintf
1157 "(fun j -> to_list j |> List.filter_map (fun x -> match \
1158 %s_of_yojson x with Ok v -> Some v | _ -> None))"
1159 item_type
1160 , false )
1161 | Ref {ref_; _} ->
1162 let type_name = gen_merged_ref_type current_nsid ref_ in
1163 (type_name ^ "_of_yojson", true)
1164 | Union {refs; _} ->
1165 let type_name =
1166 match lookup_union_name out refs with
1167 | Some n ->
1168 n
1169 | None ->
1170 gen_union_type_name refs
1171 in
1172 (type_name ^ "_of_yojson", true)
1173 | Unknown _ ->
1174 ("(fun j -> j)", false)
1175 | _ ->
1176 ("(fun _ -> failwith \"unsupported type\")", false)
1177 in
1178 (* generate converter expression for writing a type to json *)
1179 let gen_to_yojson_expr current_nsid type_def =
1180 match type_def with
1181 | String _ | Token _ ->
1182 "(fun s -> `String s)"
1183 | Integer {maximum; _} -> (
1184 match maximum with
1185 | Some m when m > 1073741823 ->
1186 "(fun i -> `Int (Int64.to_int i))"
1187 | _ ->
1188 "(fun i -> `Int i)" )
1189 | Boolean _ ->
1190 "(fun b -> `Bool b)"
1191 | Bytes _ ->
1192 "(fun b -> `String (Bytes.to_string b))"
1193 | Blob _ ->
1194 "Hermes.blob_to_yojson"
1195 | CidLink _ ->
1196 "Cid.to_yojson"
1197 | Array {items; _} ->
1198 let item_type = gen_merged_type_ref current_nsid items in
1199 Printf.sprintf "(fun l -> `List (List.map %s_to_yojson l))" item_type
1200 | Ref {ref_; _} ->
1201 let type_name = gen_merged_ref_type current_nsid ref_ in
1202 type_name ^ "_to_yojson"
1203 | Union {refs; _} ->
1204 let type_name =
1205 match lookup_union_name out refs with
1206 | Some n ->
1207 n
1208 | None ->
1209 gen_union_type_name refs
1210 in
1211 type_name ^ "_to_yojson"
1212 | Unknown _ ->
1213 "(fun j -> j)"
1214 | _ ->
1215 "(fun _ -> `Null)"
1216 in
1217 (* generate type uri for merged context *)
1218 let gen_merged_type_uri current_nsid ref_str =
1219 if String.length ref_str > 0 && ref_str.[0] = '#' then
1220 current_nsid ^ ref_str
1221 else ref_str
1222 in
1223 (* register inline union names without generating code *)
1224 let register_merged_inline_unions nsid properties =
1225 let rec collect_inline_unions_with_context context acc type_def =
1226 match type_def with
1227 | Union spec ->
1228 (context, spec.refs, spec) :: acc
1229 | Array {items; _} ->
1230 collect_inline_unions_with_context (context ^ "_item") acc items
1231 | _ ->
1232 acc
1233 in
1234 let inline_unions =
1235 List.fold_left
1236 (fun acc (prop_name, (prop : property)) ->
1237 collect_inline_unions_with_context prop_name acc prop.type_def )
1238 [] properties
1239 in
1240 List.iter
1241 (fun (context, refs, _spec) ->
1242 let base_name = Naming.type_name context in
1243 let unique_name = get_unique_inline_union_name nsid base_name in
1244 register_union_name out refs unique_name )
1245 inline_unions
1246 in
1247 (* generate object type for merged context *)
1248 let gen_merged_object_type ?(first = true) ?(last = true) current_nsid name
1249 (spec : object_spec) =
1250 let required = Option.value spec.required ~default:[] in
1251 let nullable = Option.value spec.nullable ~default:[] in
1252 let keyword = if first then "type" else "and" in
1253 let type_name = get_unique_type_name current_nsid name in
1254 if spec.properties = [] then begin
1255 emitln out (Printf.sprintf "%s %s = unit" keyword type_name) ;
1256 if last then begin
1257 emitln out (Printf.sprintf "let %s_of_yojson _ = Ok ()" type_name) ;
1258 emitln out (Printf.sprintf "let %s_to_yojson () = `Assoc []" type_name) ;
1259 emit_newline out
1260 end
1261 end
1262 else begin
1263 if first then register_merged_inline_unions current_nsid spec.properties ;
1264 emitln out (Printf.sprintf "%s %s =" keyword type_name) ;
1265 emitln out " {" ;
1266 List.iter
1267 (fun (prop_name, (prop : property)) ->
1268 let ocaml_name = Naming.field_name prop_name in
1269 let base_type = gen_merged_type_ref current_nsid prop.type_def in
1270 let is_required = List.mem prop_name required in
1271 let is_nullable = List.mem prop_name nullable in
1272 let type_str =
1273 if is_required && not is_nullable then base_type
1274 else base_type ^ " option"
1275 in
1276 let key_attr = Naming.key_annotation prop_name ocaml_name in
1277 let default_attr =
1278 if is_required && not is_nullable then "" else " [@default None]"
1279 in
1280 emitln out
1281 (Printf.sprintf " %s: %s%s%s;" ocaml_name type_str key_attr
1282 default_attr ) )
1283 spec.properties ;
1284 emitln out " }" ;
1285 if last then begin
1286 emitln out "[@@deriving yojson {strict= false}]" ;
1287 emit_newline out
1288 end
1289 end
1290 in
1291 (* generate union type for merged context *)
1292 let gen_merged_union_type current_nsid name (spec : union_spec) =
1293 let type_name = get_unique_type_name current_nsid name in
1294 let is_closed = Option.value spec.closed ~default:false in
1295 emitln out (Printf.sprintf "type %s =" type_name) ;
1296 List.iter
1297 (fun ref_str ->
1298 let variant_name = Naming.variant_name_of_ref ref_str in
1299 let payload_type = gen_merged_ref_type current_nsid ref_str in
1300 emitln out (Printf.sprintf " | %s of %s" variant_name payload_type) )
1301 spec.refs ;
1302 if not is_closed then emitln out " | Unknown of Yojson.Safe.t" ;
1303 emit_newline out ;
1304 emitln out (Printf.sprintf "let %s_of_yojson json =" type_name) ;
1305 emitln out " let open Yojson.Safe.Util in" ;
1306 emitln out " try" ;
1307 emitln out " match json |> member \"$type\" |> to_string with" ;
1308 List.iter
1309 (fun ref_str ->
1310 let variant_name = Naming.variant_name_of_ref ref_str in
1311 let full_type_uri = gen_merged_type_uri current_nsid ref_str in
1312 let payload_type = gen_merged_ref_type current_nsid ref_str in
1313 emitln out (Printf.sprintf " | \"%s\" ->" full_type_uri) ;
1314 emitln out
1315 (Printf.sprintf " (match %s_of_yojson json with" payload_type) ;
1316 emitln out (Printf.sprintf " | Ok v -> Ok (%s v)" variant_name) ;
1317 emitln out " | Error e -> Error e)" )
1318 spec.refs ;
1319 if is_closed then
1320 emitln out " | t -> Error (\"unknown union type: \" ^ t)"
1321 else emitln out " | _ -> Ok (Unknown json)" ;
1322 emitln out " with _ -> Error \"failed to parse union\"" ;
1323 emit_newline out ;
1324 emitln out (Printf.sprintf "let %s_to_yojson = function" type_name) ;
1325 List.iter
1326 (fun ref_str ->
1327 let variant_name = Naming.variant_name_of_ref ref_str in
1328 let full_type_uri = gen_merged_type_uri current_nsid ref_str in
1329 let payload_type = gen_merged_ref_type current_nsid ref_str in
1330 emitln out (Printf.sprintf " | %s v ->" variant_name) ;
1331 emitln out
1332 (Printf.sprintf " (match %s_to_yojson v with" payload_type) ;
1333 emitln out
1334 (Printf.sprintf
1335 " | `Assoc fields -> `Assoc ((\"$type\", `String \"%s\") :: \
1336 fields)"
1337 full_type_uri ) ;
1338 emitln out " | other -> other)" )
1339 spec.refs ;
1340 if not is_closed then emitln out " | Unknown j -> j" ;
1341 emit_newline out
1342 in
1343 (* collect refs for merged SCC detection, using compound keys (nsid#name) *)
1344 let collect_merged_local_refs current_nsid acc type_def =
1345 let rec aux acc = function
1346 | Array {items; _} ->
1347 aux acc items
1348 | Ref {ref_; _} ->
1349 if String.length ref_ > 0 && ref_.[0] = '#' then
1350 (* local ref: #foo -> current_nsid#foo *)
1351 let def_name = String.sub ref_ 1 (String.length ref_ - 1) in
1352 (current_nsid ^ "#" ^ def_name) :: acc
1353 else
1354 begin match String.split_on_char '#' ref_ with
1355 | [ext_nsid; def_name] when List.mem ext_nsid merged_nsids ->
1356 (* cross-nsid ref within merged group *)
1357 (ext_nsid ^ "#" ^ def_name) :: acc
1358 | _ ->
1359 acc
1360 end
1361 | Union {refs; _} ->
1362 List.fold_left
1363 (fun a r ->
1364 if String.length r > 0 && r.[0] = '#' then
1365 let def_name = String.sub r 1 (String.length r - 1) in
1366 (current_nsid ^ "#" ^ def_name) :: a
1367 else
1368 match String.split_on_char '#' r with
1369 | [ext_nsid; def_name] when List.mem ext_nsid merged_nsids ->
1370 (ext_nsid ^ "#" ^ def_name) :: a
1371 | _ ->
1372 a )
1373 acc refs
1374 | Object {properties; _} ->
1375 List.fold_left
1376 (fun a (_, (prop : property)) -> aux a prop.type_def)
1377 acc properties
1378 | Record {record; _} ->
1379 List.fold_left
1380 (fun a (_, (prop : property)) -> aux a prop.type_def)
1381 acc record.properties
1382 | Query {parameters; output; _} -> (
1383 let acc =
1384 match parameters with
1385 | Some params ->
1386 List.fold_left
1387 (fun a (_, (prop : property)) -> aux a prop.type_def)
1388 acc params.properties
1389 | None ->
1390 acc
1391 in
1392 match output with
1393 | Some body ->
1394 Option.fold ~none:acc ~some:(aux acc) body.schema
1395 | None ->
1396 acc )
1397 | Procedure {parameters; input; output; _} -> (
1398 let acc =
1399 match parameters with
1400 | Some params ->
1401 List.fold_left
1402 (fun a (_, (prop : property)) -> aux a prop.type_def)
1403 acc params.properties
1404 | None ->
1405 acc
1406 in
1407 let acc =
1408 match input with
1409 | Some body ->
1410 Option.fold ~none:acc ~some:(aux acc) body.schema
1411 | None ->
1412 acc
1413 in
1414 match output with
1415 | Some body ->
1416 Option.fold ~none:acc ~some:(aux acc) body.schema
1417 | None ->
1418 acc )
1419 | _ ->
1420 acc
1421 in
1422 aux acc type_def
1423 in
1424 (* generate merged SCC *)
1425 let gen_merged_scc scc =
1426 match scc with
1427 | [] ->
1428 ()
1429 | [(nsid, def)] -> (
1430 match def.type_def with
1431 | Object spec ->
1432 gen_merged_object_type nsid def.name spec
1433 | Union spec ->
1434 gen_merged_union_type nsid def.name spec
1435 | Token spec ->
1436 gen_token nsid out def.name spec
1437 | Query spec ->
1438 gen_query nsid out def.name spec
1439 | Procedure spec ->
1440 gen_procedure nsid out def.name spec
1441 | Record spec ->
1442 gen_merged_object_type nsid def.name spec.record
1443 | String spec when spec.known_values <> None ->
1444 gen_string_type out def.name spec
1445 | Array {items; _} ->
1446 (* generate inline union for array items if needed *)
1447 ( match items with
1448 | Union spec ->
1449 let item_type_name = Naming.type_name (def.name ^ "_item") in
1450 register_union_name out spec.refs item_type_name ;
1451 gen_merged_union_type nsid (def.name ^ "_item") spec
1452 | _ ->
1453 () ) ;
1454 (* generate type alias for array *)
1455 let type_name = get_unique_type_name nsid def.name in
1456 let item_type = gen_merged_type_ref nsid items in
1457 emitln out (Printf.sprintf "type %s = %s list" type_name item_type) ;
1458 emitln out (Printf.sprintf "let %s_of_yojson json =" type_name) ;
1459 emitln out " let open Yojson.Safe.Util in" ;
1460 emitln out
1461 (Printf.sprintf
1462 " Ok (to_list json |> List.filter_map (fun x -> match \
1463 %s_of_yojson x with Ok v -> Some v | _ -> None))"
1464 item_type ) ;
1465 emitln out
1466 (Printf.sprintf
1467 "let %s_to_yojson l = `List (List.map %s_to_yojson l)" type_name
1468 item_type ) ;
1469 emit_newline out
1470 | _ ->
1471 () )
1472 | defs ->
1473 (* multi-def SCC - register inline union names first *)
1474 List.iter
1475 (fun (nsid, def) ->
1476 match def.type_def with
1477 | Object spec ->
1478 register_merged_inline_unions nsid spec.properties
1479 | Record spec ->
1480 register_merged_inline_unions nsid spec.record.properties
1481 | _ ->
1482 () )
1483 defs ;
1484 let obj_defs =
1485 List.filter
1486 (fun (_, def) ->
1487 match def.type_def with Object _ | Record _ -> true | _ -> false )
1488 defs
1489 in
1490 let other_defs =
1491 List.filter
1492 (fun (_, def) ->
1493 match def.type_def with Object _ | Record _ -> false | _ -> true )
1494 defs
1495 in
1496 List.iter
1497 (fun (nsid, def) ->
1498 match def.type_def with
1499 | Union spec ->
1500 gen_merged_union_type nsid def.name spec
1501 | Token spec ->
1502 gen_token nsid out def.name spec
1503 | Query spec ->
1504 gen_query nsid out def.name spec
1505 | Procedure spec ->
1506 gen_procedure nsid out def.name spec
1507 | String spec when spec.known_values <> None ->
1508 gen_string_type out def.name spec
1509 | _ ->
1510 () )
1511 other_defs ;
1512 let n = List.length obj_defs in
1513 List.iteri
1514 (fun i (nsid, def) ->
1515 let first = i = 0 in
1516 let last = i = n - 1 in
1517 match def.type_def with
1518 | Object spec ->
1519 let required = Option.value spec.required ~default:[] in
1520 let nullable = Option.value spec.nullable ~default:[] in
1521 let keyword = if first then "type" else "and" in
1522 let type_name = get_unique_type_name nsid def.name in
1523 if spec.properties = [] then begin
1524 emitln out (Printf.sprintf "%s %s = unit" keyword type_name) ;
1525 if last then begin
1526 emitln out "[@@deriving yojson {strict= false}]" ;
1527 emit_newline out
1528 end
1529 end
1530 else begin
1531 emitln out (Printf.sprintf "%s %s =" keyword type_name) ;
1532 emitln out " {" ;
1533 List.iter
1534 (fun (prop_name, (prop : property)) ->
1535 let ocaml_name = Naming.field_name prop_name in
1536 let base_type = gen_merged_type_ref nsid prop.type_def in
1537 let is_required = List.mem prop_name required in
1538 let is_nullable = List.mem prop_name nullable in
1539 let type_str =
1540 if is_required && not is_nullable then base_type
1541 else base_type ^ " option"
1542 in
1543 let key_attr =
1544 Naming.key_annotation prop_name ocaml_name
1545 in
1546 let default_attr =
1547 if is_required && not is_nullable then ""
1548 else " [@default None]"
1549 in
1550 emitln out
1551 (Printf.sprintf " %s: %s%s%s;" ocaml_name type_str
1552 key_attr default_attr ) )
1553 spec.properties ;
1554 emitln out " }" ;
1555 if last then begin
1556 emitln out "[@@deriving yojson {strict= false}]" ;
1557 emit_newline out
1558 end
1559 end
1560 | Record spec ->
1561 let obj_spec = spec.record in
1562 let required = Option.value obj_spec.required ~default:[] in
1563 let nullable = Option.value obj_spec.nullable ~default:[] in
1564 let keyword = if first then "type" else "and" in
1565 let type_name = get_unique_type_name nsid def.name in
1566 if obj_spec.properties = [] then begin
1567 emitln out (Printf.sprintf "%s %s = unit" keyword type_name) ;
1568 if last then begin
1569 emitln out "[@@deriving yojson {strict= false}]" ;
1570 emit_newline out
1571 end
1572 end
1573 else begin
1574 emitln out (Printf.sprintf "%s %s =" keyword type_name) ;
1575 emitln out " {" ;
1576 List.iter
1577 (fun (prop_name, (prop : property)) ->
1578 let ocaml_name = Naming.field_name prop_name in
1579 let base_type = gen_merged_type_ref nsid prop.type_def in
1580 let is_required = List.mem prop_name required in
1581 let is_nullable = List.mem prop_name nullable in
1582 let type_str =
1583 if is_required && not is_nullable then base_type
1584 else base_type ^ " option"
1585 in
1586 let key_attr =
1587 Naming.key_annotation prop_name ocaml_name
1588 in
1589 let default_attr =
1590 if is_required && not is_nullable then ""
1591 else " [@default None]"
1592 in
1593 emitln out
1594 (Printf.sprintf " %s: %s%s%s;" ocaml_name type_str
1595 key_attr default_attr ) )
1596 obj_spec.properties ;
1597 emitln out " }" ;
1598 if last then begin
1599 emitln out "[@@deriving yojson {strict= false}]" ;
1600 emit_newline out
1601 end
1602 end
1603 | _ ->
1604 () )
1605 obj_defs
1606 in
1607 (* create extended defs that include inline unions as pseudo-entries *)
1608 (* inline union key format: nsid#__inline__name *)
1609 let inline_union_defs =
1610 List.map
1611 (fun (nsid, name, refs, spec) ->
1612 let key = nsid ^ "#__inline__" ^ name in
1613 (* inline unions depend on the types they reference *)
1614 let deps =
1615 List.filter_map
1616 (fun r ->
1617 if String.length r > 0 && r.[0] = '#' then
1618 let def_name = String.sub r 1 (String.length r - 1) in
1619 Some (nsid ^ "#" ^ def_name)
1620 else
1621 match String.split_on_char '#' r with
1622 | [ext_nsid; def_name] when List.mem ext_nsid merged_nsids ->
1623 Some (ext_nsid ^ "#" ^ def_name)
1624 | _ ->
1625 None )
1626 refs
1627 in
1628 (key, deps, `InlineUnion (nsid, name, refs, spec)) )
1629 all_inline_unions
1630 in
1631 (* create regular def entries *)
1632 let regular_def_entries =
1633 List.map
1634 (fun (nsid, def) ->
1635 let key = nsid ^ "#" ^ def.name in
1636 let base_deps = collect_merged_local_refs nsid [] def.type_def in
1637 (* add dependencies on inline unions used by this def *)
1638 let inline_deps =
1639 match def.type_def with
1640 | Object spec | Record {record= spec; _} ->
1641 let rec collect_inline_union_deps acc type_def =
1642 match type_def with
1643 | Union _ -> (
1644 (* this property uses an inline union - find its name *)
1645 match lookup_union_name out [] with
1646 | _ ->
1647 acc (* we'll handle this differently *) )
1648 | Array {items; _} ->
1649 collect_inline_union_deps acc items
1650 | _ ->
1651 acc
1652 in
1653 List.fold_left
1654 (fun acc (prop_name, (prop : property)) ->
1655 match prop.type_def with
1656 | Union _ ->
1657 let union_name = Naming.type_name prop_name in
1658 (nsid ^ "#__inline__" ^ union_name) :: acc
1659 | Array {items= Union _; _} ->
1660 let union_name = Naming.type_name (prop_name ^ "_item") in
1661 (nsid ^ "#__inline__" ^ union_name) :: acc
1662 | _ ->
1663 collect_inline_union_deps acc prop.type_def )
1664 [] spec.properties
1665 | _ ->
1666 []
1667 in
1668 (key, base_deps @ inline_deps, `RegularDef (nsid, def)) )
1669 all_defs
1670 in
1671 (* combine all entries *)
1672 let all_entries = regular_def_entries @ inline_union_defs in
1673 (* build dependency map *)
1674 let deps_map = List.map (fun (k, deps, _) -> (k, deps)) all_entries in
1675 let entry_map = List.map (fun (k, _, entry) -> (k, entry)) all_entries in
1676 let all_keys = List.map (fun (k, _, _) -> k) all_entries in
1677 (* run Tarjan's algorithm on combined entries *)
1678 let index_counter = ref 0 in
1679 let indices = Hashtbl.create 64 in
1680 let lowlinks = Hashtbl.create 64 in
1681 let on_stack = Hashtbl.create 64 in
1682 let stack = ref [] in
1683 let sccs = ref [] in
1684 let rec strongconnect key =
1685 let index = !index_counter in
1686 incr index_counter ;
1687 Hashtbl.add indices key index ;
1688 Hashtbl.add lowlinks key index ;
1689 Hashtbl.add on_stack key true ;
1690 stack := key :: !stack ;
1691 let successors =
1692 try List.assoc key deps_map |> List.filter (fun k -> List.mem k all_keys)
1693 with Not_found -> []
1694 in
1695 List.iter
1696 (fun succ ->
1697 if not (Hashtbl.mem indices succ) then begin
1698 strongconnect succ ;
1699 Hashtbl.replace lowlinks key
1700 (min (Hashtbl.find lowlinks key) (Hashtbl.find lowlinks succ))
1701 end
1702 else if Hashtbl.find_opt on_stack succ = Some true then
1703 Hashtbl.replace lowlinks key
1704 (min (Hashtbl.find lowlinks key) (Hashtbl.find indices succ)) )
1705 successors ;
1706 if Hashtbl.find lowlinks key = Hashtbl.find indices key then begin
1707 let rec pop_scc acc =
1708 match !stack with
1709 | [] ->
1710 acc
1711 | top :: rest ->
1712 stack := rest ;
1713 Hashtbl.replace on_stack top false ;
1714 if top = key then top :: acc else pop_scc (top :: acc)
1715 in
1716 let scc_keys = pop_scc [] in
1717 let scc_entries =
1718 List.filter_map (fun k -> List.assoc_opt k entry_map) scc_keys
1719 in
1720 if scc_entries <> [] then sccs := scc_entries :: !sccs
1721 end
1722 in
1723 List.iter
1724 (fun key -> if not (Hashtbl.mem indices key) then strongconnect key)
1725 all_keys ;
1726 let ordered_sccs = List.rev !sccs in
1727 (* helper to generate object type definition only (no converters) *)
1728 let gen_object_type_only ?(keyword = "type") nsid name (spec : object_spec) =
1729 let required = Option.value spec.required ~default:[] in
1730 let nullable = Option.value spec.nullable ~default:[] in
1731 let type_name = get_unique_type_name nsid name in
1732 if spec.properties = [] then
1733 emitln out (Printf.sprintf "%s %s = unit" keyword type_name)
1734 else begin
1735 emitln out (Printf.sprintf "%s %s = {" keyword type_name) ;
1736 List.iter
1737 (fun (prop_name, (prop : property)) ->
1738 let ocaml_name = Naming.field_name prop_name in
1739 let base_type = gen_merged_type_ref nsid prop.type_def in
1740 let is_required = List.mem prop_name required in
1741 let is_nullable = List.mem prop_name nullable in
1742 let type_str =
1743 if is_required && not is_nullable then base_type
1744 else base_type ^ " option"
1745 in
1746 let key_attr = Naming.key_annotation prop_name ocaml_name in
1747 let default_attr =
1748 if is_required && not is_nullable then "" else " [@default None]"
1749 in
1750 emitln out
1751 (Printf.sprintf " %s: %s%s%s;" ocaml_name type_str key_attr
1752 default_attr ) )
1753 spec.properties ;
1754 emitln out "}"
1755 end
1756 in
1757 (* helper to generate inline union type definition only (no converters) *)
1758 let gen_inline_union_type_only ?(keyword = "type") nsid name refs spec =
1759 let is_closed = Option.value spec.closed ~default:false in
1760 emitln out (Printf.sprintf "%s %s =" keyword name) ;
1761 List.iter
1762 (fun ref_str ->
1763 let variant_name = Naming.qualified_variant_name_of_ref ref_str in
1764 let payload_type = gen_merged_ref_type nsid ref_str in
1765 emitln out (Printf.sprintf " | %s of %s" variant_name payload_type) )
1766 refs ;
1767 if not is_closed then emitln out " | Unknown of Yojson.Safe.t"
1768 in
1769 (* helper to generate object converters *)
1770 let gen_object_converters ?(of_keyword = "let") ?(to_keyword = "let") nsid
1771 name (spec : object_spec) =
1772 let required = Option.value spec.required ~default:[] in
1773 let nullable = Option.value spec.nullable ~default:[] in
1774 let type_name = get_unique_type_name nsid name in
1775 if spec.properties = [] then begin
1776 if of_keyword <> "SKIP" then
1777 emitln out
1778 (Printf.sprintf "%s %s_of_yojson _ = Ok ()" of_keyword type_name) ;
1779 if to_keyword <> "SKIP" then
1780 emitln out
1781 (Printf.sprintf "%s %s_to_yojson () = `Assoc []" to_keyword type_name)
1782 end
1783 else begin
1784 (* of_yojson *)
1785 if of_keyword <> "SKIP" then begin
1786 emitln out
1787 (Printf.sprintf "%s %s_of_yojson json =" of_keyword type_name) ;
1788 emitln out " let open Yojson.Safe.Util in" ;
1789 emitln out " try" ;
1790 List.iter
1791 (fun (prop_name, (prop : property)) ->
1792 let ocaml_name = Naming.field_name prop_name in
1793 let conv_expr, needs_unwrap =
1794 gen_of_yojson_expr nsid prop.type_def
1795 in
1796 let is_required = List.mem prop_name required in
1797 let is_nullable = List.mem prop_name nullable in
1798 let is_optional = (not is_required) || is_nullable in
1799 if is_optional then
1800 begin if needs_unwrap then
1801 emitln out
1802 (Printf.sprintf
1803 " let %s = json |> member \"%s\" |> to_option (fun x \
1804 -> match %s x with Ok v -> Some v | _ -> None) |> \
1805 Option.join in"
1806 ocaml_name prop_name conv_expr )
1807 else
1808 emitln out
1809 (Printf.sprintf
1810 " let %s = json |> member \"%s\" |> to_option %s in"
1811 ocaml_name prop_name conv_expr )
1812 end
1813 else
1814 begin if needs_unwrap then
1815 emitln out
1816 (Printf.sprintf
1817 " let %s = json |> member \"%s\" |> %s |> \
1818 Result.get_ok in"
1819 ocaml_name prop_name conv_expr )
1820 else
1821 emitln out
1822 (Printf.sprintf " let %s = json |> member \"%s\" |> %s in"
1823 ocaml_name prop_name conv_expr )
1824 end )
1825 spec.properties ;
1826 emit out " Ok { " ;
1827 emit out
1828 (String.concat "; "
1829 (List.map (fun (pn, _) -> Naming.field_name pn) spec.properties) ) ;
1830 emitln out " }" ;
1831 emitln out " with e -> Error (Printexc.to_string e)" ;
1832 emit_newline out
1833 end ;
1834 (* to_yojson *)
1835 if to_keyword <> "SKIP" then begin
1836 emitln out
1837 (Printf.sprintf "%s %s_to_yojson (r : %s) =" to_keyword type_name
1838 type_name ) ;
1839 emitln out " `Assoc [" ;
1840 List.iteri
1841 (fun i (prop_name, (prop : property)) ->
1842 let ocaml_name = Naming.field_name prop_name in
1843 let conv_expr = gen_to_yojson_expr nsid prop.type_def in
1844 let is_required = List.mem prop_name required in
1845 let is_nullable = List.mem prop_name nullable in
1846 let is_optional = (not is_required) || is_nullable in
1847 let comma =
1848 if i < List.length spec.properties - 1 then ";" else ""
1849 in
1850 if is_optional then
1851 emitln out
1852 (Printf.sprintf
1853 " (\"%s\", match r.%s with Some v -> %s v | None -> \
1854 `Null)%s"
1855 prop_name ocaml_name conv_expr comma )
1856 else
1857 emitln out
1858 (Printf.sprintf " (\"%s\", %s r.%s)%s" prop_name conv_expr
1859 ocaml_name comma ) )
1860 spec.properties ;
1861 emitln out " ]" ;
1862 emit_newline out
1863 end
1864 end
1865 in
1866 (* helper to generate inline union converters *)
1867 let gen_inline_union_converters ?(of_keyword = "let") ?(to_keyword = "let")
1868 nsid name refs spec =
1869 let is_closed = Option.value spec.closed ~default:false in
1870 (* of_yojson *)
1871 if of_keyword <> "SKIP" then begin
1872 emitln out (Printf.sprintf "%s %s_of_yojson json =" of_keyword name) ;
1873 emitln out " let open Yojson.Safe.Util in" ;
1874 emitln out " try" ;
1875 emitln out " match json |> member \"$type\" |> to_string with" ;
1876 List.iter
1877 (fun ref_str ->
1878 let variant_name = Naming.qualified_variant_name_of_ref ref_str in
1879 let full_type_uri = gen_merged_type_uri nsid ref_str in
1880 let payload_type = gen_merged_ref_type nsid ref_str in
1881 emitln out (Printf.sprintf " | \"%s\" ->" full_type_uri) ;
1882 emitln out
1883 (Printf.sprintf " (match %s_of_yojson json with" payload_type) ;
1884 emitln out
1885 (Printf.sprintf " | Ok v -> Ok (%s v)" variant_name) ;
1886 emitln out " | Error e -> Error e)" )
1887 refs ;
1888 if is_closed then
1889 emitln out " | t -> Error (\"unknown union type: \" ^ t)"
1890 else emitln out " | _ -> Ok (Unknown json)" ;
1891 emitln out " with _ -> Error \"failed to parse union\"" ;
1892 emit_newline out
1893 end ;
1894 (* to_yojson *)
1895 if to_keyword <> "SKIP" then begin
1896 emitln out (Printf.sprintf "%s %s_to_yojson = function" to_keyword name) ;
1897 List.iter
1898 (fun ref_str ->
1899 let variant_name = Naming.qualified_variant_name_of_ref ref_str in
1900 let full_type_uri = gen_merged_type_uri nsid ref_str in
1901 let payload_type = gen_merged_ref_type nsid ref_str in
1902 emitln out (Printf.sprintf " | %s v ->" variant_name) ;
1903 emitln out
1904 (Printf.sprintf " (match %s_to_yojson v with" payload_type) ;
1905 emitln out
1906 (Printf.sprintf
1907 " | `Assoc fields -> `Assoc ((\"$type\", `String \"%s\") \
1908 :: fields)"
1909 full_type_uri ) ;
1910 emitln out " | other -> other)" )
1911 refs ;
1912 if not is_closed then emitln out " | Unknown j -> j" ;
1913 emit_newline out
1914 end
1915 in
1916 (* generate each SCC *)
1917 List.iter
1918 (fun scc ->
1919 (* separate inline unions from regular defs *)
1920 let inline_unions_in_scc =
1921 List.filter_map (function `InlineUnion x -> Some x | _ -> None) scc
1922 in
1923 let regular_defs_in_scc =
1924 List.filter_map (function `RegularDef x -> Some x | _ -> None) scc
1925 in
1926 if inline_unions_in_scc = [] then
1927 (* no inline unions - use standard generation with [@@deriving yojson] *)
1928 begin if regular_defs_in_scc <> [] then
1929 gen_merged_scc regular_defs_in_scc
1930 end
1931 else begin
1932 (* has inline unions - generate all types first, then all converters *)
1933 (* register inline union names *)
1934 List.iter
1935 (fun (nsid, name, refs, _spec) ->
1936 let unique_name = get_unique_inline_union_name nsid name in
1937 register_union_name out refs unique_name ;
1938 mark_union_generated out unique_name )
1939 inline_unions_in_scc ;
1940 (* collect all items to generate *)
1941 let all_items =
1942 List.map (fun x -> `Inline x) inline_unions_in_scc
1943 @ List.map (fun x -> `Regular x) regular_defs_in_scc
1944 in
1945 let n = List.length all_items in
1946 if n = 1 then
1947 (* single item - generate normally *)
1948 begin match List.hd all_items with
1949 | `Inline (nsid, name, refs, spec) ->
1950 let unique_name = get_unique_inline_union_name nsid name in
1951 gen_inline_union_type_only nsid unique_name refs spec ;
1952 emit_newline out ;
1953 gen_inline_union_converters nsid unique_name refs spec
1954 | `Regular (nsid, def) -> (
1955 match def.type_def with
1956 | Object spec ->
1957 register_merged_inline_unions nsid spec.properties ;
1958 gen_object_type_only nsid def.name spec ;
1959 emit_newline out ;
1960 gen_object_converters nsid def.name spec
1961 | Record rspec ->
1962 register_merged_inline_unions nsid rspec.record.properties ;
1963 gen_object_type_only nsid def.name rspec.record ;
1964 emit_newline out ;
1965 gen_object_converters nsid def.name rspec.record
1966 | _ ->
1967 gen_merged_scc [(nsid, def)] )
1968 end
1969 else begin
1970 (* multiple items - generate as mutually recursive types *)
1971 (* first pass: register inline unions from objects *)
1972 List.iter
1973 (function
1974 | `Regular (nsid, def) -> (
1975 match def.type_def with
1976 | Object spec ->
1977 register_merged_inline_unions nsid spec.properties
1978 | Record rspec ->
1979 register_merged_inline_unions nsid rspec.record.properties
1980 | _ ->
1981 () )
1982 | `Inline _ ->
1983 () )
1984 all_items ;
1985 (* second pass: generate all type definitions *)
1986 List.iteri
1987 (fun i item ->
1988 let keyword = if i = 0 then "type" else "and" in
1989 match item with
1990 | `Inline (nsid, name, refs, spec) ->
1991 let unique_name = get_unique_inline_union_name nsid name in
1992 gen_inline_union_type_only ~keyword nsid unique_name refs spec
1993 | `Regular (nsid, def) -> (
1994 match def.type_def with
1995 | Object spec ->
1996 gen_object_type_only ~keyword nsid def.name spec
1997 | Record rspec ->
1998 gen_object_type_only ~keyword nsid def.name rspec.record
1999 | _ ->
2000 () ) )
2001 all_items ;
2002 emit_newline out ;
2003 (* third pass: generate all _of_yojson converters as mutually recursive *)
2004 List.iteri
2005 (fun i item ->
2006 let of_keyword = if i = 0 then "let rec" else "and" in
2007 match item with
2008 | `Inline (nsid, name, refs, spec) ->
2009 let unique_name = get_unique_inline_union_name nsid name in
2010 gen_inline_union_converters ~of_keyword ~to_keyword:"SKIP"
2011 nsid unique_name refs spec
2012 | `Regular (nsid, def) -> (
2013 match def.type_def with
2014 | Object spec ->
2015 gen_object_converters ~of_keyword ~to_keyword:"SKIP" nsid
2016 def.name spec
2017 | Record rspec ->
2018 gen_object_converters ~of_keyword ~to_keyword:"SKIP" nsid
2019 def.name rspec.record
2020 | _ ->
2021 () ) )
2022 all_items ;
2023 (* fourth pass: generate all _to_yojson converters as mutually recursive *)
2024 List.iteri
2025 (fun i item ->
2026 let to_keyword = if i = 0 then "and" else "and" in
2027 match item with
2028 | `Inline (nsid, name, refs, spec) ->
2029 let unique_name = get_unique_inline_union_name nsid name in
2030 gen_inline_union_converters ~of_keyword:"SKIP" ~to_keyword
2031 nsid unique_name refs spec
2032 | `Regular (nsid, def) -> (
2033 match def.type_def with
2034 | Object spec ->
2035 gen_object_converters ~of_keyword:"SKIP" ~to_keyword nsid
2036 def.name spec
2037 | Record rspec ->
2038 gen_object_converters ~of_keyword:"SKIP" ~to_keyword nsid
2039 def.name rspec.record
2040 | _ ->
2041 () ) )
2042 all_items
2043 end
2044 end )
2045 ordered_sccs ;
2046 Emitter.contents out
2047
2048(* generate a re-export stub that selectively exports types from a merged module *)
2049let gen_reexport_stub ~merged_module_name ~all_merged_docs (doc : lexicon_doc) :
2050 string =
2051 let buf = Buffer.create 1024 in
2052 let emit s = Buffer.add_string buf s in
2053 let emitln s = Buffer.add_string buf s ; Buffer.add_char buf '\n' in
2054 (* detect collisions across all merged docs *)
2055 let all_defs =
2056 List.concat_map
2057 (fun d -> List.map (fun def -> (d.id, def)) d.defs)
2058 all_merged_docs
2059 in
2060 let name_counts = Hashtbl.create 64 in
2061 List.iter
2062 (fun (nsid, def) ->
2063 let existing = Hashtbl.find_opt name_counts def.name in
2064 match existing with
2065 | None ->
2066 Hashtbl.add name_counts def.name [nsid]
2067 | Some nsids when not (List.mem nsid nsids) ->
2068 Hashtbl.replace name_counts def.name (nsid :: nsids)
2069 | _ ->
2070 () )
2071 all_defs ;
2072 let colliding_names =
2073 Hashtbl.fold
2074 (fun name nsids acc -> if List.length nsids > 1 then name :: acc else acc)
2075 name_counts []
2076 in
2077 (* the "host" nsid is the first one - types from here keep short names *)
2078 let host_nsid = (List.hd all_merged_docs).id in
2079 let get_unique_type_name nsid def_name =
2080 if List.mem def_name colliding_names && nsid <> host_nsid then
2081 let prefix = Naming.flat_name_of_nsid nsid ^ "_" in
2082 Naming.type_name (prefix ^ def_name)
2083 else Naming.type_name def_name
2084 in
2085 emitln (Printf.sprintf "(* re-exported from %s *)" merged_module_name) ;
2086 emitln "" ;
2087 List.iter
2088 (fun def ->
2089 let local_type_name = Naming.type_name def.name in
2090 let merged_type_name = get_unique_type_name doc.id def.name in
2091 match def.type_def with
2092 | Object _ | Record _ | Union _ ->
2093 (* type alias and converter aliases *)
2094 emitln
2095 (Printf.sprintf "type %s = %s.%s" local_type_name merged_module_name
2096 merged_type_name ) ;
2097 emitln
2098 (Printf.sprintf "let %s_of_yojson = %s.%s_of_yojson" local_type_name
2099 merged_module_name merged_type_name ) ;
2100 emitln
2101 (Printf.sprintf "let %s_to_yojson = %s.%s_to_yojson" local_type_name
2102 merged_module_name merged_type_name ) ;
2103 emit "\n"
2104 | String spec when spec.known_values <> None ->
2105 emitln
2106 (Printf.sprintf "type %s = %s.%s" local_type_name merged_module_name
2107 merged_type_name ) ;
2108 emitln
2109 (Printf.sprintf "let %s_of_yojson = %s.%s_of_yojson" local_type_name
2110 merged_module_name merged_type_name ) ;
2111 emitln
2112 (Printf.sprintf "let %s_to_yojson = %s.%s_to_yojson" local_type_name
2113 merged_module_name merged_type_name ) ;
2114 emit "\n"
2115 | Array _ ->
2116 (* re-export array type alias and converters *)
2117 emitln
2118 (Printf.sprintf "type %s = %s.%s" local_type_name merged_module_name
2119 merged_type_name ) ;
2120 emitln
2121 (Printf.sprintf "let %s_of_yojson = %s.%s_of_yojson" local_type_name
2122 merged_module_name merged_type_name ) ;
2123 emitln
2124 (Printf.sprintf "let %s_to_yojson = %s.%s_to_yojson" local_type_name
2125 merged_module_name merged_type_name ) ;
2126 emit "\n"
2127 | Token _ ->
2128 emitln
2129 (Printf.sprintf "let %s = %s.%s" local_type_name merged_module_name
2130 merged_type_name ) ;
2131 emit "\n"
2132 | Query _ | Procedure _ ->
2133 let mod_name = Naming.def_module_name def.name in
2134 emitln
2135 (Printf.sprintf "module %s = %s.%s" mod_name merged_module_name
2136 mod_name ) ;
2137 emit "\n"
2138 | _ ->
2139 () )
2140 doc.defs ;
2141 Buffer.contents buf
2142
2143(* generate a shared module for mutually recursive lexicons *)
2144(* uses Naming.shared_type_name for context-based naming instead of full nsid prefix *)
2145let gen_shared_module (docs : lexicon_doc list) : string =
2146 let out = make_output () in
2147 (* collect all nsids in this shared group *)
2148 let shared_nsids = List.map (fun d -> d.id) docs in
2149 (* header *)
2150 emitln out
2151 (Printf.sprintf "(* shared module for lexicons: %s *)"
2152 (String.concat ", " shared_nsids) ) ;
2153 emit_newline out ;
2154 (* collect all defs from all docs *)
2155 let all_defs =
2156 List.concat_map
2157 (fun doc -> List.map (fun def -> (doc.id, def)) doc.defs)
2158 docs
2159 in
2160 (* detect name collisions - names that appear in multiple nsids *)
2161 let name_counts = Hashtbl.create 64 in
2162 List.iter
2163 (fun (nsid, def) ->
2164 let existing = Hashtbl.find_opt name_counts def.name in
2165 match existing with
2166 | None ->
2167 Hashtbl.add name_counts def.name [nsid]
2168 | Some nsids when not (List.mem nsid nsids) ->
2169 Hashtbl.replace name_counts def.name (nsid :: nsids)
2170 | _ ->
2171 () )
2172 all_defs ;
2173 let colliding_names =
2174 Hashtbl.fold
2175 (fun name nsids acc -> if List.length nsids > 1 then name :: acc else acc)
2176 name_counts []
2177 in
2178 (* also detect inline union name collisions *)
2179 let rec collect_inline_union_contexts nsid context acc type_def =
2180 match type_def with
2181 | Union spec ->
2182 (nsid, context, spec.refs) :: acc
2183 | Array {items; _} ->
2184 collect_inline_union_contexts nsid (context ^ "_item") acc items
2185 | Object {properties; _} ->
2186 List.fold_left
2187 (fun a (prop_name, (prop : property)) ->
2188 collect_inline_union_contexts nsid prop_name a prop.type_def )
2189 acc properties
2190 | _ ->
2191 acc
2192 in
2193 let all_inline_union_contexts =
2194 List.concat_map
2195 (fun (nsid, def) ->
2196 match def.type_def with
2197 | Object spec ->
2198 List.fold_left
2199 (fun acc (prop_name, (prop : property)) ->
2200 collect_inline_union_contexts nsid prop_name acc prop.type_def )
2201 [] spec.properties
2202 | Record rspec ->
2203 List.fold_left
2204 (fun acc (prop_name, (prop : property)) ->
2205 collect_inline_union_contexts nsid prop_name acc prop.type_def )
2206 [] rspec.record.properties
2207 | _ ->
2208 [] )
2209 all_defs
2210 in
2211 (* group inline unions by context name *)
2212 let inline_union_by_context = Hashtbl.create 64 in
2213 List.iter
2214 (fun (nsid, context, refs) ->
2215 let key = Naming.type_name context in
2216 let sorted_refs = List.sort String.compare refs in
2217 let existing = Hashtbl.find_opt inline_union_by_context key in
2218 match existing with
2219 | None ->
2220 Hashtbl.add inline_union_by_context key [(nsid, sorted_refs)]
2221 | Some entries ->
2222 (* collision if different nsid OR different refs *)
2223 if
2224 not
2225 (List.exists (fun (n, r) -> n = nsid && r = sorted_refs) entries)
2226 then
2227 Hashtbl.replace inline_union_by_context key
2228 ((nsid, sorted_refs) :: entries) )
2229 all_inline_union_contexts ;
2230 (* add inline union collisions to colliding_names *)
2231 let colliding_names =
2232 Hashtbl.fold
2233 (fun name entries acc ->
2234 (* collision if more than one entry (different nsid or different refs) *)
2235 if List.length entries > 1 then name :: acc else acc )
2236 inline_union_by_context colliding_names
2237 in
2238 (* function to get unique type name using shared_type_name for collisions *)
2239 let get_shared_type_name nsid def_name =
2240 if List.mem def_name colliding_names then
2241 (* use context-based name: e.g., feed_viewer_state *)
2242 Naming.shared_type_name nsid def_name
2243 else
2244 (* no collision, use simple name *)
2245 Naming.type_name def_name
2246 in
2247 (* custom ref type generator that treats shared nsids as local *)
2248 let rec gen_shared_type_ref current_nsid type_def =
2249 match type_def with
2250 | String _ ->
2251 "string"
2252 | Integer {maximum; _} -> (
2253 match maximum with Some m when m > 1073741823 -> "int64" | _ -> "int" )
2254 | Boolean _ ->
2255 "bool"
2256 | Bytes _ ->
2257 "bytes"
2258 | Blob _ ->
2259 "Hermes.blob"
2260 | CidLink _ ->
2261 "Cid.t"
2262 | Array {items; _} ->
2263 let item_type = gen_shared_type_ref current_nsid items in
2264 item_type ^ " list"
2265 | Object _ ->
2266 "object_todo"
2267 | Ref {ref_; _} ->
2268 gen_shared_ref_type current_nsid ref_
2269 | Union {refs; _} -> (
2270 match lookup_union_name out refs with
2271 | Some name ->
2272 name
2273 | None ->
2274 gen_union_type_name refs )
2275 | Token _ ->
2276 "string"
2277 | Unknown _ ->
2278 "Yojson.Safe.t"
2279 | Query _ | Procedure _ | Subscription _ | Record _ ->
2280 "unit (* primary type *)"
2281 | PermissionSet _ ->
2282 "unit (* permission-set type *)"
2283 and gen_shared_ref_type current_nsid ref_str =
2284 if String.length ref_str > 0 && ref_str.[0] = '#' then begin
2285 (* local ref within same nsid *)
2286 let def_name = String.sub ref_str 1 (String.length ref_str - 1) in
2287 get_shared_type_name current_nsid def_name
2288 end
2289 else
2290 begin match String.split_on_char '#' ref_str with
2291 | [ext_nsid; def_name] ->
2292 if List.mem ext_nsid shared_nsids then
2293 (* ref to another nsid in the shared group *)
2294 get_shared_type_name ext_nsid def_name
2295 else begin
2296 (* truly external ref *)
2297 let flat_module = Naming.flat_module_name_of_nsid ext_nsid in
2298 add_import out flat_module ;
2299 flat_module ^ "." ^ Naming.type_name def_name
2300 end
2301 | [ext_nsid] ->
2302 if List.mem ext_nsid shared_nsids then
2303 get_shared_type_name ext_nsid "main"
2304 else begin
2305 let flat_module = Naming.flat_module_name_of_nsid ext_nsid in
2306 add_import out flat_module ; flat_module ^ ".main"
2307 end
2308 | _ ->
2309 "invalid_ref"
2310 end
2311 in
2312 (* generate type uri for shared context *)
2313 let gen_shared_type_uri current_nsid ref_str =
2314 if String.length ref_str > 0 && ref_str.[0] = '#' then
2315 current_nsid ^ ref_str
2316 else ref_str
2317 in
2318 (* generate converter expression for reading a type from json *)
2319 let gen_shared_of_yojson_expr current_nsid type_def =
2320 match type_def with
2321 | String _ | Token _ ->
2322 ("to_string", false)
2323 | Integer {maximum; _} -> (
2324 match maximum with
2325 | Some m when m > 1073741823 ->
2326 ("(fun j -> Int64.of_int (to_int j))", false)
2327 | _ ->
2328 ("to_int", false) )
2329 | Boolean _ ->
2330 ("to_bool", false)
2331 | Bytes _ ->
2332 ("(fun j -> Bytes.of_string (to_string j))", false)
2333 | Blob _ ->
2334 ("Hermes.blob_of_yojson", true)
2335 | CidLink _ ->
2336 ("Cid.of_yojson", true)
2337 | Array {items; _} ->
2338 let item_type = gen_shared_type_ref current_nsid items in
2339 ( Printf.sprintf
2340 "(fun j -> to_list j |> List.filter_map (fun x -> match \
2341 %s_of_yojson x with Ok v -> Some v | _ -> None))"
2342 item_type
2343 , false )
2344 | Ref {ref_; _} ->
2345 let type_name = gen_shared_ref_type current_nsid ref_ in
2346 (type_name ^ "_of_yojson", true)
2347 | Union {refs; _} ->
2348 let type_name =
2349 match lookup_union_name out refs with
2350 | Some n ->
2351 n
2352 | None ->
2353 gen_union_type_name refs
2354 in
2355 (type_name ^ "_of_yojson", true)
2356 | Unknown _ ->
2357 ("(fun j -> j)", false)
2358 | _ ->
2359 ("(fun _ -> failwith \"unsupported type\")", false)
2360 in
2361 (* generate converter expression for writing a type to json *)
2362 let gen_shared_to_yojson_expr current_nsid type_def =
2363 match type_def with
2364 | String _ | Token _ ->
2365 "(fun s -> `String s)"
2366 | Integer {maximum; _} -> (
2367 match maximum with
2368 | Some m when m > 1073741823 ->
2369 "(fun i -> `Int (Int64.to_int i))"
2370 | _ ->
2371 "(fun i -> `Int i)" )
2372 | Boolean _ ->
2373 "(fun b -> `Bool b)"
2374 | Bytes _ ->
2375 "(fun b -> `String (Bytes.to_string b))"
2376 | Blob _ ->
2377 "Hermes.blob_to_yojson"
2378 | CidLink _ ->
2379 "Cid.to_yojson"
2380 | Array {items; _} ->
2381 let item_type = gen_shared_type_ref current_nsid items in
2382 Printf.sprintf "(fun l -> `List (List.map %s_to_yojson l))" item_type
2383 | Ref {ref_; _} ->
2384 let type_name = gen_shared_ref_type current_nsid ref_ in
2385 type_name ^ "_to_yojson"
2386 | Union {refs; _} ->
2387 let type_name =
2388 match lookup_union_name out refs with
2389 | Some n ->
2390 n
2391 | None ->
2392 gen_union_type_name refs
2393 in
2394 type_name ^ "_to_yojson"
2395 | Unknown _ ->
2396 "(fun j -> j)"
2397 | _ ->
2398 "(fun _ -> `Null)"
2399 in
2400 (* collect inline unions with context-based naming *)
2401 let get_shared_inline_union_name nsid context =
2402 let base_name = Naming.type_name context in
2403 (* check if there's a collision with this inline union name *)
2404 if List.mem base_name colliding_names then
2405 Naming.shared_type_name nsid context
2406 else base_name
2407 in
2408 let register_shared_inline_unions nsid properties =
2409 let rec collect_inline_unions_with_context context acc type_def =
2410 match type_def with
2411 | Union spec ->
2412 (context, spec.refs, spec) :: acc
2413 | Array {items; _} ->
2414 collect_inline_unions_with_context (context ^ "_item") acc items
2415 | _ ->
2416 acc
2417 in
2418 let inline_unions =
2419 List.fold_left
2420 (fun acc (prop_name, (prop : property)) ->
2421 collect_inline_unions_with_context prop_name acc prop.type_def )
2422 [] properties
2423 in
2424 List.iter
2425 (fun (context, refs, _spec) ->
2426 let unique_name = get_shared_inline_union_name nsid context in
2427 register_union_name out refs unique_name )
2428 inline_unions
2429 in
2430 (* generate object type for shared context *)
2431 let gen_shared_object_type ?(first = true) ?(last = true) current_nsid name
2432 (spec : object_spec) =
2433 let required = Option.value spec.required ~default:[] in
2434 let nullable = Option.value spec.nullable ~default:[] in
2435 let keyword = if first then "type" else "and" in
2436 let type_name = get_shared_type_name current_nsid name in
2437 if spec.properties = [] then begin
2438 emitln out (Printf.sprintf "%s %s = unit" keyword type_name) ;
2439 if last then begin
2440 emitln out (Printf.sprintf "let %s_of_yojson _ = Ok ()" type_name) ;
2441 emitln out (Printf.sprintf "let %s_to_yojson () = `Assoc []" type_name) ;
2442 emit_newline out
2443 end
2444 end
2445 else begin
2446 if first then register_shared_inline_unions current_nsid spec.properties ;
2447 emitln out (Printf.sprintf "%s %s =" keyword type_name) ;
2448 emitln out " {" ;
2449 List.iter
2450 (fun (prop_name, (prop : property)) ->
2451 let ocaml_name = Naming.field_name prop_name in
2452 let base_type = gen_shared_type_ref current_nsid prop.type_def in
2453 let is_required = List.mem prop_name required in
2454 let is_nullable = List.mem prop_name nullable in
2455 let type_str =
2456 if is_required && not is_nullable then base_type
2457 else base_type ^ " option"
2458 in
2459 let key_attr = Naming.key_annotation prop_name ocaml_name in
2460 let default_attr =
2461 if is_required && not is_nullable then "" else " [@default None]"
2462 in
2463 emitln out
2464 (Printf.sprintf " %s: %s%s%s;" ocaml_name type_str key_attr
2465 default_attr ) )
2466 spec.properties ;
2467 emitln out " }" ;
2468 if last then begin
2469 emitln out "[@@deriving yojson {strict= false}]" ;
2470 emit_newline out
2471 end
2472 end
2473 in
2474 (* generate union type for shared context *)
2475 let gen_shared_union_type current_nsid name (spec : union_spec) =
2476 let type_name = get_shared_type_name current_nsid name in
2477 let is_closed = Option.value spec.closed ~default:false in
2478 emitln out (Printf.sprintf "type %s =" type_name) ;
2479 List.iter
2480 (fun ref_str ->
2481 let variant_name = Naming.qualified_variant_name_of_ref ref_str in
2482 let payload_type = gen_shared_ref_type current_nsid ref_str in
2483 emitln out (Printf.sprintf " | %s of %s" variant_name payload_type) )
2484 spec.refs ;
2485 if not is_closed then emitln out " | Unknown of Yojson.Safe.t" ;
2486 emit_newline out ;
2487 emitln out (Printf.sprintf "let %s_of_yojson json =" type_name) ;
2488 emitln out " let open Yojson.Safe.Util in" ;
2489 emitln out " try" ;
2490 emitln out " match json |> member \"$type\" |> to_string with" ;
2491 List.iter
2492 (fun ref_str ->
2493 let variant_name = Naming.qualified_variant_name_of_ref ref_str in
2494 let full_type_uri = gen_shared_type_uri current_nsid ref_str in
2495 let payload_type = gen_shared_ref_type current_nsid ref_str in
2496 emitln out (Printf.sprintf " | \"%s\" ->" full_type_uri) ;
2497 emitln out
2498 (Printf.sprintf " (match %s_of_yojson json with" payload_type) ;
2499 emitln out (Printf.sprintf " | Ok v -> Ok (%s v)" variant_name) ;
2500 emitln out " | Error e -> Error e)" )
2501 spec.refs ;
2502 if is_closed then
2503 emitln out " | t -> Error (\"unknown union type: \" ^ t)"
2504 else emitln out " | _ -> Ok (Unknown json)" ;
2505 emitln out " with _ -> Error \"failed to parse union\"" ;
2506 emit_newline out ;
2507 emitln out (Printf.sprintf "let %s_to_yojson = function" type_name) ;
2508 List.iter
2509 (fun ref_str ->
2510 let variant_name = Naming.qualified_variant_name_of_ref ref_str in
2511 let full_type_uri = gen_shared_type_uri current_nsid ref_str in
2512 let payload_type = gen_shared_ref_type current_nsid ref_str in
2513 emitln out (Printf.sprintf " | %s v ->" variant_name) ;
2514 emitln out
2515 (Printf.sprintf " (match %s_to_yojson v with" payload_type) ;
2516 emitln out
2517 (Printf.sprintf
2518 " | `Assoc fields -> `Assoc ((\"$type\", `String \"%s\") :: \
2519 fields)"
2520 full_type_uri ) ;
2521 emitln out " | other -> other)" )
2522 spec.refs ;
2523 if not is_closed then emitln out " | Unknown j -> j" ;
2524 emit_newline out
2525 in
2526 (* collect refs for shared SCC detection, using compound keys (nsid#name) *)
2527 let collect_shared_local_refs current_nsid acc type_def =
2528 let rec aux acc = function
2529 | Array {items; _} ->
2530 aux acc items
2531 | Ref {ref_; _} ->
2532 if String.length ref_ > 0 && ref_.[0] = '#' then
2533 (* local ref: #foo -> current_nsid#foo *)
2534 let def_name = String.sub ref_ 1 (String.length ref_ - 1) in
2535 (current_nsid ^ "#" ^ def_name) :: acc
2536 else
2537 begin match String.split_on_char '#' ref_ with
2538 | [ext_nsid; def_name] when List.mem ext_nsid shared_nsids ->
2539 (* cross-nsid ref within shared group *)
2540 (ext_nsid ^ "#" ^ def_name) :: acc
2541 | _ ->
2542 acc
2543 end
2544 | Union {refs; _} ->
2545 List.fold_left
2546 (fun a r ->
2547 if String.length r > 0 && r.[0] = '#' then
2548 let def_name = String.sub r 1 (String.length r - 1) in
2549 (current_nsid ^ "#" ^ def_name) :: a
2550 else
2551 match String.split_on_char '#' r with
2552 | [ext_nsid; def_name] when List.mem ext_nsid shared_nsids ->
2553 (ext_nsid ^ "#" ^ def_name) :: a
2554 | _ ->
2555 a )
2556 acc refs
2557 | Object {properties; _} ->
2558 List.fold_left
2559 (fun a (_, (prop : property)) -> aux a prop.type_def)
2560 acc properties
2561 | Record {record; _} ->
2562 List.fold_left
2563 (fun a (_, (prop : property)) -> aux a prop.type_def)
2564 acc record.properties
2565 | Query {parameters; output; _} -> (
2566 let acc =
2567 match parameters with
2568 | Some params ->
2569 List.fold_left
2570 (fun a (_, (prop : property)) -> aux a prop.type_def)
2571 acc params.properties
2572 | None ->
2573 acc
2574 in
2575 match output with
2576 | Some body ->
2577 Option.fold ~none:acc ~some:(aux acc) body.schema
2578 | None ->
2579 acc )
2580 | Procedure {parameters; input; output; _} -> (
2581 let acc =
2582 match parameters with
2583 | Some params ->
2584 List.fold_left
2585 (fun a (_, (prop : property)) -> aux a prop.type_def)
2586 acc params.properties
2587 | None ->
2588 acc
2589 in
2590 let acc =
2591 match input with
2592 | Some body ->
2593 Option.fold ~none:acc ~some:(aux acc) body.schema
2594 | None ->
2595 acc
2596 in
2597 match output with
2598 | Some body ->
2599 Option.fold ~none:acc ~some:(aux acc) body.schema
2600 | None ->
2601 acc )
2602 | _ ->
2603 acc
2604 in
2605 aux acc type_def
2606 in
2607 (* generate single shared def *)
2608 let gen_shared_single_def (nsid, def) =
2609 match def.type_def with
2610 | Object spec ->
2611 gen_shared_object_type nsid def.name spec
2612 | Union spec ->
2613 gen_shared_union_type nsid def.name spec
2614 | Token spec ->
2615 gen_token nsid out def.name spec
2616 | Query spec ->
2617 gen_query nsid out def.name spec
2618 | Procedure spec ->
2619 gen_procedure nsid out def.name spec
2620 | Record spec ->
2621 gen_shared_object_type nsid def.name spec.record
2622 | String spec when spec.known_values <> None ->
2623 gen_string_type out def.name spec
2624 | Array {items; _} ->
2625 (* generate inline union for array items if needed *)
2626 ( match items with
2627 | Union spec ->
2628 let item_type_name = Naming.type_name (def.name ^ "_item") in
2629 register_union_name out spec.refs item_type_name ;
2630 gen_shared_union_type nsid (def.name ^ "_item") spec
2631 | _ ->
2632 () ) ;
2633 (* generate type alias for array *)
2634 let type_name = get_shared_type_name nsid def.name in
2635 let item_type = gen_shared_type_ref nsid items in
2636 emitln out (Printf.sprintf "type %s = %s list" type_name item_type) ;
2637 emitln out (Printf.sprintf "let %s_of_yojson json =" type_name) ;
2638 emitln out " let open Yojson.Safe.Util in" ;
2639 emitln out
2640 (Printf.sprintf
2641 " Ok (to_list json |> List.filter_map (fun x -> match \
2642 %s_of_yojson x with Ok v -> Some v | _ -> None))"
2643 item_type ) ;
2644 emitln out
2645 (Printf.sprintf "let %s_to_yojson l = `List (List.map %s_to_yojson l)"
2646 type_name item_type ) ;
2647 emit_newline out
2648 | _ ->
2649 ()
2650 in
2651 (* helper to generate object type definition only (no converters) *)
2652 let gen_shared_object_type_only ?(keyword = "type") nsid name
2653 (spec : object_spec) =
2654 let required = Option.value spec.required ~default:[] in
2655 let nullable = Option.value spec.nullable ~default:[] in
2656 let type_name = get_shared_type_name nsid name in
2657 if spec.properties = [] then
2658 emitln out (Printf.sprintf "%s %s = unit" keyword type_name)
2659 else begin
2660 emitln out (Printf.sprintf "%s %s = {" keyword type_name) ;
2661 List.iter
2662 (fun (prop_name, (prop : property)) ->
2663 let ocaml_name = Naming.field_name prop_name in
2664 let base_type = gen_shared_type_ref nsid prop.type_def in
2665 let is_required = List.mem prop_name required in
2666 let is_nullable = List.mem prop_name nullable in
2667 let type_str =
2668 if is_required && not is_nullable then base_type
2669 else base_type ^ " option"
2670 in
2671 let key_attr = Naming.key_annotation prop_name ocaml_name in
2672 let default_attr =
2673 if is_required && not is_nullable then "" else " [@default None]"
2674 in
2675 emitln out
2676 (Printf.sprintf " %s: %s%s%s;" ocaml_name type_str key_attr
2677 default_attr ) )
2678 spec.properties ;
2679 emitln out "}"
2680 end
2681 in
2682 (* helper to generate inline union type definition only *)
2683 let gen_shared_inline_union_type_only ?(keyword = "type") nsid name refs spec
2684 =
2685 let is_closed = Option.value spec.closed ~default:false in
2686 emitln out (Printf.sprintf "%s %s =" keyword name) ;
2687 List.iter
2688 (fun ref_str ->
2689 let variant_name = Naming.qualified_variant_name_of_ref ref_str in
2690 let payload_type = gen_shared_ref_type nsid ref_str in
2691 emitln out (Printf.sprintf " | %s of %s" variant_name payload_type) )
2692 refs ;
2693 if not is_closed then emitln out " | Unknown of Yojson.Safe.t"
2694 in
2695 (* helper to generate object converters *)
2696 let gen_shared_object_converters ?(of_keyword = "let") ?(to_keyword = "let")
2697 nsid name (spec : object_spec) =
2698 let required = Option.value spec.required ~default:[] in
2699 let nullable = Option.value spec.nullable ~default:[] in
2700 let type_name = get_shared_type_name nsid name in
2701 if spec.properties = [] then begin
2702 if of_keyword <> "SKIP" then
2703 emitln out
2704 (Printf.sprintf "%s %s_of_yojson _ = Ok ()" of_keyword type_name) ;
2705 if to_keyword <> "SKIP" then
2706 emitln out
2707 (Printf.sprintf "%s %s_to_yojson () = `Assoc []" to_keyword type_name)
2708 end
2709 else begin
2710 (* of_yojson *)
2711 if of_keyword <> "SKIP" then begin
2712 emitln out
2713 (Printf.sprintf "%s %s_of_yojson json =" of_keyword type_name) ;
2714 emitln out " let open Yojson.Safe.Util in" ;
2715 emitln out " try" ;
2716 List.iter
2717 (fun (prop_name, (prop : property)) ->
2718 let ocaml_name = Naming.field_name prop_name in
2719 let conv_expr, needs_unwrap =
2720 gen_shared_of_yojson_expr nsid prop.type_def
2721 in
2722 let is_required = List.mem prop_name required in
2723 let is_nullable = List.mem prop_name nullable in
2724 let is_optional = (not is_required) || is_nullable in
2725 if is_optional then
2726 begin if needs_unwrap then
2727 emitln out
2728 (Printf.sprintf
2729 " let %s = json |> member \"%s\" |> to_option (fun x \
2730 -> match %s x with Ok v -> Some v | _ -> None) |> \
2731 Option.join in"
2732 ocaml_name prop_name conv_expr )
2733 else
2734 emitln out
2735 (Printf.sprintf
2736 " let %s = json |> member \"%s\" |> to_option %s in"
2737 ocaml_name prop_name conv_expr )
2738 end
2739 else
2740 begin if needs_unwrap then
2741 emitln out
2742 (Printf.sprintf
2743 " let %s = json |> member \"%s\" |> %s |> \
2744 Result.get_ok in"
2745 ocaml_name prop_name conv_expr )
2746 else
2747 emitln out
2748 (Printf.sprintf " let %s = json |> member \"%s\" |> %s in"
2749 ocaml_name prop_name conv_expr )
2750 end )
2751 spec.properties ;
2752 emit out " Ok { " ;
2753 emit out
2754 (String.concat "; "
2755 (List.map (fun (pn, _) -> Naming.field_name pn) spec.properties) ) ;
2756 emitln out " }" ;
2757 emitln out " with e -> Error (Printexc.to_string e)" ;
2758 emit_newline out
2759 end ;
2760 (* to_yojson *)
2761 if to_keyword <> "SKIP" then begin
2762 emitln out
2763 (Printf.sprintf "%s %s_to_yojson (r : %s) =" to_keyword type_name
2764 type_name ) ;
2765 emitln out " `Assoc [" ;
2766 List.iteri
2767 (fun i (prop_name, (prop : property)) ->
2768 let ocaml_name = Naming.field_name prop_name in
2769 let conv_expr = gen_shared_to_yojson_expr nsid prop.type_def in
2770 let is_required = List.mem prop_name required in
2771 let is_nullable = List.mem prop_name nullable in
2772 let is_optional = (not is_required) || is_nullable in
2773 let comma =
2774 if i < List.length spec.properties - 1 then ";" else ""
2775 in
2776 if is_optional then
2777 emitln out
2778 (Printf.sprintf
2779 " (\"%s\", match r.%s with Some v -> %s v | None -> \
2780 `Null)%s"
2781 prop_name ocaml_name conv_expr comma )
2782 else
2783 emitln out
2784 (Printf.sprintf " (\"%s\", %s r.%s)%s" prop_name conv_expr
2785 ocaml_name comma ) )
2786 spec.properties ;
2787 emitln out " ]" ;
2788 emit_newline out
2789 end
2790 end
2791 in
2792 (* helper to generate inline union converters *)
2793 let gen_shared_inline_union_converters ?(of_keyword = "let")
2794 ?(to_keyword = "let") nsid name refs spec =
2795 let is_closed = Option.value spec.closed ~default:false in
2796 (* of_yojson *)
2797 if of_keyword <> "SKIP" then begin
2798 emitln out (Printf.sprintf "%s %s_of_yojson json =" of_keyword name) ;
2799 emitln out " let open Yojson.Safe.Util in" ;
2800 emitln out " try" ;
2801 emitln out " match json |> member \"$type\" |> to_string with" ;
2802 List.iter
2803 (fun ref_str ->
2804 let variant_name = Naming.qualified_variant_name_of_ref ref_str in
2805 let full_type_uri = gen_shared_type_uri nsid ref_str in
2806 let payload_type = gen_shared_ref_type nsid ref_str in
2807 emitln out (Printf.sprintf " | \"%s\" ->" full_type_uri) ;
2808 emitln out
2809 (Printf.sprintf " (match %s_of_yojson json with" payload_type) ;
2810 emitln out
2811 (Printf.sprintf " | Ok v -> Ok (%s v)" variant_name) ;
2812 emitln out " | Error e -> Error e)" )
2813 refs ;
2814 if is_closed then
2815 emitln out " | t -> Error (\"unknown union type: \" ^ t)"
2816 else emitln out " | _ -> Ok (Unknown json)" ;
2817 emitln out " with _ -> Error \"failed to parse union\"" ;
2818 emit_newline out
2819 end ;
2820 (* to_yojson *)
2821 if to_keyword <> "SKIP" then begin
2822 emitln out (Printf.sprintf "%s %s_to_yojson = function" to_keyword name) ;
2823 List.iter
2824 (fun ref_str ->
2825 let variant_name = Naming.qualified_variant_name_of_ref ref_str in
2826 let full_type_uri = gen_shared_type_uri nsid ref_str in
2827 let payload_type = gen_shared_ref_type nsid ref_str in
2828 emitln out (Printf.sprintf " | %s v ->" variant_name) ;
2829 emitln out
2830 (Printf.sprintf " (match %s_to_yojson v with" payload_type) ;
2831 emitln out
2832 (Printf.sprintf
2833 " | `Assoc fields -> `Assoc ((\"$type\", `String \"%s\") \
2834 :: fields)"
2835 full_type_uri ) ;
2836 emitln out " | other -> other)" )
2837 refs ;
2838 if not is_closed then emitln out " | Unknown j -> j" ;
2839 emit_newline out
2840 end
2841 in
2842 (* collect all inline unions as pseudo-defs for proper ordering *)
2843 let rec collect_inline_unions_from_type nsid context acc type_def =
2844 match type_def with
2845 | Union spec ->
2846 let union_name = get_shared_inline_union_name nsid context in
2847 (nsid, union_name, spec.refs, spec) :: acc
2848 | Array {items; _} ->
2849 collect_inline_unions_from_type nsid (context ^ "_item") acc items
2850 | Object {properties; _} ->
2851 List.fold_left
2852 (fun a (prop_name, (prop : property)) ->
2853 collect_inline_unions_from_type nsid prop_name a prop.type_def )
2854 acc properties
2855 | _ ->
2856 acc
2857 in
2858 let all_inline_unions =
2859 List.concat_map
2860 (fun (nsid, def) ->
2861 match def.type_def with
2862 | Object spec ->
2863 List.fold_left
2864 (fun acc (prop_name, (prop : property)) ->
2865 collect_inline_unions_from_type nsid prop_name acc prop.type_def )
2866 [] spec.properties
2867 | Record spec ->
2868 List.fold_left
2869 (fun acc (prop_name, (prop : property)) ->
2870 collect_inline_unions_from_type nsid prop_name acc prop.type_def )
2871 [] spec.record.properties
2872 | _ ->
2873 [] )
2874 all_defs
2875 in
2876 (* create inline union entries *)
2877 let inline_union_defs =
2878 List.map
2879 (fun (nsid, name, refs, spec) ->
2880 let key = nsid ^ "#__inline__" ^ name in
2881 let deps =
2882 List.filter_map
2883 (fun r ->
2884 if String.length r > 0 && r.[0] = '#' then
2885 let def_name = String.sub r 1 (String.length r - 1) in
2886 Some (nsid ^ "#" ^ def_name)
2887 else
2888 match String.split_on_char '#' r with
2889 | [ext_nsid; def_name] when List.mem ext_nsid shared_nsids ->
2890 Some (ext_nsid ^ "#" ^ def_name)
2891 | _ ->
2892 None )
2893 refs
2894 in
2895 (key, deps, `InlineUnion (nsid, name, refs, spec)) )
2896 all_inline_unions
2897 in
2898 (* create regular def entries *)
2899 let regular_def_entries =
2900 List.map
2901 (fun (nsid, def) ->
2902 let key = nsid ^ "#" ^ def.name in
2903 let base_deps = collect_shared_local_refs nsid [] def.type_def in
2904 let inline_deps =
2905 match def.type_def with
2906 | Object spec | Record {record= spec; _} ->
2907 List.fold_left
2908 (fun acc (prop_name, (prop : property)) ->
2909 match prop.type_def with
2910 | Union _ ->
2911 let union_name =
2912 get_shared_inline_union_name nsid prop_name
2913 in
2914 (nsid ^ "#__inline__" ^ union_name) :: acc
2915 | Array {items= Union _; _} ->
2916 let union_name =
2917 get_shared_inline_union_name nsid (prop_name ^ "_item")
2918 in
2919 (nsid ^ "#__inline__" ^ union_name) :: acc
2920 | _ ->
2921 acc )
2922 [] spec.properties
2923 | _ ->
2924 []
2925 in
2926 (key, base_deps @ inline_deps, `RegularDef (nsid, def)) )
2927 all_defs
2928 in
2929 (* combine all entries *)
2930 let all_entries = regular_def_entries @ inline_union_defs in
2931 let deps_map = List.map (fun (k, deps, _) -> (k, deps)) all_entries in
2932 let entry_map = List.map (fun (k, _, entry) -> (k, entry)) all_entries in
2933 let all_keys = List.map (fun (k, _, _) -> k) all_entries in
2934 (* run Tarjan's algorithm *)
2935 let index_counter = ref 0 in
2936 let indices = Hashtbl.create 64 in
2937 let lowlinks = Hashtbl.create 64 in
2938 let on_stack = Hashtbl.create 64 in
2939 let stack = ref [] in
2940 let sccs = ref [] in
2941 let rec strongconnect key =
2942 let index = !index_counter in
2943 incr index_counter ;
2944 Hashtbl.add indices key index ;
2945 Hashtbl.add lowlinks key index ;
2946 Hashtbl.add on_stack key true ;
2947 stack := key :: !stack ;
2948 let successors =
2949 try List.assoc key deps_map |> List.filter (fun k -> List.mem k all_keys)
2950 with Not_found -> []
2951 in
2952 List.iter
2953 (fun succ ->
2954 if not (Hashtbl.mem indices succ) then begin
2955 strongconnect succ ;
2956 Hashtbl.replace lowlinks key
2957 (min (Hashtbl.find lowlinks key) (Hashtbl.find lowlinks succ))
2958 end
2959 else if Hashtbl.find_opt on_stack succ = Some true then
2960 Hashtbl.replace lowlinks key
2961 (min (Hashtbl.find lowlinks key) (Hashtbl.find indices succ)) )
2962 successors ;
2963 if Hashtbl.find lowlinks key = Hashtbl.find indices key then begin
2964 let rec pop_scc acc =
2965 match !stack with
2966 | [] ->
2967 acc
2968 | top :: rest ->
2969 stack := rest ;
2970 Hashtbl.replace on_stack top false ;
2971 if top = key then top :: acc else pop_scc (top :: acc)
2972 in
2973 let scc_keys = pop_scc [] in
2974 let scc_entries =
2975 List.filter_map (fun k -> List.assoc_opt k entry_map) scc_keys
2976 in
2977 if scc_entries <> [] then sccs := scc_entries :: !sccs
2978 end
2979 in
2980 List.iter
2981 (fun key -> if not (Hashtbl.mem indices key) then strongconnect key)
2982 all_keys ;
2983 let ordered_sccs = List.rev !sccs in
2984 (* generate each SCC *)
2985 List.iter
2986 (fun scc ->
2987 let inline_unions_in_scc =
2988 List.filter_map (function `InlineUnion x -> Some x | _ -> None) scc
2989 in
2990 let regular_defs_in_scc =
2991 List.filter_map (function `RegularDef x -> Some x | _ -> None) scc
2992 in
2993 if inline_unions_in_scc = [] then
2994 (* no inline unions - check if we still need mutual recursion *)
2995 begin match regular_defs_in_scc with
2996 | [] ->
2997 ()
2998 | [(nsid, def)] ->
2999 (* single def, generate normally *)
3000 gen_shared_single_def (nsid, def)
3001 | defs ->
3002 (* multiple defs in SCC - need mutual recursion *)
3003 (* filter to only object-like types that can be mutually recursive *)
3004 let obj_defs =
3005 List.filter
3006 (fun (_, def) ->
3007 match def.type_def with
3008 | Object _ | Record _ ->
3009 true
3010 | _ ->
3011 false )
3012 defs
3013 in
3014 let other_defs =
3015 List.filter
3016 (fun (_, def) ->
3017 match def.type_def with
3018 | Object _ | Record _ ->
3019 false
3020 | _ ->
3021 true )
3022 defs
3023 in
3024 (* generate non-object types first (they have their own converters) *)
3025 List.iter gen_shared_single_def other_defs ;
3026 (* generate object types as mutually recursive *)
3027 if obj_defs <> [] then begin
3028 (* register inline unions from all objects first *)
3029 List.iter
3030 (fun (nsid, def) ->
3031 match def.type_def with
3032 | Object spec ->
3033 register_shared_inline_unions nsid spec.properties
3034 | Record rspec ->
3035 register_shared_inline_unions nsid rspec.record.properties
3036 | _ ->
3037 () )
3038 obj_defs ;
3039 (* generate all type definitions *)
3040 List.iteri
3041 (fun i (nsid, def) ->
3042 let keyword = if i = 0 then "type" else "and" in
3043 match def.type_def with
3044 | Object spec ->
3045 gen_shared_object_type_only ~keyword nsid def.name spec
3046 | Record rspec ->
3047 gen_shared_object_type_only ~keyword nsid def.name
3048 rspec.record
3049 | _ ->
3050 () )
3051 obj_defs ;
3052 emit_newline out ;
3053 (* generate all _of_yojson converters as mutually recursive *)
3054 List.iteri
3055 (fun i (nsid, def) ->
3056 let of_keyword = if i = 0 then "let rec" else "and" in
3057 match def.type_def with
3058 | Object spec ->
3059 gen_shared_object_converters ~of_keyword
3060 ~to_keyword:"SKIP" nsid def.name spec
3061 | Record rspec ->
3062 gen_shared_object_converters ~of_keyword
3063 ~to_keyword:"SKIP" nsid def.name rspec.record
3064 | _ ->
3065 () )
3066 obj_defs ;
3067 (* generate all _to_yojson converters *)
3068 List.iter
3069 (fun (nsid, def) ->
3070 match def.type_def with
3071 | Object spec ->
3072 gen_shared_object_converters ~of_keyword:"SKIP"
3073 ~to_keyword:"and" nsid def.name spec
3074 | Record rspec ->
3075 gen_shared_object_converters ~of_keyword:"SKIP"
3076 ~to_keyword:"and" nsid def.name rspec.record
3077 | _ ->
3078 () )
3079 obj_defs
3080 end
3081 end
3082 else begin
3083 (* has inline unions - generate all types first, then all converters *)
3084 List.iter
3085 (fun (_nsid, name, refs, _spec) ->
3086 register_union_name out refs name ;
3087 mark_union_generated out name )
3088 inline_unions_in_scc ;
3089 let all_items =
3090 List.map (fun x -> `Inline x) inline_unions_in_scc
3091 @ List.map (fun x -> `Regular x) regular_defs_in_scc
3092 in
3093 let n = List.length all_items in
3094 if n = 1 then
3095 begin match List.hd all_items with
3096 | `Inline (nsid, name, refs, spec) ->
3097 gen_shared_inline_union_type_only nsid name refs spec ;
3098 emit_newline out ;
3099 gen_shared_inline_union_converters nsid name refs spec
3100 | `Regular (nsid, def) -> (
3101 match def.type_def with
3102 | Object spec ->
3103 register_shared_inline_unions nsid spec.properties ;
3104 gen_shared_object_type_only nsid def.name spec ;
3105 emit_newline out ;
3106 gen_shared_object_converters nsid def.name spec
3107 | Record rspec ->
3108 register_shared_inline_unions nsid rspec.record.properties ;
3109 gen_shared_object_type_only nsid def.name rspec.record ;
3110 emit_newline out ;
3111 gen_shared_object_converters nsid def.name rspec.record
3112 | _ ->
3113 gen_shared_single_def (nsid, def) )
3114 end
3115 else begin
3116 (* multiple items - generate as mutually recursive types *)
3117 List.iter
3118 (function
3119 | `Regular (nsid, def) -> (
3120 match def.type_def with
3121 | Object spec ->
3122 register_shared_inline_unions nsid spec.properties
3123 | Record rspec ->
3124 register_shared_inline_unions nsid rspec.record.properties
3125 | _ ->
3126 () )
3127 | `Inline _ ->
3128 () )
3129 all_items ;
3130 (* generate all type definitions *)
3131 List.iteri
3132 (fun i item ->
3133 let keyword = if i = 0 then "type" else "and" in
3134 match item with
3135 | `Inline (nsid, name, refs, spec) ->
3136 gen_shared_inline_union_type_only ~keyword nsid name refs spec
3137 | `Regular (nsid, def) -> (
3138 match def.type_def with
3139 | Object spec ->
3140 gen_shared_object_type_only ~keyword nsid def.name spec
3141 | Record rspec ->
3142 gen_shared_object_type_only ~keyword nsid def.name
3143 rspec.record
3144 | _ ->
3145 () ) )
3146 all_items ;
3147 emit_newline out ;
3148 (* generate all _of_yojson converters *)
3149 List.iteri
3150 (fun i item ->
3151 let of_keyword = if i = 0 then "let rec" else "and" in
3152 match item with
3153 | `Inline (nsid, name, refs, spec) ->
3154 gen_shared_inline_union_converters ~of_keyword
3155 ~to_keyword:"SKIP" nsid name refs spec
3156 | `Regular (nsid, def) -> (
3157 match def.type_def with
3158 | Object spec ->
3159 gen_shared_object_converters ~of_keyword ~to_keyword:"SKIP"
3160 nsid def.name spec
3161 | Record rspec ->
3162 gen_shared_object_converters ~of_keyword ~to_keyword:"SKIP"
3163 nsid def.name rspec.record
3164 | _ ->
3165 () ) )
3166 all_items ;
3167 (* generate all _to_yojson converters *)
3168 List.iteri
3169 (fun i item ->
3170 let to_keyword = "and" in
3171 ignore i ;
3172 match item with
3173 | `Inline (nsid, name, refs, spec) ->
3174 gen_shared_inline_union_converters ~of_keyword:"SKIP"
3175 ~to_keyword nsid name refs spec
3176 | `Regular (nsid, def) -> (
3177 match def.type_def with
3178 | Object spec ->
3179 gen_shared_object_converters ~of_keyword:"SKIP" ~to_keyword
3180 nsid def.name spec
3181 | Record rspec ->
3182 gen_shared_object_converters ~of_keyword:"SKIP" ~to_keyword
3183 nsid def.name rspec.record
3184 | _ ->
3185 () ) )
3186 all_items
3187 end
3188 end )
3189 ordered_sccs ;
3190 Emitter.contents out
3191
3192(* generate a re-export module that maps local names to shared module types *)
3193let gen_reexport_module ~shared_module_name ~all_merged_docs (doc : lexicon_doc)
3194 : string =
3195 let buf = Buffer.create 1024 in
3196 let emit s = Buffer.add_string buf s in
3197 let emitln s = Buffer.add_string buf s ; Buffer.add_char buf '\n' in
3198 (* detect collisions across all merged docs *)
3199 let all_defs =
3200 List.concat_map
3201 (fun d -> List.map (fun def -> (d.id, def)) d.defs)
3202 all_merged_docs
3203 in
3204 let name_counts = Hashtbl.create 64 in
3205 List.iter
3206 (fun (nsid, def) ->
3207 let existing = Hashtbl.find_opt name_counts def.name in
3208 match existing with
3209 | None ->
3210 Hashtbl.add name_counts def.name [nsid]
3211 | Some nsids when not (List.mem nsid nsids) ->
3212 Hashtbl.replace name_counts def.name (nsid :: nsids)
3213 | _ ->
3214 () )
3215 all_defs ;
3216 let colliding_names =
3217 Hashtbl.fold
3218 (fun name nsids acc -> if List.length nsids > 1 then name :: acc else acc)
3219 name_counts []
3220 in
3221 (* function to get shared type name (context-based for collisions) *)
3222 let get_shared_type_name nsid def_name =
3223 if List.mem def_name colliding_names then
3224 Naming.shared_type_name nsid def_name
3225 else Naming.type_name def_name
3226 in
3227 emitln (Printf.sprintf "(* re-exported from %s *)" shared_module_name) ;
3228 emitln "" ;
3229 List.iter
3230 (fun def ->
3231 let local_type_name = Naming.type_name def.name in
3232 let shared_type_name = get_shared_type_name doc.id def.name in
3233 match def.type_def with
3234 | Object _ | Record _ | Union _ ->
3235 emitln
3236 (Printf.sprintf "type %s = %s.%s" local_type_name shared_module_name
3237 shared_type_name ) ;
3238 emitln
3239 (Printf.sprintf "let %s_of_yojson = %s.%s_of_yojson" local_type_name
3240 shared_module_name shared_type_name ) ;
3241 emitln
3242 (Printf.sprintf "let %s_to_yojson = %s.%s_to_yojson" local_type_name
3243 shared_module_name shared_type_name ) ;
3244 emit "\n"
3245 | String spec when spec.known_values <> None ->
3246 emitln
3247 (Printf.sprintf "type %s = %s.%s" local_type_name shared_module_name
3248 shared_type_name ) ;
3249 emitln
3250 (Printf.sprintf "let %s_of_yojson = %s.%s_of_yojson" local_type_name
3251 shared_module_name shared_type_name ) ;
3252 emitln
3253 (Printf.sprintf "let %s_to_yojson = %s.%s_to_yojson" local_type_name
3254 shared_module_name shared_type_name ) ;
3255 emit "\n"
3256 | Array _ ->
3257 emitln
3258 (Printf.sprintf "type %s = %s.%s" local_type_name shared_module_name
3259 shared_type_name ) ;
3260 emitln
3261 (Printf.sprintf "let %s_of_yojson = %s.%s_of_yojson" local_type_name
3262 shared_module_name shared_type_name ) ;
3263 emitln
3264 (Printf.sprintf "let %s_to_yojson = %s.%s_to_yojson" local_type_name
3265 shared_module_name shared_type_name ) ;
3266 emit "\n"
3267 | Token _ ->
3268 emitln
3269 (Printf.sprintf "let %s = %s.%s" local_type_name shared_module_name
3270 shared_type_name ) ;
3271 emit "\n"
3272 | Query _ | Procedure _ ->
3273 let mod_name = Naming.def_module_name def.name in
3274 emitln
3275 (Printf.sprintf "module %s = %s.%s" mod_name shared_module_name
3276 mod_name ) ;
3277 emit "\n"
3278 | _ ->
3279 () )
3280 doc.defs ;
3281 Buffer.contents buf