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 | Map m ->
205 (* Handle Map combinators (e.g., from Jsont.option) *)
206 m.dec (decode_scalar_as d ev value style m.dom)
207 | Rec lazy_t ->
208 (* Handle recursive types *)
209 decode_scalar_as d ev value style (Lazy.force lazy_t)
210 | _ -> err_type_mismatch d ev.span t ~fnd:"scalar"
211
212(* Forward declaration for mutual recursion *)
213let rec decode : type a. decoder -> nest:int -> a t -> a =
214 fun d ~nest t ->
215 check_depth d ~nest;
216 match peek_event d with
217 | None -> err_msg_none "Unexpected end of YAML stream"
218 | Some ev -> (
219 match (ev.Event.event, t) with
220 (* Scalar events *)
221 | Event.Scalar { value; style; anchor; _ }, _ ->
222 skip_event d;
223 let result = decode_scalar d ~nest ev value style t in
224 (* Store anchor if present - TODO: implement anchor storage *)
225 (match anchor with
226 | Some _name ->
227 (* We need generic JSON for anchors - decode as json and convert back *)
228 ()
229 | None -> ());
230 result
231 (* Alias *)
232 | Event.Alias { anchor }, _ ->
233 skip_event d;
234 decode_alias d ev anchor t
235 (* Map combinator - must come before specific event matches *)
236 | _, Map m -> m.dec (decode d ~nest m.dom)
237 (* Recursive types - must come before specific event matches *)
238 | _, Rec lazy_t -> decode d ~nest (Lazy.force lazy_t)
239 (* Sequence -> Array *)
240 | Event.Sequence_start _, Array map -> decode_array d ~nest ev map
241 | Event.Sequence_start _, Any map -> decode_any_sequence d ~nest ev t map
242 | Event.Sequence_start _, _ ->
243 err_type_mismatch d ev.span t ~fnd:"sequence"
244 (* Mapping -> Object *)
245 | Event.Mapping_start _, Object map -> decode_object d ~nest ev map
246 | Event.Mapping_start _, Any map -> decode_any_mapping d ~nest ev t map
247 | Event.Mapping_start _, _ -> err_type_mismatch d ev.span t ~fnd:"mapping"
248 (* Unexpected events *)
249 | Event.Sequence_end, _ ->
250 err_msg (meta_of_span d ev.span) "Unexpected sequence end"
251 | Event.Mapping_end, _ ->
252 err_msg (meta_of_span d ev.span) "Unexpected mapping end"
253 | Event.Document_start _, _ ->
254 err_msg (meta_of_span d ev.span) "Unexpected document start"
255 | Event.Document_end _, _ ->
256 err_msg (meta_of_span d ev.span) "Unexpected document end"
257 | Event.Stream_start _, _ ->
258 err_msg (meta_of_span d ev.span) "Unexpected stream start"
259 | Event.Stream_end, _ ->
260 err_msg (meta_of_span d ev.span) "Unexpected stream end")
261
262and decode_scalar : type a.
263 decoder -> nest:int -> Event.spanned -> string -> Scalar_style.t -> a t -> a
264 =
265 fun d ~nest ev value style t ->
266 match t with
267 | Any map -> decode_any_scalar d ev value style t map
268 | Map m -> m.dec (decode_scalar d ~nest ev value style m.dom)
269 | Rec lazy_t -> decode_scalar d ~nest ev value style (Lazy.force lazy_t)
270 | _ -> decode_scalar_as d ev value style t
271
272and decode_any_scalar : type a.
273 decoder ->
274 Event.spanned ->
275 string ->
276 Scalar_style.t ->
277 a t ->
278 a any_map ->
279 a =
280 fun d ev value style t map ->
281 check_nodes d;
282 let meta = meta_of_span d ev.span in
283 let type_err fnd = Jsont.Repr.type_error meta t ~fnd in
284 (* Determine which decoder to use based on scalar content *)
285 if is_null_scalar value then
286 match map.dec_null with
287 | Some t' -> decode_scalar_as d ev value style t'
288 | None -> type_err Jsont.Sort.Null
289 else if style = `Plain then
290 (* Try bool, then number, then string *)
291 match bool_of_scalar_opt value with
292 | Some _ -> (
293 match map.dec_bool with
294 | Some t' -> decode_scalar_as d ev value style t'
295 | None -> (
296 match map.dec_string with
297 | Some t' -> decode_scalar_as d ev value style t'
298 | None -> type_err Jsont.Sort.Bool))
299 | None -> (
300 match float_of_scalar_opt value with
301 | Some _ -> (
302 match map.dec_number with
303 | Some t' -> decode_scalar_as d ev value style t'
304 | None -> (
305 match map.dec_string with
306 | Some t' -> decode_scalar_as d ev value style t'
307 | None -> type_err Jsont.Sort.Number))
308 | None -> (
309 (* Plain scalar that's not bool/number -> string *)
310 match map.dec_string with
311 | Some t' -> decode_scalar_as d ev value style t'
312 | None -> type_err Jsont.Sort.String))
313 else
314 (* Quoted scalars are strings *)
315 match map.dec_string with
316 | Some t' -> decode_scalar_as d ev value style t'
317 | None -> type_err Jsont.Sort.String
318
319and decode_alias : type a. decoder -> Event.spanned -> string -> a t -> a =
320 fun d ev anchor t ->
321 check_nodes d;
322 match Hashtbl.find_opt d._anchors anchor with
323 | None ->
324 let meta = meta_of_span d ev.span in
325 err_msg meta "Unknown anchor: %s" anchor
326 | Some json_value ->
327 (* Decode the stored JSON value through the type *)
328 let t' = Jsont.Repr.unsafe_to_t t in
329 match Jsont.Json.decode' t' json_value with
330 | Ok v -> v
331 | Error e -> raise (Jsont.Error e)
332
333and decode_array : type a elt b.
334 decoder -> nest:int -> Event.spanned -> (a, elt, b) array_map -> a =
335 fun d ~nest start_ev array_map ->
336 skip_event d;
337 (* consume Sequence_start *)
338 check_nodes d;
339 let meta = meta_of_span d start_ev.span in
340 let builder = ref (array_map.dec_empty ()) in
341 let idx = ref 0 in
342 let rec loop () =
343 match peek_event d with
344 | Some { Event.event = Event.Sequence_end; span } ->
345 skip_event d;
346 let end_meta = meta_of_span d span in
347 array_map.dec_finish end_meta !idx !builder
348 | Some _ ->
349 let i = !idx in
350 (try
351 if array_map.dec_skip i !builder then begin
352 (* Skip this element by decoding as ignore *)
353 let _ : unit =
354 decode d ~nest:(nest + 1) (Jsont.Repr.of_t Jsont.ignore)
355 in
356 ()
357 end
358 else begin
359 let elt = decode d ~nest:(nest + 1) array_map.elt in
360 builder := array_map.dec_add i elt !builder
361 end
362 with Jsont.Error e ->
363 Jsont.Repr.error_push_array meta array_map (i, Jsont.Meta.none) e);
364 incr idx;
365 loop ()
366 | None -> err_msg meta "Unclosed sequence"
367 in
368 loop ()
369
370and decode_any_sequence : type a.
371 decoder -> nest:int -> Event.spanned -> a t -> a any_map -> a =
372 fun d ~nest ev t map ->
373 match map.dec_array with
374 | Some t' -> (
375 (* The t' decoder might be wrapped (e.g., Map for option types)
376 Directly decode the array and let the wrapper handle it *)
377 match t' with
378 | Array array_map -> decode_array d ~nest ev array_map
379 | _ ->
380 (* For wrapped types like Map (Array ...), use full decode *)
381 decode d ~nest t')
382 | None ->
383 Jsont.Repr.type_error (meta_of_span d ev.span) t ~fnd:Jsont.Sort.Array
384
385and decode_object : type o.
386 decoder -> nest:int -> Event.spanned -> (o, o) object_map -> o =
387 fun d ~nest start_ev map ->
388 skip_event d;
389 (* consume Mapping_start *)
390 check_nodes d;
391 let meta = meta_of_span d start_ev.span in
392 let dict =
393 decode_object_members d ~nest meta map String_map.empty Dict.empty
394 in
395 let dict = Dict.add object_meta_arg meta dict in
396 apply_dict map.dec dict
397
398and decode_object_members : type o.
399 decoder ->
400 nest:int ->
401 Jsont.Meta.t ->
402 (o, o) object_map ->
403 mem_dec String_map.t ->
404 Dict.t ->
405 Dict.t =
406 fun d ~nest obj_meta map mem_miss dict ->
407 (* Merge expected member decoders *)
408 let u _ _ _ = assert false in
409 let mem_miss = String_map.union u mem_miss map.mem_decs in
410 match map.shape with
411 | Object_basic umems ->
412 decode_object_basic d ~nest obj_meta map umems mem_miss dict
413 | Object_cases (umems_opt, cases) ->
414 (* Wrap umems_opt to hide existential types *)
415 let umems = Unknown_mems umems_opt in
416 decode_object_cases d ~nest obj_meta map umems cases mem_miss [] dict
417
418and decode_object_basic : type o mems builder.
419 decoder ->
420 nest:int ->
421 Jsont.Meta.t ->
422 (o, o) object_map ->
423 (o, mems, builder) unknown_mems ->
424 mem_dec String_map.t ->
425 Dict.t ->
426 Dict.t =
427 fun d ~nest obj_meta object_map umems mem_miss dict ->
428 let ubuilder =
429 ref
430 (match umems with
431 | Unknown_skip | Unknown_error -> Obj.magic ()
432 | Unknown_keep (mmap, _) -> mmap.dec_empty ())
433 in
434 let mem_miss = ref mem_miss in
435 let dict = ref dict in
436 let rec loop () =
437 match peek_event d with
438 | Some { Event.event = Event.Mapping_end; _ } ->
439 skip_event d;
440 (* Finalize *)
441 finish_object obj_meta object_map umems !ubuilder !mem_miss !dict
442 | Some ev ->
443 (* Expect a scalar key *)
444 let name, name_meta = decode_mapping_key d ev in
445 (* Look up member decoder *)
446 (match String_map.find_opt name object_map.mem_decs with
447 | Some (Mem_dec mem) -> (
448 mem_miss := String_map.remove name !mem_miss;
449 try
450 let v = decode d ~nest:(nest + 1) mem.type' in
451 dict := Dict.add mem.id v !dict
452 with Jsont.Error e ->
453 Jsont.Repr.error_push_object obj_meta object_map (name, name_meta)
454 e)
455 | None -> (
456 (* Unknown member *)
457 match umems with
458 | Unknown_skip ->
459 let _ : unit =
460 decode d ~nest:(nest + 1) (Jsont.Repr.of_t Jsont.ignore)
461 in
462 ()
463 | Unknown_error ->
464 Jsont.Repr.unexpected_mems_error obj_meta object_map
465 ~fnd:[ (name, name_meta) ]
466 | Unknown_keep (mmap, _) -> (
467 try
468 let v = decode d ~nest:(nest + 1) mmap.mems_type in
469 ubuilder := mmap.dec_add name_meta name v !ubuilder
470 with Jsont.Error e ->
471 Jsont.Repr.error_push_object obj_meta object_map
472 (name, name_meta) e)));
473 loop ()
474 | None -> err_msg obj_meta "Unclosed mapping"
475 in
476 loop ()
477
478and finish_object : type o mems builder.
479 Jsont.Meta.t ->
480 (o, o) object_map ->
481 (o, mems, builder) unknown_mems ->
482 builder ->
483 mem_dec String_map.t ->
484 Dict.t ->
485 Dict.t =
486 fun meta map umems ubuilder mem_miss dict ->
487 let open Jsont.Repr in
488 let dict = Dict.add object_meta_arg meta dict in
489 let dict =
490 match umems with
491 | Unknown_skip | Unknown_error -> dict
492 | Unknown_keep (mmap, _) ->
493 Dict.add mmap.id (mmap.dec_finish meta ubuilder) dict
494 in
495 (* Check for missing required members *)
496 let add_default _ (Mem_dec mem_map) dict =
497 match mem_map.dec_absent with
498 | Some v -> Dict.add mem_map.id v dict
499 | None -> raise Exit
500 in
501 try String_map.fold add_default mem_miss dict
502 with Exit ->
503 let no_default _ (Mem_dec mm) = Option.is_none mm.dec_absent in
504 let exp = String_map.filter no_default mem_miss in
505 missing_mems_error meta map ~exp ~fnd:[]
506
507and decode_object_cases : type o cases tag.
508 decoder ->
509 nest:int ->
510 Jsont.Meta.t ->
511 (o, o) object_map ->
512 unknown_mems_option ->
513 (o, cases, tag) object_cases ->
514 mem_dec String_map.t ->
515 (Jsont.name * Jsont.json) list ->
516 Dict.t ->
517 Dict.t =
518 fun d ~nest obj_meta object_map umems cases mem_miss delayed dict ->
519 match peek_event d with
520 | Some { Event.event = Event.Mapping_end; _ } -> (
521 skip_event d;
522 (* No tag found - use dec_absent if available *)
523 match cases.tag.dec_absent with
524 | Some tag ->
525 decode_with_case_tag d ~nest obj_meta object_map umems cases tag
526 mem_miss delayed dict
527 | None ->
528 (* Missing required case tag *)
529 let exp = String_map.singleton cases.tag.name (Mem_dec cases.tag) in
530 let fnd = List.map (fun ((n, _), _) -> n) delayed in
531 Jsont.Repr.missing_mems_error obj_meta object_map ~exp ~fnd)
532 | Some ev ->
533 let name, name_meta = decode_mapping_key d ev in
534 if String.equal name cases.tag.name then begin
535 (* Found the case tag *)
536 let tag = decode d ~nest:(nest + 1) cases.tag.type' in
537 decode_with_case_tag d ~nest obj_meta object_map umems cases tag
538 mem_miss delayed dict
539 end
540 else begin
541 (* Not the case tag - check if known member or delay *)
542 match String_map.find_opt name object_map.mem_decs with
543 | Some (Mem_dec mem) -> (
544 let mem_miss = String_map.remove name mem_miss in
545 try
546 let v = decode d ~nest:(nest + 1) mem.type' in
547 let dict = Dict.add mem.id v dict in
548 decode_object_cases d ~nest obj_meta object_map umems cases
549 mem_miss delayed dict
550 with Jsont.Error e ->
551 Jsont.Repr.error_push_object obj_meta object_map (name, name_meta)
552 e)
553 | None ->
554 (* Unknown member - decode as generic JSON and delay *)
555 let v =
556 decode d ~nest:(nest + 1) (Jsont.Repr.of_t Jsont.json)
557 in
558 let delayed = ((name, name_meta), v) :: delayed in
559 decode_object_cases d ~nest obj_meta object_map umems cases
560 mem_miss delayed dict
561 end
562 | None -> err_msg obj_meta "Unclosed mapping"
563
564and decode_with_case_tag : type o cases tag.
565 decoder ->
566 nest:int ->
567 Jsont.Meta.t ->
568 (o, o) object_map ->
569 unknown_mems_option ->
570 (o, cases, tag) object_cases ->
571 tag ->
572 mem_dec String_map.t ->
573 (Jsont.name * Jsont.json) list ->
574 Dict.t ->
575 Dict.t =
576 fun d ~nest obj_meta map umems cases tag mem_miss delayed dict ->
577 let open Jsont.Repr in
578 let eq_tag (Case c) = cases.tag_compare c.tag tag = 0 in
579 match List.find_opt eq_tag cases.cases with
580 | None -> unexpected_case_tag_error obj_meta map cases tag
581 | Some (Case case) ->
582 (* Continue decoding with the case's object map *)
583 let case_dict =
584 decode_case_remaining d ~nest obj_meta case.object_map umems mem_miss
585 delayed dict
586 in
587 let case_value = apply_dict case.object_map.dec case_dict in
588 Dict.add cases.id (case.dec case_value) dict
589
590and decode_case_remaining : type o.
591 decoder ->
592 nest:int ->
593 Jsont.Meta.t ->
594 (o, o) object_map ->
595 unknown_mems_option ->
596 mem_dec String_map.t ->
597 (Jsont.name * Jsont.json) list ->
598 Dict.t ->
599 Dict.t =
600 fun d ~nest obj_meta case_map _umems mem_miss delayed dict ->
601 (* First, process delayed members against the case map *)
602 let u _ _ _ = assert false in
603 let mem_miss = String_map.union u mem_miss case_map.mem_decs in
604 let dict, mem_miss =
605 List.fold_left
606 (fun (dict, mem_miss) ((name, meta), json_value) ->
607 match String_map.find_opt name case_map.mem_decs with
608 | Some (Mem_dec mem) -> (
609 let t' = Jsont.Repr.unsafe_to_t mem.type' in
610 match Jsont.Json.decode' t' json_value with
611 | Ok v ->
612 let dict = Dict.add mem.id v dict in
613 let mem_miss = String_map.remove name mem_miss in
614 (dict, mem_miss)
615 | Error e ->
616 Jsont.Repr.error_push_object obj_meta case_map (name, meta) e)
617 | None ->
618 (* Unknown for case too - skip them *)
619 (dict, mem_miss))
620 (dict, mem_miss) delayed
621 in
622 (* Then continue reading remaining members using case's own unknown handling *)
623 match case_map.shape with
624 | Object_basic case_umems ->
625 decode_object_basic d ~nest obj_meta case_map case_umems mem_miss dict
626 | Object_cases _ ->
627 (* Nested cases shouldn't happen - use skip for safety *)
628 decode_object_basic d ~nest obj_meta case_map Unknown_skip mem_miss dict
629
630and decode_any_mapping : type a.
631 decoder -> nest:int -> Event.spanned -> a t -> a any_map -> a =
632 fun d ~nest ev t map ->
633 match map.dec_object with
634 | Some t' -> decode d ~nest t'
635 | None ->
636 Jsont.Repr.type_error (meta_of_span d ev.span) t ~fnd:Jsont.Sort.Object
637
638and decode_mapping_key : decoder -> Event.spanned -> string * Jsont.Meta.t =
639 fun d ev ->
640 match ev.Event.event with
641 | Event.Scalar { value; _ } ->
642 skip_event d;
643 let meta = meta_of_span d ev.span in
644 (value, meta)
645 | _ ->
646 let meta = meta_of_span d ev.span in
647 err_msg meta "Mapping keys must be scalars (strings), found %a" Event.pp
648 ev.event
649
650(* Skip stream/document wrappers *)
651let skip_to_content d =
652 let rec loop () =
653 match peek_event d with
654 | Some { Event.event = Event.Stream_start _; _ } ->
655 skip_event d;
656 loop ()
657 | Some { Event.event = Event.Document_start _; _ } ->
658 skip_event d;
659 loop ()
660 | _ -> ()
661 in
662 loop ()
663
664let skip_end_wrappers d =
665 let rec loop () =
666 match peek_event d with
667 | Some { Event.event = Event.Document_end _; _ } ->
668 skip_event d;
669 loop ()
670 | Some { Event.event = Event.Stream_end; _ } ->
671 skip_event d;
672 loop ()
673 | None -> ()
674 | Some ev ->
675 let meta = meta_of_span d ev.span in
676 err_msg meta "Expected end of document but found %a" Event.pp ev.event
677 in
678 loop ()
679
680(* Skip to the end of the current document after an error *)
681let skip_to_document_end d =
682 let rec loop depth =
683 match peek_event d with
684 | None -> ()
685 | Some { Event.event = Event.Stream_end; _ } -> ()
686 | Some { Event.event = Event.Document_end _; _ } ->
687 skip_event d;
688 if depth = 0 then () else loop (depth - 1)
689 | Some { Event.event = Event.Document_start _; _ } ->
690 skip_event d;
691 loop (depth + 1)
692 | Some _ ->
693 skip_event d;
694 loop depth
695 in
696 loop 0
697
698(* Public decode API *)
699
700(* Decode all documents from a multi-document YAML stream *)
701let decode_all' ?(layout = false) ?(locs = false) ?(file = "-")
702 ?(max_depth = 100) ?(max_nodes = 10_000_000) t reader =
703 let parser = Parser.of_reader reader in
704 let d = make_decoder ~layout ~locs ~file ~max_depth ~max_nodes parser in
705 let t' = Jsont.Repr.of_t t in
706 let rec next_doc () =
707 match peek_event d with
708 | None -> Seq.Nil
709 | Some { Event.event = Event.Stream_end; _ } ->
710 skip_event d;
711 Seq.Nil
712 | Some _ -> (
713 try
714 skip_to_content d;
715 (* Reset node count for each document *)
716 d.node_count <- 0;
717 let v = decode d ~nest:0 t' in
718 (* Skip document end marker if present *)
719 (match peek_event d with
720 | Some { Event.event = Event.Document_end _; _ } -> skip_event d
721 | _ -> ());
722 Seq.Cons (Ok v, next_doc)
723 with
724 | Jsont.Error e ->
725 skip_to_document_end d;
726 Seq.Cons (Error e, next_doc)
727 | Error.Yamlrw_error err ->
728 skip_to_document_end d;
729 let msg = Error.to_string err in
730 let e = Jsont.(Error.make_msg Error.Context.empty Meta.none msg) in
731 Seq.Cons (Error e, next_doc))
732 in
733 next_doc
734
735let decode_all ?layout ?locs ?file ?max_depth ?max_nodes t reader =
736 decode_all' ?layout ?locs ?file ?max_depth ?max_nodes t reader
737 |> Seq.map (Result.map_error Jsont.Error.to_string)
738
739let decode' ?layout ?locs ?file ?max_depth ?max_nodes t reader =
740 let parser = Parser.of_reader reader in
741 let d = make_decoder ?layout ?locs ?file ?max_depth ?max_nodes parser in
742 try
743 skip_to_content d;
744 let t' = Jsont.Repr.of_t t in
745 let v = decode d ~nest:0 t' in
746 skip_end_wrappers d;
747 Ok v
748 with
749 | Jsont.Error e -> Error e
750 | Error.Yamlrw_error err ->
751 let msg = Error.to_string err in
752 Error Jsont.(Error.make_msg Error.Context.empty Meta.none msg)
753
754let decode ?layout ?locs ?file ?max_depth ?max_nodes t reader =
755 Result.map_error Jsont.Error.to_string
756 (decode' ?layout ?locs ?file ?max_depth ?max_nodes t reader)
757
758(* Encoder *)
759
760type encoder = {
761 emitter : Emitter.t;
762 format : yaml_format;
763 _indent : int; (* Stored for future use in custom formatting *)
764 explicit_doc : bool;
765 scalar_style : Scalar_style.t;
766}
767
768let make_encoder ?(format = Block) ?(indent = 2) ?(explicit_doc = false)
769 ?(scalar_style = `Any) emitter =
770 { emitter; format; _indent = indent; explicit_doc; scalar_style }
771
772let layout_style_of_format = function
773 | Block -> `Block
774 | Flow -> `Flow
775 | Layout -> `Any
776
777(* Choose appropriate scalar style for a string *)
778let choose_scalar_style ~preferred s =
779 if preferred <> `Any then preferred
780 else if String.contains s '\n' then `Literal
781 else if String.length s > 80 then `Folded
782 else `Plain
783
784(* Helper to create scalar events with common defaults *)
785let scalar_event ?(anchor = None) ?(tag = None) ~value ~style () =
786 Event.Scalar
787 {
788 anchor;
789 tag;
790 value;
791 plain_implicit = true;
792 quoted_implicit = true;
793 style;
794 }
795
796(* Helper to emit events *)
797let emit e = Emitter.emit e.emitter
798
799(* Encode null *)
800let encode_null e _meta = emit e (scalar_event ~value:"null" ~style:`Plain ())
801
802(* Encode boolean *)
803let encode_bool e _meta b =
804 emit e (scalar_event ~value:(if b then "true" else "false") ~style:`Plain ())
805
806(* Encode number *)
807let encode_number e _meta f =
808 let value =
809 match Float.classify_float f with
810 | FP_nan -> ".nan"
811 | FP_infinite -> if f > 0.0 then ".inf" else "-.inf"
812 | _ ->
813 if Float.is_integer f && Float.abs f < 1e15 then Printf.sprintf "%.0f" f
814 else Printf.sprintf "%g" f
815 in
816 emit e (scalar_event ~value ~style:`Plain ())
817
818(* Encode string *)
819let encode_string e _meta s =
820 let style = choose_scalar_style ~preferred:e.scalar_style s in
821 emit e (scalar_event ~value:s ~style ())
822
823let rec encode : type a. encoder -> a t -> a -> unit =
824 fun e t v ->
825 match t with
826 | Null map ->
827 let meta = map.enc_meta v in
828 let () = map.enc v in
829 encode_null e meta
830 | Bool map ->
831 let meta = map.enc_meta v in
832 let b = map.enc v in
833 encode_bool e meta b
834 | Number map ->
835 let meta = map.enc_meta v in
836 let f = map.enc v in
837 encode_number e meta f
838 | String map ->
839 let meta = map.enc_meta v in
840 let s = map.enc v in
841 encode_string e meta s
842 | Array map -> encode_array e map v
843 | Object map -> encode_object e map v
844 | Any map ->
845 let t' = map.enc v in
846 encode e t' v
847 | Map m -> encode e m.dom (m.enc v)
848 | Rec lazy_t -> encode e (Lazy.force lazy_t) v
849
850and encode_array : type a elt b. encoder -> (a, elt, b) array_map -> a -> unit =
851 fun e map v ->
852 let style = layout_style_of_format e.format in
853 emit e
854 (Event.Sequence_start { anchor = None; tag = None; implicit = true; style });
855 let _ =
856 map.enc
857 (fun () _idx elt ->
858 encode e map.elt elt;
859 ())
860 () v
861 in
862 emit e Event.Sequence_end
863
864and encode_object : type o. encoder -> (o, o) object_map -> o -> unit =
865 fun e map v ->
866 let style = layout_style_of_format e.format in
867 emit e (Event.Mapping_start { anchor = None; tag = None; implicit = true; style });
868 (* Encode each member *)
869 List.iter
870 (fun (Mem_enc mem) ->
871 let mem_v = mem.enc v in
872 if not (mem.enc_omit mem_v) then begin
873 (* Emit key *)
874 emit e (scalar_event ~value:mem.name ~style:`Plain ());
875 (* Emit value *)
876 encode e mem.type' mem_v
877 end)
878 map.mem_encs;
879 (* Handle case objects *)
880 (match map.shape with
881 | Object_basic _ -> ()
882 | Object_cases (_, cases) ->
883 let (Case_value (case_map, case_v)) = cases.enc_case (cases.enc v) in
884 (* Emit case tag *)
885 if not (cases.tag.enc_omit case_map.tag) then begin
886 emit e (scalar_event ~value:cases.tag.name ~style:`Plain ());
887 encode e cases.tag.type' case_map.tag
888 end;
889 (* Emit case members *)
890 List.iter
891 (fun (Mem_enc mem) ->
892 let mem_v = mem.enc case_v in
893 if not (mem.enc_omit mem_v) then begin
894 emit e (scalar_event ~value:mem.name ~style:`Plain ());
895 encode e mem.type' mem_v
896 end)
897 case_map.object_map.mem_encs);
898 emit e Event.Mapping_end
899
900(* Public encode API *)
901
902let encode' ?buf:_ ?format ?indent ?explicit_doc ?scalar_style t v ~eod writer =
903 let config =
904 {
905 Emitter.default_config with
906 indent = Option.value ~default:2 indent;
907 layout_style = (match format with Some Flow -> `Flow | _ -> `Block);
908 }
909 in
910 let emitter = Emitter.of_writer ~config writer in
911 let e = make_encoder ?format ?indent ?explicit_doc ?scalar_style emitter in
912 try
913 emit e (Event.Stream_start { encoding = `Utf8 });
914 emit e (Event.Document_start { version = None; implicit = not e.explicit_doc });
915 let t' = Jsont.Repr.of_t t in
916 encode e t' v;
917 emit e (Event.Document_end { implicit = not e.explicit_doc });
918 emit e Event.Stream_end;
919 if eod then Emitter.flush e.emitter;
920 Ok ()
921 with
922 | Jsont.Error err -> Error err
923 | Error.Yamlrw_error err ->
924 let msg = Error.to_string err in
925 Error Jsont.(Error.make_msg Error.Context.empty Meta.none msg)
926
927let encode ?buf ?format ?indent ?explicit_doc ?scalar_style t v ~eod writer =
928 Result.map_error Jsont.Error.to_string
929 (encode' ?buf ?format ?indent ?explicit_doc ?scalar_style t v ~eod writer)
930
931(* Recode *)
932
933let recode ?layout ?locs ?file ?max_depth ?max_nodes ?buf ?format ?indent
934 ?explicit_doc ?scalar_style t reader writer ~eod =
935 let format =
936 match (layout, format) with Some true, None -> Some Layout | _, f -> f
937 in
938 let layout =
939 match (layout, format) with None, Some Layout -> Some true | l, _ -> l
940 in
941 match decode' ?layout ?locs ?file ?max_depth ?max_nodes t reader with
942 | Ok v ->
943 encode ?buf ?format ?indent ?explicit_doc ?scalar_style t v ~eod writer
944 | Error e -> Error (Jsont.Error.to_string e)