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