···
+
(* Local helper to reduce Jsont.Error.msgf boilerplate *)
+
let err_msg meta fmt = Jsont.Error.msgf meta fmt
+
let err_msg_none fmt = Jsont.Error.msgf Jsont.Meta.none fmt
let check_depth d ~nest =
if nest > d.max_depth then
+
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
+
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
+
err_msg meta "Expected %s but found %a" name Event.pp ev.Event.event
+
| 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
+
err_msg meta "Expected scalar but found %a" Event.pp ev.Event.event
let err_type_mismatch d span t ~fnd =
let meta = meta_of_span d span in
+
err_msg meta "Expected %s but found %s" (kinded_sort t) fnd
(* YAML scalar resolution *)
···
+
| 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, _ ->
+
err_msg (meta_of_span d ev.span) "Unexpected sequence end"
| Event.Mapping_end, _ ->
+
err_msg (meta_of_span d ev.span) "Unexpected mapping end"
| Event.Document_start _, _ ->
+
err_msg (meta_of_span d ev.span) "Unexpected document start"
| Event.Document_end _, _ ->
+
err_msg (meta_of_span d ev.span) "Unexpected document end"
| Event.Stream_start _, _ ->
+
err_msg (meta_of_span d ev.span) "Unexpected stream start"
+
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 ->
+
let meta = meta_of_span d ev.span in
+
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'
+
| 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'
+
| 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'
+
| 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'
+
| 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'
+
| 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
+
err_msg 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_value with
+
| Error e -> raise (Jsont.Error e)
and decode_array : type a elt b.
decoder -> nest:int -> Event.spanned -> (a, elt, b) array_map -> a =
+
fun d ~nest start_ev array_map ->
(* consume Sequence_start *)
let meta = meta_of_span d start_ev.span in
+
let builder = ref (array_map.dec_empty ()) in
| Some { Event.event = Event.Sequence_end; span } ->
let end_meta = meta_of_span d span in
+
array_map.dec_finish end_meta !idx !builder
+
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)
···
+
let elt = decode d ~nest:(nest + 1) array_map.elt in
+
builder := array_map.dec_add i elt !builder
+
Jsont.Repr.error_push_array meta array_map (i, Jsont.Meta.none) e);
+
| None -> err_msg meta "Unclosed sequence"
···
+
fun d ~nest obj_meta object_map umems mem_miss dict ->
···
| Some { Event.event = Event.Mapping_end; _ } ->
+
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 *)
+
(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
+
Jsont.Repr.error_push_object obj_meta object_map (name, name_meta)
···
+
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
+
Jsont.Repr.error_push_object obj_meta object_map
+
(name, name_meta) e)));
+
| None -> err_msg obj_meta "Unclosed mapping"
···
fun meta map umems ubuilder mem_miss dict ->
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
+
missing_mems_error meta map ~exp ~fnd:[]
and decode_object_cases : type o cases tag.
···
(Jsont.name * Jsont.json) list ->
+
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
+
decode_with_case_tag d ~nest obj_meta object_map umems cases tag
(* 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
+
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
+
decode_with_case_tag d ~nest obj_meta object_map umems cases tag
(* Not the case tag - check if known member or delay *)
+
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
+
decode_object_cases d ~nest obj_meta object_map umems cases
+
Jsont.Repr.error_push_object obj_meta object_map (name, name_meta)
(* Unknown member - decode as generic JSON and delay *)
+
decode d ~nest:(nest + 1) (Jsont.Repr.of_t Jsont.json)
let delayed = ((name, name_meta), v) :: delayed in
+
decode_object_cases d ~nest obj_meta object_map umems cases
+
| 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 ->
let eq_tag (Case c) = cases.tag_compare c.tag tag = 0 in
match List.find_opt eq_tag cases.cases with
+
| 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
+
(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
+
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
+
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
+
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
+
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
+
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
+
(* Helper to create scalar events with common defaults *)
+
let scalar_event ?(anchor = None) ?(tag = None) ~value ~style () =
+
quoted_implicit = true;
+
(* Helper to emit events *)
+
let emit e = Emitter.emit e.emitter
+
let encode_null e _meta = emit e (scalar_event ~value:"null" ~style:`Plain ())
let encode_bool e _meta b =
+
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
+
emit e (scalar_event ~value ~style:`Plain ())
let encode_string e _meta s =
let style = choose_scalar_style ~preferred:e.scalar_style s in
+
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
(Event.Sequence_start { anchor = None; tag = None; implicit = true; style });
···
+
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
+
emit e (Event.Mapping_start { anchor = None; tag = None; implicit = true; style });
if not (mem.enc_omit mem_v) then begin
+
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
+
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
+
emit e (scalar_event ~value:mem.name ~style:`Plain ());
case_map.object_map.mem_encs);
+
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
+
emit e (Event.Stream_start { encoding = `Utf8 });
+
emit e (Event.Document_start { version = None; implicit = not e.explicit_doc });
let t' = Jsont.Repr.of_t t in
+
emit e (Event.Document_end { implicit = not e.explicit_doc });
+
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
+
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