Yaml encoder/decoder for OCaml jsont codecs
anil.recoil.org
1(*---------------------------------------------------------------------------
2 Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3 SPDX-License-Identifier: ISC
4 ---------------------------------------------------------------------------*)
5
6open Jsont.Repr
7open Yamlrw
8
9(* YAML format *)
10
11type yaml_format = Block | Flow | Layout
12
13(* Decoder *)
14
15type decoder = {
16 parser : Parser.t;
17 file : string;
18 locs : bool;
19 _layout : bool; (* For future layout preservation *)
20 max_depth : int;
21 max_nodes : int;
22 mutable node_count : int;
23 mutable current : Event.spanned option;
24 _anchors : (string, Jsont.json) Hashtbl.t; (* For future anchor resolution *)
25 meta_none : Jsont.Meta.t;
26}
27
28let make_decoder ?(locs = false) ?(layout = false) ?(file = "-")
29 ?(max_depth = 100) ?(max_nodes = 10_000_000) parser =
30 let meta_none = Jsont.Meta.make (Jsont.Textloc.(set_file none) file) in
31 {
32 parser;
33 file;
34 locs;
35 _layout = layout;
36 max_depth;
37 max_nodes;
38 node_count = 0;
39 current = None;
40 _anchors = Hashtbl.create 16;
41 meta_none;
42 }
43
44(* Decoder helpers *)
45
46(* Local helper to reduce Jsont.Error.msgf boilerplate *)
47let err_msg meta fmt = Jsont.Error.msgf meta fmt
48let err_msg_none fmt = Jsont.Error.msgf Jsont.Meta.none fmt
49
50let check_depth d ~nest =
51 if nest > d.max_depth then
52 err_msg_none "Maximum nesting depth %d exceeded" d.max_depth
53
54let check_nodes d =
55 d.node_count <- d.node_count + 1;
56 if d.node_count > d.max_nodes then
57 err_msg_none "Maximum node count %d exceeded" d.max_nodes
58
59let meta_of_span d span =
60 if not d.locs then d.meta_none
61 else
62 let start = span.Span.start and stop = span.Span.stop in
63 let first_byte = start.Position.index in
64 let last_byte = max first_byte (stop.Position.index - 1) in
65 (* line_pos is (line_number, byte_position_of_line_start) *)
66 let first_line =
67 (start.Position.line, start.Position.index - start.Position.column + 1)
68 in
69 (* Handle case where stop is at the start of a new line (column 1)
70 This happens when the span includes a trailing newline.
71 The last_byte is on the previous line, so we need to calculate
72 the line start position based on last_byte, not stop. *)
73 let last_line =
74 if stop.Position.column = 1 && stop.Position.line > start.Position.line then
75 (* last_byte is on the previous line (stop.line - 1)
76 We need to estimate where that line starts. Since we don't have
77 the full text, we can't calculate it exactly, but we can use:
78 last_byte - (estimated_column - 1)
79 For now, we'll use the same line as start if they're close,
80 or just report it as the previous line. *)
81 let last_line_num = stop.Position.line - 1 in
82 (* Estimate: assume last_byte is somewhere on the previous line.
83 We'll use the byte position minus a reasonable offset.
84 This is approximate but better than wrapping to the next line. *)
85 if last_line_num = start.Position.line then
86 (* Same line as start - use start's line position *)
87 first_line
88 else
89 (* Different line - estimate line start as last_byte minus some offset
90 Since we subtracted 1 from stop.index to get last_byte, and stop.column was 1,
91 last_byte should be the newline character on the previous line.
92 The line likely started much earlier, but we'll estimate conservatively. *)
93 (last_line_num, last_byte)
94 else
95 (stop.Position.line, stop.Position.index - stop.Position.column + 1)
96 in
97 let textloc =
98 Jsont.Textloc.make ~file:d.file ~first_byte ~last_byte ~first_line
99 ~last_line
100 in
101 Jsont.Meta.make textloc
102
103let next_event d =
104 d.current <- Parser.next d.parser;
105 d.current
106
107let peek_event d =
108 match d.current with Some _ -> d.current | None -> next_event d
109
110let skip_event d = d.current <- None
111
112let _expect_event d pred name =
113 match peek_event d with
114 | Some ev when pred ev.Event.event ->
115 skip_event d;
116 ev
117 | Some ev ->
118 let span = ev.Event.span in
119 let meta = meta_of_span d span in
120 err_msg meta "Expected %s but found %a" name Event.pp ev.Event.event
121 | None -> err_msg_none "Expected %s but reached end of stream" name
122
123(* Error helpers *)
124
125let _err_expected_scalar d ev =
126 let meta = meta_of_span d ev.Event.span in
127 err_msg meta "Expected scalar but found %a" Event.pp ev.Event.event
128
129let err_type_mismatch d span t ~fnd =
130 let open Jsont.Repr in
131 let meta = meta_of_span d span in
132 err_msg meta "Expected %s but found %s" (kinded_sort t) fnd
133
134(* YAML scalar resolution *)
135
136let is_null_scalar s =
137 s = "" || s = "~" || s = "null" || s = "Null" || s = "NULL"
138
139let bool_of_scalar_opt s =
140 match s with
141 | "true" | "True" | "TRUE" | "yes" | "Yes" | "YES" | "on" | "On" | "ON" ->
142 Some true
143 | "false" | "False" | "FALSE" | "no" | "No" | "NO" | "off" | "Off" | "OFF" ->
144 Some false
145 | _ -> None
146
147let float_of_scalar_opt s =
148 (* Handle YAML special floats *)
149 match s with
150 | ".inf" | ".Inf" | ".INF" -> Some Float.infinity
151 | "+.inf" | "+.Inf" | "+.INF" -> Some Float.infinity
152 | "-.inf" | "-.Inf" | "-.INF" -> Some Float.neg_infinity
153 | ".nan" | ".NaN" | ".NAN" -> Some Float.nan
154 | _ -> (
155 (* Try parsing as number, allowing underscores *)
156 let s' = String.concat "" (String.split_on_char '_' s) in
157 (* Try int first (supports 0o, 0x, 0b) then float *)
158 match int_of_string_opt s' with
159 | Some i -> Some (float_of_int i)
160 | None -> float_of_string_opt s')
161
162let _int_of_scalar_opt s =
163 (* Handle hex, octal, and regular integers with underscores *)
164 let s' = String.concat "" (String.split_on_char '_' s) in
165 int_of_string_opt s'
166
167(* Decode a scalar value according to expected type *)
168let rec decode_scalar_as : type a.
169 decoder -> Event.spanned -> string -> Scalar_style.t -> a t -> a =
170 fun d ev value style t ->
171 check_nodes d;
172 let meta = meta_of_span d ev.Event.span in
173 match t with
174 | Null map ->
175 if is_null_scalar value then map.dec meta ()
176 else err_type_mismatch d ev.span t ~fnd:("scalar " ^ value)
177 | Bool map -> (
178 match bool_of_scalar_opt value with
179 | Some b -> map.dec meta b
180 | None ->
181 (* For explicitly quoted strings, fail *)
182 if style <> `Plain then
183 err_type_mismatch d ev.span t ~fnd:("string " ^ value)
184 else err_type_mismatch d ev.span t ~fnd:("scalar " ^ value))
185 | Number map -> (
186 if
187 (* Handle null -> nan mapping like jsont *)
188 is_null_scalar value
189 then map.dec meta Float.nan
190 else
191 match float_of_scalar_opt value with
192 | Some f -> map.dec meta f
193 | None -> err_type_mismatch d ev.span t ~fnd:("scalar " ^ value))
194 | String map ->
195 (* Don't decode null values as strings - they should fail so outer combinators
196 like 'option' or 'any' can handle them properly.
197 BUT: quoted strings should always be treated as strings, even if they
198 look like null (e.g., "" or "null") *)
199 if style = `Plain && is_null_scalar value then
200 err_type_mismatch d ev.span t ~fnd:"null"
201 else
202 (* Strings accept quoted scalars or non-null plain scalars *)
203 map.dec meta value
204 | Array map ->
205 (* Treat null as an empty array for convenience *)
206 if is_null_scalar value then
207 let end_meta = meta_of_span d ev.Event.span in
208 map.dec_finish end_meta 0 (map.dec_empty ())
209 else
210 err_type_mismatch d ev.span t ~fnd:"scalar"
211 | Object map ->
212 (* Treat null as an empty object for convenience *)
213 if is_null_scalar value then
214 (* Build a dict with all default values from absent members *)
215 let add_default _ (Mem_dec mem_map) dict =
216 match mem_map.dec_absent with
217 | Some v -> Dict.add mem_map.id v dict
218 | None ->
219 (* Required field without default - error *)
220 let exp = String_map.singleton mem_map.name (Mem_dec mem_map) in
221 missing_mems_error meta map ~exp ~fnd:[]
222 in
223 let dict = String_map.fold add_default map.mem_decs Dict.empty in
224 let dict = Dict.add object_meta_arg meta dict in
225 apply_dict map.dec dict
226 else
227 err_type_mismatch d ev.span t ~fnd:"scalar"
228 | Map m ->
229 (* Handle Map combinators (e.g., from Jsont.option) *)
230 m.dec (decode_scalar_as d ev value style m.dom)
231 | Rec lazy_t ->
232 (* Handle recursive types *)
233 decode_scalar_as d ev value style (Lazy.force lazy_t)
234 | _ -> err_type_mismatch d ev.span t ~fnd:"scalar"
235
236(* Forward declaration for mutual recursion *)
237let rec decode : type a. decoder -> nest:int -> a t -> a =
238 fun d ~nest t ->
239 check_depth d ~nest;
240 match peek_event d with
241 | None -> err_msg_none "Unexpected end of YAML stream"
242 | Some ev -> (
243 match (ev.Event.event, t) with
244 (* Scalar events *)
245 | Event.Scalar { value; style; anchor; _ }, _ ->
246 skip_event d;
247 let result = decode_scalar d ~nest ev value style t in
248 (* Store anchor if present - TODO: implement anchor storage *)
249 (match anchor with
250 | Some _name ->
251 (* We need generic JSON for anchors - decode as json and convert back *)
252 ()
253 | None -> ());
254 result
255 (* Alias *)
256 | Event.Alias { anchor }, _ ->
257 skip_event d;
258 decode_alias d ev anchor t
259 (* Map combinator - must come before specific event matches *)
260 | _, Map m -> m.dec (decode d ~nest m.dom)
261 (* Recursive types - must come before specific event matches *)
262 | _, Rec lazy_t -> decode d ~nest (Lazy.force lazy_t)
263 (* Sequence -> Array *)
264 | Event.Sequence_start _, Array map -> decode_array d ~nest ev map
265 | Event.Sequence_start _, Any map -> decode_any_sequence d ~nest ev t map
266 | Event.Sequence_start _, _ ->
267 err_type_mismatch d ev.span t ~fnd:"sequence"
268 (* Mapping -> Object *)
269 | Event.Mapping_start _, Object map -> decode_object d ~nest ev map
270 | Event.Mapping_start _, Any map -> decode_any_mapping d ~nest ev t map
271 | Event.Mapping_start _, _ -> err_type_mismatch d ev.span t ~fnd:"mapping"
272 (* Unexpected events *)
273 | Event.Sequence_end, _ ->
274 err_msg (meta_of_span d ev.span) "Unexpected sequence end"
275 | Event.Mapping_end, _ ->
276 err_msg (meta_of_span d ev.span) "Unexpected mapping end"
277 | Event.Document_start _, _ ->
278 err_msg (meta_of_span d ev.span) "Unexpected document start"
279 | Event.Document_end _, _ ->
280 err_msg (meta_of_span d ev.span) "Unexpected document end"
281 | Event.Stream_start _, _ ->
282 err_msg (meta_of_span d ev.span) "Unexpected stream start"
283 | Event.Stream_end, _ ->
284 err_msg (meta_of_span d ev.span) "Unexpected stream end")
285
286and decode_scalar : type a.
287 decoder -> nest:int -> Event.spanned -> string -> Scalar_style.t -> a t -> a
288 =
289 fun d ~nest ev value style t ->
290 match t with
291 | Any map -> decode_any_scalar d ev value style t map
292 | Map m -> m.dec (decode_scalar d ~nest ev value style m.dom)
293 | Rec lazy_t -> decode_scalar d ~nest ev value style (Lazy.force lazy_t)
294 | _ -> decode_scalar_as d ev value style t
295
296and decode_any_scalar : type a.
297 decoder ->
298 Event.spanned ->
299 string ->
300 Scalar_style.t ->
301 a t ->
302 a any_map ->
303 a =
304 fun d ev value style t map ->
305 check_nodes d;
306 let meta = meta_of_span d ev.span in
307 let type_err fnd = Jsont.Repr.type_error meta t ~fnd in
308 (* Determine which decoder to use based on scalar content *)
309 if is_null_scalar value then
310 match map.dec_null with
311 | Some t' -> decode_scalar_as d ev value style t'
312 | None -> type_err Jsont.Sort.Null
313 else if style = `Plain then
314 (* Try bool, then number, then string *)
315 match bool_of_scalar_opt value with
316 | Some _ -> (
317 match map.dec_bool with
318 | Some t' -> decode_scalar_as d ev value style t'
319 | None -> (
320 match map.dec_string with
321 | Some t' -> decode_scalar_as d ev value style t'
322 | None -> type_err Jsont.Sort.Bool))
323 | None -> (
324 match float_of_scalar_opt value with
325 | Some _ -> (
326 match map.dec_number with
327 | Some t' -> decode_scalar_as d ev value style t'
328 | None -> (
329 match map.dec_string with
330 | Some t' -> decode_scalar_as d ev value style t'
331 | None -> type_err Jsont.Sort.Number))
332 | None -> (
333 (* Plain scalar that's not bool/number -> string *)
334 match map.dec_string with
335 | Some t' -> decode_scalar_as d ev value style t'
336 | None -> type_err Jsont.Sort.String))
337 else
338 (* Quoted scalars are strings *)
339 match map.dec_string with
340 | Some t' -> decode_scalar_as d ev value style t'
341 | None -> type_err Jsont.Sort.String
342
343and decode_alias : type a. decoder -> Event.spanned -> string -> a t -> a =
344 fun d ev anchor t ->
345 check_nodes d;
346 match Hashtbl.find_opt d._anchors anchor with
347 | None ->
348 let meta = meta_of_span d ev.span in
349 err_msg meta "Unknown anchor: %s" anchor
350 | Some json_value ->
351 (* Decode the stored JSON value through the type *)
352 let t' = Jsont.Repr.unsafe_to_t t in
353 match Jsont.Json.decode' t' json_value with
354 | Ok v -> v
355 | Error e -> raise (Jsont.Error e)
356
357and decode_array : type a elt b.
358 decoder -> nest:int -> Event.spanned -> (a, elt, b) array_map -> a =
359 fun d ~nest start_ev array_map ->
360 skip_event d;
361 (* consume Sequence_start *)
362 check_nodes d;
363 let meta = meta_of_span d start_ev.span in
364 let builder = ref (array_map.dec_empty ()) in
365 let idx = ref 0 in
366 let rec loop () =
367 match peek_event d with
368 | Some { Event.event = Event.Sequence_end; span } ->
369 skip_event d;
370 let end_meta = meta_of_span d span in
371 array_map.dec_finish end_meta !idx !builder
372 | Some _ ->
373 let i = !idx in
374 (try
375 if array_map.dec_skip i !builder then begin
376 (* Skip this element by decoding as ignore *)
377 let _ : unit =
378 decode d ~nest:(nest + 1) (Jsont.Repr.of_t Jsont.ignore)
379 in
380 ()
381 end
382 else begin
383 let elt = decode d ~nest:(nest + 1) array_map.elt in
384 builder := array_map.dec_add i elt !builder
385 end
386 with Jsont.Error e ->
387 Jsont.Repr.error_push_array meta array_map (i, Jsont.Meta.none) e);
388 incr idx;
389 loop ()
390 | None -> err_msg meta "Unclosed sequence"
391 in
392 loop ()
393
394and decode_any_sequence : type a.
395 decoder -> nest:int -> Event.spanned -> a t -> a any_map -> a =
396 fun d ~nest ev t map ->
397 match map.dec_array with
398 | Some t' -> (
399 (* The t' decoder might be wrapped (e.g., Map for option types)
400 Directly decode the array and let the wrapper handle it *)
401 match t' with
402 | Array array_map -> decode_array d ~nest ev array_map
403 | _ ->
404 (* For wrapped types like Map (Array ...), use full decode *)
405 decode d ~nest t')
406 | None ->
407 Jsont.Repr.type_error (meta_of_span d ev.span) t ~fnd:Jsont.Sort.Array
408
409and decode_object : type o.
410 decoder -> nest:int -> Event.spanned -> (o, o) object_map -> o =
411 fun d ~nest start_ev map ->
412 skip_event d;
413 (* consume Mapping_start *)
414 check_nodes d;
415 let meta = meta_of_span d start_ev.span in
416 let dict =
417 decode_object_members d ~nest meta map String_map.empty Dict.empty
418 in
419 let dict = Dict.add object_meta_arg meta dict in
420 apply_dict map.dec dict
421
422and decode_object_members : type o.
423 decoder ->
424 nest:int ->
425 Jsont.Meta.t ->
426 (o, o) object_map ->
427 mem_dec String_map.t ->
428 Dict.t ->
429 Dict.t =
430 fun d ~nest obj_meta map mem_miss dict ->
431 (* Merge expected member decoders *)
432 let u _ _ _ = assert false in
433 let mem_miss = String_map.union u mem_miss map.mem_decs in
434 match map.shape with
435 | Object_basic umems ->
436 decode_object_basic d ~nest obj_meta map umems mem_miss dict
437 | Object_cases (umems_opt, cases) ->
438 (* Wrap umems_opt to hide existential types *)
439 let umems = Unknown_mems umems_opt in
440 decode_object_cases d ~nest obj_meta map umems cases mem_miss [] dict
441
442and decode_object_basic : type o mems builder.
443 decoder ->
444 nest:int ->
445 Jsont.Meta.t ->
446 (o, o) object_map ->
447 (o, mems, builder) unknown_mems ->
448 mem_dec String_map.t ->
449 Dict.t ->
450 Dict.t =
451 fun d ~nest obj_meta object_map umems mem_miss dict ->
452 let ubuilder =
453 ref
454 (match umems with
455 | Unknown_skip | Unknown_error -> Obj.magic ()
456 | Unknown_keep (mmap, _) -> mmap.dec_empty ())
457 in
458 let mem_miss = ref mem_miss in
459 let dict = ref dict in
460 let rec loop () =
461 match peek_event d with
462 | Some { Event.event = Event.Mapping_end; _ } ->
463 skip_event d;
464 (* Finalize *)
465 finish_object obj_meta object_map umems !ubuilder !mem_miss !dict
466 | Some ev ->
467 (* Expect a scalar key *)
468 let name, name_meta = decode_mapping_key d ev in
469 (* Look up member decoder *)
470 (match String_map.find_opt name object_map.mem_decs with
471 | Some (Mem_dec mem) -> (
472 mem_miss := String_map.remove name !mem_miss;
473 try
474 let v = decode d ~nest:(nest + 1) mem.type' in
475 dict := Dict.add mem.id v !dict
476 with Jsont.Error e ->
477 Jsont.Repr.error_push_object obj_meta object_map (name, name_meta)
478 e)
479 | None -> (
480 (* Unknown member *)
481 match umems with
482 | Unknown_skip ->
483 let _ : unit =
484 decode d ~nest:(nest + 1) (Jsont.Repr.of_t Jsont.ignore)
485 in
486 ()
487 | Unknown_error ->
488 Jsont.Repr.unexpected_mems_error obj_meta object_map
489 ~fnd:[ (name, name_meta) ]
490 | Unknown_keep (mmap, _) -> (
491 try
492 let v = decode d ~nest:(nest + 1) mmap.mems_type in
493 ubuilder := mmap.dec_add name_meta name v !ubuilder
494 with Jsont.Error e ->
495 Jsont.Repr.error_push_object obj_meta object_map
496 (name, name_meta) e)));
497 loop ()
498 | None -> err_msg obj_meta "Unclosed mapping"
499 in
500 loop ()
501
502and finish_object : type o mems builder.
503 Jsont.Meta.t ->
504 (o, o) object_map ->
505 (o, mems, builder) unknown_mems ->
506 builder ->
507 mem_dec String_map.t ->
508 Dict.t ->
509 Dict.t =
510 fun meta map umems ubuilder mem_miss dict ->
511 let open Jsont.Repr in
512 let dict = Dict.add object_meta_arg meta dict in
513 let dict =
514 match umems with
515 | Unknown_skip | Unknown_error -> dict
516 | Unknown_keep (mmap, _) ->
517 Dict.add mmap.id (mmap.dec_finish meta ubuilder) dict
518 in
519 (* Check for missing required members *)
520 let add_default _ (Mem_dec mem_map) dict =
521 match mem_map.dec_absent with
522 | Some v -> Dict.add mem_map.id v dict
523 | None -> raise Exit
524 in
525 try String_map.fold add_default mem_miss dict
526 with Exit ->
527 let no_default _ (Mem_dec mm) = Option.is_none mm.dec_absent in
528 let exp = String_map.filter no_default mem_miss in
529 missing_mems_error meta map ~exp ~fnd:[]
530
531and decode_object_cases : type o cases tag.
532 decoder ->
533 nest:int ->
534 Jsont.Meta.t ->
535 (o, o) object_map ->
536 unknown_mems_option ->
537 (o, cases, tag) object_cases ->
538 mem_dec String_map.t ->
539 (Jsont.name * Jsont.json) list ->
540 Dict.t ->
541 Dict.t =
542 fun d ~nest obj_meta object_map umems cases mem_miss delayed dict ->
543 match peek_event d with
544 | Some { Event.event = Event.Mapping_end; _ } -> (
545 skip_event d;
546 (* No tag found - use dec_absent if available *)
547 match cases.tag.dec_absent with
548 | Some tag ->
549 decode_with_case_tag d ~nest obj_meta object_map umems cases tag
550 mem_miss delayed dict
551 | None ->
552 (* Missing required case tag *)
553 let exp = String_map.singleton cases.tag.name (Mem_dec cases.tag) in
554 let fnd = List.map (fun ((n, _), _) -> n) delayed in
555 Jsont.Repr.missing_mems_error obj_meta object_map ~exp ~fnd)
556 | Some ev ->
557 let name, name_meta = decode_mapping_key d ev in
558 if String.equal name cases.tag.name then begin
559 (* Found the case tag *)
560 let tag = decode d ~nest:(nest + 1) cases.tag.type' in
561 decode_with_case_tag d ~nest obj_meta object_map umems cases tag
562 mem_miss delayed dict
563 end
564 else begin
565 (* Not the case tag - check if known member or delay *)
566 match String_map.find_opt name object_map.mem_decs with
567 | Some (Mem_dec mem) -> (
568 let mem_miss = String_map.remove name mem_miss in
569 try
570 let v = decode d ~nest:(nest + 1) mem.type' in
571 let dict = Dict.add mem.id v dict in
572 decode_object_cases d ~nest obj_meta object_map umems cases
573 mem_miss delayed dict
574 with Jsont.Error e ->
575 Jsont.Repr.error_push_object obj_meta object_map (name, name_meta)
576 e)
577 | None ->
578 (* Unknown member - decode as generic JSON and delay *)
579 let v =
580 decode d ~nest:(nest + 1) (Jsont.Repr.of_t Jsont.json)
581 in
582 let delayed = ((name, name_meta), v) :: delayed in
583 decode_object_cases d ~nest obj_meta object_map umems cases
584 mem_miss delayed dict
585 end
586 | None -> err_msg obj_meta "Unclosed mapping"
587
588and decode_with_case_tag : type o cases tag.
589 decoder ->
590 nest:int ->
591 Jsont.Meta.t ->
592 (o, o) object_map ->
593 unknown_mems_option ->
594 (o, cases, tag) object_cases ->
595 tag ->
596 mem_dec String_map.t ->
597 (Jsont.name * Jsont.json) list ->
598 Dict.t ->
599 Dict.t =
600 fun d ~nest obj_meta map umems cases tag mem_miss delayed dict ->
601 let open Jsont.Repr in
602 let eq_tag (Case c) = cases.tag_compare c.tag tag = 0 in
603 match List.find_opt eq_tag cases.cases with
604 | None -> unexpected_case_tag_error obj_meta map cases tag
605 | Some (Case case) ->
606 (* Continue decoding with the case's object map *)
607 let case_dict =
608 decode_case_remaining d ~nest obj_meta case.object_map umems mem_miss
609 delayed dict
610 in
611 let case_value = apply_dict case.object_map.dec case_dict in
612 Dict.add cases.id (case.dec case_value) dict
613
614and decode_case_remaining : type o.
615 decoder ->
616 nest:int ->
617 Jsont.Meta.t ->
618 (o, o) object_map ->
619 unknown_mems_option ->
620 mem_dec String_map.t ->
621 (Jsont.name * Jsont.json) list ->
622 Dict.t ->
623 Dict.t =
624 fun d ~nest obj_meta case_map _umems mem_miss delayed dict ->
625 (* First, process delayed members against the case map *)
626 let u _ _ _ = assert false in
627 let mem_miss = String_map.union u mem_miss case_map.mem_decs in
628 let dict, mem_miss =
629 List.fold_left
630 (fun (dict, mem_miss) ((name, meta), json_value) ->
631 match String_map.find_opt name case_map.mem_decs with
632 | Some (Mem_dec mem) -> (
633 let t' = Jsont.Repr.unsafe_to_t mem.type' in
634 match Jsont.Json.decode' t' json_value with
635 | Ok v ->
636 let dict = Dict.add mem.id v dict in
637 let mem_miss = String_map.remove name mem_miss in
638 (dict, mem_miss)
639 | Error e ->
640 Jsont.Repr.error_push_object obj_meta case_map (name, meta) e)
641 | None ->
642 (* Unknown for case too - skip them *)
643 (dict, mem_miss))
644 (dict, mem_miss) delayed
645 in
646 (* Then continue reading remaining members using case's own unknown handling *)
647 match case_map.shape with
648 | Object_basic case_umems ->
649 decode_object_basic d ~nest obj_meta case_map case_umems mem_miss dict
650 | Object_cases _ ->
651 (* Nested cases shouldn't happen - use skip for safety *)
652 decode_object_basic d ~nest obj_meta case_map Unknown_skip mem_miss dict
653
654and decode_any_mapping : type a.
655 decoder -> nest:int -> Event.spanned -> a t -> a any_map -> a =
656 fun d ~nest ev t map ->
657 match map.dec_object with
658 | Some t' -> decode d ~nest t'
659 | None ->
660 Jsont.Repr.type_error (meta_of_span d ev.span) t ~fnd:Jsont.Sort.Object
661
662and decode_mapping_key : decoder -> Event.spanned -> string * Jsont.Meta.t =
663 fun d ev ->
664 match ev.Event.event with
665 | Event.Scalar { value; _ } ->
666 skip_event d;
667 let meta = meta_of_span d ev.span in
668 (value, meta)
669 | _ ->
670 let meta = meta_of_span d ev.span in
671 err_msg meta "Mapping keys must be scalars (strings), found %a" Event.pp
672 ev.event
673
674(* Skip stream/document wrappers *)
675let skip_to_content d =
676 let rec loop () =
677 match peek_event d with
678 | Some { Event.event = Event.Stream_start _; _ } ->
679 skip_event d;
680 loop ()
681 | Some { Event.event = Event.Document_start _; _ } ->
682 skip_event d;
683 loop ()
684 | _ -> ()
685 in
686 loop ()
687
688let skip_end_wrappers d =
689 let rec loop () =
690 match peek_event d with
691 | Some { Event.event = Event.Document_end _; _ } ->
692 skip_event d;
693 loop ()
694 | Some { Event.event = Event.Stream_end; _ } ->
695 skip_event d;
696 loop ()
697 | None -> ()
698 | Some ev ->
699 let meta = meta_of_span d ev.span in
700 err_msg meta "Expected end of document but found %a" Event.pp ev.event
701 in
702 loop ()
703
704(* Skip to the end of the current document after an error *)
705let skip_to_document_end d =
706 let rec loop depth =
707 match peek_event d with
708 | None -> ()
709 | Some { Event.event = Event.Stream_end; _ } -> ()
710 | Some { Event.event = Event.Document_end _; _ } ->
711 skip_event d;
712 if depth = 0 then () else loop (depth - 1)
713 | Some { Event.event = Event.Document_start _; _ } ->
714 skip_event d;
715 loop (depth + 1)
716 | Some _ ->
717 skip_event d;
718 loop depth
719 in
720 loop 0
721
722(* Public decode API *)
723
724(* Decode all documents from a multi-document YAML stream *)
725let decode_all' ?(layout = false) ?(locs = false) ?(file = "-")
726 ?(max_depth = 100) ?(max_nodes = 10_000_000) t reader =
727 let parser = Parser.of_reader reader in
728 let d = make_decoder ~layout ~locs ~file ~max_depth ~max_nodes parser in
729 let t' = Jsont.Repr.of_t t in
730 let rec next_doc () =
731 match peek_event d with
732 | None -> Seq.Nil
733 | Some { Event.event = Event.Stream_end; _ } ->
734 skip_event d;
735 Seq.Nil
736 | Some _ -> (
737 try
738 skip_to_content d;
739 (* Reset node count for each document *)
740 d.node_count <- 0;
741 let v = decode d ~nest:0 t' in
742 (* Skip document end marker if present *)
743 (match peek_event d with
744 | Some { Event.event = Event.Document_end _; _ } -> skip_event d
745 | _ -> ());
746 Seq.Cons (Ok v, next_doc)
747 with
748 | Jsont.Error e ->
749 skip_to_document_end d;
750 Seq.Cons (Error e, next_doc)
751 | Error.Yamlrw_error err ->
752 skip_to_document_end d;
753 let msg = Error.to_string err in
754 let e = Jsont.(Error.make_msg Error.Context.empty Meta.none msg) in
755 Seq.Cons (Error e, next_doc))
756 in
757 next_doc
758
759let decode_all ?layout ?locs ?file ?max_depth ?max_nodes t reader =
760 decode_all' ?layout ?locs ?file ?max_depth ?max_nodes t reader
761 |> Seq.map (Result.map_error Jsont.Error.to_string)
762
763let decode' ?layout ?locs ?file ?max_depth ?max_nodes t reader =
764 let parser = Parser.of_reader reader in
765 let d = make_decoder ?layout ?locs ?file ?max_depth ?max_nodes parser in
766 try
767 skip_to_content d;
768 let t' = Jsont.Repr.of_t t in
769 let v = decode d ~nest:0 t' in
770 skip_end_wrappers d;
771 Ok v
772 with
773 | Jsont.Error e -> Error e
774 | Error.Yamlrw_error err ->
775 let msg = Error.to_string err in
776 Error Jsont.(Error.make_msg Error.Context.empty Meta.none msg)
777
778let decode ?layout ?locs ?file ?max_depth ?max_nodes t reader =
779 Result.map_error Jsont.Error.to_string
780 (decode' ?layout ?locs ?file ?max_depth ?max_nodes t reader)
781
782(* Encoder *)
783
784type encoder = {
785 emitter : Emitter.t;
786 format : yaml_format;
787 _indent : int; (* Stored for future use in custom formatting *)
788 explicit_doc : bool;
789 scalar_style : Scalar_style.t;
790}
791
792let make_encoder ?(format = Block) ?(indent = 2) ?(explicit_doc = false)
793 ?(scalar_style = `Any) emitter =
794 { emitter; format; _indent = indent; explicit_doc; scalar_style }
795
796let layout_style_of_format = function
797 | Block -> `Block
798 | Flow -> `Flow
799 | Layout -> `Any
800
801(* Choose appropriate scalar style for a string *)
802let choose_scalar_style ~preferred s =
803 if preferred <> `Any then preferred
804 else if String.contains s '\n' then `Literal
805 else if String.length s > 80 then `Folded
806 else `Plain
807
808(* Helper to create scalar events with common defaults *)
809let scalar_event ?(anchor = None) ?(tag = None) ~value ~style () =
810 Event.Scalar
811 {
812 anchor;
813 tag;
814 value;
815 plain_implicit = true;
816 quoted_implicit = true;
817 style;
818 }
819
820(* Helper to emit events *)
821let emit e = Emitter.emit e.emitter
822
823(* Encode null *)
824let encode_null e _meta = emit e (scalar_event ~value:"null" ~style:`Plain ())
825
826(* Encode boolean *)
827let encode_bool e _meta b =
828 emit e (scalar_event ~value:(if b then "true" else "false") ~style:`Plain ())
829
830(* Encode number *)
831let encode_number e _meta f =
832 let value =
833 match Float.classify_float f with
834 | FP_nan -> ".nan"
835 | FP_infinite -> if f > 0.0 then ".inf" else "-.inf"
836 | _ ->
837 if Float.is_integer f && Float.abs f < 1e15 then Printf.sprintf "%.0f" f
838 else Printf.sprintf "%g" f
839 in
840 emit e (scalar_event ~value ~style:`Plain ())
841
842(* Encode string *)
843let encode_string e _meta s =
844 let style = choose_scalar_style ~preferred:e.scalar_style s in
845 emit e (scalar_event ~value:s ~style ())
846
847let rec encode : type a. encoder -> a t -> a -> unit =
848 fun e t v ->
849 match t with
850 | Null map ->
851 let meta = map.enc_meta v in
852 let () = map.enc v in
853 encode_null e meta
854 | Bool map ->
855 let meta = map.enc_meta v in
856 let b = map.enc v in
857 encode_bool e meta b
858 | Number map ->
859 let meta = map.enc_meta v in
860 let f = map.enc v in
861 encode_number e meta f
862 | String map ->
863 let meta = map.enc_meta v in
864 let s = map.enc v in
865 encode_string e meta s
866 | Array map -> encode_array e map v
867 | Object map -> encode_object e map v
868 | Any map ->
869 let t' = map.enc v in
870 encode e t' v
871 | Map m -> encode e m.dom (m.enc v)
872 | Rec lazy_t -> encode e (Lazy.force lazy_t) v
873
874and encode_array : type a elt b. encoder -> (a, elt, b) array_map -> a -> unit =
875 fun e map v ->
876 let style = layout_style_of_format e.format in
877 emit e
878 (Event.Sequence_start { anchor = None; tag = None; implicit = true; style });
879 let _ =
880 map.enc
881 (fun () _idx elt ->
882 encode e map.elt elt;
883 ())
884 () v
885 in
886 emit e Event.Sequence_end
887
888and encode_object : type o. encoder -> (o, o) object_map -> o -> unit =
889 fun e map v ->
890 let style = layout_style_of_format e.format in
891 emit e (Event.Mapping_start { anchor = None; tag = None; implicit = true; style });
892 (* Encode each member *)
893 List.iter
894 (fun (Mem_enc mem) ->
895 let mem_v = mem.enc v in
896 if not (mem.enc_omit mem_v) then begin
897 (* Emit key *)
898 emit e (scalar_event ~value:mem.name ~style:`Plain ());
899 (* Emit value *)
900 encode e mem.type' mem_v
901 end)
902 map.mem_encs;
903 (* Handle case objects *)
904 (match map.shape with
905 | Object_basic _ -> ()
906 | Object_cases (_, cases) ->
907 let (Case_value (case_map, case_v)) = cases.enc_case (cases.enc v) in
908 (* Emit case tag *)
909 if not (cases.tag.enc_omit case_map.tag) then begin
910 emit e (scalar_event ~value:cases.tag.name ~style:`Plain ());
911 encode e cases.tag.type' case_map.tag
912 end;
913 (* Emit case members *)
914 List.iter
915 (fun (Mem_enc mem) ->
916 let mem_v = mem.enc case_v in
917 if not (mem.enc_omit mem_v) then begin
918 emit e (scalar_event ~value:mem.name ~style:`Plain ());
919 encode e mem.type' mem_v
920 end)
921 case_map.object_map.mem_encs);
922 emit e Event.Mapping_end
923
924(* Public encode API *)
925
926let encode' ?buf:_ ?format ?indent ?explicit_doc ?scalar_style t v ~eod writer =
927 let config =
928 {
929 Emitter.default_config with
930 indent = Option.value ~default:2 indent;
931 layout_style = (match format with Some Flow -> `Flow | _ -> `Block);
932 }
933 in
934 let emitter = Emitter.of_writer ~config writer in
935 let e = make_encoder ?format ?indent ?explicit_doc ?scalar_style emitter in
936 try
937 emit e (Event.Stream_start { encoding = `Utf8 });
938 emit e (Event.Document_start { version = None; implicit = not e.explicit_doc });
939 let t' = Jsont.Repr.of_t t in
940 encode e t' v;
941 emit e (Event.Document_end { implicit = not e.explicit_doc });
942 emit e Event.Stream_end;
943 if eod then Emitter.flush e.emitter;
944 Ok ()
945 with
946 | Jsont.Error err -> Error err
947 | Error.Yamlrw_error err ->
948 let msg = Error.to_string err in
949 Error Jsont.(Error.make_msg Error.Context.empty Meta.none msg)
950
951let encode ?buf ?format ?indent ?explicit_doc ?scalar_style t v ~eod writer =
952 Result.map_error Jsont.Error.to_string
953 (encode' ?buf ?format ?indent ?explicit_doc ?scalar_style t v ~eod writer)
954
955(* Recode *)
956
957let recode ?layout ?locs ?file ?max_depth ?max_nodes ?buf ?format ?indent
958 ?explicit_doc ?scalar_style t reader writer ~eod =
959 let format =
960 match (layout, format) with Some true, None -> Some Layout | _, f -> f
961 in
962 let layout =
963 match (layout, format) with None, Some Layout -> Some true | l, _ -> l
964 in
965 match decode' ?layout ?locs ?file ?max_depth ?max_nodes t reader with
966 | Ok v ->
967 encode ?buf ?format ?indent ?explicit_doc ?scalar_style t v ~eod writer
968 | Error e -> Error (Jsont.Error.to_string e)