futur.blue
objective categorical abstract machine language personal data server
hermes: Better names for union types
+47
-15
hermes-cli/lib/codegen.ml
+47
-15
hermes-cli/lib/codegen.ml
···
3
type output =
4
{ mutable imports: string list
5
; mutable generated_unions: string list
6
; buf: Buffer.t }
7
8
-
let make_output () = {imports= []; generated_unions= []; buf= Buffer.create 4096}
9
10
let add_import out module_name =
11
if not (List.mem module_name out.imports) then
···
16
out.generated_unions <- union_name :: out.generated_unions
17
18
let is_union_generated out union_name = List.mem union_name out.generated_unions
19
20
let emit out s = Buffer.add_string out.buf s
21
···
53
"object_todo"
54
| Ref {ref_; _} ->
55
gen_ref_type nsid out ref_
56
-
| Union {refs; _} ->
57
-
(* generate inline union reference *)
58
-
gen_union_type_name refs
59
| Token _ ->
60
"string"
61
| Unknown _ ->
···
97
(* external ref, use as-is *)
98
ref_str
99
100
-
(* collect inline union specs from object properties *)
101
-
let rec collect_inline_unions acc type_def =
102
match type_def with
103
| Union spec ->
104
-
(spec.refs, spec) :: acc
105
| Array {items; _} ->
106
-
collect_inline_unions acc items
107
| _ ->
108
acc
109
110
let collect_inline_unions_from_properties properties =
111
List.fold_left
112
-
(fun acc (_, (prop : property)) -> collect_inline_unions acc prop.type_def)
113
[] properties
114
115
(* generate inline union types that appear in object properties *)
116
let gen_inline_unions nsid out properties =
117
let inline_unions = collect_inline_unions_from_properties properties in
118
List.iter
119
-
(fun (refs, spec) ->
120
-
let type_name = Naming.union_type_name refs in
121
(* skip if already generated *)
122
if not (is_union_generated out type_name) then begin
123
mark_union_generated out type_name ;
···
162
let full_type_uri = gen_type_uri nsid ref_str in
163
let payload_type = gen_ref_type nsid out ref_str in
164
emitln out (Printf.sprintf " | %s v ->" variant_name) ;
165
-
emitln out (Printf.sprintf " (match %s_to_yojson v with" payload_type) ;
166
-
emitln out (Printf.sprintf " | `Assoc fields -> `Assoc ((\"$type\", `String \"%s\") :: fields)" full_type_uri) ;
167
emitln out " | other -> other)" )
168
refs ;
169
if not is_closed then emitln out " | Unknown j -> j" ;
···
253
let full_type_uri = gen_type_uri nsid ref_str in
254
let payload_type = gen_ref_type nsid out ref_str in
255
emitln out (Printf.sprintf " | %s v ->" variant_name) ;
256
-
emitln out (Printf.sprintf " (match %s_to_yojson v with" payload_type) ;
257
-
emitln out (Printf.sprintf " | `Assoc fields -> `Assoc ((\"$type\", `String \"%s\") :: fields)" full_type_uri) ;
258
emitln out " | other -> other)" )
259
spec.refs ;
260
if not is_closed then emitln out " | Unknown j -> j" ;
···
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 }
8
9
+
let make_output () =
10
+
{imports= []; generated_unions= []; union_names= []; buf= Buffer.create 4096}
11
12
let add_import out module_name =
13
if not (List.mem module_name out.imports) then
···
18
out.generated_unions <- union_name :: out.generated_unions
19
20
let is_union_generated out union_name = List.mem union_name out.generated_unions
21
+
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
27
+
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
32
33
let emit out s = Buffer.add_string out.buf s
34
···
66
"object_todo"
67
| Ref {ref_; _} ->
68
gen_ref_type nsid out ref_
69
+
| Union {refs; _} -> (
70
+
(* generate inline union reference, using registered name if available *)
71
+
match lookup_union_name out refs with
72
+
| Some name ->
73
+
name
74
+
| None ->
75
+
gen_union_type_name refs )
76
| Token _ ->
77
"string"
78
| Unknown _ ->
···
114
(* external ref, use as-is *)
115
ref_str
116
117
+
(* collect inline union specs from object properties with context *)
118
+
let rec collect_inline_unions_with_context context acc type_def =
119
match type_def with
120
| Union spec ->
121
+
(context, spec.refs, spec) :: acc
122
| Array {items; _} ->
123
+
(* for array items, append _item to context *)
124
+
collect_inline_unions_with_context (context ^ "_item") acc items
125
| _ ->
126
acc
127
128
let collect_inline_unions_from_properties properties =
129
List.fold_left
130
+
(fun acc (prop_name, (prop : property)) ->
131
+
collect_inline_unions_with_context prop_name acc prop.type_def )
132
[] properties
133
134
(* generate inline union types that appear in object properties *)
135
let gen_inline_unions nsid out properties =
136
let inline_unions = collect_inline_unions_from_properties properties in
137
List.iter
138
+
(fun (context, refs, spec) ->
139
+
(* register and use context-based name *)
140
+
let context_name = Naming.type_name context in
141
+
register_union_name out refs context_name ;
142
+
let type_name = context_name in
143
(* skip if already generated *)
144
if not (is_union_generated out type_name) then begin
145
mark_union_generated out type_name ;
···
184
let full_type_uri = gen_type_uri nsid ref_str in
185
let payload_type = gen_ref_type nsid out ref_str in
186
emitln out (Printf.sprintf " | %s v ->" variant_name) ;
187
+
emitln out
188
+
(Printf.sprintf " (match %s_to_yojson v with" payload_type) ;
189
+
emitln out
190
+
(Printf.sprintf
191
+
" | `Assoc fields -> `Assoc ((\"$type\", `String \
192
+
\"%s\") :: fields)"
193
+
full_type_uri ) ;
194
emitln out " | other -> other)" )
195
refs ;
196
if not is_closed then emitln out " | Unknown j -> j" ;
···
280
let full_type_uri = gen_type_uri nsid ref_str in
281
let payload_type = gen_ref_type nsid out ref_str in
282
emitln out (Printf.sprintf " | %s v ->" variant_name) ;
283
+
emitln out
284
+
(Printf.sprintf " (match %s_to_yojson v with" payload_type) ;
285
+
emitln out
286
+
(Printf.sprintf
287
+
" | `Assoc fields -> `Assoc ((\"$type\", `String \"%s\") :: \
288
+
fields)"
289
+
full_type_uri ) ;
290
emitln out " | other -> other)" )
291
spec.refs ;
292
if not is_closed then emitln out " | Unknown j -> j" ;