anil.recoil.org
OpenAPI generator for OCaml with Requests/Eio/Jsont
Add default values, validation, and field-level unions to OpenAPI generator
- Add default value support: extract JSON defaults and generate OCaml literals
for bools, ints, floats, strings, enums, null, and empty arrays
- Generate constructors with optional params using ?(name=default) syntax
- Generate jsont codecs with ~dec_absent:default for absent field handling
- Add runtime validation for strings (minLength, maxLength, pattern),
numbers (minimum, maximum, exclusiveMinimum, exclusiveMaximum),
and lists (minItems, maxItems, uniqueItems)
- Add field-level union types for primitive oneOf/anyOf schemas
- Handle forward references in circular dependencies with Jsont.json fallback
- Improve topological sort to handle cycles gracefully
- Regenerate immich and peertube clients with new features
Co-Authored-By: Claude Opus 4.5 <noreply@anthropic.com>
+197
OPENAPI_ROADMAP.md
+197
OPENAPI_ROADMAP.md
···
1
+
# OpenAPI Code Generator Roadmap
2
+
3
+
This document outlines future enhancements for the OCaml OpenAPI code generator.
4
+
5
+
## Recently Completed
6
+
7
+
### Union Type Generation (v0.2)
8
+
- Generate OCaml variant types for `oneOf`/`anyOf` schemas at the top level
9
+
- Support discriminator-based codec (using `Jsont.Object.Case`)
10
+
- Support try-each codec for schemas without discriminators
11
+
- Currently handles schema-level unions; field-level unions fallback to `Jsont.json`
12
+
13
+
### Typed Error Responses (v0.2)
14
+
- Enhanced `api_error` type with `parsed_body` field
15
+
- `error_body` type: `Raw`, `Json`, or `Typed` variants
16
+
- Generate error parsing code for operations with typed error schemas
17
+
- Fallback to JSON/raw parsing for untyped errors
18
+
19
+
### Field-Level Union Types (v0.3)
20
+
- Detect `oneOf`/`anyOf` in property definitions
21
+
- For primitive-only unions (string|int|bool), generate polymorphic variants
22
+
- For unions with schema references, fall back to `Jsont.json` due to module ordering constraints
23
+
- Example: `oneOf: [{type: string}, {type: integer}]` → `[ \`String of string | \`Int of int ]`
24
+
25
+
### Runtime Validation (v0.3)
26
+
- Added validation functions: `validated_string`, `validated_int`, `validated_float`, `validated_list`
27
+
- String validation: `minLength`, `maxLength`, `pattern` (using Re library with PCRE syntax)
28
+
- Number validation: `minimum`, `maximum`, `exclusiveMinimum`, `exclusiveMaximum`
29
+
- List validation: `minItems`, `maxItems`, `uniqueItems`
30
+
- Validation errors reported via `Jsont.Error.msgf`
31
+
- Added `poly_union_decoder` helper for polymorphic variant union types
32
+
33
+
### Two-Phase Module Generation (v0.4)
34
+
- Solved the module ordering problem for union types referencing sibling schemas
35
+
- Each prefix module now uses a two-phase structure:
36
+
- **Phase 1 (Types module)**: All type definitions, ordered by TYPE dependencies
37
+
- **Phase 2 (Full modules)**: Full modules with `include Types.X` + codecs, ordered by CODEC dependencies
38
+
- Benefits:
39
+
- Types can reference any sibling type (they're all in the same Types module)
40
+
- Codecs can reference any sibling codec (properly ordered by codec dependencies)
41
+
- Union type codecs can now use try-each decoding across multiple sibling schemas
42
+
- Generated structure:
43
+
```ocaml
44
+
module Prefix = struct
45
+
module Types = struct
46
+
module Schema_a = struct type t = { ... } end
47
+
module Union_c = struct type t = A of Schema_a.t | B of Schema_b.t end
48
+
end
49
+
module Schema_a = struct include Types.Schema_a let jsont = ... end
50
+
module Union_c = struct include Types.Union_c let jsont = (* uses Schema_a.jsont *) end
51
+
end
52
+
```
53
+
- Preserves the user-facing API: `Prefix.Schema.t`, `Prefix.Schema.jsont`, etc.
54
+
55
+
## Planned Enhancements
56
+
57
+
### 1. Streaming Support
58
+
59
+
**Priority:** High
60
+
61
+
Add support for `text/event-stream` media type handling for Server-Sent Events.
62
+
63
+
**Requirements:**
64
+
- Detect SSE endpoints in OpenAPI spec
65
+
- Generate async iterator types for streaming responses
66
+
- Requires `requests` library enhancement for chunked/streaming reads
67
+
68
+
**Target API:**
69
+
```ocaml
70
+
val stream_events :
71
+
t -> unit ->
72
+
(Event.t, Openapi.Runtime.api_error) Seq.t
73
+
```
74
+
75
+
### 2. File Upload Support
76
+
77
+
**Priority:** High
78
+
79
+
Handle `multipart/form-data` with binary parts for file uploads.
80
+
81
+
**Requirements:**
82
+
- Detect multipart endpoints in spec
83
+
- Generate proper file upload functions accepting `Eio.Flow.source`
84
+
- Requires `requests` library multipart encoding support
85
+
86
+
**Target API:**
87
+
```ocaml
88
+
val upload_file :
89
+
filename:string ->
90
+
content_type:string ->
91
+
body:_ Eio.Flow.source ->
92
+
t -> unit ->
93
+
UploadResponse.t
94
+
```
95
+
96
+
### 3. Authentication Code Generation
97
+
98
+
**Priority:** Medium
99
+
100
+
Generate auth header injection based on `securitySchemes`.
101
+
102
+
**Supported schemes:**
103
+
- `apiKey` (header, query, cookie)
104
+
- `http` (basic, bearer)
105
+
- `oauth2` flows (implicit, password, clientCredentials, authorizationCode)
106
+
- `openIdConnect`
107
+
108
+
**Target API:**
109
+
```ocaml
110
+
module Auth : sig
111
+
type t =
112
+
| Api_key of string
113
+
| Bearer of string
114
+
| Basic of { username: string; password: string }
115
+
| OAuth2 of { access_token: string; refresh_token: string option }
116
+
117
+
val with_auth : t -> client -> client
118
+
end
119
+
```
120
+
121
+
### 4. Additional Schema Features
122
+
123
+
**Priority:** Medium
124
+
125
+
#### 4.1 `additionalProperties`
126
+
Convert to OCaml string maps:
127
+
```ocaml
128
+
type t = { known_field: string; extra: Jsont.json StringMap.t }
129
+
```
130
+
131
+
#### 4.2 `const`
132
+
Generate literal type validation or unit variants.
133
+
134
+
#### 4.3 `default`
135
+
Handle default values for optional fields:
136
+
- Make fields with defaults optional in constructors
137
+
- Use the default value when field is absent during decoding
138
+
- Consider generating builder-style constructors for complex schemas
139
+
140
+
#### 4.4 `readOnly`/`writeOnly`
141
+
Generate separate request/response types when fields differ.
142
+
143
+
### 5. Requests Library Enhancements
144
+
145
+
**Priority:** Varies
146
+
147
+
These depend on enhancements to the `requests` library:
148
+
149
+
| Feature | Requests Support | OpenAPI Use Case |
150
+
|---------|-----------------|------------------|
151
+
| Streaming responses | Needed | SSE, large downloads |
152
+
| Multipart form data | Needed | File uploads |
153
+
| Connection pooling | Nice to have | Performance |
154
+
| Retry with backoff | Nice to have | Resilience |
155
+
| WebSocket | Future | Real-time APIs |
156
+
157
+
## Architecture Notes
158
+
159
+
### Current Module Structure
160
+
```
161
+
openapi
162
+
├── Spec -- OpenAPI 3.x types
163
+
├── Codegen -- Code generation
164
+
├── Runtime -- Runtime utilities
165
+
└── Nestjs -- NestJS error handling
166
+
```
167
+
168
+
### Generated Code Structure
169
+
```
170
+
generated_client
171
+
├── t -- Client type
172
+
├── create -- Constructor
173
+
└── Module1 -- Per-prefix modules
174
+
├── Schema1 -- Per-schema submodules
175
+
│ ├── t
176
+
│ ├── jsont
177
+
│ └── accessors
178
+
└── operation1 -- Operations
179
+
```
180
+
181
+
### Design Principles
182
+
183
+
1. **Type safety over flexibility**: Prefer typed codecs over `Jsont.json`
184
+
2. **Minimal runtime**: Keep `Runtime` module small
185
+
3. **Idiomatic OCaml**: Use modules, not objects
186
+
4. **Eio-native**: No blocking IO, cooperative concurrency
187
+
5. **Forward-compatible**: Handle unknown fields gracefully
188
+
189
+
## Contributing
190
+
191
+
To add a new feature:
192
+
193
+
1. Update `openapi_spec.ml` if new OpenAPI fields are needed
194
+
2. Update `openapi_codegen.ml` with analysis and generation
195
+
3. Update `openapi_runtime.ml` if new runtime support is needed
196
+
4. Regenerate test specs: `dune exec openapi-gen -- generate ...`
197
+
5. Verify with `dune build @check` and `dune build @doc`
+1
-1
lib/dune
+1
-1
lib/dune
+1241
-145
lib/openapi_codegen.ml
+1241
-145
lib/openapi_codegen.ml
···
236
236
module StringMap = Map.Make(String)
237
237
module StringSet = Set.Make(String)
238
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
+
244
+
let forward_refs : StringSet.t ref = ref StringSet.empty
245
+
246
+
let set_forward_refs mods = forward_refs := StringSet.of_list mods
247
+
248
+
let is_forward_ref module_name =
249
+
StringSet.mem module_name !forward_refs
250
+
239
251
(** {1 Topological Sort} *)
240
252
241
253
(** Kahn's algorithm for topological sorting.
···
266
278
let queue = List.filter (fun n ->
267
279
StringMap.find n in_degree = 0
268
280
) nodes in
269
-
let rec process queue in_degree result =
281
+
let rec process queue in_degree result processed =
270
282
match queue with
271
-
| [] -> List.rev result
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)
272
303
| node :: rest ->
273
304
let result = node :: result in
305
+
let processed = StringSet.add node processed in
274
306
let dependents = Option.value ~default:[] (StringMap.find_opt node adj) in
275
307
let (queue', in_degree) = List.fold_left (fun (q, deg) dep ->
276
-
let new_deg = StringMap.find dep deg - 1 in
277
-
let deg = StringMap.add dep new_deg deg in
278
-
if new_deg = 0 then (dep :: q, deg) else (q, deg)
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)
279
313
) (rest, in_degree) dependents in
280
-
process queue' in_degree result
314
+
process queue' in_degree result processed
281
315
in
282
-
process queue in_degree []
316
+
process queue in_degree [] StringSet.empty
317
+
318
+
(** Validation constraints extracted from JSON Schema *)
319
+
type 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
+
332
+
let 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
+
339
+
let 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 *)
346
+
type 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 *)
351
+
type field_union_info = {
352
+
field_variants : inline_union_variant list;
353
+
field_union_style : [ `OneOf | `AnyOf ];
354
+
}
283
355
284
356
type field_info = {
285
357
ocaml_name : string;
···
290
362
is_required : bool;
291
363
is_nullable : bool; (** JSON schema nullable: true *)
292
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 *)
371
+
type 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 *)
377
+
type 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 ];
293
382
}
294
383
295
384
type schema_info = {
···
302
391
enum_variants : (string * string) list; (* ocaml_name, json_value *)
303
392
description : string option;
304
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 *)
399
+
type 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;
305
403
}
306
404
307
405
type operation_info = {
···
316
414
query_params : (string * string * string option * bool) list;
317
415
body_schema_ref : string option;
318
416
response_schema_ref : string option;
417
+
error_responses : error_response list; (** Typed error responses *)
319
418
}
320
419
321
420
type module_node = {
···
330
429
331
430
(** {1 Type Resolution} *)
332
431
333
-
let rec type_of_json_schema (json : Jsont.json) : string * bool =
432
+
(** Extract validation constraints from a JSON schema *)
433
+
let 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. *)
464
+
let 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 *)
494
+
let 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) *)
525
+
let 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. *)
535
+
let 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 *)
552
+
type type_resolution = {
553
+
resolved_type : string;
554
+
resolved_nullable : bool;
555
+
resolved_constraints : validation_constraints;
556
+
resolved_union : field_union_info option;
557
+
}
558
+
559
+
let rec resolve_type_full (json : Jsont.json) : type_resolution =
334
560
(* Check if the schema is nullable *)
335
561
let is_nullable = match get_member "nullable" json with
336
562
| Some (Jsont.Bool (b, _)) -> b
337
563
| _ -> false
338
564
in
339
-
match get_ref json with
340
-
| Some ref_ ->
341
-
(match schema_name_from_ref ref_ with
342
-
| Some name ->
343
-
let prefix, suffix = Name.split_schema_name name in
344
-
(Printf.sprintf "%s.%s.t" (Name.to_module_name prefix) (Name.to_module_name suffix), is_nullable)
345
-
| None -> ("Jsont.json", is_nullable))
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 }
346
573
| None ->
347
-
(* Check for allOf with a single $ref - common pattern for type aliasing *)
348
-
(match get_member "allOf" json with
349
-
| Some (Jsont.Array ([item], _)) ->
350
-
(* Single item allOf - try to resolve it *)
351
-
type_of_json_schema item
352
-
| Some (Jsont.Array (items, _)) when List.length items > 0 ->
353
-
(* Multiple allOf items - try to find a $ref among them *)
354
-
(match List.find_map (fun item ->
355
-
match get_ref item with
356
-
| Some ref_ -> schema_name_from_ref ref_
357
-
| None -> None
358
-
) items with
574
+
match get_ref json with
575
+
| Some ref_ ->
576
+
(match schema_name_from_ref ref_ with
359
577
| Some name ->
360
578
let prefix, suffix = Name.split_schema_name name in
361
-
(Printf.sprintf "%s.%s.t" (Name.to_module_name prefix) (Name.to_module_name suffix), is_nullable)
362
-
| None -> ("Jsont.json", is_nullable))
363
-
| _ ->
364
-
match get_string_member "type" json with
365
-
| Some "string" ->
366
-
(match get_string_member "format" json with
367
-
| Some "date-time" -> ("Ptime.t", is_nullable)
368
-
| _ -> ("string", is_nullable))
369
-
| Some "integer" ->
370
-
(match get_string_member "format" json with
371
-
| Some "int64" -> ("int64", is_nullable)
372
-
| Some "int32" -> ("int32", is_nullable)
373
-
| _ -> ("int", is_nullable))
374
-
| Some "number" -> ("float", is_nullable)
375
-
| Some "boolean" -> ("bool", is_nullable)
376
-
| Some "array" ->
377
-
(match get_member "items" json with
378
-
| Some items ->
379
-
let (elem_type, _) = type_of_json_schema items in
380
-
(elem_type ^ " list", is_nullable)
381
-
| None -> ("Jsont.json list", is_nullable))
382
-
| Some "object" -> ("Jsont.json", is_nullable)
383
-
| _ -> ("Jsont.json", is_nullable))
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 *)
630
+
let 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)
384
633
385
634
let rec jsont_of_base_type = function
386
635
| "string" -> "Jsont.string"
···
410
659
(* For other types, wrap with nullable_any *)
411
660
Printf.sprintf "(Openapi.Runtime.nullable_any %s)" (jsont_of_base_type base_type)
412
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) *)
664
+
let 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 *)
679
+
let 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. *)
735
+
let 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
+
413
769
(** {1 Schema Processing} *)
414
770
771
+
(** Extract variant name from a schema ref, stripping common prefixes *)
772
+
let 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 *)
789
+
let 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
+
415
817
let analyze_schema ~(components : Spec.components option) (name : string) (schema : Spec.schema) : schema_info =
416
818
(* First expand allOf composition *)
417
819
let expanded = expand_schema ~components schema in
···
426
828
) values
427
829
| None -> []
428
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
429
834
let fields = List.map (fun (field_name, field_json) ->
430
835
let ocaml_name = Name.to_snake_case field_name in
431
836
let is_required = List.mem field_name expanded.required in
432
-
let (base_type, json_nullable) = type_of_json_schema field_json in
433
-
let is_nullable = json_nullable in
434
-
let is_optional = is_nullable || not is_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
435
847
let ocaml_type = if is_optional then base_type ^ " option" else base_type in
436
848
let description = get_string_member "description" field_json in
437
-
{ ocaml_name; json_name = field_name; ocaml_type; base_type; is_optional; is_required; is_nullable; description }
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 }
438
854
) expanded.properties in
439
855
(* Check if schema references itself *)
440
856
let deps = find_schema_dependencies expanded in
441
857
let is_recursive = List.mem name deps in
442
858
{ original_name = name; prefix; suffix; schema = expanded; fields; is_enum; enum_variants;
443
-
description = expanded.description; is_recursive }
859
+
description = expanded.description; is_recursive; is_union; union_info }
444
860
445
861
(** {1 Operation Processing} *)
446
862
···
503
919
| _ -> None
504
920
in
505
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
+
506
934
let response_schema_ref =
507
-
let find_in_content content =
508
-
List.find_map (fun (ct, (media : Spec.media_type)) ->
509
-
if String.length ct >= 16 && String.sub ct 0 16 = "application/json" then
510
-
match media.schema with
511
-
| Some (Spec.Ref r) -> schema_name_from_ref r
512
-
| Some (Spec.Value s) when s.type_ = Some "array" ->
513
-
Option.bind s.items (fun items -> Option.bind (get_ref items) schema_name_from_ref)
514
-
| _ -> None
515
-
else None
516
-
) content
517
-
in
518
935
let try_status status =
519
936
List.find_map (fun (code, resp) ->
520
937
if code = status then
···
533
950
| _ -> None
534
951
in
535
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
+
536
972
{ func_name; operation_id = op.operation_id; summary = op.summary;
537
973
description = op.description; tags = op.tags; path; method_;
538
-
path_params; query_params; body_schema_ref; response_schema_ref }
974
+
path_params; query_params; body_schema_ref; response_schema_ref; error_responses }
539
975
540
976
(** {1 Module Tree Building} *)
541
977
···
678
1114
in
679
1115
Printf.sprintf "%s\n\nval jsont : t Jsont.t" type_def
680
1116
1117
+
(** {2 Union Type Generation} *)
1118
+
1119
+
(** Format a union variant type reference for code generation *)
1120
+
let 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 *)
1132
+
let 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. *)
1145
+
let 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. *)
1194
+
let 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 *)
1229
+
let 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 *)
1252
+
let 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
+
681
1265
(** Localize an OCaml type string by stripping the current_prefix and current_suffix modules.
682
1266
When generating code inside a submodule, self-references need to be unqualified. *)
683
1267
let localize_type ~current_prefix ~current_suffix (type_str : string) : string =
···
746
1330
747
1331
let gen_record_impl ~current_prefix ~current_suffix (schema : schema_info) : string =
748
1332
(* For recursive schemas, self-referential fields need to use Jsont.json
749
-
to avoid OCaml's let rec restrictions on non-functional values *)
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
750
1341
let loc_type s =
751
1342
let localized = localize_type ~current_prefix ~current_suffix s in
752
1343
if schema.is_recursive && localized = "t" then "Jsont.json"
753
1344
else if schema.is_recursive && localized = "t list" then "Jsont.json list"
754
1345
else if schema.is_recursive && localized = "t option" then "Jsont.json option"
755
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"
756
1353
else localized
757
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
758
1369
let loc_jsont s =
759
1370
let localized = localize_jsont ~current_prefix ~current_suffix s in
760
1371
if schema.is_recursive && localized = "jsont" then "Jsont.json"
761
1372
else if schema.is_recursive && localized = "(Jsont.list jsont)" then
762
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"
763
1382
else localized
764
1383
in
765
1384
let doc = format_doc schema.description in
···
777
1396
778
1397
let type_def = Printf.sprintf "%stype t = {\n%s\n}" doc type_fields in
779
1398
780
-
(* Constructor function v *)
781
-
let required_fields = List.filter (fun (f : field_info) -> not f.is_optional) schema.fields in
782
-
let optional_fields = List.filter (fun (f : field_info) -> f.is_optional) schema.fields in
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
783
1412
let v_params =
784
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) @
785
1417
(List.map (fun (f : field_info) -> Printf.sprintf "?%s" f.ocaml_name) optional_fields) @
786
1418
["()"]
787
1419
in
···
796
1428
(* Jsont codec *)
797
1429
let make_params = String.concat " " (List.map (fun (f : field_info) -> f.ocaml_name) schema.fields) in
798
1430
let jsont_members = String.concat "\n" (List.map (fun (f : field_info) ->
799
-
(* Determine the right codec based on nullable/required status:
800
-
- nullable + required: use nullable codec with mem (field must be present, can be null)
801
-
- nullable + not required: use nullable codec with opt_mem (field may be absent or null)
802
-
- not nullable + required: use base codec with mem
803
-
- not nullable + not required: use base codec with opt_mem *)
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
804
1452
if f.is_nullable then
805
-
let nullable_codec = loc_jsont (nullable_jsont_of_base_type f.base_type) in
806
-
if f.is_required then
807
-
Printf.sprintf " |> Jsont.Object.mem %S %s\n ~dec_absent:None ~enc_omit:Option.is_none ~enc:(fun r -> r.%s)"
808
-
f.json_name nullable_codec f.ocaml_name
809
-
else
810
-
Printf.sprintf " |> Jsont.Object.mem %S %s\n ~dec_absent:None ~enc_omit:Option.is_none ~enc:(fun r -> r.%s)"
811
-
f.json_name nullable_codec f.ocaml_name
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
812
1469
else if f.is_optional then
813
-
let codec = loc_jsont (jsont_of_base_type f.base_type) in
1470
+
(* Optional non-nullable field without default - use opt_mem *)
814
1471
Printf.sprintf " |> Jsont.Object.opt_mem %S %s ~enc:(fun r -> r.%s)"
815
-
f.json_name codec f.ocaml_name
1472
+
f.json_name base_codec f.ocaml_name
816
1473
else
817
-
let codec = loc_jsont (jsont_of_base_type f.base_type) in
818
-
Printf.sprintf " |> Jsont.Object.mem %S %s ~enc:(fun r -> r.%s)"
819
-
f.json_name codec f.ocaml_name
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)
820
1482
) schema.fields) in
821
1483
822
1484
Printf.sprintf {|%s
···
835
1497
836
1498
let gen_record_intf ~current_prefix ~current_suffix (schema : schema_info) : string =
837
1499
(* For recursive schemas, self-referential fields need to use Jsont.json
838
-
to avoid OCaml's let rec restrictions on non-functional values *)
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
839
1507
let loc_type s =
840
1508
let localized = localize_type ~current_prefix ~current_suffix s in
841
1509
if schema.is_recursive && localized = "t" then "Jsont.json"
842
1510
else if schema.is_recursive && localized = "t list" then "Jsont.json list"
843
1511
else if schema.is_recursive && localized = "t option" then "Jsont.json option"
844
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"
845
1519
else localized
846
1520
in
847
1521
let doc = format_doc schema.description in
848
1522
if schema.fields = [] then
849
-
Printf.sprintf "%stype t\n\nval jsont : t Jsont.t\n\nval v : unit -> t" doc
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
850
1525
else
851
1526
(* Abstract type *)
852
1527
let type_decl = Printf.sprintf "%stype t" doc in
853
1528
854
-
(* Constructor signature *)
855
-
let required_fields = List.filter (fun (f : field_info) -> not f.is_optional) schema.fields in
856
-
let optional_fields = List.filter (fun (f : field_info) -> f.is_optional) schema.fields in
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
857
1542
let v_param_docs = String.concat ""
858
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) @
859
1545
(List.map (fun (f : field_info) -> format_param_doc f.ocaml_name f.description) optional_fields))
860
1546
in
861
1547
let v_params =
862
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) @
863
1550
(List.map (fun (f : field_info) -> Printf.sprintf "?%s:%s" f.ocaml_name (loc_type f.base_type)) optional_fields) @
864
1551
["unit"; "t"]
865
1552
in
···
879
1566
Printf.sprintf "%s\n\n%s\n\n%s\n\nval jsont : t Jsont.t"
880
1567
type_decl v_sig accessor_sigs
881
1568
882
-
(** Format a jsont codec reference, stripping the current_prefix if present *)
1569
+
(** Format a jsont codec reference, stripping the current_prefix if present.
1570
+
Returns Jsont.json for forward references to avoid unbound module errors. *)
883
1571
let format_jsont_ref ~current_prefix (schema_ref : string) : string =
884
1572
let prefix, suffix = Name.split_schema_name schema_ref in
885
1573
let prefix_mod = Name.to_module_name prefix in
886
1574
let suffix_mod = Name.to_module_name suffix in
887
-
if prefix_mod = current_prefix then
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
888
1579
Printf.sprintf "%s.jsont" suffix_mod
889
1580
else
890
1581
Printf.sprintf "%s.%s.jsont" prefix_mod suffix_mod
···
975
1666
Printf.sprintf "Openapi.Runtime.Json.decode_json_exn %s (Requests.Response.json response)" response_codec
976
1667
in
977
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
+
978
1726
Printf.sprintf {|%slet %s %s =
979
1727
let op_name = %S in
980
1728
let url_path = %s in
···
989
1737
if Requests.Response.ok response then
990
1738
%s
991
1739
else
992
-
raise (Openapi.Runtime.Api_error {
993
-
operation = op_name;
994
-
method_ = %S;
995
-
url;
996
-
status = Requests.Response.status_code response;
997
-
body = Requests.Response.text response;
998
-
})|}
1740
+
%s|}
999
1741
full_doc op.func_name (String.concat " " all_args)
1000
-
op.func_name path_render query_build http_call op.method_ decode op.method_
1742
+
op.func_name path_render query_build http_call op.method_ decode error_handling
1001
1743
1002
1744
(** Format a type reference, stripping the current_prefix if present *)
1003
1745
let format_type_ref ~current_prefix (schema_ref : string) : string =
···
1007
1749
if prefix_mod = current_prefix then
1008
1750
(* Local reference - use unqualified name *)
1009
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"
1010
1755
else
1011
1756
Printf.sprintf "%s.%s.t" prefix_mod suffix_mod
1012
1757
···
1046
1791
1047
1792
Printf.sprintf "%sval %s : %s" full_doc op.func_name (String.concat " -> " all_args)
1048
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) *)
1814
+
let 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. *)
1824
+
let 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) *)
1847
+
let 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 *)
1880
+
let 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) *)
1893
+
let 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
+
1906
+
let 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) *)
1915
+
let 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) *)
1928
+
let 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
+
2035
+
let 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) *)
2044
+
let 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? *)
2060
+
let 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
+
1049
2084
(** {1 Full Module Generation} *)
1050
2085
1051
2086
let gen_submodule_impl ~current_prefix (schema : schema_info) : string =
1052
2087
let suffix_mod = Name.to_module_name schema.suffix in
1053
-
let content = if schema.is_enum then gen_enum_impl schema
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
1054
2091
else gen_record_impl ~current_prefix ~current_suffix:suffix_mod schema in
1055
2092
let indented = String.split_on_char '\n' content |> List.map (fun l -> " " ^ l) |> String.concat "\n" in
1056
2093
Printf.sprintf "module %s = struct\n%s\nend" suffix_mod indented
1057
2094
1058
2095
let gen_submodule_intf ~current_prefix (schema : schema_info) : string =
1059
2096
let suffix_mod = Name.to_module_name schema.suffix in
1060
-
let content = if schema.is_enum then gen_enum_intf schema
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
1061
2100
else gen_record_intf ~current_prefix ~current_suffix:suffix_mod schema in
1062
2101
let indented = String.split_on_char '\n' content |> List.map (fun l -> " " ^ l) |> String.concat "\n" in
1063
2102
Printf.sprintf "module %s : sig\n%s\nend" suffix_mod indented
···
1074
2113
else None
1075
2114
) schema.fields
1076
2115
1077
-
(** Sort schemas within a prefix module by their dependencies *)
1078
-
let sort_schemas_by_deps ~current_prefix (schemas : schema_info list) : schema_info list =
2116
+
(** Sort schemas within a prefix module by their TYPE dependencies.
2117
+
Used for ordering types in the Types module. *)
2118
+
let sort_schemas_by_type_deps ~current_prefix (schemas : schema_info list) : schema_info list =
1079
2119
let suffix_of schema = Name.to_module_name schema.suffix in
1080
2120
let suffix_names = List.map suffix_of schemas in
1081
2121
let deps_of suffix =
···
1088
2128
List.find_opt (fun s -> suffix_of s = suffix) schemas
1089
2129
) sorted
1090
2130
2131
+
(** Sort schemas within a prefix module by their CODEC dependencies.
2132
+
Used for ordering full modules with codecs. *)
2133
+
let 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 *)
1091
2149
let gen_prefix_module_impl (node : module_node) : string =
1092
-
let sorted_schemas = sort_schemas_by_deps ~current_prefix:node.name node.schemas in
1093
-
let schema_mods = List.map (gen_submodule_impl ~current_prefix:node.name) sorted_schemas in
1094
-
let op_impls = List.map (gen_operation_impl ~current_prefix:node.name) (List.rev node.operations) in
1095
-
let content = String.concat "\n\n" (schema_mods @ op_impls) in
1096
-
let indented = String.split_on_char '\n' content |> List.map (fun l -> " " ^ l) |> String.concat "\n" in
1097
-
Printf.sprintf "module %s = struct\n%s\nend" node.name indented
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
1098
2176
1099
2177
let gen_prefix_module_intf (node : module_node) : string =
1100
-
let sorted_schemas = sort_schemas_by_deps ~current_prefix:node.name node.schemas in
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
1101
2181
let schema_mods = List.map (gen_submodule_intf ~current_prefix:node.name) sorted_schemas in
1102
2182
let op_intfs = List.map (gen_operation_intf ~current_prefix:node.name) (List.rev node.operations) in
1103
2183
let content = String.concat "\n\n" (schema_mods @ op_intfs) in
···
1160
2240
let base_url t = t.base_url
1161
2241
let session t = t.session|} in
1162
2242
1163
-
(* Generate prefix modules in dependency order *)
1164
-
let prefix_mods = List.filter_map (fun name ->
1165
-
match StringMap.find_opt name tree.children with
1166
-
| None -> None
1167
-
| Some node ->
1168
-
if node.name = "Client" then
1169
-
(* Generate Client operations inline *)
1170
-
let ops = List.map (gen_operation_impl ~current_prefix:"Client") (List.rev node.operations) in
1171
-
if ops = [] then None
1172
-
else
1173
-
let content = String.concat "\n\n" ops in
1174
-
let indented = String.split_on_char '\n' content |> List.map (fun l -> " " ^ l) |> String.concat "\n" in
1175
-
Some (Printf.sprintf "module Client = struct\n%s\nend" indented)
1176
-
else
1177
-
Some (gen_prefix_module_impl node)
1178
-
) sorted_modules in
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
1179
2267
1180
2268
Printf.sprintf {|(** {1 %s}
1181
2269
···
1235
2323
val base_url : t -> string
1236
2324
val session : t -> Requests.t|} in
1237
2325
1238
-
(* Generate prefix modules in dependency order *)
1239
-
let prefix_mods = List.filter_map (fun name ->
1240
-
match StringMap.find_opt name tree.children with
1241
-
| None -> None
1242
-
| Some node ->
1243
-
if node.name = "Client" then
1244
-
let ops = List.map (gen_operation_intf ~current_prefix:"Client") (List.rev node.operations) in
1245
-
if ops = [] then None
1246
-
else
1247
-
let content = String.concat "\n\n" ops in
1248
-
let indented = String.split_on_char '\n' content |> List.map (fun l -> " " ^ l) |> String.concat "\n" in
1249
-
Some (Printf.sprintf "module Client : sig\n%s\nend" indented)
1250
-
else
1251
-
Some (gen_prefix_module_intf node)
1252
-
) sorted_modules in
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
1253
2349
1254
2350
Printf.sprintf {|(** {1 %s}
1255
2351
+213
-3
lib/openapi_runtime.ml
+213
-3
lib/openapi_runtime.ml
···
222
222
223
223
let json_jsont : json Jsont.t = Jsont.json
224
224
225
+
(** {1 Validation} *)
226
+
227
+
(** Validation error type *)
228
+
type validation_error =
229
+
| Min_length of { actual: int; min: int }
230
+
| Max_length of { actual: int; max: int }
231
+
| Pattern_mismatch of { value: string; pattern: string }
232
+
| Min_value of { actual: float; min: float; exclusive: bool }
233
+
| Max_value of { actual: float; max: float; exclusive: bool }
234
+
| Min_items of { actual: int; min: int }
235
+
| Max_items of { actual: int; max: int }
236
+
| Duplicate_items of { count: int }
237
+
238
+
let validation_error_to_string = function
239
+
| Min_length { actual; min } ->
240
+
Printf.sprintf "string too short: %d < %d" actual min
241
+
| Max_length { actual; max } ->
242
+
Printf.sprintf "string too long: %d > %d" actual max
243
+
| Pattern_mismatch { value; pattern } ->
244
+
Printf.sprintf "value %S does not match pattern %S" value pattern
245
+
| Min_value { actual; min; exclusive } ->
246
+
if exclusive then Printf.sprintf "value %g must be > %g" actual min
247
+
else Printf.sprintf "value %g must be >= %g" actual min
248
+
| Max_value { actual; max; exclusive } ->
249
+
if exclusive then Printf.sprintf "value %g must be < %g" actual max
250
+
else Printf.sprintf "value %g must be <= %g" actual max
251
+
| Min_items { actual; min } ->
252
+
Printf.sprintf "array too short: %d < %d items" actual min
253
+
| Max_items { actual; max } ->
254
+
Printf.sprintf "array too long: %d > %d items" actual max
255
+
| Duplicate_items { count } ->
256
+
Printf.sprintf "array contains %d duplicate items" count
257
+
258
+
(** Validated string codec with optional length and pattern constraints.
259
+
Pattern validation uses the Re library with PCRE syntax. *)
260
+
let validated_string
261
+
?min_length ?max_length ?pattern
262
+
(base : string Jsont.t) : string Jsont.t =
263
+
(* Compile regex if pattern is provided *)
264
+
let pattern_re = Option.map (fun p ->
265
+
try Some (Re.compile (Re.Pcre.re p))
266
+
with _ -> None (* Invalid regex - skip validation *)
267
+
) pattern in
268
+
Jsont.map base ~kind:"validated_string"
269
+
~dec:(fun s ->
270
+
let len = String.length s in
271
+
(match min_length with
272
+
| Some min when len < min ->
273
+
Jsont.Error.msgf Jsont.Meta.none "%s"
274
+
(validation_error_to_string (Min_length { actual = len; min }))
275
+
| _ -> ());
276
+
(match max_length with
277
+
| Some max when len > max ->
278
+
Jsont.Error.msgf Jsont.Meta.none "%s"
279
+
(validation_error_to_string (Max_length { actual = len; max }))
280
+
| _ -> ());
281
+
(match pattern_re, pattern with
282
+
| Some (Some re), Some pat ->
283
+
if not (Re.execp re s) then
284
+
Jsont.Error.msgf Jsont.Meta.none "%s"
285
+
(validation_error_to_string (Pattern_mismatch { value = s; pattern = pat }))
286
+
| _ -> ());
287
+
s)
288
+
~enc:Fun.id
289
+
290
+
(** Validated int codec with optional min/max constraints *)
291
+
let validated_int
292
+
?minimum ?maximum ?exclusive_minimum ?exclusive_maximum
293
+
(base : int Jsont.t) : int Jsont.t =
294
+
Jsont.map base ~kind:"validated_int"
295
+
~dec:(fun n ->
296
+
let f = float_of_int n in
297
+
(match exclusive_minimum with
298
+
| Some min when f <= min ->
299
+
Jsont.Error.msgf Jsont.Meta.none "%s"
300
+
(validation_error_to_string (Min_value { actual = f; min; exclusive = true }))
301
+
| _ -> ());
302
+
(match minimum with
303
+
| Some min when f < min ->
304
+
Jsont.Error.msgf Jsont.Meta.none "%s"
305
+
(validation_error_to_string (Min_value { actual = f; min; exclusive = false }))
306
+
| _ -> ());
307
+
(match exclusive_maximum with
308
+
| Some max when f >= max ->
309
+
Jsont.Error.msgf Jsont.Meta.none "%s"
310
+
(validation_error_to_string (Max_value { actual = f; max; exclusive = true }))
311
+
| _ -> ());
312
+
(match maximum with
313
+
| Some max when f > max ->
314
+
Jsont.Error.msgf Jsont.Meta.none "%s"
315
+
(validation_error_to_string (Max_value { actual = f; max; exclusive = false }))
316
+
| _ -> ());
317
+
n)
318
+
~enc:Fun.id
319
+
320
+
(** Validated float codec with optional min/max constraints *)
321
+
let validated_float
322
+
?minimum ?maximum ?exclusive_minimum ?exclusive_maximum
323
+
(base : float Jsont.t) : float Jsont.t =
324
+
Jsont.map base ~kind:"validated_float"
325
+
~dec:(fun f ->
326
+
(match exclusive_minimum with
327
+
| Some min when f <= min ->
328
+
Jsont.Error.msgf Jsont.Meta.none "%s"
329
+
(validation_error_to_string (Min_value { actual = f; min; exclusive = true }))
330
+
| _ -> ());
331
+
(match minimum with
332
+
| Some min when f < min ->
333
+
Jsont.Error.msgf Jsont.Meta.none "%s"
334
+
(validation_error_to_string (Min_value { actual = f; min; exclusive = false }))
335
+
| _ -> ());
336
+
(match exclusive_maximum with
337
+
| Some max when f >= max ->
338
+
Jsont.Error.msgf Jsont.Meta.none "%s"
339
+
(validation_error_to_string (Max_value { actual = f; max; exclusive = true }))
340
+
| _ -> ());
341
+
(match maximum with
342
+
| Some max when f > max ->
343
+
Jsont.Error.msgf Jsont.Meta.none "%s"
344
+
(validation_error_to_string (Max_value { actual = f; max; exclusive = false }))
345
+
| _ -> ());
346
+
f)
347
+
~enc:Fun.id
348
+
349
+
(** Validated list codec with optional min/max items and uniqueness constraints *)
350
+
let validated_list
351
+
?min_items ?max_items ?(unique_items = false)
352
+
(elem_codec : 'a Jsont.t) : 'a list Jsont.t =
353
+
let base = Jsont.list elem_codec in
354
+
Jsont.map base ~kind:"validated_list"
355
+
~dec:(fun lst ->
356
+
let len = List.length lst in
357
+
(match min_items with
358
+
| Some min when len < min ->
359
+
Jsont.Error.msgf Jsont.Meta.none "%s"
360
+
(validation_error_to_string (Min_items { actual = len; min }))
361
+
| _ -> ());
362
+
(match max_items with
363
+
| Some max when len > max ->
364
+
Jsont.Error.msgf Jsont.Meta.none "%s"
365
+
(validation_error_to_string (Max_items { actual = len; max }))
366
+
| _ -> ());
367
+
(* Check for unique items using structural equality *)
368
+
(if unique_items then
369
+
let rec count_duplicates seen count = function
370
+
| [] -> count
371
+
| x :: xs ->
372
+
if List.exists (( = ) x) seen then
373
+
count_duplicates seen (count + 1) xs
374
+
else
375
+
count_duplicates (x :: seen) count xs
376
+
in
377
+
let dup_count = count_duplicates [] 0 lst in
378
+
if dup_count > 0 then
379
+
Jsont.Error.msgf Jsont.Meta.none "%s"
380
+
(validation_error_to_string (Duplicate_items { count = dup_count })));
381
+
lst)
382
+
~enc:Fun.id
383
+
384
+
(** {1 Polymorphic Variant Codecs for Union Types} *)
385
+
386
+
(** Create a try-each decoder for polymorphic variant union types.
387
+
Attempts each decoder in order until one succeeds. *)
388
+
let poly_union_decoder (decoders : (Jsont.json -> 'a option) list) (json : Jsont.json) : 'a =
389
+
match List.find_map (fun dec -> dec json) decoders with
390
+
| Some v -> v
391
+
| None -> Jsont.Error.msgf Jsont.Meta.none "No variant matched for union type"
392
+
225
393
(** {1 API Errors} *)
226
394
395
+
(** Parsed error body, in increasing levels of typed-ness *)
396
+
type error_body =
397
+
| Raw of string (** Unparsed string *)
398
+
| Json of Jsont.json (** Parsed but untyped JSON *)
399
+
| Typed of string * Jsont.json (** schema_name, typed value as JSON *)
400
+
227
401
(** Error raised when an API call fails with a non-2xx status code *)
228
402
type api_error = {
229
403
operation : string;
230
404
method_ : string;
231
405
url : string;
232
406
status : int;
233
-
body : string;
407
+
body : string; (** Always keep raw body for debugging *)
408
+
parsed_body : error_body option; (** Parsed/typed body if available *)
234
409
}
235
410
236
411
exception Api_error of api_error
···
238
413
let () =
239
414
Printexc.register_printer (function
240
415
| Api_error e ->
241
-
Some (Printf.sprintf "Api_error: %s %s returned %d: %s"
242
-
e.method_ e.url e.status e.body)
416
+
let parsed_info = match e.parsed_body with
417
+
| None -> ""
418
+
| Some (Raw _) -> " (raw)"
419
+
| Some (Json _) -> " (json)"
420
+
| Some (Typed (schema, _)) -> Printf.sprintf " (typed: %s)" schema
421
+
in
422
+
Some (Printf.sprintf "Api_error: %s %s returned %d%s: %s"
423
+
e.method_ e.url e.status parsed_info e.body)
243
424
| _ -> None)
425
+
426
+
(** Helper to try parsing error body with a list of status-keyed parsers *)
427
+
let try_parse_error_body ~status ~body
428
+
(parsers : (string * (string -> (Jsont.json, string) result)) list) : error_body option =
429
+
let status_str = string_of_int status in
430
+
(* Try exact status match first, then wildcard, then default *)
431
+
let try_parser key =
432
+
List.find_map (fun (k, parser) ->
433
+
if k = key then
434
+
match parser body with
435
+
| Ok json -> Some json
436
+
| Error _ -> None
437
+
else None
438
+
) parsers
439
+
in
440
+
match try_parser status_str with
441
+
| Some json -> Some (Json json)
442
+
| None ->
443
+
let wildcard = String.make 1 status_str.[0] ^ "XX" in
444
+
match try_parser wildcard with
445
+
| Some json -> Some (Json json)
446
+
| None ->
447
+
match try_parser "default" with
448
+
| Some json -> Some (Json json)
449
+
| None ->
450
+
(* Try parsing as generic JSON *)
451
+
match Jsont_bytesrw.decode_string Jsont.json body with
452
+
| Ok json -> Some (Json json)
453
+
| Error _ -> Some (Raw body)