···
(*---------------------------------------------------------------------------
2
-
Copyright (c) 2024 The yamlrw programmers. All rights reserved.
3
-
SPDX-License-Identifier: ISC
4
-
---------------------------------------------------------------------------*)
2
+
Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
···
meta_none : Jsont.Meta.t;
30
-
?(locs = false) ?(layout = false) ?(file = "-")
29
+
let make_decoder ?(locs = false) ?(layout = false) ?(file = "-")
?(max_depth = 100) ?(max_nodes = 10_000_000) parser =
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 }
41
+
_anchors = Hashtbl.create 16;
let check_depth d ~nest =
if nest > d.max_depth then
41
-
Jsont.Error.msgf Jsont.Meta.none "Maximum nesting depth %d exceeded" d.max_depth
49
+
Jsont.Error.msgf Jsont.Meta.none "Maximum nesting depth %d exceeded"
d.node_count <- d.node_count + 1;
if d.node_count > d.max_nodes then
46
-
Jsont.Error.msgf Jsont.Meta.none "Maximum node count %d exceeded" d.max_nodes
55
+
Jsont.Error.msgf Jsont.Meta.none "Maximum node count %d exceeded"
let 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
+
if not d.locs then d.meta_none
61
+
let start = span.Span.start and stop = span.Span.stop in
62
+
let first_byte = start.Position.index in
63
+
let last_byte = max first_byte (stop.Position.index - 1) in
64
+
(* line_pos is (line_number, byte_position_of_line_start) *)
66
+
(start.Position.line, start.Position.index - start.Position.column + 1)
69
+
(stop.Position.line, stop.Position.index - stop.Position.column + 1)
72
+
Jsont.Textloc.make ~file:d.file ~first_byte ~last_byte ~first_line
75
+
Jsont.Meta.make textloc
d.current <- Parser.next d.parser;
65
-
match d.current with
66
-
| Some _ -> d.current
67
-
| None -> next_event d
82
+
match d.current with Some _ -> d.current | None -> next_event d
84
+
let skip_event d = d.current <- None
let _expect_event d pred name =
74
-
| Some ev when pred ev.Event.event -> skip_event d; ev
88
+
| Some ev when pred ev.Event.event ->
let span = ev.Event.span in
let meta = meta_of_span d span in
78
-
Jsont.Error.msgf meta "Expected %s but found %a" name Event.pp ev.Event.event
94
+
Jsont.Error.msgf meta "Expected %s but found %a" name Event.pp
80
-
Jsont.Error.msgf Jsont.Meta.none "Expected %s but reached end of stream" name
97
+
Jsont.Error.msgf Jsont.Meta.none "Expected %s but reached end of stream"
···
let err_type_mismatch d span t ~fnd =
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
108
+
Jsont.Error.msgf meta "Expected %s but found %s" (Jsont.Repr.kinded_sort t)
(* YAML scalar resolution *)
96
-
s = "" || s = "~" ||
97
-
s = "null" || s = "Null" || s = "NULL"
114
+
s = "" || s = "~" || s = "null" || s = "Null" || s = "NULL"
let bool_of_scalar_opt s =
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
118
+
| "true" | "True" | "TRUE" | "yes" | "Yes" | "YES" | "on" | "On" | "ON" ->
120
+
| "false" | "False" | "FALSE" | "no" | "No" | "NO" | "off" | "Off" | "OFF" ->
let float_of_scalar_opt s =
···
| "+.inf" | "+.Inf" | "+.INF" -> Some Float.infinity
| "-.inf" | "-.Inf" | "-.INF" -> Some Float.neg_infinity
| ".nan" | ".NaN" | ".NAN" -> Some Float.nan
(* Try parsing as number, allowing underscores *)
let s' = String.concat "" (String.split_on_char '_' s) in
(* Try int first (supports 0o, 0x, 0b) then float *)
match int_of_string_opt s' with
| Some i -> Some (float_of_int i)
122
-
| None -> float_of_string_opt s'
137
+
| None -> float_of_string_opt s')
let _int_of_scalar_opt s =
(* Handle hex, octal, and regular integers with underscores *)
···
(* Decode a scalar value according to expected type *)
130
-
let rec decode_scalar_as :
131
-
type a. decoder -> Event.spanned -> string -> Scalar_style.t -> a t -> a =
132
-
fun d ev value style t ->
145
+
let rec decode_scalar_as : type a.
146
+
decoder -> Event.spanned -> string -> Scalar_style.t -> a t -> a =
147
+
fun d ev value style t ->
let meta = meta_of_span d ev.Event.span in
if is_null_scalar value then map.dec meta ()
else err_type_mismatch d ev.span t ~fnd:("scalar " ^ value)
140
-
(match bool_of_scalar_opt value with
141
-
| Some b -> map.dec meta b
143
-
(* For explicitly quoted strings, fail *)
144
-
if style <> `Plain then
145
-
err_type_mismatch d ev.span t ~fnd:("string " ^ value)
147
-
err_type_mismatch d ev.span t ~fnd:("scalar " ^ value))
149
-
(* Handle null -> nan mapping like jsont *)
150
-
if is_null_scalar value then map.dec meta Float.nan
155
+
match bool_of_scalar_opt value with
156
+
| Some b -> map.dec meta b
158
+
(* For explicitly quoted strings, fail *)
159
+
if style <> `Plain then
160
+
err_type_mismatch d ev.span t ~fnd:("string " ^ value)
161
+
else err_type_mismatch d ev.span t ~fnd:("scalar " ^ value))
164
+
(* Handle null -> nan mapping like jsont *)
165
+
is_null_scalar value
166
+
then map.dec meta Float.nan
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))
168
+
match float_of_scalar_opt value with
169
+
| Some f -> map.dec meta f
170
+
| None -> err_type_mismatch d ev.span t ~fnd:("scalar " ^ value))
(* Don't decode null values as strings - they should fail so outer combinators
like 'option' or 'any' can handle them properly.
···
(* Handle recursive types *)
decode_scalar_as d ev value style (Lazy.force lazy_t)
172
-
err_type_mismatch d ev.span t ~fnd:"scalar"
187
+
| _ -> err_type_mismatch d ev.span t ~fnd:"scalar"
(* Forward declaration for mutual recursion *)
let rec decode : type a. decoder -> nest:int -> a t -> a =
| None -> Jsont.Error.msgf Jsont.Meta.none "Unexpected end of YAML stream"
181
-
match ev.Event.event, t with
196
+
match (ev.Event.event, t) with
| Event.Scalar { value; style; anchor; _ }, _ ->
let result = decode_scalar d ~nest ev value style t in
(* Store anchor if present - TODO: implement anchor storage *)
189
-
(* We need generic JSON for anchors - decode as json and convert back *)
204
+
(* We need generic JSON for anchors - decode as json and convert back *)
| Event.Alias { anchor }, _ ->
decode_alias d ev anchor t
(* Map combinator - must come before specific event matches *)
201
-
m.dec (decode d ~nest m.dom)
213
+
| _, Map m -> m.dec (decode d ~nest m.dom)
(* Recursive types - must come before specific event matches *)
205
-
decode d ~nest (Lazy.force lazy_t)
215
+
| _, Rec lazy_t -> decode d ~nest (Lazy.force lazy_t)
208
-
| Event.Sequence_start _, Array map ->
209
-
decode_array d ~nest ev map
211
-
| Event.Sequence_start _, Any map ->
212
-
decode_any_sequence d ~nest ev t map
217
+
| Event.Sequence_start _, Array map -> decode_array d ~nest ev map
218
+
| Event.Sequence_start _, Any map -> decode_any_sequence d ~nest ev t map
| Event.Sequence_start _, _ ->
err_type_mismatch d ev.span t ~fnd:"sequence"
218
-
| Event.Mapping_start _, Object map ->
219
-
decode_object d ~nest ev map
221
-
| Event.Mapping_start _, Any map ->
222
-
decode_any_mapping d ~nest ev t map
224
-
| Event.Mapping_start _, _ ->
225
-
err_type_mismatch d ev.span t ~fnd:"mapping"
222
+
| Event.Mapping_start _, Object map -> decode_object d ~nest ev map
223
+
| Event.Mapping_start _, Any map -> decode_any_mapping d ~nest ev t map
224
+
| Event.Mapping_start _, _ -> err_type_mismatch d ev.span t ~fnd:"mapping"
| Event.Sequence_end, _ ->
Jsont.Error.msgf (meta_of_span d ev.span) "Unexpected sequence end"
···
| Event.Stream_start _, _ ->
Jsont.Error.msgf (meta_of_span d ev.span) "Unexpected stream start"
239
-
Jsont.Error.msgf (meta_of_span d ev.span) "Unexpected stream end"
237
+
Jsont.Error.msgf (meta_of_span d ev.span) "Unexpected stream end")
241
-
and decode_scalar : type a. decoder -> nest:int -> Event.spanned -> string -> Scalar_style.t -> a t -> a =
242
-
fun d ~nest ev value style t ->
239
+
and decode_scalar : type a.
240
+
decoder -> nest:int -> Event.spanned -> string -> Scalar_style.t -> a t -> a
242
+
fun d ~nest ev value style t ->
| Any map -> decode_any_scalar d ev value style t map
| Map m -> m.dec (decode_scalar d ~nest ev value style m.dom)
| Rec lazy_t -> decode_scalar d ~nest ev value style (Lazy.force lazy_t)
| _ -> decode_scalar_as d ev value style t
249
-
and 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 ->
249
+
and decode_any_scalar : type a.
257
+
fun d ev value style t map ->
(* Determine which decoder to use based on scalar content *)
if is_null_scalar value then
| 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
264
+
Jsont.Repr.type_error (meta_of_span d ev.span) t ~fnd:Jsont.Sort.Null
else if style = `Plain then
(* Try bool, then number, then string *)
match bool_of_scalar_opt value with
261
-
(match map.dec_bool with
262
-
| Some t' -> decode_scalar_as d ev value style t'
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)
269
+
match map.dec_bool with
270
+
| Some t' -> decode_scalar_as d ev value style t'
272
+
match map.dec_string with
273
+
| Some t' -> decode_scalar_as d ev value style t'
275
+
Jsont.Repr.type_error (meta_of_span d ev.span) t
276
+
~fnd:Jsont.Sort.Bool))
match float_of_scalar_opt value with
270
-
(match map.dec_number with
271
-
| Some t' -> decode_scalar_as d ev value style t'
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)
280
+
match map.dec_number with
281
+
| Some t' -> decode_scalar_as d ev value style t'
283
+
match map.dec_string with
284
+
| Some t' -> decode_scalar_as d ev value style t'
286
+
Jsont.Repr.type_error (meta_of_span d ev.span) t
287
+
~fnd:Jsont.Sort.Number))
(* Plain scalar that's not bool/number -> string *)
match map.dec_string with
| 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
293
+
Jsont.Repr.type_error (meta_of_span d ev.span) t
294
+
~fnd:Jsont.Sort.String))
(* Quoted scalars are strings *)
match map.dec_string with
| 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
300
+
Jsont.Repr.type_error (meta_of_span d ev.span) t ~fnd:Jsont.Sort.String
and decode_alias : type a. decoder -> Event.spanned -> string -> a t -> a =
288
-
fun d ev anchor t ->
303
+
fun d ev anchor t ->
match Hashtbl.find_opt d._anchors anchor with
let meta = meta_of_span d ev.span in
Jsont.Error.msgf meta "Unknown anchor: %s" anchor
(* Decode the stored JSON value through the type *)
let t' = Jsont.Repr.unsafe_to_t t in
match Jsont.Json.decode' t' json with
299
-
| Error e -> raise (Jsont.Error e)
314
+
| Error e -> raise (Jsont.Error e))
301
-
and 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 *)
316
+
and decode_array : type a elt b.
317
+
decoder -> nest:int -> Event.spanned -> (a, elt, b) array_map -> a =
318
+
fun d ~nest start_ev map ->
320
+
(* consume Sequence_start *)
let meta = meta_of_span d start_ev.span in
let builder = ref (map.dec_empty ()) in
···
if map.dec_skip i !builder then begin
(* Skip this element by decoding as ignore *)
319
-
let _ : unit = decode d ~nest:(nest + 1) (Jsont.Repr.of_t Jsont.ignore) in
337
+
decode d ~nest:(nest + 1) (Jsont.Repr.of_t Jsont.ignore)
let elt = decode d ~nest:(nest + 1) map.elt in
builder := map.dec_add i elt !builder
···
Jsont.Repr.error_push_array meta map (i, imeta) e);
331
-
Jsont.Error.msgf meta "Unclosed sequence"
350
+
| None -> Jsont.Error.msgf meta "Unclosed sequence"
335
-
and decode_any_sequence : type a. decoder -> nest:int -> Event.spanned -> a t -> a any_map -> a =
336
-
fun d ~nest ev t map ->
354
+
and decode_any_sequence : type a.
355
+
decoder -> nest:int -> Event.spanned -> a t -> a any_map -> a =
356
+
fun d ~nest ev t map ->
(* The t' decoder might be wrapped (e.g., Map for option types)
Directly decode the array and let the wrapper handle it *)
342
-
| Array array_map ->
343
-
decode_array d ~nest ev array_map
345
-
(* For wrapped types like Map (Array ...), use full decode *)
347
-
| None -> Jsont.Repr.type_error (meta_of_span d ev.span) t ~fnd:Jsont.Sort.Array
362
+
| Array array_map -> decode_array d ~nest ev array_map
364
+
(* For wrapped types like Map (Array ...), use full decode *)
367
+
Jsont.Repr.type_error (meta_of_span d ev.span) t ~fnd:Jsont.Sort.Array
349
-
and 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 *)
369
+
and decode_object : type o.
370
+
decoder -> nest:int -> Event.spanned -> (o, o) object_map -> o =
371
+
fun d ~nest start_ev map ->
373
+
(* consume Mapping_start *)
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
377
+
decode_object_members d ~nest meta map String_map.empty Dict.empty
let dict = Dict.add object_meta_arg meta dict in
and 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 ->
386
+
(o, o) object_map ->
387
+
mem_dec String_map.t ->
390
+
fun d ~nest obj_meta map mem_miss dict ->
(* Merge expected member decoders *)
let u _ _ _ = assert false in
let mem_miss = String_map.union u mem_miss map.mem_decs in
···
decode_object_cases d ~nest obj_meta map umems cases mem_miss [] dict
and 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
406
+
(o, o) object_map ->
407
+
(o, mems, builder) unknown_mems ->
408
+
mem_dec String_map.t ->
411
+
fun d ~nest obj_meta map umems mem_miss dict ->
415
+
| Unknown_skip | Unknown_error -> Obj.magic ()
416
+
| Unknown_keep (mmap, _) -> mmap.dec_empty ())
let mem_miss = ref mem_miss in
···
let name, name_meta = decode_mapping_key d ev in
(* Look up member decoder *)
(match String_map.find_opt name map.mem_decs with
394
-
| Some (Mem_dec mem) ->
395
-
mem_miss := String_map.remove name !mem_miss;
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)
402
-
(* Unknown member *)
405
-
let _ : unit = decode d ~nest:(nest + 1) (Jsont.Repr.of_t Jsont.ignore) in
408
-
Jsont.Repr.unexpected_mems_error obj_meta map ~fnd:[(name, name_meta)]
409
-
| Unknown_keep (mmap, _) ->
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));
431
+
| Some (Mem_dec mem) -> (
432
+
mem_miss := String_map.remove name !mem_miss;
434
+
let v = decode d ~nest:(nest + 1) mem.type' in
435
+
dict := Dict.add mem.id v !dict
436
+
with Jsont.Error e ->
437
+
Jsont.Repr.error_push_object obj_meta map (name, name_meta) e)
439
+
(* Unknown member *)
443
+
decode d ~nest:(nest + 1) (Jsont.Repr.of_t Jsont.ignore)
447
+
Jsont.Repr.unexpected_mems_error obj_meta map
448
+
~fnd:[ (name, name_meta) ]
449
+
| Unknown_keep (mmap, _) -> (
451
+
let v = decode d ~nest:(nest + 1) mmap.mems_type in
452
+
ubuilder := mmap.dec_add name_meta name v !ubuilder
453
+
with Jsont.Error e ->
454
+
Jsont.Repr.error_push_object obj_meta map (name, name_meta) e)
417
-
Jsont.Error.msgf obj_meta "Unclosed mapping"
457
+
| None -> Jsont.Error.msgf obj_meta "Unclosed mapping"
and 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 ->
463
+
(o, o) object_map ->
464
+
(o, mems, builder) unknown_mems ->
466
+
mem_dec String_map.t ->
469
+
fun meta map umems ubuilder mem_miss dict ->
let dict = Dict.add object_meta_arg meta dict in
426
-
let dict = match umems with
| Unknown_skip | Unknown_error -> dict
428
-
| Unknown_keep (mmap, _) -> Dict.add mmap.id (mmap.dec_finish meta ubuilder) dict
474
+
| Unknown_keep (mmap, _) ->
475
+
Dict.add mmap.id (mmap.dec_finish meta ubuilder) dict
(* Check for missing required members *)
let add_default _ (Mem_dec mem_map) dict =
···
Jsont.Repr.missing_mems_error meta map ~exp ~fnd:[]
and 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 ->
493
+
(o, o) object_map ->
494
+
unknown_mems_option ->
495
+
(o, cases, tag) object_cases ->
496
+
mem_dec String_map.t ->
497
+
(Jsont.name * Jsont.json) list ->
500
+
fun d ~nest obj_meta map umems cases mem_miss delayed dict ->
449
-
| Some { Event.event = Event.Mapping_end; _ } ->
502
+
| Some { Event.event = Event.Mapping_end; _ } -> (
(* No tag found - use dec_absent if available *)
452
-
(match cases.tag.dec_absent with
454
-
decode_with_case_tag d ~nest obj_meta map umems cases tag mem_miss delayed dict
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)
505
+
match cases.tag.dec_absent with
507
+
decode_with_case_tag d ~nest obj_meta map umems cases tag mem_miss
510
+
(* Missing required case tag *)
511
+
let exp = String_map.singleton cases.tag.name (Mem_dec cases.tag) in
512
+
let fnd = List.map (fun ((n, _), _) -> n) delayed in
513
+
Jsont.Repr.missing_mems_error obj_meta map ~exp ~fnd)
let name, name_meta = decode_mapping_key d ev in
if String.equal name cases.tag.name then begin
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
519
+
decode_with_case_tag d ~nest obj_meta map umems cases tag mem_miss
(* Not the case tag - check if known member or delay *)
match String_map.find_opt name map.mem_decs with
469
-
| Some (Mem_dec mem) ->
525
+
| Some (Mem_dec mem) -> (
let mem_miss = String_map.remove name mem_miss in
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)
528
+
let v = decode d ~nest:(nest + 1) mem.type' in
529
+
let dict = Dict.add mem.id v dict in
530
+
decode_object_cases d ~nest obj_meta map umems cases mem_miss
532
+
with Jsont.Error e ->
533
+
Jsont.Repr.error_push_object obj_meta map (name, name_meta) e)
(* Unknown member - decode as generic JSON and delay *)
let v = decode d ~nest:(nest + 1) (Jsont.Repr.of_t Jsont.json) in
let delayed = ((name, name_meta), v) :: delayed in
481
-
decode_object_cases d ~nest obj_meta map umems cases mem_miss delayed dict
538
+
decode_object_cases d ~nest obj_meta map umems cases mem_miss
484
-
Jsont.Error.msgf obj_meta "Unclosed mapping"
541
+
| None -> Jsont.Error.msgf obj_meta "Unclosed mapping"
and 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 ->
547
+
(o, o) object_map ->
548
+
unknown_mems_option ->
549
+
(o, cases, tag) object_cases ->
551
+
mem_dec String_map.t ->
552
+
(Jsont.name * Jsont.json) list ->
555
+
fun d ~nest obj_meta map umems cases tag mem_miss delayed dict ->
let eq_tag (Case c) = cases.tag_compare c.tag tag = 0 in
match List.find_opt eq_tag cases.cases with
495
-
Jsont.Repr.unexpected_case_tag_error obj_meta map cases tag
558
+
| None -> Jsont.Repr.unexpected_case_tag_error obj_meta map cases tag
(* 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
562
+
decode_case_remaining d ~nest obj_meta case.object_map umems mem_miss
let case_value = apply_dict case.object_map.dec case_dict in
Dict.add cases.id (case.dec case_value) dict
and 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 ->
572
+
(o, o) object_map ->
573
+
unknown_mems_option ->
574
+
mem_dec String_map.t ->
575
+
(Jsont.name * Jsont.json) list ->
578
+
fun d ~nest obj_meta case_map _umems mem_miss delayed dict ->
(* First, process delayed members against the case map *)
let u _ _ _ = assert false in
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
517
-
let dict = Dict.add mem.id v dict in
518
-
let mem_miss = String_map.remove name mem_miss in
521
-
Jsont.Repr.error_push_object obj_meta case_map (name, meta) e)
523
-
(* Unknown for case too - skip them *)
525
-
) (dict, mem_miss) delayed in
582
+
let dict, mem_miss =
584
+
(fun (dict, mem_miss) ((name, meta), json) ->
585
+
match String_map.find_opt name case_map.mem_decs with
586
+
| Some (Mem_dec mem) -> (
587
+
let t' = Jsont.Repr.unsafe_to_t mem.type' in
588
+
match Jsont.Json.decode' t' json with
590
+
let dict = Dict.add mem.id v dict in
591
+
let mem_miss = String_map.remove name mem_miss in
594
+
Jsont.Repr.error_push_object obj_meta case_map (name, meta) e)
596
+
(* Unknown for case too - skip them *)
598
+
(dict, mem_miss) delayed
(* Then continue reading remaining members using case's own unknown handling *)
match case_map.shape with
| Object_basic case_umems ->
···
(* Nested cases shouldn't happen - use skip for safety *)
decode_object_basic d ~nest obj_meta case_map Unknown_skip mem_miss dict
534
-
and decode_any_mapping : type a. decoder -> nest:int -> Event.spanned -> a t -> a any_map -> a =
535
-
fun d ~nest ev t map ->
608
+
and decode_any_mapping : type a.
609
+
decoder -> nest:int -> Event.spanned -> a t -> a any_map -> a =
610
+
fun d ~nest ev t map ->
match map.dec_object with
| Some t' -> decode d ~nest t'
538
-
| None -> Jsont.Repr.type_error (meta_of_span d ev.span) t ~fnd:Jsont.Sort.Object
614
+
Jsont.Repr.type_error (meta_of_span d ev.span) t ~fnd:Jsont.Sort.Object
and decode_mapping_key : decoder -> Event.spanned -> string * Jsont.Meta.t =
match ev.Event.event with
| Event.Scalar { value; _ } ->
···
556
-
| Some { Event.event = Event.Stream_start _; _ } -> skip_event d; loop ()
557
-
| Some { Event.event = Event.Document_start _; _ } -> skip_event d; loop ()
632
+
| Some { Event.event = Event.Stream_start _; _ } ->
635
+
| Some { Event.event = Event.Document_start _; _ } ->
···
let skip_end_wrappers d =
565
-
| Some { Event.event = Event.Document_end _; _ } -> skip_event d; loop ()
566
-
| Some { Event.event = Event.Stream_end; _ } -> skip_event d; loop ()
645
+
| Some { Event.event = Event.Document_end _; _ } ->
648
+
| Some { Event.event = Event.Stream_end; _ } ->
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
654
+
Jsont.Error.msgf meta "Expected end of document but found %a" Event.pp
···
scalar_style : Scalar_style.t;
612
-
?(format = Block) ?(indent = 2) ?(explicit_doc = false)
696
+
let make_encoder ?(format = Block) ?(indent = 2) ?(explicit_doc = false)
?(scalar_style = `Any) emitter =
{ emitter; format; _indent = indent; explicit_doc; scalar_style }
···
let encode_null e _meta =
630
-
Emitter.emit e.emitter (Event.Scalar {
634
-
plain_implicit = true;
635
-
quoted_implicit = true;
714
+
Emitter.emit e.emitter
720
+
plain_implicit = true;
721
+
quoted_implicit = true;
let encode_bool e _meta b =
641
-
Emitter.emit e.emitter (Event.Scalar {
644
-
value = if b then "true" else "false";
645
-
plain_implicit = true;
646
-
quoted_implicit = true;
727
+
Emitter.emit e.emitter
732
+
value = (if b then "true" else "false");
733
+
plain_implicit = true;
734
+
quoted_implicit = true;
let encode_number e _meta f =
···
| FP_infinite -> if f > 0.0 then ".inf" else "-.inf"
657
-
if Float.is_integer f && Float.abs f < 1e15 then
658
-
Printf.sprintf "%.0f" f
660
-
Printf.sprintf "%g" f
745
+
if Float.is_integer f && Float.abs f < 1e15 then Printf.sprintf "%.0f" f
746
+
else Printf.sprintf "%g" f
662
-
Emitter.emit e.emitter (Event.Scalar {
666
-
plain_implicit = true;
667
-
quoted_implicit = true;
748
+
Emitter.emit e.emitter
754
+
plain_implicit = true;
755
+
quoted_implicit = true;
let encode_string e _meta s =
let style = choose_scalar_style ~preferred:e.scalar_style s in
674
-
Emitter.emit e.emitter (Event.Scalar {
678
-
plain_implicit = true;
679
-
quoted_implicit = true;
762
+
Emitter.emit e.emitter
768
+
plain_implicit = true;
769
+
quoted_implicit = true;
let rec encode : type a. encoder -> a t -> a -> unit =
let meta = map.enc_meta v in
let meta = map.enc_meta v in
let meta = map.enc_meta v in
let meta = map.enc_meta v in
707
-
encode_array e map v
710
-
encode_object e map v
792
+
| Array map -> encode_array e map v
793
+
| Object map -> encode_object e map v
717
-
encode e m.dom (m.enc v)
720
-
encode e (Lazy.force lazy_t) v
797
+
| Map m -> encode e m.dom (m.enc v)
798
+
| Rec lazy_t -> encode e (Lazy.force lazy_t) v
and encode_array : type a elt b. encoder -> (a, elt, b) array_map -> a -> unit =
let style = layout_style_of_format e.format in
725
-
Emitter.emit e.emitter (Event.Sequence_start {
731
-
let _ = map.enc (fun () _idx elt ->
732
-
encode e map.elt elt;
803
+
Emitter.emit e.emitter
804
+
(Event.Sequence_start { anchor = None; tag = None; implicit = true; style });
807
+
(fun () _idx elt ->
808
+
encode e map.elt elt;
Emitter.emit e.emitter Event.Sequence_end
and encode_object : type o. encoder -> (o, o) object_map -> o -> unit =
let style = layout_style_of_format e.format in
740
-
Emitter.emit e.emitter (Event.Mapping_start {
817
+
Emitter.emit e.emitter
818
+
(Event.Mapping_start { anchor = None; tag = None; implicit = true; style });
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
751
-
Emitter.emit e.emitter (Event.Scalar {
755
-
plain_implicit = true;
756
-
quoted_implicit = true;
760
-
encode e mem.type' mem_v
821
+
(fun (Mem_enc mem) ->
822
+
let mem_v = mem.enc v in
823
+
if not (mem.enc_omit mem_v) then begin
825
+
Emitter.emit e.emitter
831
+
plain_implicit = true;
832
+
quoted_implicit = true;
836
+
encode e mem.type' mem_v
(* Handle case objects *)
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 {
773
-
value = cases.tag.name;
774
-
plain_implicit = true;
775
-
quoted_implicit = true;
778
-
encode e cases.tag.type' case_map.tag
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 {
788
-
plain_implicit = true;
789
-
quoted_implicit = true;
792
-
encode e mem.type' mem_v
794
-
) case_map.object_map.mem_encs);
841
+
| Object_basic _ -> ()
842
+
| Object_cases (_, cases) ->
843
+
let (Case_value (case_map, case_v)) = cases.enc_case (cases.enc v) in
844
+
(* Emit case tag *)
845
+
if not (cases.tag.enc_omit case_map.tag) then begin
846
+
Emitter.emit e.emitter
851
+
value = cases.tag.name;
852
+
plain_implicit = true;
853
+
quoted_implicit = true;
856
+
encode e cases.tag.type' case_map.tag
858
+
(* Emit case members *)
860
+
(fun (Mem_enc mem) ->
861
+
let mem_v = mem.enc case_v in
862
+
if not (mem.enc_omit mem_v) then begin
863
+
Emitter.emit e.emitter
869
+
plain_implicit = true;
870
+
quoted_implicit = true;
873
+
encode e mem.type' mem_v
875
+
case_map.object_map.mem_encs);
Emitter.emit e.emitter Event.Mapping_end
let encode' ?buf:_ ?format ?indent ?explicit_doc ?scalar_style t v ~eod writer =
801
-
Emitter.default_config with
802
-
indent = Option.value ~default:2 indent;
803
-
layout_style = (match format with
804
-
| Some Flow -> `Flow
883
+
Emitter.default_config with
884
+
indent = Option.value ~default:2 indent;
885
+
layout_style = (match format with Some Flow -> `Flow | _ -> `Block);
let emitter = Emitter.of_writer ~config writer in
let e = make_encoder ?format ?indent ?explicit_doc ?scalar_style emitter in
Emitter.emit e.emitter (Event.Stream_start { encoding = `Utf8 });
811
-
Emitter.emit e.emitter (Event.Document_start {
813
-
implicit = not e.explicit_doc;
892
+
Emitter.emit e.emitter
893
+
(Event.Document_start { version = None; implicit = not e.explicit_doc });
let t' = Jsont.Repr.of_t t in
817
-
Emitter.emit e.emitter (Event.Document_end { implicit = not e.explicit_doc });
896
+
Emitter.emit e.emitter
897
+
(Event.Document_end { implicit = not e.explicit_doc });
Emitter.emit e.emitter Event.Stream_end;
if eod then Emitter.flush e.emitter;
···
let encode_string' ?buf ?format ?indent ?explicit_doc ?scalar_style t v =
let b = Buffer.create 256 in
let writer = Bytes.Writer.of_buffer b in
834
-
match encode' ?buf ?format ?indent ?explicit_doc ?scalar_style t v ~eod:true writer with
915
+
encode' ?buf ?format ?indent ?explicit_doc ?scalar_style t v ~eod:true
| Ok () -> Ok (Buffer.contents b)
···
844
-
let 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
927
+
let recode ?layout ?locs ?file ?max_depth ?max_nodes ?buf ?format ?indent
928
+
?explicit_doc ?scalar_style t reader writer ~eod =
930
+
match (layout, format) with Some true, None -> Some Layout | _, f -> f
850
-
let layout = match layout, format with
851
-
| None, Some Layout -> Some true
933
+
match (layout, format) with None, Some Layout -> Some true | l, _ -> l
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
937
+
encode ?buf ?format ?indent ?explicit_doc ?scalar_style t v ~eod writer
| Error e -> Error (Jsont.Error.to_string e)
858
-
let 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
940
+
let recode_string ?layout ?locs ?file ?max_depth ?max_nodes ?buf ?format ?indent
941
+
?explicit_doc ?scalar_style t s =
943
+
match (layout, format) with Some true, None -> Some Layout | _, f -> f
864
-
let layout = match layout, format with
865
-
| None, Some Layout -> Some true
946
+
match (layout, format) with None, Some Layout -> Some true | l, _ -> l
match decode_string' ?layout ?locs ?file ?max_depth ?max_nodes t s with
| Ok v -> encode_string ?buf ?format ?indent ?explicit_doc ?scalar_style t v
anil.recoil.org