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
3
type output =
4
4
{ mutable imports: string list
5
5
; mutable generated_unions: string list
6
+
; mutable union_names: (string list * string) list (* refs -> context name *)
6
7
; buf: Buffer.t }
7
8
8
-
let make_output () = {imports= []; generated_unions= []; buf= Buffer.create 4096}
9
+
let make_output () =
10
+
{imports= []; generated_unions= []; union_names= []; buf= Buffer.create 4096}
9
11
10
12
let add_import out module_name =
11
13
if not (List.mem module_name out.imports) then
···
16
18
out.generated_unions <- union_name :: out.generated_unions
17
19
18
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
19
32
20
33
let emit out s = Buffer.add_string out.buf s
21
34
···
53
66
"object_todo"
54
67
| Ref {ref_; _} ->
55
68
gen_ref_type nsid out ref_
56
-
| Union {refs; _} ->
57
-
(* generate inline union reference *)
58
-
gen_union_type_name refs
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 )
59
76
| Token _ ->
60
77
"string"
61
78
| Unknown _ ->
···
97
114
(* external ref, use as-is *)
98
115
ref_str
99
116
100
-
(* collect inline union specs from object properties *)
101
-
let rec collect_inline_unions acc type_def =
117
+
(* collect inline union specs from object properties with context *)
118
+
let rec collect_inline_unions_with_context context acc type_def =
102
119
match type_def with
103
120
| Union spec ->
104
-
(spec.refs, spec) :: acc
121
+
(context, spec.refs, spec) :: acc
105
122
| Array {items; _} ->
106
-
collect_inline_unions acc items
123
+
(* for array items, append _item to context *)
124
+
collect_inline_unions_with_context (context ^ "_item") acc items
107
125
| _ ->
108
126
acc
109
127
110
128
let collect_inline_unions_from_properties properties =
111
129
List.fold_left
112
-
(fun acc (_, (prop : property)) -> collect_inline_unions acc prop.type_def)
130
+
(fun acc (prop_name, (prop : property)) ->
131
+
collect_inline_unions_with_context prop_name acc prop.type_def )
113
132
[] properties
114
133
115
134
(* generate inline union types that appear in object properties *)
116
135
let gen_inline_unions nsid out properties =
117
136
let inline_unions = collect_inline_unions_from_properties properties in
118
137
List.iter
119
-
(fun (refs, spec) ->
120
-
let type_name = Naming.union_type_name refs in
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
121
143
(* skip if already generated *)
122
144
if not (is_union_generated out type_name) then begin
123
145
mark_union_generated out type_name ;
···
162
184
let full_type_uri = gen_type_uri nsid ref_str in
163
185
let payload_type = gen_ref_type nsid out ref_str in
164
186
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) ;
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 ) ;
167
194
emitln out " | other -> other)" )
168
195
refs ;
169
196
if not is_closed then emitln out " | Unknown j -> j" ;
···
253
280
let full_type_uri = gen_type_uri nsid ref_str in
254
281
let payload_type = gen_ref_type nsid out ref_str in
255
282
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) ;
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 ) ;
258
290
emitln out " | other -> other)" )
259
291
spec.refs ;
260
292
if not is_closed then emitln out " | Unknown j -> j" ;