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