···
46
+
(* Local helper to reduce Jsont.Error.msgf boilerplate *)
47
+
let err_msg meta fmt = Jsont.Error.msgf meta fmt
48
+
let err_msg_none fmt = Jsont.Error.msgf Jsont.Meta.none fmt
let check_depth d ~nest =
if nest > d.max_depth then
48
-
Jsont.Error.msgf Jsont.Meta.none "Maximum nesting depth %d exceeded"
52
+
err_msg_none "Maximum nesting depth %d exceeded" d.max_depth
d.node_count <- d.node_count + 1;
if d.node_count > d.max_nodes then
54
-
Jsont.Error.msgf Jsont.Meta.none "Maximum node count %d exceeded"
57
+
err_msg_none "Maximum node count %d exceeded" d.max_nodes
let meta_of_span d span =
if not d.locs then d.meta_none
···
let span = ev.Event.span in
let meta = meta_of_span d span in
118
-
Jsont.Error.msgf meta "Expected %s but found %a" name Event.pp
121
-
Jsont.Error.msgf Jsont.Meta.none "Expected %s but reached end of stream"
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
let _err_expected_scalar d ev =
let meta = meta_of_span d ev.Event.span in
128
-
Jsont.Error.msgf meta "Expected scalar but found %a" Event.pp ev.Event.event
127
+
err_msg meta "Expected scalar but found %a" Event.pp ev.Event.event
let err_type_mismatch d span t ~fnd =
130
+
let open Jsont.Repr in
let meta = meta_of_span d span in
132
-
Jsont.Error.msgf meta "Expected %s but found %s" (Jsont.Repr.kinded_sort t)
132
+
err_msg meta "Expected %s but found %s" (kinded_sort t) fnd
(* YAML scalar resolution *)
···
218
-
| None -> Jsont.Error.msgf Jsont.Meta.none "Unexpected end of YAML stream"
217
+
| None -> err_msg_none "Unexpected end of YAML stream"
match (ev.Event.event, t) with
···
| Event.Mapping_start _, _ -> err_type_mismatch d ev.span t ~fnd:"mapping"
| Event.Sequence_end, _ ->
251
-
Jsont.Error.msgf (meta_of_span d ev.span) "Unexpected sequence end"
250
+
err_msg (meta_of_span d ev.span) "Unexpected sequence end"
| Event.Mapping_end, _ ->
253
-
Jsont.Error.msgf (meta_of_span d ev.span) "Unexpected mapping end"
252
+
err_msg (meta_of_span d ev.span) "Unexpected mapping end"
| Event.Document_start _, _ ->
255
-
Jsont.Error.msgf (meta_of_span d ev.span) "Unexpected document start"
254
+
err_msg (meta_of_span d ev.span) "Unexpected document start"
| Event.Document_end _, _ ->
257
-
Jsont.Error.msgf (meta_of_span d ev.span) "Unexpected document end"
256
+
err_msg (meta_of_span d ev.span) "Unexpected document end"
| Event.Stream_start _, _ ->
259
-
Jsont.Error.msgf (meta_of_span d ev.span) "Unexpected stream start"
258
+
err_msg (meta_of_span d ev.span) "Unexpected stream start"
261
-
Jsont.Error.msgf (meta_of_span d ev.span) "Unexpected stream end")
260
+
err_msg (meta_of_span d ev.span) "Unexpected stream end")
and decode_scalar : type a.
decoder -> nest:int -> Event.spanned -> string -> Scalar_style.t -> a t -> a
···
fun d ev value style t map ->
282
+
let meta = meta_of_span d ev.span in
283
+
let type_err fnd = Jsont.Repr.type_error meta t ~fnd in
(* 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'
288
-
Jsont.Repr.type_error (meta_of_span d ev.span) t ~fnd:Jsont.Sort.Null
288
+
| None -> type_err Jsont.Sort.Null
else if style = `Plain then
(* Try bool, then number, then string *)
match bool_of_scalar_opt value with
···
match map.dec_string with
| Some t' -> decode_scalar_as d ev value style t'
299
-
Jsont.Repr.type_error (meta_of_span d ev.span) t
300
-
~fnd:Jsont.Sort.Bool))
298
+
| None -> type_err Jsont.Sort.Bool))
match float_of_scalar_opt value with
···
match map.dec_string with
| Some t' -> decode_scalar_as d ev value style t'
310
-
Jsont.Repr.type_error (meta_of_span d ev.span) t
311
-
~fnd:Jsont.Sort.Number))
307
+
| None -> type_err 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'
317
-
Jsont.Repr.type_error (meta_of_span d ev.span) t
318
-
~fnd:Jsont.Sort.String))
312
+
| None -> type_err Jsont.Sort.String))
(* Quoted scalars are strings *)
match map.dec_string with
| Some t' -> decode_scalar_as d ev value style t'
324
-
Jsont.Repr.type_error (meta_of_span d ev.span) t ~fnd:Jsont.Sort.String
317
+
| None -> type_err Jsont.Sort.String
and decode_alias : type a. decoder -> Event.spanned -> string -> a t -> a =
···
match Hashtbl.find_opt d._anchors anchor with
let meta = meta_of_span d ev.span in
332
-
Jsont.Error.msgf meta "Unknown anchor: %s" anchor
325
+
err_msg meta "Unknown anchor: %s" anchor
326
+
| Some json_value ->
(* Decode the stored JSON value through the type *)
let t' = Jsont.Repr.unsafe_to_t t in
336
-
match Jsont.Json.decode' t' json with
329
+
match Jsont.Json.decode' t' json_value with
338
-
| Error e -> raise (Jsont.Error e))
331
+
| Error e -> raise (Jsont.Error e)
and decode_array : type a elt b.
decoder -> nest:int -> Event.spanned -> (a, elt, b) array_map -> a =
342
-
fun d ~nest start_ev map ->
335
+
fun d ~nest start_ev array_map ->
(* consume Sequence_start *)
let meta = meta_of_span d start_ev.span in
347
-
let builder = ref (map.dec_empty ()) in
340
+
let builder = ref (array_map.dec_empty ()) in
| Some { Event.event = Event.Sequence_end; span } ->
let end_meta = meta_of_span d span in
354
-
map.dec_finish end_meta !idx !builder
347
+
array_map.dec_finish end_meta !idx !builder
358
-
if map.dec_skip i !builder then begin
351
+
if array_map.dec_skip i !builder then begin
(* Skip this element by decoding as ignore *)
decode d ~nest:(nest + 1) (Jsont.Repr.of_t Jsont.ignore)
···
366
-
let elt = decode d ~nest:(nest + 1) map.elt in
367
-
builder := map.dec_add i elt !builder
359
+
let elt = decode d ~nest:(nest + 1) array_map.elt in
360
+
builder := array_map.dec_add i elt !builder
370
-
let imeta = Jsont.Meta.none in
371
-
Jsont.Repr.error_push_array meta map (i, imeta) e);
363
+
Jsont.Repr.error_push_array meta array_map (i, Jsont.Meta.none) e);
374
-
| None -> Jsont.Error.msgf meta "Unclosed sequence"
366
+
| None -> err_msg meta "Unclosed sequence"
···
435
-
fun d ~nest obj_meta map umems mem_miss dict ->
427
+
fun d ~nest obj_meta object_map umems mem_miss dict ->
···
| Some { Event.event = Event.Mapping_end; _ } ->
449
-
finish_object obj_meta map umems !ubuilder !mem_miss !dict
441
+
finish_object obj_meta object_map umems !ubuilder !mem_miss !dict
(* Expect a scalar key *)
let name, name_meta = decode_mapping_key d ev in
(* Look up member decoder *)
454
-
(match String_map.find_opt name map.mem_decs with
446
+
(match String_map.find_opt name object_map.mem_decs with
| Some (Mem_dec mem) -> (
mem_miss := String_map.remove name !mem_miss;
let v = decode d ~nest:(nest + 1) mem.type' in
dict := Dict.add mem.id v !dict
461
-
Jsont.Repr.error_push_object obj_meta map (name, name_meta) e)
453
+
Jsont.Repr.error_push_object obj_meta object_map (name, name_meta)
···
471
-
Jsont.Repr.unexpected_mems_error obj_meta map
464
+
Jsont.Repr.unexpected_mems_error obj_meta object_map
~fnd:[ (name, name_meta) ]
| Unknown_keep (mmap, _) -> (
let v = decode d ~nest:(nest + 1) mmap.mems_type in
ubuilder := mmap.dec_add name_meta name v !ubuilder
478
-
Jsont.Repr.error_push_object obj_meta map (name, name_meta) e)
471
+
Jsont.Repr.error_push_object obj_meta object_map
472
+
(name, name_meta) e)));
481
-
| None -> Jsont.Error.msgf obj_meta "Unclosed mapping"
474
+
| None -> err_msg obj_meta "Unclosed mapping"
···
fun meta map umems ubuilder mem_miss dict ->
487
+
let open Jsont.Repr in
let dict = Dict.add object_meta_arg meta dict in
···
let no_default _ (Mem_dec mm) = Option.is_none mm.dec_absent in
let exp = String_map.filter no_default mem_miss in
511
-
Jsont.Repr.missing_mems_error meta map ~exp ~fnd:[]
505
+
missing_mems_error meta map ~exp ~fnd:[]
and decode_object_cases : type o cases tag.
···
(Jsont.name * Jsont.json) list ->
524
-
fun d ~nest obj_meta map umems cases mem_miss delayed dict ->
518
+
fun d ~nest obj_meta object_map umems cases mem_miss delayed dict ->
| Some { Event.event = Event.Mapping_end; _ } -> (
(* No tag found - use dec_absent if available *)
match cases.tag.dec_absent with
531
-
decode_with_case_tag d ~nest obj_meta map umems cases tag mem_miss
525
+
decode_with_case_tag d ~nest obj_meta object_map umems cases tag
526
+
mem_miss delayed dict
(* Missing required case tag *)
let exp = String_map.singleton cases.tag.name (Mem_dec cases.tag) in
let fnd = List.map (fun ((n, _), _) -> n) delayed in
537
-
Jsont.Repr.missing_mems_error obj_meta map ~exp ~fnd)
531
+
Jsont.Repr.missing_mems_error obj_meta object_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
543
-
decode_with_case_tag d ~nest obj_meta map umems cases tag mem_miss
537
+
decode_with_case_tag d ~nest obj_meta object_map umems cases tag
538
+
mem_miss delayed dict
(* Not the case tag - check if known member or delay *)
548
-
match String_map.find_opt name map.mem_decs with
542
+
match String_map.find_opt name object_map.mem_decs with
| Some (Mem_dec mem) -> (
let mem_miss = String_map.remove name mem_miss in
let v = decode d ~nest:(nest + 1) mem.type' in
let dict = Dict.add mem.id v dict in
554
-
decode_object_cases d ~nest obj_meta map umems cases mem_miss
548
+
decode_object_cases d ~nest obj_meta object_map umems cases
549
+
mem_miss delayed dict
557
-
Jsont.Repr.error_push_object obj_meta map (name, name_meta) e)
551
+
Jsont.Repr.error_push_object obj_meta object_map (name, name_meta)
(* Unknown member - decode as generic JSON and delay *)
560
-
let v = decode d ~nest:(nest + 1) (Jsont.Repr.of_t Jsont.json) in
556
+
decode d ~nest:(nest + 1) (Jsont.Repr.of_t Jsont.json)
let delayed = ((name, name_meta), v) :: delayed in
562
-
decode_object_cases d ~nest obj_meta map umems cases mem_miss
559
+
decode_object_cases d ~nest obj_meta object_map umems cases
560
+
mem_miss delayed dict
565
-
| None -> Jsont.Error.msgf obj_meta "Unclosed mapping"
562
+
| None -> err_msg obj_meta "Unclosed mapping"
and decode_with_case_tag : type o cases tag.
···
fun d ~nest obj_meta map umems cases tag mem_miss delayed dict ->
577
+
let open Jsont.Repr in
let eq_tag (Case c) = cases.tag_compare c.tag tag = 0 in
match List.find_opt eq_tag cases.cases with
582
-
| None -> Jsont.Repr.unexpected_case_tag_error obj_meta map cases tag
580
+
| None -> unexpected_case_tag_error obj_meta map cases tag
(* Continue decoding with the case's object map *)
···
let mem_miss = String_map.union u mem_miss case_map.mem_decs in
608
-
(fun (dict, mem_miss) ((name, meta), json) ->
606
+
(fun (dict, mem_miss) ((name, meta), json_value) ->
match String_map.find_opt name case_map.mem_decs with
| Some (Mem_dec mem) -> (
let t' = Jsont.Repr.unsafe_to_t mem.type' in
612
-
match Jsont.Json.decode' t' json with
610
+
match Jsont.Json.decode' t' json_value with
let dict = Dict.add mem.id v dict in
let mem_miss = String_map.remove name mem_miss in
···
let meta = meta_of_span d ev.span in
649
-
Jsont.Error.msgf meta "Mapping keys must be scalars (strings), found %a"
647
+
err_msg meta "Mapping keys must be scalars (strings), found %a" Event.pp
(* Skip stream/document wrappers *)
···
let meta = meta_of_span d ev.span in
678
-
Jsont.Error.msgf meta "Expected end of document but found %a" Event.pp
676
+
err_msg meta "Expected end of document but found %a" Event.pp ev.event
···
| Error.Yamlrw_error err ->
let msg = Error.to_string err in
734
-
Jsont.Error.make_msg Jsont.Error.Context.empty Jsont.Meta.none msg
730
+
let e = Jsont.(Error.make_msg Error.Context.empty Meta.none msg) in
Seq.Cons (Error e, next_doc))
···
| Jsont.Error e -> Error e
| Error.Yamlrw_error err ->
let msg = Error.to_string err in
757
-
Error (Jsont.Error.make_msg Jsont.Error.Context.empty Jsont.Meta.none msg)
752
+
Error Jsont.(Error.make_msg Error.Context.empty Meta.none msg)
let decode ?layout ?locs ?file ?max_depth ?max_nodes t reader =
Result.map_error Jsont.Error.to_string
···
else if String.contains s '\n' then `Literal
else if String.length s > 80 then `Folded
784
+
(* Helper to create scalar events with common defaults *)
785
+
let scalar_event ?(anchor = None) ?(tag = None) ~value ~style () =
791
+
plain_implicit = true;
792
+
quoted_implicit = true;
796
+
(* Helper to emit events *)
797
+
let emit e = Emitter.emit e.emitter
790
-
let encode_null e _meta =
791
-
Emitter.emit e.emitter
797
-
plain_implicit = true;
798
-
quoted_implicit = true;
800
+
let encode_null e _meta = emit e (scalar_event ~value:"null" ~style:`Plain ())
let encode_bool e _meta b =
804
-
Emitter.emit e.emitter
809
-
value = (if b then "true" else "false");
810
-
plain_implicit = true;
811
-
quoted_implicit = true;
804
+
emit e (scalar_event ~value:(if b then "true" else "false") ~style:`Plain ())
let encode_number e _meta f =
···
if Float.is_integer f && Float.abs f < 1e15 then Printf.sprintf "%.0f" f
else Printf.sprintf "%g" f
825
-
Emitter.emit e.emitter
831
-
plain_implicit = true;
832
-
quoted_implicit = true;
816
+
emit e (scalar_event ~value ~style:`Plain ())
let encode_string e _meta s =
let style = choose_scalar_style ~preferred:e.scalar_style s in
839
-
Emitter.emit e.emitter
845
-
plain_implicit = true;
846
-
quoted_implicit = true;
821
+
emit e (scalar_event ~value:s ~style ())
let rec encode : type a. encoder -> a t -> a -> unit =
···
and encode_array : type a elt b. encoder -> (a, elt, b) array_map -> a -> unit =
let style = layout_style_of_format e.format in
880
-
Emitter.emit e.emitter
(Event.Sequence_start { anchor = None; tag = None; implicit = true; style });
···
889
-
Emitter.emit e.emitter Event.Sequence_end
862
+
emit e Event.Sequence_end
and encode_object : type o. encoder -> (o, o) object_map -> o -> unit =
let style = layout_style_of_format e.format in
894
-
Emitter.emit e.emitter
895
-
(Event.Mapping_start { anchor = None; tag = None; implicit = true; style });
867
+
emit e (Event.Mapping_start { anchor = None; tag = None; implicit = true; style });
if not (mem.enc_omit mem_v) then begin
902
-
Emitter.emit e.emitter
908
-
plain_implicit = true;
909
-
quoted_implicit = true;
874
+
emit e (scalar_event ~value:mem.name ~style:`Plain ());
···
let (Case_value (case_map, case_v)) = cases.enc_case (cases.enc v) in
if not (cases.tag.enc_omit case_map.tag) then begin
923
-
Emitter.emit e.emitter
928
-
value = cases.tag.name;
929
-
plain_implicit = true;
930
-
quoted_implicit = true;
886
+
emit e (scalar_event ~value:cases.tag.name ~style:`Plain ());
encode e cases.tag.type' case_map.tag
···
let mem_v = mem.enc case_v in
if not (mem.enc_omit mem_v) then begin
940
-
Emitter.emit e.emitter
946
-
plain_implicit = true;
947
-
quoted_implicit = true;
894
+
emit e (scalar_event ~value:mem.name ~style:`Plain ());
case_map.object_map.mem_encs);
953
-
Emitter.emit e.emitter Event.Mapping_end
898
+
emit e Event.Mapping_end
···
let emitter = Emitter.of_writer ~config writer in
let e = make_encoder ?format ?indent ?explicit_doc ?scalar_style emitter in
968
-
Emitter.emit e.emitter (Event.Stream_start { encoding = `Utf8 });
969
-
Emitter.emit e.emitter
970
-
(Event.Document_start { version = None; implicit = not e.explicit_doc });
913
+
emit e (Event.Stream_start { encoding = `Utf8 });
914
+
emit e (Event.Document_start { version = None; implicit = not e.explicit_doc });
let t' = Jsont.Repr.of_t t in
973
-
Emitter.emit e.emitter
974
-
(Event.Document_end { implicit = not e.explicit_doc });
975
-
Emitter.emit e.emitter Event.Stream_end;
917
+
emit e (Event.Document_end { implicit = not e.explicit_doc });
918
+
emit e Event.Stream_end;
if eod then Emitter.flush e.emitter;
| Jsont.Error err -> Error err
| Error.Yamlrw_error err ->
let msg = Error.to_string err in
982
-
Error (Jsont.Error.make_msg Jsont.Error.Context.empty Jsont.Meta.none msg)
925
+
Error Jsont.(Error.make_msg Error.Context.empty Meta.none msg)
let encode ?buf ?format ?indent ?explicit_doc ?scalar_style t v ~eod writer =
Result.map_error Jsont.Error.to_string
anil.recoil.org