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