Pure OCaml Yaml 1.2 reader and writer using Bytesrw
anil.recoil.org
1(*---------------------------------------------------------------------------
2 Copyright (c) 2025 Anil Madhavapeddy <anil@recoil.org>. All rights reserved.
3 SPDX-License-Identifier: ISC
4 ---------------------------------------------------------------------------*)
5
6(** Serialize - high-level serialization to buffers and event streams
7
8 This module provides functions to convert YAML values to events and strings.
9 Both {!Emitter.t}-based and function-based emission APIs are provided. *)
10
11(** {1 Internal Helpers} *)
12
13(** Emit a YAML node using an emit function.
14 This is the core implementation used by both Emitter.t and function-based APIs. *)
15let rec emit_yaml_node_impl ~emit (yaml : Yaml.t) =
16 match yaml with
17 | `Scalar s ->
18 emit (Event.Scalar {
19 anchor = Scalar.anchor s;
20 tag = Scalar.tag s;
21 value = Scalar.value s;
22 plain_implicit = Scalar.plain_implicit s;
23 quoted_implicit = Scalar.quoted_implicit s;
24 style = Scalar.style s;
25 })
26
27 | `Alias name ->
28 emit (Event.Alias { anchor = name })
29
30 | `A seq ->
31 let members = Sequence.members seq in
32 (* Force flow style for empty sequences *)
33 let style = if members = [] then `Flow else Sequence.style seq in
34 emit (Event.Sequence_start {
35 anchor = Sequence.anchor seq;
36 tag = Sequence.tag seq;
37 implicit = Sequence.implicit seq;
38 style;
39 });
40 List.iter (emit_yaml_node_impl ~emit) members;
41 emit Event.Sequence_end
42
43 | `O map ->
44 let members = Mapping.members map in
45 (* Force flow style for empty mappings *)
46 let style = if members = [] then `Flow else Mapping.style map in
47 emit (Event.Mapping_start {
48 anchor = Mapping.anchor map;
49 tag = Mapping.tag map;
50 implicit = Mapping.implicit map;
51 style;
52 });
53 List.iter (fun (k, v) ->
54 emit_yaml_node_impl ~emit k;
55 emit_yaml_node_impl ~emit v
56 ) members;
57 emit Event.Mapping_end
58
59(** Emit a Value node using an emit function.
60 This is the core implementation used by both Emitter.t and function-based APIs. *)
61let rec emit_value_node_impl ~emit ~config (value : Value.t) =
62 match value with
63 | `Null ->
64 emit (Event.Scalar {
65 anchor = None; tag = None;
66 value = "null";
67 plain_implicit = true; quoted_implicit = false;
68 style = `Plain;
69 })
70
71 | `Bool b ->
72 emit (Event.Scalar {
73 anchor = None; tag = None;
74 value = if b then "true" else "false";
75 plain_implicit = true; quoted_implicit = false;
76 style = `Plain;
77 })
78
79 | `Float f ->
80 let value =
81 match Float.classify_float f with
82 | FP_nan -> ".nan"
83 | FP_infinite -> if f > 0.0 then ".inf" else "-.inf"
84 | _ ->
85 if Float.is_integer f && Float.abs f < 1e15 then
86 Printf.sprintf "%.0f" f
87 else
88 Printf.sprintf "%g" f
89 in
90 emit (Event.Scalar {
91 anchor = None; tag = None;
92 value;
93 plain_implicit = true; quoted_implicit = false;
94 style = `Plain;
95 })
96
97 | `String s ->
98 let style = Quoting.choose_style s in
99 emit (Event.Scalar {
100 anchor = None; tag = None;
101 value = s;
102 plain_implicit = style = `Plain;
103 quoted_implicit = style <> `Plain;
104 style;
105 })
106
107 | `A items ->
108 (* Force flow style for empty sequences, otherwise use config *)
109 let style =
110 if items = [] || config.Emitter.layout_style = `Flow then `Flow else `Block
111 in
112 emit (Event.Sequence_start {
113 anchor = None; tag = None;
114 implicit = true;
115 style;
116 });
117 List.iter (emit_value_node_impl ~emit ~config) items;
118 emit Event.Sequence_end
119
120 | `O pairs ->
121 (* Force flow style for empty mappings, otherwise use config *)
122 let style =
123 if pairs = [] || config.Emitter.layout_style = `Flow then `Flow else `Block
124 in
125 emit (Event.Mapping_start {
126 anchor = None; tag = None;
127 implicit = true;
128 style;
129 });
130 List.iter (fun (k, v) ->
131 let style = Quoting.choose_style k in
132 emit (Event.Scalar {
133 anchor = None; tag = None;
134 value = k;
135 plain_implicit = style = `Plain;
136 quoted_implicit = style <> `Plain;
137 style;
138 });
139 emit_value_node_impl ~emit ~config v
140 ) pairs;
141 emit Event.Mapping_end
142
143(** Strip anchors from a YAML tree (used when resolving aliases for output) *)
144let rec strip_anchors (yaml : Yaml.t) : Yaml.t =
145 match yaml with
146 | `Scalar s ->
147 if Option.is_none (Scalar.anchor s) then yaml
148 else
149 `Scalar (Scalar.make
150 ?tag:(Scalar.tag s)
151 ~plain_implicit:(Scalar.plain_implicit s)
152 ~quoted_implicit:(Scalar.quoted_implicit s)
153 ~style:(Scalar.style s)
154 (Scalar.value s))
155 | `Alias _ -> yaml
156 | `A seq ->
157 `A (Sequence.make
158 ?tag:(Sequence.tag seq)
159 ~implicit:(Sequence.implicit seq)
160 ~style:(Sequence.style seq)
161 (List.map strip_anchors (Sequence.members seq)))
162 | `O map ->
163 `O (Mapping.make
164 ?tag:(Mapping.tag map)
165 ~implicit:(Mapping.implicit map)
166 ~style:(Mapping.style map)
167 (List.map (fun (k, v) -> (strip_anchors k, strip_anchors v)) (Mapping.members map)))
168
169(** Emit a document using an emit function *)
170let emit_document_impl ?(resolve_aliases = true) ~emit doc =
171 emit (Event.Document_start {
172 version = Document.version doc;
173 implicit = Document.implicit_start doc;
174 });
175 (match Document.root doc with
176 | Some yaml ->
177 let yaml = if resolve_aliases then
178 yaml |> Yaml.resolve_aliases |> strip_anchors
179 else yaml in
180 emit_yaml_node_impl ~emit yaml
181 | None ->
182 emit (Event.Scalar {
183 anchor = None; tag = None;
184 value = "";
185 plain_implicit = true; quoted_implicit = false;
186 style = `Plain;
187 }));
188 emit (Event.Document_end { implicit = Document.implicit_end doc })
189
190(** {1 Emitter.t-based API} *)
191
192(** Emit a YAML node to an emitter *)
193let emit_yaml_node t yaml =
194 emit_yaml_node_impl ~emit:(Emitter.emit t) yaml
195
196(** Emit a complete YAML document to an emitter *)
197let emit_yaml t yaml =
198 let config = Emitter.config t in
199 Emitter.emit t (Event.Stream_start { encoding = config.encoding });
200 Emitter.emit t (Event.Document_start { version = None; implicit = true });
201 emit_yaml_node t yaml;
202 Emitter.emit t (Event.Document_end { implicit = true });
203 Emitter.emit t Event.Stream_end
204
205(** Emit a Value node to an emitter *)
206let emit_value_node t value =
207 let config = Emitter.config t in
208 emit_value_node_impl ~emit:(Emitter.emit t) ~config value
209
210(** Emit a complete Value document to an emitter *)
211let emit_value t value =
212 let config = Emitter.config t in
213 Emitter.emit t (Event.Stream_start { encoding = config.encoding });
214 Emitter.emit t (Event.Document_start { version = None; implicit = true });
215 emit_value_node t value;
216 Emitter.emit t (Event.Document_end { implicit = true });
217 Emitter.emit t Event.Stream_end
218
219(** Emit a document to an emitter *)
220let emit_document ?resolve_aliases t doc =
221 emit_document_impl ?resolve_aliases ~emit:(Emitter.emit t) doc
222
223(** {1 Buffer-based API} *)
224
225(** Serialize a Value to a buffer.
226
227 @param config Emitter configuration (default: {!Emitter.default_config})
228 @param buffer Optional buffer to append to; creates new one if not provided
229 @return The buffer containing serialized YAML *)
230let value_to_buffer ?(config = Emitter.default_config) ?buffer value =
231 let buf = Option.value buffer ~default:(Buffer.create 1024) in
232 let t = Emitter.create ~config () in
233 emit_value t value;
234 Buffer.add_string buf (Emitter.contents t);
235 buf
236
237(** Serialize a Yaml.t to a buffer.
238
239 @param config Emitter configuration (default: {!Emitter.default_config})
240 @param buffer Optional buffer to append to; creates new one if not provided
241 @return The buffer containing serialized YAML *)
242let yaml_to_buffer ?(config = Emitter.default_config) ?buffer yaml =
243 let buf = Option.value buffer ~default:(Buffer.create 1024) in
244 let t = Emitter.create ~config () in
245 emit_yaml t yaml;
246 Buffer.add_string buf (Emitter.contents t);
247 buf
248
249(** Serialize documents to a buffer.
250
251 @param config Emitter configuration (default: {!Emitter.default_config})
252 @param resolve_aliases Whether to resolve aliases before emission (default: true)
253 @param buffer Optional buffer to append to; creates new one if not provided
254 @return The buffer containing serialized YAML *)
255let documents_to_buffer ?(config = Emitter.default_config) ?(resolve_aliases = true) ?buffer documents =
256 let buf = Option.value buffer ~default:(Buffer.create 1024) in
257 let t = Emitter.create ~config () in
258 Emitter.emit t (Event.Stream_start { encoding = config.encoding });
259 List.iter (emit_document ~resolve_aliases t) documents;
260 Emitter.emit t Event.Stream_end;
261 Buffer.add_string buf (Emitter.contents t);
262 buf
263
264(** {1 String-based API} *)
265
266(** Serialize a Value to a string.
267
268 @param config Emitter configuration (default: {!Emitter.default_config}) *)
269let value_to_string ?(config = Emitter.default_config) value =
270 Buffer.contents (value_to_buffer ~config value)
271
272(** Serialize a Yaml.t to a string.
273
274 @param config Emitter configuration (default: {!Emitter.default_config}) *)
275let yaml_to_string ?(config = Emitter.default_config) yaml =
276 Buffer.contents (yaml_to_buffer ~config yaml)
277
278(** Serialize documents to a string.
279
280 @param config Emitter configuration (default: {!Emitter.default_config})
281 @param resolve_aliases Whether to resolve aliases before emission (default: true) *)
282let documents_to_string ?(config = Emitter.default_config) ?(resolve_aliases = true) documents =
283 Buffer.contents (documents_to_buffer ~config ~resolve_aliases documents)
284
285(** {1 Writer-based API}
286
287 These functions write directly to a bytesrw [Bytes.Writer.t],
288 enabling true streaming output without intermediate string allocation.
289 Uses the emitter's native Writer support for efficiency. *)
290
291(** Serialize a Value directly to a Bytes.Writer.
292
293 @param config Emitter configuration (default: {!Emitter.default_config})
294 @param eod Whether to write end-of-data after serialization (default: true) *)
295let value_to_writer ?(config = Emitter.default_config) ?(eod = true) writer value =
296 let t = Emitter.of_writer ~config writer in
297 emit_value t value;
298 if eod then Emitter.flush t
299
300(** Serialize a Yaml.t directly to a Bytes.Writer.
301
302 @param config Emitter configuration (default: {!Emitter.default_config})
303 @param eod Whether to write end-of-data after serialization (default: true) *)
304let yaml_to_writer ?(config = Emitter.default_config) ?(eod = true) writer yaml =
305 let t = Emitter.of_writer ~config writer in
306 emit_yaml t yaml;
307 if eod then Emitter.flush t
308
309(** Serialize documents directly to a Bytes.Writer.
310
311 @param config Emitter configuration (default: {!Emitter.default_config})
312 @param resolve_aliases Whether to resolve aliases before emission (default: true)
313 @param eod Whether to write end-of-data after serialization (default: true) *)
314let documents_to_writer ?(config = Emitter.default_config) ?(resolve_aliases = true) ?(eod = true) writer documents =
315 let t = Emitter.of_writer ~config writer in
316 Emitter.emit t (Event.Stream_start { encoding = config.encoding });
317 List.iter (emit_document ~resolve_aliases t) documents;
318 Emitter.emit t Event.Stream_end;
319 if eod then Emitter.flush t
320
321(** {1 Function-based API}
322
323 These functions accept an emit function [Event.t -> unit] instead of
324 an {!Emitter.t}, allowing them to work with any event sink
325 (e.g., streaming writers, custom processors). *)
326
327(** Emit a YAML node using an emitter function *)
328let emit_yaml_node_fn ~emitter yaml =
329 emit_yaml_node_impl ~emit:emitter yaml
330
331(** Emit a complete YAML stream using an emitter function *)
332let emit_yaml_fn ~emitter ~config yaml =
333 emitter (Event.Stream_start { encoding = config.Emitter.encoding });
334 emitter (Event.Document_start { version = None; implicit = true });
335 emit_yaml_node_fn ~emitter yaml;
336 emitter (Event.Document_end { implicit = true });
337 emitter Event.Stream_end
338
339(** Emit a Value node using an emitter function *)
340let emit_value_node_fn ~emitter ~config value =
341 emit_value_node_impl ~emit:emitter ~config value
342
343(** Emit a complete Value stream using an emitter function *)
344let emit_value_fn ~emitter ~config value =
345 emitter (Event.Stream_start { encoding = config.Emitter.encoding });
346 emitter (Event.Document_start { version = None; implicit = true });
347 emit_value_node_fn ~emitter ~config value;
348 emitter (Event.Document_end { implicit = true });
349 emitter Event.Stream_end
350
351(** Emit a document using an emitter function *)
352let emit_document_fn ?resolve_aliases ~emitter doc =
353 emit_document_impl ?resolve_aliases ~emit:emitter doc
354
355(** Emit multiple documents using an emitter function *)
356let emit_documents ~emitter ~config ?(resolve_aliases = true) documents =
357 emitter (Event.Stream_start { encoding = config.Emitter.encoding });
358 List.iter (emit_document_fn ~resolve_aliases ~emitter) documents;
359 emitter Event.Stream_end