anil.recoil.org
OpenAPI generator for OCaml with Requests/Eio/Jsont
1(** Code generation from OpenAPI specifications.
2
3 This module generates OCaml code from parsed OpenAPI specs:
4 - Nested module structure grouped by common schema prefixes
5 - Abstract types with accessor and constructor functions
6 - Client functions placed in relevant type modules
7 - Proper Eio error handling with context
8*)
9
10module Spec = Openapi_spec
11
12(** {1 Name Conversion} *)
13
14module Name = struct
15 module StringSet = Set.Make(String)
16
17 let ocaml_keywords = StringSet.of_list [
18 "and"; "as"; "assert"; "asr"; "begin"; "class"; "constraint"; "do"; "done";
19 "downto"; "else"; "end"; "exception"; "external"; "false"; "for"; "fun";
20 "function"; "functor"; "if"; "in"; "include"; "inherit"; "initializer";
21 "land"; "lazy"; "let"; "lor"; "lsl"; "lsr"; "lxor"; "match"; "method";
22 "mod"; "module"; "mutable"; "new"; "nonrec"; "object"; "of"; "open"; "or";
23 "private"; "rec"; "sig"; "struct"; "then"; "to"; "true"; "try"; "type";
24 "val"; "virtual"; "when"; "while"; "with"
25 ]
26
27 let escape_keyword s =
28 if StringSet.mem s ocaml_keywords then s ^ "_" else s
29
30 let to_snake_case s =
31 let buf = Buffer.create (String.length s) in
32 let prev_upper = ref false in
33 String.iteri (fun i c ->
34 match c with
35 | 'A'..'Z' ->
36 if i > 0 && not !prev_upper then Buffer.add_char buf '_';
37 Buffer.add_char buf (Char.lowercase_ascii c);
38 prev_upper := true
39 | 'a'..'z' | '0'..'9' | '_' ->
40 Buffer.add_char buf c;
41 prev_upper := false
42 | '-' | ' ' | '.' | '/' ->
43 Buffer.add_char buf '_';
44 prev_upper := false
45 | _ ->
46 prev_upper := false
47 ) s;
48 escape_keyword (Buffer.contents buf)
49
50 let to_module_name s =
51 let snake = to_snake_case s in
52 let parts = String.split_on_char '_' snake in
53 String.concat "" (List.map String.capitalize_ascii parts)
54
55 let to_type_name s = String.lowercase_ascii (to_snake_case s)
56
57 let to_variant_name s = String.capitalize_ascii (to_snake_case s)
58
59 (** Split a schema name into prefix and suffix for nested modules.
60 E.g., "AlbumResponseDto" -> ("Album", "ResponseDto") *)
61 let split_schema_name (name : string) : string * string =
62 (* Common suffixes to look for *)
63 let suffixes = [
64 "ResponseDto"; "RequestDto"; "CreateDto"; "UpdateDto"; "Dto";
65 "Response"; "Request"; "Create"; "Update"; "Config"; "Info";
66 "Status"; "Type"; "Entity"; "Item"; "Entry"; "Data"; "Result"
67 ] in
68 let found = List.find_opt (fun suffix ->
69 String.length name > String.length suffix &&
70 String.ends_with ~suffix name
71 ) suffixes in
72 match found with
73 | Some suffix ->
74 let prefix_len = String.length name - String.length suffix in
75 let prefix = String.sub name 0 prefix_len in
76 if prefix = "" then (name, "T")
77 else (prefix, suffix)
78 | None ->
79 (* No known suffix, use as-is with submodule T *)
80 (name, "T")
81
82 let operation_name ~(method_ : string) ~(path : string) ~(operation_id : string option) =
83 match operation_id with
84 | Some id -> to_snake_case id
85 | None ->
86 let method_name = String.lowercase_ascii method_ in
87 let path_parts = String.split_on_char '/' path
88 |> List.filter (fun s -> s <> "" && not (String.length s > 0 && s.[0] = '{'))
89 in
90 let path_name = String.concat "_" (List.map to_snake_case path_parts) in
91 method_name ^ "_" ^ path_name
92end
93
94(** {1 OCamldoc Helpers} *)
95
96let escape_doc s =
97 let s = String.concat "\\}" (String.split_on_char '}' s) in
98 String.concat "\\{" (String.split_on_char '{' s)
99
100let format_doc ?(indent=0) description =
101 let prefix = String.make indent ' ' in
102 match description with
103 | None | Some "" -> ""
104 | Some desc -> Printf.sprintf "%s(** %s *)\n" prefix (escape_doc desc)
105
106let format_doc_block ?(indent=0) ~summary ?description () =
107 let prefix = String.make indent ' ' in
108 match summary, description with
109 | None, None -> ""
110 | Some s, None -> Printf.sprintf "%s(** %s *)\n" prefix (escape_doc s)
111 | None, Some d -> Printf.sprintf "%s(** %s *)\n" prefix (escape_doc d)
112 | Some s, Some d ->
113 Printf.sprintf "%s(** %s\n\n%s %s *)\n" prefix (escape_doc s) prefix (escape_doc d)
114
115let format_param_doc name description =
116 match description with
117 | None | Some "" -> ""
118 | Some d -> Printf.sprintf " @param %s %s\n" name (escape_doc d)
119
120(** {1 JSON Helpers} *)
121
122let json_string = function
123 | Jsont.String (s, _) -> Some s
124 | _ -> None
125
126let json_object = function
127 | Jsont.Object (mems, _) -> Some mems
128 | _ -> None
129
130let get_ref json =
131 Option.bind (json_object json) (fun mems ->
132 List.find_map (fun ((n, _), v) ->
133 if n = "$ref" then json_string v else None
134 ) mems)
135
136let get_member name json =
137 Option.bind (json_object json) (fun mems ->
138 List.find_map (fun ((n, _), v) ->
139 if n = name then Some v else None
140 ) mems)
141
142let get_string_member name json =
143 Option.bind (get_member name json) json_string
144
145(** {1 Schema Analysis} *)
146
147let schema_name_from_ref (ref_ : string) : string option =
148 match String.split_on_char '/' ref_ with
149 | ["#"; "components"; "schemas"; name] -> Some name
150 | _ -> None
151
152(** Resolve a schema reference to its definition *)
153let resolve_schema_ref ~(components : Spec.components option) (ref_str : string) : Spec.schema option =
154 match schema_name_from_ref ref_str with
155 | None -> None
156 | Some name ->
157 match components with
158 | None -> None
159 | Some comps ->
160 List.find_map (fun (n, s_or_ref) ->
161 if n = name then
162 match s_or_ref with
163 | Spec.Value s -> Some s
164 | Spec.Ref _ -> None (* Nested refs not supported *)
165 else None
166 ) comps.schemas
167
168(** Flatten allOf composition by merging properties from all schemas *)
169let rec flatten_all_of ~(components : Spec.components option) (schemas : Jsont.json list) : (string * Jsont.json) list * string list =
170 List.fold_left (fun (props, reqs) json ->
171 match get_ref json with
172 | Some ref_str ->
173 (* Resolve the reference and get its properties *)
174 (match resolve_schema_ref ~components ref_str with
175 | Some schema ->
176 let (nested_props, nested_reqs) =
177 match schema.all_of with
178 | Some all_of -> flatten_all_of ~components all_of
179 | None -> (schema.properties, schema.required)
180 in
181 (props @ nested_props, reqs @ nested_reqs)
182 | None -> (props, reqs))
183 | None ->
184 (* Inline schema - get properties directly *)
185 let inline_props = match get_member "properties" json with
186 | Some (Jsont.Object (mems, _)) ->
187 List.map (fun ((n, _), v) -> (n, v)) mems
188 | _ -> []
189 in
190 let inline_reqs = match get_member "required" json with
191 | Some (Jsont.Array (items, _)) ->
192 List.filter_map (function Jsont.String (s, _) -> Some s | _ -> None) items
193 | _ -> []
194 in
195 (props @ inline_props, reqs @ inline_reqs)
196 ) ([], []) schemas
197
198(** Expand a schema by resolving allOf composition *)
199let expand_schema ~(components : Spec.components option) (schema : Spec.schema) : Spec.schema =
200 match schema.all_of with
201 | None -> schema
202 | Some all_of_jsons ->
203 let (all_props, all_reqs) = flatten_all_of ~components all_of_jsons in
204 (* Merge with any direct properties on the schema *)
205 let merged_props = schema.properties @ all_props in
206 let merged_reqs = schema.required @ all_reqs in
207 (* Deduplicate by property name, keeping later definitions *)
208 let seen = Hashtbl.create 32 in
209 let deduped_props = List.filter (fun (name, _) ->
210 if Hashtbl.mem seen name then false
211 else (Hashtbl.add seen name (); true)
212 ) (List.rev merged_props) |> List.rev in
213 let deduped_reqs = List.sort_uniq String.compare merged_reqs in
214 { schema with properties = deduped_props; required = deduped_reqs; all_of = None }
215
216let rec find_refs_in_json (json : Jsont.json) : string list =
217 match json with
218 | Jsont.Object (mems, _) ->
219 (match List.find_map (fun ((n, _), v) ->
220 if n = "$ref" then json_string v else None) mems with
221 | Some ref_ -> Option.to_list (schema_name_from_ref ref_)
222 | None -> List.concat_map (fun (_, v) -> find_refs_in_json v) mems)
223 | Jsont.Array (items, _) -> List.concat_map find_refs_in_json items
224 | _ -> []
225
226let find_schema_dependencies (schema : Spec.schema) : string list =
227 let from_properties = List.concat_map (fun (_, json) -> find_refs_in_json json) schema.properties in
228 let refs_from_list = Option.fold ~none:[] ~some:(List.concat_map find_refs_in_json) in
229 let from_items = Option.fold ~none:[] ~some:find_refs_in_json schema.items in
230 List.sort_uniq String.compare
231 (from_properties @ from_items @ refs_from_list schema.all_of
232 @ refs_from_list schema.one_of @ refs_from_list schema.any_of)
233
234(** {1 Module Tree Structure} *)
235
236module StringMap = Map.Make(String)
237module StringSet = Set.Make(String)
238
239(** {1 Forward Reference Tracking}
240
241 Track which modules come after the current module in the sorted order.
242 This is used to detect forward references and replace them with Jsont.json. *)
243
244let forward_refs : StringSet.t ref = ref StringSet.empty
245
246let set_forward_refs mods = forward_refs := StringSet.of_list mods
247
248let is_forward_ref module_name =
249 StringSet.mem module_name !forward_refs
250
251(** {1 Topological Sort} *)
252
253(** Kahn's algorithm for topological sorting.
254 Returns nodes in dependency order (dependencies first).
255 Self-dependencies are ignored (they don't affect ordering). *)
256let topological_sort (nodes : string list) (deps : string -> string list) : string list =
257 (* Build adjacency list and in-degree map *)
258 let nodes_set = StringSet.of_list nodes in
259 let in_degree = List.fold_left (fun m node ->
260 StringMap.add node 0 m
261 ) StringMap.empty nodes in
262 let adj = List.fold_left (fun m node ->
263 StringMap.add node [] m
264 ) StringMap.empty nodes in
265 (* Add edges: if A depends on B, add edge B -> A
266 Ignore self-dependencies (node depending on itself) *)
267 let (in_degree, adj) = List.fold_left (fun (in_degree, adj) node ->
268 let node_deps = deps node
269 |> List.filter (fun d -> StringSet.mem d nodes_set && d <> node) in
270 let in_degree = StringMap.add node (List.length node_deps) in_degree in
271 let adj = List.fold_left (fun adj dep ->
272 let existing = Option.value ~default:[] (StringMap.find_opt dep adj) in
273 StringMap.add dep (node :: existing) adj
274 ) adj node_deps in
275 (in_degree, adj)
276 ) (in_degree, adj) nodes in
277 (* Start with nodes that have no dependencies *)
278 let queue = List.filter (fun n ->
279 StringMap.find n in_degree = 0
280 ) nodes in
281 let rec process queue in_degree result processed =
282 match queue with
283 | [] ->
284 (* Check for remaining nodes (cycles) - break cycles by picking one node *)
285 let remaining = List.filter (fun n ->
286 not (StringSet.mem n processed) && StringMap.find n in_degree > 0
287 ) nodes in
288 (match remaining with
289 | [] -> List.rev result
290 | node :: _ ->
291 (* Pick a node from the cycle and add it, then continue *)
292 let result = node :: result in
293 let processed = StringSet.add node processed in
294 let dependents = Option.value ~default:[] (StringMap.find_opt node adj) in
295 let (queue', in_degree) = List.fold_left (fun (q, deg) dep ->
296 if StringSet.mem dep processed then (q, deg)
297 else
298 let new_deg = StringMap.find dep deg - 1 in
299 let deg = StringMap.add dep new_deg deg in
300 if new_deg = 0 then (dep :: q, deg) else (q, deg)
301 ) ([], in_degree) dependents in
302 process queue' in_degree result processed)
303 | node :: rest ->
304 let result = node :: result in
305 let processed = StringSet.add node processed in
306 let dependents = Option.value ~default:[] (StringMap.find_opt node adj) in
307 let (queue', in_degree) = List.fold_left (fun (q, deg) dep ->
308 if StringSet.mem dep processed then (q, deg)
309 else
310 let new_deg = StringMap.find dep deg - 1 in
311 let deg = StringMap.add dep new_deg deg in
312 if new_deg = 0 then (dep :: q, deg) else (q, deg)
313 ) (rest, in_degree) dependents in
314 process queue' in_degree result processed
315 in
316 process queue in_degree [] StringSet.empty
317
318(** Validation constraints extracted from JSON Schema *)
319type validation_constraints = {
320 minimum : float option;
321 maximum : float option;
322 exclusive_minimum : float option;
323 exclusive_maximum : float option;
324 min_length : int option;
325 max_length : int option;
326 pattern : string option;
327 min_items : int option;
328 max_items : int option;
329 unique_items : bool;
330}
331
332let empty_constraints = {
333 minimum = None; maximum = None;
334 exclusive_minimum = None; exclusive_maximum = None;
335 min_length = None; max_length = None; pattern = None;
336 min_items = None; max_items = None; unique_items = false;
337}
338
339let has_constraints c =
340 c.minimum <> None || c.maximum <> None ||
341 c.exclusive_minimum <> None || c.exclusive_maximum <> None ||
342 c.min_length <> None || c.max_length <> None || c.pattern <> None ||
343 c.min_items <> None || c.max_items <> None || c.unique_items
344
345(** Inline union variant for field-level oneOf/anyOf *)
346type inline_union_variant =
347 | Ref_variant of string * string (** variant_name, schema_ref *)
348 | Prim_variant of string * string (** variant_name, primitive_type (string, int, etc.) *)
349
350(** Field-level union info *)
351type field_union_info = {
352 field_variants : inline_union_variant list;
353 field_union_style : [ `OneOf | `AnyOf ];
354}
355
356type field_info = {
357 ocaml_name : string;
358 json_name : string;
359 ocaml_type : string;
360 base_type : string;
361 is_optional : bool;
362 is_required : bool;
363 is_nullable : bool; (** JSON schema nullable: true *)
364 description : string option;
365 constraints : validation_constraints; (** Validation constraints *)
366 field_union : field_union_info option; (** Inline union type info *)
367 default_value : string option; (** OCaml literal for default value *)
368}
369
370(** Union variant info for oneOf/anyOf schemas *)
371type union_variant = {
372 variant_name : string; (** OCaml constructor name: "Crop" *)
373 schema_ref : string; (** Schema name: "AssetEditActionCrop" *)
374}
375
376(** Union type info for oneOf/anyOf schemas *)
377type union_info = {
378 discriminator_field : string option; (** e.g., "type" or "action" *)
379 discriminator_mapping : (string * string) list; (** tag -> schema_ref *)
380 variants : union_variant list;
381 style : [ `OneOf | `AnyOf ];
382}
383
384type schema_info = {
385 original_name : string;
386 prefix : string;
387 suffix : string;
388 schema : Spec.schema;
389 fields : field_info list;
390 is_enum : bool;
391 enum_variants : (string * string) list; (* ocaml_name, json_value *)
392 description : string option;
393 is_recursive : bool; (* true if schema references itself *)
394 is_union : bool; (** true if this is a oneOf/anyOf schema *)
395 union_info : union_info option;
396}
397
398(** Error response info for typed error handling *)
399type error_response = {
400 status_code : string; (** "400", "404", "5XX", "default" *)
401 schema_ref : string option; (** Reference to error schema if present *)
402 error_description : string;
403}
404
405type operation_info = {
406 func_name : string;
407 operation_id : string option;
408 summary : string option;
409 description : string option;
410 tags : string list;
411 path : string;
412 method_ : string;
413 path_params : (string * string * string option * bool) list; (* ocaml, json, desc, required *)
414 query_params : (string * string * string option * bool) list;
415 body_schema_ref : string option;
416 response_schema_ref : string option;
417 error_responses : error_response list; (** Typed error responses *)
418}
419
420type module_node = {
421 name : string;
422 schemas : schema_info list;
423 operations : operation_info list;
424 dependencies : StringSet.t; (* Other prefix modules this depends on *)
425 children : module_node StringMap.t;
426}
427
428let empty_node name = { name; schemas = []; operations = []; dependencies = StringSet.empty; children = StringMap.empty }
429
430(** {1 Type Resolution} *)
431
432(** Extract validation constraints from a JSON schema *)
433let extract_constraints (json : Jsont.json) : validation_constraints =
434 let get_float name =
435 match get_member name json with
436 | Some (Jsont.Number (f, _)) -> Some f
437 | _ -> None
438 in
439 let get_int name =
440 match get_member name json with
441 | Some (Jsont.Number (f, _)) -> Some (int_of_float f)
442 | _ -> None
443 in
444 let get_bool name =
445 match get_member name json with
446 | Some (Jsont.Bool (b, _)) -> b
447 | _ -> false
448 in
449 {
450 minimum = get_float "minimum";
451 maximum = get_float "maximum";
452 exclusive_minimum = get_float "exclusiveMinimum";
453 exclusive_maximum = get_float "exclusiveMaximum";
454 min_length = get_int "minLength";
455 max_length = get_int "maxLength";
456 pattern = get_string_member "pattern" json;
457 min_items = get_int "minItems";
458 max_items = get_int "maxItems";
459 unique_items = get_bool "uniqueItems";
460 }
461
462(** Extract and convert a default value to an OCaml literal.
463 Returns None if no default or if the default can't be represented. *)
464let extract_default_value (json : Jsont.json) (base_type : string) : string option =
465 match get_member "default" json with
466 | None -> None
467 | Some default_json ->
468 match default_json, base_type with
469 | Jsont.Bool (b, _), "bool" ->
470 Some (if b then "true" else "false")
471 | Jsont.Number (f, _), "int" ->
472 Some (Printf.sprintf "%d" (int_of_float f))
473 | Jsont.Number (f, _), "int32" ->
474 Some (Printf.sprintf "%ldl" (Int32.of_float f))
475 | Jsont.Number (f, _), "int64" ->
476 Some (Printf.sprintf "%LdL" (Int64.of_float f))
477 | Jsont.Number (f, _), "float" ->
478 let s = Printf.sprintf "%g" f in
479 (* Ensure it's a valid float literal *)
480 if String.contains s '.' || String.contains s 'e' then Some s
481 else Some (s ^ ".")
482 | Jsont.String (s, _), "string" ->
483 Some (Printf.sprintf "%S" s)
484 | Jsont.String (s, _), t when String.contains t '.' ->
485 (* Enum type reference like "AlbumUserRole.T.t" - use backtick variant *)
486 Some (Printf.sprintf "`%s" (Name.to_variant_name s))
487 | Jsont.Null _, _ ->
488 Some "None" (* For nullable fields *)
489 | Jsont.Array ([], _), t when String.ends_with ~suffix:" list" t ->
490 Some "[]"
491 | _ -> None (* Complex defaults not yet supported *)
492
493(** Analyze inline oneOf/anyOf for field-level unions *)
494let analyze_field_union (json : Jsont.json) : field_union_info option =
495 let extract_variants style items =
496 let variants = List.filter_map (fun item ->
497 match get_ref item with
498 | Some ref_ ->
499 schema_name_from_ref ref_ |> Option.map (fun schema_ref ->
500 let variant_name = Name.to_module_name schema_ref in
501 Ref_variant (variant_name, schema_ref))
502 | None ->
503 (* Check for primitive type *)
504 match get_string_member "type" item with
505 | Some "string" -> Some (Prim_variant ("String", "string"))
506 | Some "integer" -> Some (Prim_variant ("Int", "int"))
507 | Some "number" -> Some (Prim_variant ("Float", "float"))
508 | Some "boolean" -> Some (Prim_variant ("Bool", "bool"))
509 | Some "null" -> Some (Prim_variant ("Null", "unit"))
510 | _ -> None
511 ) items in
512 if List.length variants >= 2 then
513 Some { field_variants = variants; field_union_style = style }
514 else
515 None
516 in
517 match get_member "oneOf" json with
518 | Some (Jsont.Array (items, _)) -> extract_variants `OneOf items
519 | _ ->
520 match get_member "anyOf" json with
521 | Some (Jsont.Array (items, _)) -> extract_variants `AnyOf items
522 | _ -> None
523
524(** Check if a field union has any schema references (which may have ordering issues) *)
525let field_union_has_refs (union : field_union_info) : bool =
526 List.exists (fun v ->
527 match v with
528 | Ref_variant _ -> true
529 | Prim_variant _ -> false
530 ) union.field_variants
531
532(** Generate polymorphic variant type string for inline union.
533 For unions with only primitive types, generate proper polymorphic variants.
534 For unions with schema references, fall back to Jsont.json to avoid module ordering issues. *)
535let poly_variant_type_of_union (union : field_union_info) : string =
536 (* If any variant references a schema, we can't reliably generate types
537 at analysis time due to module ordering. Use Jsont.json instead. *)
538 if field_union_has_refs union then
539 "Jsont.json"
540 else
541 let variants = List.map (fun v ->
542 match v with
543 | Ref_variant (name, schema_ref) ->
544 let prefix, suffix = Name.split_schema_name schema_ref in
545 Printf.sprintf "`%s of %s.%s.t" name (Name.to_module_name prefix) (Name.to_module_name suffix)
546 | Prim_variant (name, prim_type) ->
547 Printf.sprintf "`%s of %s" name prim_type
548 ) union.field_variants in
549 Printf.sprintf "[ %s ]" (String.concat " | " variants)
550
551(** Type resolution result with full info *)
552type type_resolution = {
553 resolved_type : string;
554 resolved_nullable : bool;
555 resolved_constraints : validation_constraints;
556 resolved_union : field_union_info option;
557}
558
559let rec resolve_type_full (json : Jsont.json) : type_resolution =
560 (* Check if the schema is nullable *)
561 let is_nullable = match get_member "nullable" json with
562 | Some (Jsont.Bool (b, _)) -> b
563 | _ -> false
564 in
565 let constraints = extract_constraints json in
566
567 (* Check for oneOf/anyOf first *)
568 match analyze_field_union json with
569 | Some union ->
570 let poly_type = poly_variant_type_of_union union in
571 { resolved_type = poly_type; resolved_nullable = is_nullable;
572 resolved_constraints = constraints; resolved_union = Some union }
573 | None ->
574 match get_ref json with
575 | Some ref_ ->
576 (match schema_name_from_ref ref_ with
577 | Some name ->
578 let prefix, suffix = Name.split_schema_name name in
579 { resolved_type = Printf.sprintf "%s.%s.t" (Name.to_module_name prefix) (Name.to_module_name suffix);
580 resolved_nullable = is_nullable; resolved_constraints = constraints; resolved_union = None }
581 | None ->
582 { resolved_type = "Jsont.json"; resolved_nullable = is_nullable;
583 resolved_constraints = constraints; resolved_union = None })
584 | None ->
585 (* Check for allOf with a single $ref - common pattern for type aliasing *)
586 (match get_member "allOf" json with
587 | Some (Jsont.Array ([item], _)) ->
588 (* Single item allOf - try to resolve it *)
589 resolve_type_full item
590 | Some (Jsont.Array (items, _)) when List.length items > 0 ->
591 (* Multiple allOf items - try to find a $ref among them *)
592 (match List.find_map (fun item ->
593 match get_ref item with
594 | Some ref_ -> schema_name_from_ref ref_
595 | None -> None
596 ) items with
597 | Some name ->
598 let prefix, suffix = Name.split_schema_name name in
599 { resolved_type = Printf.sprintf "%s.%s.t" (Name.to_module_name prefix) (Name.to_module_name suffix);
600 resolved_nullable = is_nullable; resolved_constraints = constraints; resolved_union = None }
601 | None ->
602 { resolved_type = "Jsont.json"; resolved_nullable = is_nullable;
603 resolved_constraints = constraints; resolved_union = None })
604 | _ ->
605 let resolved_type = match get_string_member "type" json with
606 | Some "string" ->
607 (match get_string_member "format" json with
608 | Some "date-time" -> "Ptime.t"
609 | _ -> "string")
610 | Some "integer" ->
611 (match get_string_member "format" json with
612 | Some "int64" -> "int64"
613 | Some "int32" -> "int32"
614 | _ -> "int")
615 | Some "number" -> "float"
616 | Some "boolean" -> "bool"
617 | Some "array" ->
618 (match get_member "items" json with
619 | Some items ->
620 let elem = resolve_type_full items in
621 elem.resolved_type ^ " list"
622 | None -> "Jsont.json list")
623 | Some "object" -> "Jsont.json"
624 | _ -> "Jsont.json"
625 in
626 { resolved_type; resolved_nullable = is_nullable;
627 resolved_constraints = constraints; resolved_union = None })
628
629(** Simple type resolution for backward compatibility *)
630let rec type_of_json_schema (json : Jsont.json) : string * bool =
631 let result = resolve_type_full json in
632 (result.resolved_type, result.resolved_nullable)
633
634let rec jsont_of_base_type = function
635 | "string" -> "Jsont.string"
636 | "int" -> "Jsont.int"
637 | "int32" -> "Jsont.int32"
638 | "int64" -> "Jsont.int64"
639 | "float" -> "Jsont.number"
640 | "bool" -> "Jsont.bool"
641 | "Ptime.t" -> "Openapi.Runtime.ptime_jsont"
642 | "Jsont.json" -> "Jsont.json"
643 | s when String.ends_with ~suffix:" list" s ->
644 let elem = String.sub s 0 (String.length s - 5) in
645 Printf.sprintf "(Jsont.list %s)" (jsont_of_base_type elem)
646 | s when String.ends_with ~suffix:".t" s ->
647 let module_path = String.sub s 0 (String.length s - 2) in
648 module_path ^ ".jsont"
649 | _ -> "Jsont.json"
650
651(** Generate a nullable codec wrapper for types that need to handle explicit JSON nulls *)
652let nullable_jsont_of_base_type = function
653 | "string" -> "Openapi.Runtime.nullable_string"
654 | "int" -> "Openapi.Runtime.nullable_int"
655 | "float" -> "Openapi.Runtime.nullable_float"
656 | "bool" -> "Openapi.Runtime.nullable_bool"
657 | "Ptime.t" -> "Openapi.Runtime.nullable_ptime"
658 | base_type ->
659 (* For other types, wrap with nullable_any *)
660 Printf.sprintf "(Openapi.Runtime.nullable_any %s)" (jsont_of_base_type base_type)
661
662(** Format a float value for OCaml code, wrapping negative numbers in parentheses
663 and ensuring the value is formatted as a float (with decimal point) *)
664let format_float_arg (name : string) (v : float) : string =
665 (* Format as float with at least one decimal place *)
666 let str = Printf.sprintf "%g" v in
667 let float_str =
668 if String.contains str '.' || String.contains str 'e' || String.contains str 'E' then
669 str
670 else
671 str ^ "."
672 in
673 if v < 0.0 then
674 Printf.sprintf "~%s:(%s)" name float_str
675 else
676 Printf.sprintf "~%s:%s" name float_str
677
678(** Generate a validated codec wrapper based on constraints *)
679let validated_jsont (constraints : validation_constraints) (base_codec : string) (base_type : string) : string =
680 if not (has_constraints constraints) then
681 base_codec
682 else
683 match base_type with
684 | "string" ->
685 let args = List.filter_map Fun.id [
686 Option.map (fun v -> Printf.sprintf "~min_length:%d" v) constraints.min_length;
687 Option.map (fun v -> Printf.sprintf "~max_length:%d" v) constraints.max_length;
688 Option.map (fun v -> Printf.sprintf "~pattern:%S" v) constraints.pattern;
689 ] in
690 if args = [] then base_codec
691 else Printf.sprintf "(Openapi.Runtime.validated_string %s %s)" (String.concat " " args) base_codec
692 | "int" | "int32" | "int64" ->
693 let args = List.filter_map Fun.id [
694 Option.map (format_float_arg "minimum") constraints.minimum;
695 Option.map (format_float_arg "maximum") constraints.maximum;
696 Option.map (format_float_arg "exclusive_minimum") constraints.exclusive_minimum;
697 Option.map (format_float_arg "exclusive_maximum") constraints.exclusive_maximum;
698 ] in
699 if args = [] then base_codec
700 else Printf.sprintf "(Openapi.Runtime.validated_int %s %s)" (String.concat " " args) base_codec
701 | "float" ->
702 let args = List.filter_map Fun.id [
703 Option.map (format_float_arg "minimum") constraints.minimum;
704 Option.map (format_float_arg "maximum") constraints.maximum;
705 Option.map (format_float_arg "exclusive_minimum") constraints.exclusive_minimum;
706 Option.map (format_float_arg "exclusive_maximum") constraints.exclusive_maximum;
707 ] in
708 if args = [] then base_codec
709 else Printf.sprintf "(Openapi.Runtime.validated_float %s %s)" (String.concat " " args) base_codec
710 | s when String.ends_with ~suffix:" list" s ->
711 let args = List.filter_map Fun.id [
712 Option.map (fun v -> Printf.sprintf "~min_items:%d" v) constraints.min_items;
713 Option.map (fun v -> Printf.sprintf "~max_items:%d" v) constraints.max_items;
714 (if constraints.unique_items then Some "~unique_items:true" else None);
715 ] in
716 if args = [] then base_codec
717 else
718 (* Extract element codec from "(Jsont.list elem_codec)" pattern.
719 validated_list takes elem_codec directly, not the wrapped list. *)
720 let elem_codec =
721 if String.length base_codec > 12 && String.sub base_codec 0 12 = "(Jsont.list " then
722 (* Extract from "(Jsont.list X)" -> "X" *)
723 String.sub base_codec 12 (String.length base_codec - 13)
724 else
725 (* Fallback: can't extract, skip validation *)
726 ""
727 in
728 if elem_codec = "" then base_codec
729 else Printf.sprintf "(Openapi.Runtime.validated_list %s %s)" (String.concat " " args) elem_codec
730 | _ -> base_codec
731
732(** Generate a jsont codec for a polymorphic variant union type.
733 For unions with schema refs, returns Jsont.json (matching the fallback type).
734 For primitive-only unions, generates a proper polymorphic variant codec. *)
735let jsont_of_field_union ~current_prefix:_ (union : field_union_info) : string =
736 (* If union has schema refs, we've already fallen back to Jsont.json type *)
737 if field_union_has_refs union then
738 "Jsont.json"
739 else
740 (* Primitive-only union - generate polymorphic variant codec *)
741 let decoders = List.map (fun v ->
742 match v with
743 | Ref_variant _ -> failwith "unreachable: ref variant in primitive-only union"
744 | Prim_variant (name, prim_type) ->
745 let codec = jsont_of_base_type prim_type in
746 Printf.sprintf {|(fun json ->
747 match Openapi.Runtime.Json.decode_json %s json with
748 | Ok v -> Some (`%s v)
749 | Error _ -> None)|} codec name
750 ) union.field_variants in
751
752 let encoders = List.map (fun v ->
753 match v with
754 | Ref_variant _ -> failwith "unreachable: ref variant in primitive-only union"
755 | Prim_variant (name, prim_type) ->
756 let codec = jsont_of_base_type prim_type in
757 Printf.sprintf " | `%s v -> Openapi.Runtime.Json.encode_json %s v" name codec
758 ) union.field_variants in
759
760 Printf.sprintf {|(Jsont.map Jsont.json ~kind:"poly_union"
761 ~dec:(Openapi.Runtime.poly_union_decoder [
762 %s
763 ])
764 ~enc:(function
765%s))|}
766 (String.concat ";\n " decoders)
767 (String.concat "\n" encoders)
768
769(** {1 Schema Processing} *)
770
771(** Extract variant name from a schema ref, stripping common prefixes *)
772let variant_name_from_ref (ref_ : string) (parent_name : string) : string =
773 match schema_name_from_ref ref_ with
774 | None -> "Unknown"
775 | Some name ->
776 (* Try to strip parent prefix for shorter names *)
777 let parent_prefix = match String.split_on_char '_' (Name.to_snake_case parent_name) with
778 | first :: _ -> Name.to_module_name first
779 | [] -> ""
780 in
781 if String.length name > String.length parent_prefix &&
782 String.sub name 0 (String.length parent_prefix) = parent_prefix then
783 Name.to_module_name (String.sub name (String.length parent_prefix)
784 (String.length name - String.length parent_prefix))
785 else
786 Name.to_module_name name
787
788(** Analyze oneOf/anyOf schemas to extract union information *)
789let analyze_union ~(name : string) (schema : Spec.schema) : union_info option =
790 let extract_variants style json_list =
791 let variants = List.filter_map (fun json ->
792 match get_ref json with
793 | Some ref_ ->
794 schema_name_from_ref ref_ |> Option.map (fun schema_ref ->
795 let variant_name = variant_name_from_ref ref_ name in
796 { variant_name; schema_ref })
797 | None -> None (* Skip inline schemas for now *)
798 ) json_list in
799 if variants = [] then None
800 else
801 let discriminator_field = Option.map (fun (d : Spec.discriminator) ->
802 d.property_name) schema.discriminator in
803 let discriminator_mapping = Option.fold ~none:[]
804 ~some:(fun (d : Spec.discriminator) -> d.mapping) schema.discriminator in
805 Some {
806 discriminator_field;
807 discriminator_mapping;
808 variants;
809 style;
810 }
811 in
812 match schema.one_of, schema.any_of with
813 | Some items, _ -> extract_variants `OneOf items
814 | None, Some items -> extract_variants `AnyOf items
815 | None, None -> None
816
817let analyze_schema ~(components : Spec.components option) (name : string) (schema : Spec.schema) : schema_info =
818 (* First expand allOf composition *)
819 let expanded = expand_schema ~components schema in
820 let prefix, suffix = Name.split_schema_name name in
821 let is_enum = Option.is_some expanded.enum in
822 let enum_variants = match expanded.enum with
823 | Some values ->
824 List.filter_map (fun json ->
825 match json with
826 | Jsont.String (s, _) -> Some (Name.to_variant_name s, s)
827 | _ -> None
828 ) values
829 | None -> []
830 in
831 (* Check for oneOf/anyOf union types *)
832 let union_info = analyze_union ~name expanded in
833 let is_union = Option.is_some union_info in
834 let fields = List.map (fun (field_name, field_json) ->
835 let ocaml_name = Name.to_snake_case field_name in
836 let is_required = List.mem field_name expanded.required in
837 let resolved = resolve_type_full field_json in
838 let base_type = resolved.resolved_type in
839 let is_nullable = resolved.resolved_nullable in
840 let default_value = extract_default_value field_json base_type in
841 (* Field is optional in record type if:
842 - nullable (can be null) OR
843 - not required AND no default (may be absent with no fallback)
844 Fields with defaults are NOT optional - they always have a value *)
845 let has_default = Option.is_some default_value in
846 let is_optional = is_nullable || (not is_required && not has_default) in
847 let ocaml_type = if is_optional then base_type ^ " option" else base_type in
848 let description = get_string_member "description" field_json in
849 { ocaml_name; json_name = field_name; ocaml_type; base_type; is_optional;
850 is_required; is_nullable; description;
851 constraints = resolved.resolved_constraints;
852 field_union = resolved.resolved_union;
853 default_value }
854 ) expanded.properties in
855 (* Check if schema references itself *)
856 let deps = find_schema_dependencies expanded in
857 let is_recursive = List.mem name deps in
858 { original_name = name; prefix; suffix; schema = expanded; fields; is_enum; enum_variants;
859 description = expanded.description; is_recursive; is_union; union_info }
860
861(** {1 Operation Processing} *)
862
863(** Extract parameter name from a $ref like "#/components/parameters/idOrUUID" *)
864let param_name_from_ref ref_str =
865 let prefix = "#/components/parameters/" in
866 if String.length ref_str > String.length prefix &&
867 String.sub ref_str 0 (String.length prefix) = prefix then
868 Some (String.sub ref_str (String.length prefix)
869 (String.length ref_str - String.length prefix))
870 else None
871
872(** Resolve a parameter reference or return inline parameter *)
873let resolve_parameter ~(components : Spec.components option) (p : Spec.parameter Spec.or_ref) : Spec.parameter option =
874 match p with
875 | Spec.Value param -> Some param
876 | Spec.Ref ref_str ->
877 match param_name_from_ref ref_str with
878 | None -> None
879 | Some name ->
880 match components with
881 | None -> None
882 | Some comps ->
883 List.find_map (fun (n, p_or_ref) ->
884 if n = name then
885 match p_or_ref with
886 | Spec.Value param -> Some param
887 | Spec.Ref _ -> None (* Nested refs not supported *)
888 else None
889 ) comps.parameters
890
891let analyze_operation ~(spec : Spec.t) ~(path_item_params : Spec.parameter Spec.or_ref list)
892 ~path ~method_ (op : Spec.operation) : operation_info =
893 let func_name = Name.operation_name ~method_ ~path ~operation_id:op.operation_id in
894 (* Merge path_item parameters with operation parameters, operation takes precedence *)
895 let all_param_refs = path_item_params @ op.parameters in
896 let params = List.filter_map (resolve_parameter ~components:spec.components) all_param_refs in
897
898 let path_params = List.filter_map (fun (p : Spec.parameter) ->
899 if p.in_ = Spec.Path then
900 Some (Name.to_snake_case p.name, p.name, p.description, p.required)
901 else None
902 ) params in
903
904 let query_params = List.filter_map (fun (p : Spec.parameter) ->
905 if p.in_ = Spec.Query then
906 Some (Name.to_snake_case p.name, p.name, p.description, p.required)
907 else None
908 ) params in
909
910 let body_schema_ref = match op.request_body with
911 | Some (Spec.Value (rb : Spec.request_body)) ->
912 List.find_map (fun (ct, (media : Spec.media_type)) ->
913 if String.length ct >= 16 && String.sub ct 0 16 = "application/json" then
914 match media.schema with
915 | Some (Spec.Ref r) -> schema_name_from_ref r
916 | _ -> None
917 else None
918 ) rb.content
919 | _ -> None
920 in
921
922 let find_in_content content =
923 List.find_map (fun (ct, (media : Spec.media_type)) ->
924 if String.length ct >= 16 && String.sub ct 0 16 = "application/json" then
925 match media.schema with
926 | Some (Spec.Ref r) -> schema_name_from_ref r
927 | Some (Spec.Value s) when s.type_ = Some "array" ->
928 Option.bind s.items (fun items -> Option.bind (get_ref items) schema_name_from_ref)
929 | _ -> None
930 else None
931 ) content
932 in
933
934 let response_schema_ref =
935 let try_status status =
936 List.find_map (fun (code, resp) ->
937 if code = status then
938 match resp with
939 | Spec.Value (r : Spec.response) -> find_in_content r.content
940 | _ -> None
941 else None
942 ) op.responses.responses
943 in
944 match try_status "200" with
945 | Some r -> Some r
946 | None -> match try_status "201" with
947 | Some r -> Some r
948 | None -> match op.responses.default with
949 | Some (Spec.Value (r : Spec.response)) -> find_in_content r.content
950 | _ -> None
951 in
952
953 (* Extract error responses (4xx, 5xx, default) *)
954 let error_responses =
955 let is_error_code code =
956 code = "default" ||
957 (try int_of_string code >= 400 with _ ->
958 String.length code = 3 && (code.[0] = '4' || code.[0] = '5'))
959 in
960 List.filter_map (fun (code, resp) ->
961 if is_error_code code then
962 match resp with
963 | Spec.Value (r : Spec.response) ->
964 let schema_ref = find_in_content r.content in
965 Some { status_code = code; schema_ref; error_description = r.description }
966 | Spec.Ref _ ->
967 Some { status_code = code; schema_ref = None; error_description = "" }
968 else None
969 ) op.responses.responses
970 in
971
972 { func_name; operation_id = op.operation_id; summary = op.summary;
973 description = op.description; tags = op.tags; path; method_;
974 path_params; query_params; body_schema_ref; response_schema_ref; error_responses }
975
976(** {1 Module Tree Building} *)
977
978(** Extract prefix module dependencies from a schema's fields *)
979let schema_prefix_deps (schema : schema_info) : StringSet.t =
980 let deps = List.filter_map (fun (f : field_info) ->
981 (* Check if the type references another module *)
982 if String.contains f.base_type '.' then
983 (* Extract first component before the dot *)
984 match String.split_on_char '.' f.base_type with
985 | prefix :: _ when prefix <> "Jsont" && prefix <> "Ptime" && prefix <> "Openapi" ->
986 Some prefix
987 | _ -> None
988 else None
989 ) schema.fields in
990 StringSet.of_list deps
991
992(** Extract prefix module dependencies from an operation's types *)
993let operation_prefix_deps (op : operation_info) : StringSet.t =
994 let body_dep = match op.body_schema_ref with
995 | Some name ->
996 let prefix, _ = Name.split_schema_name name in
997 Some (Name.to_module_name prefix)
998 | None -> None
999 in
1000 let response_dep = match op.response_schema_ref with
1001 | Some name ->
1002 let prefix, _ = Name.split_schema_name name in
1003 Some (Name.to_module_name prefix)
1004 | None -> None
1005 in
1006 StringSet.of_list (List.filter_map Fun.id [body_dep; response_dep])
1007
1008let build_module_tree (schemas : schema_info list) (operations : operation_info list) : module_node * string list =
1009 let root = empty_node "Root" in
1010
1011 (* Build set of known schema names for validation *)
1012 let known_schemas = StringSet.of_list (List.map (fun s -> s.original_name) schemas) in
1013
1014 (* Add schemas to tree and track dependencies *)
1015 let root = List.fold_left (fun root schema ->
1016 let prefix_mod = Name.to_module_name schema.prefix in
1017 let child = match StringMap.find_opt prefix_mod root.children with
1018 | Some c -> c
1019 | None -> empty_node prefix_mod
1020 in
1021 let schema_deps = schema_prefix_deps schema in
1022 (* Remove self-dependency *)
1023 let schema_deps = StringSet.remove prefix_mod schema_deps in
1024 let child = { child with
1025 schemas = schema :: child.schemas;
1026 dependencies = StringSet.union child.dependencies schema_deps
1027 } in
1028 { root with children = StringMap.add prefix_mod child root.children }
1029 ) root schemas in
1030
1031 (* Add operations to tree based on response type, and track operation dependencies.
1032 Only use response_schema_ref if the schema actually exists in components/schemas. *)
1033 let root = List.fold_left (fun root op ->
1034 (* Check if response schema actually exists *)
1035 let valid_response_ref = match op.response_schema_ref with
1036 | Some name when StringSet.mem name known_schemas -> Some name
1037 | _ -> None
1038 in
1039 match valid_response_ref with
1040 | Some ref_name ->
1041 let prefix, _ = Name.split_schema_name ref_name in
1042 let prefix_mod = Name.to_module_name prefix in
1043 let child = match StringMap.find_opt prefix_mod root.children with
1044 | Some c -> c
1045 | None -> empty_node prefix_mod
1046 in
1047 let op_deps = operation_prefix_deps op in
1048 (* Remove self-dependency *)
1049 let op_deps = StringSet.remove prefix_mod op_deps in
1050 let child = { child with
1051 operations = op :: child.operations;
1052 dependencies = StringSet.union child.dependencies op_deps
1053 } in
1054 { root with children = StringMap.add prefix_mod child root.children }
1055 | None ->
1056 (* Put in Client module for operations without valid typed response *)
1057 let child = match StringMap.find_opt "Client" root.children with
1058 | Some c -> c
1059 | None -> empty_node "Client"
1060 in
1061 let op_deps = operation_prefix_deps op in
1062 let op_deps = StringSet.remove "Client" op_deps in
1063 let child = { child with
1064 operations = op :: child.operations;
1065 dependencies = StringSet.union child.dependencies op_deps
1066 } in
1067 { root with children = StringMap.add "Client" child root.children }
1068 ) root operations in
1069
1070 (* Get sorted list of module names (dependencies first) *)
1071 let module_names = StringMap.fold (fun name _ acc -> name :: acc) root.children [] in
1072 let deps_of name =
1073 match StringMap.find_opt name root.children with
1074 | Some node -> StringSet.elements node.dependencies
1075 | None -> []
1076 in
1077 let sorted = topological_sort module_names deps_of in
1078
1079 (root, sorted)
1080
1081(** {1 Code Generation} *)
1082
1083let gen_enum_impl (schema : schema_info) : string =
1084 let doc = format_doc schema.description in
1085 if schema.enum_variants = [] then
1086 Printf.sprintf "%stype t = string\n\nlet jsont = Jsont.string" doc
1087 else
1088 let type_def = Printf.sprintf "%stype t = [\n%s\n]" doc
1089 (String.concat "\n" (List.map (fun (v, _) -> " | `" ^ v) schema.enum_variants))
1090 in
1091 let dec_cases = String.concat "\n" (List.map (fun (v, raw) ->
1092 Printf.sprintf " | %S -> `%s" raw v
1093 ) schema.enum_variants) in
1094 let enc_cases = String.concat "\n" (List.map (fun (v, raw) ->
1095 Printf.sprintf " | `%s -> %S" v raw
1096 ) schema.enum_variants) in
1097 Printf.sprintf {|%s
1098
1099let jsont : t Jsont.t =
1100 Jsont.map Jsont.string ~kind:%S
1101 ~dec:(function
1102%s
1103 | s -> Jsont.Error.msgf Jsont.Meta.none "Unknown value: %%s" s)
1104 ~enc:(function
1105%s)|} type_def schema.original_name dec_cases enc_cases
1106
1107let gen_enum_intf (schema : schema_info) : string =
1108 let doc = format_doc schema.description in
1109 if schema.enum_variants = [] then
1110 Printf.sprintf "%stype t = string\n\nval jsont : t Jsont.t" doc
1111 else
1112 let type_def = Printf.sprintf "%stype t = [\n%s\n]" doc
1113 (String.concat "\n" (List.map (fun (v, _) -> " | `" ^ v) schema.enum_variants))
1114 in
1115 Printf.sprintf "%s\n\nval jsont : t Jsont.t" type_def
1116
1117(** {2 Union Type Generation} *)
1118
1119(** Format a union variant type reference for code generation *)
1120let format_union_type_ref ~current_prefix (schema_ref : string) : string =
1121 let prefix, suffix = Name.split_schema_name schema_ref in
1122 let prefix_mod = Name.to_module_name prefix in
1123 let suffix_mod = Name.to_module_name suffix in
1124 if prefix_mod = current_prefix then
1125 Printf.sprintf "%s.t" suffix_mod
1126 else if is_forward_ref prefix_mod then
1127 "Jsont.json"
1128 else
1129 Printf.sprintf "%s.%s.t" prefix_mod suffix_mod
1130
1131(** Format a union variant jsont codec reference *)
1132let format_union_jsont_ref ~current_prefix (schema_ref : string) : string =
1133 let prefix, suffix = Name.split_schema_name schema_ref in
1134 let prefix_mod = Name.to_module_name prefix in
1135 let suffix_mod = Name.to_module_name suffix in
1136 if prefix_mod <> current_prefix && is_forward_ref prefix_mod then
1137 "Jsont.json"
1138 else if prefix_mod = current_prefix then
1139 Printf.sprintf "%s.jsont" suffix_mod
1140 else
1141 Printf.sprintf "%s.%s.jsont" prefix_mod suffix_mod
1142
1143(** Generate a discriminator-based jsont codec for union types.
1144 Uses Jsont.Object.Case for tag-based discrimination. *)
1145let gen_union_jsont_discriminator ~current_prefix (schema : schema_info) (union : union_info) (field : string) : string =
1146 (* Generate case definitions *)
1147 let cases = List.map (fun (v : union_variant) ->
1148 let codec_ref = format_union_jsont_ref ~current_prefix v.schema_ref in
1149 (* Look up the tag value in discriminator mapping, or default to snake_case variant name *)
1150 let tag_value = match List.find_opt (fun (_, ref_) ->
1151 match schema_name_from_ref ref_ with
1152 | Some name -> name = v.schema_ref
1153 | None -> false
1154 ) union.discriminator_mapping with
1155 | Some (tag, _) -> tag
1156 | None -> Name.to_snake_case v.variant_name
1157 in
1158 Printf.sprintf {| let case_%s =
1159 Jsont.Object.Case.map %S %s ~dec:(fun v -> %s v)
1160 in|}
1161 (Name.to_snake_case v.variant_name)
1162 tag_value
1163 codec_ref
1164 v.variant_name
1165 ) union.variants in
1166
1167 let enc_cases = List.map (fun (v : union_variant) ->
1168 Printf.sprintf " | %s v -> Jsont.Object.Case.value case_%s v"
1169 v.variant_name (Name.to_snake_case v.variant_name)
1170 ) union.variants in
1171
1172 let case_list = List.map (fun (v : union_variant) ->
1173 Printf.sprintf "make case_%s" (Name.to_snake_case v.variant_name)
1174 ) union.variants in
1175
1176 Printf.sprintf {|let jsont : t Jsont.t =
1177%s
1178 let enc_case = function
1179%s
1180 in
1181 let cases = Jsont.Object.Case.[%s] in
1182 Jsont.Object.map ~kind:%S Fun.id
1183 |> Jsont.Object.case_mem %S Jsont.string ~enc:Fun.id ~enc_case cases
1184 ~tag_to_string:Fun.id ~tag_compare:String.compare
1185 |> Jsont.Object.finish|}
1186 (String.concat "\n" cases)
1187 (String.concat "\n" enc_cases)
1188 (String.concat "; " case_list)
1189 schema.original_name
1190 field
1191
1192(** Generate a try-each jsont codec for union types without discriminator.
1193 Attempts to decode each variant in order until one succeeds. *)
1194let gen_union_jsont_try_each ~current_prefix (schema : schema_info) (union : union_info) : string =
1195 let try_cases = List.mapi (fun i (v : union_variant) ->
1196 let codec_ref = format_union_jsont_ref ~current_prefix v.schema_ref in
1197 let prefix = if i = 0 then " " else " " in
1198 let error_prefix = if i = List.length union.variants - 1 then
1199 Printf.sprintf {|%sJsont.Error.msgf Jsont.Meta.none "No variant matched for %s"|} prefix schema.original_name
1200 else
1201 ""
1202 in
1203 Printf.sprintf {|%smatch Openapi.Runtime.Json.decode_json %s json with
1204%s| Ok v -> %s v
1205%s| Error _ ->
1206%s|}
1207 prefix codec_ref prefix v.variant_name prefix error_prefix
1208 ) union.variants in
1209
1210 let enc_cases = List.map (fun (v : union_variant) ->
1211 let codec_ref = format_union_jsont_ref ~current_prefix v.schema_ref in
1212 Printf.sprintf " | %s v -> Openapi.Runtime.Json.encode_json %s v"
1213 v.variant_name codec_ref
1214 ) union.variants in
1215
1216 Printf.sprintf {|let jsont : t Jsont.t =
1217 let decode json =
1218%s
1219 in
1220 Jsont.map Jsont.json ~kind:%S
1221 ~dec:decode
1222 ~enc:(function
1223%s)|}
1224 (String.concat "" try_cases)
1225 schema.original_name
1226 (String.concat "\n" enc_cases)
1227
1228(** Generate implementation code for a union type schema *)
1229let gen_union_impl ~current_prefix (schema : schema_info) : string =
1230 match schema.union_info with
1231 | None -> failwith "gen_union_impl called on non-union schema"
1232 | Some union ->
1233 let doc = format_doc schema.description in
1234
1235 (* Type definition with variant constructors *)
1236 let type_def = Printf.sprintf "%stype t =\n%s" doc
1237 (String.concat "\n" (List.map (fun (v : union_variant) ->
1238 Printf.sprintf " | %s of %s" v.variant_name
1239 (format_union_type_ref ~current_prefix v.schema_ref)
1240 ) union.variants))
1241 in
1242
1243 (* Jsont codec - discriminator-based or try-each *)
1244 let jsont_code = match union.discriminator_field with
1245 | Some field -> gen_union_jsont_discriminator ~current_prefix schema union field
1246 | None -> gen_union_jsont_try_each ~current_prefix schema union
1247 in
1248
1249 Printf.sprintf "%s\n\n%s" type_def jsont_code
1250
1251(** Generate interface code for a union type schema *)
1252let gen_union_intf ~current_prefix (schema : schema_info) : string =
1253 match schema.union_info with
1254 | None -> failwith "gen_union_intf called on non-union schema"
1255 | Some union ->
1256 let doc = format_doc schema.description in
1257 let type_def = Printf.sprintf "%stype t =\n%s" doc
1258 (String.concat "\n" (List.map (fun (v : union_variant) ->
1259 Printf.sprintf " | %s of %s" v.variant_name
1260 (format_union_type_ref ~current_prefix v.schema_ref)
1261 ) union.variants))
1262 in
1263 Printf.sprintf "%s\n\nval jsont : t Jsont.t" type_def
1264
1265(** Localize an OCaml type string by stripping the current_prefix and current_suffix modules.
1266 When generating code inside a submodule, self-references need to be unqualified. *)
1267let localize_type ~current_prefix ~current_suffix (type_str : string) : string =
1268 (* Handle patterns like "User.ResponseDto.t" -> "ResponseDto.t" if current_prefix = "User"
1269 And further "ResponseDto.t" -> "t" if current_suffix = "ResponseDto" *)
1270 let prefix_dot = current_prefix ^ "." in
1271 let suffix_dot = current_suffix ^ "." in
1272 let full_path = current_prefix ^ "." ^ current_suffix ^ "." in
1273 let strip_prefix s =
1274 (* First try to strip full path (Prefix.Suffix.) *)
1275 if String.length s >= String.length full_path &&
1276 String.sub s 0 (String.length full_path) = full_path then
1277 String.sub s (String.length full_path) (String.length s - String.length full_path)
1278 (* Then try just prefix *)
1279 else if String.length s >= String.length prefix_dot &&
1280 String.sub s 0 (String.length prefix_dot) = prefix_dot then
1281 let rest = String.sub s (String.length prefix_dot) (String.length s - String.length prefix_dot) in
1282 (* If the rest starts with our suffix, strip that too *)
1283 if String.length rest >= String.length suffix_dot &&
1284 String.sub rest 0 (String.length suffix_dot) = suffix_dot then
1285 String.sub rest (String.length suffix_dot) (String.length rest - String.length suffix_dot)
1286 else rest
1287 else s
1288 in
1289 (* Handle "X list", "X option", and nested combinations *)
1290 let rec localize s =
1291 if String.ends_with ~suffix:" list" s then
1292 let elem = String.sub s 0 (String.length s - 5) in
1293 (localize elem) ^ " list"
1294 else if String.ends_with ~suffix:" option" s then
1295 let elem = String.sub s 0 (String.length s - 7) in
1296 (localize elem) ^ " option"
1297 else
1298 strip_prefix s
1299 in
1300 localize type_str
1301
1302(** Localize a jsont codec string by stripping the current_prefix and current_suffix modules *)
1303let rec localize_jsont ~current_prefix ~current_suffix (jsont_str : string) : string =
1304 let prefix_dot = current_prefix ^ "." in
1305 let suffix_dot = current_suffix ^ "." in
1306 let full_path = current_prefix ^ "." ^ current_suffix ^ "." in
1307 let strip_prefix s =
1308 (* First try to strip full path (Prefix.Suffix.) *)
1309 if String.length s >= String.length full_path &&
1310 String.sub s 0 (String.length full_path) = full_path then
1311 String.sub s (String.length full_path) (String.length s - String.length full_path)
1312 (* Then try just prefix *)
1313 else if String.length s >= String.length prefix_dot &&
1314 String.sub s 0 (String.length prefix_dot) = prefix_dot then
1315 let rest = String.sub s (String.length prefix_dot) (String.length s - String.length prefix_dot) in
1316 (* If the rest starts with our suffix, strip that too *)
1317 if String.length rest >= String.length suffix_dot &&
1318 String.sub rest 0 (String.length suffix_dot) = suffix_dot then
1319 String.sub rest (String.length suffix_dot) (String.length rest - String.length suffix_dot)
1320 else rest
1321 else s
1322 in
1323 (* Handle patterns like "User.ResponseDto.jsont" -> "ResponseDto.jsont" -> "jsont"
1324 Also handle "(Jsont.list User.ResponseDto.jsont)" *)
1325 if String.length jsont_str > 12 && String.sub jsont_str 0 12 = "(Jsont.list " then
1326 let inner = String.sub jsont_str 12 (String.length jsont_str - 13) in
1327 "(Jsont.list " ^ localize_jsont ~current_prefix ~current_suffix inner ^ ")"
1328 else
1329 strip_prefix jsont_str
1330
1331let gen_record_impl ~current_prefix ~current_suffix (schema : schema_info) : string =
1332 (* For recursive schemas, self-referential fields need to use Jsont.json
1333 to avoid OCaml's let rec restrictions on non-functional values.
1334 Also handle forward references to modules that come later in the sort order. *)
1335 let is_forward_reference type_str =
1336 (* Extract prefix from type like "People.Update.t" *)
1337 match String.split_on_char '.' type_str with
1338 | prefix :: _ when prefix <> current_prefix && is_forward_ref prefix -> true
1339 | _ -> false
1340 in
1341 let loc_type s =
1342 let localized = localize_type ~current_prefix ~current_suffix s in
1343 if schema.is_recursive && localized = "t" then "Jsont.json"
1344 else if schema.is_recursive && localized = "t list" then "Jsont.json list"
1345 else if schema.is_recursive && localized = "t option" then "Jsont.json option"
1346 else if schema.is_recursive && localized = "t list option" then "Jsont.json list option"
1347 (* Handle forward references - use Jsont.json for types from modules not yet defined *)
1348 else if is_forward_reference s then
1349 if String.ends_with ~suffix:" option" localized then "Jsont.json option"
1350 else if String.ends_with ~suffix:" list" localized then "Jsont.json list"
1351 else if String.ends_with ~suffix:" list option" localized then "Jsont.json list option"
1352 else "Jsont.json"
1353 else localized
1354 in
1355 let is_forward_jsont_ref jsont_str =
1356 (* Extract prefix from jsont like "People.Update.jsont", "(Jsont.list People.Update.jsont)",
1357 or "(Openapi.Runtime.nullable_any People.Update.jsont)" *)
1358 let s =
1359 if String.length jsont_str > 12 && String.sub jsont_str 0 12 = "(Jsont.list " then
1360 String.sub jsont_str 12 (String.length jsont_str - 13)
1361 else if String.length jsont_str > 31 && String.sub jsont_str 0 31 = "(Openapi.Runtime.nullable_any " then
1362 String.sub jsont_str 31 (String.length jsont_str - 32)
1363 else jsont_str
1364 in
1365 match String.split_on_char '.' s with
1366 | prefix :: _ when prefix <> current_prefix && is_forward_ref prefix -> true
1367 | _ -> false
1368 in
1369 let loc_jsont s =
1370 let localized = localize_jsont ~current_prefix ~current_suffix s in
1371 if schema.is_recursive && localized = "jsont" then "Jsont.json"
1372 else if schema.is_recursive && localized = "(Jsont.list jsont)" then
1373 "(Jsont.list Jsont.json)"
1374 (* Handle forward references in jsont codecs *)
1375 else if is_forward_jsont_ref s then
1376 if String.length localized > 12 && String.sub localized 0 12 = "(Jsont.list " then
1377 "(Jsont.list Jsont.json)"
1378 else if String.length s > 31 && String.sub s 0 31 = "(Openapi.Runtime.nullable_any " then
1379 (* For nullable forward refs, Jsont.json can decode nulls too *)
1380 "Jsont.json"
1381 else "Jsont.json"
1382 else localized
1383 in
1384 let doc = format_doc schema.description in
1385 if schema.fields = [] then
1386 Printf.sprintf "%stype t = Jsont.json\n\nlet jsont = Jsont.json\n\nlet v () = Jsont.Null ((), Jsont.Meta.none)" doc
1387 else
1388 (* Private type definition *)
1389 let type_fields = String.concat "\n" (List.map (fun (f : field_info) ->
1390 let field_doc = match f.description with
1391 | Some d -> Printf.sprintf " (** %s *)" (escape_doc d)
1392 | None -> ""
1393 in
1394 Printf.sprintf " %s : %s;%s" f.ocaml_name (loc_type f.ocaml_type) field_doc
1395 ) schema.fields) in
1396
1397 let type_def = Printf.sprintf "%stype t = {\n%s\n}" doc type_fields in
1398
1399 (* Constructor function v
1400 - Required fields (no default, not optional): ~field
1401 - Fields with defaults: ?(field=default)
1402 - Optional fields (no default, is_optional): ?field *)
1403 let required_fields = List.filter (fun (f : field_info) ->
1404 not f.is_optional && Option.is_none f.default_value
1405 ) schema.fields in
1406 let default_fields = List.filter (fun (f : field_info) ->
1407 Option.is_some f.default_value
1408 ) schema.fields in
1409 let optional_fields = List.filter (fun (f : field_info) ->
1410 f.is_optional && Option.is_none f.default_value
1411 ) schema.fields in
1412 let v_params =
1413 (List.map (fun (f : field_info) -> Printf.sprintf "~%s" f.ocaml_name) required_fields) @
1414 (List.map (fun (f : field_info) ->
1415 Printf.sprintf "?(%s=%s)" f.ocaml_name (Option.get f.default_value)
1416 ) default_fields) @
1417 (List.map (fun (f : field_info) -> Printf.sprintf "?%s" f.ocaml_name) optional_fields) @
1418 ["()"]
1419 in
1420 let v_body = String.concat "; " (List.map (fun (f : field_info) -> f.ocaml_name) schema.fields) in
1421 let v_func = Printf.sprintf "let v %s = { %s }" (String.concat " " v_params) v_body in
1422
1423 (* Accessor functions *)
1424 let accessors = String.concat "\n" (List.map (fun (f : field_info) ->
1425 Printf.sprintf "let %s t = t.%s" f.ocaml_name f.ocaml_name
1426 ) schema.fields) in
1427
1428 (* Jsont codec *)
1429 let make_params = String.concat " " (List.map (fun (f : field_info) -> f.ocaml_name) schema.fields) in
1430 let jsont_members = String.concat "\n" (List.map (fun (f : field_info) ->
1431 (* Determine the right codec based on nullable/required/default status:
1432 - nullable: use nullable codec, dec_absent depends on default
1433 - optional with default: use mem with dec_absent:(Some default)
1434 - optional without default: use opt_mem
1435 - required: use mem
1436 - field union: use polymorphic variant codec
1437 - with validation: use validated codec *)
1438 let base_codec =
1439 match f.field_union with
1440 | Some union ->
1441 (* Field-level union - generate inline polymorphic variant codec *)
1442 jsont_of_field_union ~current_prefix union
1443 | None ->
1444 (* Regular field - may need validation *)
1445 let raw_codec = jsont_of_base_type f.base_type in
1446 let localized = loc_jsont raw_codec in
1447 if has_constraints f.constraints then
1448 validated_jsont f.constraints localized f.base_type
1449 else
1450 localized
1451 in
1452 if f.is_nullable then
1453 let nullable_codec =
1454 match f.field_union with
1455 | Some _ -> Printf.sprintf "(Openapi.Runtime.nullable_any %s)" base_codec
1456 | None -> loc_jsont (nullable_jsont_of_base_type f.base_type)
1457 in
1458 (* For nullable fields, dec_absent depends on default:
1459 - No default: None (absent = null)
1460 - Default is "None" (JSON null): None
1461 - Default is a value: (Some value) *)
1462 let dec_absent = match f.default_value with
1463 | Some "None" -> "None" (* Default is null *)
1464 | Some def -> Printf.sprintf "(Some %s)" def
1465 | None -> "None"
1466 in
1467 Printf.sprintf " |> Jsont.Object.mem %S %s\n ~dec_absent:%s ~enc_omit:Option.is_none ~enc:(fun r -> r.%s)"
1468 f.json_name nullable_codec dec_absent f.ocaml_name
1469 else if f.is_optional then
1470 (* Optional non-nullable field without default - use opt_mem *)
1471 Printf.sprintf " |> Jsont.Object.opt_mem %S %s ~enc:(fun r -> r.%s)"
1472 f.json_name base_codec f.ocaml_name
1473 else
1474 (* Required or has default - use mem, possibly with dec_absent *)
1475 (match f.default_value with
1476 | Some def ->
1477 Printf.sprintf " |> Jsont.Object.mem %S %s ~dec_absent:%s ~enc:(fun r -> r.%s)"
1478 f.json_name base_codec def f.ocaml_name
1479 | None ->
1480 Printf.sprintf " |> Jsont.Object.mem %S %s ~enc:(fun r -> r.%s)"
1481 f.json_name base_codec f.ocaml_name)
1482 ) schema.fields) in
1483
1484 Printf.sprintf {|%s
1485
1486%s
1487
1488%s
1489
1490let jsont : t Jsont.t =
1491 Jsont.Object.map ~kind:%S
1492 (fun %s -> { %s })
1493%s
1494 |> Jsont.Object.skip_unknown
1495 |> Jsont.Object.finish|}
1496 type_def v_func accessors schema.original_name make_params v_body jsont_members
1497
1498let gen_record_intf ~current_prefix ~current_suffix (schema : schema_info) : string =
1499 (* For recursive schemas, self-referential fields need to use Jsont.json
1500 to avoid OCaml's let rec restrictions on non-functional values.
1501 Also handle forward references to modules that come later in the sort order. *)
1502 let is_forward_reference type_str =
1503 match String.split_on_char '.' type_str with
1504 | prefix :: _ when prefix <> current_prefix && is_forward_ref prefix -> true
1505 | _ -> false
1506 in
1507 let loc_type s =
1508 let localized = localize_type ~current_prefix ~current_suffix s in
1509 if schema.is_recursive && localized = "t" then "Jsont.json"
1510 else if schema.is_recursive && localized = "t list" then "Jsont.json list"
1511 else if schema.is_recursive && localized = "t option" then "Jsont.json option"
1512 else if schema.is_recursive && localized = "t list option" then "Jsont.json list option"
1513 (* Handle forward references *)
1514 else if is_forward_reference s then
1515 if String.ends_with ~suffix:" option" localized then "Jsont.json option"
1516 else if String.ends_with ~suffix:" list" localized then "Jsont.json list"
1517 else if String.ends_with ~suffix:" list option" localized then "Jsont.json list option"
1518 else "Jsont.json"
1519 else localized
1520 in
1521 let doc = format_doc schema.description in
1522 if schema.fields = [] then
1523 (* Expose that the type is Jsont.json for opaque types - allows users to pattern match *)
1524 Printf.sprintf "%stype t = Jsont.json\n\nval jsont : t Jsont.t\n\nval v : unit -> t" doc
1525 else
1526 (* Abstract type *)
1527 let type_decl = Printf.sprintf "%stype t" doc in
1528
1529 (* Constructor signature
1530 - Required fields (no default, not optional): field:type
1531 - Fields with defaults: ?field:type (optional parameter)
1532 - Optional fields (no default, is_optional): ?field:type *)
1533 let required_fields = List.filter (fun (f : field_info) ->
1534 not f.is_optional && Option.is_none f.default_value
1535 ) schema.fields in
1536 let default_fields = List.filter (fun (f : field_info) ->
1537 Option.is_some f.default_value
1538 ) schema.fields in
1539 let optional_fields = List.filter (fun (f : field_info) ->
1540 f.is_optional && Option.is_none f.default_value
1541 ) schema.fields in
1542 let v_param_docs = String.concat ""
1543 ((List.map (fun (f : field_info) -> format_param_doc f.ocaml_name f.description) required_fields) @
1544 (List.map (fun (f : field_info) -> format_param_doc f.ocaml_name f.description) default_fields) @
1545 (List.map (fun (f : field_info) -> format_param_doc f.ocaml_name f.description) optional_fields))
1546 in
1547 let v_params =
1548 (List.map (fun (f : field_info) -> Printf.sprintf "%s:%s" f.ocaml_name (loc_type f.base_type)) required_fields) @
1549 (List.map (fun (f : field_info) -> Printf.sprintf "?%s:%s" f.ocaml_name (loc_type f.ocaml_type)) default_fields) @
1550 (List.map (fun (f : field_info) -> Printf.sprintf "?%s:%s" f.ocaml_name (loc_type f.base_type)) optional_fields) @
1551 ["unit"; "t"]
1552 in
1553 let v_doc = if v_param_docs = "" then "(** Construct a value *)\n"
1554 else Printf.sprintf "(** Construct a value\n%s*)\n" v_param_docs in
1555 let v_sig = Printf.sprintf "%sval v : %s" v_doc (String.concat " -> " v_params) in
1556
1557 (* Accessor signatures *)
1558 let accessor_sigs = String.concat "\n\n" (List.map (fun (f : field_info) ->
1559 let acc_doc = match f.description with
1560 | Some d -> Printf.sprintf "(** %s *)\n" (escape_doc d)
1561 | None -> ""
1562 in
1563 Printf.sprintf "%sval %s : t -> %s" acc_doc f.ocaml_name (loc_type f.ocaml_type)
1564 ) schema.fields) in
1565
1566 Printf.sprintf "%s\n\n%s\n\n%s\n\nval jsont : t Jsont.t"
1567 type_decl v_sig accessor_sigs
1568
1569(** Format a jsont codec reference, stripping the current_prefix if present.
1570 Returns Jsont.json for forward references to avoid unbound module errors. *)
1571let format_jsont_ref ~current_prefix (schema_ref : string) : string =
1572 let prefix, suffix = Name.split_schema_name schema_ref in
1573 let prefix_mod = Name.to_module_name prefix in
1574 let suffix_mod = Name.to_module_name suffix in
1575 (* Check if this is a forward reference to a module that hasn't been defined yet *)
1576 if prefix_mod <> current_prefix && is_forward_ref prefix_mod then
1577 "Jsont.json"
1578 else if prefix_mod = current_prefix then
1579 Printf.sprintf "%s.jsont" suffix_mod
1580 else
1581 Printf.sprintf "%s.%s.jsont" prefix_mod suffix_mod
1582
1583(** Check if a schema exists - used to validate refs before generating code *)
1584let schema_exists_ref = ref (fun (_ : string) -> true)
1585let set_known_schemas (schemas : schema_info list) =
1586 let known = StringSet.of_list (List.map (fun s -> s.original_name) schemas) in
1587 schema_exists_ref := (fun name -> StringSet.mem name known)
1588
1589let gen_operation_impl ~current_prefix (op : operation_info) : string =
1590 let doc = format_doc_block ~summary:op.summary ?description:op.description () in
1591 let param_docs = String.concat ""
1592 ((List.map (fun (n, _, d, _) -> format_param_doc n d) op.path_params) @
1593 (List.map (fun (n, _, d, _) -> format_param_doc n d) op.query_params)) in
1594 let full_doc = if param_docs = "" then doc
1595 else if doc = "" then Printf.sprintf "(**\n%s*)\n" param_docs
1596 else String.sub doc 0 (String.length doc - 3) ^ "\n" ^ param_docs ^ "*)\n" in
1597
1598 (* Only use body/response refs if schema actually exists *)
1599 let valid_body_ref = match op.body_schema_ref with
1600 | Some name when !schema_exists_ref name -> Some name
1601 | _ -> None
1602 in
1603 let valid_response_ref = match op.response_schema_ref with
1604 | Some name when !schema_exists_ref name -> Some name
1605 | _ -> None
1606 in
1607
1608 let path_args = List.map (fun (n, _, _, _) -> Printf.sprintf "~%s" n) op.path_params in
1609 let query_args = List.map (fun (n, _, _, req) ->
1610 if req then Printf.sprintf "~%s" n else Printf.sprintf "?%s" n
1611 ) op.query_params in
1612 (* DELETE and HEAD don't support body in the requests library *)
1613 let method_supports_body = not (List.mem op.method_ ["DELETE"; "HEAD"; "OPTIONS"]) in
1614 let body_arg = match valid_body_ref, method_supports_body with
1615 | Some _, true -> ["~body"]
1616 | _ -> []
1617 in
1618 let all_args = path_args @ query_args @ body_arg @ ["client"; "()"] in
1619
1620 let path_render =
1621 if op.path_params = [] then Printf.sprintf "%S" op.path
1622 else
1623 let bindings = List.map (fun (ocaml, json, _, _) ->
1624 Printf.sprintf "(%S, %s)" json ocaml
1625 ) op.path_params in
1626 Printf.sprintf "Openapi.Runtime.Path.render ~params:[%s] %S"
1627 (String.concat "; " bindings) op.path
1628 in
1629
1630 let query_build =
1631 if op.query_params = [] then "\"\""
1632 else
1633 let parts = List.map (fun (ocaml, json, _, req) ->
1634 if req then Printf.sprintf "Openapi.Runtime.Query.singleton ~key:%S ~value:%s" json ocaml
1635 else Printf.sprintf "Openapi.Runtime.Query.optional ~key:%S ~value:%s" json ocaml
1636 ) op.query_params in
1637 Printf.sprintf "Openapi.Runtime.Query.encode (List.concat [%s])" (String.concat "; " parts)
1638 in
1639
1640 let method_lower = String.lowercase_ascii op.method_ in
1641 let body_codec = match valid_body_ref with
1642 | Some name -> format_jsont_ref ~current_prefix name
1643 | None -> "Jsont.json"
1644 in
1645 (* DELETE and HEAD don't support body in the requests library *)
1646 let method_supports_body' = not (List.mem op.method_ ["DELETE"; "HEAD"; "OPTIONS"]) in
1647 let http_call = match valid_body_ref, method_supports_body' with
1648 | Some _, true ->
1649 Printf.sprintf "Requests.%s client.session ~body:(Requests.Body.json (Openapi.Runtime.Json.encode_json %s body)) url"
1650 method_lower body_codec
1651 | Some _, false ->
1652 (* Method doesn't support body - ignore the body parameter *)
1653 Printf.sprintf "Requests.%s client.session url" method_lower
1654 | None, _ ->
1655 Printf.sprintf "Requests.%s client.session url" method_lower
1656 in
1657
1658 let response_codec = match valid_response_ref with
1659 | Some name -> format_jsont_ref ~current_prefix name
1660 | None -> "Jsont.json"
1661 in
1662
1663 let decode = if response_codec = "Jsont.json" then
1664 "Requests.Response.json response"
1665 else
1666 Printf.sprintf "Openapi.Runtime.Json.decode_json_exn %s (Requests.Response.json response)" response_codec
1667 in
1668
1669 (* Generate typed error parsing if we have error schemas *)
1670 let valid_error_responses = List.filter_map (fun (err : error_response) ->
1671 match err.schema_ref with
1672 | Some name when !schema_exists_ref name ->
1673 let codec = format_jsont_ref ~current_prefix name in
1674 Some (err.status_code, codec, name)
1675 | _ -> None
1676 ) op.error_responses in
1677
1678 let error_handling =
1679 if valid_error_responses = [] then
1680 (* No typed errors - simple error with parsed JSON fallback *)
1681 {|let body = Requests.Response.text response in
1682 let parsed_body =
1683 match Jsont_bytesrw.decode_string Jsont.json body with
1684 | Ok json -> Some (Openapi.Runtime.Json json)
1685 | Error _ -> Some (Openapi.Runtime.Raw body)
1686 in
1687 raise (Openapi.Runtime.Api_error {
1688 operation = op_name;
1689 method_ = |} ^ Printf.sprintf "%S" op.method_ ^ {|;
1690 url;
1691 status = Requests.Response.status_code response;
1692 body;
1693 parsed_body;
1694 })|}
1695 else
1696 (* Generate try-parse for each error type *)
1697 let parser_cases = List.map (fun (code, codec, ref_) ->
1698 Printf.sprintf {| | %s ->
1699 (match Openapi.Runtime.Json.decode_json %s (Requests.Response.json response) with
1700 | Ok v -> Some (Openapi.Runtime.Typed (%S, Openapi.Runtime.Json.encode_json %s v))
1701 | Error _ -> None)|}
1702 code codec ref_ codec
1703 ) valid_error_responses in
1704
1705 Printf.sprintf {|let body = Requests.Response.text response in
1706 let status = Requests.Response.status_code response in
1707 let parsed_body = match status with
1708%s
1709 | _ ->
1710 (match Jsont_bytesrw.decode_string Jsont.json body with
1711 | Ok json -> Some (Openapi.Runtime.Json json)
1712 | Error _ -> Some (Openapi.Runtime.Raw body))
1713 in
1714 raise (Openapi.Runtime.Api_error {
1715 operation = op_name;
1716 method_ = %S;
1717 url;
1718 status;
1719 body;
1720 parsed_body;
1721 })|}
1722 (String.concat "\n" parser_cases)
1723 op.method_
1724 in
1725
1726 Printf.sprintf {|%slet %s %s =
1727 let op_name = %S in
1728 let url_path = %s in
1729 let query = %s in
1730 let url = client.base_url ^ url_path ^ query in
1731 let response =
1732 try %s
1733 with Eio.Io _ as ex ->
1734 let bt = Printexc.get_raw_backtrace () in
1735 Eio.Exn.reraise_with_context ex bt "calling %%s %%s" %S url
1736 in
1737 if Requests.Response.ok response then
1738 %s
1739 else
1740 %s|}
1741 full_doc op.func_name (String.concat " " all_args)
1742 op.func_name path_render query_build http_call op.method_ decode error_handling
1743
1744(** Format a type reference, stripping the current_prefix if present *)
1745let format_type_ref ~current_prefix (schema_ref : string) : string =
1746 let prefix, suffix = Name.split_schema_name schema_ref in
1747 let prefix_mod = Name.to_module_name prefix in
1748 let suffix_mod = Name.to_module_name suffix in
1749 if prefix_mod = current_prefix then
1750 (* Local reference - use unqualified name *)
1751 Printf.sprintf "%s.t" suffix_mod
1752 else if is_forward_ref prefix_mod then
1753 (* Forward reference to module not yet defined - use Jsont.json *)
1754 "Jsont.json"
1755 else
1756 Printf.sprintf "%s.%s.t" prefix_mod suffix_mod
1757
1758let gen_operation_intf ~current_prefix (op : operation_info) : string =
1759 let doc = format_doc_block ~summary:op.summary ?description:op.description () in
1760 let param_docs = String.concat ""
1761 ((List.map (fun (n, _, d, _) -> format_param_doc n d) op.path_params) @
1762 (List.map (fun (n, _, d, _) -> format_param_doc n d) op.query_params)) in
1763 let full_doc = if param_docs = "" then doc
1764 else if doc = "" then Printf.sprintf "(**\n%s*)\n" param_docs
1765 else String.sub doc 0 (String.length doc - 3) ^ "\n" ^ param_docs ^ "*)\n" in
1766
1767 (* Only use body/response refs if schema actually exists *)
1768 let valid_body_ref = match op.body_schema_ref with
1769 | Some name when !schema_exists_ref name -> Some name
1770 | _ -> None
1771 in
1772 let valid_response_ref = match op.response_schema_ref with
1773 | Some name when !schema_exists_ref name -> Some name
1774 | _ -> None
1775 in
1776
1777 let path_args = List.map (fun (n, _, _, _) -> Printf.sprintf "%s:string" n) op.path_params in
1778 let query_args = List.map (fun (n, _, _, req) ->
1779 if req then Printf.sprintf "%s:string" n else Printf.sprintf "?%s:string" n
1780 ) op.query_params in
1781 let method_supports_body = not (List.mem op.method_ ["DELETE"; "HEAD"; "OPTIONS"]) in
1782 let body_arg = match valid_body_ref, method_supports_body with
1783 | Some name, true -> [Printf.sprintf "body:%s" (format_type_ref ~current_prefix name)]
1784 | _ -> []
1785 in
1786 let response_type = match valid_response_ref with
1787 | Some name -> format_type_ref ~current_prefix name
1788 | None -> "Jsont.json"
1789 in
1790 let all_args = path_args @ query_args @ body_arg @ ["t"; "unit"; response_type] in
1791
1792 Printf.sprintf "%sval %s : %s" full_doc op.func_name (String.concat " -> " all_args)
1793
1794(** {1 Two-Phase Module Generation}
1795
1796 To solve the module ordering problem for union types that reference multiple
1797 schemas, we use a two-phase generation approach within each prefix module:
1798
1799 Phase 1 - Types module: Generate all type definitions first, ordered only by
1800 TYPE dependencies (A.t contains B.t). No codec dependencies matter here.
1801
1802 Phase 2 - Full modules: Generate full modules with [include Types.X] plus
1803 codecs. These are ordered by CODEC dependencies (A.jsont uses B.jsont).
1804 Since all types exist in the Types module, any type can be referenced.
1805 Since codecs are ordered by their own dependencies, any needed codec
1806 exists when referenced.
1807
1808 This allows union types to reference multiple sibling schemas' codecs
1809 without forward reference issues. *)
1810
1811(** {2 Phase 1: Type-Only Generation} *)
1812
1813(** Generate type-only content for an enum schema (for Types module) *)
1814let gen_enum_type_only (schema : schema_info) : string =
1815 let doc = format_doc schema.description in
1816 if schema.enum_variants = [] then
1817 Printf.sprintf "%stype t = string" doc
1818 else
1819 Printf.sprintf "%stype t = [\n%s\n]" doc
1820 (String.concat "\n" (List.map (fun (v, _) -> " | `" ^ v) schema.enum_variants))
1821
1822(** Generate type-only content for a union schema (for Types module).
1823 Type references use Types.Sibling.t format within the Types module. *)
1824let gen_union_type_only ~current_prefix (schema : schema_info) : string =
1825 match schema.union_info with
1826 | None -> failwith "gen_union_type_only called on non-union schema"
1827 | Some union ->
1828 let doc = format_doc schema.description in
1829 (* In Types module, reference siblings as Sibling.t (same namespace) *)
1830 let format_type_in_types (schema_ref : string) : string =
1831 let prefix, suffix = Name.split_schema_name schema_ref in
1832 let prefix_mod = Name.to_module_name prefix in
1833 let suffix_mod = Name.to_module_name suffix in
1834 if prefix_mod = current_prefix then
1835 Printf.sprintf "%s.t" suffix_mod
1836 else if is_forward_ref prefix_mod then
1837 "Jsont.json" (* Cross-prefix forward ref *)
1838 else
1839 Printf.sprintf "%s.%s.t" prefix_mod suffix_mod
1840 in
1841 Printf.sprintf "%stype t =\n%s" doc
1842 (String.concat "\n" (List.map (fun (v : union_variant) ->
1843 Printf.sprintf " | %s of %s" v.variant_name (format_type_in_types v.schema_ref)
1844 ) union.variants))
1845
1846(** Generate type-only content for a record schema (for Types module) *)
1847let gen_record_type_only ~current_prefix ~current_suffix (schema : schema_info) : string =
1848 let is_forward_reference type_str =
1849 match String.split_on_char '.' type_str with
1850 | prefix :: _ when prefix <> current_prefix && is_forward_ref prefix -> true
1851 | _ -> false
1852 in
1853 let loc_type s =
1854 let localized = localize_type ~current_prefix ~current_suffix s in
1855 if schema.is_recursive && localized = "t" then "Jsont.json"
1856 else if schema.is_recursive && localized = "t list" then "Jsont.json list"
1857 else if schema.is_recursive && localized = "t option" then "Jsont.json option"
1858 else if schema.is_recursive && localized = "t list option" then "Jsont.json list option"
1859 else if is_forward_reference s then
1860 if String.ends_with ~suffix:" option" localized then "Jsont.json option"
1861 else if String.ends_with ~suffix:" list" localized then "Jsont.json list"
1862 else if String.ends_with ~suffix:" list option" localized then "Jsont.json list option"
1863 else "Jsont.json"
1864 else localized
1865 in
1866 let doc = format_doc schema.description in
1867 if schema.fields = [] then
1868 Printf.sprintf "%stype t = Jsont.json" doc
1869 else
1870 let type_fields = String.concat "\n" (List.map (fun (f : field_info) ->
1871 let field_doc = match f.description with
1872 | Some d -> Printf.sprintf " (** %s *)" (escape_doc d)
1873 | None -> ""
1874 in
1875 Printf.sprintf " %s : %s;%s" f.ocaml_name (loc_type f.ocaml_type) field_doc
1876 ) schema.fields) in
1877 Printf.sprintf "%stype t = {\n%s\n}" doc type_fields
1878
1879(** Generate a type-only submodule for the Types module *)
1880let gen_type_only_submodule ~current_prefix (schema : schema_info) : string =
1881 let suffix_mod = Name.to_module_name schema.suffix in
1882 let content =
1883 if schema.is_union then gen_union_type_only ~current_prefix schema
1884 else if schema.is_enum then gen_enum_type_only schema
1885 else gen_record_type_only ~current_prefix ~current_suffix:suffix_mod schema
1886 in
1887 let indented = String.split_on_char '\n' content |> List.map (fun l -> " " ^ l) |> String.concat "\n" in
1888 Printf.sprintf " module %s = struct\n%s\n end" suffix_mod indented
1889
1890(** {2 Phase 2: Codec-Only Generation (with include Types.X)} *)
1891
1892(** Generate codec content for an enum schema (includes Types.X) *)
1893let gen_enum_codec_only (schema : schema_info) : string =
1894 let suffix_mod = Name.to_module_name schema.suffix in
1895 if schema.enum_variants = [] then
1896 Printf.sprintf "include Types.%s\nlet jsont = Jsont.string" suffix_mod
1897 else
1898 let dec_cases = String.concat "\n" (List.map (fun (v, raw) ->
1899 Printf.sprintf " | %S -> `%s" raw v
1900 ) schema.enum_variants) in
1901 let enc_cases = String.concat "\n" (List.map (fun (v, raw) ->
1902 Printf.sprintf " | `%s -> %S" v raw
1903 ) schema.enum_variants) in
1904 Printf.sprintf {|include Types.%s
1905
1906let jsont : t Jsont.t =
1907 Jsont.map Jsont.string ~kind:%S
1908 ~dec:(function
1909%s
1910 | s -> Jsont.Error.msgf Jsont.Meta.none "Unknown value: %%s" s)
1911 ~enc:(function
1912%s)|} suffix_mod schema.original_name dec_cases enc_cases
1913
1914(** Generate codec content for a union schema (includes Types.X) *)
1915let gen_union_codec_only ~current_prefix (schema : schema_info) : string =
1916 match schema.union_info with
1917 | None -> failwith "gen_union_codec_only called on non-union schema"
1918 | Some union ->
1919 let suffix_mod = Name.to_module_name schema.suffix in
1920 (* Jsont codec - discriminator-based or try-each *)
1921 let jsont_code = match union.discriminator_field with
1922 | Some field -> gen_union_jsont_discriminator ~current_prefix schema union field
1923 | None -> gen_union_jsont_try_each ~current_prefix schema union
1924 in
1925 Printf.sprintf "include Types.%s\n\n%s" suffix_mod jsont_code
1926
1927(** Generate codec content for a record schema (includes Types.X) *)
1928let gen_record_codec_only ~current_prefix ~current_suffix (schema : schema_info) : string =
1929 let suffix_mod = Name.to_module_name schema.suffix in
1930 (* Note: loc_type is not needed here since types come from Types.X via include *)
1931 let is_forward_jsont_ref jsont_str =
1932 let s =
1933 if String.length jsont_str > 12 && String.sub jsont_str 0 12 = "(Jsont.list " then
1934 String.sub jsont_str 12 (String.length jsont_str - 13)
1935 else if String.length jsont_str > 31 && String.sub jsont_str 0 31 = "(Openapi.Runtime.nullable_any " then
1936 String.sub jsont_str 31 (String.length jsont_str - 32)
1937 else jsont_str
1938 in
1939 match String.split_on_char '.' s with
1940 | prefix :: _ when prefix <> current_prefix && is_forward_ref prefix -> true
1941 | _ -> false
1942 in
1943 let loc_jsont s =
1944 let localized = localize_jsont ~current_prefix ~current_suffix s in
1945 if schema.is_recursive && localized = "jsont" then "Jsont.json"
1946 else if schema.is_recursive && localized = "(Jsont.list jsont)" then "(Jsont.list Jsont.json)"
1947 else if is_forward_jsont_ref s then
1948 if String.length localized > 12 && String.sub localized 0 12 = "(Jsont.list " then "(Jsont.list Jsont.json)"
1949 else if String.length s > 31 && String.sub s 0 31 = "(Openapi.Runtime.nullable_any " then "Jsont.json"
1950 else "Jsont.json"
1951 else localized
1952 in
1953 if schema.fields = [] then
1954 Printf.sprintf "include Types.%s\nlet jsont = Jsont.json\nlet v () = Jsont.Null ((), Jsont.Meta.none)" suffix_mod
1955 else
1956 (* Constructor function v
1957 - Required fields (no default, not optional): ~field
1958 - Fields with defaults: ?(field=default)
1959 - Optional fields (no default, is_optional): ?field *)
1960 let required_fields = List.filter (fun (f : field_info) ->
1961 not f.is_optional && Option.is_none f.default_value
1962 ) schema.fields in
1963 let default_fields = List.filter (fun (f : field_info) ->
1964 Option.is_some f.default_value
1965 ) schema.fields in
1966 let optional_fields = List.filter (fun (f : field_info) ->
1967 f.is_optional && Option.is_none f.default_value
1968 ) schema.fields in
1969 let v_params =
1970 (List.map (fun (f : field_info) -> Printf.sprintf "~%s" f.ocaml_name) required_fields) @
1971 (List.map (fun (f : field_info) ->
1972 Printf.sprintf "?(%s=%s)" f.ocaml_name (Option.get f.default_value)
1973 ) default_fields) @
1974 (List.map (fun (f : field_info) -> Printf.sprintf "?%s" f.ocaml_name) optional_fields) @
1975 ["()"]
1976 in
1977 let v_body = String.concat "; " (List.map (fun (f : field_info) -> f.ocaml_name) schema.fields) in
1978 let v_func = Printf.sprintf "let v %s = { %s }" (String.concat " " v_params) v_body in
1979
1980 (* Accessor functions *)
1981 let accessors = String.concat "\n" (List.map (fun (f : field_info) ->
1982 Printf.sprintf "let %s t = t.%s" f.ocaml_name f.ocaml_name
1983 ) schema.fields) in
1984
1985 (* Jsont codec *)
1986 let make_params = String.concat " " (List.map (fun (f : field_info) -> f.ocaml_name) schema.fields) in
1987 let jsont_members = String.concat "\n" (List.map (fun (f : field_info) ->
1988 let base_codec =
1989 match f.field_union with
1990 | Some union -> jsont_of_field_union ~current_prefix union
1991 | None ->
1992 let raw_codec = jsont_of_base_type f.base_type in
1993 let localized = loc_jsont raw_codec in
1994 if has_constraints f.constraints then validated_jsont f.constraints localized f.base_type
1995 else localized
1996 in
1997 if f.is_nullable then
1998 let nullable_codec =
1999 match f.field_union with
2000 | Some _ -> Printf.sprintf "(Openapi.Runtime.nullable_any %s)" base_codec
2001 | None -> loc_jsont (nullable_jsont_of_base_type f.base_type)
2002 in
2003 (* For nullable fields, dec_absent depends on default:
2004 - No default: None (absent = null)
2005 - Default is "None" (JSON null): None
2006 - Default is a value: (Some value) *)
2007 let dec_absent = match f.default_value with
2008 | Some "None" -> "None" (* Default is null *)
2009 | Some def -> Printf.sprintf "(Some %s)" def
2010 | None -> "None"
2011 in
2012 Printf.sprintf " |> Jsont.Object.mem %S %s\n ~dec_absent:%s ~enc_omit:Option.is_none ~enc:(fun r -> r.%s)"
2013 f.json_name nullable_codec dec_absent f.ocaml_name
2014 else if f.is_optional then
2015 (* Optional non-nullable field without default - use opt_mem *)
2016 Printf.sprintf " |> Jsont.Object.opt_mem %S %s ~enc:(fun r -> r.%s)"
2017 f.json_name base_codec f.ocaml_name
2018 else
2019 (* Required or has default - use mem, possibly with dec_absent *)
2020 (match f.default_value with
2021 | Some def ->
2022 Printf.sprintf " |> Jsont.Object.mem %S %s ~dec_absent:%s ~enc:(fun r -> r.%s)"
2023 f.json_name base_codec def f.ocaml_name
2024 | None ->
2025 Printf.sprintf " |> Jsont.Object.mem %S %s ~enc:(fun r -> r.%s)"
2026 f.json_name base_codec f.ocaml_name)
2027 ) schema.fields) in
2028
2029 Printf.sprintf {|include Types.%s
2030
2031%s
2032
2033%s
2034
2035let jsont : t Jsont.t =
2036 Jsont.Object.map ~kind:%S
2037 (fun %s -> { %s })
2038%s
2039 |> Jsont.Object.skip_unknown
2040 |> Jsont.Object.finish|}
2041 suffix_mod v_func accessors schema.original_name make_params v_body jsont_members
2042
2043(** Generate a codec-only submodule (uses include Types.X) *)
2044let gen_codec_only_submodule ~current_prefix (schema : schema_info) : string =
2045 let suffix_mod = Name.to_module_name schema.suffix in
2046 let content =
2047 if schema.is_union then gen_union_codec_only ~current_prefix schema
2048 else if schema.is_enum then gen_enum_codec_only schema
2049 else gen_record_codec_only ~current_prefix ~current_suffix:suffix_mod schema
2050 in
2051 let indented = String.split_on_char '\n' content |> List.map (fun l -> " " ^ l) |> String.concat "\n" in
2052 Printf.sprintf "module %s = struct\n%s\nend" suffix_mod indented
2053
2054(** {2 Codec Dependency Extraction}
2055
2056 For the two-phase approach, we need to order codecs by their codec dependencies
2057 (which codecs reference other codecs), separate from type dependencies. *)
2058
2059(** Extract codec dependencies for a schema - which sibling codecs does this schema's codec reference? *)
2060let schema_codec_deps ~current_prefix (schema : schema_info) : string list =
2061 (* For union types, the codec references all variant codecs *)
2062 let union_deps = match schema.union_info with
2063 | None -> []
2064 | Some union ->
2065 List.filter_map (fun (v : union_variant) ->
2066 let prefix, suffix = Name.split_schema_name v.schema_ref in
2067 let prefix_mod = Name.to_module_name prefix in
2068 if prefix_mod = current_prefix then
2069 Some (Name.to_module_name suffix)
2070 else None
2071 ) union.variants
2072 in
2073 (* For records, codecs reference field type codecs *)
2074 let field_deps = List.filter_map (fun (f : field_info) ->
2075 if String.contains f.base_type '.' then
2076 match String.split_on_char '.' f.base_type with
2077 | prefix :: suffix :: _ when prefix = current_prefix ->
2078 Some (Name.to_module_name suffix)
2079 | _ -> None
2080 else None
2081 ) schema.fields in
2082 union_deps @ field_deps |> List.sort_uniq String.compare
2083
2084(** {1 Full Module Generation} *)
2085
2086let gen_submodule_impl ~current_prefix (schema : schema_info) : string =
2087 let suffix_mod = Name.to_module_name schema.suffix in
2088 let content =
2089 if schema.is_union then gen_union_impl ~current_prefix schema
2090 else if schema.is_enum then gen_enum_impl schema
2091 else gen_record_impl ~current_prefix ~current_suffix:suffix_mod schema in
2092 let indented = String.split_on_char '\n' content |> List.map (fun l -> " " ^ l) |> String.concat "\n" in
2093 Printf.sprintf "module %s = struct\n%s\nend" suffix_mod indented
2094
2095let gen_submodule_intf ~current_prefix (schema : schema_info) : string =
2096 let suffix_mod = Name.to_module_name schema.suffix in
2097 let content =
2098 if schema.is_union then gen_union_intf ~current_prefix schema
2099 else if schema.is_enum then gen_enum_intf schema
2100 else gen_record_intf ~current_prefix ~current_suffix:suffix_mod schema in
2101 let indented = String.split_on_char '\n' content |> List.map (fun l -> " " ^ l) |> String.concat "\n" in
2102 Printf.sprintf "module %s : sig\n%s\nend" suffix_mod indented
2103
2104(** Extract suffix module dependencies within the same prefix *)
2105let schema_suffix_deps ~current_prefix (schema : schema_info) : string list =
2106 List.filter_map (fun (f : field_info) ->
2107 (* Check if the type references a sibling module (same prefix) *)
2108 if String.contains f.base_type '.' then
2109 match String.split_on_char '.' f.base_type with
2110 | prefix :: suffix :: _ when prefix = current_prefix ->
2111 Some (Name.to_module_name suffix)
2112 | _ -> None
2113 else None
2114 ) schema.fields
2115
2116(** Sort schemas within a prefix module by their TYPE dependencies.
2117 Used for ordering types in the Types module. *)
2118let sort_schemas_by_type_deps ~current_prefix (schemas : schema_info list) : schema_info list =
2119 let suffix_of schema = Name.to_module_name schema.suffix in
2120 let suffix_names = List.map suffix_of schemas in
2121 let deps_of suffix =
2122 match List.find_opt (fun s -> suffix_of s = suffix) schemas with
2123 | Some schema -> schema_suffix_deps ~current_prefix schema |> List.filter (fun d -> List.mem d suffix_names)
2124 | None -> []
2125 in
2126 let sorted = topological_sort suffix_names deps_of in
2127 List.filter_map (fun suffix ->
2128 List.find_opt (fun s -> suffix_of s = suffix) schemas
2129 ) sorted
2130
2131(** Sort schemas within a prefix module by their CODEC dependencies.
2132 Used for ordering full modules with codecs. *)
2133let sort_schemas_by_codec_deps ~current_prefix (schemas : schema_info list) : schema_info list =
2134 let suffix_of schema = Name.to_module_name schema.suffix in
2135 let suffix_names = List.map suffix_of schemas in
2136 let deps_of suffix =
2137 match List.find_opt (fun s -> suffix_of s = suffix) schemas with
2138 | Some schema -> schema_codec_deps ~current_prefix schema |> List.filter (fun d -> List.mem d suffix_names)
2139 | None -> []
2140 in
2141 let sorted = topological_sort suffix_names deps_of in
2142 List.filter_map (fun suffix ->
2143 List.find_opt (fun s -> suffix_of s = suffix) schemas
2144 ) sorted
2145
2146(** Generate a prefix module using two-phase generation:
2147 Phase 1: Types module with all type definitions
2148 Phase 2: Full modules with include Types.X + codecs *)
2149let gen_prefix_module_impl (node : module_node) : string =
2150 if node.schemas = [] then
2151 (* No schemas - just generate operations *)
2152 let op_impls = List.map (gen_operation_impl ~current_prefix:node.name) (List.rev node.operations) in
2153 if op_impls = [] then
2154 Printf.sprintf "module %s = struct\nend" node.name
2155 else
2156 let content = String.concat "\n\n" op_impls in
2157 let indented = String.split_on_char '\n' content |> List.map (fun l -> " " ^ l) |> String.concat "\n" in
2158 Printf.sprintf "module %s = struct\n%s\nend" node.name indented
2159 else
2160 (* Phase 1: Generate Types module with all type definitions *)
2161 let type_sorted_schemas = sort_schemas_by_type_deps ~current_prefix:node.name node.schemas in
2162 let type_mods = List.map (gen_type_only_submodule ~current_prefix:node.name) type_sorted_schemas in
2163 let types_content = String.concat "\n\n" type_mods in
2164 let types_module = Printf.sprintf "module Types = struct\n%s\nend" types_content in
2165
2166 (* Phase 2: Generate full modules with codecs, sorted by codec dependencies *)
2167 let codec_sorted_schemas = sort_schemas_by_codec_deps ~current_prefix:node.name node.schemas in
2168 let codec_mods = List.map (gen_codec_only_submodule ~current_prefix:node.name) codec_sorted_schemas in
2169
2170 (* Operations *)
2171 let op_impls = List.map (gen_operation_impl ~current_prefix:node.name) (List.rev node.operations) in
2172
2173 let content = String.concat "\n\n" ([types_module] @ codec_mods @ op_impls) in
2174 let indented = String.split_on_char '\n' content |> List.map (fun l -> " " ^ l) |> String.concat "\n" in
2175 Printf.sprintf "module %s = struct\n%s\nend" node.name indented
2176
2177let gen_prefix_module_intf (node : module_node) : string =
2178 (* For interfaces, we don't need the two-phase approach.
2179 Just sort by type dependencies and generate full interfaces. *)
2180 let sorted_schemas = sort_schemas_by_type_deps ~current_prefix:node.name node.schemas in
2181 let schema_mods = List.map (gen_submodule_intf ~current_prefix:node.name) sorted_schemas in
2182 let op_intfs = List.map (gen_operation_intf ~current_prefix:node.name) (List.rev node.operations) in
2183 let content = String.concat "\n\n" (schema_mods @ op_intfs) in
2184 let indented = String.split_on_char '\n' content |> List.map (fun l -> " " ^ l) |> String.concat "\n" in
2185 Printf.sprintf "module %s : sig\n%s\nend" node.name indented
2186
2187(** {1 Top-Level Generation} *)
2188
2189type config = {
2190 output_dir : string;
2191 package_name : string;
2192 spec_path : string option;
2193}
2194
2195let generate_ml (spec : Spec.t) (package_name : string) : string =
2196 let api_desc = Option.value ~default:"Generated API client." spec.info.description in
2197
2198 (* Collect schemas *)
2199 let schemas = match spec.components with
2200 | None -> []
2201 | Some c -> List.filter_map (fun (name, sor) ->
2202 match sor with
2203 | Spec.Ref _ -> None
2204 | Spec.Value s -> Some (analyze_schema ~components:spec.components name s)
2205 ) c.schemas
2206 in
2207
2208 (* Set known schemas for validation during code generation *)
2209 set_known_schemas schemas;
2210
2211 (* Collect operations *)
2212 let operations = List.concat_map (fun (path, (pi : Spec.path_item)) ->
2213 let path_item_params = pi.parameters in
2214 let ops = [
2215 ("GET", pi.Spec.get); ("POST", pi.post); ("PUT", pi.put);
2216 ("DELETE", pi.delete); ("PATCH", pi.patch);
2217 ("HEAD", pi.head); ("OPTIONS", pi.options);
2218 ] in
2219 List.filter_map (fun (method_, op_opt) ->
2220 Option.map (fun op -> analyze_operation ~spec ~path_item_params ~path ~method_ op) op_opt
2221 ) ops
2222 ) spec.paths in
2223
2224 (* Build module tree *)
2225 let (tree, sorted_modules) = build_module_tree schemas operations in
2226
2227 (* Generate top-level client type and functions *)
2228 let client_impl = {|type t = {
2229 session : Requests.t;
2230 base_url : string;
2231}
2232
2233let create ?session ~sw env ~base_url =
2234 let session = match session with
2235 | Some s -> s
2236 | None -> Requests.create ~sw env
2237 in
2238 { session; base_url }
2239
2240let base_url t = t.base_url
2241let session t = t.session|} in
2242
2243 (* Generate prefix modules in dependency order, tracking forward references *)
2244 let rec gen_with_forward_refs remaining_modules acc =
2245 match remaining_modules with
2246 | [] -> List.rev acc
2247 | name :: rest ->
2248 (* Set forward refs to modules that come after this one *)
2249 set_forward_refs rest;
2250 let result = match StringMap.find_opt name tree.children with
2251 | None -> None
2252 | Some node ->
2253 if node.name = "Client" then
2254 (* Generate Client operations inline *)
2255 let ops = List.map (gen_operation_impl ~current_prefix:"Client") (List.rev node.operations) in
2256 if ops = [] then None
2257 else
2258 let content = String.concat "\n\n" ops in
2259 let indented = String.split_on_char '\n' content |> List.map (fun l -> " " ^ l) |> String.concat "\n" in
2260 Some (Printf.sprintf "module Client = struct\n%s\nend" indented)
2261 else
2262 Some (gen_prefix_module_impl node)
2263 in
2264 gen_with_forward_refs rest (match result with Some r -> r :: acc | None -> acc)
2265 in
2266 let prefix_mods = gen_with_forward_refs sorted_modules [] in
2267
2268 Printf.sprintf {|(** {1 %s}
2269
2270 %s
2271
2272 @version %s *)
2273
2274%s
2275
2276%s
2277|}
2278 (Name.to_module_name package_name) (escape_doc api_desc) spec.info.version
2279 client_impl (String.concat "\n\n" prefix_mods)
2280
2281let generate_mli (spec : Spec.t) (package_name : string) : string =
2282 let api_desc = Option.value ~default:"Generated API client." spec.info.description in
2283
2284 (* Collect schemas *)
2285 let schemas = match spec.components with
2286 | None -> []
2287 | Some c -> List.filter_map (fun (name, sor) ->
2288 match sor with
2289 | Spec.Ref _ -> None
2290 | Spec.Value s -> Some (analyze_schema ~components:spec.components name s)
2291 ) c.schemas
2292 in
2293
2294 (* Set known schemas for validation during code generation *)
2295 set_known_schemas schemas;
2296
2297 (* Collect operations *)
2298 let operations = List.concat_map (fun (path, (pi : Spec.path_item)) ->
2299 let path_item_params = pi.parameters in
2300 let ops = [
2301 ("GET", pi.Spec.get); ("POST", pi.post); ("PUT", pi.put);
2302 ("DELETE", pi.delete); ("PATCH", pi.patch);
2303 ("HEAD", pi.head); ("OPTIONS", pi.options);
2304 ] in
2305 List.filter_map (fun (method_, op_opt) ->
2306 Option.map (fun op -> analyze_operation ~spec ~path_item_params ~path ~method_ op) op_opt
2307 ) ops
2308 ) spec.paths in
2309
2310 (* Build module tree *)
2311 let (tree, sorted_modules) = build_module_tree schemas operations in
2312
2313 (* Generate top-level client type and function interfaces *)
2314 let client_intf = {|type t
2315
2316val create :
2317 ?session:Requests.t ->
2318 sw:Eio.Switch.t ->
2319 < net : _ Eio.Net.t ; fs : Eio.Fs.dir_ty Eio.Path.t ; clock : _ Eio.Time.clock ; .. > ->
2320 base_url:string ->
2321 t
2322
2323val base_url : t -> string
2324val session : t -> Requests.t|} in
2325
2326 (* Generate prefix modules in dependency order, tracking forward references *)
2327 let rec gen_with_forward_refs remaining_modules acc =
2328 match remaining_modules with
2329 | [] -> List.rev acc
2330 | name :: rest ->
2331 (* Set forward refs to modules that come after this one *)
2332 set_forward_refs rest;
2333 let result = match StringMap.find_opt name tree.children with
2334 | None -> None
2335 | Some node ->
2336 if node.name = "Client" then
2337 let ops = List.map (gen_operation_intf ~current_prefix:"Client") (List.rev node.operations) in
2338 if ops = [] then None
2339 else
2340 let content = String.concat "\n\n" ops in
2341 let indented = String.split_on_char '\n' content |> List.map (fun l -> " " ^ l) |> String.concat "\n" in
2342 Some (Printf.sprintf "module Client : sig\n%s\nend" indented)
2343 else
2344 Some (gen_prefix_module_intf node)
2345 in
2346 gen_with_forward_refs rest (match result with Some r -> r :: acc | None -> acc)
2347 in
2348 let prefix_mods = gen_with_forward_refs sorted_modules [] in
2349
2350 Printf.sprintf {|(** {1 %s}
2351
2352 %s
2353
2354 @version %s *)
2355
2356%s
2357
2358%s
2359|}
2360 (Name.to_module_name package_name) (escape_doc api_desc) spec.info.version
2361 client_intf (String.concat "\n\n" prefix_mods)
2362
2363let generate_dune (package_name : string) : string =
2364 Printf.sprintf {|(library
2365 (name %s)
2366 (public_name %s)
2367 (libraries openapi jsont jsont.bytesrw requests ptime eio)
2368 (wrapped true))
2369
2370(include dune.inc)
2371|} package_name package_name
2372
2373let generate_dune_inc ~(spec_path : string option) (package_name : string) : string =
2374 match spec_path with
2375 | None -> "; No spec path provided - regeneration rules not generated\n"
2376 | Some path ->
2377 Printf.sprintf {|; Generated rules for OpenAPI code regeneration
2378; Run: dune build @gen --auto-promote
2379
2380(rule
2381 (alias gen)
2382 (mode (promote (until-clean)))
2383 (targets %s.ml %s.mli)
2384 (deps %s)
2385 (action
2386 (run openapi-gen generate -o . -n %s %%{deps})))
2387|} package_name package_name path package_name
2388
2389let generate ~(config : config) (spec : Spec.t) : (string * string) list =
2390 let package_name = config.package_name in
2391 [
2392 ("dune", generate_dune package_name);
2393 ("dune.inc", generate_dune_inc ~spec_path:config.spec_path package_name);
2394 (package_name ^ ".ml", generate_ml spec package_name);
2395 (package_name ^ ".mli", generate_mli spec package_name);
2396 ]
2397
2398let write_files ~(output_dir : string) (files : (string * string) list) : unit =
2399 List.iter (fun (filename, content) ->
2400 let path = Filename.concat output_dir filename in
2401 let oc = open_out path in
2402 output_string oc content;
2403 close_out oc
2404 ) files