+120 -99

bin/yamlcat.ml

··· 16 16 | `Float f -> 17 17 if Float.is_integer f && Float.abs f < 1e15 then 18 18 Buffer.add_string buf (Printf.sprintf "%.0f" f) 19 19 - else 20 20 - Buffer.add_string buf (Printf.sprintf "%g" f) 19 19 + else Buffer.add_string buf (Printf.sprintf "%g" f) 21 20 | `String s -> Buffer.add_string buf (Printf.sprintf "%S" s) 22 21 | `A items -> 23 22 Buffer.add_char buf '['; 24 24 - List.iteri (fun i item -> 25 25 - if i > 0 then Buffer.add_string buf ", "; 26 26 - json_to_string buf item 27 27 - ) items; 23 23 + List.iteri 24 24 + (fun i item -> 25 25 + if i > 0 then Buffer.add_string buf ", "; 26 26 + json_to_string buf item) 27 27 + items; 28 28 Buffer.add_char buf ']' 29 29 | `O pairs -> 30 30 Buffer.add_char buf '{'; 31 31 - List.iteri (fun i (k, v) -> 32 32 - if i > 0 then Buffer.add_string buf ", "; 33 33 - Buffer.add_string buf (Printf.sprintf "%S: " k); 34 34 - json_to_string buf v 35 35 - ) pairs; 31 31 + List.iteri 32 32 + (fun i (k, v) -> 33 33 + if i > 0 then Buffer.add_string buf ", "; 34 34 + Buffer.add_string buf (Printf.sprintf "%S: " k); 35 35 + json_to_string buf v) 36 36 + pairs; 36 37 Buffer.add_char buf '}' 37 38 38 39 let value_to_json v = ··· 49 50 | Yaml -> 50 51 (* Convert through Value to apply tag-based type coercion *) 51 52 let first = ref true in 52 52 - List.iter (fun (doc : Yamlrw.document) -> 53 53 - if not !first then print_string "---\n"; 54 54 - first := false; 55 55 - match doc.root with 56 56 - | None -> print_endline "" 57 57 - | Some yaml -> 58 58 - let value = Yamlrw.to_json ~resolve_aliases ~max_nodes ~max_depth yaml in 59 59 - print_string (Yamlrw.to_string value) 60 60 - ) documents 53 53 + List.iter 54 54 + (fun (doc : Yamlrw.document) -> 55 55 + if not !first then print_string "---\n"; 56 56 + first := false; 57 57 + match doc.root with 58 58 + | None -> print_endline "" 59 59 + | Some yaml -> 60 60 + let value = 61 61 + Yamlrw.to_json ~resolve_aliases ~max_nodes ~max_depth yaml 62 62 + in 63 63 + print_string (Yamlrw.to_string value)) 64 64 + documents 61 65 | Flow -> 62 66 (* Convert through Value to apply tag-based type coercion *) 63 67 let first = ref true in 64 64 - List.iter (fun (doc : Yamlrw.document) -> 65 65 - if not !first then print_string "---\n"; 66 66 - first := false; 67 67 - match doc.root with 68 68 - | None -> print_endline "" 69 69 - | Some yaml -> 70 70 - let value = Yamlrw.to_json ~resolve_aliases ~max_nodes ~max_depth yaml in 71 71 - print_string (Yamlrw.to_string ~layout_style:`Flow value) 72 72 - ) documents 68 68 + List.iter 69 69 + (fun (doc : Yamlrw.document) -> 70 70 + if not !first then print_string "---\n"; 71 71 + first := false; 72 72 + match doc.root with 73 73 + | None -> print_endline "" 74 74 + | Some yaml -> 75 75 + let value = 76 76 + Yamlrw.to_json ~resolve_aliases ~max_nodes ~max_depth yaml 77 77 + in 78 78 + print_string (Yamlrw.to_string ~layout_style:`Flow value)) 79 79 + documents 73 80 | Json -> 74 81 let first = ref true in 75 75 - List.iter (fun (doc : Yamlrw.document) -> 76 76 - match doc.root with 77 77 - | None -> () 78 78 - | Some yaml -> 79 79 - if not !first then print_endline "---"; 80 80 - first := false; 81 81 - let value = Yamlrw.to_json ~resolve_aliases ~max_nodes ~max_depth yaml in 82 82 - print_endline (value_to_json value) 83 83 - ) documents 82 82 + List.iter 83 83 + (fun (doc : Yamlrw.document) -> 84 84 + match doc.root with 85 85 + | None -> () 86 86 + | Some yaml -> 87 87 + if not !first then print_endline "---"; 88 88 + first := false; 89 89 + let value = 90 90 + Yamlrw.to_json ~resolve_aliases ~max_nodes ~max_depth yaml 91 91 + in 92 92 + print_endline (value_to_json value)) 93 93 + documents 84 94 | Debug -> 85 85 - List.iteri (fun i (doc : Yamlrw.document) -> 86 86 - Format.printf "Document %d:@." (i + 1); 87 87 - (* Convert back to Document.t for printing *) 88 88 - let doc' : Yamlrw.Document.t = { 89 89 - Yamlrw.Document.version = doc.version; 90 90 - Yamlrw.Document.tags = doc.tags; 91 91 - Yamlrw.Document.root = (doc.root :> Yamlrw.Yaml.t option); 92 92 - Yamlrw.Document.implicit_start = doc.implicit_start; 93 93 - Yamlrw.Document.implicit_end = doc.implicit_end; 94 94 - } in 95 95 - Format.printf "%a@." Yamlrw.Document.pp doc' 96 96 - ) documents 97 97 - with 98 98 - | Yamlrw.Yamlrw_error e -> 99 99 - Printf.eprintf "Error: %s\n" (Yamlrw.Error.to_string e); 100 100 - exit 1 95 95 + List.iteri 96 96 + (fun i (doc : Yamlrw.document) -> 97 97 + Format.printf "Document %d:@." (i + 1); 98 98 + (* Convert back to Document.t for printing *) 99 99 + let doc' : Yamlrw.Document.t = 100 100 + { 101 101 + Yamlrw.Document.version = doc.version; 102 102 + Yamlrw.Document.tags = doc.tags; 103 103 + Yamlrw.Document.root = (doc.root :> Yamlrw.Yaml.t option); 104 104 + Yamlrw.Document.implicit_start = doc.implicit_start; 105 105 + Yamlrw.Document.implicit_end = doc.implicit_end; 106 106 + } 107 107 + in 108 108 + Format.printf "%a@." Yamlrw.Document.pp doc') 109 109 + documents 110 110 + with Yamlrw.Yamlrw_error e -> 111 111 + Printf.eprintf "Error: %s\n" (Yamlrw.Error.to_string e); 112 112 + exit 1 101 113 102 114 let process_file ~format ~resolve_aliases ~max_nodes ~max_depth filename = 103 115 let content = 104 104 - if filename = "-" then 105 105 - In_channel.input_all In_channel.stdin 106 106 - else 107 107 - In_channel.with_open_text filename In_channel.input_all 116 116 + if filename = "-" then In_channel.input_all In_channel.stdin 117 117 + else In_channel.with_open_text filename In_channel.input_all 108 118 in 109 119 process_string ~format ~resolve_aliases ~max_nodes ~max_depth content 110 120 111 121 let run format _all resolve_aliases max_nodes max_depth files = 112 112 - let files = if files = [] then ["-"] else files in 122 122 + let files = if files = [] then [ "-" ] else files in 113 123 List.iter (process_file ~format ~resolve_aliases ~max_nodes ~max_depth) files; 114 124 `Ok () 115 125 ··· 117 127 118 128 let format_arg = 119 129 let doc = "Output format: yaml (default), json, flow, or debug." in 120 120 - let formats = [ 121 121 - ("yaml", Yaml); 122 122 - ("json", Json); 123 123 - ("flow", Flow); 124 124 - ("debug", Debug); 125 125 - ] in 126 126 - Arg.(value & opt (enum formats) Yaml & info ["format"; "f"] ~docv:"FORMAT" ~doc) 130 130 + let formats = 131 131 + [ ("yaml", Yaml); ("json", Json); ("flow", Flow); ("debug", Debug) ] 132 132 + in 133 133 + Arg.( 134 134 + value & opt (enum formats) Yaml & info [ "format"; "f" ] ~docv:"FORMAT" ~doc) 127 135 128 136 let json_arg = 129 137 let doc = "Output as JSON (shorthand for --format=json)." in 130 130 - Arg.(value & flag & info ["json"] ~doc) 138 138 + Arg.(value & flag & info [ "json" ] ~doc) 131 139 132 140 let flow_arg = 133 141 let doc = "Output in flow style (shorthand for --format=flow)." in 134 134 - Arg.(value & flag & info ["flow"] ~doc) 142 142 + Arg.(value & flag & info [ "flow" ] ~doc) 135 143 136 144 let debug_arg = 137 145 let doc = "Output internal representation (shorthand for --format=debug)." in 138 138 - Arg.(value & flag & info ["debug"] ~doc) 146 146 + Arg.(value & flag & info [ "debug" ] ~doc) 139 147 140 148 let all_arg = 141 149 let doc = "Output all documents (for multi-document YAML)." in 142 142 - Arg.(value & flag & info ["all"; "a"] ~doc) 150 150 + Arg.(value & flag & info [ "all"; "a" ] ~doc) 143 151 144 152 let no_resolve_aliases_arg = 145 153 let doc = "Don't resolve aliases (keep them as references)." in 146 146 - Arg.(value & flag & info ["no-resolve-aliases"] ~doc) 154 154 + Arg.(value & flag & info [ "no-resolve-aliases" ] ~doc) 147 155 148 156 let max_nodes_arg = 149 149 - let doc = "Maximum number of nodes during alias expansion (default: 10000000). \ 150 150 - Protection against billion laughs attack." in 151 151 - Arg.(value & opt int Yamlrw.default_max_alias_nodes & info ["max-nodes"] ~docv:"N" ~doc) 157 157 + let doc = 158 158 + "Maximum number of nodes during alias expansion (default: 10000000). \ 159 159 + Protection against billion laughs attack." 160 160 + in 161 161 + Arg.( 162 162 + value 163 163 + & opt int Yamlrw.default_max_alias_nodes 164 164 + & info [ "max-nodes" ] ~docv:"N" ~doc) 152 165 153 166 let max_depth_arg = 154 154 - let doc = "Maximum alias nesting depth (default: 100). \ 155 155 - Protection against deeply nested alias chains." in 156 156 - Arg.(value & opt int Yamlrw.default_max_alias_depth & info ["max-depth"] ~docv:"N" ~doc) 167 167 + let doc = 168 168 + "Maximum alias nesting depth (default: 100). Protection against deeply \ 169 169 + nested alias chains." 170 170 + in 171 171 + Arg.( 172 172 + value 173 173 + & opt int Yamlrw.default_max_alias_depth 174 174 + & info [ "max-depth" ] ~docv:"N" ~doc) 157 175 158 176 let files_arg = 159 177 let doc = "YAML file(s) to process. Use '-' for stdin." in 160 178 Arg.(value & pos_all file [] & info [] ~docv:"FILE" ~doc) 161 179 162 180 let combined_format format json flow debug = 163 163 - if json then Json 164 164 - else if flow then Flow 165 165 - else if debug then Debug 166 166 - else format 181 181 + if json then Json else if flow then Flow else if debug then Debug else format 167 182 168 183 let term = 169 184 let combine format json flow debug all no_resolve max_nodes max_depth files = ··· 171 186 let resolve_aliases = not no_resolve in 172 187 run format all resolve_aliases max_nodes max_depth files 173 188 in 174 174 - Term.(ret (const combine $ format_arg $ json_arg $ flow_arg $ debug_arg $ 175 175 - all_arg $ no_resolve_aliases_arg $ max_nodes_arg $ max_depth_arg $ files_arg)) 189 189 + Term.( 190 190 + ret 191 191 + (const combine $ format_arg $ json_arg $ flow_arg $ debug_arg $ all_arg 192 192 + $ no_resolve_aliases_arg $ max_nodes_arg $ max_depth_arg $ files_arg)) 176 193 177 194 let info = 178 195 let doc = "Parse and reprint YAML files" in 179 179 - let man = [ 180 180 - `S Manpage.s_description; 181 181 - `P "$(tname) parses YAML files and reprints them in various formats. \ 182 182 - It can be used to validate YAML, convert between styles, or convert to JSON."; 183 183 - `S Manpage.s_examples; 184 184 - `P "Parse and reprint a YAML file:"; 185 185 - `Pre " $(tname) config.yaml"; 186 186 - `P "Convert YAML to JSON:"; 187 187 - `Pre " $(tname) --json config.yaml"; 188 188 - `P "Process multi-document YAML:"; 189 189 - `Pre " $(tname) --all multi.yaml"; 190 190 - `P "Limit alias expansion (protection against malicious YAML):"; 191 191 - `Pre " $(tname) --max-nodes 1000 --max-depth 10 untrusted.yaml"; 192 192 - `S Manpage.s_bugs; 193 193 - `P "Report bugs at https://github.com/avsm/ocaml-yaml/issues"; 194 194 - ] in 196 196 + let man = 197 197 + [ 198 198 + `S Manpage.s_description; 199 199 + `P 200 200 + "$(tname) parses YAML files and reprints them in various formats. It \ 201 201 + can be used to validate YAML, convert between styles, or convert to \ 202 202 + JSON."; 203 203 + `S Manpage.s_examples; 204 204 + `P "Parse and reprint a YAML file:"; 205 205 + `Pre " $(tname) config.yaml"; 206 206 + `P "Convert YAML to JSON:"; 207 207 + `Pre " $(tname) --json config.yaml"; 208 208 + `P "Process multi-document YAML:"; 209 209 + `Pre " $(tname) --all multi.yaml"; 210 210 + `P "Limit alias expansion (protection against malicious YAML):"; 211 211 + `Pre " $(tname) --max-nodes 1000 --max-depth 10 untrusted.yaml"; 212 212 + `S Manpage.s_bugs; 213 213 + `P "Report bugs at https://github.com/avsm/ocaml-yaml/issues"; 214 214 + ] 215 215 + in 195 216 Cmd.info "yamlcat" ~version:"0.1.0" ~doc ~man 196 217 197 218 let () = exit (Cmd.eval (Cmd.v info term))

+1

dune

··· 1 1 ; Root dune file 2 2 3 3 ; Ignore third_party directory (for fetched dependency sources) 4 4 + 4 5 (data_only_dirs third_party)

+6 -12

lib/char_class.ml

··· 19 19 20 20 (** Hexadecimal digit *) 21 21 let is_hex c = 22 22 - (c >= '0' && c <= '9') || 23 23 - (c >= 'a' && c <= 'f') || 24 24 - (c >= 'A' && c <= 'F') 22 22 + (c >= '0' && c <= '9') || (c >= 'a' && c <= 'f') || (c >= 'A' && c <= 'F') 25 23 26 24 (** Alphabetic character *) 27 27 - let is_alpha c = 28 28 - (c >= 'a' && c <= 'z') || 29 29 - (c >= 'A' && c <= 'Z') 25 25 + let is_alpha c = (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') 30 26 31 27 (** Alphanumeric character *) 32 28 let is_alnum c = is_alpha c || is_digit c ··· 34 30 (** YAML indicator characters *) 35 31 let is_indicator c = 36 32 match c with 37 37 - | '-' | '?' | ':' | ',' | '[' | ']' | '{' | '}' 38 38 - | '#' | '&' | '*' | '!' | '|' | '>' | '\'' | '"' 39 39 - | '%' | '@' | '`' -> true 33 33 + | '-' | '?' | ':' | ',' | '[' | ']' | '{' | '}' | '#' | '&' | '*' | '!' | '|' 34 34 + | '>' | '\'' | '"' | '%' | '@' | '`' -> 35 35 + true 40 36 | _ -> false 41 37 42 38 (** Flow context indicator characters *) 43 39 let is_flow_indicator c = 44 44 - match c with 45 45 - | ',' | '[' | ']' | '{' | '}' -> true 46 46 - | _ -> false 40 40 + match c with ',' | '[' | ']' | '{' | '}' -> true | _ -> false

+5 -19

lib/chomping.ml

··· 6 6 (** Block scalar chomping indicators *) 7 7 8 8 type t = 9 9 - | Strip (** Remove final line break and trailing empty lines *) 9 9 + | Strip (** Remove final line break and trailing empty lines *) 10 10 | Clip (** Keep final line break, remove trailing empty lines (default) *) 11 11 | Keep (** Keep final line break and trailing empty lines *) 12 12 13 13 - let to_string = function 14 14 - | Strip -> "strip" 15 15 - | Clip -> "clip" 16 16 - | Keep -> "keep" 17 17 - 18 18 - let pp fmt t = 19 19 - Format.pp_print_string fmt (to_string t) 20 20 - 21 21 - let of_char = function 22 22 - | '-' -> Some Strip 23 23 - | '+' -> Some Keep 24 24 - | _ -> None 25 25 - 26 26 - let to_char = function 27 27 - | Strip -> Some '-' 28 28 - | Clip -> None 29 29 - | Keep -> Some '+' 30 30 - 13 13 + let to_string = function Strip -> "strip" | Clip -> "clip" | Keep -> "keep" 14 14 + let pp fmt t = Format.pp_print_string fmt (to_string t) 15 15 + let of_char = function '-' -> Some Strip | '+' -> Some Keep | _ -> None 16 16 + let to_char = function Strip -> Some '-' | Clip -> None | Keep -> Some '+' 31 17 let equal a b = a = b

+16 -20

lib/document.ml

··· 13 13 implicit_end : bool; 14 14 } 15 15 16 16 - let make 17 17 - ?(version : (int * int) option) 18 18 - ?(tags : (string * string) list = []) 19 19 - ?(implicit_start = true) 20 20 - ?(implicit_end = true) 21 21 - root = 16 16 + let make ?(version : (int * int) option) ?(tags : (string * string) list = []) 17 17 + ?(implicit_start = true) ?(implicit_end = true) root = 22 18 { version; tags; root; implicit_start; implicit_end } 23 19 24 20 let version t = t.version ··· 26 22 let root t = t.root 27 23 let implicit_start t = t.implicit_start 28 24 let implicit_end t = t.implicit_end 29 29 - 30 25 let with_version version t = { t with version = Some version } 31 26 let with_tags tags t = { t with tags } 32 27 let with_root root t = { t with root = Some root } ··· 34 29 let pp fmt t = 35 30 Format.fprintf fmt "@[<v 2>document(@,"; 36 31 (match t.version with 37 37 - | Some (maj, min) -> Format.fprintf fmt "version=%d.%d,@ " maj min 38 38 - | None -> ()); 32 32 + | Some (maj, min) -> Format.fprintf fmt "version=%d.%d,@ " maj min 33 33 + | None -> ()); 39 34 if t.tags <> [] then begin 40 35 Format.fprintf fmt "tags=["; 41 41 - List.iteri (fun i (h, p) -> 42 42 - if i > 0 then Format.fprintf fmt ", "; 43 43 - Format.fprintf fmt "%s -> %s" h p 44 44 - ) t.tags; 36 36 + List.iteri 37 37 + (fun i (h, p) -> 38 38 + if i > 0 then Format.fprintf fmt ", "; 39 39 + Format.fprintf fmt "%s -> %s" h p) 40 40 + t.tags; 45 41 Format.fprintf fmt "],@ " 46 42 end; 47 43 Format.fprintf fmt "implicit_start=%b,@ " t.implicit_start; 48 44 Format.fprintf fmt "implicit_end=%b,@ " t.implicit_end; 49 45 (match t.root with 50 50 - | Some root -> Format.fprintf fmt "root=%a" Yaml.pp root 51 51 - | None -> Format.fprintf fmt "root=<empty>"); 46 46 + | Some root -> Format.fprintf fmt "root=%a" Yaml.pp root 47 47 + | None -> Format.fprintf fmt "root=<empty>"); 52 48 Format.fprintf fmt "@]@,)" 53 49 54 50 let equal a b = 55 55 - Option.equal ( = ) a.version b.version && 56 56 - List.equal ( = ) a.tags b.tags && 57 57 - Option.equal Yaml.equal a.root b.root && 58 58 - a.implicit_start = b.implicit_start && 59 59 - a.implicit_end = b.implicit_end 51 51 + Option.equal ( = ) a.version b.version 52 52 + && List.equal ( = ) a.tags b.tags 53 53 + && Option.equal Yaml.equal a.root b.root 54 54 + && a.implicit_start = b.implicit_start 55 55 + && a.implicit_end = b.implicit_end

+63 -107

lib/eio/yamlrw_eio.ml

··· 5 5 6 6 (** Yamlrw Eio - Streaming YAML parsing and emitting with Eio 7 7 8 8 - This module provides Eio-compatible streaming YAML parsing and emitting. 9 9 - It uses bytesrw adapters to convert Eio sources/sinks to the standard 10 10 - YAML scanner/parser/emitter, eliminating code duplication. *) 8 8 + This module provides Eio-compatible streaming YAML parsing and emitting. It 9 9 + uses bytesrw adapters to convert Eio sources/sinks to the standard YAML 10 10 + scanner/parser/emitter, eliminating code duplication. *) 11 11 12 12 open Yamlrw 13 13 ··· 30 30 Scanner.of_input input 31 31 32 32 (** Create a parser from an Eio flow *) 33 33 - let parser_of_flow flow = 34 34 - Parser.of_scanner (scanner_of_flow flow) 33 33 + let parser_of_flow flow = Parser.of_scanner (scanner_of_flow flow) 35 34 36 35 (** Parse a JSON-compatible value from an Eio flow. 37 36 38 37 @param resolve_aliases Whether to expand aliases (default: true) 39 38 @param max_nodes Maximum nodes during alias expansion (default: 10M) 40 39 @param max_depth Maximum alias nesting depth (default: 100) *) 41 41 - let value 42 42 - ?(resolve_aliases = true) 40 40 + let value ?(resolve_aliases = true) 43 41 ?(max_nodes = Yaml.default_max_alias_nodes) 44 44 - ?(max_depth = Yaml.default_max_alias_depth) 45 45 - flow = 42 42 + ?(max_depth = Yaml.default_max_alias_depth) flow = 46 43 let parser = parser_of_flow flow in 47 47 - Loader.value_of_parser 48 48 - ~resolve_aliases ~max_nodes ~max_depth 49 49 - (fun () -> Parser.next parser) 44 44 + Loader.value_of_parser ~resolve_aliases ~max_nodes ~max_depth (fun () -> 45 45 + Parser.next parser) 50 46 51 47 (** Parse a full YAML value from an Eio flow. 52 48 ··· 55 51 @param resolve_aliases Whether to expand aliases (default: false) 56 52 @param max_nodes Maximum nodes during alias expansion (default: 10M) 57 53 @param max_depth Maximum alias nesting depth (default: 100) *) 58 58 - let yaml 59 59 - ?(resolve_aliases = false) 54 54 + let yaml ?(resolve_aliases = false) 60 55 ?(max_nodes = Yaml.default_max_alias_nodes) 61 61 - ?(max_depth = Yaml.default_max_alias_depth) 62 62 - flow = 56 56 + ?(max_depth = Yaml.default_max_alias_depth) flow = 63 57 let parser = parser_of_flow flow in 64 64 - Loader.yaml_of_parser 65 65 - ~resolve_aliases ~max_nodes ~max_depth 66 66 - (fun () -> Parser.next parser) 58 58 + Loader.yaml_of_parser ~resolve_aliases ~max_nodes ~max_depth (fun () -> 59 59 + Parser.next parser) 67 60 68 61 (** Parse multiple YAML documents from an Eio flow. *) 69 62 let documents flow = ··· 72 65 73 66 (** {2 Event-Based Streaming} *) 74 67 68 68 + type event_reader = { parser : Parser.t } 75 69 (** A streaming event reader backed by a flow *) 76 76 - type event_reader = { 77 77 - parser : Parser.t; 78 78 - } 79 70 80 80 - (** Create an event reader from an Eio flow. 81 81 - This reads data incrementally as events are requested. *) 82 82 - let event_reader flow = 83 83 - { parser = parser_of_flow flow } 71 71 + (** Create an event reader from an Eio flow. This reads data incrementally as 72 72 + events are requested. *) 73 73 + let event_reader flow = { parser = parser_of_flow flow } 84 74 85 85 - (** Get the next event from an event reader. 86 86 - Returns [None] when parsing is complete. *) 87 87 - let next_event reader = 88 88 - Parser.next reader.parser 75 75 + (** Get the next event from an event reader. Returns [None] when parsing is 76 76 + complete. *) 77 77 + let next_event reader = Parser.next reader.parser 89 78 90 79 (** Iterate over all events from a flow. 91 80 ··· 127 116 @param encoding Output encoding (default: UTF-8) 128 117 @param scalar_style Preferred scalar style (default: Any) 129 118 @param layout_style Preferred layout style (default: Any) *) 130 130 - let value 131 131 - ?(encoding = `Utf8) 132 132 - ?(scalar_style = `Any) 133 133 - ?(layout_style = `Any) 134 134 - flow 135 135 - (v : value) = 136 136 - let config = { Emitter.default_config with encoding; scalar_style; layout_style } in 119 119 + let value ?(encoding = `Utf8) ?(scalar_style = `Any) ?(layout_style = `Any) 120 120 + flow (v : value) = 121 121 + let config = 122 122 + { Emitter.default_config with encoding; scalar_style; layout_style } 123 123 + in 137 124 let writer = Bytesrw_eio.bytes_writer_of_flow flow in 138 125 Serialize.value_to_writer ~config writer v 139 126 ··· 142 129 @param encoding Output encoding (default: UTF-8) 143 130 @param scalar_style Preferred scalar style (default: Any) 144 131 @param layout_style Preferred layout style (default: Any) *) 145 145 - let yaml 146 146 - ?(encoding = `Utf8) 147 147 - ?(scalar_style = `Any) 148 148 - ?(layout_style = `Any) 149 149 - flow 150 150 - (v : yaml) = 151 151 - let config = { Emitter.default_config with encoding; scalar_style; layout_style } in 132 132 + let yaml ?(encoding = `Utf8) ?(scalar_style = `Any) ?(layout_style = `Any) 133 133 + flow (v : yaml) = 134 134 + let config = 135 135 + { Emitter.default_config with encoding; scalar_style; layout_style } 136 136 + in 152 137 let writer = Bytesrw_eio.bytes_writer_of_flow flow in 153 138 Serialize.yaml_to_writer ~config writer v 154 139 ··· 158 143 @param scalar_style Preferred scalar style (default: Any) 159 144 @param layout_style Preferred layout style (default: Any) 160 145 @param resolve_aliases Whether to expand aliases (default: true) *) 161 161 - let documents 162 162 - ?(encoding = `Utf8) 163 163 - ?(scalar_style = `Any) 164 164 - ?(layout_style = `Any) 165 165 - ?(resolve_aliases = true) 166 166 - flow 167 167 - docs = 168 168 - let config = { Emitter.default_config with encoding; scalar_style; layout_style } in 146 146 + let documents ?(encoding = `Utf8) ?(scalar_style = `Any) 147 147 + ?(layout_style = `Any) ?(resolve_aliases = true) flow docs = 148 148 + let config = 149 149 + { Emitter.default_config with encoding; scalar_style; layout_style } 150 150 + in 169 151 let writer = Bytesrw_eio.bytes_writer_of_flow flow in 170 152 Serialize.documents_to_writer ~config ~resolve_aliases writer docs 171 153 172 154 (** {2 Event-Based Streaming} *) 173 155 156 156 + type event_writer = { emitter : Emitter.t } 174 157 (** A streaming event writer that writes directly to a flow *) 175 175 - type event_writer = { 176 176 - emitter : Emitter.t; 177 177 - } 178 158 179 179 - (** Create an event writer that writes directly to a flow. 180 180 - Events are written incrementally as they are emitted. 159 159 + (** Create an event writer that writes directly to a flow. Events are written 160 160 + incrementally as they are emitted. 181 161 182 162 @param encoding Output encoding (default: UTF-8) 183 163 @param scalar_style Preferred scalar style (default: Any) 184 164 @param layout_style Preferred layout style (default: Any) *) 185 185 - let event_writer 186 186 - ?(encoding = `Utf8) 187 187 - ?(scalar_style = `Any) 188 188 - ?(layout_style = `Any) 189 189 - flow = 190 190 - let config = { Emitter.default_config with encoding; scalar_style; layout_style } in 165 165 + let event_writer ?(encoding = `Utf8) ?(scalar_style = `Any) 166 166 + ?(layout_style = `Any) flow = 167 167 + let config = 168 168 + { Emitter.default_config with encoding; scalar_style; layout_style } 169 169 + in 191 170 let writer = Bytesrw_eio.bytes_writer_of_flow flow in 192 171 { emitter = Emitter.of_writer ~config writer } 193 172 194 173 (** Emit a single event to the writer. *) 195 195 - let emit ew ev = 196 196 - Emitter.emit ew.emitter ev 174 174 + let emit ew ev = Emitter.emit ew.emitter ev 197 175 198 176 (** Flush the writer by sending end-of-data. *) 199 199 - let flush ew = 200 200 - Emitter.flush ew.emitter 177 177 + let flush ew = Emitter.flush ew.emitter 201 178 202 179 (** Emit events from a list to a flow. *) 203 180 let emit_all flow events = ··· 209 186 (** {1 Convenience Functions} *) 210 187 211 188 (** Read a value from a file path *) 212 212 - let of_file 213 213 - ?(resolve_aliases = true) 189 189 + let of_file ?(resolve_aliases = true) 214 190 ?(max_nodes = Yaml.default_max_alias_nodes) 215 215 - ?(max_depth = Yaml.default_max_alias_depth) 216 216 - ~fs 217 217 - path = 191 191 + ?(max_depth = Yaml.default_max_alias_depth) ~fs path = 218 192 Eio.Path.with_open_in Eio.Path.(fs / path) @@ fun flow -> 219 193 Read.value ~resolve_aliases ~max_nodes ~max_depth flow 220 194 221 195 (** Read full YAML from a file path *) 222 222 - let yaml_of_file 223 223 - ?(resolve_aliases = false) 196 196 + let yaml_of_file ?(resolve_aliases = false) 224 197 ?(max_nodes = Yaml.default_max_alias_nodes) 225 225 - ?(max_depth = Yaml.default_max_alias_depth) 226 226 - ~fs 227 227 - path = 198 198 + ?(max_depth = Yaml.default_max_alias_depth) ~fs path = 228 199 Eio.Path.with_open_in Eio.Path.(fs / path) @@ fun flow -> 229 200 Read.yaml ~resolve_aliases ~max_nodes ~max_depth flow 230 201 231 202 (** Read documents from a file path *) 232 203 let documents_of_file ~fs path = 233 233 - Eio.Path.with_open_in Eio.Path.(fs / path) @@ fun flow -> 234 234 - Read.documents flow 204 204 + Eio.Path.with_open_in Eio.Path.(fs / path) @@ fun flow -> Read.documents flow 235 205 236 206 (** Write a value to a file path *) 237 237 - let to_file 238 238 - ?(encoding = `Utf8) 239 239 - ?(scalar_style = `Any) 240 240 - ?(layout_style = `Any) 241 241 - ~fs 242 242 - path 243 243 - v = 244 244 - Eio.Path.with_open_out ~create:(`Or_truncate 0o644) Eio.Path.(fs / path) @@ fun flow -> 245 245 - Write.value ~encoding ~scalar_style ~layout_style flow v 207 207 + let to_file ?(encoding = `Utf8) ?(scalar_style = `Any) ?(layout_style = `Any) 208 208 + ~fs path v = 209 209 + Eio.Path.with_open_out ~create:(`Or_truncate 0o644) Eio.Path.(fs / path) 210 210 + @@ fun flow -> Write.value ~encoding ~scalar_style ~layout_style flow v 246 211 247 212 (** Write full YAML to a file path *) 248 248 - let yaml_to_file 249 249 - ?(encoding = `Utf8) 250 250 - ?(scalar_style = `Any) 251 251 - ?(layout_style = `Any) 252 252 - ~fs 253 253 - path 254 254 - v = 255 255 - Eio.Path.with_open_out ~create:(`Or_truncate 0o644) Eio.Path.(fs / path) @@ fun flow -> 256 256 - Write.yaml ~encoding ~scalar_style ~layout_style flow v 213 213 + let yaml_to_file ?(encoding = `Utf8) ?(scalar_style = `Any) 214 214 + ?(layout_style = `Any) ~fs path v = 215 215 + Eio.Path.with_open_out ~create:(`Or_truncate 0o644) Eio.Path.(fs / path) 216 216 + @@ fun flow -> Write.yaml ~encoding ~scalar_style ~layout_style flow v 257 217 258 218 (** Write documents to a file path *) 259 259 - let documents_to_file 260 260 - ?(encoding = `Utf8) 261 261 - ?(scalar_style = `Any) 262 262 - ?(layout_style = `Any) 263 263 - ?(resolve_aliases = true) 264 264 - ~fs 265 265 - path 266 266 - docs = 267 267 - Eio.Path.with_open_out ~create:(`Or_truncate 0o644) Eio.Path.(fs / path) @@ fun flow -> 268 268 - Write.documents ~encoding ~scalar_style ~layout_style ~resolve_aliases flow docs 219 219 + let documents_to_file ?(encoding = `Utf8) ?(scalar_style = `Any) 220 220 + ?(layout_style = `Any) ?(resolve_aliases = true) ~fs path docs = 221 221 + Eio.Path.with_open_out ~create:(`Or_truncate 0o644) Eio.Path.(fs / path) 222 222 + @@ fun flow -> 223 223 + Write.documents ~encoding ~scalar_style ~layout_style ~resolve_aliases flow 224 224 + docs

+66 -52

lib/eio/yamlrw_eio.mli

··· 5 5 6 6 (** Yamlrw Eio - Streaming YAML parsing and emitting with Eio 7 7 8 8 - This library provides Eio-based streaming support for YAML parsing 9 9 - and emitting. It uses bytesrw adapters that read/write directly to 10 10 - Eio flows, with bytesrw handling internal buffering. 8 8 + This library provides Eio-based streaming support for YAML parsing and 9 9 + emitting. It uses bytesrw adapters that read/write directly to Eio flows, 10 10 + with bytesrw handling internal buffering. 11 11 12 12 {2 Quick Start} 13 13 ··· 24 24 Eio_main.run @@ fun env -> 25 25 let fs = Eio.Stdenv.fs env in 26 26 Eio.Path.with_open_out Eio.Path.(fs / "output.yaml") @@ fun flow -> 27 27 - Yaml_eio.Write.value flow (`O [("name", `String "test")]) 27 27 + Yaml_eio.Write.value flow (`O [ ("name", `String "test") ]) 28 28 ]} 29 29 30 30 Stream events incrementally: ··· 32 32 Eio_main.run @@ fun env -> 33 33 let fs = Eio.Stdenv.fs env in 34 34 Eio.Path.with_open_in Eio.Path.(fs / "data.yaml") @@ fun flow -> 35 35 - Yaml_eio.Read.iter_events (fun event span -> 36 36 - Format.printf "Event at %a@." Yamlrw.Span.pp span 37 37 - ) flow 35 35 + Yaml_eio.Read.iter_events 36 36 + (fun event span -> Format.printf "Event at %a@." Yamlrw.Span.pp span) 37 37 + flow 38 38 ]} 39 39 40 40 {2 Streaming Architecture} 41 41 42 42 This library uses bytesrw for direct I/O with Eio flows: 43 43 44 44 - - {b Reading}: Data is read directly from the flow as the 45 45 - parser requests it. Bytesrw handles internal buffering. 44 44 + - {b Reading}: Data is read directly from the flow as the parser requests 45 45 + it. Bytesrw handles internal buffering. 46 46 47 47 - - {b Writing}: Output is written directly to the flow. 48 48 - Bytesrw handles chunking and buffering. *) 47 47 + - {b Writing}: Output is written directly to the flow. Bytesrw handles 48 48 + chunking and buffering. *) 49 49 50 50 (** {1 Types} *) 51 51 ··· 66 66 module Read : sig 67 67 (** Parse YAML from Eio flows. 68 68 69 69 - All functions read data incrementally from the underlying flow, 70 70 - without loading the entire file into memory first. *) 69 69 + All functions read data incrementally from the underlying flow, without 70 70 + loading the entire file into memory first. *) 71 71 72 72 (** {2 High-Level Parsing} *) 73 73 ··· 75 75 ?resolve_aliases:bool -> 76 76 ?max_nodes:int -> 77 77 ?max_depth:int -> 78 78 - _ Eio.Flow.source -> value 78 78 + _ Eio.Flow.source -> 79 79 + value 79 80 (** Parse a JSON-compatible value from an Eio flow. 80 81 81 82 @param resolve_aliases Whether to expand aliases (default: true) ··· 86 87 ?resolve_aliases:bool -> 87 88 ?max_nodes:int -> 88 89 ?max_depth:int -> 89 89 - _ Eio.Flow.source -> yaml 90 90 + _ Eio.Flow.source -> 91 91 + yaml 90 92 (** Parse a full YAML value from an Eio flow. 91 93 92 94 By default, aliases are NOT resolved, preserving the document structure. ··· 101 103 (** {2 Event-Based Streaming} *) 102 104 103 105 type event_reader 104 104 - (** A streaming event reader backed by a flow. 105 105 - Events are parsed incrementally as requested. *) 106 106 + (** A streaming event reader backed by a flow. Events are parsed incrementally 107 107 + as requested. *) 106 108 107 109 val event_reader : _ Eio.Flow.source -> event_reader 108 110 (** Create an event reader from an Eio flow. *) 109 111 110 112 val next_event : event_reader -> Yamlrw.Event.spanned option 111 111 - (** Get the next event from an event reader. 112 112 - Returns [None] when parsing is complete. *) 113 113 + (** Get the next event from an event reader. Returns [None] when parsing is 114 114 + complete. *) 113 115 114 116 val iter_events : 115 115 - (event -> Yamlrw.Span.t -> unit) -> 116 116 - _ Eio.Flow.source -> unit 117 117 + (event -> Yamlrw.Span.t -> unit) -> _ Eio.Flow.source -> unit 117 118 (** Iterate over all events from a flow. *) 118 119 119 119 - val fold_events : 120 120 - ('a -> event -> 'a) -> 'a -> 121 121 - _ Eio.Flow.source -> 'a 120 120 + val fold_events : ('a -> event -> 'a) -> 'a -> _ Eio.Flow.source -> 'a 122 121 (** Fold over all events from a flow. *) 123 122 124 124 - val iter_documents : 125 125 - (document -> unit) -> 126 126 - _ Eio.Flow.source -> unit 123 123 + val iter_documents : (document -> unit) -> _ Eio.Flow.source -> unit 127 124 (** Iterate over documents from a flow, calling [f] for each document. *) 128 125 129 129 - val fold_documents : 130 130 - ('a -> document -> 'a) -> 'a -> 131 131 - _ Eio.Flow.source -> 'a 126 126 + val fold_documents : ('a -> document -> 'a) -> 'a -> _ Eio.Flow.source -> 'a 132 127 (** Fold over documents from a flow. *) 133 128 end 134 129 ··· 145 140 ?encoding:Yamlrw.Encoding.t -> 146 141 ?scalar_style:Yamlrw.Scalar_style.t -> 147 142 ?layout_style:Yamlrw.Layout_style.t -> 148 148 - _ Eio.Flow.sink -> value -> unit 143 143 + _ Eio.Flow.sink -> 144 144 + value -> 145 145 + unit 149 146 (** Write a JSON-compatible value to an Eio flow. 150 147 151 148 @param encoding Output encoding (default: UTF-8) ··· 156 153 ?encoding:Yamlrw.Encoding.t -> 157 154 ?scalar_style:Yamlrw.Scalar_style.t -> 158 155 ?layout_style:Yamlrw.Layout_style.t -> 159 159 - _ Eio.Flow.sink -> yaml -> unit 156 156 + _ Eio.Flow.sink -> 157 157 + yaml -> 158 158 + unit 160 159 (** Write a full YAML value to an Eio flow. 161 160 162 161 @param encoding Output encoding (default: UTF-8) ··· 168 167 ?scalar_style:Yamlrw.Scalar_style.t -> 169 168 ?layout_style:Yamlrw.Layout_style.t -> 170 169 ?resolve_aliases:bool -> 171 171 - _ Eio.Flow.sink -> document list -> unit 170 170 + _ Eio.Flow.sink -> 171 171 + document list -> 172 172 + unit 172 173 (** Write multiple YAML documents to an Eio flow. 173 174 174 175 @param encoding Output encoding (default: UTF-8) ··· 179 180 (** {2 Event-Based Streaming} *) 180 181 181 182 type event_writer 182 182 - (** A streaming event writer backed by a flow. 183 183 - Events are written incrementally to the underlying flow. *) 183 183 + (** A streaming event writer backed by a flow. Events are written 184 184 + incrementally to the underlying flow. *) 184 185 185 186 val event_writer : 186 187 ?encoding:Yamlrw.Encoding.t -> 187 188 ?scalar_style:Yamlrw.Scalar_style.t -> 188 189 ?layout_style:Yamlrw.Layout_style.t -> 189 189 - _ Eio.Flow.sink -> event_writer 190 190 - (** Create an event writer that writes directly to a flow. 191 191 - Events are written incrementally as they are emitted. 190 190 + _ Eio.Flow.sink -> 191 191 + event_writer 192 192 + (** Create an event writer that writes directly to a flow. Events are written 193 193 + incrementally as they are emitted. 192 194 193 195 @param encoding Output encoding (default: UTF-8) 194 196 @param scalar_style Preferred scalar style (default: Any) ··· 211 213 ?max_nodes:int -> 212 214 ?max_depth:int -> 213 215 fs:_ Eio.Path.t -> 214 214 - string -> value 216 216 + string -> 217 217 + value 215 218 (** Read a value from a file path. 216 219 217 217 - @param fs The filesystem path (e.g., [Eio.Stdenv.fs env] or [Eio.Stdenv.cwd env]) *) 220 220 + @param fs 221 221 + The filesystem path (e.g., [Eio.Stdenv.fs env] or [Eio.Stdenv.cwd env]) *) 218 222 219 223 val yaml_of_file : 220 224 ?resolve_aliases:bool -> 221 225 ?max_nodes:int -> 222 226 ?max_depth:int -> 223 227 fs:_ Eio.Path.t -> 224 224 - string -> yaml 228 228 + string -> 229 229 + yaml 225 230 (** Read full YAML from a file path. 226 231 227 227 - @param fs The filesystem path (e.g., [Eio.Stdenv.fs env] or [Eio.Stdenv.cwd env]) *) 232 232 + @param fs 233 233 + The filesystem path (e.g., [Eio.Stdenv.fs env] or [Eio.Stdenv.cwd env]) *) 228 234 229 229 - val documents_of_file : 230 230 - fs:_ Eio.Path.t -> 231 231 - string -> document list 235 235 + val documents_of_file : fs:_ Eio.Path.t -> string -> document list 232 236 (** Read documents from a file path. 233 237 234 234 - @param fs The filesystem path (e.g., [Eio.Stdenv.fs env] or [Eio.Stdenv.cwd env]) *) 238 238 + @param fs 239 239 + The filesystem path (e.g., [Eio.Stdenv.fs env] or [Eio.Stdenv.cwd env]) *) 235 240 236 241 val to_file : 237 242 ?encoding:Yamlrw.Encoding.t -> 238 243 ?scalar_style:Yamlrw.Scalar_style.t -> 239 244 ?layout_style:Yamlrw.Layout_style.t -> 240 245 fs:_ Eio.Path.t -> 241 241 - string -> value -> unit 246 246 + string -> 247 247 + value -> 248 248 + unit 242 249 (** Write a value to a file path. 243 250 244 244 - @param fs The filesystem path (e.g., [Eio.Stdenv.fs env] or [Eio.Stdenv.cwd env]) *) 251 251 + @param fs 252 252 + The filesystem path (e.g., [Eio.Stdenv.fs env] or [Eio.Stdenv.cwd env]) *) 245 253 246 254 val yaml_to_file : 247 255 ?encoding:Yamlrw.Encoding.t -> 248 256 ?scalar_style:Yamlrw.Scalar_style.t -> 249 257 ?layout_style:Yamlrw.Layout_style.t -> 250 258 fs:_ Eio.Path.t -> 251 251 - string -> yaml -> unit 259 259 + string -> 260 260 + yaml -> 261 261 + unit 252 262 (** Write full YAML to a file path. 253 263 254 254 - @param fs The filesystem path (e.g., [Eio.Stdenv.fs env] or [Eio.Stdenv.cwd env]) *) 264 264 + @param fs 265 265 + The filesystem path (e.g., [Eio.Stdenv.fs env] or [Eio.Stdenv.cwd env]) *) 255 266 256 267 val documents_to_file : 257 268 ?encoding:Yamlrw.Encoding.t -> ··· 259 270 ?layout_style:Yamlrw.Layout_style.t -> 260 271 ?resolve_aliases:bool -> 261 272 fs:_ Eio.Path.t -> 262 262 - string -> document list -> unit 273 273 + string -> 274 274 + document list -> 275 275 + unit 263 276 (** Write documents to a file path. 264 277 265 265 - @param fs The filesystem path (e.g., [Eio.Stdenv.fs env] or [Eio.Stdenv.cwd env]) *) 278 278 + @param fs 279 279 + The filesystem path (e.g., [Eio.Stdenv.fs env] or [Eio.Stdenv.cwd env]) *)

+209 -211

lib/emitter.ml

··· 5 5 6 6 (** Emitter - converts YAML data structures to string output 7 7 8 8 - The emitter can write to either a Buffer (default) or directly to a 9 9 - bytesrw Bytes.Writer for streaming output. *) 8 8 + The emitter can write to either a Buffer (default) or directly to a bytesrw 9 9 + Bytes.Writer for streaming output. *) 10 10 11 11 type config = { 12 12 encoding : Encoding.t; ··· 17 17 canonical : bool; 18 18 } 19 19 20 20 - let default_config = { 21 21 - encoding = `Utf8; 22 22 - scalar_style = `Any; 23 23 - layout_style = `Any; 24 24 - indent = 2; 25 25 - width = 80; 26 26 - canonical = false; 27 27 - } 20 20 + let default_config = 21 21 + { 22 22 + encoding = `Utf8; 23 23 + scalar_style = `Any; 24 24 + layout_style = `Any; 25 25 + indent = 2; 26 26 + width = 80; 27 27 + canonical = false; 28 28 + } 28 29 29 30 type state = 30 31 | Initial 31 32 | Stream_started 32 33 | Document_started 33 33 - | In_block_sequence of int (* indent level *) 34 34 + | In_block_sequence of int (* indent level *) 34 35 | In_block_mapping_key of int 35 36 | In_block_mapping_value of int 36 36 - | In_block_mapping_first_key of int (* first key after "- ", no indent needed *) 37 37 + | In_block_mapping_first_key of 38 38 + int (* first key after "- ", no indent needed *) 37 39 | In_flow_sequence 38 40 | In_flow_mapping_key 39 41 | In_flow_mapping_value ··· 41 43 | Stream_ended 42 44 43 45 (** Output sink - either a Buffer or a bytesrw Writer *) 44 44 - type sink = 45 45 - | Buffer_sink of Buffer.t 46 46 - | Writer_sink of Bytesrw.Bytes.Writer.t 46 46 + type sink = Buffer_sink of Buffer.t | Writer_sink of Bytesrw.Bytes.Writer.t 47 47 48 48 type t = { 49 49 config : config; ··· 55 55 mutable need_separator : bool; 56 56 } 57 57 58 58 - let create ?(config = default_config) () = { 59 59 - config; 60 60 - sink = Buffer_sink (Buffer.create 1024); 61 61 - state = Initial; 62 62 - states = []; 63 63 - indent = 0; 64 64 - flow_level = 0; 65 65 - need_separator = false; 66 66 - } 58 58 + let create ?(config = default_config) () = 59 59 + { 60 60 + config; 61 61 + sink = Buffer_sink (Buffer.create 1024); 62 62 + state = Initial; 63 63 + states = []; 64 64 + indent = 0; 65 65 + flow_level = 0; 66 66 + need_separator = false; 67 67 + } 67 68 68 69 (** Create an emitter that writes directly to a Bytes.Writer *) 69 69 - let of_writer ?(config = default_config) writer = { 70 70 - config; 71 71 - sink = Writer_sink writer; 72 72 - state = Initial; 73 73 - states = []; 74 74 - indent = 0; 75 75 - flow_level = 0; 76 76 - need_separator = false; 77 77 - } 70 70 + let of_writer ?(config = default_config) writer = 71 71 + { 72 72 + config; 73 73 + sink = Writer_sink writer; 74 74 + state = Initial; 75 75 + states = []; 76 76 + indent = 0; 77 77 + flow_level = 0; 78 78 + need_separator = false; 79 79 + } 78 80 79 81 let contents t = 80 82 match t.sink with 81 83 | Buffer_sink buf -> Buffer.contents buf 82 82 - | Writer_sink _ -> "" (* No accumulated content for writer sink *) 84 84 + | Writer_sink _ -> "" (* No accumulated content for writer sink *) 83 85 84 86 let reset t = 85 87 (match t.sink with 86 86 - | Buffer_sink buf -> Buffer.clear buf 87 87 - | Writer_sink _ -> ()); 88 88 + | Buffer_sink buf -> Buffer.clear buf 89 89 + | Writer_sink _ -> ()); 88 90 t.state <- Initial; 89 91 t.states <- []; 90 92 t.indent <- 0; ··· 107 109 108 110 let write_indent t = 109 111 if t.indent <= 8 then 110 110 - for _ = 1 to t.indent do write_char t ' ' done 111 111 - else 112 112 - write t (String.make t.indent ' ') 112 112 + for _ = 1 to t.indent do 113 113 + write_char t ' ' 114 114 + done 115 115 + else write t (String.make t.indent ' ') 113 116 114 114 - let write_newline t = 115 115 - write_char t '\n' 117 117 + let write_newline t = write_char t '\n' 116 118 117 119 let push_state t s = 118 120 t.states <- t.state :: t.states; ··· 123 125 | s :: rest -> 124 126 t.state <- s; 125 127 t.states <- rest 126 126 - | [] -> 127 127 - t.state <- Stream_ended 128 128 + | [] -> t.state <- Stream_ended 128 129 129 129 - (** Escape a string for double-quoted output. 130 130 - Uses a buffer to batch writes instead of character-by-character. *) 130 130 + (** Escape a string for double-quoted output. Uses a buffer to batch writes 131 131 + instead of character-by-character. *) 131 132 let escape_double_quoted value = 132 133 let len = String.length value in 133 134 (* Check if any escaping is needed *) ··· 140 141 done; 141 142 if not !needs_escape then value 142 143 else begin 143 143 - let buf = Buffer.create (len + len / 4) in 144 144 + let buf = Buffer.create (len + (len / 4)) in 144 145 for i = 0 to len - 1 do 145 146 match value.[i] with 146 147 | '"' -> Buffer.add_string buf "\\\"" ··· 148 149 | '\n' -> Buffer.add_string buf "\\n" 149 150 | '\r' -> Buffer.add_string buf "\\r" 150 151 | '\t' -> Buffer.add_string buf "\\t" 151 151 - | c when c < ' ' -> Buffer.add_string buf (Printf.sprintf "\\x%02x" (Char.code c)) 152 152 + | c when c < ' ' -> 153 153 + Buffer.add_string buf (Printf.sprintf "\\x%02x" (Char.code c)) 152 154 | c -> Buffer.add_char buf c 153 155 done; 154 156 Buffer.contents buf ··· 159 161 if not (String.contains value '\'') then value 160 162 else begin 161 163 let len = String.length value in 162 162 - let buf = Buffer.create (len + len / 8) in 164 164 + let buf = Buffer.create (len + (len / 8)) in 163 165 for i = 0 to len - 1 do 164 166 let c = value.[i] in 165 165 - if c = '\'' then Buffer.add_string buf "''" 166 166 - else Buffer.add_char buf c 167 167 + if c = '\'' then Buffer.add_string buf "''" else Buffer.add_char buf c 167 168 done; 168 169 Buffer.contents buf 169 170 end 170 171 171 172 (** Write scalar with appropriate quoting *) 172 173 let write_scalar t ?(style = `Any) value = 173 173 - match (match style with `Any -> Quoting.choose_style value | s -> s) with 174 174 - | `Plain | `Any -> 175 175 - write t value 174 174 + match match style with `Any -> Quoting.choose_style value | s -> s with 175 175 + | `Plain | `Any -> write t value 176 176 | `Single_quoted -> 177 177 write_char t '\''; 178 178 write t (escape_single_quoted value); ··· 184 184 | `Literal -> 185 185 write t "|"; 186 186 write_newline t; 187 187 - String.split_on_char '\n' value |> List.iter (fun line -> 188 188 - write_indent t; 189 189 - write t line; 190 190 - write_newline t 191 191 - ) 187 187 + String.split_on_char '\n' value 188 188 + |> List.iter (fun line -> 189 189 + write_indent t; 190 190 + write t line; 191 191 + write_newline t) 192 192 | `Folded -> 193 193 write t ">"; 194 194 write_newline t; 195 195 - String.split_on_char '\n' value |> List.iter (fun line -> 196 196 - write_indent t; 197 197 - write t line; 198 198 - write_newline t 199 199 - ) 195 195 + String.split_on_char '\n' value 196 196 + |> List.iter (fun line -> 197 197 + write_indent t; 198 198 + write t line; 199 199 + write_newline t) 200 200 201 201 (** Write anchor if present *) 202 202 let write_anchor t anchor = ··· 221 221 222 222 let emit t (ev : Event.t) = 223 223 match ev with 224 224 - | Event.Stream_start _ -> 225 225 - t.state <- Stream_started 226 226 - 227 227 - | Event.Stream_end -> 228 228 - t.state <- Stream_ended 229 229 - 224 224 + | Event.Stream_start _ -> t.state <- Stream_started 225 225 + | Event.Stream_end -> t.state <- Stream_ended 230 226 | Event.Document_start { version; implicit } -> 231 227 if not implicit then begin 232 228 (match version with 233 233 - | Some (maj, min) -> 234 234 - write t (Printf.sprintf "%%YAML %d.%d\n" maj min) 235 235 - | None -> ()); 229 229 + | Some (maj, min) -> write t (Printf.sprintf "%%YAML %d.%d\n" maj min) 230 230 + | None -> ()); 236 231 write t "---"; 237 232 write_newline t 238 233 end; 239 234 t.state <- Document_started 240 240 - 241 235 | Event.Document_end { implicit } -> 242 236 if not implicit then begin 243 237 write t "..."; 244 238 write_newline t 245 239 end; 246 240 t.state <- Document_ended 247 247 - 248 241 | Event.Alias { anchor } -> 249 242 if t.flow_level > 0 then begin 250 243 if t.need_separator then write t ", "; 251 244 t.need_separator <- true; 252 245 write_char t '*'; 253 246 write t anchor 254 254 - end else begin 255 255 - (match t.state with 256 256 - | In_block_sequence _ -> 257 257 - write_indent t; 258 258 - write t "- *"; 259 259 - write t anchor; 260 260 - write_newline t 261 261 - | In_block_mapping_key _ -> 262 262 - write_indent t; 263 263 - write_char t '*'; 264 264 - write t anchor; 265 265 - write t ": "; 266 266 - t.state <- In_block_mapping_value t.indent 267 267 - | In_block_mapping_value indent -> 268 268 - write_char t '*'; 269 269 - write t anchor; 270 270 - write_newline t; 271 271 - t.state <- In_block_mapping_key indent 272 272 - | _ -> 273 273 - write_char t '*'; 274 274 - write t anchor; 275 275 - write_newline t) 247 247 + end 248 248 + else begin 249 249 + match t.state with 250 250 + | In_block_sequence _ -> 251 251 + write_indent t; 252 252 + write t "- *"; 253 253 + write t anchor; 254 254 + write_newline t 255 255 + | In_block_mapping_key _ -> 256 256 + write_indent t; 257 257 + write_char t '*'; 258 258 + write t anchor; 259 259 + write t ": "; 260 260 + t.state <- In_block_mapping_value t.indent 261 261 + | In_block_mapping_value indent -> 262 262 + write_char t '*'; 263 263 + write t anchor; 264 264 + write_newline t; 265 265 + t.state <- In_block_mapping_key indent 266 266 + | _ -> 267 267 + write_char t '*'; 268 268 + write t anchor; 269 269 + write_newline t 276 270 end 277 277 - 278 271 | Event.Scalar { anchor; tag; value; plain_implicit; style; _ } -> 279 272 if t.flow_level > 0 then begin 280 280 - (match t.state with 281 281 - | In_flow_mapping_key -> 282 282 - if t.need_separator then write t ", "; 283 283 - write_anchor t anchor; 284 284 - write_tag t ~implicit:plain_implicit tag; 285 285 - write_scalar t ~style value; 286 286 - write t ": "; 287 287 - t.need_separator <- false; 288 288 - t.state <- In_flow_mapping_value 289 289 - | In_flow_mapping_value -> 290 290 - if t.need_separator then begin 291 291 - (* We just finished a nested structure (array/mapping), 273 273 + match t.state with 274 274 + | In_flow_mapping_key -> 275 275 + if t.need_separator then write t ", "; 276 276 + write_anchor t anchor; 277 277 + write_tag t ~implicit:plain_implicit tag; 278 278 + write_scalar t ~style value; 279 279 + write t ": "; 280 280 + t.need_separator <- false; 281 281 + t.state <- In_flow_mapping_value 282 282 + | In_flow_mapping_value -> 283 283 + if t.need_separator then begin 284 284 + (* We just finished a nested structure (array/mapping), 292 285 so this scalar is the next key, not a value *) 293 293 - write t ", "; 294 294 - write_anchor t anchor; 295 295 - write_tag t ~implicit:plain_implicit tag; 296 296 - write_scalar t ~style value; 297 297 - write t ": "; 298 298 - t.need_separator <- false; 299 299 - t.state <- In_flow_mapping_value 300 300 - end else begin 301 301 - (* Normal value scalar *) 302 302 - write_anchor t anchor; 303 303 - write_tag t ~implicit:plain_implicit tag; 304 304 - write_scalar t ~style value; 305 305 - t.need_separator <- true; 306 306 - t.state <- In_flow_mapping_key 307 307 - end 308 308 - | _ -> 309 309 - if t.need_separator then write t ", "; 310 310 - t.need_separator <- true; 311 311 - write_anchor t anchor; 312 312 - write_tag t ~implicit:plain_implicit tag; 313 313 - write_scalar t ~style value) 314 314 - end else begin 286 286 + write t ", "; 287 287 + write_anchor t anchor; 288 288 + write_tag t ~implicit:plain_implicit tag; 289 289 + write_scalar t ~style value; 290 290 + write t ": "; 291 291 + t.need_separator <- false; 292 292 + t.state <- In_flow_mapping_value 293 293 + end 294 294 + else begin 295 295 + (* Normal value scalar *) 296 296 + write_anchor t anchor; 297 297 + write_tag t ~implicit:plain_implicit tag; 298 298 + write_scalar t ~style value; 299 299 + t.need_separator <- true; 300 300 + t.state <- In_flow_mapping_key 301 301 + end 302 302 + | _ -> 303 303 + if t.need_separator then write t ", "; 304 304 + t.need_separator <- true; 305 305 + write_anchor t anchor; 306 306 + write_tag t ~implicit:plain_implicit tag; 307 307 + write_scalar t ~style value 308 308 + end 309 309 + else begin 315 310 match t.state with 316 311 | In_block_sequence _ -> 317 312 write_indent t; ··· 347 342 write_scalar t ~style value; 348 343 write_newline t 349 344 end 350 350 - 351 345 | Event.Sequence_start { anchor; tag; implicit; style } -> 352 346 let use_flow = style = `Flow || t.flow_level > 0 in 353 347 if t.flow_level > 0 then begin 354 354 - (match t.state with 355 355 - | In_flow_mapping_key -> 356 356 - if t.need_separator then write t ", "; 357 357 - write_anchor t anchor; 358 358 - write_tag t ~implicit tag; 359 359 - write_char t '['; 360 360 - t.flow_level <- t.flow_level + 1; 361 361 - t.need_separator <- false; 362 362 - push_state t In_flow_mapping_value; (* After ] we'll be in value position but sequence handles it *) 363 363 - t.state <- In_flow_sequence 364 364 - | In_flow_mapping_value -> 365 365 - write_anchor t anchor; 366 366 - write_tag t ~implicit tag; 367 367 - write_char t '['; 368 368 - t.flow_level <- t.flow_level + 1; 369 369 - t.need_separator <- false; 370 370 - push_state t In_flow_mapping_key; 371 371 - t.state <- In_flow_sequence 372 372 - | _ -> 373 373 - if t.need_separator then write t ", "; 374 374 - write_anchor t anchor; 375 375 - write_tag t ~implicit tag; 376 376 - write_char t '['; 377 377 - t.flow_level <- t.flow_level + 1; 378 378 - t.need_separator <- false; 379 379 - push_state t In_flow_sequence) 380 380 - end else begin 348 348 + match t.state with 349 349 + | In_flow_mapping_key -> 350 350 + if t.need_separator then write t ", "; 351 351 + write_anchor t anchor; 352 352 + write_tag t ~implicit tag; 353 353 + write_char t '['; 354 354 + t.flow_level <- t.flow_level + 1; 355 355 + t.need_separator <- false; 356 356 + push_state t In_flow_mapping_value; 357 357 + (* After ] we'll be in value position but sequence handles it *) 358 358 + t.state <- In_flow_sequence 359 359 + | In_flow_mapping_value -> 360 360 + write_anchor t anchor; 361 361 + write_tag t ~implicit tag; 362 362 + write_char t '['; 363 363 + t.flow_level <- t.flow_level + 1; 364 364 + t.need_separator <- false; 365 365 + push_state t In_flow_mapping_key; 366 366 + t.state <- In_flow_sequence 367 367 + | _ -> 368 368 + if t.need_separator then write t ", "; 369 369 + write_anchor t anchor; 370 370 + write_tag t ~implicit tag; 371 371 + write_char t '['; 372 372 + t.flow_level <- t.flow_level + 1; 373 373 + t.need_separator <- false; 374 374 + push_state t In_flow_sequence 375 375 + end 376 376 + else begin 381 377 match t.state with 382 378 | In_block_sequence _ -> 383 379 write_indent t; ··· 389 385 t.flow_level <- t.flow_level + 1; 390 386 t.need_separator <- false; 391 387 push_state t In_flow_sequence 392 392 - end else begin 388 388 + end 389 389 + else begin 393 390 write_newline t; 394 391 push_state t (In_block_sequence t.indent); 395 392 t.indent <- t.indent + t.config.indent ··· 423 420 (* Save key state to return to after flow sequence *) 424 421 t.state <- In_block_mapping_key indent; 425 422 push_state t In_flow_sequence 426 426 - end else begin 423 423 + end 424 424 + else begin 427 425 write_newline t; 428 426 (* Save key state to return to after nested sequence *) 429 427 t.state <- In_block_mapping_key indent; ··· 438 436 t.flow_level <- t.flow_level + 1; 439 437 t.need_separator <- false; 440 438 push_state t In_flow_sequence 441 441 - end else begin 439 439 + end 440 440 + else begin 442 441 push_state t (In_block_sequence t.indent); 443 442 t.state <- In_block_sequence t.indent 444 443 end 445 444 end 446 446 - 447 445 | Event.Sequence_end -> 448 446 if t.flow_level > 0 then begin 449 447 write_char t ']'; ··· 451 449 t.need_separator <- true; 452 450 pop_state t; 453 451 (* Write newline if returning to block context *) 454 454 - (match t.state with 455 455 - | In_block_mapping_key _ | In_block_sequence _ -> write_newline t 456 456 - | _ -> ()) 457 457 - end else begin 452 452 + match t.state with 453 453 + | In_block_mapping_key _ | In_block_sequence _ -> write_newline t 454 454 + | _ -> () 455 455 + end 456 456 + else begin 458 457 t.indent <- t.indent - t.config.indent; 459 458 pop_state t 460 459 end 461 461 - 462 460 | Event.Mapping_start { anchor; tag; implicit; style } -> 463 461 let use_flow = style = `Flow || t.flow_level > 0 in 464 462 if t.flow_level > 0 then begin 465 465 - (match t.state with 466 466 - | In_flow_mapping_key -> 467 467 - if t.need_separator then write t ", "; 468 468 - write_anchor t anchor; 469 469 - write_tag t ~implicit tag; 470 470 - write_char t '{'; 471 471 - t.flow_level <- t.flow_level + 1; 472 472 - t.need_separator <- false; 473 473 - push_state t In_flow_mapping_value; 474 474 - t.state <- In_flow_mapping_key 475 475 - | In_flow_mapping_value -> 476 476 - write_anchor t anchor; 477 477 - write_tag t ~implicit tag; 478 478 - write_char t '{'; 479 479 - t.flow_level <- t.flow_level + 1; 480 480 - t.need_separator <- false; 481 481 - push_state t In_flow_mapping_key; 482 482 - t.state <- In_flow_mapping_key 483 483 - | _ -> 484 484 - if t.need_separator then write t ", "; 485 485 - write_anchor t anchor; 486 486 - write_tag t ~implicit tag; 487 487 - write_char t '{'; 488 488 - t.flow_level <- t.flow_level + 1; 489 489 - t.need_separator <- false; 490 490 - push_state t In_flow_mapping_key) 491 491 - end else begin 463 463 + match t.state with 464 464 + | In_flow_mapping_key -> 465 465 + if t.need_separator then write t ", "; 466 466 + write_anchor t anchor; 467 467 + write_tag t ~implicit tag; 468 468 + write_char t '{'; 469 469 + t.flow_level <- t.flow_level + 1; 470 470 + t.need_separator <- false; 471 471 + push_state t In_flow_mapping_value; 472 472 + t.state <- In_flow_mapping_key 473 473 + | In_flow_mapping_value -> 474 474 + write_anchor t anchor; 475 475 + write_tag t ~implicit tag; 476 476 + write_char t '{'; 477 477 + t.flow_level <- t.flow_level + 1; 478 478 + t.need_separator <- false; 479 479 + push_state t In_flow_mapping_key; 480 480 + t.state <- In_flow_mapping_key 481 481 + | _ -> 482 482 + if t.need_separator then write t ", "; 483 483 + write_anchor t anchor; 484 484 + write_tag t ~implicit tag; 485 485 + write_char t '{'; 486 486 + t.flow_level <- t.flow_level + 1; 487 487 + t.need_separator <- false; 488 488 + push_state t In_flow_mapping_key 489 489 + end 490 490 + else begin 492 491 match t.state with 493 492 | In_block_sequence _ -> 494 493 write_indent t; ··· 500 499 t.flow_level <- t.flow_level + 1; 501 500 t.need_separator <- false; 502 501 push_state t In_flow_mapping_key 503 503 - end else begin 502 502 + end 503 503 + else begin 504 504 (* Don't write newline - first key goes on same line as "- " *) 505 505 push_state t (In_block_sequence t.indent); 506 506 t.indent <- t.indent + t.config.indent; ··· 535 535 (* Save key state to return to after flow mapping *) 536 536 t.state <- In_block_mapping_key indent; 537 537 push_state t In_flow_mapping_key 538 538 - end else begin 538 538 + end 539 539 + else begin 539 540 write_newline t; 540 541 (* Save key state to return to after nested mapping *) 541 542 t.state <- In_block_mapping_key indent; ··· 550 551 t.flow_level <- t.flow_level + 1; 551 552 t.need_separator <- false; 552 553 push_state t In_flow_mapping_key 553 553 - end else begin 554 554 + end 555 555 + else begin 554 556 push_state t (In_block_mapping_key t.indent); 555 557 t.state <- In_block_mapping_key t.indent 556 558 end 557 559 end 558 558 - 559 560 | Event.Mapping_end -> 560 561 if t.flow_level > 0 then begin 561 562 write_char t '}'; ··· 563 564 t.need_separator <- true; 564 565 pop_state t; 565 566 (* Write newline if returning to block context *) 566 566 - (match t.state with 567 567 - | In_block_mapping_key _ | In_block_sequence _ -> write_newline t 568 568 - | _ -> ()) 569 569 - end else begin 567 567 + match t.state with 568 568 + | In_block_mapping_key _ | In_block_sequence _ -> write_newline t 569 569 + | _ -> () 570 570 + end 571 571 + else begin 570 572 t.indent <- t.indent - t.config.indent; 571 573 pop_state t 572 574 end 573 575 574 574 - (** Access to the underlying buffer for advanced use. 575 575 - Returns None if emitter is writing to a Writer instead of Buffer. *) 576 576 + (** Access to the underlying buffer for advanced use. Returns None if emitter is 577 577 + writing to a Writer instead of Buffer. *) 576 578 let buffer t = 577 577 - match t.sink with 578 578 - | Buffer_sink buf -> Some buf 579 579 - | Writer_sink _ -> None 579 579 + match t.sink with Buffer_sink buf -> Some buf | Writer_sink _ -> None 580 580 581 581 (** Get config *) 582 582 let config t = t.config 583 583 584 584 (** Check if emitter is writing to a Writer *) 585 585 let is_streaming t = 586 586 - match t.sink with 587 587 - | Writer_sink _ -> true 588 588 - | Buffer_sink _ -> false 586 586 + match t.sink with Writer_sink _ -> true | Buffer_sink _ -> false 589 587 590 588 (** Flush the writer sink (no-op for buffer sink) *) 591 589 let flush t =

+12 -20

lib/encoding.ml

··· 5 5 6 6 (** Character encoding detection and handling *) 7 7 8 8 - type t = [ 9 9 - | `Utf8 10 10 - | `Utf16be 11 11 - | `Utf16le 12 12 - | `Utf32be 13 13 - | `Utf32le 14 14 - ] 8 8 + type t = [ `Utf8 | `Utf16be | `Utf16le | `Utf32be | `Utf32le ] 15 9 16 10 let to_string = function 17 11 | `Utf8 -> "UTF-8" ··· 20 14 | `Utf32be -> "UTF-32BE" 21 15 | `Utf32le -> "UTF-32LE" 22 16 23 23 - let pp fmt t = 24 24 - Format.pp_print_string fmt (to_string t) 17 17 + let pp fmt t = Format.pp_print_string fmt (to_string t) 25 18 26 26 - (** Detect encoding from BOM or first bytes. 27 27 - Returns (encoding, bom_length) *) 19 19 + (** Detect encoding from BOM or first bytes. Returns (encoding, bom_length) *) 28 20 let detect s = 29 21 let len = String.length s in 30 22 if len = 0 then (`Utf8, 0) ··· 35 27 let b3 = if len > 3 then Char.code s.[3] else 0 in 36 28 match (b0, b1, b2, b3) with 37 29 (* BOM patterns *) 38 38 - | (0xEF, 0xBB, 0xBF, _) -> (`Utf8, 3) 39 39 - | (0xFE, 0xFF, _, _) -> (`Utf16be, 2) 40 40 - | (0xFF, 0xFE, 0x00, 0x00) -> (`Utf32le, 4) 41 41 - | (0xFF, 0xFE, _, _) -> (`Utf16le, 2) 42 42 - | (0x00, 0x00, 0xFE, 0xFF) -> (`Utf32be, 4) 30 30 + | 0xEF, 0xBB, 0xBF, _ -> (`Utf8, 3) 31 31 + | 0xFE, 0xFF, _, _ -> (`Utf16be, 2) 32 32 + | 0xFF, 0xFE, 0x00, 0x00 -> (`Utf32le, 4) 33 33 + | 0xFF, 0xFE, _, _ -> (`Utf16le, 2) 34 34 + | 0x00, 0x00, 0xFE, 0xFF -> (`Utf32be, 4) 43 35 (* Content pattern detection (no BOM) *) 44 44 - | (0x00, 0x00, 0x00, b3) when b3 <> 0x00 -> (`Utf32be, 0) 45 45 - | (b0, 0x00, 0x00, 0x00) when b0 <> 0x00 -> (`Utf32le, 0) 46 46 - | (0x00, b1, _, _) when b1 <> 0x00 -> (`Utf16be, 0) 47 47 - | (b0, 0x00, _, _) when b0 <> 0x00 -> (`Utf16le, 0) 36 36 + | 0x00, 0x00, 0x00, b3 when b3 <> 0x00 -> (`Utf32be, 0) 37 37 + | b0, 0x00, 0x00, 0x00 when b0 <> 0x00 -> (`Utf32le, 0) 38 38 + | 0x00, b1, _, _ when b1 <> 0x00 -> (`Utf16be, 0) 39 39 + | b0, 0x00, _, _ when b0 <> 0x00 -> (`Utf16le, 0) 48 40 | _ -> (`Utf8, 0) 49 41 50 42 let equal a b = a = b

+135 -105

lib/error.ml

··· 7 7 8 8 Comprehensive error reporting for YAML parsing and emission. 9 9 10 10 - This module provides detailed error types that correspond to various 11 11 - failure modes in YAML processing, as specified in the 10 10 + This module provides detailed error types that correspond to various failure 11 11 + modes in YAML processing, as specified in the 12 12 {{:https://yaml.org/spec/1.2.2/}YAML 1.2.2 specification}. 13 13 14 14 Each error includes: ··· 17 17 - A context stack showing where the error occurred 18 18 - Optional source text for error display 19 19 20 20 - See also {{:https://yaml.org/spec/1.2.2/#31-processes}Section 3.1 (Processes)} 21 21 - for background on the YAML processing model. *) 20 20 + See also 21 21 + {{:https://yaml.org/spec/1.2.2/#31-processes}Section 3.1 (Processes)} for 22 22 + background on the YAML processing model. *) 22 23 23 24 (** {2 Error Classification} 24 25 ··· 31 32 (* Scanner errors - see {{:https://yaml.org/spec/1.2.2/#51-character-set}Section 5.1} *) 32 33 | Unexpected_character of char 33 34 (** Invalid character in input. See 34 34 - {{:https://yaml.org/spec/1.2.2/#51-character-set}Section 5.1 (Character Set)}. *) 35 35 - | Unexpected_eof 36 36 - (** Premature end of input. *) 35 35 + {{:https://yaml.org/spec/1.2.2/#51-character-set}Section 5.1 36 36 + (Character Set)}. *) 37 37 + | Unexpected_eof (** Premature end of input. *) 37 38 | Invalid_escape_sequence of string 38 39 (** Invalid escape in double-quoted string. See 39 39 - {{:https://yaml.org/spec/1.2.2/#57-escaped-characters}Section 5.7 (Escaped Characters)}. *) 40 40 + {{:https://yaml.org/spec/1.2.2/#57-escaped-characters}Section 5.7 41 41 + (Escaped Characters)}. *) 40 42 | Invalid_unicode_escape of string 41 43 (** Invalid Unicode escape sequence (\uXXXX or \UXXXXXXXX). *) 42 44 | Invalid_hex_escape of string 43 45 (** Invalid hexadecimal escape sequence (\xXX). *) 44 46 | Invalid_tag of string 45 47 (** Malformed tag syntax. See 46 46 - {{:https://yaml.org/spec/1.2.2/#681-node-tags}Section 6.8.1 (Node Tags)}. *) 48 48 + {{:https://yaml.org/spec/1.2.2/#681-node-tags}Section 6.8.1 (Node 49 49 + Tags)}. *) 47 50 | Invalid_anchor of string 48 51 (** Malformed anchor name. See 49 49 - {{:https://yaml.org/spec/1.2.2/#3222-anchors-and-aliases}Section 3.2.2.2 (Anchors and Aliases)}. *) 52 52 + {{:https://yaml.org/spec/1.2.2/#3222-anchors-and-aliases}Section 53 53 + 3.2.2.2 (Anchors and Aliases)}. *) 50 54 | Invalid_alias of string 51 55 (** Malformed alias reference. See 52 52 - {{:https://yaml.org/spec/1.2.2/#3222-anchors-and-aliases}Section 3.2.2.2 (Anchors and Aliases)}. *) 56 56 + {{:https://yaml.org/spec/1.2.2/#3222-anchors-and-aliases}Section 57 57 + 3.2.2.2 (Anchors and Aliases)}. *) 53 58 | Invalid_comment 54 59 (** Comment not properly separated from content. See 55 55 - {{:https://yaml.org/spec/1.2.2/#62-comments}Section 6.2 (Comments)}. *) 60 60 + {{:https://yaml.org/spec/1.2.2/#62-comments}Section 6.2 (Comments)}. 61 61 + *) 56 62 | Unclosed_single_quote 57 63 (** Unterminated single-quoted scalar. See 58 58 - {{:https://yaml.org/spec/1.2.2/#72-single-quoted-style}Section 7.2 (Single-Quoted Style)}. *) 64 64 + {{:https://yaml.org/spec/1.2.2/#72-single-quoted-style}Section 7.2 65 65 + (Single-Quoted Style)}. *) 59 66 | Unclosed_double_quote 60 67 (** Unterminated double-quoted scalar. See 61 61 - {{:https://yaml.org/spec/1.2.2/#73-double-quoted-style}Section 7.3 (Double-Quoted Style)}. *) 68 68 + {{:https://yaml.org/spec/1.2.2/#73-double-quoted-style}Section 7.3 69 69 + (Double-Quoted Style)}. *) 62 70 | Unclosed_flow_sequence 63 71 (** Missing closing bracket \] for flow sequence. See 64 64 - {{:https://yaml.org/spec/1.2.2/#742-flow-sequences}Section 7.4.2 (Flow Sequences)}. *) 72 72 + {{:https://yaml.org/spec/1.2.2/#742-flow-sequences}Section 7.4.2 (Flow 73 73 + Sequences)}. *) 65 74 | Unclosed_flow_mapping 66 75 (** Missing closing brace \} for flow mapping. See 67 67 - {{:https://yaml.org/spec/1.2.2/#743-flow-mappings}Section 7.4.3 (Flow Mappings)}. *) 76 76 + {{:https://yaml.org/spec/1.2.2/#743-flow-mappings}Section 7.4.3 (Flow 77 77 + Mappings)}. *) 68 78 | Invalid_indentation of int * int 69 79 (** Incorrect indentation level (expected, got). See 70 70 - {{:https://yaml.org/spec/1.2.2/#61-indentation-spaces}Section 6.1 (Indentation Spaces)}. *) 80 80 + {{:https://yaml.org/spec/1.2.2/#61-indentation-spaces}Section 6.1 81 81 + (Indentation Spaces)}. *) 71 82 | Invalid_flow_indentation 72 83 (** Content in flow collection must be indented. See 73 73 - {{:https://yaml.org/spec/1.2.2/#74-flow-styles}Section 7.4 (Flow Styles)}. *) 84 84 + {{:https://yaml.org/spec/1.2.2/#74-flow-styles}Section 7.4 (Flow 85 85 + Styles)}. *) 74 86 | Tab_in_indentation 75 87 (** Tab character used for indentation (only spaces allowed). See 76 76 - {{:https://yaml.org/spec/1.2.2/#61-indentation-spaces}Section 6.1 (Indentation Spaces)}. *) 88 88 + {{:https://yaml.org/spec/1.2.2/#61-indentation-spaces}Section 6.1 89 89 + (Indentation Spaces)}. *) 77 90 | Invalid_block_scalar_header of string 78 91 (** Malformed block scalar header (| or >). See 79 79 - {{:https://yaml.org/spec/1.2.2/#81-block-scalar-styles}Section 8.1 (Block Scalar Styles)}. *) 92 92 + {{:https://yaml.org/spec/1.2.2/#81-block-scalar-styles}Section 8.1 93 93 + (Block Scalar Styles)}. *) 80 94 | Invalid_quoted_scalar_indentation of string 81 95 (** Incorrect indentation in quoted scalar. *) 82 96 | Invalid_directive of string 83 97 (** Malformed directive. See 84 84 - {{:https://yaml.org/spec/1.2.2/#68-directives}Section 6.8 (Directives)}. *) 98 98 + {{:https://yaml.org/spec/1.2.2/#68-directives}Section 6.8 99 99 + (Directives)}. *) 85 100 | Invalid_yaml_version of string 86 101 (** Unsupported YAML version in %YAML directive. See 87 87 - {{:https://yaml.org/spec/1.2.2/#681-yaml-directives}Section 6.8.1 (YAML Directives)}. *) 102 102 + {{:https://yaml.org/spec/1.2.2/#681-yaml-directives}Section 6.8.1 103 103 + (YAML Directives)}. *) 88 104 | Invalid_tag_directive of string 89 105 (** Malformed %TAG directive. See 90 90 - {{:https://yaml.org/spec/1.2.2/#682-tag-directives}Section 6.8.2 (TAG Directives)}. *) 106 106 + {{:https://yaml.org/spec/1.2.2/#682-tag-directives}Section 6.8.2 (TAG 107 107 + Directives)}. *) 91 108 | Reserved_directive of string 92 109 (** Reserved directive name. See 93 93 - {{:https://yaml.org/spec/1.2.2/#683-reserved-directives}Section 6.8.3 (Reserved Directives)}. *) 110 110 + {{:https://yaml.org/spec/1.2.2/#683-reserved-directives}Section 6.8.3 111 111 + (Reserved Directives)}. *) 94 112 | Illegal_flow_key_line 95 113 (** Key and colon must be on same line in flow context. See 96 96 - {{:https://yaml.org/spec/1.2.2/#743-flow-mappings}Section 7.4.3 (Flow Mappings)}. *) 114 114 + {{:https://yaml.org/spec/1.2.2/#743-flow-mappings}Section 7.4.3 (Flow 115 115 + Mappings)}. *) 97 116 | Block_sequence_disallowed 98 117 (** Block sequence entries not allowed in this context. See 99 99 - {{:https://yaml.org/spec/1.2.2/#82-block-collection-styles}Section 8.2 (Block Collection Styles)}. *) 100 100 - 118 118 + {{:https://yaml.org/spec/1.2.2/#82-block-collection-styles}Section 8.2 119 119 + (Block Collection Styles)}. *) 101 120 (* Parser errors - see {{:https://yaml.org/spec/1.2.2/#3-processing-yaml-information}Section 3 (Processing)} *) 102 102 - | Unexpected_token of string 103 103 - (** Unexpected token in event stream. *) 121 121 + | Unexpected_token of string (** Unexpected token in event stream. *) 104 122 | Expected_document_start 105 123 (** Expected document start marker (---). See 106 106 - {{:https://yaml.org/spec/1.2.2/#912-document-markers}Section 9.1.2 (Document Markers)}. *) 124 124 + {{:https://yaml.org/spec/1.2.2/#912-document-markers}Section 9.1.2 125 125 + (Document Markers)}. *) 107 126 | Expected_document_end 108 127 (** Expected document end marker (...). See 109 109 - {{:https://yaml.org/spec/1.2.2/#912-document-markers}Section 9.1.2 (Document Markers)}. *) 128 128 + {{:https://yaml.org/spec/1.2.2/#912-document-markers}Section 9.1.2 129 129 + (Document Markers)}. *) 110 130 | Expected_block_entry 111 131 (** Expected block sequence entry marker (-). See 112 112 - {{:https://yaml.org/spec/1.2.2/#821-block-sequences}Section 8.2.1 (Block Sequences)}. *) 132 132 + {{:https://yaml.org/spec/1.2.2/#821-block-sequences}Section 8.2.1 133 133 + (Block Sequences)}. *) 113 134 | Expected_key 114 135 (** Expected mapping key. See 115 115 - {{:https://yaml.org/spec/1.2.2/#822-block-mappings}Section 8.2.2 (Block Mappings)}. *) 136 136 + {{:https://yaml.org/spec/1.2.2/#822-block-mappings}Section 8.2.2 137 137 + (Block Mappings)}. *) 116 138 | Expected_value 117 139 (** Expected mapping value after colon. See 118 118 - {{:https://yaml.org/spec/1.2.2/#822-block-mappings}Section 8.2.2 (Block Mappings)}. *) 119 119 - | Expected_node 120 120 - (** Expected a YAML node. *) 121 121 - | Expected_scalar 122 122 - (** Expected a scalar value. *) 140 140 + {{:https://yaml.org/spec/1.2.2/#822-block-mappings}Section 8.2.2 141 141 + (Block Mappings)}. *) 142 142 + | Expected_node (** Expected a YAML node. *) 143 143 + | Expected_scalar (** Expected a scalar value. *) 123 144 | Expected_sequence_end 124 145 (** Expected closing bracket \] for flow sequence. See 125 125 - {{:https://yaml.org/spec/1.2.2/#742-flow-sequences}Section 7.4.2 (Flow Sequences)}. *) 146 146 + {{:https://yaml.org/spec/1.2.2/#742-flow-sequences}Section 7.4.2 (Flow 147 147 + Sequences)}. *) 126 148 | Expected_mapping_end 127 149 (** Expected closing brace \} for flow mapping. See 128 128 - {{:https://yaml.org/spec/1.2.2/#743-flow-mappings}Section 7.4.3 (Flow Mappings)}. *) 150 150 + {{:https://yaml.org/spec/1.2.2/#743-flow-mappings}Section 7.4.3 (Flow 151 151 + Mappings)}. *) 129 152 | Duplicate_anchor of string 130 153 (** Anchor name defined multiple times. See 131 131 - {{:https://yaml.org/spec/1.2.2/#3222-anchors-and-aliases}Section 3.2.2.2 (Anchors and Aliases)}. *) 154 154 + {{:https://yaml.org/spec/1.2.2/#3222-anchors-and-aliases}Section 155 155 + 3.2.2.2 (Anchors and Aliases)}. *) 132 156 | Undefined_alias of string 133 157 (** Alias references non-existent anchor. See 134 134 - {{:https://yaml.org/spec/1.2.2/#3222-anchors-and-aliases}Section 3.2.2.2 (Anchors and Aliases)}. *) 158 158 + {{:https://yaml.org/spec/1.2.2/#3222-anchors-and-aliases}Section 159 159 + 3.2.2.2 (Anchors and Aliases)}. *) 135 160 | Alias_cycle of string 136 161 (** Circular reference in alias chain. See 137 137 - {{:https://yaml.org/spec/1.2.2/#3222-anchors-and-aliases}Section 3.2.2.2 (Anchors and Aliases)}. *) 162 162 + {{:https://yaml.org/spec/1.2.2/#3222-anchors-and-aliases}Section 163 163 + 3.2.2.2 (Anchors and Aliases)}. *) 138 164 | Multiple_documents 139 165 (** Multiple documents found when single document expected. See 140 140 - {{:https://yaml.org/spec/1.2.2/#912-document-markers}Section 9.1.2 (Document Markers)}. *) 166 166 + {{:https://yaml.org/spec/1.2.2/#912-document-markers}Section 9.1.2 167 167 + (Document Markers)}. *) 141 168 | Mapping_key_too_long 142 169 (** Mapping key exceeds maximum length (1024 characters). *) 143 143 - 144 170 (* Loader errors - see {{:https://yaml.org/spec/1.2.2/#31-processes}Section 3.1 (Processes)} *) 145 171 | Invalid_scalar_conversion of string * string 146 146 - (** Cannot convert scalar value to target type (value, target type). 147 147 - See {{:https://yaml.org/spec/1.2.2/#103-core-schema}Section 10.3 (Core Schema)}. *) 172 172 + (** Cannot convert scalar value to target type (value, target type). See 173 173 + {{:https://yaml.org/spec/1.2.2/#103-core-schema}Section 10.3 (Core 174 174 + Schema)}. *) 148 175 | Type_mismatch of string * string 149 176 (** Value has wrong type for operation (expected, got). *) 150 177 | Unresolved_alias of string 151 151 - (** Alias encountered during conversion but not resolved. 152 152 - See {{:https://yaml.org/spec/1.2.2/#3222-anchors-and-aliases}Section 3.2.2.2 (Anchors and Aliases)}. *) 153 153 - | Key_not_found of string 154 154 - (** Mapping key not found. *) 178 178 + (** Alias encountered during conversion but not resolved. See 179 179 + {{:https://yaml.org/spec/1.2.2/#3222-anchors-and-aliases}Section 180 180 + 3.2.2.2 (Anchors and Aliases)}. *) 181 181 + | Key_not_found of string (** Mapping key not found. *) 155 182 | Alias_expansion_node_limit of int 156 156 - (** Alias expansion exceeded maximum node count (protection against billion laughs attack). 157 157 - See {{:https://yaml.org/spec/1.2.2/#321-processes}Section 3.2.1 (Processes)}. 183 183 + (** Alias expansion exceeded maximum node count (protection against 184 184 + billion laughs attack). See 185 185 + {{:https://yaml.org/spec/1.2.2/#321-processes}Section 3.2.1 186 186 + (Processes)}. 158 187 159 159 - The "billion laughs attack" (also known as an XML bomb) is a denial-of-service 160 160 - attack where a small YAML document expands to enormous size through recursive 161 161 - alias expansion. This limit prevents such attacks. *) 188 188 + The "billion laughs attack" (also known as an XML bomb) is a 189 189 + denial-of-service attack where a small YAML document expands to 190 190 + enormous size through recursive alias expansion. This limit prevents 191 191 + such attacks. *) 162 192 | Alias_expansion_depth_limit of int 163 163 - (** Alias expansion exceeded maximum nesting depth (protection against deeply nested aliases). 164 164 - See {{:https://yaml.org/spec/1.2.2/#321-processes}Section 3.2.1 (Processes)}. *) 165 165 - 193 193 + (** Alias expansion exceeded maximum nesting depth (protection against 194 194 + deeply nested aliases). See 195 195 + {{:https://yaml.org/spec/1.2.2/#321-processes}Section 3.2.1 196 196 + (Processes)}. *) 166 197 (* Emitter errors *) 167 198 | Invalid_encoding of string 168 199 (** Invalid character encoding specified. See 169 169 - {{:https://yaml.org/spec/1.2.2/#51-character-set}Section 5.1 (Character Set)}. *) 200 200 + {{:https://yaml.org/spec/1.2.2/#51-character-set}Section 5.1 201 201 + (Character Set)}. *) 170 202 | Scalar_contains_invalid_chars of string 171 203 (** Scalar contains characters invalid for chosen style. *) 172 172 - | Anchor_not_set 173 173 - (** Attempted to emit alias before anchor was defined. *) 204 204 + | Anchor_not_set (** Attempted to emit alias before anchor was defined. *) 174 205 | Invalid_state of string 175 206 (** Emitter in invalid state for requested operation. *) 176 176 - 177 207 (* Generic *) 178 178 - | Custom of string 179 179 - (** Custom error message. *) 208 208 + | Custom of string (** Custom error message. *) 180 209 181 181 - (** {2 Error Value} 182 182 - 183 183 - Full error information including classification, location, and context. *) 184 210 type t = { 185 185 - kind : kind; 186 186 - (** The specific error classification. *) 211 211 + kind : kind; (** The specific error classification. *) 187 212 span : Span.t option; 188 213 (** Source location where the error occurred (if available). *) 189 214 context : string list; ··· 191 216 source : string option; 192 217 (** Source text for displaying the error in context. *) 193 218 } 219 219 + (** {2 Error Value} 194 220 221 221 + Full error information including classification, location, and context. *) 222 222 + 223 223 + exception Yamlrw_error of t 195 224 (** {2 Exception} 196 225 197 226 The main exception type raised by all yamlrw operations. 198 227 199 199 - All parsing, loading, and emitting errors are reported by raising 200 200 - this exception with detailed error information. *) 201 201 - exception Yamlrw_error of t 228 228 + All parsing, loading, and emitting errors are reported by raising this 229 229 + exception with detailed error information. *) 202 230 203 231 let () = 204 232 Printexc.register_printer (function 205 233 | Yamlrw_error e -> 206 206 - let loc = match e.span with 234 234 + let loc = 235 235 + match e.span with 207 236 | None -> "" 208 237 | Some span -> " at " ^ Span.to_string span 209 238 in 210 210 - Some (Printf.sprintf "Yamlrw_error: %s%s" 211 211 - (match e.kind with Custom s -> s | _ -> "error") loc) 239 239 + Some 240 240 + (Printf.sprintf "Yamlrw_error: %s%s" 241 241 + (match e.kind with Custom s -> s | _ -> "error") 242 242 + loc) 212 243 | _ -> None) 213 244 214 245 (** {2 Error Construction} *) ··· 219 250 @param context Context stack (defaults to empty) 220 251 @param source Source text 221 252 @param kind Error classification *) 222 222 - let make ?span ?(context=[]) ?source kind = 223 223 - { kind; span; context; source } 253 253 + let make ?span ?(context = []) ?source kind = { kind; span; context; source } 224 254 225 255 (** [raise ?span ?context ?source kind] constructs and raises an error. 226 256 ··· 248 278 @param span Source span 249 279 @param kind Error classification 250 280 @raise Yamlrw_error *) 251 251 - let raise_span span kind = 252 252 - raise ~span kind 281 281 + let raise_span span kind = raise ~span kind 253 282 254 254 - (** [with_context ctx f] executes [f ()] and adds [ctx] to any raised error's context. 283 283 + (** [with_context ctx f] executes [f ()] and adds [ctx] to any raised error's 284 284 + context. 255 285 256 286 This is useful for tracking the processing path through nested structures. 257 287 258 288 @param ctx Context description (e.g., "parsing mapping key") 259 289 @param f Function to execute *) 260 290 let with_context ctx f = 261 261 - try f () with 262 262 - | Yamlrw_error e -> 263 263 - Stdlib.raise (Yamlrw_error { e with context = ctx :: e.context }) 291 291 + try f () 292 292 + with Yamlrw_error e -> 293 293 + Stdlib.raise (Yamlrw_error { e with context = ctx :: e.context }) 264 294 265 295 (** {2 Error Formatting} *) 266 296 ··· 274 304 | Invalid_tag s -> Printf.sprintf "invalid tag: %s" s 275 305 | Invalid_anchor s -> Printf.sprintf "invalid anchor: %s" s 276 306 | Invalid_alias s -> Printf.sprintf "invalid alias: %s" s 277 277 - | Invalid_comment -> "comments must be separated from other tokens by whitespace" 307 307 + | Invalid_comment -> 308 308 + "comments must be separated from other tokens by whitespace" 278 309 | Unclosed_single_quote -> "unclosed single quote" 279 310 | Unclosed_double_quote -> "unclosed double quote" 280 311 | Unclosed_flow_sequence -> "unclosed flow sequence '['" ··· 285 316 | Tab_in_indentation -> "tab character in indentation" 286 317 | Invalid_block_scalar_header s -> 287 318 Printf.sprintf "invalid block scalar header: %s" s 288 288 - | Invalid_quoted_scalar_indentation s -> 289 289 - Printf.sprintf "%s" s 319 319 + | Invalid_quoted_scalar_indentation s -> Printf.sprintf "%s" s 290 320 | Invalid_directive s -> Printf.sprintf "invalid directive: %s" s 291 321 | Invalid_yaml_version s -> Printf.sprintf "invalid YAML version: %s" s 292 322 | Invalid_tag_directive s -> Printf.sprintf "invalid TAG directive: %s" s 293 323 | Reserved_directive s -> Printf.sprintf "reserved directive: %s" s 294 294 - | Illegal_flow_key_line -> "key and ':' must be on the same line in flow context" 295 295 - | Block_sequence_disallowed -> "block sequence entries are not allowed in this context" 324 324 + | Illegal_flow_key_line -> 325 325 + "key and ':' must be on the same line in flow context" 326 326 + | Block_sequence_disallowed -> 327 327 + "block sequence entries are not allowed in this context" 296 328 | Unexpected_token s -> Printf.sprintf "unexpected token: %s" s 297 329 | Expected_document_start -> "expected document start '---'" 298 330 | Expected_document_end -> "expected document end '...'" ··· 329 361 330 362 Includes error kind, source location (if available), and context stack. *) 331 363 let to_string t = 332 332 - let loc = match t.span with 333 333 - | None -> "" 334 334 - | Some span -> " at " ^ Span.to_string span 364 364 + let loc = 365 365 + match t.span with None -> "" | Some span -> " at " ^ Span.to_string span 335 366 in 336 336 - let ctx = match t.context with 367 367 + let ctx = 368 368 + match t.context with 337 369 | [] -> "" 338 370 | ctxs -> " (in " ^ String.concat " > " (List.rev ctxs) ^ ")" 339 371 in 340 372 kind_to_string t.kind ^ loc ^ ctx 341 373 342 374 (** [pp fmt t] pretty-prints an error to a formatter. *) 343 343 - let pp fmt t = 344 344 - Format.fprintf fmt "Yamlrw error: %s" (to_string t) 375 375 + let pp fmt t = Format.fprintf fmt "Yamlrw error: %s" (to_string t) 345 376 346 377 (** [pp_with_source ~source fmt t] pretty-prints an error with source context. 347 378 348 348 - Shows the error message followed by the relevant source line with 349 349 - a caret (^) pointing to the error location. 379 379 + Shows the error message followed by the relevant source line with a caret 380 380 + (^) pointing to the error location. 350 381 351 382 @param source The source text 352 383 @param fmt Output formatter 353 384 @param t The error to display *) 354 385 let pp_with_source ~source fmt t = 355 355 - let extract_line source line_num = 356 356 - let lines = String.split_on_char '\n' source in 357 357 - if line_num >= 1 && line_num <= List.length lines then 358 358 - Some (List.nth lines (line_num - 1)) 359 359 - else 360 360 - None 386 386 + let extract_line source line_num = 387 387 + let lines = String.split_on_char '\n' source in 388 388 + if line_num >= 1 && line_num <= List.length lines then 389 389 + Some (List.nth lines (line_num - 1)) 390 390 + else None 361 391 in 362 392 363 393 pp fmt t; 364 394 match t.span with 365 395 | None -> () 366 366 - | Some span -> 396 396 + | Some span -> ( 367 397 match extract_line source span.start.line with 368 398 | None -> () 369 399 | Some line -> 370 400 Format.fprintf fmt "\n %d | %s\n" span.start.line line; 371 401 let padding = String.make (span.start.column - 1) ' ' in 372 372 - Format.fprintf fmt " | %s^" padding 402 402 + Format.fprintf fmt " | %s^" padding)

+10 -18

lib/event.ml

··· 8 8 type t = 9 9 | Stream_start of { encoding : Encoding.t } 10 10 | Stream_end 11 11 - | Document_start of { 12 12 - version : (int * int) option; 13 13 - implicit : bool; 14 14 - } 11 11 + | Document_start of { version : (int * int) option; implicit : bool } 15 12 | Document_end of { implicit : bool } 16 13 | Alias of { anchor : string } 17 14 | Scalar of { ··· 37 34 } 38 35 | Mapping_end 39 36 40 40 - type spanned = { 41 41 - event : t; 42 42 - span : Span.t; 43 43 - } 37 37 + type spanned = { event : t; span : Span.t } 44 38 45 39 let pp_opt_str = Option.value ~default:"none" 46 40 47 41 let pp fmt = function 48 42 | Stream_start { encoding } -> 49 43 Format.fprintf fmt "stream-start(%a)" Encoding.pp encoding 50 50 - | Stream_end -> 51 51 - Format.fprintf fmt "stream-end" 44 44 + | Stream_end -> Format.fprintf fmt "stream-end" 52 45 | Document_start { version; implicit } -> 53 53 - let version_str = match version with 46 46 + let version_str = 47 47 + match version with 54 48 | None -> "none" 55 49 | Some (maj, min) -> Printf.sprintf "%d.%d" maj min 56 50 in 57 57 - Format.fprintf fmt "document-start(version=%s, implicit=%b)" version_str implicit 51 51 + Format.fprintf fmt "document-start(version=%s, implicit=%b)" version_str 52 52 + implicit 58 53 | Document_end { implicit } -> 59 54 Format.fprintf fmt "document-end(implicit=%b)" implicit 60 60 - | Alias { anchor } -> 61 61 - Format.fprintf fmt "alias(%s)" anchor 55 55 + | Alias { anchor } -> Format.fprintf fmt "alias(%s)" anchor 62 56 | Scalar { anchor; tag; value; style; _ } -> 63 57 Format.fprintf fmt "scalar(anchor=%s, tag=%s, style=%a, value=%S)" 64 58 (pp_opt_str anchor) (pp_opt_str tag) Scalar_style.pp style value 65 59 | Sequence_start { anchor; tag; implicit; style } -> 66 60 Format.fprintf fmt "sequence-start(anchor=%s, tag=%s, implicit=%b, style=%a)" 67 61 (pp_opt_str anchor) (pp_opt_str tag) implicit Layout_style.pp style 68 68 - | Sequence_end -> 69 69 - Format.fprintf fmt "sequence-end" 62 62 + | Sequence_end -> Format.fprintf fmt "sequence-end" 70 63 | Mapping_start { anchor; tag; implicit; style } -> 71 64 Format.fprintf fmt "mapping-start(anchor=%s, tag=%s, implicit=%b, style=%a)" 72 65 (pp_opt_str anchor) (pp_opt_str tag) implicit Layout_style.pp style 73 73 - | Mapping_end -> 74 74 - Format.fprintf fmt "mapping-end" 66 66 + | Mapping_end -> Format.fprintf fmt "mapping-end" 75 67 76 68 let pp_spanned fmt { event; span } = 77 69 Format.fprintf fmt "%a at %a" pp event Span.pp span

+50 -71

lib/input.ml

··· 5 5 6 6 (** Character input source with lookahead, based on Bytes.Reader.t 7 7 8 8 - This module wraps a bytesrw [Bytes.Reader.t] to provide character-by-character 9 9 - access with lookahead for the YAML scanner. Uses bytesrw's sniff and push_back 10 10 - for efficient lookahead without excessive copying. 8 8 + This module wraps a bytesrw [Bytes.Reader.t] to provide 9 9 + character-by-character access with lookahead for the YAML scanner. Uses 10 10 + bytesrw's sniff and push_back for efficient lookahead without excessive 11 11 + copying. 11 12 12 13 The same input type works with any reader source: strings, files, channels, 13 14 or streaming sources like Eio. *) 14 15 15 16 open Bytesrw 16 17 17 17 - (** Re-export character classification *) 18 18 include Char_class 19 19 + (** Re-export character classification *) 19 20 20 21 type t = { 21 22 reader : Bytes.Reader.t; 22 22 - mutable current_slice : Bytes.Slice.t option; (** Current slice being consumed *) 23 23 - mutable slice_pos : int; (** Position within current slice *) 24 24 - mutable position : Position.t; (** Line/column tracking *) 23 23 + mutable current_slice : Bytes.Slice.t option; 24 24 + (** Current slice being consumed *) 25 25 + mutable slice_pos : int; (** Position within current slice *) 26 26 + mutable position : Position.t; (** Line/column tracking *) 25 27 } 26 28 27 29 (** Ensure we have a current slice. Returns true if data available. *) ··· 33 35 if Bytes.Slice.is_eod slice then begin 34 36 t.current_slice <- None; 35 37 false 36 36 - end else begin 38 38 + end 39 39 + else begin 37 40 t.current_slice <- Some slice; 38 41 t.slice_pos <- 0; 39 42 true ··· 50 53 51 54 (** Create input from a Bytes.Reader.t *) 52 55 let of_reader ?(initial_position = Position.initial) reader = 53 53 - let t = { 54 54 - reader; 55 55 - current_slice = None; 56 56 - slice_pos = 0; 57 57 - position = initial_position; 58 58 - } in 56 56 + let t = 57 57 + { reader; current_slice = None; slice_pos = 0; position = initial_position } 58 58 + in 59 59 (* Use sniff for BOM detection - this is exactly what sniff is for *) 60 60 let sample = Bytes.Reader.sniff 4 t.reader in 61 61 let bom_len = 62 62 - if String.length sample >= 3 && 63 63 - sample.[0] = '\xEF' && 64 64 - sample.[1] = '\xBB' && 65 65 - sample.[2] = '\xBF' 66 66 - then 3 (* UTF-8 BOM *) 62 62 + if 63 63 + String.length sample >= 3 64 64 + && sample.[0] = '\xEF' 65 65 + && sample.[1] = '\xBB' 66 66 + && sample.[2] = '\xBF' 67 67 + then 3 (* UTF-8 BOM *) 67 68 else 0 68 69 in 69 70 (* Skip BOM if present *) 70 70 - if bom_len > 0 then 71 71 - Bytes.Reader.skip bom_len t.reader; 71 71 + if bom_len > 0 then Bytes.Reader.skip bom_len t.reader; 72 72 t 73 73 74 74 (** Create input from a string *) ··· 77 77 of_reader reader 78 78 79 79 let position t = t.position 80 80 - 81 81 - let is_eof t = 82 82 - not (ensure_slice t) 83 83 - 84 84 - let peek t = 85 85 - if ensure_slice t then 86 86 - peek_current t 87 87 - else 88 88 - None 80 80 + let is_eof t = not (ensure_slice t) 81 81 + let peek t = if ensure_slice t then peek_current t else None 89 82 90 83 let peek_exn t = 91 84 match peek t with ··· 112 105 let sample_offset = n - slice_remaining in 113 106 if sample_offset < String.length sample then 114 107 Some sample.[sample_offset] 115 115 - else 116 116 - None 108 108 + else None 117 109 end 118 118 - | None -> 119 119 - if n < String.length sample then 120 120 - Some sample.[n] 121 121 - else 122 122 - None 110 110 + | None -> if n < String.length sample then Some sample.[n] else None 123 111 end 124 112 125 113 (** Peek at up to n characters as a string *) ··· 139 127 let needed_from_reader = n - slice_remaining in 140 128 let sample = Bytes.Reader.sniff needed_from_reader t.reader in 141 129 let buf = Buffer.create n in 142 142 - Buffer.add_subbytes buf slice_bytes (slice_first + t.slice_pos) slice_remaining; 130 130 + Buffer.add_subbytes buf slice_bytes 131 131 + (slice_first + t.slice_pos) 132 132 + slice_remaining; 143 133 Buffer.add_string buf sample; 144 134 Buffer.contents buf 145 135 end 146 146 - | None -> 147 147 - if ensure_slice t then 148 148 - peek_string t n 149 149 - else 150 150 - "" 136 136 + | None -> if ensure_slice t then peek_string t n else "" 151 137 end 152 138 153 139 (** Consume next character *) ··· 161 147 t.slice_pos <- t.slice_pos + 1; 162 148 t.position <- Position.advance_char c t.position; 163 149 (* Check if we've exhausted this slice *) 164 164 - if t.slice_pos >= Bytes.Slice.length slice then 165 165 - t.current_slice <- None; 150 150 + if t.slice_pos >= Bytes.Slice.length slice then t.current_slice <- None; 166 151 Some c 167 152 | None -> None 168 168 - end else 169 169 - None 153 153 + end 154 154 + else None 170 155 171 156 let next_exn t = 172 157 match next t with ··· 181 166 let skip_while t pred = 182 167 let rec loop () = 183 168 match peek t with 184 184 - | Some c when pred c -> ignore (next t); loop () 169 169 + | Some c when pred c -> 170 170 + ignore (next t); 171 171 + loop () 185 172 | _ -> () 186 173 in 187 174 loop () 188 175 189 176 (** Check if next char satisfies predicate *) 190 190 - let next_is pred t = 191 191 - match peek t with 192 192 - | None -> false 193 193 - | Some c -> pred c 177 177 + let next_is pred t = match peek t with None -> false | Some c -> pred c 194 178 195 179 let next_is_break t = next_is is_break t 196 180 let next_is_blank t = next_is is_blank t ··· 209 193 if len < 3 then false 210 194 else 211 195 let prefix = String.sub s 0 3 in 212 212 - (prefix = "---" || prefix = "...") && 213 213 - (len = 3 || is_whitespace s.[3]) 196 196 + (prefix = "---" || prefix = "...") && (len = 3 || is_whitespace s.[3]) 214 197 end 215 198 216 199 (** Consume line break, handling \r\n as single break *) 217 200 let consume_break t = 218 201 match peek t with 219 219 - | Some '\r' -> 202 202 + | Some '\r' -> ( 220 203 ignore (next t); 221 221 - (match peek t with 222 222 - | Some '\n' -> ignore (next t) 223 223 - | _ -> ()) 224 224 - | Some '\n' -> 225 225 - ignore (next t) 204 204 + match peek t with Some '\n' -> ignore (next t) | _ -> ()) 205 205 + | Some '\n' -> ignore (next t) 226 206 | _ -> () 227 207 228 208 (** Get remaining content from current position *) ··· 230 210 let buf = Buffer.create 256 in 231 211 (* Add current slice remainder *) 232 212 (match t.current_slice with 233 233 - | Some slice -> 234 234 - let bytes = Bytes.Slice.bytes slice in 235 235 - let first = Bytes.Slice.first slice in 236 236 - let remaining = Bytes.Slice.length slice - t.slice_pos in 237 237 - if remaining > 0 then 238 238 - Buffer.add_subbytes buf bytes (first + t.slice_pos) remaining 239 239 - | None -> ()); 213 213 + | Some slice -> 214 214 + let bytes = Bytes.Slice.bytes slice in 215 215 + let first = Bytes.Slice.first slice in 216 216 + let remaining = Bytes.Slice.length slice - t.slice_pos in 217 217 + if remaining > 0 then 218 218 + Buffer.add_subbytes buf bytes (first + t.slice_pos) remaining 219 219 + | None -> ()); 240 220 (* Add remaining from reader *) 241 221 Bytes.Reader.add_to_buffer buf t.reader; 242 222 Buffer.contents buf ··· 253 233 Some (Stdlib.Bytes.get bytes (first + t.slice_pos - 1)) 254 234 | _ -> None 255 235 256 256 - (** Get a sample of the source for encoding detection. 257 257 - Uses sniff to peek without consuming. *) 236 236 + (** Get a sample of the source for encoding detection. Uses sniff to peek 237 237 + without consuming. *) 258 238 let source t = 259 239 (* First check current slice *) 260 240 match t.current_slice with ··· 268 248 Bytes.Reader.sniff 4 t.reader 269 249 270 250 (** Get the byte position in the underlying stream *) 271 271 - let byte_pos t = 272 272 - Bytes.Reader.pos t.reader 251 251 + let byte_pos t = Bytes.Reader.pos t.reader

+7 -18

lib/layout_style.ml

··· 5 5 6 6 (** Collection layout styles *) 7 7 8 8 - type t = [ 9 9 - | `Any (** Let emitter choose *) 10 10 - | `Block (** Indentation-based *) 11 11 - | `Flow (** Inline with brackets *) 12 12 - ] 8 8 + type t = 9 9 + [ `Any (** Let emitter choose *) 10 10 + | `Block (** Indentation-based *) 11 11 + | `Flow (** Inline with brackets *) ] 13 12 14 14 - let to_string = function 15 15 - | `Any -> "any" 16 16 - | `Block -> "block" 17 17 - | `Flow -> "flow" 18 18 - 19 19 - let pp fmt t = 20 20 - Format.pp_print_string fmt (to_string t) 21 21 - 13 13 + let to_string = function `Any -> "any" | `Block -> "block" | `Flow -> "flow" 14 14 + let pp fmt t = Format.pp_print_string fmt (to_string t) 22 15 let equal a b = a = b 23 16 24 17 let compare a b = 25 25 - let to_int = function 26 26 - | `Any -> 0 27 27 - | `Block -> 1 28 28 - | `Flow -> 2 29 29 - in 18 18 + let to_int = function `Any -> 0 | `Block -> 1 | `Flow -> 2 in 30 19 Int.compare (to_int a) (to_int b)

+138 -162

lib/loader.ml

··· 31 31 mutable doc_implicit_start : bool; 32 32 } 33 33 34 34 - let create_state () = { 35 35 - stack = []; 36 36 - current = None; 37 37 - documents = []; 38 38 - doc_version = None; 39 39 - doc_implicit_start = true; 40 40 - } 34 34 + let create_state () = 35 35 + { 36 36 + stack = []; 37 37 + current = None; 38 38 + documents = []; 39 39 + doc_version = None; 40 40 + doc_implicit_start = true; 41 41 + } 41 42 42 43 (** Process a single event *) 43 44 let rec process_event state (ev : Event.spanned) = 44 45 match ev.event with 45 46 | Event.Stream_start _ -> () 46 46 - 47 47 | Event.Stream_end -> () 48 48 - 49 48 | Event.Document_start { version; implicit } -> 50 49 state.doc_version <- version; 51 50 state.doc_implicit_start <- implicit 52 52 - 53 51 | Event.Document_end { implicit } -> 54 54 - let doc = Document.make 55 55 - ?version:state.doc_version 56 56 - ~implicit_start:state.doc_implicit_start 57 57 - ~implicit_end:implicit 58 58 - state.current 52 52 + let doc = 53 53 + Document.make ?version:state.doc_version 54 54 + ~implicit_start:state.doc_implicit_start ~implicit_end:implicit 55 55 + state.current 59 56 in 60 57 state.documents <- doc :: state.documents; 61 58 state.current <- None; 62 59 state.doc_version <- None; 63 60 state.doc_implicit_start <- true 64 64 - 65 61 | Event.Alias { anchor } -> 66 62 let node : Yaml.t = `Alias anchor in 67 63 add_node state node 68 68 - 69 69 - | Event.Scalar { anchor; tag; value; plain_implicit; quoted_implicit; style } -> 70 70 - let scalar = Scalar.make 71 71 - ?anchor ?tag 72 72 - ~plain_implicit ~quoted_implicit 73 73 - ~style value 64 64 + | Event.Scalar { anchor; tag; value; plain_implicit; quoted_implicit; style } 65 65 + -> 66 66 + let scalar = 67 67 + Scalar.make ?anchor ?tag ~plain_implicit ~quoted_implicit ~style value 74 68 in 75 69 let node : Yaml.t = `Scalar scalar in 76 70 add_node state node 77 77 - 78 71 | Event.Sequence_start { anchor; tag; implicit; style } -> 79 79 - let frame = Sequence_frame { 80 80 - anchor; tag; implicit; style; 81 81 - items = []; 82 82 - } in 72 72 + let frame = Sequence_frame { anchor; tag; implicit; style; items = [] } in 83 73 state.stack <- frame :: state.stack 84 84 - 85 85 - | Event.Sequence_end -> 86 86 - (match state.stack with 87 87 - | Sequence_frame { anchor; tag; implicit; style; items } :: rest -> 88 88 - let seq = Sequence.make ?anchor ?tag ~implicit ~style (List.rev items) in 89 89 - let node : Yaml.t = `A seq in 90 90 - state.stack <- rest; 91 91 - add_node state node 92 92 - | _ -> Error.raise (Invalid_state "unexpected sequence end")) 93 93 - 74 74 + | Event.Sequence_end -> ( 75 75 + match state.stack with 76 76 + | Sequence_frame { anchor; tag; implicit; style; items } :: rest -> 77 77 + let seq = 78 78 + Sequence.make ?anchor ?tag ~implicit ~style (List.rev items) 79 79 + in 80 80 + let node : Yaml.t = `A seq in 81 81 + state.stack <- rest; 82 82 + add_node state node 83 83 + | _ -> Error.raise (Invalid_state "unexpected sequence end")) 94 84 | Event.Mapping_start { anchor; tag; implicit; style } -> 95 95 - let frame = Mapping_frame { 96 96 - anchor; tag; implicit; style; 97 97 - pairs = []; 98 98 - pending_key = None; 99 99 - } in 85 85 + let frame = 86 86 + Mapping_frame 87 87 + { anchor; tag; implicit; style; pairs = []; pending_key = None } 88 88 + in 100 89 state.stack <- frame :: state.stack 101 101 - 102 102 - | Event.Mapping_end -> 103 103 - (match state.stack with 104 104 - | Mapping_frame { anchor; tag; implicit; style; pairs; pending_key = None } :: rest -> 105 105 - let map = Mapping.make ?anchor ?tag ~implicit ~style (List.rev pairs) in 106 106 - let node : Yaml.t = `O map in 107 107 - state.stack <- rest; 108 108 - add_node state node 109 109 - | Mapping_frame { pending_key = Some _; _ } :: _ -> 110 110 - Error.raise (Invalid_state "mapping ended with pending key") 111 111 - | _ -> Error.raise (Invalid_state "unexpected mapping end")) 90 90 + | Event.Mapping_end -> ( 91 91 + match state.stack with 92 92 + | Mapping_frame 93 93 + { anchor; tag; implicit; style; pairs; pending_key = None } 94 94 + :: rest -> 95 95 + let map = 96 96 + Mapping.make ?anchor ?tag ~implicit ~style (List.rev pairs) 97 97 + in 98 98 + let node : Yaml.t = `O map in 99 99 + state.stack <- rest; 100 100 + add_node state node 101 101 + | Mapping_frame { pending_key = Some _; _ } :: _ -> 102 102 + Error.raise (Invalid_state "mapping ended with pending key") 103 103 + | _ -> Error.raise (Invalid_state "unexpected mapping end")) 112 104 113 105 (** Add a node to current context *) 114 106 and add_node state node = 115 107 match state.stack with 116 116 - | [] -> 117 117 - state.current <- Some node 118 118 - 108 108 + | [] -> state.current <- Some node 119 109 | Sequence_frame f :: rest -> 120 110 state.stack <- Sequence_frame { f with items = node :: f.items } :: rest 121 121 - 122 122 - | Mapping_frame f :: rest -> 123 123 - (match f.pending_key with 124 124 - | None -> 125 125 - (* This is a key *) 126 126 - state.stack <- Mapping_frame { f with pending_key = Some node } :: rest 127 127 - | Some key -> 128 128 - (* This is a value *) 129 129 - state.stack <- Mapping_frame { 130 130 - f with 131 131 - pairs = (key, node) :: f.pairs; 132 132 - pending_key = None; 133 133 - } :: rest) 111 111 + | Mapping_frame f :: rest -> ( 112 112 + match f.pending_key with 113 113 + | None -> 114 114 + (* This is a key *) 115 115 + state.stack <- 116 116 + Mapping_frame { f with pending_key = Some node } :: rest 117 117 + | Some key -> 118 118 + (* This is a value *) 119 119 + state.stack <- 120 120 + Mapping_frame 121 121 + { f with pairs = (key, node) :: f.pairs; pending_key = None } 122 122 + :: rest) 134 123 135 124 (** Internal: parse all documents from a parser *) 136 125 let parse_all_documents parser = ··· 149 138 150 139 @param resolve_aliases Whether to resolve aliases (default true) 151 140 @param max_nodes Maximum nodes during alias expansion (default 10M) 152 152 - @param max_depth Maximum alias nesting depth (default 100) 153 153 - *) 154 154 - let value_of_string 155 155 - ?(resolve_aliases = true) 141 141 + @param max_depth Maximum alias nesting depth (default 100) *) 142 142 + let value_of_string ?(resolve_aliases = true) 156 143 ?(max_nodes = Yaml.default_max_alias_nodes) 157 157 - ?(max_depth = Yaml.default_max_alias_depth) 158 158 - s = 144 144 + ?(max_depth = Yaml.default_max_alias_depth) s = 159 145 let docs = parse_all_documents (Parser.of_string s) in 160 146 let doc = single_document_or_error docs ~empty:(Document.make None) in 161 147 match Document.root doc with 162 148 | None -> `Null 163 149 | Some yaml -> 164 164 - Yaml.to_value ~resolve_aliases_first:resolve_aliases ~max_nodes ~max_depth yaml 150 150 + Yaml.to_value ~resolve_aliases_first:resolve_aliases ~max_nodes ~max_depth 151 151 + yaml 165 152 166 153 (** Load single document as Yaml. 167 154 168 155 @param resolve_aliases Whether to resolve aliases (default false for Yaml.t) 169 156 @param max_nodes Maximum nodes during alias expansion (default 10M) 170 170 - @param max_depth Maximum alias nesting depth (default 100) 171 171 - *) 172 172 - let yaml_of_string 173 173 - ?(resolve_aliases = false) 157 157 + @param max_depth Maximum alias nesting depth (default 100) *) 158 158 + let yaml_of_string ?(resolve_aliases = false) 174 159 ?(max_nodes = Yaml.default_max_alias_nodes) 175 175 - ?(max_depth = Yaml.default_max_alias_depth) 176 176 - s = 160 160 + ?(max_depth = Yaml.default_max_alias_depth) s = 177 161 let docs = parse_all_documents (Parser.of_string s) in 178 162 let doc = single_document_or_error docs ~empty:(Document.make None) in 179 163 match Document.root doc with 180 164 | None -> `Scalar (Scalar.make "") 181 165 | Some yaml -> 182 182 - if resolve_aliases then 183 183 - Yaml.resolve_aliases ~max_nodes ~max_depth yaml 184 184 - else 185 185 - yaml 166 166 + if resolve_aliases then Yaml.resolve_aliases ~max_nodes ~max_depth yaml 167 167 + else yaml 186 168 187 169 (** Load all documents *) 188 170 let documents_of_string s = ··· 194 176 195 177 @param resolve_aliases Whether to resolve aliases (default true) 196 178 @param max_nodes Maximum nodes during alias expansion (default 10M) 197 197 - @param max_depth Maximum alias nesting depth (default 100) 198 198 - *) 199 199 - let value_of_reader 200 200 - ?(resolve_aliases = true) 179 179 + @param max_depth Maximum alias nesting depth (default 100) *) 180 180 + let value_of_reader ?(resolve_aliases = true) 201 181 ?(max_nodes = Yaml.default_max_alias_nodes) 202 202 - ?(max_depth = Yaml.default_max_alias_depth) 203 203 - reader = 182 182 + ?(max_depth = Yaml.default_max_alias_depth) reader = 204 183 let docs = parse_all_documents (Parser.of_reader reader) in 205 184 let doc = single_document_or_error docs ~empty:(Document.make None) in 206 185 match Document.root doc with 207 186 | None -> `Null 208 187 | Some yaml -> 209 209 - Yaml.to_value ~resolve_aliases_first:resolve_aliases ~max_nodes ~max_depth yaml 188 188 + Yaml.to_value ~resolve_aliases_first:resolve_aliases ~max_nodes ~max_depth 189 189 + yaml 210 190 211 191 (** Load single document as Yaml from a Bytes.Reader. 212 192 213 193 @param resolve_aliases Whether to resolve aliases (default false for Yaml.t) 214 194 @param max_nodes Maximum nodes during alias expansion (default 10M) 215 215 - @param max_depth Maximum alias nesting depth (default 100) 216 216 - *) 217 217 - let yaml_of_reader 218 218 - ?(resolve_aliases = false) 195 195 + @param max_depth Maximum alias nesting depth (default 100) *) 196 196 + let yaml_of_reader ?(resolve_aliases = false) 219 197 ?(max_nodes = Yaml.default_max_alias_nodes) 220 220 - ?(max_depth = Yaml.default_max_alias_depth) 221 221 - reader = 198 198 + ?(max_depth = Yaml.default_max_alias_depth) reader = 222 199 let docs = parse_all_documents (Parser.of_reader reader) in 223 200 let doc = single_document_or_error docs ~empty:(Document.make None) in 224 201 match Document.root doc with 225 202 | None -> `Scalar (Scalar.make "") 226 203 | Some yaml -> 227 227 - if resolve_aliases then 228 228 - Yaml.resolve_aliases ~max_nodes ~max_depth yaml 229 229 - else 230 230 - yaml 204 204 + if resolve_aliases then Yaml.resolve_aliases ~max_nodes ~max_depth yaml 205 205 + else yaml 231 206 232 207 (** Load all documents from a Bytes.Reader *) 233 208 let documents_of_reader reader = ··· 245 220 let rec loop () = 246 221 match next_event () with 247 222 | None -> None 248 248 - | Some ev -> 223 223 + | Some ev -> ( 249 224 process_event state ev; 250 225 match ev.event with 251 251 - | Event.Document_end _ -> 252 252 - (match state.documents with 253 253 - | doc :: _ -> 254 254 - state.documents <- []; 255 255 - Some (extract doc) 256 256 - | [] -> None) 226 226 + | Event.Document_end _ -> ( 227 227 + match state.documents with 228 228 + | doc :: _ -> 229 229 + state.documents <- []; 230 230 + Some (extract doc) 231 231 + | [] -> None) 257 232 | Event.Stream_end -> None 258 258 - | _ -> loop () 233 233 + | _ -> loop ()) 259 234 in 260 235 loop () 261 236 ··· 267 242 268 243 @param resolve_aliases Whether to resolve aliases (default true) 269 244 @param max_nodes Maximum nodes during alias expansion (default 10M) 270 270 - @param max_depth Maximum alias nesting depth (default 100) 271 271 - *) 272 272 - let load_value 273 273 - ?(resolve_aliases = true) 245 245 + @param max_depth Maximum alias nesting depth (default 100) *) 246 246 + let load_value ?(resolve_aliases = true) 274 247 ?(max_nodes = Yaml.default_max_alias_nodes) 275 275 - ?(max_depth = Yaml.default_max_alias_depth) 276 276 - parser = 277 277 - load_generic (fun doc -> 278 278 - match Document.root doc with 279 279 - | None -> `Null 280 280 - | Some yaml -> 281 281 - Yaml.to_value ~resolve_aliases_first:resolve_aliases ~max_nodes ~max_depth yaml 282 282 - ) parser 248 248 + ?(max_depth = Yaml.default_max_alias_depth) parser = 249 249 + load_generic 250 250 + (fun doc -> 251 251 + match Document.root doc with 252 252 + | None -> `Null 253 253 + | Some yaml -> 254 254 + Yaml.to_value ~resolve_aliases_first:resolve_aliases ~max_nodes 255 255 + ~max_depth yaml) 256 256 + parser 283 257 284 258 (** Load single Yaml from parser *) 285 259 let load_yaml parser = 286 286 - load_generic (fun doc -> 287 287 - Document.root doc |> Option.value ~default:(`Scalar (Scalar.make "")) 288 288 - ) parser 260 260 + load_generic 261 261 + (fun doc -> 262 262 + Document.root doc |> Option.value ~default:(`Scalar (Scalar.make ""))) 263 263 + parser 289 264 290 265 (** Load single Document from parser *) 291 291 - let load_document parser = 292 292 - load_generic Fun.id parser 266 266 + let load_document parser = load_generic Fun.id parser 293 267 294 268 (** Iterate over documents *) 295 269 let iter_documents f parser = 296 270 let rec loop () = 297 271 match load_document parser with 298 272 | None -> () 299 299 - | Some doc -> f doc; loop () 273 273 + | Some doc -> 274 274 + f doc; 275 275 + loop () 300 276 in 301 277 loop () 302 278 303 279 (** Fold over documents *) 304 280 let fold_documents f init parser = 305 281 let rec loop acc = 306 306 - match load_document parser with 307 307 - | None -> acc 308 308 - | Some doc -> loop (f acc doc) 282 282 + match load_document parser with None -> acc | Some doc -> loop (f acc doc) 309 283 in 310 284 loop init 285 285 + 311 286 312 287 (** Load single Value from event source. 313 288 314 289 @param resolve_aliases Whether to resolve aliases (default true) 315 290 @param max_nodes Maximum nodes during alias expansion (default 10M) 316 316 - @param max_depth Maximum alias nesting depth (default 100) 317 317 - *) 318 318 - let value_of_parser 319 319 - ?(resolve_aliases = true) 291 291 + @param max_depth Maximum alias nesting depth (default 100) *) 292 292 + let value_of_parser ?(resolve_aliases = true) 320 293 ?(max_nodes = Yaml.default_max_alias_nodes) 321 321 - ?(max_depth = Yaml.default_max_alias_depth) 322 322 - next_event = 323 323 - match load_generic_fn (fun doc -> 324 324 - match Document.root doc with 325 325 - | None -> `Null 326 326 - | Some yaml -> 327 327 - Yaml.to_value ~resolve_aliases_first:resolve_aliases ~max_nodes ~max_depth yaml 328 328 - ) next_event with 294 294 + ?(max_depth = Yaml.default_max_alias_depth) next_event = 295 295 + match 296 296 + load_generic_fn 297 297 + (fun doc -> 298 298 + match Document.root doc with 299 299 + | None -> `Null 300 300 + | Some yaml -> 301 301 + Yaml.to_value ~resolve_aliases_first:resolve_aliases ~max_nodes 302 302 + ~max_depth yaml) 303 303 + next_event 304 304 + with 329 305 | Some v -> v 330 306 | None -> `Null 331 307 ··· 333 309 334 310 @param resolve_aliases Whether to resolve aliases (default false) 335 311 @param max_nodes Maximum nodes during alias expansion (default 10M) 336 336 - @param max_depth Maximum alias nesting depth (default 100) 337 337 - *) 338 338 - let yaml_of_parser 339 339 - ?(resolve_aliases = false) 312 312 + @param max_depth Maximum alias nesting depth (default 100) *) 313 313 + let yaml_of_parser ?(resolve_aliases = false) 340 314 ?(max_nodes = Yaml.default_max_alias_nodes) 341 341 - ?(max_depth = Yaml.default_max_alias_depth) 342 342 - next_event = 343 343 - match load_generic_fn (fun doc -> 344 344 - match Document.root doc with 345 345 - | None -> `Scalar (Scalar.make "") 346 346 - | Some yaml -> 347 347 - if resolve_aliases then 348 348 - Yaml.resolve_aliases ~max_nodes ~max_depth yaml 349 349 - else 350 350 - yaml 351 351 - ) next_event with 315 315 + ?(max_depth = Yaml.default_max_alias_depth) next_event = 316 316 + match 317 317 + load_generic_fn 318 318 + (fun doc -> 319 319 + match Document.root doc with 320 320 + | None -> `Scalar (Scalar.make "") 321 321 + | Some yaml -> 322 322 + if resolve_aliases then 323 323 + Yaml.resolve_aliases ~max_nodes ~max_depth yaml 324 324 + else yaml) 325 325 + next_event 326 326 + with 352 327 | Some v -> v 353 328 | None -> `Scalar (Scalar.make "") 354 329 355 330 (** Load single Document from event source *) 356 356 - let document_of_parser next_event = 357 357 - load_generic_fn Fun.id next_event 331 331 + let document_of_parser next_event = load_generic_fn Fun.id next_event 358 332 359 333 (** Load all documents from event source *) 360 334 let documents_of_parser next_event = ··· 373 347 let rec loop () = 374 348 match document_of_parser next_event with 375 349 | None -> () 376 376 - | Some doc -> f doc; loop () 350 350 + | Some doc -> 351 351 + f doc; 352 352 + loop () 377 353 in 378 354 loop () 379 355

+38 -41

lib/mapping.ml

··· 13 13 members : ('k * 'v) list; 14 14 } 15 15 16 16 - let make 17 17 - ?(anchor : string option) 18 18 - ?(tag : string option) 19 19 - ?(implicit = true) 20 20 - ?(style = `Any) 21 21 - members = 16 16 + let make ?(anchor : string option) ?(tag : string option) ?(implicit = true) 17 17 + ?(style = `Any) members = 22 18 { anchor; tag; implicit; style; members } 23 19 24 20 let members t = t.members ··· 26 22 let tag t = t.tag 27 23 let implicit t = t.implicit 28 24 let style t = t.style 29 29 - 30 25 let with_anchor anchor t = { t with anchor = Some anchor } 31 26 let with_tag tag t = { t with tag = Some tag } 32 27 let with_style style t = { t with style } 33 28 34 34 - let map_keys f t = { t with members = List.map (fun (k, v) -> (f k, v)) t.members } 35 35 - let map_values f t = { t with members = List.map (fun (k, v) -> (k, f v)) t.members } 36 36 - let map f t = { t with members = List.map (fun (k, v) -> f k v) t.members } 29 29 + let map_keys f t = 30 30 + { t with members = List.map (fun (k, v) -> (f k, v)) t.members } 37 31 38 38 - let length t = List.length t.members 32 32 + let map_values f t = 33 33 + { t with members = List.map (fun (k, v) -> (k, f v)) t.members } 39 34 35 35 + let map f t = { t with members = List.map (fun (k, v) -> f k v) t.members } 36 36 + let length t = List.length t.members 40 37 let is_empty t = t.members = [] 41 38 42 39 let find pred t = 43 40 List.find_opt (fun (k, _) -> pred k) t.members |> Option.map snd 44 41 45 45 - let find_key pred t = 46 46 - List.find_opt (fun (k, _) -> pred k) t.members 47 47 - 48 48 - let mem pred t = 49 49 - List.exists (fun (k, _) -> pred k) t.members 50 50 - 42 42 + let find_key pred t = List.find_opt (fun (k, _) -> pred k) t.members 43 43 + let mem pred t = List.exists (fun (k, _) -> pred k) t.members 51 44 let keys t = List.map fst t.members 52 52 - 53 45 let values t = List.map snd t.members 54 54 - 55 46 let iter f t = List.iter (fun (k, v) -> f k v) t.members 56 56 - 57 47 let fold f init t = List.fold_left (fun acc (k, v) -> f acc k v) init t.members 58 48 59 49 let pp pp_key pp_val fmt t = ··· 62 52 Option.iter (Format.fprintf fmt "tag=%s,@ ") t.tag; 63 53 Format.fprintf fmt "style=%a,@ " Layout_style.pp t.style; 64 54 Format.fprintf fmt "members={@,"; 65 65 - List.iteri (fun i (k, v) -> 66 66 - if i > 0 then Format.fprintf fmt ",@ "; 67 67 - Format.fprintf fmt "@[<hv 2>%a:@ %a@]" pp_key k pp_val v 68 68 - ) t.members; 55 55 + List.iteri 56 56 + (fun i (k, v) -> 57 57 + if i > 0 then Format.fprintf fmt ",@ "; 58 58 + Format.fprintf fmt "@[<hv 2>%a:@ %a@]" pp_key k pp_val v) 59 59 + t.members; 69 60 Format.fprintf fmt "@]@,})" 70 61 71 62 let equal eq_k eq_v a b = 72 72 - Option.equal String.equal a.anchor b.anchor && 73 73 - Option.equal String.equal a.tag b.tag && 74 74 - a.implicit = b.implicit && 75 75 - Layout_style.equal a.style b.style && 76 76 - List.equal (fun (k1, v1) (k2, v2) -> eq_k k1 k2 && eq_v v1 v2) a.members b.members 63 63 + Option.equal String.equal a.anchor b.anchor 64 64 + && Option.equal String.equal a.tag b.tag 65 65 + && a.implicit = b.implicit 66 66 + && Layout_style.equal a.style b.style 67 67 + && List.equal 68 68 + (fun (k1, v1) (k2, v2) -> eq_k k1 k2 && eq_v v1 v2) 69 69 + a.members b.members 77 70 78 71 let compare cmp_k cmp_v a b = 79 72 let c = Option.compare String.compare a.anchor b.anchor in 80 80 - if c <> 0 then c else 81 81 - let c = Option.compare String.compare a.tag b.tag in 82 82 - if c <> 0 then c else 83 83 - let c = Bool.compare a.implicit b.implicit in 84 84 - if c <> 0 then c else 85 85 - let c = Layout_style.compare a.style b.style in 86 86 - if c <> 0 then c else 87 87 - let cmp_pair (k1, v1) (k2, v2) = 88 88 - let c = cmp_k k1 k2 in 89 89 - if c <> 0 then c else cmp_v v1 v2 90 90 - in 91 91 - List.compare cmp_pair a.members b.members 73 73 + if c <> 0 then c 74 74 + else 75 75 + let c = Option.compare String.compare a.tag b.tag in 76 76 + if c <> 0 then c 77 77 + else 78 78 + let c = Bool.compare a.implicit b.implicit in 79 79 + if c <> 0 then c 80 80 + else 81 81 + let c = Layout_style.compare a.style b.style in 82 82 + if c <> 0 then c 83 83 + else 84 84 + let cmp_pair (k1, v1) (k2, v2) = 85 85 + let c = cmp_k k1 k2 in 86 86 + if c <> 0 then c else cmp_v v1 v2 87 87 + in 88 88 + List.compare cmp_pair a.members b.members

+266 -305

lib/parser.ml

··· 10 10 | Stream_start 11 11 | Implicit_document_start 12 12 | Document_content 13 13 - | Document_content_done (* After parsing a node, check for unexpected content *) 13 13 + | Document_content_done 14 14 + (* After parsing a node, check for unexpected content *) 14 15 | Document_end 15 16 | Block_sequence_first_entry 16 17 | Block_sequence_entry ··· 36 37 mutable tag_directives : (string * string) list; 37 38 mutable current_token : Token.spanned option; 38 39 mutable finished : bool; 39 39 - mutable explicit_doc_end : bool; (** True if last doc ended with explicit ... *) 40 40 - mutable stream_start : bool; (** True if we haven't emitted any documents yet *) 40 40 + mutable explicit_doc_end : bool; 41 41 + (** True if last doc ended with explicit ... *) 42 42 + mutable stream_start : bool; 43 43 + (** True if we haven't emitted any documents yet *) 41 44 } 42 45 43 43 - let create scanner = { 44 44 - scanner; 45 45 - state = Stream_start; 46 46 - states = []; 47 47 - version = None; 48 48 - tag_directives = [ 49 49 - ("!", "!"); 50 50 - ("!!", "tag:yaml.org,2002:"); 51 51 - ]; 52 52 - current_token = None; 53 53 - finished = false; 54 54 - explicit_doc_end = false; 55 55 - stream_start = true; 56 56 - } 46 46 + let create scanner = 47 47 + { 48 48 + scanner; 49 49 + state = Stream_start; 50 50 + states = []; 51 51 + version = None; 52 52 + tag_directives = [ ("!", "!"); ("!!", "tag:yaml.org,2002:") ]; 53 53 + current_token = None; 54 54 + finished = false; 55 55 + explicit_doc_end = false; 56 56 + stream_start = true; 57 57 + } 57 58 58 59 let of_string s = create (Scanner.of_string s) 59 60 let of_scanner = create ··· 64 65 let current_token t = 65 66 match t.current_token with 66 67 | Some tok -> tok 67 67 - | None -> 68 68 + | None -> ( 68 69 let tok = Scanner.next t.scanner in 69 70 t.current_token <- tok; 70 70 - match tok with 71 71 - | Some tok -> tok 72 72 - | None -> Error.raise Unexpected_eof 71 71 + match tok with Some tok -> tok | None -> Error.raise Unexpected_eof) 73 72 74 73 (** Peek at current token *) 75 74 let peek_token t = ··· 80 79 t.current_token 81 80 82 81 (** Skip current token *) 83 83 - let skip_token t = 84 84 - t.current_token <- None 82 82 + let skip_token t = t.current_token <- None 85 83 86 84 (** Check if current token matches predicate *) 87 85 let check t pred = 88 88 - match peek_token t with 89 89 - | Some tok -> pred tok.token 90 90 - | None -> false 86 86 + match peek_token t with Some tok -> pred tok.token | None -> false 87 87 + 91 88 92 89 (** Push state onto stack *) 93 93 - let push_state t s = 94 94 - t.states <- s :: t.states 90 90 + let push_state t s = t.states <- s :: t.states 95 91 96 92 (** Pop state from stack *) 97 93 let pop_state t = ··· 115 111 (** Process directives at document start *) 116 112 let process_directives t = 117 113 t.version <- None; 118 118 - t.tag_directives <- [("!", "!"); ("!!", "tag:yaml.org,2002:")]; 114 114 + t.tag_directives <- [ ("!", "!"); ("!!", "tag:yaml.org,2002:") ]; 119 115 120 120 - while check t (function 121 121 - | Token.Version_directive _ | Token.Tag_directive _ -> true 122 122 - | _ -> false) 116 116 + while 117 117 + check t (function 118 118 + | Token.Version_directive _ | Token.Tag_directive _ -> true 119 119 + | _ -> false) 123 120 do 124 121 let tok = current_token t in 125 122 skip_token t; 126 123 match tok.token with 127 124 | Token.Version_directive { major; minor } -> 128 125 if t.version <> None then 129 129 - Error.raise_span tok.span (Invalid_yaml_version "duplicate YAML directive"); 126 126 + Error.raise_span tok.span 127 127 + (Invalid_yaml_version "duplicate YAML directive"); 130 128 t.version <- Some (major, minor) 131 129 | Token.Tag_directive { handle; prefix } -> 132 130 (* Skip empty tag directives (these are reserved/unknown directives that were ignored) *) 133 133 - if handle = "" && prefix = "" then 134 134 - () (* Ignore reserved directives *) 131 131 + if handle = "" && prefix = "" then () (* Ignore reserved directives *) 135 132 else begin 136 136 - if List.mem_assoc handle t.tag_directives && 137 137 - handle <> "!" && handle <> "!!" then 138 138 - Error.raise_span tok.span (Invalid_tag_directive ("duplicate tag handle: " ^ handle)); 133 133 + if 134 134 + List.mem_assoc handle t.tag_directives 135 135 + && handle <> "!" && handle <> "!!" 136 136 + then 137 137 + Error.raise_span tok.span 138 138 + (Invalid_tag_directive ("duplicate tag handle: " ^ handle)); 139 139 t.tag_directives <- (handle, prefix) :: t.tag_directives 140 140 end 141 141 | _ -> () ··· 146 146 let anchor = ref None in 147 147 let tag = ref None in 148 148 149 149 - while check t (function 150 150 - | Token.Anchor _ | Token.Tag _ -> true 151 151 - | _ -> false) 149 149 + while 150 150 + check t (function Token.Anchor _ | Token.Tag _ -> true | _ -> false) 152 151 do 153 152 let tok = current_token t in 154 153 skip_token t; ··· 172 171 173 172 (** Empty scalar event *) 174 173 let empty_scalar_event ~anchor ~tag span = 175 175 - Event.Scalar { 176 176 - anchor; 177 177 - tag; 178 178 - value = ""; 179 179 - plain_implicit = tag = None; 180 180 - quoted_implicit = false; 181 181 - style = `Plain; 182 182 - }, span 174 174 + ( Event.Scalar 175 175 + { 176 176 + anchor; 177 177 + tag; 178 178 + value = ""; 179 179 + plain_implicit = tag = None; 180 180 + quoted_implicit = false; 181 181 + style = `Plain; 182 182 + }, 183 183 + span ) 183 184 184 185 (** Parse stream start *) 185 186 let parse_stream_start t = ··· 188 189 match tok.token with 189 190 | Token.Stream_start encoding -> 190 191 t.state <- Implicit_document_start; 191 191 - Event.Stream_start { encoding }, tok.span 192 192 - | _ -> 193 193 - Error.raise_span tok.span (Unexpected_token "expected stream start") 192 192 + (Event.Stream_start { encoding }, tok.span) 193 193 + | _ -> Error.raise_span tok.span (Unexpected_token "expected stream start") 194 194 195 195 (** Parse document start (implicit or explicit) *) 196 196 let parse_document_start t ~implicit = ··· 199 199 if not implicit then begin 200 200 let tok = current_token t in 201 201 match tok.token with 202 202 - | Token.Document_start -> 203 203 - skip_token t 204 204 - | _ -> 205 205 - Error.raise_span tok.span Expected_document_start 202 202 + | Token.Document_start -> skip_token t 203 203 + | _ -> Error.raise_span tok.span Expected_document_start 206 204 end; 207 205 208 208 - let span = match peek_token t with 206 206 + let span = 207 207 + match peek_token t with 209 208 | Some tok -> tok.span 210 209 | None -> Span.point Position.initial 211 210 in ··· 214 213 t.stream_start <- false; 215 214 push_state t Document_end; 216 215 t.state <- Document_content; 217 217 - Event.Document_start { version = t.version; implicit }, span 216 216 + (Event.Document_start { version = t.version; implicit }, span) 218 217 219 218 (** Parse document end *) 220 219 let parse_document_end t = 221 221 - let implicit = not (check t (function Token.Document_end -> true | _ -> false)) in 222 222 - let span = match peek_token t with 220 220 + let implicit = 221 221 + not (check t (function Token.Document_end -> true | _ -> false)) 222 222 + in 223 223 + let span = 224 224 + match peek_token t with 223 225 | Some tok -> tok.span 224 226 | None -> Span.point Position.initial 225 227 in ··· 229 231 (* Track if this document ended explicitly with ... *) 230 232 t.explicit_doc_end <- not implicit; 231 233 t.state <- Implicit_document_start; 232 232 - Event.Document_end { implicit }, span 234 234 + (Event.Document_end { implicit }, span) 233 235 234 236 (** Parse node in various contexts *) 235 237 let parse_node t ~block ~indentless = ··· 238 240 | Token.Alias name -> 239 241 skip_token t; 240 242 t.state <- pop_state t; 241 241 - Event.Alias { anchor = name }, tok.span 242 242 - 243 243 - | Token.Anchor _ | Token.Tag _ -> 243 243 + (Event.Alias { anchor = name }, tok.span) 244 244 + | Token.Anchor _ | Token.Tag _ -> ( 244 245 let anchor, tag = parse_properties t in 245 246 let tok = current_token t in 246 246 - (match tok.token with 247 247 - | Token.Block_entry when indentless -> 248 248 - t.state <- Indentless_sequence_entry; 249 249 - Event.Sequence_start { 250 250 - anchor; tag; 251 251 - implicit = tag = None; 252 252 - style = `Block; 253 253 - }, tok.span 254 254 - 255 255 - | Token.Block_sequence_start when block -> 256 256 - t.state <- Block_sequence_first_entry; 257 257 - skip_token t; 258 258 - Event.Sequence_start { 259 259 - anchor; tag; 260 260 - implicit = tag = None; 261 261 - style = `Block; 262 262 - }, tok.span 263 263 - 264 264 - | Token.Block_mapping_start when block -> 265 265 - t.state <- Block_mapping_first_key; 266 266 - skip_token t; 267 267 - Event.Mapping_start { 268 268 - anchor; tag; 269 269 - implicit = tag = None; 270 270 - style = `Block; 271 271 - }, tok.span 272 272 - 273 273 - | Token.Flow_sequence_start -> 274 274 - t.state <- Flow_sequence_first_entry; 275 275 - skip_token t; 276 276 - Event.Sequence_start { 277 277 - anchor; tag; 278 278 - implicit = tag = None; 279 279 - style = `Flow; 280 280 - }, tok.span 281 281 - 282 282 - | Token.Flow_mapping_start -> 283 283 - t.state <- Flow_mapping_first_key; 284 284 - skip_token t; 285 285 - Event.Mapping_start { 286 286 - anchor; tag; 287 287 - implicit = tag = None; 288 288 - style = `Flow; 289 289 - }, tok.span 290 290 - 291 291 - | Token.Scalar { style; value } -> 292 292 - skip_token t; 293 293 - t.state <- pop_state t; 294 294 - let plain_implicit = tag = None && style = `Plain in 295 295 - let quoted_implicit = tag = None && style <> `Plain in 296 296 - Event.Scalar { 297 297 - anchor; tag; value; 298 298 - plain_implicit; quoted_implicit; style; 299 299 - }, tok.span 300 300 - 301 301 - | _ -> 302 302 - (* Empty node *) 303 303 - t.state <- pop_state t; 304 304 - empty_scalar_event ~anchor ~tag tok.span) 305 305 - 247 247 + match tok.token with 248 248 + | Token.Block_entry when indentless -> 249 249 + t.state <- Indentless_sequence_entry; 250 250 + ( Event.Sequence_start 251 251 + { anchor; tag; implicit = tag = None; style = `Block }, 252 252 + tok.span ) 253 253 + | Token.Block_sequence_start when block -> 254 254 + t.state <- Block_sequence_first_entry; 255 255 + skip_token t; 256 256 + ( Event.Sequence_start 257 257 + { anchor; tag; implicit = tag = None; style = `Block }, 258 258 + tok.span ) 259 259 + | Token.Block_mapping_start when block -> 260 260 + t.state <- Block_mapping_first_key; 261 261 + skip_token t; 262 262 + ( Event.Mapping_start 263 263 + { anchor; tag; implicit = tag = None; style = `Block }, 264 264 + tok.span ) 265 265 + | Token.Flow_sequence_start -> 266 266 + t.state <- Flow_sequence_first_entry; 267 267 + skip_token t; 268 268 + ( Event.Sequence_start 269 269 + { anchor; tag; implicit = tag = None; style = `Flow }, 270 270 + tok.span ) 271 271 + | Token.Flow_mapping_start -> 272 272 + t.state <- Flow_mapping_first_key; 273 273 + skip_token t; 274 274 + ( Event.Mapping_start 275 275 + { anchor; tag; implicit = tag = None; style = `Flow }, 276 276 + tok.span ) 277 277 + | Token.Scalar { style; value } -> 278 278 + skip_token t; 279 279 + t.state <- pop_state t; 280 280 + let plain_implicit = tag = None && style = `Plain in 281 281 + let quoted_implicit = tag = None && style <> `Plain in 282 282 + ( Event.Scalar 283 283 + { anchor; tag; value; plain_implicit; quoted_implicit; style }, 284 284 + tok.span ) 285 285 + | _ -> 286 286 + (* Empty node *) 287 287 + t.state <- pop_state t; 288 288 + empty_scalar_event ~anchor ~tag tok.span) 306 289 | Token.Block_sequence_start when block -> 307 290 t.state <- Block_sequence_first_entry; 308 291 skip_token t; 309 309 - Event.Sequence_start { 310 310 - anchor = None; tag = None; 311 311 - implicit = true; 312 312 - style = `Block; 313 313 - }, tok.span 314 314 - 292 292 + ( Event.Sequence_start 293 293 + { anchor = None; tag = None; implicit = true; style = `Block }, 294 294 + tok.span ) 315 295 | Token.Block_mapping_start when block -> 316 296 t.state <- Block_mapping_first_key; 317 297 skip_token t; 318 318 - Event.Mapping_start { 319 319 - anchor = None; tag = None; 320 320 - implicit = true; 321 321 - style = `Block; 322 322 - }, tok.span 323 323 - 298 298 + ( Event.Mapping_start 299 299 + { anchor = None; tag = None; implicit = true; style = `Block }, 300 300 + tok.span ) 324 301 | Token.Flow_sequence_start -> 325 302 t.state <- Flow_sequence_first_entry; 326 303 skip_token t; 327 327 - Event.Sequence_start { 328 328 - anchor = None; tag = None; 329 329 - implicit = true; 330 330 - style = `Flow; 331 331 - }, tok.span 332 332 - 304 304 + ( Event.Sequence_start 305 305 + { anchor = None; tag = None; implicit = true; style = `Flow }, 306 306 + tok.span ) 333 307 | Token.Flow_mapping_start -> 334 308 t.state <- Flow_mapping_first_key; 335 309 skip_token t; 336 336 - Event.Mapping_start { 337 337 - anchor = None; tag = None; 338 338 - implicit = true; 339 339 - style = `Flow; 340 340 - }, tok.span 341 341 - 310 310 + ( Event.Mapping_start 311 311 + { anchor = None; tag = None; implicit = true; style = `Flow }, 312 312 + tok.span ) 342 313 | Token.Block_entry when indentless -> 343 314 t.state <- Indentless_sequence_entry; 344 344 - Event.Sequence_start { 345 345 - anchor = None; tag = None; 346 346 - implicit = true; 347 347 - style = `Block; 348 348 - }, tok.span 349 349 - 315 315 + ( Event.Sequence_start 316 316 + { anchor = None; tag = None; implicit = true; style = `Block }, 317 317 + tok.span ) 350 318 | Token.Scalar { style; value } -> 351 319 skip_token t; 352 320 t.state <- pop_state t; 353 321 let plain_implicit = style = `Plain in 354 322 let quoted_implicit = style <> `Plain in 355 355 - Event.Scalar { 356 356 - anchor = None; tag = None; value; 357 357 - plain_implicit; quoted_implicit; style; 358 358 - }, tok.span 359 359 - 323 323 + ( Event.Scalar 324 324 + { 325 325 + anchor = None; 326 326 + tag = None; 327 327 + value; 328 328 + plain_implicit; 329 329 + quoted_implicit; 330 330 + style; 331 331 + }, 332 332 + tok.span ) 360 333 | _ -> 361 334 (* Empty node *) 362 335 t.state <- pop_state t; ··· 368 341 match tok.token with 369 342 | Token.Block_entry -> 370 343 skip_token t; 371 371 - if check t (function 372 372 - | Token.Block_entry | Token.Block_end -> true 373 373 - | _ -> false) 344 344 + if 345 345 + check t (function 346 346 + | Token.Block_entry | Token.Block_end -> true 347 347 + | _ -> false) 374 348 then begin 375 349 t.state <- Block_sequence_entry; 376 350 empty_scalar_event ~anchor:None ~tag:None tok.span 377 377 - end else begin 351 351 + end 352 352 + else begin 378 353 push_state t Block_sequence_entry; 379 354 parse_node t ~block:true ~indentless:false 380 355 end 381 356 | Token.Block_end -> 382 357 skip_token t; 383 358 t.state <- pop_state t; 384 384 - Event.Sequence_end, tok.span 385 385 - | _ -> 386 386 - Error.raise_span tok.span Expected_block_entry 359 359 + (Event.Sequence_end, tok.span) 360 360 + | _ -> Error.raise_span tok.span Expected_block_entry 387 361 388 362 (** Parse block mapping key *) 389 363 let parse_block_mapping_key t = ··· 391 365 match tok.token with 392 366 | Token.Key -> 393 367 skip_token t; 394 394 - if check t (function 395 395 - | Token.Key | Token.Value | Token.Block_end -> true 396 396 - | _ -> false) 368 368 + if 369 369 + check t (function 370 370 + | Token.Key | Token.Value | Token.Block_end -> true 371 371 + | _ -> false) 397 372 then begin 398 373 t.state <- Block_mapping_value; 399 374 empty_scalar_event ~anchor:None ~tag:None tok.span 400 400 - end else begin 375 375 + end 376 376 + else begin 401 377 push_state t Block_mapping_value; 402 378 parse_node t ~block:true ~indentless:true 403 379 end ··· 408 384 | Token.Block_end -> 409 385 skip_token t; 410 386 t.state <- pop_state t; 411 411 - Event.Mapping_end, tok.span 412 412 - | _ -> 413 413 - Error.raise_span tok.span Expected_key 387 387 + (Event.Mapping_end, tok.span) 388 388 + | _ -> Error.raise_span tok.span Expected_key 414 389 415 390 (** Parse block mapping value *) 416 391 let parse_block_mapping_value t = ··· 418 393 match tok.token with 419 394 | Token.Value -> 420 395 skip_token t; 421 421 - if check t (function 422 422 - | Token.Key | Token.Value | Token.Block_end -> true 423 423 - | _ -> false) 396 396 + if 397 397 + check t (function 398 398 + | Token.Key | Token.Value | Token.Block_end -> true 399 399 + | _ -> false) 424 400 then begin 425 401 t.state <- Block_mapping_key; 426 402 empty_scalar_event ~anchor:None ~tag:None tok.span 427 427 - end else begin 403 403 + end 404 404 + else begin 428 405 push_state t Block_mapping_key; 429 406 parse_node t ~block:true ~indentless:true 430 407 end ··· 439 416 match tok.token with 440 417 | Token.Block_entry -> 441 418 skip_token t; 442 442 - if check t (function 443 443 - | Token.Block_entry | Token.Key | Token.Value | Token.Block_end -> true 444 444 - | _ -> false) 419 419 + if 420 420 + check t (function 421 421 + | Token.Block_entry | Token.Key | Token.Value | Token.Block_end -> 422 422 + true 423 423 + | _ -> false) 445 424 then begin 446 425 t.state <- Indentless_sequence_entry; 447 426 empty_scalar_event ~anchor:None ~tag:None tok.span 448 448 - end else begin 427 427 + end 428 428 + else begin 449 429 push_state t Indentless_sequence_entry; 450 430 parse_node t ~block:true ~indentless:false 451 431 end 452 432 | _ -> 453 433 t.state <- pop_state t; 454 454 - Event.Sequence_end, tok.span 434 434 + (Event.Sequence_end, tok.span) 455 435 456 436 (** Parse flow sequence *) 457 437 let rec parse_flow_sequence_entry t ~first = ··· 460 440 | Token.Flow_sequence_end -> 461 441 skip_token t; 462 442 t.state <- pop_state t; 463 463 - Event.Sequence_end, tok.span 443 443 + (Event.Sequence_end, tok.span) 464 444 | Token.Flow_entry when not first -> 465 445 skip_token t; 466 446 parse_flow_sequence_entry_internal t 467 467 - | _ when first -> 468 468 - parse_flow_sequence_entry_internal t 469 469 - | _ -> 470 470 - Error.raise_span tok.span Expected_sequence_end 447 447 + | _ when first -> parse_flow_sequence_entry_internal t 448 448 + | _ -> Error.raise_span tok.span Expected_sequence_end 471 449 472 450 and parse_flow_sequence_entry_internal t = 473 451 let tok = current_token t in ··· 476 454 (* Trailing comma case - don't emit empty scalar, just go back to sequence entry state *) 477 455 skip_token t; 478 456 t.state <- pop_state t; 479 479 - Event.Sequence_end, tok.span 457 457 + (Event.Sequence_end, tok.span) 480 458 | Token.Flow_entry -> 481 459 (* Double comma or comma after comma - invalid *) 482 482 - Error.raise_span tok.span (Unexpected_token "unexpected ',' in flow sequence") 460 460 + Error.raise_span tok.span 461 461 + (Unexpected_token "unexpected ',' in flow sequence") 483 462 | Token.Key -> 484 463 skip_token t; 485 464 t.state <- Flow_sequence_entry_mapping_key; 486 486 - Event.Mapping_start { 487 487 - anchor = None; tag = None; 488 488 - implicit = true; 489 489 - style = `Flow; 490 490 - }, tok.span 465 465 + ( Event.Mapping_start 466 466 + { anchor = None; tag = None; implicit = true; style = `Flow }, 467 467 + tok.span ) 491 468 | Token.Value -> 492 469 (* Implicit empty key mapping: [ : value ] *) 493 470 t.state <- Flow_sequence_entry_mapping_key; 494 494 - Event.Mapping_start { 495 495 - anchor = None; tag = None; 496 496 - implicit = true; 497 497 - style = `Flow; 498 498 - }, tok.span 471 471 + ( Event.Mapping_start 472 472 + { anchor = None; tag = None; implicit = true; style = `Flow }, 473 473 + tok.span ) 499 474 | _ -> 500 475 push_state t Flow_sequence_entry; 501 476 parse_node t ~block:false ~indentless:false ··· 503 478 (** Parse flow sequence entry mapping *) 504 479 let parse_flow_sequence_entry_mapping_key t = 505 480 let tok = current_token t in 506 506 - if check t (function 507 507 - | Token.Value | Token.Flow_entry | Token.Flow_sequence_end -> true 508 508 - | _ -> false) 481 481 + if 482 482 + check t (function 483 483 + | Token.Value | Token.Flow_entry | Token.Flow_sequence_end -> true 484 484 + | _ -> false) 509 485 then begin 510 486 t.state <- Flow_sequence_entry_mapping_value; 511 487 empty_scalar_event ~anchor:None ~tag:None tok.span 512 512 - end else begin 488 488 + end 489 489 + else begin 513 490 push_state t Flow_sequence_entry_mapping_value; 514 491 parse_node t ~block:false ~indentless:false 515 492 end ··· 519 496 match tok.token with 520 497 | Token.Value -> 521 498 skip_token t; 522 522 - if check t (function 523 523 - | Token.Flow_entry | Token.Flow_sequence_end -> true 524 524 - | _ -> false) 499 499 + if 500 500 + check t (function 501 501 + | Token.Flow_entry | Token.Flow_sequence_end -> true 502 502 + | _ -> false) 525 503 then begin 526 504 t.state <- Flow_sequence_entry_mapping_end; 527 505 empty_scalar_event ~anchor:None ~tag:None tok.span 528 528 - end else begin 506 506 + end 507 507 + else begin 529 508 push_state t Flow_sequence_entry_mapping_end; 530 509 parse_node t ~block:false ~indentless:false 531 510 end ··· 536 515 let parse_flow_sequence_entry_mapping_end t = 537 516 let tok = current_token t in 538 517 t.state <- Flow_sequence_entry; 539 539 - Event.Mapping_end, tok.span 518 518 + (Event.Mapping_end, tok.span) 540 519 541 520 (** Parse flow mapping *) 542 521 let rec parse_flow_mapping_key t ~first = ··· 545 524 | Token.Flow_mapping_end -> 546 525 skip_token t; 547 526 t.state <- pop_state t; 548 548 - Event.Mapping_end, tok.span 527 527 + (Event.Mapping_end, tok.span) 549 528 | Token.Flow_entry when not first -> 550 529 skip_token t; 551 530 parse_flow_mapping_key_internal t 552 552 - | _ when first -> 553 553 - parse_flow_mapping_key_internal t 554 554 - | _ -> 555 555 - Error.raise_span tok.span Expected_mapping_end 531 531 + | _ when first -> parse_flow_mapping_key_internal t 532 532 + | _ -> Error.raise_span tok.span Expected_mapping_end 556 533 557 534 and parse_flow_mapping_key_internal t = 558 535 let tok = current_token t in ··· 561 538 (* Trailing comma case - don't emit empty scalar, just return to key state *) 562 539 skip_token t; 563 540 t.state <- pop_state t; 564 564 - Event.Mapping_end, tok.span 541 541 + (Event.Mapping_end, tok.span) 565 542 | Token.Flow_entry -> 566 543 (* Double comma or comma after comma - invalid *) 567 567 - Error.raise_span tok.span (Unexpected_token "unexpected ',' in flow mapping") 544 544 + Error.raise_span tok.span 545 545 + (Unexpected_token "unexpected ',' in flow mapping") 568 546 | Token.Key -> 569 547 skip_token t; 570 570 - if check t (function 571 571 - | Token.Value | Token.Flow_entry | Token.Flow_mapping_end -> true 572 572 - | _ -> false) 548 548 + if 549 549 + check t (function 550 550 + | Token.Value | Token.Flow_entry | Token.Flow_mapping_end -> true 551 551 + | _ -> false) 573 552 then begin 574 553 t.state <- Flow_mapping_value; 575 554 empty_scalar_event ~anchor:None ~tag:None tok.span 576 576 - end else begin 555 555 + end 556 556 + else begin 577 557 push_state t Flow_mapping_value; 578 558 parse_node t ~block:false ~indentless:false 579 559 end ··· 586 566 if empty then begin 587 567 t.state <- Flow_mapping_key; 588 568 empty_scalar_event ~anchor:None ~tag:None tok.span 589 589 - end else 569 569 + end 570 570 + else 590 571 match tok.token with 591 572 | Token.Value -> 592 573 skip_token t; 593 593 - if check t (function 594 594 - | Token.Flow_entry | Token.Flow_mapping_end -> true 595 595 - | _ -> false) 574 574 + if 575 575 + check t (function 576 576 + | Token.Flow_entry | Token.Flow_mapping_end -> true 577 577 + | _ -> false) 596 578 then begin 597 579 t.state <- Flow_mapping_key; 598 580 empty_scalar_event ~anchor:None ~tag:None tok.span 599 599 - end else begin 581 581 + end 582 582 + else begin 600 583 push_state t Flow_mapping_key; 601 584 parse_node t ~block:false ~indentless:false 602 585 end ··· 607 590 (** Main state machine dispatcher *) 608 591 let rec parse t = 609 592 match t.state with 610 610 - | Stream_start -> 611 611 - parse_stream_start t 612 612 - 613 613 - | Implicit_document_start -> 593 593 + | Stream_start -> parse_stream_start t 594 594 + | Implicit_document_start -> ( 614 595 (* Skip any document end markers before checking what's next *) 615 596 while check t (function Token.Document_end -> true | _ -> false) do 616 616 - t.explicit_doc_end <- true; (* Seeing ... counts as explicit end *) 597 597 + t.explicit_doc_end <- true; 598 598 + (* Seeing ... counts as explicit end *) 617 599 skip_token t 618 600 done; 619 601 620 602 let tok = current_token t in 621 621 - (match tok.token with 622 622 - | Token.Stream_end -> 623 623 - skip_token t; 624 624 - t.state <- End; 625 625 - t.finished <- true; 626 626 - Event.Stream_end, tok.span 627 627 - | Token.Version_directive _ | Token.Tag_directive _ -> 628 628 - (* Directives are only allowed at stream start or after explicit ... (MUS6/01) *) 629 629 - if not t.stream_start && not t.explicit_doc_end then 630 630 - Error.raise_span tok.span (Invalid_directive "directives require explicit document end '...' before them"); 631 631 - parse_document_start t ~implicit:false 632 632 - | Token.Document_start -> 633 633 - parse_document_start t ~implicit:false 634 634 - (* These tokens are invalid at document start - they indicate leftover junk *) 635 635 - | Token.Flow_sequence_end | Token.Flow_mapping_end | Token.Flow_entry 636 636 - | Token.Block_end | Token.Value -> 637 637 - Error.raise_span tok.span (Unexpected_token "unexpected token at document start") 638 638 - | _ -> 639 639 - parse_document_start t ~implicit:true) 603 603 + match tok.token with 604 604 + | Token.Stream_end -> 605 605 + skip_token t; 606 606 + t.state <- End; 607 607 + t.finished <- true; 608 608 + (Event.Stream_end, tok.span) 609 609 + | Token.Version_directive _ | Token.Tag_directive _ -> 610 610 + (* Directives are only allowed at stream start or after explicit ... (MUS6/01) *) 611 611 + if (not t.stream_start) && not t.explicit_doc_end then 612 612 + Error.raise_span tok.span 613 613 + (Invalid_directive 614 614 + "directives require explicit document end '...' before them"); 615 615 + parse_document_start t ~implicit:false 616 616 + | Token.Document_start -> parse_document_start t ~implicit:false 617 617 + (* These tokens are invalid at document start - they indicate leftover junk *) 618 618 + | Token.Flow_sequence_end | Token.Flow_mapping_end | Token.Flow_entry 619 619 + | Token.Block_end | Token.Value -> 620 620 + Error.raise_span tok.span 621 621 + (Unexpected_token "unexpected token at document start") 622 622 + | _ -> parse_document_start t ~implicit:true) 640 623 641 624 | Document_content -> 642 642 - if check t (function 643 643 - | Token.Version_directive _ | Token.Tag_directive _ 644 644 - | Token.Document_start | Token.Document_end | Token.Stream_end -> true 645 645 - | _ -> false) 625 625 + if 626 626 + check t (function 627 627 + | Token.Version_directive _ | Token.Tag_directive _ 628 628 + | Token.Document_start | Token.Document_end | Token.Stream_end -> 629 629 + true 630 630 + | _ -> false) 646 631 then begin 647 632 let tok = current_token t in 648 633 t.state <- pop_state t; 649 634 empty_scalar_event ~anchor:None ~tag:None tok.span 650 650 - end else begin 635 635 + end 636 636 + else begin 651 637 (* Push Document_content_done so we return there after parsing the node. 652 638 This allows us to check for unexpected content after the node. *) 653 639 push_state t Document_content_done; 654 640 parse_node t ~block:true ~indentless:false 655 641 end 656 656 - 657 642 | Document_content_done -> 658 643 (* After parsing a node in document content, check for unexpected content *) 659 659 - if check t (function 660 660 - | Token.Version_directive _ | Token.Tag_directive _ 661 661 - | Token.Document_start | Token.Document_end | Token.Stream_end -> true 662 662 - | _ -> false) 644 644 + if 645 645 + check t (function 646 646 + | Token.Version_directive _ | Token.Tag_directive _ 647 647 + | Token.Document_start | Token.Document_end | Token.Stream_end -> 648 648 + true 649 649 + | _ -> false) 663 650 then begin 664 651 (* Valid document boundary - continue to Document_end *) 665 652 t.state <- pop_state t; 666 666 - parse t (* Continue to emit the next event *) 667 667 - end else begin 653 653 + parse t (* Continue to emit the next event *) 654 654 + end 655 655 + else begin 668 656 (* Unexpected content after document value - this is an error (KS4U, BS4K) *) 669 657 let tok = current_token t in 670 658 Error.raise_span tok.span 671 659 (Unexpected_token "content not allowed after document value") 672 660 end 673 673 - 674 674 - | Document_end -> 675 675 - parse_document_end t 661 661 + | Document_end -> parse_document_end t 676 662 677 663 | Block_sequence_first_entry -> 678 664 t.state <- Block_sequence_entry; 679 665 parse_block_sequence_entry t 680 680 - 681 681 - | Block_sequence_entry -> 682 682 - parse_block_sequence_entry t 683 683 - 684 684 - | Indentless_sequence_entry -> 685 685 - parse_indentless_sequence_entry t 686 686 - 666 666 + | Block_sequence_entry -> parse_block_sequence_entry t 667 667 + | Indentless_sequence_entry -> parse_indentless_sequence_entry t 687 668 | Block_mapping_first_key -> 688 669 t.state <- Block_mapping_key; 689 670 parse_block_mapping_key t 690 690 - 691 691 - | Block_mapping_key -> 692 692 - parse_block_mapping_key t 693 693 - 694 694 - | Block_mapping_value -> 695 695 - parse_block_mapping_value t 696 696 - 697 697 - | Flow_sequence_first_entry -> 698 698 - parse_flow_sequence_entry t ~first:true 699 699 - 700 700 - | Flow_sequence_entry -> 701 701 - parse_flow_sequence_entry t ~first:false 702 702 - 703 703 - | Flow_sequence_entry_mapping_key -> 704 704 - parse_flow_sequence_entry_mapping_key t 705 705 - 671 671 + | Block_mapping_key -> parse_block_mapping_key t 672 672 + | Block_mapping_value -> parse_block_mapping_value t 673 673 + | Flow_sequence_first_entry -> parse_flow_sequence_entry t ~first:true 674 674 + | Flow_sequence_entry -> parse_flow_sequence_entry t ~first:false 675 675 + | Flow_sequence_entry_mapping_key -> parse_flow_sequence_entry_mapping_key t 706 676 | Flow_sequence_entry_mapping_value -> 707 677 parse_flow_sequence_entry_mapping_value t 708 708 - 709 709 - | Flow_sequence_entry_mapping_end -> 710 710 - parse_flow_sequence_entry_mapping_end t 711 711 - 712 712 - | Flow_mapping_first_key -> 713 713 - parse_flow_mapping_key t ~first:true 714 714 - 715 715 - | Flow_mapping_key -> 716 716 - parse_flow_mapping_key t ~first:false 717 717 - 718 718 - | Flow_mapping_value -> 719 719 - parse_flow_mapping_value t ~empty:false 678 678 + | Flow_sequence_entry_mapping_end -> parse_flow_sequence_entry_mapping_end t 679 679 + | Flow_mapping_first_key -> parse_flow_mapping_key t ~first:true 680 680 + | Flow_mapping_key -> parse_flow_mapping_key t ~first:false 681 681 + | Flow_mapping_value -> parse_flow_mapping_value t ~empty:false 720 682 721 683 | End -> 722 684 let span = Span.point Position.initial in 723 685 t.finished <- true; 724 724 - Event.Stream_end, span 686 686 + (Event.Stream_end, span) 725 687 726 688 (** Get next event *) 727 689 let next t = ··· 735 697 let rec loop () = 736 698 match next t with 737 699 | None -> () 738 738 - | Some ev -> f ev; loop () 700 700 + | Some ev -> 701 701 + f ev; 702 702 + loop () 739 703 in 740 704 loop () 741 705 742 706 (** Fold over all events *) 743 707 let fold f init t = 744 708 let rec loop acc = 745 745 - match next t with 746 746 - | None -> acc 747 747 - | Some ev -> loop (f acc ev) 709 709 + match next t with None -> acc | Some ev -> loop (f acc ev) 748 710 in 749 711 loop init 750 712 751 713 (** Convert to list *) 752 752 - let to_list t = 753 753 - fold (fun acc ev -> ev :: acc) [] t |> List.rev 714 714 + let to_list t = fold (fun acc ev -> ev :: acc) [] t |> List.rev

+11 -28

lib/position.ml

··· 6 6 (** Position tracking for source locations *) 7 7 8 8 type t = { 9 9 - index : int; (** Byte offset from start *) 10 10 - line : int; (** 1-indexed line number *) 9 9 + index : int; (** Byte offset from start *) 10 10 + line : int; (** 1-indexed line number *) 11 11 column : int; (** 1-indexed column number *) 12 12 } 13 13 14 14 let initial = { index = 0; line = 1; column = 1 } 15 15 - 16 16 - let advance_byte t = 17 17 - { t with index = t.index + 1; column = t.column + 1 } 18 18 - 19 19 - let advance_line t = 20 20 - { index = t.index + 1; line = t.line + 1; column = 1 } 21 21 - 22 22 - let advance_char c t = 23 23 - if c = '\n' then advance_line t 24 24 - else advance_byte t 15 15 + let advance_byte t = { t with index = t.index + 1; column = t.column + 1 } 16 16 + let advance_line t = { index = t.index + 1; line = t.line + 1; column = 1 } 17 17 + let advance_char c t = if c = '\n' then advance_line t else advance_byte t 25 18 26 19 let advance_utf8 uchar t = 27 20 let len = Uchar.utf_8_byte_length uchar in 28 21 let code = Uchar.to_int uchar in 29 22 if code = 0x0A (* LF *) then 30 23 { index = t.index + len; line = t.line + 1; column = 1 } 31 31 - else 32 32 - { t with index = t.index + len; column = t.column + 1 } 24 24 + else { t with index = t.index + len; column = t.column + 1 } 33 25 34 34 - let advance_bytes n t = 35 35 - { t with index = t.index + n; column = t.column + n } 36 36 - 37 37 - let pp fmt t = 38 38 - Format.fprintf fmt "line %d, column %d" t.line t.column 39 39 - 40 40 - let to_string t = 41 41 - Format.asprintf "%a" pp t 42 42 - 43 43 - let compare a b = 44 44 - Int.compare a.index b.index 45 45 - 46 46 - let equal a b = 47 47 - a.index = b.index 26 26 + let advance_bytes n t = { t with index = t.index + n; column = t.column + n } 27 27 + let pp fmt t = Format.fprintf fmt "line %d, column %d" t.line t.column 28 28 + let to_string t = Format.asprintf "%a" pp t 29 29 + let compare a b = Int.compare a.index b.index 30 30 + let equal a b = a.index = b.index

+31 -27

lib/quoting.ml

··· 5 5 6 6 (** YAML scalar quoting detection *) 7 7 8 8 - (** Check if a string value needs quoting in YAML output. 9 9 - Returns true if the string: 8 8 + (** Check if a string value needs quoting in YAML output. Returns true if the 9 9 + string: 10 10 - Is empty 11 11 - Starts with an indicator character 12 12 - Is a reserved word (null, true, false, yes, no, etc.) ··· 17 17 else 18 18 let first = s.[0] in 19 19 (* Check first character for indicators *) 20 20 - if first = '-' || first = '?' || first = ':' || first = ',' || 21 21 - first = '[' || first = ']' || first = '{' || first = '}' || 22 22 - first = '#' || first = '&' || first = '*' || first = '!' || 23 23 - first = '|' || first = '>' || first = '\'' || first = '"' || 24 24 - first = '%' || first = '@' || first = '`' || first = ' ' then 25 25 - true 20 20 + if 21 21 + first = '-' || first = '?' || first = ':' || first = ',' || first = '[' 22 22 + || first = ']' || first = '{' || first = '}' || first = '#' || first = '&' 23 23 + || first = '*' || first = '!' || first = '|' || first = '>' 24 24 + || first = '\'' || first = '"' || first = '%' || first = '@' 25 25 + || first = '`' || first = ' ' 26 26 + then true 26 27 else 27 28 (* Check for reserved/special values *) 28 29 let lower = String.lowercase_ascii s in 29 29 - if lower = "null" || lower = "true" || lower = "false" || 30 30 - lower = "yes" || lower = "no" || lower = "on" || lower = "off" || 31 31 - lower = "~" || lower = ".inf" || lower = "-.inf" || lower = ".nan" then 32 32 - true 30 30 + if 31 31 + lower = "null" || lower = "true" || lower = "false" || lower = "yes" 32 32 + || lower = "no" || lower = "on" || lower = "off" || lower = "~" 33 33 + || lower = ".inf" || lower = "-.inf" || lower = ".nan" 34 34 + then true 33 35 else 34 36 (* Check for problematic characters *) 35 37 try 36 36 - String.iter (fun c -> 37 37 - if c = ':' || c = '#' || c = '\n' || c = '\r' then 38 38 - raise Exit 39 39 - ) s; 38 38 + String.iter 39 39 + (fun c -> 40 40 + if c = ':' || c = '#' || c = '\n' || c = '\r' then raise Exit) 41 41 + s; 40 42 (* Check if it looks like a number *) 41 41 - (try ignore (Float.of_string s); true with _ -> false) 43 43 + try 44 44 + ignore (Float.of_string s); 45 45 + true 46 46 + with _ -> false 42 47 with Exit -> true 43 48 44 44 - (** Check if a string requires double quotes (vs single quotes). 45 45 - Returns true if the string contains characters that need escape sequences. *) 49 49 + (** Check if a string requires double quotes (vs single quotes). Returns true if 50 50 + the string contains characters that need escape sequences. *) 46 51 let needs_double_quotes s = 47 52 try 48 48 - String.iter (fun c -> 49 49 - if c = '\n' || c = '\r' || c = '\t' || c = '\\' || 50 50 - c < ' ' || c = '"' then 51 51 - raise Exit 52 52 - ) s; 53 53 + String.iter 54 54 + (fun c -> 55 55 + if c = '\n' || c = '\r' || c = '\t' || c = '\\' || c < ' ' || c = '"' 56 56 + then raise Exit) 57 57 + s; 53 58 false 54 59 with Exit -> true 55 60 56 61 (** Choose the appropriate quoting style for a string value *) 57 62 let choose_style s = 58 63 match (needs_double_quotes s, needs_quoting s) with 59 59 - | (true, _) -> `Double_quoted 60 60 - | (_, true) -> `Single_quoted 64 64 + | true, _ -> `Double_quoted 65 65 + | _, true -> `Single_quoted 61 66 | _ -> `Plain 62 62 -

+22 -24

lib/scalar.ml

··· 14 14 style : Scalar_style.t; 15 15 } 16 16 17 17 - let make 18 18 - ?(anchor : string option) 19 19 - ?(tag : string option) 20 20 - ?(plain_implicit = true) 21 21 - ?(quoted_implicit = false) 22 22 - ?(style = `Plain) 23 23 - value = 17 17 + let make ?(anchor : string option) ?(tag : string option) 18 18 + ?(plain_implicit = true) ?(quoted_implicit = false) ?(style = `Plain) value 19 19 + = 24 20 { anchor; tag; value; plain_implicit; quoted_implicit; style } 25 21 26 22 let value t = t.value ··· 29 25 let style t = t.style 30 26 let plain_implicit t = t.plain_implicit 31 27 let quoted_implicit t = t.quoted_implicit 32 32 - 33 28 let with_anchor anchor t = { t with anchor = Some anchor } 34 29 let with_tag tag t = { t with tag = Some tag } 35 30 let with_style style t = { t with style } ··· 41 36 Format.fprintf fmt ", style=%a)" Scalar_style.pp t.style 42 37 43 38 let equal a b = 44 44 - Option.equal String.equal a.anchor b.anchor && 45 45 - Option.equal String.equal a.tag b.tag && 46 46 - String.equal a.value b.value && 47 47 - a.plain_implicit = b.plain_implicit && 48 48 - a.quoted_implicit = b.quoted_implicit && 49 49 - Scalar_style.equal a.style b.style 39 39 + Option.equal String.equal a.anchor b.anchor 40 40 + && Option.equal String.equal a.tag b.tag 41 41 + && String.equal a.value b.value 42 42 + && a.plain_implicit = b.plain_implicit 43 43 + && a.quoted_implicit = b.quoted_implicit 44 44 + && Scalar_style.equal a.style b.style 50 45 51 46 let compare a b = 52 47 let c = Option.compare String.compare a.anchor b.anchor in 53 53 - if c <> 0 then c else 54 54 - let c = Option.compare String.compare a.tag b.tag in 55 55 - if c <> 0 then c else 56 56 - let c = String.compare a.value b.value in 57 57 - if c <> 0 then c else 58 58 - let c = Bool.compare a.plain_implicit b.plain_implicit in 59 59 - if c <> 0 then c else 60 60 - let c = Bool.compare a.quoted_implicit b.quoted_implicit in 61 61 - if c <> 0 then c else 62 62 - Scalar_style.compare a.style b.style 48 48 + if c <> 0 then c 49 49 + else 50 50 + let c = Option.compare String.compare a.tag b.tag in 51 51 + if c <> 0 then c 52 52 + else 53 53 + let c = String.compare a.value b.value in 54 54 + if c <> 0 then c 55 55 + else 56 56 + let c = Bool.compare a.plain_implicit b.plain_implicit in 57 57 + if c <> 0 then c 58 58 + else 59 59 + let c = Bool.compare a.quoted_implicit b.quoted_implicit in 60 60 + if c <> 0 then c else Scalar_style.compare a.style b.style

+8 -11

lib/scalar_style.ml

··· 5 5 6 6 (** Scalar formatting styles *) 7 7 8 8 - type t = [ 9 9 - | `Any (** Let emitter choose *) 10 10 - | `Plain (** Unquoted: foo *) 11 11 - | `Single_quoted (** 'foo' *) 12 12 - | `Double_quoted (** "foo" *) 13 13 - | `Literal (** | block *) 14 14 - | `Folded (** > block *) 15 15 - ] 8 8 + type t = 9 9 + [ `Any (** Let emitter choose *) 10 10 + | `Plain (** Unquoted: foo *) 11 11 + | `Single_quoted (** 'foo' *) 12 12 + | `Double_quoted (** "foo" *) 13 13 + | `Literal (** | block *) 14 14 + | `Folded (** > block *) ] 16 15 17 16 let to_string = function 18 17 | `Any -> "any" ··· 22 21 | `Literal -> "literal" 23 22 | `Folded -> "folded" 24 23 25 25 - let pp fmt t = 26 26 - Format.pp_print_string fmt (to_string t) 27 27 - 24 24 + let pp fmt t = Format.pp_print_string fmt (to_string t) 28 25 let equal a b = a = b 29 26 30 27 let compare a b =

+536 -399

lib/scanner.ml

··· 5 5 6 6 (** YAML tokenizer/scanner with lookahead for ambiguity resolution *) 7 7 8 8 - (** Simple key tracking for mapping key disambiguation *) 9 8 type simple_key = { 10 9 sk_possible : bool; 11 10 sk_required : bool; 12 11 sk_token_number : int; 13 12 sk_position : Position.t; 14 13 } 14 14 + (** Simple key tracking for mapping key disambiguation *) 15 15 16 16 - (** Indent level tracking *) 17 16 type indent = { 18 17 indent : int; 19 18 needs_block_end : bool; 20 19 } 20 20 + (** Indent level tracking *) 21 21 22 22 type t = { 23 23 input : Input.t; ··· 27 27 mutable stream_started : bool; 28 28 mutable stream_ended : bool; 29 29 mutable indent_stack : indent list; (** Stack of indentation levels *) 30 30 - mutable flow_level : int; (** Nesting depth in \[\] or \{\} *) 31 31 - mutable flow_indent : int; (** Column where outermost flow collection started *) 32 32 - mutable simple_keys : simple_key option list; (** Per flow-level simple key tracking *) 30 30 + mutable flow_level : int; (** Nesting depth in \[\] or \{\} *) 31 31 + mutable flow_indent : int; 32 32 + (** Column where outermost flow collection started *) 33 33 + mutable simple_keys : simple_key option list; 34 34 + (** Per flow-level simple key tracking *) 33 35 mutable allow_simple_key : bool; 34 34 - mutable leading_whitespace : bool; (** True when at start of line (only whitespace seen) *) 35 35 - mutable document_has_content : bool; (** True if we've emitted content tokens in current document *) 36 36 - mutable adjacent_value_allowed_at : Position.t option; (** Position where adjacent : is allowed *) 37 37 - mutable flow_mapping_stack : bool list; (** Stack of whether each flow level is a mapping *) 36 36 + mutable leading_whitespace : bool; 37 37 + (** True when at start of line (only whitespace seen) *) 38 38 + mutable document_has_content : bool; 39 39 + (** True if we've emitted content tokens in current document *) 40 40 + mutable adjacent_value_allowed_at : Position.t option; 41 41 + (** Position where adjacent : is allowed *) 42 42 + mutable flow_mapping_stack : bool list; 43 43 + (** Stack of whether each flow level is a mapping *) 38 44 } 39 45 40 46 let create input = ··· 48 54 indent_stack = []; 49 55 flow_level = 0; 50 56 flow_indent = 0; 51 51 - simple_keys = [None]; (* One entry for the base level *) 57 57 + simple_keys = [ None ]; 58 58 + (* One entry for the base level *) 52 59 allow_simple_key = true; 53 53 - leading_whitespace = true; (* Start at beginning of stream *) 60 60 + leading_whitespace = true; 61 61 + (* Start at beginning of stream *) 54 62 document_has_content = false; 55 63 adjacent_value_allowed_at = None; 56 64 flow_mapping_stack = []; ··· 59 67 let of_string s = create (Input.of_string s) 60 68 let of_input = create 61 69 let of_reader r = create (Input.of_reader r) 62 62 - 63 70 let position t = Input.position t.input 64 71 65 72 (** Add a token to the queue *) ··· 72 79 73 80 (** Get current indent level *) 74 81 let current_indent t = 75 75 - match t.indent_stack with 76 76 - | [] -> -1 77 77 - | { indent; _ } :: _ -> indent 82 82 + match t.indent_stack with [] -> -1 | { indent; _ } :: _ -> indent 78 83 79 79 - (** Skip whitespace to end of line, checking for valid comments. 80 80 - Returns true if any whitespace (including tabs) was found before a comment. *) 84 84 + (** Skip whitespace to end of line, checking for valid comments. Returns true if 85 85 + any whitespace (including tabs) was found before a comment. *) 81 86 let skip_whitespace_and_comment t = 82 87 let has_whitespace = ref false in 83 88 (* Skip blanks (spaces and tabs) *) ··· 98 103 Error.raise_at (Input.mark t.input) Invalid_comment 99 104 end; 100 105 (* Skip to end of line *) 101 101 - while not (Input.is_eof t.input) && not (Input.next_is_break t.input) do 106 106 + while (not (Input.is_eof t.input)) && not (Input.next_is_break t.input) do 102 107 ignore (Input.next t.input) 103 108 done 104 109 end ··· 109 114 let found_space = ref false in 110 115 while Input.next_is_blank t.input do 111 116 (match Input.peek t.input with 112 112 - | Some '\t' -> found_tab := true 113 113 - | Some ' ' -> found_space := true 114 114 - | _ -> ()); 117 117 + | Some '\t' -> found_tab := true 118 118 + | Some ' ' -> found_space := true 119 119 + | _ -> ()); 115 120 ignore (Input.next t.input) 116 121 done; 117 122 (!found_tab, !found_space) ··· 120 125 let rec skip_to_next_token t = 121 126 (* Check for tabs used as indentation in block context *) 122 127 (match Input.peek t.input with 123 123 - | Some '\t' when t.flow_level = 0 && t.leading_whitespace && 124 124 - (column t - 1) < current_indent t -> 125 125 - (* Tab found in indentation zone - this is invalid *) 126 126 - (* Skip to end of line to check if line has content *) 127 127 - let start_pos = Input.mark t.input in 128 128 - while Input.next_is_blank t.input do 129 129 - ignore (Input.next t.input) 130 130 - done; 131 131 - (* If we have content on this line with a tab, raise error *) 132 132 - if not (Input.next_is_break t.input) && not (Input.is_eof t.input) then 133 133 - Error.raise_at start_pos Tab_in_indentation 134 134 - | _ -> ()); 128 128 + | Some '\t' 129 129 + when t.flow_level = 0 && t.leading_whitespace 130 130 + && column t - 1 < current_indent t -> 131 131 + (* Tab found in indentation zone - this is invalid *) 132 132 + (* Skip to end of line to check if line has content *) 133 133 + let start_pos = Input.mark t.input in 134 134 + while Input.next_is_blank t.input do 135 135 + ignore (Input.next t.input) 136 136 + done; 137 137 + (* If we have content on this line with a tab, raise error *) 138 138 + if (not (Input.next_is_break t.input)) && not (Input.is_eof t.input) then 139 139 + Error.raise_at start_pos Tab_in_indentation 140 140 + | _ -> ()); 135 141 136 142 (* Skip blanks and validate comments *) 137 143 skip_whitespace_and_comment t; ··· 158 164 ignore (Input.next t.input) 159 165 done; 160 166 (* If only tabs were used (no spaces) and column < flow_indent, error *) 161 161 - if not (Input.next_is_break t.input) && not (Input.is_eof t.input) && 162 162 - column t < t.flow_indent then 163 163 - Error.raise_at start_mark Invalid_flow_indentation 167 167 + if 168 168 + (not (Input.next_is_break t.input)) 169 169 + && (not (Input.is_eof t.input)) 170 170 + && column t < t.flow_indent 171 171 + then Error.raise_at start_mark Invalid_flow_indentation 164 172 end; 165 173 skip_to_next_token t 166 166 - end else begin 174 174 + end 175 175 + else begin 167 176 ignore (Input.next t.input); 168 177 skip_to_next_token t 169 178 end ··· 174 183 if t.flow_level = 0 && col > current_indent t then begin 175 184 t.indent_stack <- { indent = col; needs_block_end = true } :: t.indent_stack; 176 185 true 177 177 - end else 178 178 - false 186 186 + end 187 187 + else false 179 188 180 189 (** Unroll indentation to given column *) 181 190 let unroll_indent t col = 182 182 - while t.flow_level = 0 && 183 183 - match t.indent_stack with 184 184 - | { indent; needs_block_end = true; _ } :: _ when indent > col -> true 185 185 - | _ -> false 191 191 + while 192 192 + t.flow_level = 0 193 193 + && 194 194 + match t.indent_stack with 195 195 + | { indent; needs_block_end = true; _ } :: _ when indent > col -> true 196 196 + | _ -> false 186 197 do 187 198 match t.indent_stack with 188 199 | { indent = _; needs_block_end = true; _ } :: rest -> ··· 199 210 (* A simple key is required only if we're in a block context, 200 211 at the current indentation level, AND the current indent needs a block end. 201 212 This matches saphyr's logic and prevents false positives for values. *) 202 202 - let required = t.flow_level = 0 && 203 203 - match t.indent_stack with 204 204 - | { indent; needs_block_end = true; _ } :: _ -> 205 205 - indent = column t 206 206 - | _ -> false 213 213 + let required = 214 214 + t.flow_level = 0 215 215 + && 216 216 + match t.indent_stack with 217 217 + | { indent; needs_block_end = true; _ } :: _ -> indent = column t 218 218 + | _ -> false 207 219 in 208 208 - let sk = { 209 209 - sk_possible = true; 210 210 - sk_required = required; 211 211 - sk_token_number = t.token_number; 212 212 - sk_position = Input.position t.input; 213 213 - } in 220 220 + let sk = 221 221 + { 222 222 + sk_possible = true; 223 223 + sk_required = required; 224 224 + sk_token_number = t.token_number; 225 225 + sk_position = Input.position t.input; 226 226 + } 227 227 + in 214 228 (* Remove any existing simple key at current level *) 215 215 - t.simple_keys <- ( 216 216 - match t.simple_keys with 229 229 + t.simple_keys <- 230 230 + (match t.simple_keys with 217 231 | _ :: rest -> Some sk :: rest 218 218 - | [] -> [Some sk] 219 219 - ) 232 232 + | [] -> [ Some sk ]) 220 233 end 221 234 222 235 (** Remove simple key at current level *) ··· 229 242 230 243 (** Stale simple keys that span too many tokens *) 231 244 let stale_simple_keys t = 232 232 - t.simple_keys <- List.map (fun sk_opt -> 233 233 - match sk_opt with 234 234 - | Some sk when sk.sk_possible && 235 235 - (Input.position t.input).line > sk.sk_position.line && 236 236 - t.flow_level = 0 -> 237 237 - if sk.sk_required then 238 238 - Error.raise_at sk.sk_position Expected_key; 239 239 - None 240 240 - | _ -> sk_opt 241 241 - ) t.simple_keys 245 245 + t.simple_keys <- 246 246 + List.map 247 247 + (fun sk_opt -> 248 248 + match sk_opt with 249 249 + | Some sk 250 250 + when sk.sk_possible 251 251 + && (Input.position t.input).line > sk.sk_position.line 252 252 + && t.flow_level = 0 -> 253 253 + if sk.sk_required then Error.raise_at sk.sk_position Expected_key; 254 254 + None 255 255 + | _ -> sk_opt) 256 256 + t.simple_keys 242 257 243 258 (** Read anchor or alias name *) 244 259 let scan_anchor_alias t = ··· 251 266 This matches the saphyr implementation: is_yaml_non_space && !is_flow *) 252 267 while 253 268 match Input.peek t.input with 254 254 - | Some c when not (Input.is_whitespace c) && 255 255 - not (Input.is_flow_indicator c) && 256 256 - c <> '\x00' -> 269 269 + | Some c 270 270 + when (not (Input.is_whitespace c)) 271 271 + && (not (Input.is_flow_indicator c)) 272 272 + && c <> '\x00' -> 257 273 Buffer.add_char buf c; 258 274 ignore (Input.next t.input); 259 275 true 260 276 | _ -> false 261 261 - do () done; 277 277 + do 278 278 + () 279 279 + done; 262 280 let name = Buffer.contents buf in 263 281 if String.length name = 0 then 264 282 Error.raise_at start (Invalid_anchor "empty anchor name"); ··· 270 288 let buf = Buffer.create 16 in 271 289 (* Expect ! *) 272 290 (match Input.peek t.input with 273 273 - | Some '!' -> 274 274 - Buffer.add_char buf '!'; 275 275 - ignore (Input.next t.input) 276 276 - | _ -> Error.raise_at start (Invalid_tag "expected '!'")); 291 291 + | Some '!' -> 292 292 + Buffer.add_char buf '!'; 293 293 + ignore (Input.next t.input) 294 294 + | _ -> Error.raise_at start (Invalid_tag "expected '!'")); 277 295 (* Read word chars *) 278 296 while 279 297 match Input.peek t.input with ··· 282 300 ignore (Input.next t.input); 283 301 true 284 302 | _ -> false 285 285 - do () done; 303 303 + do 304 304 + () 305 305 + done; 286 306 (* Check for secondary ! *) 287 307 (match Input.peek t.input with 288 288 - | Some '!' -> 289 289 - Buffer.add_char buf '!'; 290 290 - ignore (Input.next t.input) 291 291 - | _ -> ()); 308 308 + | Some '!' -> 309 309 + Buffer.add_char buf '!'; 310 310 + ignore (Input.next t.input) 311 311 + | _ -> ()); 292 312 Buffer.contents buf 293 313 294 314 (** Scan tag suffix (after handle) *) ··· 298 318 in 299 319 let hex_val c = 300 320 match c with 301 301 - | '0'..'9' -> Char.code c - Char.code '0' 302 302 - | 'A'..'F' -> Char.code c - Char.code 'A' + 10 303 303 - | 'a'..'f' -> Char.code c - Char.code 'a' + 10 321 321 + | '0' .. '9' -> Char.code c - Char.code '0' 322 322 + | 'A' .. 'F' -> Char.code c - Char.code 'A' + 10 323 323 + | 'a' .. 'f' -> Char.code c - Char.code 'a' + 10 304 324 | _ -> 0 305 325 in 306 326 let buf = Buffer.create 32 in 307 327 while 308 328 match Input.peek t.input with 309 309 - | Some '%' -> 329 329 + | Some '%' -> ( 310 330 (* Percent-encoded character *) 311 331 ignore (Input.next t.input); 312 312 - (match Input.peek t.input, Input.peek_nth t.input 1 with 313 313 - | Some c1, Some c2 when is_hex_digit c1 && is_hex_digit c2 -> 314 314 - ignore (Input.next t.input); 315 315 - ignore (Input.next t.input); 316 316 - let code = (hex_val c1) * 16 + (hex_val c2) in 317 317 - Buffer.add_char buf (Char.chr code); 318 318 - true 319 319 - | _ -> 320 320 - (* Invalid percent encoding - keep the % *) 321 321 - Buffer.add_char buf '%'; 322 322 - true) 323 323 - | Some c when not (Input.is_whitespace c) && 324 324 - not (Input.is_flow_indicator c) -> 332 332 + match (Input.peek t.input, Input.peek_nth t.input 1) with 333 333 + | Some c1, Some c2 when is_hex_digit c1 && is_hex_digit c2 -> 334 334 + ignore (Input.next t.input); 335 335 + ignore (Input.next t.input); 336 336 + let code = (hex_val c1 * 16) + hex_val c2 in 337 337 + Buffer.add_char buf (Char.chr code); 338 338 + true 339 339 + | _ -> 340 340 + (* Invalid percent encoding - keep the % *) 341 341 + Buffer.add_char buf '%'; 342 342 + true) 343 343 + | Some c 344 344 + when (not (Input.is_whitespace c)) && not (Input.is_flow_indicator c) -> 325 345 Buffer.add_char buf c; 326 346 ignore (Input.next t.input); 327 347 true 328 348 | _ -> false 329 329 - do () done; 349 349 + do 350 350 + () 351 351 + done; 330 352 Buffer.contents buf 331 353 332 354 (** Scan a tag *) 333 355 let scan_tag t = 334 356 let start = Input.mark t.input in 335 335 - ignore (Input.next t.input); (* consume ! *) 357 357 + ignore (Input.next t.input); 358 358 + (* consume ! *) 336 359 let handle, suffix = 337 360 match Input.peek t.input with 338 361 | Some '<' -> ··· 346 369 Buffer.add_char buf c; 347 370 ignore (Input.next t.input); 348 371 true 349 349 - | None -> Error.raise_at (Input.mark t.input) (Invalid_tag "unclosed verbatim tag") 350 350 - do () done; 351 351 - ignore (Input.next t.input); (* consume > *) 372 372 + | None -> 373 373 + Error.raise_at (Input.mark t.input) 374 374 + (Invalid_tag "unclosed verbatim tag") 375 375 + do 376 376 + () 377 377 + done; 378 378 + ignore (Input.next t.input); 379 379 + (* consume > *) 352 380 ("", Buffer.contents buf) 353 381 | Some c when Input.is_whitespace c || Input.is_flow_indicator c -> 354 382 (* Non-specific tag: ! *) 355 383 ("!", "") 356 384 | Some '!' -> 357 385 (* Secondary handle: !! *) 358 358 - ignore (Input.next t.input); (* consume second ! *) 386 386 + ignore (Input.next t.input); 387 387 + (* consume second ! *) 359 388 let suffix = scan_tag_suffix t in 360 389 ("!!", suffix) 361 361 - | _ -> 390 390 + | _ -> ( 362 391 (* Primary handle or just suffix: !foo or !e!foo *) 363 392 (* Read alphanumeric characters *) 364 393 let buf = Buffer.create 16 in ··· 369 398 ignore (Input.next t.input); 370 399 true 371 400 | _ -> false 372 372 - do () done; 401 401 + do 402 402 + () 403 403 + done; 373 404 (* Check if next character is ! - if so, this is a named handle *) 374 374 - (match Input.peek t.input with 375 375 - | Some '!' -> 376 376 - (* Named handle like !e! *) 377 377 - ignore (Input.next t.input); 378 378 - let handle_name = Buffer.contents buf in 379 379 - let suffix = scan_tag_suffix t in 380 380 - ("!" ^ handle_name ^ "!", suffix) 381 381 - | _ -> 382 382 - (* Just ! followed by suffix *) 383 383 - ("!", Buffer.contents buf ^ scan_tag_suffix t)) 405 405 + match Input.peek t.input with 406 406 + | Some '!' -> 407 407 + (* Named handle like !e! *) 408 408 + ignore (Input.next t.input); 409 409 + let handle_name = Buffer.contents buf in 410 410 + let suffix = scan_tag_suffix t in 411 411 + ("!" ^ handle_name ^ "!", suffix) 412 412 + | _ -> 413 413 + (* Just ! followed by suffix *) 414 414 + ("!", Buffer.contents buf ^ scan_tag_suffix t)) 384 415 in 385 416 (* Validate that tag is followed by whitespace, break, or (in flow) flow indicator *) 386 417 (match Input.peek t.input with 387 387 - | None -> () (* EOF is ok *) 388 388 - | Some c when Input.is_whitespace c || Input.is_break c -> () 389 389 - | Some c when t.flow_level > 0 && Input.is_flow_indicator c -> () 390 390 - | _ -> Error.raise_at start (Invalid_tag "expected whitespace or line break after tag")); 418 418 + | None -> () (* EOF is ok *) 419 419 + | Some c when Input.is_whitespace c || Input.is_break c -> () 420 420 + | Some c when t.flow_level > 0 && Input.is_flow_indicator c -> () 421 421 + | _ -> 422 422 + Error.raise_at start 423 423 + (Invalid_tag "expected whitespace or line break after tag")); 391 424 let span = Span.make ~start ~stop:(Input.mark t.input) in 392 425 (handle, suffix, span) 393 426 394 427 (** Scan single-quoted scalar *) 395 428 let scan_single_quoted t = 396 429 let start = Input.mark t.input in 397 397 - ignore (Input.next t.input); (* consume opening single-quote *) 430 430 + ignore (Input.next t.input); 431 431 + (* consume opening single-quote *) 398 432 let buf = Buffer.create 64 in 399 399 - let whitespace = Buffer.create 16 in (* Track trailing whitespace *) 433 433 + let whitespace = Buffer.create 16 in 434 434 + (* Track trailing whitespace *) 400 435 401 436 let flush_whitespace () = 402 437 if Buffer.length whitespace > 0 then begin ··· 408 443 let rec loop () = 409 444 match Input.peek t.input with 410 445 | None -> Error.raise_at start Unclosed_single_quote 411 411 - | Some '\'' -> 446 446 + | Some '\'' -> ( 412 447 ignore (Input.next t.input); 413 448 (* Check for escaped quote ('') *) 414 414 - (match Input.peek t.input with 415 415 - | Some '\'' -> 416 416 - flush_whitespace (); 417 417 - Buffer.add_char buf '\''; 418 418 - ignore (Input.next t.input); 419 419 - loop () 420 420 - | _ -> 421 421 - (* End of string - flush any trailing whitespace *) 422 422 - flush_whitespace ()) 449 449 + match Input.peek t.input with 450 450 + | Some '\'' -> 451 451 + flush_whitespace (); 452 452 + Buffer.add_char buf '\''; 453 453 + ignore (Input.next t.input); 454 454 + loop () 455 455 + | _ -> 456 456 + (* End of string - flush any trailing whitespace *) 457 457 + flush_whitespace ()) 423 458 | Some ' ' | Some '\t' -> 424 459 (* Track whitespace - don't add to buf yet *) 425 460 Buffer.add_char whitespace (Option.get (Input.peek t.input)); ··· 439 474 (* Check indentation: continuation must be > block indent (QB6E, DK95) *) 440 475 let col = column t in 441 476 let indent = current_indent t in 442 442 - if not (Input.is_eof t.input) && not (Input.next_is_break t.input) && col <= indent && indent >= 0 then 443 443 - Error.raise_at (Input.mark t.input) (Invalid_quoted_scalar_indentation "invalid indentation in quoted scalar"); 477 477 + if 478 478 + (not (Input.is_eof t.input)) 479 479 + && (not (Input.next_is_break t.input)) 480 480 + && col <= indent && indent >= 0 481 481 + then 482 482 + Error.raise_at (Input.mark t.input) 483 483 + (Invalid_quoted_scalar_indentation 484 484 + "invalid indentation in quoted scalar"); 444 485 (* Count empty lines (consecutive line breaks) *) 445 486 let empty_lines = ref 0 in 446 487 while Input.next_is_break t.input do ··· 454 495 (* Check indentation after each empty line too *) 455 496 let col = column t in 456 497 let indent = current_indent t in 457 457 - if not (Input.is_eof t.input) && not (Input.next_is_break t.input) && col <= indent && indent >= 0 then 458 458 - Error.raise_at (Input.mark t.input) (Invalid_quoted_scalar_indentation "invalid indentation in quoted scalar") 498 498 + if 499 499 + (not (Input.is_eof t.input)) 500 500 + && (not (Input.next_is_break t.input)) 501 501 + && col <= indent && indent >= 0 502 502 + then 503 503 + Error.raise_at (Input.mark t.input) 504 504 + (Invalid_quoted_scalar_indentation 505 505 + "invalid indentation in quoted scalar") 459 506 done; 460 507 (* Apply folding rules *) 461 508 if !empty_lines > 0 then begin ··· 463 510 for _ = 1 to !empty_lines do 464 511 Buffer.add_char buf '\n' 465 512 done 466 466 - end else 513 513 + end 514 514 + else 467 515 (* Single break: fold to space (even at start of string) *) 468 516 Buffer.add_char buf ' '; 469 517 loop () ··· 486 534 | Some c when Input.is_hex c -> 487 535 Buffer.add_char buf c; 488 536 ignore (Input.next t.input) 489 489 - | _ -> 490 490 - Error.raise_at start (Invalid_hex_escape (Buffer.contents buf)) 537 537 + | _ -> Error.raise_at start (Invalid_hex_escape (Buffer.contents buf)) 491 538 done; 492 539 let code = int_of_string ("0x" ^ Buffer.contents buf) in 493 493 - if code <= 0x7F then 494 494 - String.make 1 (Char.chr code) 540 540 + if code <= 0x7F then String.make 1 (Char.chr code) 495 541 else if code <= 0x7FF then 496 542 let b1 = 0xC0 lor (code lsr 6) in 497 543 let b2 = 0x80 lor (code land 0x3F) in ··· 500 546 let b1 = 0xE0 lor (code lsr 12) in 501 547 let b2 = 0x80 lor ((code lsr 6) land 0x3F) in 502 548 let b3 = 0x80 lor (code land 0x3F) in 503 503 - String.init 3 (fun i -> Char.chr (match i with 0 -> b1 | 1 -> b2 | _ -> b3)) 549 549 + String.init 3 (fun i -> 550 550 + Char.chr (match i with 0 -> b1 | 1 -> b2 | _ -> b3)) 504 551 else 505 552 let b1 = 0xF0 lor (code lsr 18) in 506 553 let b2 = 0x80 lor ((code lsr 12) land 0x3F) in 507 554 let b3 = 0x80 lor ((code lsr 6) land 0x3F) in 508 555 let b4 = 0x80 lor (code land 0x3F) in 509 509 - String.init 4 (fun i -> Char.chr (match i with 0 -> b1 | 1 -> b2 | 2 -> b3 | _ -> b4)) 556 556 + String.init 4 (fun i -> 557 557 + Char.chr (match i with 0 -> b1 | 1 -> b2 | 2 -> b3 | _ -> b4)) 510 558 511 559 (** Scan double-quoted scalar *) 512 560 let scan_double_quoted t = 513 561 let start = Input.mark t.input in 514 514 - ignore (Input.next t.input); (* consume opening double-quote *) 562 562 + ignore (Input.next t.input); 563 563 + (* consume opening double-quote *) 515 564 let buf = Buffer.create 64 in 516 516 - let whitespace = Buffer.create 16 in (* Track pending whitespace *) 565 565 + let whitespace = Buffer.create 16 in 566 566 + (* Track pending whitespace *) 517 567 518 568 let flush_whitespace () = 519 569 if Buffer.length whitespace > 0 then begin ··· 529 579 (* Flush trailing whitespace before closing quote to preserve it *) 530 580 flush_whitespace (); 531 581 ignore (Input.next t.input) 532 532 - | Some ' ' | Some '\t' as c_opt -> 582 582 + | (Some ' ' | Some '\t') as c_opt -> 533 583 (* Track whitespace - don't add to buf yet *) 534 584 let c = match c_opt with Some c -> c | None -> assert false in 535 585 Buffer.add_char whitespace c; ··· 537 587 loop () 538 588 | Some '\\' -> 539 589 (* Escape sequence - this is non-whitespace content *) 540 540 - flush_whitespace (); (* Commit any pending whitespace *) 590 590 + flush_whitespace (); 591 591 + (* Commit any pending whitespace *) 541 592 ignore (Input.next t.input); 542 593 (match Input.peek t.input with 543 543 - | None -> Error.raise_at start (Invalid_escape_sequence "\\<EOF>") 544 544 - | Some '0' -> Buffer.add_char buf '\x00'; ignore (Input.next t.input) 545 545 - | Some 'a' -> Buffer.add_char buf '\x07'; ignore (Input.next t.input) 546 546 - | Some 'b' -> Buffer.add_char buf '\x08'; ignore (Input.next t.input) 547 547 - | Some 't' | Some '\t' -> Buffer.add_char buf '\t'; ignore (Input.next t.input) 548 548 - | Some 'n' -> Buffer.add_char buf '\n'; ignore (Input.next t.input) 549 549 - | Some 'v' -> Buffer.add_char buf '\x0B'; ignore (Input.next t.input) 550 550 - | Some 'f' -> Buffer.add_char buf '\x0C'; ignore (Input.next t.input) 551 551 - | Some 'r' -> Buffer.add_char buf '\r'; ignore (Input.next t.input) 552 552 - | Some 'e' -> Buffer.add_char buf '\x1B'; ignore (Input.next t.input) 553 553 - | Some ' ' -> Buffer.add_char buf ' '; ignore (Input.next t.input) 554 554 - | Some '"' -> Buffer.add_char buf '"'; ignore (Input.next t.input) 555 555 - | Some '/' -> Buffer.add_char buf '/'; ignore (Input.next t.input) 556 556 - | Some '\\' -> Buffer.add_char buf '\\'; ignore (Input.next t.input) 557 557 - | Some 'N' -> Buffer.add_string buf "\xC2\x85"; ignore (Input.next t.input) (* NEL *) 558 558 - | Some '_' -> Buffer.add_string buf "\xC2\xA0"; ignore (Input.next t.input) (* NBSP *) 559 559 - | Some 'L' -> Buffer.add_string buf "\xE2\x80\xA8"; ignore (Input.next t.input) (* LS *) 560 560 - | Some 'P' -> Buffer.add_string buf "\xE2\x80\xA9"; ignore (Input.next t.input) (* PS *) 561 561 - | Some 'x' -> 562 562 - ignore (Input.next t.input); 563 563 - Buffer.add_string buf (decode_hex t 2) 564 564 - | Some 'u' -> 565 565 - ignore (Input.next t.input); 566 566 - Buffer.add_string buf (decode_hex t 4) 567 567 - | Some 'U' -> 568 568 - ignore (Input.next t.input); 569 569 - Buffer.add_string buf (decode_hex t 8) 570 570 - | Some '\n' | Some '\r' -> 571 571 - (* Line continuation escape *) 572 572 - Input.consume_break t.input; 573 573 - while Input.next_is_blank t.input do 574 574 - ignore (Input.next t.input) 575 575 - done 576 576 - | Some c -> 577 577 - Error.raise_at (Input.mark t.input) 578 578 - (Invalid_escape_sequence (Printf.sprintf "\\%c" c))); 594 594 + | None -> Error.raise_at start (Invalid_escape_sequence "\\<EOF>") 595 595 + | Some '0' -> 596 596 + Buffer.add_char buf '\x00'; 597 597 + ignore (Input.next t.input) 598 598 + | Some 'a' -> 599 599 + Buffer.add_char buf '\x07'; 600 600 + ignore (Input.next t.input) 601 601 + | Some 'b' -> 602 602 + Buffer.add_char buf '\x08'; 603 603 + ignore (Input.next t.input) 604 604 + | Some 't' | Some '\t' -> 605 605 + Buffer.add_char buf '\t'; 606 606 + ignore (Input.next t.input) 607 607 + | Some 'n' -> 608 608 + Buffer.add_char buf '\n'; 609 609 + ignore (Input.next t.input) 610 610 + | Some 'v' -> 611 611 + Buffer.add_char buf '\x0B'; 612 612 + ignore (Input.next t.input) 613 613 + | Some 'f' -> 614 614 + Buffer.add_char buf '\x0C'; 615 615 + ignore (Input.next t.input) 616 616 + | Some 'r' -> 617 617 + Buffer.add_char buf '\r'; 618 618 + ignore (Input.next t.input) 619 619 + | Some 'e' -> 620 620 + Buffer.add_char buf '\x1B'; 621 621 + ignore (Input.next t.input) 622 622 + | Some ' ' -> 623 623 + Buffer.add_char buf ' '; 624 624 + ignore (Input.next t.input) 625 625 + | Some '"' -> 626 626 + Buffer.add_char buf '"'; 627 627 + ignore (Input.next t.input) 628 628 + | Some '/' -> 629 629 + Buffer.add_char buf '/'; 630 630 + ignore (Input.next t.input) 631 631 + | Some '\\' -> 632 632 + Buffer.add_char buf '\\'; 633 633 + ignore (Input.next t.input) 634 634 + | Some 'N' -> 635 635 + Buffer.add_string buf "\xC2\x85"; 636 636 + ignore (Input.next t.input) (* NEL *) 637 637 + | Some '_' -> 638 638 + Buffer.add_string buf "\xC2\xA0"; 639 639 + ignore (Input.next t.input) (* NBSP *) 640 640 + | Some 'L' -> 641 641 + Buffer.add_string buf "\xE2\x80\xA8"; 642 642 + ignore (Input.next t.input) (* LS *) 643 643 + | Some 'P' -> 644 644 + Buffer.add_string buf "\xE2\x80\xA9"; 645 645 + ignore (Input.next t.input) (* PS *) 646 646 + | Some 'x' -> 647 647 + ignore (Input.next t.input); 648 648 + Buffer.add_string buf (decode_hex t 2) 649 649 + | Some 'u' -> 650 650 + ignore (Input.next t.input); 651 651 + Buffer.add_string buf (decode_hex t 4) 652 652 + | Some 'U' -> 653 653 + ignore (Input.next t.input); 654 654 + Buffer.add_string buf (decode_hex t 8) 655 655 + | Some '\n' | Some '\r' -> 656 656 + (* Line continuation escape *) 657 657 + Input.consume_break t.input; 658 658 + while Input.next_is_blank t.input do 659 659 + ignore (Input.next t.input) 660 660 + done 661 661 + | Some c -> 662 662 + Error.raise_at (Input.mark t.input) 663 663 + (Invalid_escape_sequence (Printf.sprintf "\\%c" c))); 579 664 loop () 580 665 | Some '\n' | Some '\r' -> 581 666 (* Line break: discard any pending trailing whitespace *) ··· 596 681 if Input.next_is_break t.input then begin 597 682 Input.consume_break t.input; 598 683 incr empty_lines; 599 599 - started_with_tab := false (* Reset for next line *) 600 600 - end else 601 601 - continue := false 684 684 + started_with_tab := false (* Reset for next line *) 685 685 + end 686 686 + else continue := false 602 687 done; 603 688 (* Check for document boundary - this terminates the quoted string *) 604 689 if Input.at_document_boundary t.input then ··· 609 694 let indent = current_indent t in 610 695 let start_col = start.column in 611 696 (* DK95/01: if continuation started with tabs and column < start column, error *) 612 612 - if not (Input.is_eof t.input) && !started_with_tab && col < start_col then 613 613 - Error.raise_at (Input.mark t.input) (Invalid_quoted_scalar_indentation "invalid indentation in quoted scalar"); 614 614 - if not (Input.is_eof t.input) && col <= indent && indent >= 0 then 615 615 - Error.raise_at (Input.mark t.input) (Invalid_quoted_scalar_indentation "invalid indentation in quoted scalar"); 697 697 + if (not (Input.is_eof t.input)) && !started_with_tab && col < start_col 698 698 + then 699 699 + Error.raise_at (Input.mark t.input) 700 700 + (Invalid_quoted_scalar_indentation 701 701 + "invalid indentation in quoted scalar"); 702 702 + if (not (Input.is_eof t.input)) && col <= indent && indent >= 0 then 703 703 + Error.raise_at (Input.mark t.input) 704 704 + (Invalid_quoted_scalar_indentation 705 705 + "invalid indentation in quoted scalar"); 616 706 (* Per YAML spec: single break = space, break + empty lines = newlines *) 617 707 if !empty_lines > 0 then begin 618 708 (* Empty lines: output N newlines where N = number of empty lines *) 619 709 for _ = 1 to !empty_lines do 620 710 Buffer.add_char buf '\n' 621 711 done 622 622 - end else 712 712 + end 713 713 + else 623 714 (* Single break folds to space *) 624 715 Buffer.add_char buf ' '; 625 716 loop () 626 717 | Some c -> 627 718 (* Non-whitespace character *) 628 628 - flush_whitespace (); (* Commit any pending whitespace *) 719 719 + flush_whitespace (); 720 720 + (* Commit any pending whitespace *) 629 721 Buffer.add_char buf c; 630 722 ignore (Input.next t.input); 631 723 loop () ··· 637 729 (** Check if character can appear in plain scalar at this position *) 638 730 let can_continue_plain t c ~in_flow = 639 731 match c with 640 640 - | ':' -> 732 732 + | ':' -> ( 641 733 (* : is OK if not followed by whitespace or flow indicator *) 642 642 - (match Input.peek_nth t.input 1 with 643 643 - | None -> true 644 644 - | Some c2 when Input.is_whitespace c2 -> false 645 645 - | Some c2 when in_flow && Input.is_flow_indicator c2 -> false 646 646 - | _ -> true) 647 647 - | '#' -> 734 734 + match Input.peek_nth t.input 1 with 735 735 + | None -> true 736 736 + | Some c2 when Input.is_whitespace c2 -> false 737 737 + | Some c2 when in_flow && Input.is_flow_indicator c2 -> false 738 738 + | _ -> true) 739 739 + | '#' -> ( 648 740 (* # is a comment indicator only if preceded by whitespace *) 649 741 (* Check the previous character to determine if this is a comment *) 650 650 - (match Input.peek_back t.input with 651 651 - | None -> true (* At start - can't be comment indicator, allow it *) 652 652 - | Some c when Input.is_whitespace c -> false (* Preceded by whitespace - comment *) 653 653 - | Some c when Input.is_break c -> false (* At start of line - comment *) 654 654 - | _ -> true) (* Not preceded by whitespace - part of scalar *) 742 742 + match Input.peek_back t.input with 743 743 + | None -> true (* At start - can't be comment indicator, allow it *) 744 744 + | Some c when Input.is_whitespace c -> 745 745 + false (* Preceded by whitespace - comment *) 746 746 + | Some c when Input.is_break c -> false (* At start of line - comment *) 747 747 + | _ -> true (* Not preceded by whitespace - part of scalar *)) 655 748 | c when in_flow && Input.is_flow_indicator c -> false 656 749 | _ when Input.is_break c -> false 657 750 | _ -> true ··· 663 756 let indent = current_indent t in 664 757 (* In flow context, scalars must be indented more than the current block indent. 665 758 This ensures that content at block indent or less ends the flow context. *) 666 666 - if in_flow && (column t - 1) < indent then 759 759 + if in_flow && column t - 1 < indent then 667 760 Error.raise_at start Invalid_flow_indentation; 668 761 let buf = Buffer.create 64 in 669 762 let spaces = Buffer.create 16 in 670 670 - let whitespace = Buffer.create 16 in (* Track whitespace within a line *) 763 763 + let whitespace = Buffer.create 16 in 764 764 + (* Track whitespace within a line *) 671 765 let leading_blanks = ref false in 672 766 673 767 let rec scan_line () = ··· 684 778 if Buffer.length spaces > 0 then begin 685 779 if !leading_blanks then begin 686 780 (* Fold line break *) 687 687 - if Buffer.contents spaces = "\n" then 688 688 - Buffer.add_char buf ' ' 781 781 + if Buffer.contents spaces = "\n" then Buffer.add_char buf ' ' 689 782 else begin 690 783 (* Multiple breaks - preserve all but first *) 691 784 let s = Buffer.contents spaces in 692 785 Buffer.add_substring buf s 1 (String.length s - 1) 693 786 end 694 694 - end else 695 695 - Buffer.add_buffer buf spaces; 787 787 + end 788 788 + else Buffer.add_buffer buf spaces; 696 789 Buffer.clear spaces 697 790 end; 698 791 (* Add any pending whitespace from within the line *) ··· 719 812 if !leading_blanks then begin 720 813 (* We already had a break - this is an additional break (empty line) *) 721 814 Buffer.add_char spaces '\n' 722 722 - end else begin 815 815 + end 816 816 + else begin 723 817 (* First line break *) 724 818 Buffer.clear spaces; 725 819 Buffer.add_char spaces '\n'; ··· 739 833 (* However, allow empty lines (line breaks) to continue even if dedented *) 740 834 if Input.next_is_break t.input then 741 835 scan_lines () (* Empty line - continue *) 742 742 - else if not in_flow && col <= indent then 743 743 - () (* Stop - dedented or at parent level in block context *) 744 744 - else if Input.at_document_boundary t.input then 745 745 - () (* Stop - document boundary *) 746 746 - else 747 747 - scan_lines () 836 836 + else if (not in_flow) && col <= indent then () 837 837 + (* Stop - dedented or at parent level in block context *) 838 838 + else if Input.at_document_boundary t.input then () 839 839 + (* Stop - document boundary *) 840 840 + else scan_lines () 748 841 end 749 842 in 750 843 ··· 755 848 let len = String.length value in 756 849 let rec find_end i = 757 850 if i < 0 then 0 758 758 - else match value.[i] with 759 759 - | ' ' | '\t' -> find_end (i - 1) 760 760 - | _ -> i + 1 851 851 + else match value.[i] with ' ' | '\t' -> find_end (i - 1) | _ -> i + 1 761 852 in 762 853 let end_pos = find_end (len - 1) in 763 854 String.sub value 0 end_pos ··· 769 860 (** Scan block scalar (literal | or folded >) *) 770 861 let scan_block_scalar t literal = 771 862 let start = Input.mark t.input in 772 772 - ignore (Input.next t.input); (* consume | or > *) 863 863 + ignore (Input.next t.input); 864 864 + 865 865 + (* consume | or > *) 773 866 774 867 (* Parse header: optional indentation indicator and chomping *) 775 868 let explicit_indent = ref None in ··· 777 870 778 871 (* First character of header *) 779 872 (match Input.peek t.input with 780 780 - | Some c when Input.is_digit c && c <> '0' -> 781 781 - explicit_indent := Some (Char.code c - Char.code '0'); 782 782 - ignore (Input.next t.input) 783 783 - | Some '-' -> chomping := Chomping.Strip; ignore (Input.next t.input) 784 784 - | Some '+' -> chomping := Chomping.Keep; ignore (Input.next t.input) 785 785 - | _ -> ()); 873 873 + | Some c when Input.is_digit c && c <> '0' -> 874 874 + explicit_indent := Some (Char.code c - Char.code '0'); 875 875 + ignore (Input.next t.input) 876 876 + | Some '-' -> 877 877 + chomping := Chomping.Strip; 878 878 + ignore (Input.next t.input) 879 879 + | Some '+' -> 880 880 + chomping := Chomping.Keep; 881 881 + ignore (Input.next t.input) 882 882 + | _ -> ()); 786 883 787 884 (* Second character of header *) 788 885 (match Input.peek t.input with 789 789 - | Some c when Input.is_digit c && c <> '0' && !explicit_indent = None -> 790 790 - explicit_indent := Some (Char.code c - Char.code '0'); 791 791 - ignore (Input.next t.input) 792 792 - | Some '-' when !chomping = Chomping.Clip -> 793 793 - chomping := Chomping.Strip; ignore (Input.next t.input) 794 794 - | Some '+' when !chomping = Chomping.Clip -> 795 795 - chomping := Chomping.Keep; ignore (Input.next t.input) 796 796 - | _ -> ()); 886 886 + | Some c when Input.is_digit c && c <> '0' && !explicit_indent = None -> 887 887 + explicit_indent := Some (Char.code c - Char.code '0'); 888 888 + ignore (Input.next t.input) 889 889 + | Some '-' when !chomping = Chomping.Clip -> 890 890 + chomping := Chomping.Strip; 891 891 + ignore (Input.next t.input) 892 892 + | Some '+' when !chomping = Chomping.Clip -> 893 893 + chomping := Chomping.Keep; 894 894 + ignore (Input.next t.input) 895 895 + | _ -> ()); 797 896 798 897 (* Skip whitespace and optional comment *) 799 898 skip_whitespace_and_comment t; 800 899 801 900 (* Consume line break *) 802 802 - if Input.next_is_break t.input then 803 803 - Input.consume_break t.input 901 901 + if Input.next_is_break t.input then Input.consume_break t.input 804 902 else if not (Input.is_eof t.input) then 805 903 Error.raise_at (Input.mark t.input) 806 904 (Invalid_block_scalar_header "expected newline after header"); ··· 808 906 let base_indent = current_indent t in 809 907 (* base_indent is the indent level from the stack, -1 if empty. 810 908 It's used directly for comparisons in implicit indent case. *) 811 811 - let content_indent = ref ( 812 812 - match !explicit_indent with 813 813 - | Some n -> 814 814 - (* Explicit indent: base_indent is 1-indexed column, convert to 0-indexed. 909 909 + let content_indent = 910 910 + ref 911 911 + (match !explicit_indent with 912 912 + | Some n -> 913 913 + (* Explicit indent: base_indent is 1-indexed column, convert to 0-indexed. 815 914 content_indent = (base_indent - 1) + n, but at least n for document level. *) 816 816 - let base_level = max 0 (base_indent - 1) in 817 817 - base_level + n 818 818 - | None -> 0 (* Will be determined by first non-empty line *) 819 819 - ) in 915 915 + let base_level = max 0 (base_indent - 1) in 916 916 + base_level + n 917 917 + | None -> 0 (* Will be determined by first non-empty line *)) 918 918 + in 820 919 821 920 let buf = Buffer.create 256 in 822 921 let trailing_breaks = Buffer.create 16 in 823 823 - let leading_blank = ref false in (* Was the previous line "more indented"? *) 824 824 - let max_empty_line_indent = ref 0 in (* Track max indent of empty lines before first content *) 922 922 + let leading_blank = ref false in 923 923 + (* Was the previous line "more indented"? *) 924 924 + let max_empty_line_indent = ref 0 in 925 925 + (* Track max indent of empty lines before first content *) 825 926 826 927 (* Skip to content indentation, skipping empty lines. 827 928 Returns the number of spaces actually skipped (important for detecting dedentation). *) ··· 829 930 if !content_indent > 0 then begin 830 931 (* Explicit indent - skip up to content_indent spaces *) 831 932 let spaces_skipped = ref 0 in 832 832 - while !spaces_skipped < !content_indent && Input.next_is (( = ) ' ') t.input do 933 933 + while 934 934 + !spaces_skipped < !content_indent && Input.next_is (( = ) ' ') t.input 935 935 + do 833 936 incr spaces_skipped; 834 937 ignore (Input.next t.input) 835 938 done; ··· 840 943 Buffer.add_char trailing_breaks '\n'; 841 944 Input.consume_break t.input; 842 945 skip_to_content_indent () 843 843 - end else if !spaces_skipped < !content_indent then begin 946 946 + end 947 947 + else if !spaces_skipped < !content_indent then begin 844 948 (* Line starts with fewer spaces than content_indent - dedented *) 845 949 !spaces_skipped 846 846 - end else if Input.next_is_blank t.input then begin 950 950 + end 951 951 + else if Input.next_is_blank t.input then begin 847 952 (* Line has spaces/tabs beyond content_indent - could be whitespace content or empty line. 848 953 For literal scalars, whitespace-only lines ARE content (not empty). 849 954 For folded scalars, whitespace-only lines that are "more indented" are preserved. *) ··· 853 958 else begin 854 959 (* Folded: check if rest is only blanks *) 855 960 let idx = ref 0 in 856 856 - while match Input.peek_nth t.input !idx with 857 857 - | Some c when Input.is_blank c -> incr idx; true 858 858 - | _ -> false 859 859 - do () done; 860 860 - match Input.peek_nth t.input (!idx) with 961 961 + while 962 962 + match Input.peek_nth t.input !idx with 963 963 + | Some c when Input.is_blank c -> 964 964 + incr idx; 965 965 + true 966 966 + | _ -> false 967 967 + do 968 968 + () 969 969 + done; 970 970 + match Input.peek_nth t.input !idx with 861 971 | None | Some '\n' | Some '\r' -> 862 972 (* Empty/whitespace-only line in folded - skip spaces *) 863 973 while Input.next_is_blank t.input do ··· 870 980 (* Has non-whitespace content *) 871 981 !content_indent 872 982 end 873 873 - end else 874 874 - !content_indent 875 875 - end else begin 983 983 + end 984 984 + else !content_indent 985 985 + end 986 986 + else begin 876 987 (* Implicit indent - skip empty lines without consuming spaces. 877 988 Note: Only SPACES count as indentation. Tabs are content, not indentation. 878 989 So we only check for spaces when determining if a line is "empty". *) ··· 880 991 Buffer.add_char trailing_breaks '\n'; 881 992 Input.consume_break t.input; 882 993 skip_to_content_indent () 883 883 - end else if Input.next_is (( = ) ' ') t.input then begin 994 994 + end 995 995 + else if Input.next_is (( = ) ' ') t.input then begin 884 996 (* Check if line is empty (only spaces before break) *) 885 997 let idx = ref 0 in 886 886 - while match Input.peek_nth t.input !idx with 887 887 - | Some ' ' -> incr idx; true 888 888 - | _ -> false 889 889 - do () done; 890 890 - match Input.peek_nth t.input (!idx) with 998 998 + while 999 999 + match Input.peek_nth t.input !idx with 1000 1000 + | Some ' ' -> 1001 1001 + incr idx; 1002 1002 + true 1003 1003 + | _ -> false 1004 1004 + do 1005 1005 + () 1006 1006 + done; 1007 1007 + match Input.peek_nth t.input !idx with 891 1008 | None | Some '\n' | Some '\r' -> 892 1009 (* Line has only spaces - empty line *) 893 1010 (* Track max indent of empty lines for later validation *) 894 894 - if !idx > !max_empty_line_indent then 895 895 - max_empty_line_indent := !idx; 1011 1011 + if !idx > !max_empty_line_indent then max_empty_line_indent := !idx; 896 1012 while Input.next_is (( = ) ' ') t.input do 897 1013 ignore (Input.next t.input) 898 1014 done; ··· 902 1018 | _ -> 903 1019 (* Has content (including tabs which are content, not indentation) *) 904 1020 0 905 905 - end else if Input.next_is (( = ) '\t') t.input then begin 1021 1021 + end 1022 1022 + else if Input.next_is (( = ) '\t') t.input then begin 906 1023 (* Tab at start of line in implicit indent mode - this is an error (Y79Y) 907 1024 because tabs cannot be used as indentation in YAML *) 908 1025 Error.raise_at (Input.mark t.input) Tab_in_indentation 909 909 - end else 1026 1026 + end 1027 1027 + else 910 1028 (* Not at break or space - other content character *) 911 1029 0 912 1030 end ··· 938 1056 let should_process = 939 1057 if !content_indent = 0 then begin 940 1058 (* For implicit indent, content must be more indented than base_level. *) 941 941 - if line_indent <= base_level then 942 942 - false (* No content - first line not indented enough *) 1059 1059 + if line_indent <= base_level then false 1060 1060 + (* No content - first line not indented enough *) 943 1061 else begin 944 1062 (* Validate: first content line must be indented at least as much as 945 1063 the maximum indent seen on empty lines before it (5LLU, S98Z, W9L4) *) 946 946 - if line_indent < !max_empty_line_indent && line_indent > base_level then 1064 1064 + if line_indent < !max_empty_line_indent && line_indent > base_level 1065 1065 + then 947 1066 Error.raise_at (Input.mark t.input) 948 948 - (Invalid_block_scalar_header "wrongly indented line in block scalar"); 1067 1067 + (Invalid_block_scalar_header 1068 1068 + "wrongly indented line in block scalar"); 949 1069 content_indent := line_indent; 950 1070 true 951 1071 end 952 952 - end else if line_indent < !content_indent then 953 953 - false (* Dedented - done with content *) 954 954 - else 955 955 - true 1072 1072 + end 1073 1073 + else if line_indent < !content_indent then false 1074 1074 + (* Dedented - done with content *) 1075 1075 + else true 956 1076 in 957 1077 958 1078 if should_process then begin ··· 960 1080 For folded scalars, lines that start with any whitespace (space or tab) after the 961 1081 content indentation are "more indented" and preserve breaks. 962 1082 Note: we check Input.next_is_blank BEFORE reading content to see if content starts with whitespace. *) 963 963 - let trailing_blank = line_indent > !content_indent || Input.next_is_blank t.input in 1083 1083 + let trailing_blank = 1084 1084 + line_indent > !content_indent || Input.next_is_blank t.input 1085 1085 + in 964 1086 965 1087 (* Add trailing breaks to buffer *) 966 1088 if Buffer.length buf > 0 then begin 967 1089 if Buffer.length trailing_breaks > 0 then begin 968 968 - if literal then 969 969 - Buffer.add_buffer buf trailing_breaks 1090 1090 + if literal then Buffer.add_buffer buf trailing_breaks 970 1091 else begin 971 1092 (* Folded scalar: fold only if both previous and current lines are not more-indented *) 972 972 - if not !leading_blank && not trailing_blank then begin 1093 1093 + if (not !leading_blank) && not trailing_blank then begin 973 1094 let breaks = Buffer.contents trailing_breaks in 974 974 - if String.length breaks = 1 then 975 975 - Buffer.add_char buf ' ' 976 976 - else 977 977 - Buffer.add_substring buf breaks 1 (String.length breaks - 1) 978 978 - end else begin 1095 1095 + if String.length breaks = 1 then Buffer.add_char buf ' ' 1096 1096 + else Buffer.add_substring buf breaks 1 (String.length breaks - 1) 1097 1097 + end 1098 1098 + else begin 979 1099 (* Preserve breaks for more-indented lines *) 980 1100 Buffer.add_buffer buf trailing_breaks 981 1101 end 982 1102 end 983 983 - end else if not literal then 984 984 - Buffer.add_char buf ' ' 985 985 - end else 986 986 - Buffer.add_buffer buf trailing_breaks; 1103 1103 + end 1104 1104 + else if not literal then Buffer.add_char buf ' ' 1105 1105 + end 1106 1106 + else Buffer.add_buffer buf trailing_breaks; 987 1107 Buffer.clear trailing_breaks; 988 1108 989 1109 (* Add extra indentation for literal or more-indented folded lines *) 990 1110 (* On the first line (when determining content_indent), we've already consumed all spaces, 991 1111 so we should NOT add any back. On subsequent lines, we add only the spaces beyond content_indent. *) 992 992 - if not first_line && (literal || (!extra_spaces > 0 && not literal)) then begin 1112 1112 + if (not first_line) && (literal || (!extra_spaces > 0 && not literal)) 1113 1113 + then begin 993 1114 for _ = 1 to !extra_spaces do 994 1115 Buffer.add_char buf ' ' 995 1116 done 996 1117 end; 997 1118 998 1119 (* Read line content *) 999 999 - while not (Input.is_eof t.input) && not (Input.next_is_break t.input) do 1120 1120 + while 1121 1121 + (not (Input.is_eof t.input)) && not (Input.next_is_break t.input) 1122 1122 + do 1000 1123 Buffer.add_char buf (Input.next_exn t.input) 1001 1124 done; 1002 1125 ··· 1023 1146 | Chomping.Strip -> content 1024 1147 | Chomping.Clip -> 1025 1148 if String.length content > 0 then content ^ "\n" else content 1026 1026 - | Chomping.Keep -> 1027 1027 - content ^ Buffer.contents trailing_breaks 1149 1149 + | Chomping.Keep -> content ^ Buffer.contents trailing_breaks 1028 1150 in 1029 1151 1030 1152 let span = Span.make ~start ~stop:(Input.mark t.input) in ··· 1034 1156 (** Scan directive (after %) *) 1035 1157 let scan_directive t = 1036 1158 let start = Input.mark t.input in 1037 1037 - ignore (Input.next t.input); (* consume % *) 1159 1159 + ignore (Input.next t.input); 1160 1160 + 1161 1161 + (* consume % *) 1038 1162 1039 1163 (* Read directive name *) 1040 1164 let name_buf = Buffer.create 16 in ··· 1045 1169 ignore (Input.next t.input); 1046 1170 true 1047 1171 | _ -> false 1048 1048 - do () done; 1172 1172 + do 1173 1173 + () 1174 1174 + done; 1049 1175 let name = Buffer.contents name_buf in 1050 1176 1051 1177 (* Skip blanks *) ··· 1060 1186 let minor = ref 0 in 1061 1187 (* Read major version *) 1062 1188 while Input.next_is_digit t.input do 1063 1063 - major := !major * 10 + (Char.code (Input.next_exn t.input) - Char.code '0') 1189 1189 + major := 1190 1190 + (!major * 10) + (Char.code (Input.next_exn t.input) - Char.code '0') 1064 1191 done; 1065 1192 (* Expect . *) 1066 1193 (match Input.peek t.input with 1067 1067 - | Some '.' -> ignore (Input.next t.input) 1068 1068 - | _ -> Error.raise_at (Input.mark t.input) (Invalid_yaml_version "expected '.'")); 1194 1194 + | Some '.' -> ignore (Input.next t.input) 1195 1195 + | _ -> 1196 1196 + Error.raise_at (Input.mark t.input) 1197 1197 + (Invalid_yaml_version "expected '.'")); 1069 1198 (* Read minor version *) 1070 1199 while Input.next_is_digit t.input do 1071 1071 - minor := !minor * 10 + (Char.code (Input.next_exn t.input) - Char.code '0') 1200 1200 + minor := 1201 1201 + (!minor * 10) + (Char.code (Input.next_exn t.input) - Char.code '0') 1072 1202 done; 1073 1203 (* Validate: only whitespace and comments allowed before line break (MUS6) *) 1074 1204 skip_whitespace_and_comment t; 1075 1075 - if not (Input.next_is_break t.input) && not (Input.is_eof t.input) then 1076 1076 - Error.raise_at (Input.mark t.input) (Invalid_directive "expected comment or line break after version"); 1205 1205 + if (not (Input.next_is_break t.input)) && not (Input.is_eof t.input) then 1206 1206 + Error.raise_at (Input.mark t.input) 1207 1207 + (Invalid_directive "expected comment or line break after version"); 1077 1208 let span = Span.make ~start ~stop:(Input.mark t.input) in 1078 1078 - Token.Version_directive { major = !major; minor = !minor }, span 1079 1079 - 1209 1209 + (Token.Version_directive { major = !major; minor = !minor }, span) 1080 1210 | "TAG" -> 1081 1211 (* Tag directive: %TAG !foo! tag:example.com,2000: *) 1082 1212 let handle = scan_tag_handle t in ··· 1093 1223 ignore (Input.next t.input); 1094 1224 true 1095 1225 | _ -> false 1096 1096 - do () done; 1226 1226 + do 1227 1227 + () 1228 1228 + done; 1097 1229 let prefix = Buffer.contents prefix_buf in 1098 1230 let span = Span.make ~start ~stop:(Input.mark t.input) in 1099 1099 - Token.Tag_directive { handle; prefix }, span 1100 1100 - 1231 1231 + (Token.Tag_directive { handle; prefix }, span) 1101 1232 | _ -> 1102 1233 (* Reserved/Unknown directive - skip to end of line and ignore *) 1103 1234 (* Per YAML spec, reserved directives should be ignored with a warning *) 1104 1104 - while not (Input.is_eof t.input) && not (Input.next_is_break t.input) do 1235 1235 + while (not (Input.is_eof t.input)) && not (Input.next_is_break t.input) do 1105 1236 ignore (Input.next t.input) 1106 1237 done; 1107 1238 let span = Span.make ~start ~stop:(Input.mark t.input) in 1108 1239 (* Return an empty tag directive token to indicate directive was processed but ignored *) 1109 1109 - Token.Tag_directive { handle = ""; prefix = "" }, span 1240 1240 + (Token.Tag_directive { handle = ""; prefix = "" }, span) 1110 1241 1111 1242 (** Fetch the next token(s) into the queue *) 1112 1243 let rec fetch_next_token t = ··· 1120 1251 (* We're about to process actual content, not leading whitespace *) 1121 1252 t.leading_whitespace <- false; 1122 1253 1123 1123 - if Input.is_eof t.input then 1124 1124 - fetch_stream_end t 1125 1125 - else if Input.at_document_boundary t.input then 1126 1126 - fetch_document_indicator t 1254 1254 + if Input.is_eof t.input then fetch_stream_end t 1255 1255 + else if Input.at_document_boundary t.input then fetch_document_indicator t 1127 1256 else begin 1128 1257 match Input.peek t.input with 1129 1258 | None -> fetch_stream_end t 1130 1130 - | Some '%' when (Input.position t.input).column = 1 -> 1131 1131 - fetch_directive t 1259 1259 + | Some '%' when (Input.position t.input).column = 1 -> fetch_directive t 1132 1260 | Some '[' -> fetch_flow_collection_start t Token.Flow_sequence_start 1133 1261 | Some '{' -> fetch_flow_collection_start t Token.Flow_mapping_start 1134 1262 | Some ']' -> fetch_flow_collection_end t Token.Flow_sequence_end ··· 1136 1264 | Some ',' -> fetch_flow_entry t 1137 1265 | Some '-' when t.flow_level = 0 && check_block_entry t -> 1138 1266 fetch_block_entry t 1139 1139 - | Some '?' when check_key t -> 1140 1140 - fetch_key t 1141 1141 - | Some ':' when check_value t -> 1142 1142 - fetch_value t 1267 1267 + | Some '?' when check_key t -> fetch_key t 1268 1268 + | Some ':' when check_value t -> fetch_value t 1143 1269 | Some '*' -> fetch_alias t 1144 1270 | Some '&' -> fetch_anchor t 1145 1271 | Some '!' -> fetch_tag t ··· 1147 1273 | Some '>' when t.flow_level = 0 -> fetch_block_scalar t false 1148 1274 | Some '\'' -> fetch_single_quoted t 1149 1275 | Some '"' -> fetch_double_quoted t 1150 1150 - | Some '-' when can_start_plain t -> 1151 1151 - fetch_plain_scalar t 1152 1152 - | Some '?' when can_start_plain t -> 1153 1153 - fetch_plain_scalar t 1154 1154 - | Some ':' when can_start_plain t -> 1155 1155 - fetch_plain_scalar t 1156 1156 - | Some c when can_start_plain_char c t -> 1157 1157 - fetch_plain_scalar t 1158 1158 - | Some c -> 1159 1159 - Error.raise_at (Input.mark t.input) (Unexpected_character c) 1276 1276 + | Some '-' when can_start_plain t -> fetch_plain_scalar t 1277 1277 + | Some '?' when can_start_plain t -> fetch_plain_scalar t 1278 1278 + | Some ':' when can_start_plain t -> fetch_plain_scalar t 1279 1279 + | Some c when can_start_plain_char c t -> fetch_plain_scalar t 1280 1280 + | Some c -> Error.raise_at (Input.mark t.input) (Unexpected_character c) 1160 1281 end 1161 1282 1162 1283 and fetch_stream_end t = ··· 1177 1298 let indicator = Input.peek_string t.input 3 in 1178 1299 Input.skip t.input 3; 1179 1300 let span = Span.make ~start ~stop:(Input.mark t.input) in 1180 1180 - let token = if indicator = "---" then Token.Document_start else Token.Document_end in 1301 1301 + let token = 1302 1302 + if indicator = "---" then Token.Document_start else Token.Document_end 1303 1303 + in 1181 1304 (* Reset document content flag after document end marker *) 1182 1305 if indicator = "..." then begin 1183 1306 t.document_has_content <- false; 1184 1307 (* After document end marker, skip whitespace and check for end of line or comment *) 1185 1185 - while Input.next_is_blank t.input do ignore (Input.next t.input) done; 1186 1186 - (match Input.peek t.input with 1187 1187 - | None -> () (* EOF is ok *) 1188 1188 - | Some c when Input.is_break c -> () 1189 1189 - | Some '#' -> () (* Comment is ok *) 1190 1190 - | _ -> Error.raise_at start (Invalid_directive "content not allowed after document end marker on same line")) 1308 1308 + while Input.next_is_blank t.input do 1309 1309 + ignore (Input.next t.input) 1310 1310 + done; 1311 1311 + match Input.peek t.input with 1312 1312 + | None -> () (* EOF is ok *) 1313 1313 + | Some c when Input.is_break c -> () 1314 1314 + | Some '#' -> () (* Comment is ok *) 1315 1315 + | _ -> 1316 1316 + Error.raise_at start 1317 1317 + (Invalid_directive 1318 1318 + "content not allowed after document end marker on same line") 1191 1319 end; 1192 1320 emit t span token 1193 1321 ··· 1198 1326 If we've emitted content in the current document, we need a document end marker first *) 1199 1327 if t.document_has_content then 1200 1328 Error.raise_at (Input.mark t.input) 1201 1201 - (Unexpected_token "directives must be separated from document content by document end marker (...)"); 1329 1329 + (Unexpected_token 1330 1330 + "directives must be separated from document content by document end \ 1331 1331 + marker (...)"); 1202 1332 unroll_indent t (-1); 1203 1333 remove_simple_key t; 1204 1334 t.allow_simple_key <- false; ··· 1208 1338 and fetch_flow_collection_start t token_type = 1209 1339 save_simple_key t; 1210 1340 (* Record indent of outermost flow collection *) 1211 1211 - if t.flow_level = 0 then 1212 1212 - t.flow_indent <- column t; 1341 1341 + if t.flow_level = 0 then t.flow_indent <- column t; 1213 1342 t.flow_level <- t.flow_level + 1; 1214 1343 (* Track whether this is a mapping or sequence *) 1215 1215 - let is_mapping = (token_type = Token.Flow_mapping_start) in 1344 1344 + let is_mapping = token_type = Token.Flow_mapping_start in 1216 1345 t.flow_mapping_stack <- is_mapping :: t.flow_mapping_stack; 1217 1346 t.allow_simple_key <- true; 1218 1347 t.simple_keys <- None :: t.simple_keys; ··· 1225 1354 and fetch_flow_collection_end t token_type = 1226 1355 remove_simple_key t; 1227 1356 t.flow_level <- t.flow_level - 1; 1228 1228 - t.flow_mapping_stack <- (match t.flow_mapping_stack with _ :: rest -> rest | [] -> []); 1357 1357 + t.flow_mapping_stack <- 1358 1358 + (match t.flow_mapping_stack with _ :: rest -> rest | [] -> []); 1229 1359 t.simple_keys <- (match t.simple_keys with _ :: rest -> rest | [] -> []); 1230 1360 t.allow_simple_key <- false; 1231 1361 let start = Input.mark t.input in ··· 1270 1400 ignore (Input.next t.input); 1271 1401 1272 1402 (* Check for tabs after - : pattern like -\t- is invalid *) 1273 1273 - let (found_tabs, _found_spaces) = skip_blanks_check_tabs t in 1403 1403 + let found_tabs, _found_spaces = skip_blanks_check_tabs t in 1274 1404 if found_tabs then begin 1275 1405 (* If we found tabs and next char is - followed by whitespace, error *) 1276 1406 match Input.peek t.input with 1277 1277 - | Some '-' -> 1278 1278 - (match Input.peek_nth t.input 1 with 1279 1279 - | None -> Error.raise_at start Tab_in_indentation 1280 1280 - | Some c when Input.is_whitespace c -> 1281 1281 - Error.raise_at start Tab_in_indentation 1282 1282 - | Some _ -> ()) 1407 1407 + | Some '-' -> ( 1408 1408 + match Input.peek_nth t.input 1 with 1409 1409 + | None -> Error.raise_at start Tab_in_indentation 1410 1410 + | Some c when Input.is_whitespace c -> 1411 1411 + Error.raise_at start Tab_in_indentation 1412 1412 + | Some _ -> ()) 1283 1413 | _ -> () 1284 1414 end; 1285 1415 ··· 1289 1419 and check_key t = 1290 1420 (* ? followed by whitespace or flow indicator in both block and flow *) 1291 1421 match Input.peek_nth t.input 1 with 1292 1292 - | None -> true 1293 1293 - | Some c -> 1294 1294 - Input.is_whitespace c || 1295 1295 - (t.flow_level > 0 && Input.is_flow_indicator c) 1422 1422 + | None -> true 1423 1423 + | Some c -> 1424 1424 + Input.is_whitespace c || (t.flow_level > 0 && Input.is_flow_indicator c) 1296 1425 1297 1426 and fetch_key t = 1298 1427 if t.flow_level = 0 then begin ··· 1311 1440 ignore (Input.next t.input); 1312 1441 1313 1442 (* Check for tabs after ? : pattern like ?\t- or ?\tkey is invalid *) 1314 1314 - let (found_tabs, _found_spaces) = skip_blanks_check_tabs t in 1443 1443 + let found_tabs, _found_spaces = skip_blanks_check_tabs t in 1315 1444 if found_tabs && t.flow_level = 0 then begin 1316 1445 (* In block context, tabs after ? are not allowed *) 1317 1446 Error.raise_at start Tab_in_indentation ··· 1324 1453 (* : followed by whitespace in block, or whitespace/flow indicator in flow, or adjacent value *) 1325 1454 match Input.peek_nth t.input 1 with 1326 1455 | None -> true 1327 1327 - | Some c -> 1328 1328 - Input.is_whitespace c || 1329 1329 - (t.flow_level > 0 && Input.is_flow_indicator c) || 1456 1456 + | Some c -> ( 1457 1457 + Input.is_whitespace c 1458 1458 + || (t.flow_level > 0 && Input.is_flow_indicator c) 1459 1459 + || 1330 1460 (* Allow adjacent values in flow context at designated positions *) 1331 1331 - (t.flow_level > 0 && 1332 1332 - match t.adjacent_value_allowed_at with 1333 1333 - | Some pos -> pos.Position.line = (Input.position t.input).Position.line && 1334 1334 - pos.Position.column = (Input.position t.input).Position.column 1335 1335 - | None -> false) 1461 1461 + t.flow_level > 0 1462 1462 + && 1463 1463 + match t.adjacent_value_allowed_at with 1464 1464 + | Some pos -> 1465 1465 + pos.Position.line = (Input.position t.input).Position.line 1466 1466 + && pos.Position.column = (Input.position t.input).Position.column 1467 1467 + | None -> false) 1336 1468 1337 1469 and fetch_value t = 1338 1470 let start = Input.mark t.input in ··· 1342 1474 | Some sk :: _ when sk.sk_possible -> 1343 1475 (* In implicit flow mapping (inside a flow sequence), key and : must be on the same line. 1344 1476 In explicit flow mapping { }, key and : can span lines. *) 1345 1345 - let is_implicit_flow_mapping = match t.flow_mapping_stack with 1346 1346 - | false :: _ -> true (* false = we're in a sequence, so any mapping is implicit *) 1477 1477 + let is_implicit_flow_mapping = 1478 1478 + match t.flow_mapping_stack with 1479 1479 + | false :: _ -> 1480 1480 + true (* false = we're in a sequence, so any mapping is implicit *) 1347 1481 | _ -> false 1348 1482 in 1349 1349 - if is_implicit_flow_mapping && sk.sk_position.line < (Input.position t.input).line then 1350 1350 - Error.raise_at start Illegal_flow_key_line; 1483 1483 + if 1484 1484 + is_implicit_flow_mapping 1485 1485 + && sk.sk_position.line < (Input.position t.input).line 1486 1486 + then Error.raise_at start Illegal_flow_key_line; 1351 1487 (* Insert KEY token before the simple key value *) 1352 1488 let key_span = Span.point sk.sk_position in 1353 1489 let key_token = { Token.token = Token.Key; span = key_span } in ··· 1355 1491 let tokens = Queue.to_seq t.tokens |> Array.of_seq in 1356 1492 Queue.clear t.tokens; 1357 1493 let insert_pos = sk.sk_token_number - t.tokens_taken in 1358 1358 - Array.iteri (fun i tok -> 1359 1359 - if i = insert_pos then Queue.add key_token t.tokens; 1360 1360 - Queue.add tok t.tokens 1361 1361 - ) tokens; 1362 1362 - if insert_pos >= Array.length tokens then 1363 1363 - Queue.add key_token t.tokens; 1494 1494 + Array.iteri 1495 1495 + (fun i tok -> 1496 1496 + if i = insert_pos then Queue.add key_token t.tokens; 1497 1497 + Queue.add tok t.tokens) 1498 1498 + tokens; 1499 1499 + if insert_pos >= Array.length tokens then Queue.add key_token t.tokens; 1364 1500 t.token_number <- t.token_number + 1; 1365 1501 (* Roll indent for implicit block mapping *) 1366 1502 if t.flow_level = 0 then begin ··· 1371 1507 let bm_token = { Token.token = Token.Block_mapping_start; span } in 1372 1508 let tokens = Queue.to_seq t.tokens |> Array.of_seq in 1373 1509 Queue.clear t.tokens; 1374 1374 - Array.iteri (fun i tok -> 1375 1375 - if i = insert_pos then Queue.add bm_token t.tokens; 1376 1376 - Queue.add tok t.tokens 1377 1377 - ) tokens; 1510 1510 + Array.iteri 1511 1511 + (fun i tok -> 1512 1512 + if i = insert_pos then Queue.add bm_token t.tokens; 1513 1513 + Queue.add tok t.tokens) 1514 1514 + tokens; 1378 1515 if insert_pos >= Array.length tokens then 1379 1516 Queue.add bm_token t.tokens; 1380 1517 t.token_number <- t.token_number + 1 1381 1518 end 1382 1519 end; 1383 1383 - t.simple_keys <- None :: (List.tl t.simple_keys); 1520 1520 + t.simple_keys <- None :: List.tl t.simple_keys; 1384 1521 true 1385 1522 | _ -> 1386 1523 (* No simple key - this is a complex value (or empty key) *) ··· 1400 1537 remove_simple_key t; 1401 1538 (* In block context without simple key, allow simple keys for compact mappings like ": moon: white" 1402 1539 In flow context or after using a simple key, disallow simple keys *) 1403 1403 - t.allow_simple_key <- (not used_simple_key) && (t.flow_level = 0); 1540 1540 + t.allow_simple_key <- (not used_simple_key) && t.flow_level = 0; 1404 1541 t.document_has_content <- true; 1405 1542 let start = Input.mark t.input in 1406 1543 ignore (Input.next t.input); 1407 1544 1408 1545 (* Check for tabs after : : patterns like :\t- or :\tkey: are invalid in block context (Y79Y/09) 1409 1546 However, :\t bar (tab followed by space then content) is valid (6BCT) *) 1410 1410 - let (found_tabs, found_spaces) = skip_blanks_check_tabs t in 1411 1411 - if found_tabs && not found_spaces && t.flow_level = 0 then begin 1547 1547 + let found_tabs, found_spaces = skip_blanks_check_tabs t in 1548 1548 + if found_tabs && (not found_spaces) && t.flow_level = 0 then begin 1412 1549 (* In block context, tabs-only after : followed by indicator or alphanumeric are not allowed *) 1413 1550 match Input.peek t.input with 1414 1414 - | Some ('-' | '?') -> 1415 1415 - Error.raise_at start Tab_in_indentation 1416 1416 - | Some c when (c >= 'a' && c <= 'z') || (c >= 'A' && c <= 'Z') || (c >= '0' && c <= '9') -> 1551 1551 + | Some ('-' | '?') -> Error.raise_at start Tab_in_indentation 1552 1552 + | Some c 1553 1553 + when (c >= 'a' && c <= 'z') 1554 1554 + || (c >= 'A' && c <= 'Z') 1555 1555 + || (c >= '0' && c <= '9') -> 1417 1556 (* Tab-only followed by alphanumeric - likely a key, which is invalid *) 1418 1557 Error.raise_at start Tab_in_indentation 1419 1558 | _ -> () ··· 1430 1569 t.allow_simple_key <- false; 1431 1570 t.document_has_content <- true; 1432 1571 let start = Input.mark t.input in 1433 1433 - ignore (Input.next t.input); (* consume * or & *) 1572 1572 + ignore (Input.next t.input); 1573 1573 + (* consume * or & *) 1434 1574 let name, span = scan_anchor_alias t in 1435 1575 let span = Span.make ~start ~stop:span.stop in 1436 1576 let token = if is_alias then Token.Alias name else Token.Anchor name in ··· 1475 1615 match Input.peek_nth t.input 1 with 1476 1616 | None -> false 1477 1617 | Some c -> 1478 1478 - not (Input.is_whitespace c) && 1479 1479 - (t.flow_level = 0 || not (Input.is_flow_indicator c)) 1618 1618 + (not (Input.is_whitespace c)) 1619 1619 + && (t.flow_level = 0 || not (Input.is_flow_indicator c)) 1480 1620 1481 1621 and can_start_plain_char c _t = 1482 1622 (* Characters that can start a plain scalar *) ··· 1492 1632 (* If the plain scalar ended after crossing a line break (leading_blanks = true), 1493 1633 allow simple keys. This is important because the scanner already consumed the 1494 1634 line break and leading whitespace when checking for continuation. *) 1495 1495 - if ended_with_linebreak then 1496 1496 - t.allow_simple_key <- true; 1635 1635 + if ended_with_linebreak then t.allow_simple_key <- true; 1497 1636 emit t span (Token.Scalar { style = `Plain; value }) 1498 1637 1499 1638 (** Check if we need more tokens to resolve simple keys *) ··· 1502 1641 else if Queue.is_empty t.tokens then true 1503 1642 else 1504 1643 (* Check if any simple key could affect the first queued token *) 1505 1505 - List.exists (function 1506 1506 - | Some sk when sk.sk_possible -> 1507 1507 - sk.sk_token_number >= t.tokens_taken 1508 1508 - | _ -> false 1509 1509 - ) t.simple_keys 1644 1644 + List.exists 1645 1645 + (function 1646 1646 + | Some sk when sk.sk_possible -> sk.sk_token_number >= t.tokens_taken 1647 1647 + | _ -> false) 1648 1648 + t.simple_keys 1510 1649 1511 1650 (** Ensure we have enough tokens to return one safely *) 1512 1651 let ensure_tokens t = ··· 1523 1662 (** Get next token *) 1524 1663 let next t = 1525 1664 ensure_tokens t; 1526 1526 - if Queue.is_empty t.tokens then 1527 1527 - None 1665 1665 + if Queue.is_empty t.tokens then None 1528 1666 else begin 1529 1667 t.tokens_taken <- t.tokens_taken + 1; 1530 1668 Some (Queue.pop t.tokens) ··· 1540 1678 let rec loop () = 1541 1679 match next t with 1542 1680 | None -> () 1543 1543 - | Some tok -> f tok; loop () 1681 1681 + | Some tok -> 1682 1682 + f tok; 1683 1683 + loop () 1544 1684 in 1545 1685 loop () 1546 1686 1547 1687 (** Fold over all tokens *) 1548 1688 let fold f init t = 1549 1689 let rec loop acc = 1550 1550 - match next t with 1551 1551 - | None -> acc 1552 1552 - | Some tok -> loop (f acc tok) 1690 1690 + match next t with None -> acc | Some tok -> loop (f acc tok) 1553 1691 in 1554 1692 loop init 1555 1693 1556 1694 (** Convert to list *) 1557 1557 - let to_list t = 1558 1558 - fold (fun acc tok -> tok :: acc) [] t |> List.rev 1695 1695 + let to_list t = fold (fun acc tok -> tok :: acc) [] t |> List.rev

+20 -28

lib/sequence.ml

··· 13 13 members : 'a list; 14 14 } 15 15 16 16 - let make 17 17 - ?(anchor : string option) 18 18 - ?(tag : string option) 19 19 - ?(implicit = true) 20 20 - ?(style = `Any) 21 21 - members = 16 16 + let make ?(anchor : string option) ?(tag : string option) ?(implicit = true) 17 17 + ?(style = `Any) members = 22 18 { anchor; tag; implicit; style; members } 23 19 24 20 let members t = t.members ··· 26 22 let tag t = t.tag 27 23 let implicit t = t.implicit 28 24 let style t = t.style 29 29 - 30 25 let with_anchor anchor t = { t with anchor = Some anchor } 31 26 let with_tag tag t = { t with tag = Some tag } 32 27 let with_style style t = { t with style } 33 33 - 34 28 let map f t = { t with members = List.map f t.members } 35 35 - 36 29 let length t = List.length t.members 37 37 - 38 30 let is_empty t = t.members = [] 39 39 - 40 31 let nth t n = List.nth t.members n 41 41 - 42 32 let nth_opt t n = List.nth_opt t.members n 43 43 - 44 33 let iter f t = List.iter f t.members 45 45 - 46 34 let fold f init t = List.fold_left f init t.members 47 35 48 36 let pp pp_elem fmt t = ··· 51 39 Option.iter (Format.fprintf fmt "tag=%s,@ ") t.tag; 52 40 Format.fprintf fmt "style=%a,@ " Layout_style.pp t.style; 53 41 Format.fprintf fmt "members=[@,%a@]@,)" 54 54 - (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") pp_elem) 42 42 + (Format.pp_print_list 43 43 + ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") 44 44 + pp_elem) 55 45 t.members 56 46 57 47 let equal eq a b = 58 58 - Option.equal String.equal a.anchor b.anchor && 59 59 - Option.equal String.equal a.tag b.tag && 60 60 - a.implicit = b.implicit && 61 61 - Layout_style.equal a.style b.style && 62 62 - List.equal eq a.members b.members 48 48 + Option.equal String.equal a.anchor b.anchor 49 49 + && Option.equal String.equal a.tag b.tag 50 50 + && a.implicit = b.implicit 51 51 + && Layout_style.equal a.style b.style 52 52 + && List.equal eq a.members b.members 63 53 64 54 let compare cmp a b = 65 55 let c = Option.compare String.compare a.anchor b.anchor in 66 66 - if c <> 0 then c else 67 67 - let c = Option.compare String.compare a.tag b.tag in 68 68 - if c <> 0 then c else 69 69 - let c = Bool.compare a.implicit b.implicit in 70 70 - if c <> 0 then c else 71 71 - let c = Layout_style.compare a.style b.style in 72 72 - if c <> 0 then c else 73 73 - List.compare cmp a.members b.members 56 56 + if c <> 0 then c 57 57 + else 58 58 + let c = Option.compare String.compare a.tag b.tag in 59 59 + if c <> 0 then c 60 60 + else 61 61 + let c = Bool.compare a.implicit b.implicit in 62 62 + if c <> 0 then c 63 63 + else 64 64 + let c = Layout_style.compare a.style b.style in 65 65 + if c <> 0 then c else List.compare cmp a.members b.members

+166 -139

lib/serialize.ml

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

+10 -16

lib/span.ml

··· 5 5 6 6 (** Source spans representing ranges in input *) 7 7 8 8 - type t = { 9 9 - start : Position.t; 10 10 - stop : Position.t; 11 11 - } 8 8 + type t = { start : Position.t; stop : Position.t } 12 9 13 10 let make ~start ~stop = { start; stop } 14 14 - 15 11 let point pos = { start = pos; stop = pos } 16 12 17 13 let merge a b = 18 18 - let start = if Position.compare a.start b.start <= 0 then a.start else b.start in 14 14 + let start = 15 15 + if Position.compare a.start b.start <= 0 then a.start else b.start 16 16 + in 19 17 let stop = if Position.compare a.stop b.stop >= 0 then a.stop else b.stop in 20 18 { start; stop } 21 19 22 22 - let extend span pos = 23 23 - { span with stop = pos } 20 20 + let extend span pos = { span with stop = pos } 24 21 25 22 let pp fmt t = 26 23 if t.start.line = t.stop.line then 27 27 - Format.fprintf fmt "line %d, columns %d-%d" 28 28 - t.start.line t.start.column t.stop.column 29 29 - else 30 30 - Format.fprintf fmt "lines %d-%d" t.start.line t.stop.line 24 24 + Format.fprintf fmt "line %d, columns %d-%d" t.start.line t.start.column 25 25 + t.stop.column 26 26 + else Format.fprintf fmt "lines %d-%d" t.start.line t.stop.line 31 27 32 32 - let to_string t = 33 33 - Format.asprintf "%a" pp t 28 28 + let to_string t = Format.asprintf "%a" pp t 34 29 35 30 let compare a b = 36 31 let c = Position.compare a.start b.start in 37 32 if c <> 0 then c else Position.compare a.stop b.stop 38 33 39 39 - let equal a b = 40 40 - Position.equal a.start b.start && Position.equal a.stop b.stop 34 34 + let equal a b = Position.equal a.start b.start && Position.equal a.stop b.stop

+12 -14

lib/tag.ml

··· 18 18 | 0 -> None 19 19 | _ when s.[0] <> '!' -> None 20 20 | 1 -> Some { handle = "!"; suffix = "" } 21 21 - | _ -> 21 21 + | _ -> ( 22 22 match s.[1] with 23 23 - | '!' -> (* !! handle *) 23 23 + | '!' -> 24 24 + (* !! handle *) 24 25 Some { handle = "!!"; suffix = String.sub s 2 (len - 2) } 25 25 - | '<' -> (* Verbatim tag !<...> *) 26 26 + | '<' -> 27 27 + (* Verbatim tag !<...> *) 26 28 if len > 2 && s.[len - 1] = '>' then 27 29 Some { handle = "!"; suffix = String.sub s 2 (len - 3) } 28 28 - else 29 29 - None 30 30 - | _ -> (* Primary handle or local tag *) 31 31 - Some { handle = "!"; suffix = String.sub s 1 (len - 1) } 30 30 + else None 31 31 + | _ -> 32 32 + (* Primary handle or local tag *) 33 33 + Some { handle = "!"; suffix = String.sub s 1 (len - 1) }) 32 34 33 35 let to_string t = 34 34 - if t.handle = "!" && t.suffix = "" then "!" 35 35 - else t.handle ^ t.suffix 36 36 + if t.handle = "!" && t.suffix = "" then "!" else t.handle ^ t.suffix 36 37 37 38 let to_uri t = 38 39 match t.handle with ··· 40 41 | "!" -> "!" ^ t.suffix 41 42 | h -> h ^ t.suffix 42 43 43 43 - let pp fmt t = 44 44 - Format.pp_print_string fmt (to_string t) 45 45 - 46 46 - let equal a b = 47 47 - String.equal a.handle b.handle && String.equal a.suffix b.suffix 44 44 + let pp fmt t = Format.pp_print_string fmt (to_string t) 45 45 + let equal a b = String.equal a.handle b.handle && String.equal a.suffix b.suffix 48 46 49 47 let compare a b = 50 48 let c = String.compare a.handle b.handle in

+30 -51

lib/token.ml

··· 10 10 | Stream_end 11 11 | Version_directive of { major : int; minor : int } 12 12 | Tag_directive of { handle : string; prefix : string } 13 13 - | Document_start (** --- *) 14 14 - | Document_end (** ... *) 13 13 + | Document_start (** --- *) 14 14 + | Document_end (** ... *) 15 15 | Block_sequence_start 16 16 | Block_mapping_start 17 17 - | Block_entry (** [-] *) 18 18 - | Block_end (** implicit, from dedent *) 17 17 + | Block_entry (** [-] *) 18 18 + | Block_end (** implicit, from dedent *) 19 19 | Flow_sequence_start (** \[ *) 20 20 - | Flow_sequence_end (** \] *) 21 21 - | Flow_mapping_start (** \{ *) 22 22 - | Flow_mapping_end (** \} *) 23 23 - | Flow_entry (** [,] *) 24 24 - | Key (** ? or implicit key *) 25 25 - | Value (** : *) 20 20 + | Flow_sequence_end (** \] *) 21 21 + | Flow_mapping_start (** \{ *) 22 22 + | Flow_mapping_end (** \} *) 23 23 + | Flow_entry (** [,] *) 24 24 + | Key (** ? or implicit key *) 25 25 + | Value (** : *) 26 26 | Anchor of string (** &name *) 27 27 - | Alias of string (** *name *) 27 27 + | Alias of string (** *name *) 28 28 | Tag of { handle : string; suffix : string } 29 29 | Scalar of { style : Scalar_style.t; value : string } 30 30 31 31 - type spanned = { 32 32 - token : t; 33 33 - span : Span.t; 34 34 - } 31 31 + type spanned = { token : t; span : Span.t } 35 32 36 33 let pp_token fmt = function 37 37 - | Stream_start enc -> 38 38 - Format.fprintf fmt "STREAM-START(%a)" Encoding.pp enc 39 39 - | Stream_end -> 40 40 - Format.fprintf fmt "STREAM-END" 34 34 + | Stream_start enc -> Format.fprintf fmt "STREAM-START(%a)" Encoding.pp enc 35 35 + | Stream_end -> Format.fprintf fmt "STREAM-END" 41 36 | Version_directive { major; minor } -> 42 37 Format.fprintf fmt "VERSION-DIRECTIVE(%d.%d)" major minor 43 38 | Tag_directive { handle; prefix } -> 44 39 Format.fprintf fmt "TAG-DIRECTIVE(%s, %s)" handle prefix 45 45 - | Document_start -> 46 46 - Format.fprintf fmt "DOCUMENT-START" 47 47 - | Document_end -> 48 48 - Format.fprintf fmt "DOCUMENT-END" 49 49 - | Block_sequence_start -> 50 50 - Format.fprintf fmt "BLOCK-SEQUENCE-START" 51 51 - | Block_mapping_start -> 52 52 - Format.fprintf fmt "BLOCK-MAPPING-START" 53 53 - | Block_entry -> 54 54 - Format.fprintf fmt "BLOCK-ENTRY" 55 55 - | Block_end -> 56 56 - Format.fprintf fmt "BLOCK-END" 57 57 - | Flow_sequence_start -> 58 58 - Format.fprintf fmt "FLOW-SEQUENCE-START" 59 59 - | Flow_sequence_end -> 60 60 - Format.fprintf fmt "FLOW-SEQUENCE-END" 61 61 - | Flow_mapping_start -> 62 62 - Format.fprintf fmt "FLOW-MAPPING-START" 63 63 - | Flow_mapping_end -> 64 64 - Format.fprintf fmt "FLOW-MAPPING-END" 65 65 - | Flow_entry -> 66 66 - Format.fprintf fmt "FLOW-ENTRY" 67 67 - | Key -> 68 68 - Format.fprintf fmt "KEY" 69 69 - | Value -> 70 70 - Format.fprintf fmt "VALUE" 71 71 - | Anchor name -> 72 72 - Format.fprintf fmt "ANCHOR(%s)" name 73 73 - | Alias name -> 74 74 - Format.fprintf fmt "ALIAS(%s)" name 75 75 - | Tag { handle; suffix } -> 76 76 - Format.fprintf fmt "TAG(%s, %s)" handle suffix 40 40 + | Document_start -> Format.fprintf fmt "DOCUMENT-START" 41 41 + | Document_end -> Format.fprintf fmt "DOCUMENT-END" 42 42 + | Block_sequence_start -> Format.fprintf fmt "BLOCK-SEQUENCE-START" 43 43 + | Block_mapping_start -> Format.fprintf fmt "BLOCK-MAPPING-START" 44 44 + | Block_entry -> Format.fprintf fmt "BLOCK-ENTRY" 45 45 + | Block_end -> Format.fprintf fmt "BLOCK-END" 46 46 + | Flow_sequence_start -> Format.fprintf fmt "FLOW-SEQUENCE-START" 47 47 + | Flow_sequence_end -> Format.fprintf fmt "FLOW-SEQUENCE-END" 48 48 + | Flow_mapping_start -> Format.fprintf fmt "FLOW-MAPPING-START" 49 49 + | Flow_mapping_end -> Format.fprintf fmt "FLOW-MAPPING-END" 50 50 + | Flow_entry -> Format.fprintf fmt "FLOW-ENTRY" 51 51 + | Key -> Format.fprintf fmt "KEY" 52 52 + | Value -> Format.fprintf fmt "VALUE" 53 53 + | Anchor name -> Format.fprintf fmt "ANCHOR(%s)" name 54 54 + | Alias name -> Format.fprintf fmt "ALIAS(%s)" name 55 55 + | Tag { handle; suffix } -> Format.fprintf fmt "TAG(%s, %s)" handle suffix 77 56 | Scalar { style; value } -> 78 57 Format.fprintf fmt "SCALAR(%a, %S)" Scalar_style.pp style value 79 58

+38 -66

lib/unix/yamlrw_unix.ml

··· 5 5 6 6 (** Yamlrw Unix - Channel and file I/O for YAML 7 7 8 8 - This module provides channel and file operations for parsing 9 9 - and emitting YAML using bytesrw for efficient streaming I/O. *) 8 8 + This module provides channel and file operations for parsing and emitting 9 9 + YAML using bytesrw for efficient streaming I/O. *) 10 10 11 11 open Bytesrw 12 12 open Yamlrw ··· 19 19 20 20 (** {1 Channel Input} *) 21 21 22 22 - let value_of_channel 23 23 - ?(resolve_aliases = true) 22 22 + let value_of_channel ?(resolve_aliases = true) 24 23 ?(max_nodes = Yaml.default_max_alias_nodes) 25 25 - ?(max_depth = Yaml.default_max_alias_depth) 26 26 - ic = 24 24 + ?(max_depth = Yaml.default_max_alias_depth) ic = 27 25 let reader = Bytes.Reader.of_in_channel ic in 28 26 Loader.value_of_reader ~resolve_aliases ~max_nodes ~max_depth reader 29 27 30 30 - let yaml_of_channel 31 31 - ?(resolve_aliases = false) 28 28 + let yaml_of_channel ?(resolve_aliases = false) 32 29 ?(max_nodes = Yaml.default_max_alias_nodes) 33 33 - ?(max_depth = Yaml.default_max_alias_depth) 34 34 - ic = 30 30 + ?(max_depth = Yaml.default_max_alias_depth) ic = 35 31 let reader = Bytes.Reader.of_in_channel ic in 36 32 Loader.yaml_of_reader ~resolve_aliases ~max_nodes ~max_depth reader 37 33 ··· 41 37 42 38 (** {1 Channel Output} *) 43 39 44 44 - let value_to_channel 45 45 - ?(encoding = `Utf8) 46 46 - ?(scalar_style = `Any) 47 47 - ?(layout_style = `Any) 48 48 - oc 49 49 - (v : value) = 50 50 - let config = { Emitter.default_config with encoding; scalar_style; layout_style } in 40 40 + let value_to_channel ?(encoding = `Utf8) ?(scalar_style = `Any) 41 41 + ?(layout_style = `Any) oc (v : value) = 42 42 + let config = 43 43 + { Emitter.default_config with encoding; scalar_style; layout_style } 44 44 + in 51 45 let writer = Bytes.Writer.of_out_channel oc in 52 46 Serialize.value_to_writer ~config writer v 53 47 54 54 - let yaml_to_channel 55 55 - ?(encoding = `Utf8) 56 56 - ?(scalar_style = `Any) 57 57 - ?(layout_style = `Any) 58 58 - oc 59 59 - (v : yaml) = 60 60 - let config = { Emitter.default_config with encoding; scalar_style; layout_style } in 48 48 + let yaml_to_channel ?(encoding = `Utf8) ?(scalar_style = `Any) 49 49 + ?(layout_style = `Any) oc (v : yaml) = 50 50 + let config = 51 51 + { Emitter.default_config with encoding; scalar_style; layout_style } 52 52 + in 61 53 let writer = Bytes.Writer.of_out_channel oc in 62 54 Serialize.yaml_to_writer ~config writer v 63 55 64 64 - let documents_to_channel 65 65 - ?(encoding = `Utf8) 66 66 - ?(scalar_style = `Any) 67 67 - ?(layout_style = `Any) 68 68 - ?(resolve_aliases = true) 69 69 - oc 70 70 - docs = 71 71 - let config = { Emitter.default_config with encoding; scalar_style; layout_style } in 56 56 + let documents_to_channel ?(encoding = `Utf8) ?(scalar_style = `Any) 57 57 + ?(layout_style = `Any) ?(resolve_aliases = true) oc docs = 58 58 + let config = 59 59 + { Emitter.default_config with encoding; scalar_style; layout_style } 60 60 + in 72 61 let writer = Bytes.Writer.of_out_channel oc in 73 62 Serialize.documents_to_writer ~config ~resolve_aliases writer docs 74 63 75 64 (** {1 File Input} *) 76 65 77 77 - let value_of_file 78 78 - ?(resolve_aliases = true) 66 66 + let value_of_file ?(resolve_aliases = true) 79 67 ?(max_nodes = Yaml.default_max_alias_nodes) 80 80 - ?(max_depth = Yaml.default_max_alias_depth) 81 81 - path = 68 68 + ?(max_depth = Yaml.default_max_alias_depth) path = 82 69 In_channel.with_open_bin path (fun ic -> 83 83 - value_of_channel ~resolve_aliases ~max_nodes ~max_depth ic) 70 70 + value_of_channel ~resolve_aliases ~max_nodes ~max_depth ic) 84 71 85 85 - let yaml_of_file 86 86 - ?(resolve_aliases = false) 72 72 + let yaml_of_file ?(resolve_aliases = false) 87 73 ?(max_nodes = Yaml.default_max_alias_nodes) 88 88 - ?(max_depth = Yaml.default_max_alias_depth) 89 89 - path = 74 74 + ?(max_depth = Yaml.default_max_alias_depth) path = 90 75 In_channel.with_open_bin path (fun ic -> 91 91 - yaml_of_channel ~resolve_aliases ~max_nodes ~max_depth ic) 76 76 + yaml_of_channel ~resolve_aliases ~max_nodes ~max_depth ic) 92 77 93 93 - let documents_of_file path = 94 94 - In_channel.with_open_bin path documents_of_channel 78 78 + let documents_of_file path = In_channel.with_open_bin path documents_of_channel 95 79 96 80 (** {1 File Output} *) 97 81 98 98 - let value_to_file 99 99 - ?(encoding = `Utf8) 100 100 - ?(scalar_style = `Any) 101 101 - ?(layout_style = `Any) 102 102 - path 103 103 - v = 82 82 + let value_to_file ?(encoding = `Utf8) ?(scalar_style = `Any) 83 83 + ?(layout_style = `Any) path v = 104 84 Out_channel.with_open_bin path (fun oc -> 105 105 - value_to_channel ~encoding ~scalar_style ~layout_style oc v) 85 85 + value_to_channel ~encoding ~scalar_style ~layout_style oc v) 106 86 107 107 - let yaml_to_file 108 108 - ?(encoding = `Utf8) 109 109 - ?(scalar_style = `Any) 110 110 - ?(layout_style = `Any) 111 111 - path 112 112 - v = 87 87 + let yaml_to_file ?(encoding = `Utf8) ?(scalar_style = `Any) 88 88 + ?(layout_style = `Any) path v = 113 89 Out_channel.with_open_bin path (fun oc -> 114 114 - yaml_to_channel ~encoding ~scalar_style ~layout_style oc v) 90 90 + yaml_to_channel ~encoding ~scalar_style ~layout_style oc v) 115 91 116 116 - let documents_to_file 117 117 - ?(encoding = `Utf8) 118 118 - ?(scalar_style = `Any) 119 119 - ?(layout_style = `Any) 120 120 - ?(resolve_aliases = true) 121 121 - path 122 122 - docs = 92 92 + let documents_to_file ?(encoding = `Utf8) ?(scalar_style = `Any) 93 93 + ?(layout_style = `Any) ?(resolve_aliases = true) path docs = 123 94 Out_channel.with_open_bin path (fun oc -> 124 124 - documents_to_channel ~encoding ~scalar_style ~layout_style ~resolve_aliases oc docs) 95 95 + documents_to_channel ~encoding ~scalar_style ~layout_style 96 96 + ~resolve_aliases oc docs)

+4 -12

lib/unix/yamlrw_unix.mli

··· 5 5 6 6 (** Yamlrw Unix - Channel and file I/O for YAML 7 7 8 8 - This module provides channel and file operations for parsing 9 9 - and emitting YAML using bytesrw for efficient streaming I/O. *) 8 8 + This module provides channel and file operations for parsing and emitting 9 9 + YAML using bytesrw for efficient streaming I/O. *) 10 10 11 11 (** {1 Types} *) 12 12 ··· 76 76 (** {1 File Input} *) 77 77 78 78 val value_of_file : 79 79 - ?resolve_aliases:bool -> 80 80 - ?max_nodes:int -> 81 81 - ?max_depth:int -> 82 82 - string -> 83 83 - value 79 79 + ?resolve_aliases:bool -> ?max_nodes:int -> ?max_depth:int -> string -> value 84 80 (** Parse a JSON-compatible value from a file. *) 85 81 86 82 val yaml_of_file : 87 87 - ?resolve_aliases:bool -> 88 88 - ?max_nodes:int -> 89 89 - ?max_depth:int -> 90 90 - string -> 91 91 - yaml 83 83 + ?resolve_aliases:bool -> ?max_nodes:int -> ?max_depth:int -> string -> yaml 92 84 (** Parse a full YAML value from a file. *) 93 85 94 86 val documents_of_file : string -> document list

+16 -20

lib/value.ml

··· 5 5 6 6 (** JSON-compatible YAML value representation *) 7 7 8 8 - type t = [ 9 9 - | `Null 8 8 + type t = 9 9 + [ `Null 10 10 | `Bool of bool 11 11 | `Float of float 12 12 | `String of string 13 13 | `A of t list 14 14 - | `O of (string * t) list 15 15 - ] 14 14 + | `O of (string * t) list ] 16 15 17 16 (* Type equality is ensured by structural compatibility with Yamlrw.value *) 18 17 ··· 23 22 let int n : t = `Float (Float.of_int n) 24 23 let float f : t = `Float f 25 24 let string s : t = `String s 26 26 - 27 25 let list f xs : t = `A (List.map f xs) 28 26 let obj pairs : t = `O pairs 29 27 ··· 72 70 | `O pairs -> List.exists (fun (k, _) -> k = key) pairs 73 71 | _ -> false 74 72 75 75 - let find key = function 76 76 - | `O pairs -> List.assoc_opt key pairs 77 77 - | _ -> None 73 73 + let find key = function `O pairs -> List.assoc_opt key pairs | _ -> None 78 74 79 75 let get key v = 80 80 - match find key v with 81 81 - | Some v -> v 82 82 - | None -> Error.raise (Key_not_found key) 76 76 + match find key v with Some v -> v | None -> Error.raise (Key_not_found key) 83 77 84 78 let keys = function 85 79 | `O pairs -> List.map fst pairs ··· 92 86 (** Combinators *) 93 87 94 88 let combine v1 v2 = 95 95 - match v1, v2 with 89 89 + match (v1, v2) with 96 90 | `O o1, `O o2 -> `O (o1 @ o2) 97 91 | v1, _ -> Error.raise (Type_mismatch ("object", type_name v1)) 98 92 ··· 113 107 | `Float f -> 114 108 if Float.is_integer f && Float.abs f < 1e15 then 115 109 Format.fprintf fmt "%.0f" f 116 116 - else 117 117 - Format.fprintf fmt "%g" f 110 110 + else Format.fprintf fmt "%g" f 118 111 | `String s -> Format.fprintf fmt "%S" s 119 112 | `A [] -> Format.pp_print_string fmt "[]" 120 113 | `A items -> 121 114 Format.fprintf fmt "@[<hv 2>[@,%a@]@,]" 122 122 - (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") pp) 115 115 + (Format.pp_print_list 116 116 + ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") 117 117 + pp) 123 118 items 124 119 | `O [] -> Format.pp_print_string fmt "{}" 125 120 | `O pairs -> 126 121 Format.fprintf fmt "@[<hv 2>{@,%a@]@,}" 127 127 - (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") 122 122 + (Format.pp_print_list 123 123 + ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@ ") 128 124 (fun fmt (k, v) -> Format.fprintf fmt "@[<hv 2>%S:@ %a@]" k pp v)) 129 125 pairs 130 126 131 127 (** Equality and comparison *) 132 128 133 129 let rec equal (a : t) (b : t) = 134 134 - match a, b with 130 130 + match (a, b) with 135 131 | `Null, `Null -> true 136 132 | `Bool a, `Bool b -> a = b 137 133 | `Float a, `Float b -> Float.equal a b 138 134 | `String a, `String b -> String.equal a b 139 135 | `A a, `A b -> List.equal equal a b 140 136 | `O a, `O b -> 141 141 - List.length a = List.length b && 142 142 - List.for_all2 (fun (k1, v1) (k2, v2) -> k1 = k2 && equal v1 v2) a b 137 137 + List.length a = List.length b 138 138 + && List.for_all2 (fun (k1, v1) (k2, v2) -> k1 = k2 && equal v1 v2) a b 143 139 | _ -> false 144 140 145 141 let rec compare (a : t) (b : t) = 146 146 - match a, b with 142 142 + match (a, b) with 147 143 | `Null, `Null -> 0 148 144 | `Null, _ -> -1 149 145 | _, `Null -> 1

+115 -102

lib/yaml.ml

··· 5 5 6 6 (** Full YAML representation with anchors, tags, and aliases *) 7 7 8 8 - type t = [ 9 9 - | `Scalar of Scalar.t 8 8 + type t = 9 9 + [ `Scalar of Scalar.t 10 10 | `Alias of string 11 11 | `A of t Sequence.t 12 12 - | `O of (t, t) Mapping.t 13 13 - ] 12 12 + | `O of (t, t) Mapping.t ] 14 13 15 14 (** Pretty printing *) 16 15 ··· 24 23 (** Equality *) 25 24 26 25 let rec equal (a : t) (b : t) = 27 27 - match a, b with 26 26 + match (a, b) with 28 27 | `Scalar a, `Scalar b -> Scalar.equal a b 29 28 | `Alias a, `Alias b -> String.equal a b 30 29 | `A a, `A b -> Sequence.equal equal a b ··· 40 39 | `Bool false -> `Scalar (Scalar.make "false") 41 40 | `Float f -> 42 41 let s = 43 43 - if Float.is_integer f && Float.abs f < 1e15 then 44 44 - Printf.sprintf "%.0f" f 45 45 - else 46 46 - Printf.sprintf "%g" f 42 42 + if Float.is_integer f && Float.abs f < 1e15 then Printf.sprintf "%.0f" f 43 43 + else Printf.sprintf "%g" f 47 44 in 48 45 `Scalar (Scalar.make s) 49 49 - | `String s -> 50 50 - `Scalar (Scalar.make s ~style:`Double_quoted) 51 51 - | `A items -> 52 52 - `A (Sequence.make (List.map of_value items)) 46 46 + | `String s -> `Scalar (Scalar.make s ~style:`Double_quoted) 47 47 + | `A items -> `A (Sequence.make (List.map of_value items)) 53 48 | `O pairs -> 54 54 - `O (Mapping.make (List.map (fun (k, v) -> 55 55 - (`Scalar (Scalar.make k), of_value v) 56 56 - ) pairs)) 49 49 + `O 50 50 + (Mapping.make 51 51 + (List.map 52 52 + (fun (k, v) -> (`Scalar (Scalar.make k), of_value v)) 53 53 + pairs)) 57 54 58 58 - (** Default limits for alias expansion (protection against billion laughs attack) *) 55 55 + (** Default limits for alias expansion (protection against billion laughs 56 56 + attack) *) 59 57 let default_max_alias_nodes = 10_000_000 58 58 + 60 59 let default_max_alias_depth = 100 61 60 62 61 (** Resolve aliases by replacing them with referenced nodes. 63 62 64 64 - Processes the tree in document order so that aliases resolve to the 65 65 - anchor value that was defined at the point the alias was encountered. 63 63 + Processes the tree in document order so that aliases resolve to the anchor 64 64 + value that was defined at the point the alias was encountered. 66 65 67 67 - See {{:https://yaml.org/spec/1.2.2/#3222-anchors-and-aliases}Section 3.2.2.2 68 68 - (Anchors and Aliases)} of the YAML 1.2.2 specification for details on 69 69 - how anchors and aliases work in YAML. 66 66 + See 67 67 + {{:https://yaml.org/spec/1.2.2/#3222-anchors-and-aliases}Section 3.2.2.2 68 68 + (Anchors and Aliases)} of the YAML 1.2.2 specification for details on how 69 69 + anchors and aliases work in YAML. 70 70 71 71 - This implements protection against the "billion laughs attack" 72 72 - (see {{:https://yaml.org/spec/1.2.2/#321-processes}Section 3.2.1 (Processes)}) 73 73 - by limiting both the total number of nodes and the nesting depth during expansion. 71 71 + This implements protection against the "billion laughs attack" (see 72 72 + {{:https://yaml.org/spec/1.2.2/#321-processes}Section 3.2.1 (Processes)}) by 73 73 + limiting both the total number of nodes and the nesting depth during 74 74 + expansion. 74 75 75 75 - @param max_nodes Maximum number of nodes to create during expansion (default 10M) 76 76 - @param max_depth Maximum depth of alias-within-alias resolution (default 100) 77 77 - @raise Error.Yamlrw_error with {!type:Error.kind} [Alias_expansion_node_limit] if max_nodes is exceeded 78 78 - @raise Error.Yamlrw_error with {!type:Error.kind} [Alias_expansion_depth_limit] if max_depth is exceeded 79 79 - *) 80 80 - let resolve_aliases ?(max_nodes = default_max_alias_nodes) ?(max_depth = default_max_alias_depth) (root : t) : t = 76 76 + @param max_nodes 77 77 + Maximum number of nodes to create during expansion (default 10M) 78 78 + @param max_depth 79 79 + Maximum depth of alias-within-alias resolution (default 100) 80 80 + @raise Error.Yamlrw_error 81 81 + with {!type:Error.kind} [Alias_expansion_node_limit] if max_nodes is 82 82 + exceeded 83 83 + @raise Error.Yamlrw_error 84 84 + with {!type:Error.kind} [Alias_expansion_depth_limit] if max_depth is 85 85 + exceeded *) 86 86 + let resolve_aliases ?(max_nodes = default_max_alias_nodes) 87 87 + ?(max_depth = default_max_alias_depth) (root : t) : t = 81 88 let anchors = Hashtbl.create 16 in 82 89 let node_count = ref 0 in 83 90 ··· 103 110 need expansion if it was registered before those anchors existed *) 104 111 resolve ~depth:(depth + 1) target 105 112 | None -> Error.raise (Undefined_alias name) 106 106 - 107 113 (* Single pass: process in document order, registering anchors and resolving aliases *) 108 114 and resolve ~depth (v : t) : t = 109 115 check_node_limit (); ··· 112 118 (* Register anchor after we have the resolved node *) 113 119 Option.iter (fun name -> register_anchor name v) (Scalar.anchor s); 114 120 v 115 115 - | `Alias name -> 116 116 - expand_alias ~depth name 121 121 + | `Alias name -> expand_alias ~depth name 117 122 | `A seq -> 118 123 (* First resolve all members in order *) 119 119 - let resolved_members = List.map (resolve ~depth) (Sequence.members seq) in 120 120 - let resolved = `A (Sequence.make 121 121 - ?anchor:(Sequence.anchor seq) 122 122 - ?tag:(Sequence.tag seq) 123 123 - ~implicit:(Sequence.implicit seq) 124 124 - ~style:(Sequence.style seq) 125 125 - resolved_members) in 124 124 + let resolved_members = 125 125 + List.map (resolve ~depth) (Sequence.members seq) 126 126 + in 127 127 + let resolved = 128 128 + `A 129 129 + (Sequence.make ?anchor:(Sequence.anchor seq) ?tag:(Sequence.tag seq) 130 130 + ~implicit:(Sequence.implicit seq) ~style:(Sequence.style seq) 131 131 + resolved_members) 132 132 + in 126 133 (* Register anchor with resolved node *) 127 134 Option.iter (fun name -> register_anchor name resolved) (Sequence.anchor seq); 128 135 resolved 129 136 | `O map -> 130 137 (* Process key-value pairs in document order *) 131 131 - let resolved_pairs = List.map (fun (k, v) -> 132 132 - let resolved_k = resolve ~depth k in 133 133 - let resolved_v = resolve ~depth v in 134 134 - (resolved_k, resolved_v) 135 135 - ) (Mapping.members map) in 136 136 - let resolved = `O (Mapping.make 137 137 - ?anchor:(Mapping.anchor map) 138 138 - ?tag:(Mapping.tag map) 139 139 - ~implicit:(Mapping.implicit map) 140 140 - ~style:(Mapping.style map) 141 141 - resolved_pairs) in 138 138 + let resolved_pairs = 139 139 + List.map 140 140 + (fun (k, v) -> 141 141 + let resolved_k = resolve ~depth k in 142 142 + let resolved_v = resolve ~depth v in 143 143 + (resolved_k, resolved_v)) 144 144 + (Mapping.members map) 145 145 + in 146 146 + let resolved = 147 147 + `O 148 148 + (Mapping.make ?anchor:(Mapping.anchor map) ?tag:(Mapping.tag map) 149 149 + ~implicit:(Mapping.implicit map) ~style:(Mapping.style map) 150 150 + resolved_pairs) 151 151 + in 142 152 (* Register anchor with resolved node *) 143 153 Option.iter (fun name -> register_anchor name resolved) (Mapping.anchor map); 144 154 resolved ··· 153 163 154 164 (* If explicitly tagged, respect the tag *) 155 165 match tag with 156 156 - | Some "tag:yaml.org,2002:null" | Some "!!null" -> 157 157 - `Null 158 158 - | Some "tag:yaml.org,2002:bool" | Some "!!bool" -> 159 159 - (match String.lowercase_ascii value with 160 160 - | "true" | "yes" | "on" -> `Bool true 161 161 - | "false" | "no" | "off" -> `Bool false 162 162 - | _ -> Error.raise (Invalid_scalar_conversion (value, "bool"))) 163 163 - | Some "tag:yaml.org,2002:int" | Some "!!int" -> 164 164 - (try `Float (Float.of_string value) 165 165 - with _ -> Error.raise (Invalid_scalar_conversion (value, "int"))) 166 166 - | Some "tag:yaml.org,2002:float" | Some "!!float" -> 167 167 - (try `Float (Float.of_string value) 168 168 - with _ -> Error.raise (Invalid_scalar_conversion (value, "float"))) 169 169 - | Some "tag:yaml.org,2002:str" | Some "!!str" -> 170 170 - `String value 166 166 + | Some "tag:yaml.org,2002:null" | Some "!!null" -> `Null 167 167 + | Some "tag:yaml.org,2002:bool" | Some "!!bool" -> ( 168 168 + match String.lowercase_ascii value with 169 169 + | "true" | "yes" | "on" -> `Bool true 170 170 + | "false" | "no" | "off" -> `Bool false 171 171 + | _ -> Error.raise (Invalid_scalar_conversion (value, "bool"))) 172 172 + | Some "tag:yaml.org,2002:int" | Some "!!int" -> ( 173 173 + try `Float (Float.of_string value) 174 174 + with _ -> Error.raise (Invalid_scalar_conversion (value, "int"))) 175 175 + | Some "tag:yaml.org,2002:float" | Some "!!float" -> ( 176 176 + try `Float (Float.of_string value) 177 177 + with _ -> Error.raise (Invalid_scalar_conversion (value, "float"))) 178 178 + | Some "tag:yaml.org,2002:str" | Some "!!str" -> `String value 171 179 | Some _ -> 172 180 (* Unknown tag - treat as string *) 173 181 `String value 174 182 | None -> 175 183 (* Implicit type resolution for plain scalars *) 176 176 - if style <> `Plain then 177 177 - `String value 178 178 - else 179 179 - infer_scalar_type value 184 184 + if style <> `Plain then `String value else infer_scalar_type value 180 185 181 186 (** Infer type from plain scalar value *) 182 187 and infer_scalar_type value = ··· 208 213 else if (first = '-' || first = '+') && len >= 2 then 209 214 let second = value.[1] in 210 215 (* After sign, must be digit or dot-digit (for +.5, -.5) *) 211 211 - second >= '0' && second <= '9' || 212 212 - (second = '.' && len >= 3 && value.[2] >= '0' && value.[2] <= '9') 216 216 + (second >= '0' && second <= '9') 217 217 + || (second = '.' && len >= 3 && value.[2] >= '0' && value.[2] <= '9') 213 218 else false 214 219 in 215 220 (* Try integer/float *) ··· 231 236 | _ -> 232 237 (* Decimal with leading zero or octal in YAML 1.1 *) 233 238 Some (`Float (Float.of_string value)) 234 234 - else 235 235 - Some (`Float (Float.of_string value)) 239 239 + else Some (`Float (Float.of_string value)) 236 240 with _ -> None 237 241 else None 238 242 in ··· 244 248 OCaml accepts "nan", "inf", "infinity" which are NOT valid YAML floats. 245 249 YAML requires the leading dot: .nan, .inf, -.inf 246 250 See: https://github.com/avsm/ocaml-yaml/issues/82 *) 247 247 - if String.length value >= 2 && value.[0] = '.' && 248 248 - value.[1] >= '0' && value.[1] <= '9' then 249 249 - try `Float (Float.of_string value) 250 250 - with _ -> `String value 251 251 - else 252 252 - `String value 251 251 + if 252 252 + String.length value >= 2 253 253 + && value.[0] = '.' 254 254 + && value.[1] >= '0' 255 255 + && value.[1] <= '9' 256 256 + then try `Float (Float.of_string value) with _ -> `String value 257 257 + else `String value 253 258 254 259 (** Convert to JSON-compatible Value. 255 260 256 256 - Converts a full YAML representation to a simplified JSON-compatible value type. 257 257 - This process implements the representation graph to serialization tree conversion 258 258 - described in {{:https://yaml.org/spec/1.2.2/#32-processes}Section 3.2 (Processes)} 259 259 - of the YAML 1.2.2 specification. 261 261 + Converts a full YAML representation to a simplified JSON-compatible value 262 262 + type. This process implements the representation graph to serialization tree 263 263 + conversion described in 264 264 + {{:https://yaml.org/spec/1.2.2/#32-processes}Section 3.2 (Processes)} of the 265 265 + YAML 1.2.2 specification. 260 266 261 261 - See also {{:https://yaml.org/spec/1.2.2/#10212-json-schema}Section 10.2.1.2 262 262 - (JSON Schema)} for the tag resolution used during conversion. 267 267 + See also 268 268 + {{:https://yaml.org/spec/1.2.2/#10212-json-schema}Section 10.2.1.2 (JSON 269 269 + Schema)} for the tag resolution used during conversion. 263 270 264 264 - @param resolve_aliases_first Whether to resolve aliases before conversion (default true) 271 271 + @param resolve_aliases_first 272 272 + Whether to resolve aliases before conversion (default true) 265 273 @param max_nodes Maximum nodes during alias expansion (default 10M) 266 274 @param max_depth Maximum alias nesting depth (default 100) 267 267 - @raise Error.Yamlrw_error with {!type:Error.kind} [Unresolved_alias] if resolve_aliases_first is false and an alias is encountered 268 268 - *) 269 269 - let to_value 270 270 - ?(resolve_aliases_first = true) 275 275 + @raise Error.Yamlrw_error 276 276 + with {!type:Error.kind} [Unresolved_alias] if resolve_aliases_first is 277 277 + false and an alias is encountered *) 278 278 + let to_value ?(resolve_aliases_first = true) 271 279 ?(max_nodes = default_max_alias_nodes) 272 272 - ?(max_depth = default_max_alias_depth) 273 273 - (v : t) : Value.t = 274 274 - let v = if resolve_aliases_first then resolve_aliases ~max_nodes ~max_depth v else v in 280 280 + ?(max_depth = default_max_alias_depth) (v : t) : Value.t = 281 281 + let v = 282 282 + if resolve_aliases_first then resolve_aliases ~max_nodes ~max_depth v else v 283 283 + in 275 284 let rec convert (v : t) : Value.t = 276 285 match v with 277 286 | `Scalar s -> scalar_to_value s 278 287 | `Alias name -> Error.raise (Unresolved_alias name) 279 288 | `A seq -> `A (List.map convert (Sequence.members seq)) 280 289 | `O map -> 281 281 - `O (List.map (fun (k, v) -> 282 282 - let key = match k with 283 283 - | `Scalar s -> Scalar.value s 284 284 - | _ -> Error.raise (Type_mismatch ("string key", "complex key")) 285 285 - in 286 286 - (key, convert v) 287 287 - ) (Mapping.members map)) 290 290 + `O 291 291 + (List.map 292 292 + (fun (k, v) -> 293 293 + let key = 294 294 + match k with 295 295 + | `Scalar s -> Scalar.value s 296 296 + | _ -> 297 297 + Error.raise (Type_mismatch ("string key", "complex key")) 298 298 + in 299 299 + (key, convert v)) 300 300 + (Mapping.members map)) 288 301 in 289 302 convert v 290 303

+183 -253

lib/yamlrw.ml

··· 11 11 12 12 exception Yamlrw_error = Error.Yamlrw_error 13 13 14 14 - 15 14 (** {2 Core Types} *) 16 15 16 16 + type value = 17 17 + [ `Null (** YAML null, ~, or empty values *) 18 18 + | `Bool of bool (** YAML booleans (true, false, yes, no, on, off) *) 19 19 + | `Float of float (** All YAML numbers (integers stored as floats) *) 20 20 + | `String of string (** YAML strings *) 21 21 + | `A of value list (** YAML sequences/arrays *) 22 22 + | `O of (string * value) list (** YAML mappings/objects with string keys *) 23 23 + ] 17 24 (** JSON-compatible YAML representation. Use this for simple data interchange. 18 25 19 26 This type is structurally equivalent to {!Value.t} and compatible with the 20 20 - ezjsonm representation. For additional operations, see {!Value} and {!Util}. *) 21 21 - type value = [ 22 22 - | `Null (** YAML null, ~, or empty values *) 23 23 - | `Bool of bool (** YAML booleans (true, false, yes, no, on, off) *) 24 24 - | `Float of float (** All YAML numbers (integers stored as floats) *) 25 25 - | `String of string (** YAML strings *) 26 26 - | `A of value list (** YAML sequences/arrays *) 27 27 - | `O of (string * value) list (** YAML mappings/objects with string keys *) 28 28 - ] 27 27 + ezjsonm representation. For additional operations, see {!Value} and {!Util}. 28 28 + *) 29 29 30 30 + type yaml = 31 31 + [ `Scalar of Scalar.t (** YAML scalar value with style and metadata *) 32 32 + | `Alias of string (** Alias reference to an anchored node *) 33 33 + | `A of yaml Sequence.t (** YAML sequence with style and metadata *) 34 34 + | `O of (yaml, yaml) Mapping.t (** YAML mapping with style and metadata *) 35 35 + ] 30 36 (** Full YAML representation preserving anchors, tags, and aliases. 31 37 32 38 This type is structurally equivalent to {!Yaml.t}. Use this when you need ··· 34 40 type tags for custom types, scalar styles (plain, quoted, literal, folded), 35 41 and collection styles (block vs flow). 36 42 37 37 - For additional operations, see {!Yaml}, {!Scalar}, {!Sequence}, and {!Mapping}. *) 38 38 - type yaml = [ 39 39 - | `Scalar of Scalar.t (** YAML scalar value with style and metadata *) 40 40 - | `Alias of string (** Alias reference to an anchored node *) 41 41 - | `A of yaml Sequence.t (** YAML sequence with style and metadata *) 42 42 - | `O of (yaml, yaml) Mapping.t (** YAML mapping with style and metadata *) 43 43 - ] 43 43 + For additional operations, see {!Yaml}, {!Scalar}, {!Sequence}, and 44 44 + {!Mapping}. *) 44 45 46 46 + type document = { 47 47 + version : (int * int) option; 48 48 + (** Optional YAML version directive (e.g., (1, 2) for YAML 1.2) *) 49 49 + tags : (string * string) list; 50 50 + (** TAG directives mapping handles to prefixes *) 51 51 + root : yaml option; (** Root content of the document *) 52 52 + implicit_start : bool; 53 53 + (** Whether the document start marker (---) is implicit *) 54 54 + implicit_end : bool; (** Whether the document end marker (...) is implicit *) 55 55 + } 45 56 (** A YAML document with directives and metadata. 46 57 47 58 This type is structurally equivalent to {!Document.t}. A YAML stream can 48 59 contain multiple documents, each separated by document markers. 49 60 50 61 For additional operations, see {!Document}. *) 51 51 - type document = { 52 52 - version : (int * int) option; (** Optional YAML version directive (e.g., (1, 2) for YAML 1.2) *) 53 53 - tags : (string * string) list; (** TAG directives mapping handles to prefixes *) 54 54 - root : yaml option; (** Root content of the document *) 55 55 - implicit_start : bool; (** Whether the document start marker (---) is implicit *) 56 56 - implicit_end : bool; (** Whether the document end marker (...) is implicit *) 57 57 - } 58 58 - 59 62 60 63 (** {2 Character Encoding} *) 61 64 62 65 module Encoding = Encoding 63 63 - 64 66 65 67 (** {2 Parsing} *) 66 68 ··· 72 74 (** Default maximum alias nesting depth (100). *) 73 75 let default_max_alias_depth = Yaml.default_max_alias_depth 74 76 75 75 - let of_string 76 76 - ?(resolve_aliases = true) 77 77 - ?(max_nodes = default_max_alias_nodes) 78 78 - ?(max_depth = default_max_alias_depth) 79 79 - s : value = 80 80 - (Loader.value_of_string ~resolve_aliases ~max_nodes ~max_depth s :> value) 81 77 (** Parse a YAML string into a JSON-compatible value. 82 78 83 79 @param resolve_aliases Whether to expand aliases (default: true) 84 80 @param max_nodes Maximum nodes during alias expansion (default: 10M) 85 81 @param max_depth Maximum alias nesting depth (default: 100) 86 82 @raise Yamlrw_error on parse error or if multiple documents found *) 83 83 + let of_string ?(resolve_aliases = true) ?(max_nodes = default_max_alias_nodes) 84 84 + ?(max_depth = default_max_alias_depth) s : value = 85 85 + (Loader.value_of_string ~resolve_aliases ~max_nodes ~max_depth s :> value) 87 86 88 88 - let yaml_of_string 89 89 - ?(resolve_aliases = false) 90 90 - ?(max_nodes = default_max_alias_nodes) 91 91 - ?(max_depth = default_max_alias_depth) 92 92 - s : yaml = 93 93 - (Loader.yaml_of_string ~resolve_aliases ~max_nodes ~max_depth s :> yaml) 94 87 (** Parse a YAML string preserving full YAML metadata (anchors, tags, etc). 95 88 96 89 By default, aliases are NOT resolved, preserving the document structure. ··· 99 92 @param max_nodes Maximum nodes during alias expansion (default: 10M) 100 93 @param max_depth Maximum alias nesting depth (default: 100) 101 94 @raise Yamlrw_error on parse error or if multiple documents found *) 95 95 + let yaml_of_string ?(resolve_aliases = false) 96 96 + ?(max_nodes = default_max_alias_nodes) 97 97 + ?(max_depth = default_max_alias_depth) s : yaml = 98 98 + (Loader.yaml_of_string ~resolve_aliases ~max_nodes ~max_depth s :> yaml) 102 99 103 103 - let documents_of_string s : document list = 104 104 - let docs = Loader.documents_of_string s in 105 105 - List.map (fun (d : Document.t) : document -> { 106 106 - version = d.version; 107 107 - tags = d.tags; 108 108 - root = (d.root :> yaml option); 109 109 - implicit_start = d.implicit_start; 110 110 - implicit_end = d.implicit_end; 111 111 - }) docs 112 100 (** Parse a multi-document YAML stream. 113 101 114 114 - Use this when your YAML input contains multiple documents separated 115 115 - by document markers (---). 102 102 + Use this when your YAML input contains multiple documents separated by 103 103 + document markers (---). 116 104 117 105 @raise Yamlrw_error on parse error *) 118 118 - 106 106 + let documents_of_string s : document list = 107 107 + let docs = Loader.documents_of_string s in 108 108 + List.map 109 109 + (fun (d : Document.t) : document -> 110 110 + { 111 111 + version = d.version; 112 112 + tags = d.tags; 113 113 + root = (d.root :> yaml option); 114 114 + implicit_start = d.implicit_start; 115 115 + implicit_end = d.implicit_end; 116 116 + }) 117 117 + docs 119 118 120 119 (** {2 Formatting Styles} *) 121 120 122 121 module Scalar_style = Scalar_style 123 123 - 124 122 module Layout_style = Layout_style 125 123 126 126 - 127 124 (** {2 Serialization} *) 128 125 129 126 let make_config ~encoding ~scalar_style ~layout_style = 130 127 { Emitter.default_config with encoding; scalar_style; layout_style } 131 128 132 132 - let to_buffer 133 133 - ?(encoding = `Utf8) 134 134 - ?(scalar_style = `Any) 135 135 - ?(layout_style = `Any) 136 136 - ?buffer 137 137 - (value : value) = 138 138 - let config = make_config ~encoding ~scalar_style ~layout_style in 139 139 - Serialize.value_to_buffer ~config ?buffer (value :> Value.t) 140 129 (** Serialize a value to a buffer. 141 130 142 131 @param encoding Output encoding (default: UTF-8) 143 132 @param scalar_style Preferred scalar style (default: Any) 144 133 @param layout_style Preferred layout style (default: Any) 145 145 - @param buffer Optional buffer to append to (allocates new one if not provided) 134 134 + @param buffer 135 135 + Optional buffer to append to (allocates new one if not provided) 146 136 @return The buffer containing the serialized YAML *) 137 137 + let to_buffer ?(encoding = `Utf8) ?(scalar_style = `Any) ?(layout_style = `Any) 138 138 + ?buffer (value : value) = 139 139 + let config = make_config ~encoding ~scalar_style ~layout_style in 140 140 + Serialize.value_to_buffer ~config ?buffer (value :> Value.t) 147 141 148 148 - let to_string 149 149 - ?(encoding = `Utf8) 150 150 - ?(scalar_style = `Any) 151 151 - ?(layout_style = `Any) 152 152 - (value : value) = 153 153 - Buffer.contents (to_buffer ~encoding ~scalar_style ~layout_style value) 154 142 (** Serialize a value to a YAML string. 155 143 156 144 @param encoding Output encoding (default: UTF-8) 157 145 @param scalar_style Preferred scalar style (default: Any) 158 146 @param layout_style Preferred layout style (default: Any) *) 147 147 + let to_string ?(encoding = `Utf8) ?(scalar_style = `Any) ?(layout_style = `Any) 148 148 + (value : value) = 149 149 + Buffer.contents (to_buffer ~encoding ~scalar_style ~layout_style value) 159 150 160 160 - let yaml_to_buffer 161 161 - ?(encoding = `Utf8) 162 162 - ?(scalar_style = `Any) 163 163 - ?(layout_style = `Any) 164 164 - ?buffer 165 165 - (yaml : yaml) = 166 166 - let config = make_config ~encoding ~scalar_style ~layout_style in 167 167 - Serialize.yaml_to_buffer ~config ?buffer (yaml :> Yaml.t) 168 151 (** Serialize a full YAML value to a buffer. 169 152 170 153 @param encoding Output encoding (default: UTF-8) 171 154 @param scalar_style Preferred scalar style (default: Any) 172 155 @param layout_style Preferred layout style (default: Any) 173 173 - @param buffer Optional buffer to append to (allocates new one if not provided) 156 156 + @param buffer 157 157 + Optional buffer to append to (allocates new one if not provided) 174 158 @return The buffer containing the serialized YAML *) 159 159 + let yaml_to_buffer ?(encoding = `Utf8) ?(scalar_style = `Any) 160 160 + ?(layout_style = `Any) ?buffer (yaml : yaml) = 161 161 + let config = make_config ~encoding ~scalar_style ~layout_style in 162 162 + Serialize.yaml_to_buffer ~config ?buffer (yaml :> Yaml.t) 175 163 176 176 - let yaml_to_string 177 177 - ?(encoding = `Utf8) 178 178 - ?(scalar_style = `Any) 179 179 - ?(layout_style = `Any) 180 180 - (yaml : yaml) = 181 181 - Buffer.contents (yaml_to_buffer ~encoding ~scalar_style ~layout_style yaml) 182 164 (** Serialize a full YAML value to a string. 183 165 184 166 @param encoding Output encoding (default: UTF-8) 185 167 @param scalar_style Preferred scalar style (default: Any) 186 168 @param layout_style Preferred layout style (default: Any) *) 169 169 + let yaml_to_string ?(encoding = `Utf8) ?(scalar_style = `Any) 170 170 + ?(layout_style = `Any) (yaml : yaml) = 171 171 + Buffer.contents (yaml_to_buffer ~encoding ~scalar_style ~layout_style yaml) 187 172 188 188 - let documents_to_buffer 189 189 - ?(encoding = `Utf8) 190 190 - ?(scalar_style = `Any) 191 191 - ?(layout_style = `Any) 192 192 - ?(resolve_aliases = true) 193 193 - ?buffer 194 194 - (documents : document list) = 195 195 - let config = make_config ~encoding ~scalar_style ~layout_style in 196 196 - let docs' = List.map (fun (d : document) : Document.t -> { 197 197 - Document.version = d.version; 198 198 - Document.tags = d.tags; 199 199 - Document.root = (d.root :> Yaml.t option); 200 200 - Document.implicit_start = d.implicit_start; 201 201 - Document.implicit_end = d.implicit_end; 202 202 - }) documents in 203 203 - Serialize.documents_to_buffer ~config ~resolve_aliases ?buffer docs' 204 173 (** Serialize multiple documents to a buffer. 205 174 206 175 @param encoding Output encoding (default: UTF-8) 207 176 @param scalar_style Preferred scalar style (default: Any) 208 177 @param layout_style Preferred layout style (default: Any) 209 178 @param resolve_aliases Whether to expand aliases (default: true) 210 210 - @param buffer Optional buffer to append to (allocates new one if not provided) 179 179 + @param buffer 180 180 + Optional buffer to append to (allocates new one if not provided) 211 181 @return The buffer containing the serialized YAML *) 212 212 - 213 213 - let documents_to_string 214 214 - ?(encoding = `Utf8) 215 215 - ?(scalar_style = `Any) 216 216 - ?(layout_style = `Any) 217 217 - ?(resolve_aliases = true) 182 182 + let documents_to_buffer ?(encoding = `Utf8) ?(scalar_style = `Any) 183 183 + ?(layout_style = `Any) ?(resolve_aliases = true) ?buffer 218 184 (documents : document list) = 219 219 - Buffer.contents (documents_to_buffer ~encoding ~scalar_style ~layout_style ~resolve_aliases documents) 185 185 + let config = make_config ~encoding ~scalar_style ~layout_style in 186 186 + let docs' = 187 187 + List.map 188 188 + (fun (d : document) : Document.t -> 189 189 + { 190 190 + Document.version = d.version; 191 191 + Document.tags = d.tags; 192 192 + Document.root = (d.root :> Yaml.t option); 193 193 + Document.implicit_start = d.implicit_start; 194 194 + Document.implicit_end = d.implicit_end; 195 195 + }) 196 196 + documents 197 197 + in 198 198 + Serialize.documents_to_buffer ~config ~resolve_aliases ?buffer docs' 199 199 + 220 200 (** Serialize multiple documents to a YAML stream. 221 201 222 202 @param encoding Output encoding (default: UTF-8) 223 203 @param scalar_style Preferred scalar style (default: Any) 224 204 @param layout_style Preferred layout style (default: Any) 225 205 @param resolve_aliases Whether to expand aliases (default: true) *) 206 206 + let documents_to_string ?(encoding = `Utf8) ?(scalar_style = `Any) 207 207 + ?(layout_style = `Any) ?(resolve_aliases = true) (documents : document list) 208 208 + = 209 209 + Buffer.contents 210 210 + (documents_to_buffer ~encoding ~scalar_style ~layout_style ~resolve_aliases 211 211 + documents) 226 212 227 213 (** {2 Buffer Parsing} *) 228 214 229 229 - let of_buffer 230 230 - ?(resolve_aliases = true) 231 231 - ?(max_nodes = default_max_alias_nodes) 232 232 - ?(max_depth = default_max_alias_depth) 233 233 - buffer : value = 234 234 - of_string ~resolve_aliases ~max_nodes ~max_depth (Buffer.contents buffer) 235 215 (** Parse YAML from a buffer into a JSON-compatible value. 236 216 237 217 @param resolve_aliases Whether to expand aliases (default: true) 238 218 @param max_nodes Maximum nodes during alias expansion (default: 10M) 239 219 @param max_depth Maximum alias nesting depth (default: 100) 240 220 @raise Yamlrw_error on parse error or if multiple documents found *) 221 221 + let of_buffer ?(resolve_aliases = true) ?(max_nodes = default_max_alias_nodes) 222 222 + ?(max_depth = default_max_alias_depth) buffer : value = 223 223 + of_string ~resolve_aliases ~max_nodes ~max_depth (Buffer.contents buffer) 241 224 242 242 - let yaml_of_buffer 243 243 - ?(resolve_aliases = false) 244 244 - ?(max_nodes = default_max_alias_nodes) 245 245 - ?(max_depth = default_max_alias_depth) 246 246 - buffer : yaml = 247 247 - yaml_of_string ~resolve_aliases ~max_nodes ~max_depth (Buffer.contents buffer) 248 225 (** Parse YAML from a buffer preserving full YAML metadata. 249 226 250 227 @param resolve_aliases Whether to expand aliases (default: false) 251 228 @param max_nodes Maximum nodes during alias expansion (default: 10M) 252 229 @param max_depth Maximum alias nesting depth (default: 100) 253 230 @raise Yamlrw_error on parse error or if multiple documents found *) 231 231 + let yaml_of_buffer ?(resolve_aliases = false) 232 232 + ?(max_nodes = default_max_alias_nodes) 233 233 + ?(max_depth = default_max_alias_depth) buffer : yaml = 234 234 + yaml_of_string ~resolve_aliases ~max_nodes ~max_depth (Buffer.contents buffer) 254 235 255 255 - let documents_of_buffer buffer : document list = 256 256 - documents_of_string (Buffer.contents buffer) 257 236 (** Parse a multi-document YAML stream from a buffer. 258 237 259 238 @raise Yamlrw_error on parse error *) 260 260 - 239 239 + let documents_of_buffer buffer : document list = 240 240 + documents_of_string (Buffer.contents buffer) 261 241 262 242 (** {2 Conversion} *) 263 243 264 264 - let to_json 265 265 - ?(resolve_aliases = true) 266 266 - ?(max_nodes = default_max_alias_nodes) 267 267 - ?(max_depth = default_max_alias_depth) 268 268 - (yaml : yaml) : value = 269 269 - (Yaml.to_value ~resolve_aliases_first:resolve_aliases ~max_nodes ~max_depth (yaml :> Yaml.t) :> value) 270 244 (** Convert full YAML to JSON-compatible value. 271 245 272 246 @param resolve_aliases Whether to expand aliases (default: true) 273 247 @param max_nodes Maximum nodes during alias expansion (default: 10M) 274 248 @param max_depth Maximum alias nesting depth (default: 100) 275 249 @raise Yamlrw_error if alias limits exceeded or complex keys found *) 250 250 + let to_json ?(resolve_aliases = true) ?(max_nodes = default_max_alias_nodes) 251 251 + ?(max_depth = default_max_alias_depth) (yaml : yaml) : value = 252 252 + (Yaml.to_value ~resolve_aliases_first:resolve_aliases ~max_nodes ~max_depth 253 253 + (yaml :> Yaml.t) 254 254 + :> value) 276 255 277 277 - let of_json (value : value) : yaml = 278 278 - (Yaml.of_value (value :> Value.t) :> yaml) 279 256 (** Convert JSON-compatible value to full YAML representation. *) 280 280 - 257 257 + let of_json (value : value) : yaml = (Yaml.of_value (value :> Value.t) :> yaml) 281 258 282 259 (** {2 Pretty Printing & Equality} *) 283 260 261 261 + (** Pretty-print a value. *) 284 262 let pp = Value.pp 285 285 - (** Pretty-print a value. *) 286 263 287 287 - let equal = Value.equal 288 264 (** Test equality of two values. *) 289 289 - 265 265 + let equal = Value.equal 290 266 291 267 (** {2 Util - Value Combinators} *) 292 268 293 269 module Util = struct 294 270 (** Combinators for working with {!type:value} values. 295 271 296 296 - This module provides constructors, accessors, and transformations 297 297 - for JSON-compatible YAML values. *) 272 272 + This module provides constructors, accessors, and transformations for 273 273 + JSON-compatible YAML values. *) 298 274 299 275 type t = Value.t 300 276 ··· 349 325 let get_string v = match v with `String s -> s | _ -> type_error "string" v 350 326 let get_list v = match v with `A l -> l | _ -> type_error "list" v 351 327 let get_obj v = match v with `O o -> o | _ -> type_error "object" v 352 352 - 353 353 - let get_int v = 354 354 - match as_int v with 355 355 - | Some i -> i 356 356 - | None -> type_error "int" v 328 328 + let get_int v = match as_int v with Some i -> i | None -> type_error "int" v 357 329 358 330 (** {3 Object Operations} *) 359 331 ··· 361 333 | `O pairs -> List.exists (fun (k, _) -> k = key) pairs 362 334 | _ -> false 363 335 364 364 - let find key = function 365 365 - | `O pairs -> List.assoc_opt key pairs 366 366 - | _ -> None 336 336 + let find key = function `O pairs -> List.assoc_opt key pairs | _ -> None 337 337 + let get key v = match find key v with Some v -> v | None -> raise Not_found 367 338 368 368 - let get key v = 369 369 - match find key v with 370 370 - | Some v -> v 371 371 - | None -> raise Not_found 339 339 + let keys v = 340 340 + match v with `O pairs -> List.map fst pairs | _ -> type_error "object" v 372 341 373 373 - let keys v = match v with 374 374 - | `O pairs -> List.map fst pairs 375 375 - | _ -> type_error "object" v 376 376 - 377 377 - let values v = match v with 378 378 - | `O pairs -> List.map snd pairs 379 379 - | _ -> type_error "object" v 342 342 + let values v = 343 343 + match v with `O pairs -> List.map snd pairs | _ -> type_error "object" v 380 344 381 345 let update key value = function 382 346 | `O pairs -> 383 347 let rec go = function 384 384 - | [] -> [(key, value)] 348 348 + | [] -> [ (key, value) ] 385 349 | (k, _) :: rest when k = key -> (key, value) :: rest 386 350 | kv :: rest -> kv :: go rest 387 351 in ··· 393 357 | v -> type_error "object" v 394 358 395 359 let combine v1 v2 = 396 396 - match v1, v2 with 360 360 + match (v1, v2) with 397 361 | `O o1, `O o2 -> `O (o1 @ o2) 398 362 | `O _, _ -> type_error "object" v2 399 363 | _, _ -> type_error "object" v1 400 364 401 365 (** {3 List Operations} *) 402 366 403 403 - let map f = function 404 404 - | `A l -> `A (List.map f l) 405 405 - | v -> type_error "list" v 406 406 - 407 407 - let mapi f = function 408 408 - | `A l -> `A (List.mapi f l) 409 409 - | v -> type_error "list" v 367 367 + let map f = function `A l -> `A (List.map f l) | v -> type_error "list" v 368 368 + let mapi f = function `A l -> `A (List.mapi f l) | v -> type_error "list" v 410 369 411 370 let filter pred = function 412 371 | `A l -> `A (List.filter pred l) ··· 416 375 | `A l -> List.fold_left f init l 417 376 | v -> type_error "list" v 418 377 419 419 - let nth n = function 420 420 - | `A l -> List.nth_opt l n 421 421 - | _ -> None 422 422 - 423 423 - let length = function 424 424 - | `A l -> List.length l 425 425 - | `O o -> List.length o 426 426 - | _ -> 0 378 378 + let nth n = function `A l -> List.nth_opt l n | _ -> None 379 379 + let length = function `A l -> List.length l | `O o -> List.length o | _ -> 0 427 380 428 381 let flatten = function 429 429 - | `A l -> 430 430 - `A (List.concat_map (function `A inner -> inner | v -> [v]) l) 382 382 + | `A l -> `A (List.concat_map (function `A inner -> inner | v -> [ v ]) l) 431 383 | v -> type_error "list" v 432 384 433 385 (** {3 Path Operations} *) ··· 435 387 let rec get_path path v = 436 388 match path with 437 389 | [] -> Some v 438 438 - | key :: rest -> 439 439 - match find key v with 440 440 - | Some child -> get_path rest child 441 441 - | None -> None 390 390 + | key :: rest -> ( 391 391 + match find key v with Some child -> get_path rest child | None -> None) 442 392 443 393 let get_path_exn path v = 444 444 - match get_path path v with 445 445 - | Some v -> v 446 446 - | None -> raise Not_found 394 394 + match get_path path v with Some v -> v | None -> raise Not_found 447 395 448 396 (** {3 Iteration} *) 449 397 ··· 451 399 | `O pairs -> List.iter (fun (k, v) -> f k v) pairs 452 400 | v -> type_error "object" v 453 401 454 454 - let iter_list f = function 455 455 - | `A l -> List.iter f l 456 456 - | v -> type_error "list" v 402 402 + let iter_list f = function `A l -> List.iter f l | v -> type_error "list" v 457 403 458 404 let fold_obj f init = function 459 405 | `O pairs -> List.fold_left (fun acc (k, v) -> f acc k v) init pairs ··· 472 418 (** {3 Conversion Helpers} *) 473 419 474 420 let to_bool ?default v = 475 475 - match as_bool v, default with 421 421 + match (as_bool v, default) with 476 422 | Some b, _ -> b 477 423 | None, Some d -> d 478 424 | None, None -> type_error "bool" v 479 425 480 426 let to_int ?default v = 481 481 - match as_int v, default with 427 427 + match (as_int v, default) with 482 428 | Some i, _ -> i 483 429 | None, Some d -> d 484 430 | None, None -> type_error "int" v 485 431 486 432 let to_float ?default v = 487 487 - match as_float v, default with 433 433 + match (as_float v, default) with 488 434 | Some f, _ -> f 489 435 | None, Some d -> d 490 436 | None, None -> type_error "float" v 491 437 492 438 let to_string ?default v = 493 493 - match as_string v, default with 439 439 + match (as_string v, default) with 494 440 | Some s, _ -> s 495 441 | None, Some d -> d 496 442 | None, None -> type_error "string" v 497 443 498 444 let to_list ?default v = 499 499 - match as_list v, default with 445 445 + match (as_list v, default) with 500 446 | Some l, _ -> l 501 447 | None, Some d -> d 502 448 | None, None -> type_error "list" v 503 449 end 504 504 - 505 450 506 451 (** {2 Stream - Low-Level Event API} *) 507 452 ··· 521 466 type position = Position.t 522 467 (** A position in the source (line, column, byte offset). *) 523 468 524 524 - (** Result of parsing an event. *) 525 469 type event_result = { 526 470 event : event; 527 471 start_pos : position; 528 472 end_pos : position; 529 473 } 474 474 + (** Result of parsing an event. *) 530 475 531 476 (** {3 Parsing} *) 532 477 533 478 type parser = Parser.t 534 479 (** A streaming YAML parser. *) 535 480 536 536 - let parser s = Parser.of_string s 537 481 (** Create a parser from a string. *) 482 482 + let parser s = Parser.of_string s 538 483 484 484 + (** Get the next event from the parser. Returns [None] when parsing is 485 485 + complete. *) 539 486 let next p = 540 487 match Parser.next p with 541 488 | Some { event; span } -> 542 542 - Some { 543 543 - event; 544 544 - start_pos = span.start; 545 545 - end_pos = span.stop; 546 546 - } 489 489 + Some { event; start_pos = span.start; end_pos = span.stop } 547 490 | None -> None 548 548 - (** Get the next event from the parser. 549 549 - Returns [None] when parsing is complete. *) 550 491 492 492 + (** Iterate over all events from the parser. *) 551 493 let iter f p = 552 494 let rec go () = 553 495 match next p with ··· 557 499 | None -> () 558 500 in 559 501 go () 560 560 - (** Iterate over all events from the parser. *) 561 502 503 503 + (** Fold over all events from the parser. *) 562 504 let fold f init p = 563 505 let rec go acc = 564 506 match Parser.next p with ··· 566 508 | None -> acc 567 509 in 568 510 go init 569 569 - (** Fold over all events from the parser. *) 570 511 571 512 (** {3 Emitting} *) 572 513 573 514 type emitter = Emitter.t 574 515 (** A streaming YAML emitter. *) 575 516 576 576 - let emitter ?len:_ () = Emitter.create () 577 517 (** Create a new emitter. *) 518 518 + let emitter ?len:_ () = Emitter.create () 578 519 579 579 - let contents e = Emitter.contents e 580 520 (** Get the emitted YAML string. *) 521 521 + let contents e = Emitter.contents e 581 522 582 582 - let emit e ev = Emitter.emit e ev 583 523 (** Emit an event. *) 524 524 + let emit e ev = Emitter.emit e ev 584 525 585 526 (** {3 Event Emission Helpers} *) 586 527 587 528 let stream_start e enc = 588 529 Emitter.emit e (Event.Stream_start { encoding = enc }) 589 530 590 590 - let stream_end e = 591 591 - Emitter.emit e Event.Stream_end 531 531 + let stream_end e = Emitter.emit e Event.Stream_end 592 532 593 533 let document_start e ?version ?(implicit = true) () = 594 594 - let version = match version with 534 534 + let version = 535 535 + match version with 595 536 | Some `V1_1 -> Some (1, 1) 596 537 | Some `V1_2 -> Some (1, 2) 597 538 | None -> None ··· 602 543 Emitter.emit e (Event.Document_end { implicit }) 603 544 604 545 let scalar e ?anchor ?tag ?(style = `Any) value = 605 605 - Emitter.emit e (Event.Scalar { 606 606 - anchor; 607 607 - tag; 608 608 - value; 609 609 - plain_implicit = true; 610 610 - quoted_implicit = true; 611 611 - style; 612 612 - }) 546 546 + Emitter.emit e 547 547 + (Event.Scalar 548 548 + { 549 549 + anchor; 550 550 + tag; 551 551 + value; 552 552 + plain_implicit = true; 553 553 + quoted_implicit = true; 554 554 + style; 555 555 + }) 613 556 614 614 - let alias e name = 615 615 - Emitter.emit e (Event.Alias { anchor = name }) 557 557 + let alias e name = Emitter.emit e (Event.Alias { anchor = name }) 616 558 617 559 let sequence_start e ?anchor ?tag ?(style = `Any) () = 618 618 - Emitter.emit e (Event.Sequence_start { 619 619 - anchor; 620 620 - tag; 621 621 - implicit = true; 622 622 - style; 623 623 - }) 560 560 + Emitter.emit e 561 561 + (Event.Sequence_start { anchor; tag; implicit = true; style }) 624 562 625 625 - let sequence_end e = 626 626 - Emitter.emit e Event.Sequence_end 563 563 + let sequence_end e = Emitter.emit e Event.Sequence_end 627 564 628 565 let mapping_start e ?anchor ?tag ?(style = `Any) () = 629 629 - Emitter.emit e (Event.Mapping_start { 630 630 - anchor; 631 631 - tag; 632 632 - implicit = true; 633 633 - style; 634 634 - }) 566 566 + Emitter.emit e (Event.Mapping_start { anchor; tag; implicit = true; style }) 635 567 636 636 - let mapping_end e = 637 637 - Emitter.emit e Event.Mapping_end 568 568 + let mapping_end e = Emitter.emit e Event.Mapping_end 638 569 end 639 639 - 640 570 641 571 (** {2 Internal Modules} *) 642 572 643 643 - (** These modules are exposed for advanced use cases requiring 644 644 - fine-grained control over parsing, emission, or data structures. 573 573 + (** These modules are exposed for advanced use cases requiring fine-grained 574 574 + control over parsing, emission, or data structures. 645 575 646 576 For typical usage, prefer the top-level functions and {!Util}. *) 647 577 648 648 - (** Source position tracking. *) 649 578 module Position = Position 579 579 + (** Source position tracking. *) 650 580 581 581 + module Span = Span 651 582 (** Source span (range of positions). *) 652 652 - module Span = Span 653 583 584 584 + module Chomping = Chomping 654 585 (** Block scalar chomping modes. *) 655 655 - module Chomping = Chomping 656 586 657 657 - (** YAML type tags. *) 658 587 module Tag = Tag 588 588 + (** YAML type tags. *) 659 589 660 660 - (** JSON-compatible value type and operations. *) 661 590 module Value = Value 591 591 + (** JSON-compatible value type and operations. *) 662 592 663 663 - (** YAML scalar with metadata. *) 664 593 module Scalar = Scalar 594 594 + (** YAML scalar with metadata. *) 665 595 596 596 + module Sequence = Sequence 666 597 (** YAML sequence with metadata. *) 667 667 - module Sequence = Sequence 668 598 599 599 + module Mapping = Mapping 669 600 (** YAML mapping with metadata. *) 670 670 - module Mapping = Mapping 671 601 672 672 - (** Full YAML value type. *) 673 602 module Yaml = Yaml 603 603 + (** Full YAML value type. *) 674 604 675 675 - (** YAML document with directives. *) 676 605 module Document = Document 606 606 + (** YAML document with directives. *) 677 607 678 678 - (** Lexical tokens. *) 679 608 module Token = Token 609 609 + (** Lexical tokens. *) 680 610 611 611 + module Scanner = Scanner 681 612 (** Lexical scanner. *) 682 682 - module Scanner = Scanner 683 613 684 684 - (** Parser events. *) 685 614 module Event = Event 615 615 + (** Parser events. *) 686 616 617 617 + module Parser = Parser 687 618 (** Event-based parser. *) 688 688 - module Parser = Parser 689 619 620 620 + module Loader = Loader 690 621 (** Document loader. *) 691 691 - module Loader = Loader 692 622 693 693 - (** Event-based emitter. *) 694 623 module Emitter = Emitter 624 624 + (** Event-based emitter. *) 695 625 696 696 - (** Input stream utilities. *) 697 626 module Input = Input 627 627 + (** Input stream utilities. *) 698 628 629 629 + module Serialize = Serialize 699 630 (** Buffer serialization utilities. *) 700 700 - module Serialize = Serialize

+96 -90

lib/yamlrw.mli

··· 32 32 let age = Yamlrw.Util.(get_int (get "age" value)) in 33 33 ]} *) 34 34 35 35 - 36 35 (** {2 Error Handling} *) 37 36 38 37 module Error = Error ··· 40 39 exception Yamlrw_error of Error.t 41 40 (** Raised on parse or emit errors. *) 42 41 43 43 - 44 42 (** {2 Core Types} *) 45 43 46 46 - type value = [ 47 47 - | `Null (** YAML null, ~, or empty values *) 48 48 - | `Bool of bool (** YAML booleans (true, false, yes, no, on, off) *) 49 49 - | `Float of float (** All YAML numbers (integers stored as floats) *) 50 50 - | `String of string (** YAML strings *) 51 51 - | `A of value list (** YAML sequences/arrays *) 52 52 - | `O of (string * value) list (** YAML mappings/objects with string keys *) 53 53 - ] 44 44 + type value = 45 45 + [ `Null (** YAML null, ~, or empty values *) 46 46 + | `Bool of bool (** YAML booleans (true, false, yes, no, on, off) *) 47 47 + | `Float of float (** All YAML numbers (integers stored as floats) *) 48 48 + | `String of string (** YAML strings *) 49 49 + | `A of value list (** YAML sequences/arrays *) 50 50 + | `O of (string * value) list (** YAML mappings/objects with string keys *) 51 51 + ] 54 52 (** JSON-compatible YAML representation. Use this for simple data interchange. 55 53 56 54 This type is structurally equivalent to {!Value.t} and compatible with the 57 57 - ezjsonm representation. For additional operations, see {!Value} and {!Util}. *) 55 55 + ezjsonm representation. For additional operations, see {!Value} and {!Util}. 56 56 + *) 58 57 59 59 - type yaml = [ 60 60 - | `Scalar of Scalar.t (** YAML scalar value with style and metadata *) 61 61 - | `Alias of string (** Alias reference to an anchored node *) 62 62 - | `A of yaml Sequence.t (** YAML sequence with style and metadata *) 63 63 - | `O of (yaml, yaml) Mapping.t (** YAML mapping with style and metadata *) 64 64 - ] 58 58 + type yaml = 59 59 + [ `Scalar of Scalar.t (** YAML scalar value with style and metadata *) 60 60 + | `Alias of string (** Alias reference to an anchored node *) 61 61 + | `A of yaml Sequence.t (** YAML sequence with style and metadata *) 62 62 + | `O of (yaml, yaml) Mapping.t (** YAML mapping with style and metadata *) 63 63 + ] 65 64 (** Full YAML representation preserving anchors, tags, and aliases. 66 65 67 66 This type is structurally equivalent to {!Yaml.t}. Use this when you need ··· 69 68 type tags for custom types, scalar styles (plain, quoted, literal, folded), 70 69 and collection styles (block vs flow). 71 70 72 72 - For additional operations, see {!Yaml}, {!Scalar}, {!Sequence}, and {!Mapping}. *) 71 71 + For additional operations, see {!Yaml}, {!Scalar}, {!Sequence}, and 72 72 + {!Mapping}. *) 73 73 74 74 type document = { 75 75 - version : (int * int) option; (** Optional YAML version directive (e.g., (1, 2) for YAML 1.2) *) 76 76 - tags : (string * string) list; (** TAG directives mapping handles to prefixes *) 77 77 - root : yaml option; (** Root content of the document *) 78 78 - implicit_start : bool; (** Whether the document start marker (---) is implicit *) 79 79 - implicit_end : bool; (** Whether the document end marker (...) is implicit *) 75 75 + version : (int * int) option; 76 76 + (** Optional YAML version directive (e.g., (1, 2) for YAML 1.2) *) 77 77 + tags : (string * string) list; 78 78 + (** TAG directives mapping handles to prefixes *) 79 79 + root : yaml option; (** Root content of the document *) 80 80 + implicit_start : bool; 81 81 + (** Whether the document start marker (---) is implicit *) 82 82 + implicit_end : bool; (** Whether the document end marker (...) is implicit *) 80 83 } 81 84 (** A YAML document with directives and metadata. 82 85 ··· 84 87 contain multiple documents, each separated by document markers. 85 88 86 89 For additional operations, see {!Document}. *) 87 87 - 88 90 89 91 (** {2 Character Encoding} *) 90 92 91 93 module Encoding = Encoding 92 94 93 93 - 94 95 (** {2 Parsing} *) 95 96 96 97 type version = [ `V1_1 | `V1_2 ] ··· 103 104 (** Default maximum alias nesting depth (100). *) 104 105 105 106 val of_string : 106 106 - ?resolve_aliases:bool -> 107 107 - ?max_nodes:int -> 108 108 - ?max_depth:int -> 109 109 - string -> value 107 107 + ?resolve_aliases:bool -> ?max_nodes:int -> ?max_depth:int -> string -> value 110 108 (** Parse a YAML string into a JSON-compatible value. 111 109 112 110 @param resolve_aliases Whether to expand aliases (default: true) ··· 115 113 @raise Yamlrw_error on parse error or if multiple documents found *) 116 114 117 115 val yaml_of_string : 118 118 - ?resolve_aliases:bool -> 119 119 - ?max_nodes:int -> 120 120 - ?max_depth:int -> 121 121 - string -> yaml 116 116 + ?resolve_aliases:bool -> ?max_nodes:int -> ?max_depth:int -> string -> yaml 122 117 (** Parse a YAML string preserving full YAML metadata (anchors, tags, etc). 123 118 124 119 By default, aliases are NOT resolved, preserving the document structure. ··· 131 126 val documents_of_string : string -> document list 132 127 (** Parse a multi-document YAML stream. 133 128 134 134 - Use this when your YAML input contains multiple documents separated 135 135 - by document markers (---). 129 129 + Use this when your YAML input contains multiple documents separated by 130 130 + document markers (---). 136 131 137 132 @raise Yamlrw_error on parse error *) 138 133 139 139 - 140 134 (** {2 Formatting Styles} *) 141 135 142 136 module Scalar_style = Scalar_style 143 143 - 144 137 module Layout_style = Layout_style 145 145 - 146 138 147 139 (** {2 Serialization} *) 148 140 ··· 151 143 ?scalar_style:Scalar_style.t -> 152 144 ?layout_style:Layout_style.t -> 153 145 ?buffer:Buffer.t -> 154 154 - value -> Buffer.t 146 146 + value -> 147 147 + Buffer.t 155 148 (** Serialize a value to a buffer. 156 149 157 150 @param encoding Output encoding (default: UTF-8) 158 151 @param scalar_style Preferred scalar style (default: Any) 159 152 @param layout_style Preferred layout style (default: Any) 160 160 - @param buffer Optional buffer to append to (allocates new one if not provided) 153 153 + @param buffer 154 154 + Optional buffer to append to (allocates new one if not provided) 161 155 @return The buffer containing the serialized YAML *) 162 156 163 157 val to_string : 164 158 ?encoding:Encoding.t -> 165 159 ?scalar_style:Scalar_style.t -> 166 160 ?layout_style:Layout_style.t -> 167 167 - value -> string 161 161 + value -> 162 162 + string 168 163 (** Serialize a value to a YAML string. 169 164 170 165 @param encoding Output encoding (default: UTF-8) ··· 176 171 ?scalar_style:Scalar_style.t -> 177 172 ?layout_style:Layout_style.t -> 178 173 ?buffer:Buffer.t -> 179 179 - yaml -> Buffer.t 174 174 + yaml -> 175 175 + Buffer.t 180 176 (** Serialize a full YAML value to a buffer. 181 177 182 178 @param encoding Output encoding (default: UTF-8) 183 179 @param scalar_style Preferred scalar style (default: Any) 184 180 @param layout_style Preferred layout style (default: Any) 185 185 - @param buffer Optional buffer to append to (allocates new one if not provided) 181 181 + @param buffer 182 182 + Optional buffer to append to (allocates new one if not provided) 186 183 @return The buffer containing the serialized YAML *) 187 184 188 185 val yaml_to_string : 189 186 ?encoding:Encoding.t -> 190 187 ?scalar_style:Scalar_style.t -> 191 188 ?layout_style:Layout_style.t -> 192 192 - yaml -> string 189 189 + yaml -> 190 190 + string 193 191 (** Serialize a full YAML value to a string. 194 192 195 193 @param encoding Output encoding (default: UTF-8) ··· 202 200 ?layout_style:Layout_style.t -> 203 201 ?resolve_aliases:bool -> 204 202 ?buffer:Buffer.t -> 205 205 - document list -> Buffer.t 203 203 + document list -> 204 204 + Buffer.t 206 205 (** Serialize multiple documents to a buffer. 207 206 208 207 @param encoding Output encoding (default: UTF-8) 209 208 @param scalar_style Preferred scalar style (default: Any) 210 209 @param layout_style Preferred layout style (default: Any) 211 210 @param resolve_aliases Whether to expand aliases (default: true) 212 212 - @param buffer Optional buffer to append to (allocates new one if not provided) 211 211 + @param buffer 212 212 + Optional buffer to append to (allocates new one if not provided) 213 213 @return The buffer containing the serialized YAML *) 214 214 215 215 val documents_to_string : ··· 217 217 ?scalar_style:Scalar_style.t -> 218 218 ?layout_style:Layout_style.t -> 219 219 ?resolve_aliases:bool -> 220 220 - document list -> string 220 220 + document list -> 221 221 + string 221 222 (** Serialize multiple documents to a YAML stream. 222 223 223 224 @param encoding Output encoding (default: UTF-8) ··· 228 229 (** {2 Buffer Parsing} *) 229 230 230 231 val of_buffer : 231 231 - ?resolve_aliases:bool -> 232 232 - ?max_nodes:int -> 233 233 - ?max_depth:int -> 234 234 - Buffer.t -> value 232 232 + ?resolve_aliases:bool -> ?max_nodes:int -> ?max_depth:int -> Buffer.t -> value 235 233 (** Parse YAML from a buffer into a JSON-compatible value. 236 234 237 235 @param resolve_aliases Whether to expand aliases (default: true) ··· 240 238 @raise Yamlrw_error on parse error or if multiple documents found *) 241 239 242 240 val yaml_of_buffer : 243 243 - ?resolve_aliases:bool -> 244 244 - ?max_nodes:int -> 245 245 - ?max_depth:int -> 246 246 - Buffer.t -> yaml 241 241 + ?resolve_aliases:bool -> ?max_nodes:int -> ?max_depth:int -> Buffer.t -> yaml 247 242 (** Parse YAML from a buffer preserving full YAML metadata. 248 243 249 244 @param resolve_aliases Whether to expand aliases (default: false) ··· 256 251 257 252 @raise Yamlrw_error on parse error *) 258 253 259 259 - 260 254 (** {2 Conversion} *) 261 255 262 256 val to_json : 263 263 - ?resolve_aliases:bool -> 264 264 - ?max_nodes:int -> 265 265 - ?max_depth:int -> 266 266 - yaml -> value 257 257 + ?resolve_aliases:bool -> ?max_nodes:int -> ?max_depth:int -> yaml -> value 267 258 (** Convert full YAML to JSON-compatible value. 268 259 269 260 @param resolve_aliases Whether to expand aliases (default: true) ··· 274 265 val of_json : value -> yaml 275 266 (** Convert JSON-compatible value to full YAML representation. *) 276 267 277 277 - 278 268 (** {2 Pretty Printing & Equality} *) 279 269 280 270 val pp : Format.formatter -> value -> unit ··· 283 273 val equal : value -> value -> bool 284 274 (** Test equality of two values. *) 285 275 286 286 - 287 276 (** {2 Util - Value Combinators} 288 277 289 278 Combinators for working with {!type:value} values. 290 279 291 291 - This module provides constructors, accessors, and transformations 292 292 - for JSON-compatible YAML values. *) 280 280 + This module provides constructors, accessors, and transformations for 281 281 + JSON-compatible YAML values. *) 293 282 294 283 module Util : sig 295 284 type t = Value.t ··· 400 389 (** {3 Object Operations} *) 401 390 402 391 val mem : string -> t -> bool 403 403 - (** [mem key obj] checks if [key] exists in object [obj]. 404 404 - Returns [false] if [obj] is not an object. *) 392 392 + (** [mem key obj] checks if [key] exists in object [obj]. Returns [false] if 393 393 + [obj] is not an object. *) 405 394 406 395 val find : string -> t -> t option 407 407 - (** [find key obj] looks up [key] in object [obj]. 408 408 - Returns [None] if key not found or if [obj] is not an object. *) 396 396 + (** [find key obj] looks up [key] in object [obj]. Returns [None] if key not 397 397 + found or if [obj] is not an object. *) 409 398 410 399 val get : string -> t -> t 411 411 - (** [get key obj] looks up [key] in object [obj]. 412 412 - Raises [Not_found] if key not found. *) 400 400 + (** [get key obj] looks up [key] in object [obj]. Raises [Not_found] if key 401 401 + not found. *) 413 402 414 403 val keys : t -> string list 415 404 (** Get all keys from an object. ··· 420 409 @raise Type_error if not an object *) 421 410 422 411 val update : string -> t -> t -> t 423 423 - (** [update key value obj] sets [key] to [value] in [obj]. 424 424 - Adds the key if it doesn't exist. 412 412 + (** [update key value obj] sets [key] to [value] in [obj]. Adds the key if it 413 413 + doesn't exist. 425 414 @raise Type_error if [obj] is not an object *) 426 415 427 416 val remove : string -> t -> t ··· 429 418 @raise Type_error if [obj] is not an object *) 430 419 431 420 val combine : t -> t -> t 432 432 - (** [combine obj1 obj2] merges two objects, with [obj2] values taking precedence. 421 421 + (** [combine obj1 obj2] merges two objects, with [obj2] values taking 422 422 + precedence. 433 423 @raise Type_error if either argument is not an object *) 434 424 435 425 (** {3 List Operations} *) ··· 451 441 @raise Type_error if [lst] is not a list *) 452 442 453 443 val nth : int -> t -> t option 454 454 - (** [nth n lst] gets element at index [n]. 455 455 - Returns [None] if [lst] is not a list or index out of bounds. *) 444 444 + (** [nth n lst] gets element at index [n]. Returns [None] if [lst] is not a 445 445 + list or index out of bounds. *) 456 446 457 447 val length : t -> int 458 448 (** Get the length of a list or object. Returns 0 for other types. *) 459 449 460 450 val flatten : t -> t 461 461 - (** Flatten a list of lists into a single list. 462 462 - Non-list elements are kept as-is. 451 451 + (** Flatten a list of lists into a single list. Non-list elements are kept 452 452 + as-is. 463 453 @raise Type_error if not a list *) 464 454 465 455 (** {3 Path Operations} *) 466 456 467 457 val get_path : string list -> t -> t option 468 468 - (** [get_path ["a"; "b"; "c"] obj] looks up nested path [obj.a.b.c]. 469 469 - Returns [None] if any key is not found. *) 458 458 + (** [get_path ["a"; "b"; "c"] obj] looks up nested path [obj.a.b.c]. Returns 459 459 + [None] if any key is not found. *) 470 460 471 461 val get_path_exn : string list -> t -> t 472 462 (** Like {!get_path} but raises [Not_found] if path not found. *) ··· 521 511 @raise Type_error if type doesn't match and no default provided *) 522 512 end 523 513 524 524 - 525 514 (** {2 Stream - Low-Level Event API} 526 515 527 516 Low-level streaming API for event-based YAML processing. ··· 532 521 - Fine-grained control over YAML emission *) 533 522 534 523 module Stream : sig 535 535 - 536 524 (** {3 Event Types} *) 537 525 538 526 type event = Event.t ··· 557 545 (** Create a parser from a string. *) 558 546 559 547 val next : parser -> event_result option 560 560 - (** Get the next event from the parser. 561 561 - Returns [None] when parsing is complete. *) 548 548 + (** Get the next event from the parser. Returns [None] when parsing is 549 549 + complete. *) 562 550 563 551 val iter : (event -> position -> position -> unit) -> parser -> unit 564 552 (** [iter f parser] calls [f event start_pos end_pos] for each event. *) ··· 589 577 val stream_end : emitter -> unit 590 578 (** Emit a stream end event. *) 591 579 592 592 - val document_start : emitter -> ?version:version -> ?implicit:bool -> unit -> unit 580 580 + val document_start : 581 581 + emitter -> ?version:version -> ?implicit:bool -> unit -> unit 593 582 (** Emit a document start event. 594 583 @param version YAML version directive 595 584 @param implicit Whether start marker is implicit (default: true) *) ··· 598 587 (** Emit a document end event. 599 588 @param implicit Whether end marker is implicit (default: true) *) 600 589 601 601 - val scalar : emitter -> ?anchor:string -> ?tag:string -> ?style:Scalar_style.t -> string -> unit 590 590 + val scalar : 591 591 + emitter -> 592 592 + ?anchor:string -> 593 593 + ?tag:string -> 594 594 + ?style:Scalar_style.t -> 595 595 + string -> 596 596 + unit 602 597 (** Emit a scalar value. 603 598 @param anchor Optional anchor name 604 599 @param tag Optional type tag ··· 607 602 val alias : emitter -> string -> unit 608 603 (** Emit an alias reference. *) 609 604 610 610 - val sequence_start : emitter -> ?anchor:string -> ?tag:string -> ?style:Layout_style.t -> unit -> unit 605 605 + val sequence_start : 606 606 + emitter -> 607 607 + ?anchor:string -> 608 608 + ?tag:string -> 609 609 + ?style:Layout_style.t -> 610 610 + unit -> 611 611 + unit 611 612 (** Emit a sequence start event. 612 613 @param anchor Optional anchor name 613 614 @param tag Optional type tag ··· 616 617 val sequence_end : emitter -> unit 617 618 (** Emit a sequence end event. *) 618 619 619 619 - val mapping_start : emitter -> ?anchor:string -> ?tag:string -> ?style:Layout_style.t -> unit -> unit 620 620 + val mapping_start : 621 621 + emitter -> 622 622 + ?anchor:string -> 623 623 + ?tag:string -> 624 624 + ?style:Layout_style.t -> 625 625 + unit -> 626 626 + unit 620 627 (** Emit a mapping start event. 621 628 @param anchor Optional anchor name 622 629 @param tag Optional type tag ··· 626 633 (** Emit a mapping end event. *) 627 634 end 628 635 629 629 - 630 636 (** {2 Internal Modules} 631 637 632 632 - These modules are exposed for advanced use cases requiring 633 633 - fine-grained control over parsing, emission, or data structures. 638 638 + These modules are exposed for advanced use cases requiring fine-grained 639 639 + control over parsing, emission, or data structures. 634 640 635 641 For typical usage, prefer the top-level functions and {!Util}. *) 636 642

+17 -8

tests/dune

··· 12 12 13 13 ; Alias to run the full YAML test suite and generate HTML report 14 14 ; Requires yaml-test-suite to be cloned to tests/yaml-test-suite 15 15 + 15 16 (rule 16 17 (alias yaml-test-suite) 17 17 - (deps (source_tree yaml-test-suite)) 18 18 + (deps 19 19 + (source_tree yaml-test-suite)) 18 20 (targets yaml-test-results.html) 19 21 (action 20 20 - (run %{exe:run_all_tests.exe} 21 21 - --test-suite-path %{workspace_root}/tests/yaml-test-suite 22 22 - --html yaml-test-results.html))) 22 22 + (run 23 23 + %{exe:run_all_tests.exe} 24 24 + --test-suite-path 25 25 + %{workspace_root}/tests/yaml-test-suite 26 26 + --html 27 27 + yaml-test-results.html))) 23 28 24 29 (rule 25 30 (alias yaml-test-suite-eio) 26 26 - (deps (source_tree yaml-test-suite)) 31 31 + (deps 32 32 + (source_tree yaml-test-suite)) 27 33 (targets yaml-test-results-eio.html) 28 34 (action 29 29 - (run %{exe:run_all_tests_eio.exe} 30 30 - --test-suite-path %{workspace_root}/tests/yaml-test-suite 31 31 - --html yaml-test-results-eio.html))) 35 35 + (run 36 36 + %{exe:run_all_tests_eio.exe} 37 37 + --test-suite-path 38 38 + %{workspace_root}/tests/yaml-test-suite 39 39 + --html 40 40 + yaml-test-results-eio.html)))

+209 -144

tests/run_all_tests.ml

··· 14 14 (* HTML escape function *) 15 15 let html_escape s = 16 16 let buf = Buffer.create (String.length s) in 17 17 - String.iter (function 18 18 - | '<' -> Buffer.add_string buf "&lt;" 19 19 - | '>' -> Buffer.add_string buf "&gt;" 20 20 - | '&' -> Buffer.add_string buf "&amp;" 21 21 - | '"' -> Buffer.add_string buf "&quot;" 22 22 - | c -> Buffer.add_char buf c 23 23 - ) s; 17 17 + String.iter 18 18 + (function 19 19 + | '<' -> Buffer.add_string buf "&lt;" 20 20 + | '>' -> Buffer.add_string buf "&gt;" 21 21 + | '&' -> Buffer.add_string buf "&amp;" 22 22 + | '"' -> Buffer.add_string buf "&quot;" 23 23 + | c -> Buffer.add_char buf c) 24 24 + s; 24 25 Buffer.contents buf 25 26 26 27 let normalize_tree s = ··· 33 34 name : string; 34 35 yaml : string; 35 36 is_error_test : bool; 36 36 - status : [`Pass | `Fail of string | `Skip]; 37 37 + status : [ `Pass | `Fail of string | `Skip ]; 37 38 output : string; 38 38 - json_status : [`Pass | `Fail of string | `Skip]; 39 39 + json_status : [ `Pass | `Fail of string | `Skip ]; 39 40 json_expected : string; 40 41 json_actual : string; 41 42 } ··· 45 46 This handles formatting differences and object key ordering. *) 46 47 JC.compare_json_strings expected actual 47 48 48 48 - let run_json_test (test : TL.test_case) : [`Pass | `Fail of string | `Skip] * string = 49 49 + let run_json_test (test : TL.test_case) : 50 50 + [ `Pass | `Fail of string | `Skip ] * string = 49 51 match test.json with 50 52 | None -> (`Skip, "") 51 51 - | Some expected_json -> 53 53 + | Some expected_json -> ( 52 54 if test.fail then 53 55 (* Error tests shouldn't have JSON comparison *) 54 56 (`Skip, "") ··· 56 58 try 57 59 (* Handle multi-document YAML by using documents_of_string *) 58 60 let docs = Loader.documents_of_string test.yaml in 59 59 - let values = List.filter_map (fun doc -> 60 60 - match Document.root doc with 61 61 - | None -> None 62 62 - | Some yaml -> Some (Yaml.to_value ~resolve_aliases_first:true yaml) 63 63 - ) docs in 64 64 - let actual_json = match values with 65 65 - | [] -> "" (* Empty document produces empty JSON *) 66 66 - | [v] -> JF.to_json v 61 61 + let values = 62 62 + List.filter_map 63 63 + (fun doc -> 64 64 + match Document.root doc with 65 65 + | None -> None 66 66 + | Some yaml -> 67 67 + Some (Yaml.to_value ~resolve_aliases_first:true yaml)) 68 68 + docs 69 69 + in 70 70 + let actual_json = 71 71 + match values with 72 72 + | [] -> "" (* Empty document produces empty JSON *) 73 73 + | [ v ] -> JF.to_json v 67 74 | vs -> JF.documents_to_json vs 68 75 in 69 69 - if compare_json expected_json actual_json then 70 70 - (`Pass, actual_json) 71 71 - else 72 72 - (`Fail "JSON mismatch", actual_json) 76 76 + if compare_json expected_json actual_json then (`Pass, actual_json) 77 77 + else (`Fail "JSON mismatch", actual_json) 73 78 with 74 79 | Yamlrw_error e -> 75 80 (`Fail (Format.asprintf "Parse error: %a" Error.pp e), "") 76 81 | exn -> 77 82 (`Fail (Printf.sprintf "Exception: %s" (Printexc.to_string exn)), "") 83 83 + ) 78 84 79 85 let run_test (test : TL.test_case) : test_result = 80 86 let json_status, json_actual = run_json_test test in 81 81 - let base = { 82 82 - id = test.id; 83 83 - name = test.name; 84 84 - yaml = test.yaml; 85 85 - is_error_test = test.fail; 86 86 - status = `Skip; 87 87 - output = ""; 88 88 - json_status; 89 89 - json_expected = Option.value ~default:"" test.json; 90 90 - json_actual; 91 91 - } in 87 87 + let base = 88 88 + { 89 89 + id = test.id; 90 90 + name = test.name; 91 91 + yaml = test.yaml; 92 92 + is_error_test = test.fail; 93 93 + status = `Skip; 94 94 + output = ""; 95 95 + json_status; 96 96 + json_expected = Option.value ~default:"" test.json; 97 97 + json_actual; 98 98 + } 99 99 + in 92 100 if test.fail then begin 93 101 try 94 102 let parser = Parser.of_string test.yaml in 95 103 let events = Parser.to_list parser in 96 104 let tree = TF.of_spanned_events events in 97 97 - { base with 98 98 - status = `Fail "Expected parsing to fail"; 99 99 - output = tree; 100 100 - } 105 105 + { base with status = `Fail "Expected parsing to fail"; output = tree } 101 106 with 102 107 | Yamlrw_error e -> 103 103 - { base with 104 104 - status = `Pass; 105 105 - output = Format.asprintf "%a" Error.pp e; 106 106 - } 107 107 - | exn -> 108 108 - { base with 109 109 - status = `Pass; 110 110 - output = Printexc.to_string exn; 111 111 - } 108 108 + { base with status = `Pass; output = Format.asprintf "%a" Error.pp e } 109 109 + | exn -> { base with status = `Pass; output = Printexc.to_string exn } 112 110 end 113 111 else begin 114 112 match test.tree with 115 115 - | None -> 113 113 + | None -> ( 116 114 (* No expected tree - check if json indicates expected success *) 117 117 - (match test.json with 118 118 - | Some _ -> 119 119 - (* Has json output, so should parse successfully *) 120 120 - (try 121 121 - let parser = Parser.of_string test.yaml in 122 122 - let events = Parser.to_list parser in 123 123 - let tree = TF.of_spanned_events events in 124 124 - { base with status = `Pass; output = tree } 125 125 - with exn -> 126 126 - { base with 127 127 - status = `Fail (Printf.sprintf "Should parse but got: %s" (Printexc.to_string exn)); 128 128 - output = Printexc.to_string exn; 129 129 - }) 130 130 - | None -> 131 131 - (* No tree, no json, no fail - ambiguous edge case, skip *) 132 132 - { base with status = `Skip; output = "(no expected tree or json)" }) 133 133 - | Some expected -> 115 115 + match test.json with 116 116 + | Some _ -> ( 117 117 + (* Has json output, so should parse successfully *) 118 118 + try 119 119 + let parser = Parser.of_string test.yaml in 120 120 + let events = Parser.to_list parser in 121 121 + let tree = TF.of_spanned_events events in 122 122 + { base with status = `Pass; output = tree } 123 123 + with exn -> 124 124 + { 125 125 + base with 126 126 + status = 127 127 + `Fail 128 128 + (Printf.sprintf "Should parse but got: %s" 129 129 + (Printexc.to_string exn)); 130 130 + output = Printexc.to_string exn; 131 131 + }) 132 132 + | None -> 133 133 + (* No tree, no json, no fail - ambiguous edge case, skip *) 134 134 + { base with status = `Skip; output = "(no expected tree or json)" }) 135 135 + | Some expected -> ( 134 136 try 135 137 let parser = Parser.of_string test.yaml in 136 138 let events = Parser.to_list parser in ··· 140 142 if expected_norm = actual_norm then 141 143 { base with status = `Pass; output = actual } 142 144 else 143 143 - { base with 145 145 + { 146 146 + base with 144 147 status = `Fail (Printf.sprintf "Tree mismatch"); 145 145 - output = Printf.sprintf "Expected:\n%s\n\nActual:\n%s" expected_norm actual_norm; 148 148 + output = 149 149 + Printf.sprintf "Expected:\n%s\n\nActual:\n%s" expected_norm 150 150 + actual_norm; 146 151 } 147 152 with exn -> 148 148 - { base with 149 149 - status = `Fail (Printf.sprintf "Exception: %s" (Printexc.to_string exn)); 153 153 + { 154 154 + base with 155 155 + status = 156 156 + `Fail (Printf.sprintf "Exception: %s" (Printexc.to_string exn)); 150 157 output = Printexc.to_string exn; 151 151 - } 158 158 + }) 152 159 end 153 160 154 161 let status_class = function ··· 163 170 164 171 let generate_html results output_file = 165 172 let oc = open_out output_file in 166 166 - let pass_count = List.length (List.filter (fun r -> r.status = `Pass) results) in 167 167 - let fail_count = List.length (List.filter (fun r -> match r.status with `Fail _ -> true | _ -> false) results) in 168 168 - let skip_count = List.length (List.filter (fun r -> r.status = `Skip) results) in 173 173 + let pass_count = 174 174 + List.length (List.filter (fun r -> r.status = `Pass) results) 175 175 + in 176 176 + let fail_count = 177 177 + List.length 178 178 + (List.filter 179 179 + (fun r -> match r.status with `Fail _ -> true | _ -> false) 180 180 + results) 181 181 + in 182 182 + let skip_count = 183 183 + List.length (List.filter (fun r -> r.status = `Skip) results) 184 184 + in 169 185 let total = List.length results in 170 170 - let json_pass_count = List.length (List.filter (fun r -> r.json_status = `Pass) results) in 171 171 - let json_fail_count = List.length (List.filter (fun r -> match r.json_status with `Fail _ -> true | _ -> false) results) in 172 172 - let json_skip_count = List.length (List.filter (fun r -> r.json_status = `Skip) results) in 186 186 + let json_pass_count = 187 187 + List.length (List.filter (fun r -> r.json_status = `Pass) results) 188 188 + in 189 189 + let json_fail_count = 190 190 + List.length 191 191 + (List.filter 192 192 + (fun r -> match r.json_status with `Fail _ -> true | _ -> false) 193 193 + results) 194 194 + in 195 195 + let json_skip_count = 196 196 + List.length (List.filter (fun r -> r.json_status = `Skip) results) 197 197 + in 173 198 174 174 - Printf.fprintf oc {|<!DOCTYPE html> 199 199 + Printf.fprintf oc 200 200 + {|<!DOCTYPE html> 175 201 <html lang="en"> 176 202 <head> 177 203 <meta charset="UTF-8"> ··· 335 361 <input type="text" class="search" placeholder="Search by ID or name..."> 336 362 </div> 337 363 <div class="tests"> 338 338 - |} pass_count fail_count skip_count total json_pass_count json_fail_count json_skip_count; 364 364 + |} 365 365 + pass_count fail_count skip_count total json_pass_count json_fail_count 366 366 + json_skip_count; 339 367 340 340 - List.iter (fun result -> 341 341 - let error_badge = if result.is_error_test then 342 342 - {|<span class="badge error-test">Error Test</span>|} 343 343 - else "" in 344 344 - let json_badge = Printf.sprintf {|<span class="badge %s" style="margin-left: 4px;">JSON: %s</span>|} 345 345 - (status_class result.json_status) (status_text result.json_status) in 346 346 - let json_section = if result.json_expected <> "" || result.json_actual <> "" then 347 347 - Printf.sprintf {| 368 368 + List.iter 369 369 + (fun result -> 370 370 + let error_badge = 371 371 + if result.is_error_test then 372 372 + {|<span class="badge error-test">Error Test</span>|} 373 373 + else "" 374 374 + in 375 375 + let json_badge = 376 376 + Printf.sprintf 377 377 + {|<span class="badge %s" style="margin-left: 4px;">JSON: %s</span>|} 378 378 + (status_class result.json_status) 379 379 + (status_text result.json_status) 380 380 + in 381 381 + let json_section = 382 382 + if result.json_expected <> "" || result.json_actual <> "" then 383 383 + Printf.sprintf 384 384 + {| 348 385 <div class="section"> 349 386 <div class="section-title">Expected JSON</div> 350 387 <pre>%s</pre> ··· 353 390 <div class="section-title">Actual JSON</div> 354 391 <pre>%s</pre> 355 392 </div>|} 356 356 - (html_escape result.json_expected) 357 357 - (html_escape result.json_actual) 358 358 - else "" in 359 359 - Printf.fprintf oc {| <div class="test" data-status="%s" data-json-status="%s" data-id="%s" data-name="%s"> 393 393 + (html_escape result.json_expected) 394 394 + (html_escape result.json_actual) 395 395 + else "" 396 396 + in 397 397 + Printf.fprintf oc 398 398 + {| <div class="test" data-status="%s" data-json-status="%s" data-id="%s" data-name="%s"> 360 399 <div class="test-header" onclick="this.parentElement.classList.toggle('expanded')"> 361 400 <span class="expand-icon">▶</span> 362 401 <span class="badge %s">%s</span> ··· 377 416 </div> 378 417 </div> 379 418 |} 380 380 - (status_class result.status) 381 381 - (status_class result.json_status) 382 382 - (html_escape result.id) 383 383 - (html_escape (String.lowercase_ascii result.name)) 384 384 - (status_class result.status) 385 385 - (status_text result.status) 386 386 - json_badge 387 387 - (html_escape result.id) 388 388 - (html_escape result.name) 389 389 - error_badge 390 390 - (html_escape result.yaml) 391 391 - (html_escape result.output) 392 392 - json_section 393 393 - ) results; 419 419 + (status_class result.status) 420 420 + (status_class result.json_status) 421 421 + (html_escape result.id) 422 422 + (html_escape (String.lowercase_ascii result.name)) 423 423 + (status_class result.status) 424 424 + (status_text result.status) 425 425 + json_badge (html_escape result.id) (html_escape result.name) error_badge 426 426 + (html_escape result.yaml) 427 427 + (html_escape result.output) 428 428 + json_section) 429 429 + results; 394 430 395 395 - Printf.fprintf oc {| </div> 431 431 + Printf.fprintf oc 432 432 + {| </div> 396 433 </div> 397 434 <script> 398 435 document.querySelectorAll('.filter-btn').forEach(btn => { ··· 425 462 let html_output = ref None in 426 463 let show_skipped = ref false in 427 464 let test_suite_path_ref = ref test_suite_path in 428 428 - let args = [ 429 429 - "--html", Arg.String (fun s -> html_output := Some s), 430 430 - "<file> Generate HTML report to file"; 431 431 - "--show-skipped", Arg.Set show_skipped, 432 432 - " Show details of skipped tests"; 433 433 - "--test-suite-path", Arg.Set_string test_suite_path_ref, 434 434 - "<path> Path to yaml-test-suite directory"; 435 435 - ] in 436 436 - Arg.parse args (fun _ -> ()) "Usage: run_all_tests [--html <file>] [--show-skipped] [--test-suite-path <path>]"; 465 465 + let args = 466 466 + [ 467 467 + ( "--html", 468 468 + Arg.String (fun s -> html_output := Some s), 469 469 + "<file> Generate HTML report to file" ); 470 470 + ("--show-skipped", Arg.Set show_skipped, " Show details of skipped tests"); 471 471 + ( "--test-suite-path", 472 472 + Arg.Set_string test_suite_path_ref, 473 473 + "<path> Path to yaml-test-suite directory" ); 474 474 + ] 475 475 + in 476 476 + Arg.parse args 477 477 + (fun _ -> ()) 478 478 + "Usage: run_all_tests [--html <file>] [--show-skipped] [--test-suite-path \ 479 479 + <path>]"; 437 480 438 481 let all_tests = TL.load_directory !test_suite_path_ref in 439 482 Printf.printf "Total tests loaded: %d\n%!" (List.length all_tests); 440 483 441 484 let results = List.map run_test all_tests in 442 485 443 443 - let pass_count = List.length (List.filter (fun r -> r.status = `Pass) results) in 444 444 - let fail_count = List.length (List.filter (fun r -> match r.status with `Fail _ -> true | _ -> false) results) in 445 445 - let skip_count = List.length (List.filter (fun r -> r.status = `Skip) results) in 486 486 + let pass_count = 487 487 + List.length (List.filter (fun r -> r.status = `Pass) results) 488 488 + in 489 489 + let fail_count = 490 490 + List.length 491 491 + (List.filter 492 492 + (fun r -> match r.status with `Fail _ -> true | _ -> false) 493 493 + results) 494 494 + in 495 495 + let skip_count = 496 496 + List.length (List.filter (fun r -> r.status = `Skip) results) 497 497 + in 446 498 447 447 - let json_pass_count = List.length (List.filter (fun r -> r.json_status = `Pass) results) in 448 448 - let json_fail_count = List.length (List.filter (fun r -> match r.json_status with `Fail _ -> true | _ -> false) results) in 449 449 - let json_skip_count = List.length (List.filter (fun r -> r.json_status = `Skip) results) in 499 499 + let json_pass_count = 500 500 + List.length (List.filter (fun r -> r.json_status = `Pass) results) 501 501 + in 502 502 + let json_fail_count = 503 503 + List.length 504 504 + (List.filter 505 505 + (fun r -> match r.json_status with `Fail _ -> true | _ -> false) 506 506 + results) 507 507 + in 508 508 + let json_skip_count = 509 509 + List.length (List.filter (fun r -> r.json_status = `Skip) results) 510 510 + in 450 511 451 451 - Printf.printf "\nEvent Tree Results: %d pass, %d fail, %d skip (total: %d)\n%!" 452 452 - pass_count fail_count skip_count (pass_count + fail_count + skip_count); 512 512 + Printf.printf 513 513 + "\nEvent Tree Results: %d pass, %d fail, %d skip (total: %d)\n%!" pass_count 514 514 + fail_count skip_count 515 515 + (pass_count + fail_count + skip_count); 453 516 454 454 - Printf.printf "JSON Results: %d pass, %d fail, %d skip\n%!" 455 455 - json_pass_count json_fail_count json_skip_count; 517 517 + Printf.printf "JSON Results: %d pass, %d fail, %d skip\n%!" json_pass_count 518 518 + json_fail_count json_skip_count; 456 519 457 520 if fail_count > 0 then begin 458 521 Printf.printf "\nFailing event tree tests:\n"; 459 459 - List.iter (fun r -> 460 460 - match r.status with 461 461 - | `Fail msg -> Printf.printf " %s: %s - %s\n" r.id r.name msg 462 462 - | _ -> () 463 463 - ) results 522 522 + List.iter 523 523 + (fun r -> 524 524 + match r.status with 525 525 + | `Fail msg -> Printf.printf " %s: %s - %s\n" r.id r.name msg 526 526 + | _ -> ()) 527 527 + results 464 528 end; 465 529 466 530 if json_fail_count > 0 then begin 467 531 Printf.printf "\nFailing JSON tests:\n"; 468 468 - List.iter (fun r -> 469 469 - match r.json_status with 470 470 - | `Fail msg -> Printf.printf " %s: %s - %s\n" r.id r.name msg 471 471 - | _ -> () 472 472 - ) results 532 532 + List.iter 533 533 + (fun r -> 534 534 + match r.json_status with 535 535 + | `Fail msg -> Printf.printf " %s: %s - %s\n" r.id r.name msg 536 536 + | _ -> ()) 537 537 + results 473 538 end; 474 539 475 540 if !show_skipped && skip_count > 0 then begin 476 541 Printf.printf "\nSkipped tests (no expected tree):\n"; 477 477 - List.iter (fun r -> 478 478 - if r.status = `Skip then begin 479 479 - Printf.printf " %s: %s\n" r.id r.name; 480 480 - Printf.printf " YAML (%d chars): %S\n" (String.length r.yaml) 481 481 - (if String.length r.yaml <= 60 then r.yaml 482 482 - else String.sub r.yaml 0 60 ^ "...") 483 483 - end 484 484 - ) results 542 542 + List.iter 543 543 + (fun r -> 544 544 + if r.status = `Skip then begin 545 545 + Printf.printf " %s: %s\n" r.id r.name; 546 546 + Printf.printf " YAML (%d chars): %S\n" (String.length r.yaml) 547 547 + (if String.length r.yaml <= 60 then r.yaml 548 548 + else String.sub r.yaml 0 60 ^ "...") 549 549 + end) 550 550 + results 485 551 end; 486 552 487 553 (match !html_output with ··· 491 557 | None -> ()); 492 558 493 559 (* Exit with non-zero code if any tests failed *) 494 494 - if fail_count > 0 || json_fail_count > 0 then 495 495 - exit 1 560 560 + if fail_count > 0 || json_fail_count > 0 then exit 1

+224 -162

tests/run_all_tests_eio.ml

··· 16 16 (* HTML escape function *) 17 17 let html_escape s = 18 18 let buf = Buffer.create (String.length s) in 19 19 - String.iter (function 20 20 - | '<' -> Buffer.add_string buf "&lt;" 21 21 - | '>' -> Buffer.add_string buf "&gt;" 22 22 - | '&' -> Buffer.add_string buf "&amp;" 23 23 - | '"' -> Buffer.add_string buf "&quot;" 24 24 - | c -> Buffer.add_char buf c 25 25 - ) s; 19 19 + String.iter 20 20 + (function 21 21 + | '<' -> Buffer.add_string buf "&lt;" 22 22 + | '>' -> Buffer.add_string buf "&gt;" 23 23 + | '&' -> Buffer.add_string buf "&amp;" 24 24 + | '"' -> Buffer.add_string buf "&quot;" 25 25 + | c -> Buffer.add_char buf c) 26 26 + s; 26 27 Buffer.contents buf 27 28 28 29 let normalize_tree s = ··· 35 36 name : string; 36 37 yaml : string; 37 38 is_error_test : bool; 38 38 - status : [`Pass | `Fail of string | `Skip]; 39 39 + status : [ `Pass | `Fail of string | `Skip ]; 39 40 output : string; 40 40 - json_status : [`Pass | `Fail of string | `Skip]; 41 41 + json_status : [ `Pass | `Fail of string | `Skip ]; 41 42 json_expected : string; 42 43 json_actual : string; 43 44 } 44 45 45 45 - let compare_json expected actual = 46 46 - JC.compare_json_strings expected actual 46 46 + let compare_json expected actual = JC.compare_json_strings expected actual 47 47 48 48 - let run_json_test (test : TL.test_case) : [`Pass | `Fail of string | `Skip] * string = 48 48 + let run_json_test (test : TL.test_case) : 49 49 + [ `Pass | `Fail of string | `Skip ] * string = 49 50 match test.json with 50 51 | None -> (`Skip, "") 51 51 - | Some expected_json -> 52 52 - if test.fail then 53 53 - (`Skip, "") 52 52 + | Some expected_json -> ( 53 53 + if test.fail then (`Skip, "") 54 54 else 55 55 try 56 56 let docs = Loader.documents_of_string test.yaml in 57 57 - let values = List.filter_map (fun doc -> 58 58 - match Document.root doc with 59 59 - | None -> None 60 60 - | Some yaml -> Some (Yaml.to_value ~resolve_aliases_first:true yaml) 61 61 - ) docs in 62 62 - let actual_json = match values with 57 57 + let values = 58 58 + List.filter_map 59 59 + (fun doc -> 60 60 + match Document.root doc with 61 61 + | None -> None 62 62 + | Some yaml -> 63 63 + Some (Yaml.to_value ~resolve_aliases_first:true yaml)) 64 64 + docs 65 65 + in 66 66 + let actual_json = 67 67 + match values with 63 68 | [] -> "" 64 64 - | [v] -> JF.to_json v 69 69 + | [ v ] -> JF.to_json v 65 70 | vs -> JF.documents_to_json vs 66 71 in 67 67 - if compare_json expected_json actual_json then 68 68 - (`Pass, actual_json) 69 69 - else 70 70 - (`Fail "JSON mismatch", actual_json) 72 72 + if compare_json expected_json actual_json then (`Pass, actual_json) 73 73 + else (`Fail "JSON mismatch", actual_json) 71 74 with 72 75 | Yamlrw_error e -> 73 76 (`Fail (Format.asprintf "Parse error: %a" Error.pp e), "") 74 77 | exn -> 75 78 (`Fail (Printf.sprintf "Exception: %s" (Printexc.to_string exn)), "") 79 79 + ) 76 80 77 81 let run_test (test : TL.test_case) : test_result = 78 82 let json_status, json_actual = run_json_test test in 79 79 - let base = { 80 80 - id = test.id; 81 81 - name = test.name; 82 82 - yaml = test.yaml; 83 83 - is_error_test = test.fail; 84 84 - status = `Skip; 85 85 - output = ""; 86 86 - json_status; 87 87 - json_expected = Option.value ~default:"" test.json; 88 88 - json_actual; 89 89 - } in 83 83 + let base = 84 84 + { 85 85 + id = test.id; 86 86 + name = test.name; 87 87 + yaml = test.yaml; 88 88 + is_error_test = test.fail; 89 89 + status = `Skip; 90 90 + output = ""; 91 91 + json_status; 92 92 + json_expected = Option.value ~default:"" test.json; 93 93 + json_actual; 94 94 + } 95 95 + in 90 96 if test.fail then begin 91 97 try 92 98 let parser = Parser.of_string test.yaml in 93 99 let events = Parser.to_list parser in 94 100 let tree = TF.of_spanned_events events in 95 95 - { base with 96 96 - status = `Fail "Expected parsing to fail"; 97 97 - output = tree; 98 98 - } 101 101 + { base with status = `Fail "Expected parsing to fail"; output = tree } 99 102 with 100 103 | Yamlrw_error e -> 101 101 - { base with 102 102 - status = `Pass; 103 103 - output = Format.asprintf "%a" Error.pp e; 104 104 - } 105 105 - | exn -> 106 106 - { base with 107 107 - status = `Pass; 108 108 - output = Printexc.to_string exn; 109 109 - } 104 104 + { base with status = `Pass; output = Format.asprintf "%a" Error.pp e } 105 105 + | exn -> { base with status = `Pass; output = Printexc.to_string exn } 110 106 end 111 107 else begin 112 108 match test.tree with 113 113 - | None -> 114 114 - (match test.json with 115 115 - | Some _ -> 116 116 - (try 117 117 - let parser = Parser.of_string test.yaml in 118 118 - let events = Parser.to_list parser in 119 119 - let tree = TF.of_spanned_events events in 120 120 - { base with status = `Pass; output = tree } 121 121 - with exn -> 122 122 - { base with 123 123 - status = `Fail (Printf.sprintf "Should parse but got: %s" (Printexc.to_string exn)); 124 124 - output = Printexc.to_string exn; 125 125 - }) 126 126 - | None -> 127 127 - { base with status = `Skip; output = "(no expected tree or json)" }) 128 128 - | Some expected -> 109 109 + | None -> ( 110 110 + match test.json with 111 111 + | Some _ -> ( 112 112 + try 113 113 + let parser = Parser.of_string test.yaml in 114 114 + let events = Parser.to_list parser in 115 115 + let tree = TF.of_spanned_events events in 116 116 + { base with status = `Pass; output = tree } 117 117 + with exn -> 118 118 + { 119 119 + base with 120 120 + status = 121 121 + `Fail 122 122 + (Printf.sprintf "Should parse but got: %s" 123 123 + (Printexc.to_string exn)); 124 124 + output = Printexc.to_string exn; 125 125 + }) 126 126 + | None -> 127 127 + { base with status = `Skip; output = "(no expected tree or json)" }) 128 128 + | Some expected -> ( 129 129 try 130 130 let parser = Parser.of_string test.yaml in 131 131 let events = Parser.to_list parser in ··· 135 135 if expected_norm = actual_norm then 136 136 { base with status = `Pass; output = actual } 137 137 else 138 138 - { base with 138 138 + { 139 139 + base with 139 140 status = `Fail (Printf.sprintf "Tree mismatch"); 140 140 - output = Printf.sprintf "Expected:\n%s\n\nActual:\n%s" expected_norm actual_norm; 141 141 + output = 142 142 + Printf.sprintf "Expected:\n%s\n\nActual:\n%s" expected_norm 143 143 + actual_norm; 141 144 } 142 145 with exn -> 143 143 - { base with 144 144 - status = `Fail (Printf.sprintf "Exception: %s" (Printexc.to_string exn)); 146 146 + { 147 147 + base with 148 148 + status = 149 149 + `Fail (Printf.sprintf "Exception: %s" (Printexc.to_string exn)); 145 150 output = Printexc.to_string exn; 146 146 - } 151 151 + }) 147 152 end 148 153 149 154 (* Run tests in parallel using Eio fibers *) 150 150 - let run_tests_parallel tests = 151 151 - Eio.Fiber.List.map run_test tests 155 155 + let run_tests_parallel tests = Eio.Fiber.List.map run_test tests 152 156 153 157 let status_class = function 154 158 | `Pass -> "pass" ··· 161 165 | `Skip -> "SKIP" 162 166 163 167 let generate_html ~fs results output_file = 164 164 - let pass_count = List.length (List.filter (fun r -> r.status = `Pass) results) in 165 165 - let fail_count = List.length (List.filter (fun r -> match r.status with `Fail _ -> true | _ -> false) results) in 166 166 - let skip_count = List.length (List.filter (fun r -> r.status = `Skip) results) in 168 168 + let pass_count = 169 169 + List.length (List.filter (fun r -> r.status = `Pass) results) 170 170 + in 171 171 + let fail_count = 172 172 + List.length 173 173 + (List.filter 174 174 + (fun r -> match r.status with `Fail _ -> true | _ -> false) 175 175 + results) 176 176 + in 177 177 + let skip_count = 178 178 + List.length (List.filter (fun r -> r.status = `Skip) results) 179 179 + in 167 180 let total = List.length results in 168 168 - let json_pass_count = List.length (List.filter (fun r -> r.json_status = `Pass) results) in 169 169 - let json_fail_count = List.length (List.filter (fun r -> match r.json_status with `Fail _ -> true | _ -> false) results) in 170 170 - let json_skip_count = List.length (List.filter (fun r -> r.json_status = `Skip) results) in 181 181 + let json_pass_count = 182 182 + List.length (List.filter (fun r -> r.json_status = `Pass) results) 183 183 + in 184 184 + let json_fail_count = 185 185 + List.length 186 186 + (List.filter 187 187 + (fun r -> match r.json_status with `Fail _ -> true | _ -> false) 188 188 + results) 189 189 + in 190 190 + let json_skip_count = 191 191 + List.length (List.filter (fun r -> r.json_status = `Skip) results) 192 192 + in 171 193 172 194 let buf = Buffer.create 65536 in 173 173 - Printf.bprintf buf {|<!DOCTYPE html> 195 195 + Printf.bprintf buf 196 196 + {|<!DOCTYPE html> 174 197 <html lang="en"> 175 198 <head> 176 199 <meta charset="UTF-8"> ··· 344 367 <input type="text" class="search" placeholder="Search by ID or name..."> 345 368 </div> 346 369 <div class="tests"> 347 347 - |} pass_count fail_count skip_count total json_pass_count json_fail_count json_skip_count; 370 370 + |} 371 371 + pass_count fail_count skip_count total json_pass_count json_fail_count 372 372 + json_skip_count; 348 373 349 349 - List.iter (fun result -> 350 350 - let error_badge = if result.is_error_test then 351 351 - {|<span class="badge error-test">Error Test</span>|} 352 352 - else "" in 353 353 - let json_badge = Printf.sprintf {|<span class="badge %s" style="margin-left: 4px;">JSON: %s</span>|} 354 354 - (status_class result.json_status) (status_text result.json_status) in 355 355 - let json_section = if result.json_expected <> "" || result.json_actual <> "" then 356 356 - Printf.sprintf {| 374 374 + List.iter 375 375 + (fun result -> 376 376 + let error_badge = 377 377 + if result.is_error_test then 378 378 + {|<span class="badge error-test">Error Test</span>|} 379 379 + else "" 380 380 + in 381 381 + let json_badge = 382 382 + Printf.sprintf 383 383 + {|<span class="badge %s" style="margin-left: 4px;">JSON: %s</span>|} 384 384 + (status_class result.json_status) 385 385 + (status_text result.json_status) 386 386 + in 387 387 + let json_section = 388 388 + if result.json_expected <> "" || result.json_actual <> "" then 389 389 + Printf.sprintf 390 390 + {| 357 391 <div class="section"> 358 392 <div class="section-title">Expected JSON</div> 359 393 <pre>%s</pre> ··· 362 396 <div class="section-title">Actual JSON</div> 363 397 <pre>%s</pre> 364 398 </div>|} 365 365 - (html_escape result.json_expected) 366 366 - (html_escape result.json_actual) 367 367 - else "" in 368 368 - Printf.bprintf buf {| <div class="test" data-status="%s" data-json-status="%s" data-id="%s" data-name="%s"> 399 399 + (html_escape result.json_expected) 400 400 + (html_escape result.json_actual) 401 401 + else "" 402 402 + in 403 403 + Printf.bprintf buf 404 404 + {| <div class="test" data-status="%s" data-json-status="%s" data-id="%s" data-name="%s"> 369 405 <div class="test-header" onclick="this.parentElement.classList.toggle('expanded')"> 370 406 <span class="expand-icon">▶</span> 371 407 <span class="badge %s">%s</span> ··· 386 422 </div> 387 423 </div> 388 424 |} 389 389 - (status_class result.status) 390 390 - (status_class result.json_status) 391 391 - (html_escape result.id) 392 392 - (html_escape (String.lowercase_ascii result.name)) 393 393 - (status_class result.status) 394 394 - (status_text result.status) 395 395 - json_badge 396 396 - (html_escape result.id) 397 397 - (html_escape result.name) 398 398 - error_badge 399 399 - (html_escape result.yaml) 400 400 - (html_escape result.output) 401 401 - json_section 402 402 - ) results; 425 425 + (status_class result.status) 426 426 + (status_class result.json_status) 427 427 + (html_escape result.id) 428 428 + (html_escape (String.lowercase_ascii result.name)) 429 429 + (status_class result.status) 430 430 + (status_text result.status) 431 431 + json_badge (html_escape result.id) (html_escape result.name) error_badge 432 432 + (html_escape result.yaml) 433 433 + (html_escape result.output) 434 434 + json_section) 435 435 + results; 403 436 404 404 - Printf.bprintf buf {| </div> 437 437 + Printf.bprintf buf 438 438 + {| </div> 405 439 </div> 406 440 <script> 407 441 document.querySelectorAll('.filter-btn').forEach(btn => { ··· 438 472 let show_skipped = ref false in 439 473 let sequential = ref false in 440 474 let test_suite_path_ref = ref test_suite_path in 441 441 - let args = [ 442 442 - "--html", Arg.String (fun s -> html_output := Some s), 443 443 - "<file> Generate HTML report to file"; 444 444 - "--show-skipped", Arg.Set show_skipped, 445 445 - " Show details of skipped tests"; 446 446 - "--sequential", Arg.Set sequential, 447 447 - " Run tests sequentially instead of in parallel"; 448 448 - "--test-suite-path", Arg.Set_string test_suite_path_ref, 449 449 - "<path> Path to yaml-test-suite directory"; 450 450 - ] in 451 451 - Arg.parse args (fun _ -> ()) "Usage: run_all_tests_eio [--html <file>] [--show-skipped] [--sequential] [--test-suite-path <path>]"; 475 475 + let args = 476 476 + [ 477 477 + ( "--html", 478 478 + Arg.String (fun s -> html_output := Some s), 479 479 + "<file> Generate HTML report to file" ); 480 480 + ("--show-skipped", Arg.Set show_skipped, " Show details of skipped tests"); 481 481 + ( "--sequential", 482 482 + Arg.Set sequential, 483 483 + " Run tests sequentially instead of in parallel" ); 484 484 + ( "--test-suite-path", 485 485 + Arg.Set_string test_suite_path_ref, 486 486 + "<path> Path to yaml-test-suite directory" ); 487 487 + ] 488 488 + in 489 489 + Arg.parse args 490 490 + (fun _ -> ()) 491 491 + "Usage: run_all_tests_eio [--html <file>] [--show-skipped] [--sequential] \ 492 492 + [--test-suite-path <path>]"; 452 493 453 494 Eio_main.run @@ fun env -> 454 495 (* Use fs (full filesystem) rather than cwd (sandboxed) to allow ".." navigation *) 455 496 let fs = Eio.Stdenv.fs env in 456 497 (* Get the absolute path to the test suite *) 457 457 - let test_suite_abs = if Filename.is_relative !test_suite_path_ref then 458 458 - Filename.concat (Sys.getcwd ()) !test_suite_path_ref 459 459 - else 460 460 - !test_suite_path_ref 498 498 + let test_suite_abs = 499 499 + if Filename.is_relative !test_suite_path_ref then 500 500 + Filename.concat (Sys.getcwd ()) !test_suite_path_ref 501 501 + else !test_suite_path_ref 461 502 in 462 503 463 504 let start_time = Unix.gettimeofday () in 464 505 465 506 (* Load tests using Eio (parallel by default) *) 466 466 - let all_tests = if !sequential then 467 467 - TL.load_directory ~fs test_suite_abs 468 468 - else 469 469 - TL.load_directory_parallel ~fs test_suite_abs 507 507 + let all_tests = 508 508 + if !sequential then TL.load_directory ~fs test_suite_abs 509 509 + else TL.load_directory_parallel ~fs test_suite_abs 470 510 in 471 511 let load_time = Unix.gettimeofday () in 472 472 - Printf.printf "Loaded %d tests in %.3fs\n%!" (List.length all_tests) (load_time -. start_time); 512 512 + Printf.printf "Loaded %d tests in %.3fs\n%!" (List.length all_tests) 513 513 + (load_time -. start_time); 473 514 474 515 (* Run tests (parallel or sequential based on flag) *) 475 475 - let results = if !sequential then 476 476 - List.map run_test all_tests 477 477 - else 478 478 - run_tests_parallel all_tests 516 516 + let results = 517 517 + if !sequential then List.map run_test all_tests 518 518 + else run_tests_parallel all_tests 479 519 in 480 520 let run_time = Unix.gettimeofday () in 481 521 Printf.printf "Ran tests in %.3fs\n%!" (run_time -. load_time); 482 522 483 483 - let pass_count = List.length (List.filter (fun r -> r.status = `Pass) results) in 484 484 - let fail_count = List.length (List.filter (fun r -> match r.status with `Fail _ -> true | _ -> false) results) in 485 485 - let skip_count = List.length (List.filter (fun r -> r.status = `Skip) results) in 523 523 + let pass_count = 524 524 + List.length (List.filter (fun r -> r.status = `Pass) results) 525 525 + in 526 526 + let fail_count = 527 527 + List.length 528 528 + (List.filter 529 529 + (fun r -> match r.status with `Fail _ -> true | _ -> false) 530 530 + results) 531 531 + in 532 532 + let skip_count = 533 533 + List.length (List.filter (fun r -> r.status = `Skip) results) 534 534 + in 486 535 487 487 - let json_pass_count = List.length (List.filter (fun r -> r.json_status = `Pass) results) in 488 488 - let json_fail_count = List.length (List.filter (fun r -> match r.json_status with `Fail _ -> true | _ -> false) results) in 489 489 - let json_skip_count = List.length (List.filter (fun r -> r.json_status = `Skip) results) in 536 536 + let json_pass_count = 537 537 + List.length (List.filter (fun r -> r.json_status = `Pass) results) 538 538 + in 539 539 + let json_fail_count = 540 540 + List.length 541 541 + (List.filter 542 542 + (fun r -> match r.json_status with `Fail _ -> true | _ -> false) 543 543 + results) 544 544 + in 545 545 + let json_skip_count = 546 546 + List.length (List.filter (fun r -> r.json_status = `Skip) results) 547 547 + in 490 548 491 491 - Printf.printf "\nEvent Tree Results: %d pass, %d fail, %d skip (total: %d)\n%!" 492 492 - pass_count fail_count skip_count (pass_count + fail_count + skip_count); 549 549 + Printf.printf 550 550 + "\nEvent Tree Results: %d pass, %d fail, %d skip (total: %d)\n%!" pass_count 551 551 + fail_count skip_count 552 552 + (pass_count + fail_count + skip_count); 493 553 494 494 - Printf.printf "JSON Results: %d pass, %d fail, %d skip\n%!" 495 495 - json_pass_count json_fail_count json_skip_count; 554 554 + Printf.printf "JSON Results: %d pass, %d fail, %d skip\n%!" json_pass_count 555 555 + json_fail_count json_skip_count; 496 556 497 557 if fail_count > 0 then begin 498 558 Printf.printf "\nFailing event tree tests:\n"; 499 499 - List.iter (fun r -> 500 500 - match r.status with 501 501 - | `Fail msg -> Printf.printf " %s: %s - %s\n" r.id r.name msg 502 502 - | _ -> () 503 503 - ) results 559 559 + List.iter 560 560 + (fun r -> 561 561 + match r.status with 562 562 + | `Fail msg -> Printf.printf " %s: %s - %s\n" r.id r.name msg 563 563 + | _ -> ()) 564 564 + results 504 565 end; 505 566 506 567 if json_fail_count > 0 then begin 507 568 Printf.printf "\nFailing JSON tests:\n"; 508 508 - List.iter (fun r -> 509 509 - match r.json_status with 510 510 - | `Fail msg -> Printf.printf " %s: %s - %s\n" r.id r.name msg 511 511 - | _ -> () 512 512 - ) results 569 569 + List.iter 570 570 + (fun r -> 571 571 + match r.json_status with 572 572 + | `Fail msg -> Printf.printf " %s: %s - %s\n" r.id r.name msg 573 573 + | _ -> ()) 574 574 + results 513 575 end; 514 576 515 577 if !show_skipped && skip_count > 0 then begin 516 578 Printf.printf "\nSkipped tests (no expected tree):\n"; 517 517 - List.iter (fun r -> 518 518 - if r.status = `Skip then begin 519 519 - Printf.printf " %s: %s\n" r.id r.name; 520 520 - Printf.printf " YAML (%d chars): %S\n" (String.length r.yaml) 521 521 - (if String.length r.yaml <= 60 then r.yaml 522 522 - else String.sub r.yaml 0 60 ^ "...") 523 523 - end 524 524 - ) results 579 579 + List.iter 580 580 + (fun r -> 581 581 + if r.status = `Skip then begin 582 582 + Printf.printf " %s: %s\n" r.id r.name; 583 583 + Printf.printf " YAML (%d chars): %S\n" (String.length r.yaml) 584 584 + (if String.length r.yaml <= 60 then r.yaml 585 585 + else String.sub r.yaml 0 60 ^ "...") 586 586 + end) 587 587 + results 525 588 end; 526 589 527 590 let total_time = Unix.gettimeofday () in ··· 534 597 | None -> ()); 535 598 536 599 (* Exit with non-zero code if any tests failed *) 537 537 - if fail_count > 0 || json_fail_count > 0 then 538 538 - exit 1 600 600 + if fail_count > 0 || json_fail_count > 0 then exit 1

+6 -1

tests/test_suite_lib/dune

··· 1 1 (library 2 2 (name test_suite_lib) 3 3 - (modules test_suite_loader_generic test_suite_loader tree_format json_format json_compare) 3 3 + (modules 4 4 + test_suite_loader_generic 5 5 + test_suite_loader 6 6 + tree_format 7 7 + json_format 8 8 + json_compare) 4 9 (libraries yamlrw jsonm)) 5 10 6 11 (library

+29 -27

tests/test_suite_lib/json_compare.ml

··· 14 14 | Object of (string * json) list 15 15 16 16 let rec equal a b = 17 17 - match a, b with 17 17 + match (a, b) with 18 18 | Null, Null -> true 19 19 | Bool a, Bool b -> a = b 20 20 | Float a, Float b -> Float.equal a b ··· 22 22 | Array a, Array b -> List.equal equal a b 23 23 | Object a, Object b -> 24 24 (* Compare objects as sets of key-value pairs (order independent) *) 25 25 - let sorted_a = List.sort (fun (k1, _) (k2, _) -> String.compare k1 k2) a in 26 26 - let sorted_b = List.sort (fun (k1, _) (k2, _) -> String.compare k1 k2) b in 27 27 - List.length sorted_a = List.length sorted_b && 28 28 - List.for_all2 (fun (k1, v1) (k2, v2) -> k1 = k2 && equal v1 v2) sorted_a sorted_b 25 25 + let sorted_a = 26 26 + List.sort (fun (k1, _) (k2, _) -> String.compare k1 k2) a 27 27 + in 28 28 + let sorted_b = 29 29 + List.sort (fun (k1, _) (k2, _) -> String.compare k1 k2) b 30 30 + in 31 31 + List.length sorted_a = List.length sorted_b 32 32 + && List.for_all2 33 33 + (fun (k1, v1) (k2, v2) -> k1 = k2 && equal v1 v2) 34 34 + sorted_a sorted_b 29 35 | _ -> false 30 36 31 37 (* Parse JSON string using jsonm *) ··· 46 52 and parse_array acc = 47 53 match Jsonm.decode decoder with 48 54 | `Lexeme `Ae -> Ok (Array (List.rev acc)) 49 49 - | `Lexeme _ as lex -> 55 55 + | `Lexeme _ as lex -> ( 50 56 (* Push back and parse value *) 51 57 let result = parse_value_with_lex lex in 52 52 - (match result with 53 53 - | Ok v -> parse_array (v :: acc) 54 54 - | Error _ as e -> e) 58 58 + match result with Ok v -> parse_array (v :: acc) | Error _ as e -> e) 55 59 | `Error e -> Error (Format.asprintf "%a" Jsonm.pp_error e) 56 60 | `End -> Error "unexpected end in array" 57 61 | `Await -> Error "unexpected await" 58 62 and parse_object acc = 59 63 match Jsonm.decode decoder with 60 64 | `Lexeme `Oe -> Ok (Object (List.rev acc)) 61 61 - | `Lexeme (`Name key) -> 62 62 - (match parse_value () with 63 63 - | Ok v -> parse_object ((key, v) :: acc) 64 64 - | Error _ as e -> e) 65 65 + | `Lexeme (`Name key) -> ( 66 66 + match parse_value () with 67 67 + | Ok v -> parse_object ((key, v) :: acc) 68 68 + | Error _ as e -> e) 65 69 | `Lexeme _ -> Error "expected object key" 66 70 | `Error e -> Error (Format.asprintf "%a" Jsonm.pp_error e) 67 71 | `End -> Error "unexpected end in object" ··· 99 103 and parse_array acc = 100 104 match Jsonm.decode decoder with 101 105 | `Lexeme `Ae -> Some (Array (List.rev acc)) 102 102 - | `Lexeme _ as lex -> 103 103 - (match parse_value_with_lex lex with 104 104 - | Some v -> parse_array (v :: acc) 105 105 - | None -> None) 106 106 + | `Lexeme _ as lex -> ( 107 107 + match parse_value_with_lex lex with 108 108 + | Some v -> parse_array (v :: acc) 109 109 + | None -> None) 106 110 | _ -> None 107 111 and parse_object acc = 108 112 match Jsonm.decode decoder with 109 113 | `Lexeme `Oe -> Some (Object (List.rev acc)) 110 110 - | `Lexeme (`Name key) -> 111 111 - (match parse_value () with 112 112 - | Some v -> parse_object ((key, v) :: acc) 113 113 - | None -> None) 114 114 + | `Lexeme (`Name key) -> ( 115 115 + match parse_value () with 116 116 + | Some v -> parse_object ((key, v) :: acc) 117 117 + | None -> None) 114 118 | _ -> None 115 119 and parse_value_with_lex lex = 116 120 match lex with ··· 134 138 (* Handle empty strings *) 135 139 let expected_trimmed = String.trim expected in 136 140 let actual_trimmed = String.trim actual in 137 137 - if expected_trimmed = "" && actual_trimmed = "" then 138 138 - true 139 139 - else if expected_trimmed = "" || actual_trimmed = "" then 140 140 - false 141 141 + if expected_trimmed = "" && actual_trimmed = "" then true 142 142 + else if expected_trimmed = "" || actual_trimmed = "" then false 141 143 else 142 144 (* Parse as potentially multiple JSON values *) 143 145 let expected_values = parse_json_multi expected in 144 146 let actual_values = parse_json_multi actual in 145 145 - List.length expected_values = List.length actual_values && 146 146 - List.for_all2 equal expected_values actual_values 147 147 + List.length expected_values = List.length actual_values 148 148 + && List.for_all2 equal expected_values actual_values

+37 -27

tests/test_suite_lib/json_format.ml

··· 10 10 let escape_string s = 11 11 let buf = Buffer.create (String.length s * 2) in 12 12 Buffer.add_char buf '"'; 13 13 - String.iter (fun c -> 14 14 - match c with 15 15 - | '"' -> Buffer.add_string buf "\\\"" 16 16 - | '\\' -> Buffer.add_string buf "\\\\" 17 17 - | '\n' -> Buffer.add_string buf "\\n" 18 18 - | '\r' -> Buffer.add_string buf "\\r" 19 19 - | '\t' -> Buffer.add_string buf "\\t" 20 20 - | '\x08' -> Buffer.add_string buf "\\b" 21 21 - | '\x0c' -> Buffer.add_string buf "\\f" 22 22 - | c when Char.code c < 32 -> 23 23 - Buffer.add_string buf (Printf.sprintf "\\u%04x" (Char.code c)) 24 24 - | c -> Buffer.add_char buf c 25 25 - ) s; 13 13 + String.iter 14 14 + (fun c -> 15 15 + match c with 16 16 + | '"' -> Buffer.add_string buf "\\\"" 17 17 + | '\\' -> Buffer.add_string buf "\\\\" 18 18 + | '\n' -> Buffer.add_string buf "\\n" 19 19 + | '\r' -> Buffer.add_string buf "\\r" 20 20 + | '\t' -> Buffer.add_string buf "\\t" 21 21 + | '\x08' -> Buffer.add_string buf "\\b" 22 22 + | '\x0c' -> Buffer.add_string buf "\\f" 23 23 + | c when Char.code c < 32 -> 24 24 + Buffer.add_string buf (Printf.sprintf "\\u%04x" (Char.code c)) 25 25 + | c -> Buffer.add_char buf c) 26 26 + s; 26 27 Buffer.add_char buf '"'; 27 28 Buffer.contents buf 28 29 29 29 - let rec format_value ?(indent=0) (v : Value.t) = 30 30 + let rec format_value ?(indent = 0) (v : Value.t) = 30 31 let spaces n = String.make n ' ' in 31 32 match v with 32 33 | `Null -> "null" 33 34 | `Bool true -> "true" 34 35 | `Bool false -> "false" 35 36 | `Float f -> 36 36 - if Float.is_nan f then "null" (* JSON doesn't support NaN *) 37 37 - else if f = Float.infinity || f = Float.neg_infinity then "null" (* JSON doesn't support Inf *) 37 37 + if Float.is_nan f then "null" (* JSON doesn't support NaN *) 38 38 + else if f = Float.infinity || f = Float.neg_infinity then "null" 39 39 + (* JSON doesn't support Inf *) 38 40 else if Float.is_integer f && Float.abs f < 1e15 then 39 41 Printf.sprintf "%.0f" f 40 42 else 41 43 (* Try to match yaml-test-suite's number formatting *) 42 44 let s = Printf.sprintf "%g" f in 43 45 (* Ensure we have a decimal point for floats *) 44 44 - if String.contains s '.' || String.contains s 'e' || String.contains s 'E' then s 46 46 + if 47 47 + String.contains s '.' || String.contains s 'e' 48 48 + || String.contains s 'E' 49 49 + then s 45 50 else s ^ ".0" 46 51 | `String s -> escape_string s 47 52 | `A [] -> "[]" 48 53 | `A items -> 49 54 let inner_indent = indent + 2 in 50 50 - let formatted_items = List.map (fun item -> 51 51 - spaces inner_indent ^ format_value ~indent:inner_indent item 52 52 - ) items in 55 55 + let formatted_items = 56 56 + List.map 57 57 + (fun item -> 58 58 + spaces inner_indent ^ format_value ~indent:inner_indent item) 59 59 + items 60 60 + in 53 61 "[\n" ^ String.concat ",\n" formatted_items ^ "\n" ^ spaces indent ^ "]" 54 62 | `O [] -> "{}" 55 63 | `O pairs -> 56 64 let inner_indent = indent + 2 in 57 57 - let formatted_pairs = List.map (fun (k, v) -> 58 58 - let key = escape_string k in 59 59 - let value = format_value ~indent:inner_indent v in 60 60 - spaces inner_indent ^ key ^ ": " ^ value 61 61 - ) pairs in 65 65 + let formatted_pairs = 66 66 + List.map 67 67 + (fun (k, v) -> 68 68 + let key = escape_string k in 69 69 + let value = format_value ~indent:inner_indent v in 70 70 + spaces inner_indent ^ key ^ ": " ^ value) 71 71 + pairs 72 72 + in 62 73 "{\n" ^ String.concat ",\n" formatted_pairs ^ "\n" ^ spaces indent ^ "}" 63 74 64 64 - let to_json (v : Value.t) : string = 65 65 - format_value v 75 75 + let to_json (v : Value.t) : string = format_value v 66 76 67 77 (* Format multiple documents (for multi-doc YAML) *) 68 78 let documents_to_json (docs : Value.t list) : string =

+5 -10

tests/test_suite_lib/test_suite_loader.ml

··· 18 18 Some s 19 19 with _ -> None 20 20 21 21 - let file_exists () path = 22 22 - Sys.file_exists path 23 23 - 24 24 - let is_directory () path = 25 25 - Sys.file_exists path && Sys.is_directory path 26 26 - 27 27 - let read_dir () path = 28 28 - Array.to_list (Sys.readdir path) 21 21 + let file_exists () path = Sys.file_exists path 22 22 + let is_directory () path = Sys.file_exists path && Sys.is_directory path 23 23 + let read_dir () path = Array.to_list (Sys.readdir path) 29 24 end 30 25 26 26 + module Loader = Test_suite_loader_generic.Make (Sync_io) 31 27 (** Internal loader module *) 32 32 - module Loader = Test_suite_loader_generic.Make(Sync_io) 33 28 34 34 - (** Re-export test_case type from loader *) 35 29 type test_case = Loader.test_case = { 36 30 id : string; 37 31 name : string; ··· 40 34 json : string option; 41 35 fail : bool; 42 36 } 37 37 + (** Re-export test_case type from loader *) 43 38 44 39 (** Load tests without needing to pass a context *) 45 40 let load_directory path : test_case list = Loader.load_directory () path

+15 -15

tests/test_suite_lib/test_suite_loader_eio.ml

··· 8 8 module Generic = Test_suite_lib.Test_suite_loader_generic 9 9 10 10 (** Eio file I/O implementation *) 11 11 - module Eio_io : Generic.FILE_IO with type ctx = Eio.Fs.dir_ty Eio.Path.t = struct 11 11 + module Eio_io : Generic.FILE_IO with type ctx = Eio.Fs.dir_ty Eio.Path.t = 12 12 + struct 12 13 type ctx = Eio.Fs.dir_ty Eio.Path.t 13 14 14 15 let read_file fs path = 15 15 - try 16 16 - Some (Eio.Path.load Eio.Path.(fs / path)) 17 17 - with _ -> None 16 16 + try Some (Eio.Path.load Eio.Path.(fs / path)) with _ -> None 18 17 19 18 let file_exists fs path = 20 19 match Eio.Path.kind ~follow:true Eio.Path.(fs / path) with ··· 28 27 | _ -> false 29 28 | exception _ -> false 30 29 31 31 - let read_dir fs path = 32 32 - Eio.Path.read_dir Eio.Path.(fs / path) 30 30 + let read_dir fs path = Eio.Path.read_dir Eio.Path.(fs / path) 33 31 end 34 32 33 33 + module Loader = Generic.Make (Eio_io) 35 34 (** Internal loader module *) 36 36 - module Loader = Generic.Make(Eio_io) 37 35 38 38 - (** Re-export test_case type from loader *) 39 36 type test_case = Loader.test_case = { 40 37 id : string; 41 38 name : string; ··· 44 41 json : string option; 45 42 fail : bool; 46 43 } 44 44 + (** Re-export test_case type from loader *) 47 45 48 46 (** Load tests with Eio filesystem context *) 49 47 let load_directory ~fs path : test_case list = Loader.load_directory fs path ··· 53 51 if not (Eio_io.is_directory fs test_suite_path) then [] 54 52 else 55 53 let entries = Eio_io.read_dir fs test_suite_path in 56 56 - let test_ids = entries 54 54 + let test_ids = 55 55 + entries 57 56 |> List.filter (fun e -> 58 58 - Eio_io.is_directory fs (Filename.concat test_suite_path e) && 59 59 - String.length e >= 4 && 60 60 - e.[0] >= '0' && e.[0] <= 'Z') 57 57 + Eio_io.is_directory fs (Filename.concat test_suite_path e) 58 58 + && String.length e >= 4 59 59 + && e.[0] >= '0' 60 60 + && e.[0] <= 'Z') 61 61 |> List.sort String.compare 62 62 in 63 63 (* Load each test ID in parallel using fibers *) 64 64 - Eio.Fiber.List.map (fun test_id -> 65 65 - Loader.load_test_id fs test_suite_path test_id 66 66 - ) test_ids 64 64 + Eio.Fiber.List.map 65 65 + (fun test_id -> Loader.load_test_id fs test_suite_path test_id) 66 66 + test_ids 67 67 |> List.concat

+40 -31

tests/test_suite_lib/test_suite_loader_generic.ml

··· 5 5 6 6 (** Generic test suite loader - parameterized by file I/O operations *) 7 7 8 8 - (** Test case representation *) 9 8 type test_case = { 10 9 id : string; 11 10 name : string; ··· 14 13 json : string option; 15 14 fail : bool; 16 15 } 16 16 + (** Test case representation *) 17 17 18 18 (** Module type for file I/O operations *) 19 19 module type FILE_IO = sig 20 20 - (** Context type for file operations (unit for sync, ~fs for Eio) *) 21 20 type ctx 21 21 + (** Context type for file operations (unit for sync, ~fs for Eio) *) 22 22 23 23 + val read_file : ctx -> string -> string option 23 24 (** Read a file, returning None if it doesn't exist or can't be read *) 24 24 - val read_file : ctx -> string -> string option 25 25 26 26 - (** Check if a path exists and is a regular file *) 27 26 val file_exists : ctx -> string -> bool 27 27 + (** Check if a path exists and is a regular file *) 28 28 29 29 - (** Check if a path exists and is a directory *) 30 29 val is_directory : ctx -> string -> bool 30 30 + (** Check if a path exists and is a directory *) 31 31 32 32 + val read_dir : ctx -> string -> string list 32 33 (** List directory entries *) 33 33 - val read_dir : ctx -> string -> string list 34 34 end 35 35 36 36 (** Create a test loader from file I/O operations *) ··· 45 45 } 46 46 47 47 let read_file_required ctx path = 48 48 - match IO.read_file ctx path with 49 49 - | Some s -> s 50 50 - | None -> "" 48 48 + match IO.read_file ctx path with Some s -> s | None -> "" 51 49 52 50 (** Load a single test from a directory *) 53 51 let load_test_dir ctx base_id dir_path = ··· 60 58 (* Must have in.yaml to be a valid test *) 61 59 if not (IO.file_exists ctx yaml_file) then None 62 60 else 63 63 - let name = match IO.read_file ctx name_file with 61 61 + let name = 62 62 + match IO.read_file ctx name_file with 64 63 | Some s -> String.trim s 65 64 | None -> base_id 66 65 in ··· 70 69 let fail = IO.file_exists ctx error_file in 71 70 Some { id = base_id; name; yaml; tree; json; fail } 72 71 73 73 - (** Load tests from a test ID directory (may have subdirectories for variants) *) 72 72 + (** Load tests from a test ID directory (may have subdirectories for variants) 73 73 + *) 74 74 let load_test_id ctx test_suite_path test_id = 75 75 let dir_path = Filename.concat test_suite_path test_id in 76 76 if not (IO.is_directory ctx dir_path) then [] 77 77 else 78 78 let entries = IO.read_dir ctx dir_path in 79 79 (* Check if this directory has variant subdirectories (00, 01, etc.) *) 80 80 - let has_variants = List.exists (fun e -> 81 81 - let subdir = Filename.concat dir_path e in 82 82 - IO.is_directory ctx subdir && 83 83 - String.length e >= 2 && 84 84 - e.[0] >= '0' && e.[0] <= '9' 85 85 - ) entries in 80 80 + let has_variants = 81 81 + List.exists 82 82 + (fun e -> 83 83 + let subdir = Filename.concat dir_path e in 84 84 + IO.is_directory ctx subdir 85 85 + && String.length e >= 2 86 86 + && e.[0] >= '0' 87 87 + && e.[0] <= '9') 88 88 + entries 89 89 + in 86 90 87 91 if has_variants then 88 92 (* Load each variant subdirectory *) 89 89 - let variants = entries 93 93 + let variants = 94 94 + entries 90 95 |> List.filter (fun e -> 91 96 let subdir = Filename.concat dir_path e in 92 92 - IO.is_directory ctx subdir && 93 93 - String.length e >= 2 && 94 94 - e.[0] >= '0' && e.[0] <= '9') 97 97 + IO.is_directory ctx subdir 98 98 + && String.length e >= 2 99 99 + && e.[0] >= '0' 100 100 + && e.[0] <= '9') 95 101 |> List.sort String.compare 96 102 in 97 97 - List.filter_map (fun variant -> 98 98 - let variant_path = Filename.concat dir_path variant in 99 99 - let variant_id = Printf.sprintf "%s:%s" test_id variant in 100 100 - load_test_dir ctx variant_id variant_path 101 101 - ) variants 103 103 + List.filter_map 104 104 + (fun variant -> 105 105 + let variant_path = Filename.concat dir_path variant in 106 106 + let variant_id = Printf.sprintf "%s:%s" test_id variant in 107 107 + load_test_dir ctx variant_id variant_path) 108 108 + variants 102 109 else 103 110 (* Single test in this directory *) 104 111 match load_test_dir ctx test_id dir_path with 105 105 - | Some t -> [t] 112 112 + | Some t -> [ t ] 106 113 | None -> [] 107 114 108 115 (** Load all tests from a test suite directory *) ··· 110 117 if not (IO.is_directory ctx test_suite_path) then [] 111 118 else 112 119 let entries = IO.read_dir ctx test_suite_path in 113 113 - let test_ids = entries 120 120 + let test_ids = 121 121 + entries 114 122 |> List.filter (fun e -> 115 115 - IO.is_directory ctx (Filename.concat test_suite_path e) && 116 116 - String.length e >= 4 && 117 117 - e.[0] >= '0' && e.[0] <= 'Z') 123 123 + IO.is_directory ctx (Filename.concat test_suite_path e) 124 124 + && String.length e >= 4 125 125 + && e.[0] >= '0' 126 126 + && e.[0] <= 'Z') 118 127 |> List.sort String.compare 119 128 in 120 129 List.concat_map (load_test_id ctx test_suite_path) test_ids

+27 -28

tests/test_suite_lib/tree_format.ml

··· 9 9 10 10 let escape_string s = 11 11 let buf = Buffer.create (String.length s * 2) in 12 12 - String.iter (fun c -> 13 13 - match c with 14 14 - | '\n' -> Buffer.add_string buf "\\n" 15 15 - | '\t' -> Buffer.add_string buf "\\t" 16 16 - | '\r' -> Buffer.add_string buf "\\r" 17 17 - | '\\' -> Buffer.add_string buf "\\\\" 18 18 - | '\x00' -> Buffer.add_string buf "\\0" 19 19 - | '\x07' -> Buffer.add_string buf "\\a" 20 20 - | '\x08' -> Buffer.add_string buf "\\b" 21 21 - | '\x0b' -> Buffer.add_string buf "\\v" 22 22 - | '\x0c' -> Buffer.add_string buf "\\f" 23 23 - | '\x1b' -> Buffer.add_string buf "\\e" 24 24 - | '\xa0' -> Buffer.add_string buf "\\_" 25 25 - | c -> Buffer.add_char buf c 26 26 - ) s; 12 12 + String.iter 13 13 + (fun c -> 14 14 + match c with 15 15 + | '\n' -> Buffer.add_string buf "\\n" 16 16 + | '\t' -> Buffer.add_string buf "\\t" 17 17 + | '\r' -> Buffer.add_string buf "\\r" 18 18 + | '\\' -> Buffer.add_string buf "\\\\" 19 19 + | '\x00' -> Buffer.add_string buf "\\0" 20 20 + | '\x07' -> Buffer.add_string buf "\\a" 21 21 + | '\x08' -> Buffer.add_string buf "\\b" 22 22 + | '\x0b' -> Buffer.add_string buf "\\v" 23 23 + | '\x0c' -> Buffer.add_string buf "\\f" 24 24 + | '\x1b' -> Buffer.add_string buf "\\e" 25 25 + | '\xa0' -> Buffer.add_string buf "\\_" 26 26 + | c -> Buffer.add_char buf c) 27 27 + s; 27 28 Buffer.contents buf 28 29 29 30 let style_char = function ··· 39 40 | Event.Stream_start _ -> "+STR" 40 41 | Event.Stream_end -> "-STR" 41 42 | Event.Document_start { implicit; _ } -> 42 42 - if implicit then "+DOC" 43 43 - else "+DOC ---" 44 44 - | Event.Document_end { implicit } -> 45 45 - if implicit then "-DOC" 46 46 - else "-DOC ..." 43 43 + if implicit then "+DOC" else "+DOC ---" 44 44 + | Event.Document_end { implicit } -> if implicit then "-DOC" else "-DOC ..." 47 45 | Event.Mapping_start { anchor; tag; style; _ } -> 48 46 let anchor_str = match anchor with Some a -> " &" ^ a | None -> "" in 49 47 let tag_str = match tag with Some t -> " <" ^ t ^ ">" | None -> "" in ··· 60 58 let anchor_str = match anchor with Some a -> " &" ^ a | None -> "" in 61 59 let tag_str = match tag with Some t -> " <" ^ t ^ ">" | None -> "" in 62 60 let style_c = style_char style in 63 63 - Printf.sprintf "=VAL%s%s %c%s" anchor_str tag_str style_c (escape_string value) 64 64 - | Event.Alias { anchor } -> 65 65 - Printf.sprintf "=ALI *%s" anchor 61 61 + Printf.sprintf "=VAL%s%s %c%s" anchor_str tag_str style_c 62 62 + (escape_string value) 63 63 + | Event.Alias { anchor } -> Printf.sprintf "=ALI *%s" anchor 66 64 67 65 let of_spanned_events events = 68 66 let buf = Buffer.create 256 in 69 69 - List.iter (fun (e : Event.spanned) -> 70 70 - let line = format_event e in 71 71 - Buffer.add_string buf line; 72 72 - Buffer.add_char buf '\n' 73 73 - ) events; 67 67 + List.iter 68 68 + (fun (e : Event.spanned) -> 69 69 + let line = format_event e in 70 70 + Buffer.add_string buf line; 71 71 + Buffer.add_char buf '\n') 72 72 + events; 74 73 Buffer.contents buf

+147 -112

tests/test_yamlrw.ml

··· 24 24 Alcotest.(check int) "token count" 8 (List.length token_types); 25 25 (* Stream_start, Block_mapping_start, Key, Scalar, Value, Scalar, Block_end, Stream_end *) 26 26 match token_types with 27 27 - | Token.Stream_start _ :: Token.Block_mapping_start :: Token.Key :: 28 28 - Token.Scalar { value = "hello"; _ } :: Token.Value :: 29 29 - Token.Scalar { value = "world"; _ } :: Token.Block_end :: Token.Stream_end :: [] -> 27 27 + | [ 28 28 + Token.Stream_start _; 29 29 + Token.Block_mapping_start; 30 30 + Token.Key; 31 31 + Token.Scalar { value = "hello"; _ }; 32 32 + Token.Value; 33 33 + Token.Scalar { value = "world"; _ }; 34 34 + Token.Block_end; 35 35 + Token.Stream_end; 36 36 + ] -> 30 37 () 31 31 - | _ -> 32 32 - Alcotest.fail "unexpected token sequence" 38 38 + | _ -> Alcotest.fail "unexpected token sequence" 33 39 34 40 let test_scanner_sequence () = 35 41 let scanner = Scanner.of_string "- one\n- two\n- three" in ··· 39 45 let test_scanner_flow () = 40 46 let scanner = Scanner.of_string "[1, 2, 3]" in 41 47 let tokens = Scanner.to_list scanner in 42 42 - let has_flow_start = List.exists (fun (t : Token.spanned) -> 43 43 - match t.token with Token.Flow_sequence_start -> true | _ -> false 44 44 - ) tokens in 48 48 + let has_flow_start = 49 49 + List.exists 50 50 + (fun (t : Token.spanned) -> 51 51 + match t.token with Token.Flow_sequence_start -> true | _ -> false) 52 52 + tokens 53 53 + in 45 54 Alcotest.(check bool) "has flow sequence start" true has_flow_start 46 55 47 47 - let scanner_tests = [ 48 48 - "simple mapping", `Quick, test_scanner_simple; 49 49 - "sequence", `Quick, test_scanner_sequence; 50 50 - "flow sequence", `Quick, test_scanner_flow; 51 51 - ] 56 56 + let scanner_tests = 57 57 + [ 58 58 + ("simple mapping", `Quick, test_scanner_simple); 59 59 + ("sequence", `Quick, test_scanner_sequence); 60 60 + ("flow sequence", `Quick, test_scanner_flow); 61 61 + ] 52 62 53 63 (** Parser tests *) 54 64 ··· 56 66 let parser = Parser.of_string "key: value" in 57 67 let events = Parser.to_list parser in 58 68 Alcotest.(check bool) "has events" true (List.length events > 0); 59 59 - let has_stream_start = List.exists (fun (e : Event.spanned) -> 60 60 - match e.event with Event.Stream_start _ -> true | _ -> false 61 61 - ) events in 69 69 + let has_stream_start = 70 70 + List.exists 71 71 + (fun (e : Event.spanned) -> 72 72 + match e.event with Event.Stream_start _ -> true | _ -> false) 73 73 + events 74 74 + in 62 75 Alcotest.(check bool) "has stream start" true has_stream_start 63 76 64 77 let test_parser_sequence_events () = 65 78 let parser = Parser.of_string "- a\n- b" in 66 79 let events = Parser.to_list parser in 67 67 - let has_seq_start = List.exists (fun (e : Event.spanned) -> 68 68 - match e.event with Event.Sequence_start _ -> true | _ -> false 69 69 - ) events in 80 80 + let has_seq_start = 81 81 + List.exists 82 82 + (fun (e : Event.spanned) -> 83 83 + match e.event with Event.Sequence_start _ -> true | _ -> false) 84 84 + events 85 85 + in 70 86 Alcotest.(check bool) "has sequence start" true has_seq_start 71 87 72 72 - let parser_tests = [ 73 73 - "parse events", `Quick, test_parser_events; 74 74 - "sequence events", `Quick, test_parser_sequence_events; 75 75 - ] 88 88 + let parser_tests = 89 89 + [ 90 90 + ("parse events", `Quick, test_parser_events); 91 91 + ("sequence events", `Quick, test_parser_sequence_events); 92 92 + ] 76 93 77 94 (** Value parsing tests *) 78 95 ··· 93 110 check_value "float" (`Float 3.14) (of_string "3.14") 94 111 95 112 let test_parse_string () = 96 96 - check_value "plain" (`String "hello") (of_string "hello world" |> function `String s -> `String (String.sub s 0 5) | v -> v); 113 113 + check_value "plain" (`String "hello") 114 114 + ( of_string "hello world" |> function 115 115 + | `String s -> `String (String.sub s 0 5) 116 116 + | v -> v ); 97 117 check_value "quoted" (`String "hello") (of_string {|"hello"|}) 98 118 99 119 let test_parse_sequence () = 100 120 let result = of_string "- one\n- two\n- three" in 101 121 match result with 102 102 - | `A [_; _; _] -> () 122 122 + | `A [ _; _; _ ] -> () 103 123 | _ -> Alcotest.fail "expected sequence with 3 elements" 104 124 105 125 let test_parse_mapping () = ··· 118 138 |} in 119 139 let result = of_string yaml in 120 140 match result with 121 121 - | `O [("person", `O _)] -> () 141 141 + | `O [ ("person", `O _) ] -> () 122 142 | _ -> Alcotest.fail "expected nested structure" 123 143 124 144 let test_parse_flow_sequence () = 125 145 let result = of_string "[1, 2, 3]" in 126 146 match result with 127 127 - | `A [`Float 1.0; `Float 2.0; `Float 3.0] -> () 147 147 + | `A [ `Float 1.0; `Float 2.0; `Float 3.0 ] -> () 128 148 | _ -> Alcotest.fail "expected flow sequence [1, 2, 3]" 129 149 130 150 let test_parse_flow_mapping () = 131 151 let result = of_string "{a: 1, b: 2}" in 132 152 match result with 133 133 - | `O [("a", `Float 1.0); ("b", `Float 2.0)] -> () 153 153 + | `O [ ("a", `Float 1.0); ("b", `Float 2.0) ] -> () 134 154 | _ -> Alcotest.fail "expected flow mapping {a: 1, b: 2}" 135 155 136 156 let test_parse_flow_mapping_trailing_comma () = 137 157 let result = of_string "{ a: 1, }" in 138 158 match result with 139 139 - | `O [("a", `Float 1.0)] -> () 159 159 + | `O [ ("a", `Float 1.0) ] -> () 140 160 | `O pairs -> 141 141 - Alcotest.failf "expected 1 pair but got %d pairs (trailing comma should not create empty entry)" 161 161 + Alcotest.failf 162 162 + "expected 1 pair but got %d pairs (trailing comma should not create \ 163 163 + empty entry)" 142 164 (List.length pairs) 143 165 | _ -> Alcotest.fail "expected flow mapping with 1 pair" 144 166 145 145 - let value_tests = [ 146 146 - "parse null", `Quick, test_parse_null; 147 147 - "parse bool", `Quick, test_parse_bool; 148 148 - "parse number", `Quick, test_parse_number; 149 149 - "parse string", `Quick, test_parse_string; 150 150 - "parse sequence", `Quick, test_parse_sequence; 151 151 - "parse mapping", `Quick, test_parse_mapping; 152 152 - "parse nested", `Quick, test_parse_nested; 153 153 - "parse flow sequence", `Quick, test_parse_flow_sequence; 154 154 - "parse flow mapping", `Quick, test_parse_flow_mapping; 155 155 - "flow mapping trailing comma", `Quick, test_parse_flow_mapping_trailing_comma; 156 156 - ] 167 167 + let value_tests = 168 168 + [ 169 169 + ("parse null", `Quick, test_parse_null); 170 170 + ("parse bool", `Quick, test_parse_bool); 171 171 + ("parse number", `Quick, test_parse_number); 172 172 + ("parse string", `Quick, test_parse_string); 173 173 + ("parse sequence", `Quick, test_parse_sequence); 174 174 + ("parse mapping", `Quick, test_parse_mapping); 175 175 + ("parse nested", `Quick, test_parse_nested); 176 176 + ("parse flow sequence", `Quick, test_parse_flow_sequence); 177 177 + ("parse flow mapping", `Quick, test_parse_flow_mapping); 178 178 + ( "flow mapping trailing comma", 179 179 + `Quick, 180 180 + test_parse_flow_mapping_trailing_comma ); 181 181 + ] 157 182 158 183 (** Emitter tests *) 159 184 ··· 162 187 Alcotest.(check bool) "contains null" true (String.length result > 0) 163 188 164 189 let starts_with prefix s = 165 165 - String.length s >= String.length prefix && 166 166 - String.sub s 0 (String.length prefix) = prefix 190 190 + String.length s >= String.length prefix 191 191 + && String.sub s 0 (String.length prefix) = prefix 167 192 168 193 let test_emit_mapping () = 169 169 - let value = `O [("name", `String "Alice"); ("age", `Float 30.0)] in 194 194 + let value = `O [ ("name", `String "Alice"); ("age", `Float 30.0) ] in 170 195 let result = to_string value in 171 196 let trimmed = String.trim result in 172 172 - Alcotest.(check bool) "contains name" true (starts_with "name" trimmed || starts_with "\"name\"" trimmed) 197 197 + Alcotest.(check bool) 198 198 + "contains name" true 199 199 + (starts_with "name" trimmed || starts_with "\"name\"" trimmed) 173 200 174 201 let test_roundtrip_simple () = 175 202 let yaml = "name: Alice" in ··· 187 214 () 188 215 | _ -> Alcotest.fail "roundtrip failed" 189 216 190 190 - let emitter_tests = [ 191 191 - "emit null", `Quick, test_emit_null; 192 192 - "emit mapping", `Quick, test_emit_mapping; 193 193 - "roundtrip simple", `Quick, test_roundtrip_simple; 194 194 - "roundtrip sequence", `Quick, test_roundtrip_sequence; 195 195 - ] 217 217 + let emitter_tests = 218 218 + [ 219 219 + ("emit null", `Quick, test_emit_null); 220 220 + ("emit mapping", `Quick, test_emit_mapping); 221 221 + ("roundtrip simple", `Quick, test_roundtrip_simple); 222 222 + ("roundtrip sequence", `Quick, test_roundtrip_sequence); 223 223 + ] 196 224 197 225 (** YAML-specific tests *) 198 226 ··· 204 232 | _ -> Alcotest.fail "expected scalar with anchor" 205 233 206 234 let test_yaml_alias () = 207 207 - let yaml = {| 235 235 + let yaml = 236 236 + {| 208 237 defaults: &defaults 209 238 timeout: 30 210 239 production: 211 240 <<: *defaults 212 241 port: 8080 213 213 - |} in 242 242 + |} 243 243 + in 214 244 (* Just check it parses without error *) 215 245 let _ = yaml_of_string yaml in 216 246 () 217 247 218 218 - let yaml_tests = [ 219 219 - "yaml anchor", `Quick, test_yaml_anchor; 220 220 - "yaml alias", `Quick, test_yaml_alias; 221 221 - ] 248 248 + let yaml_tests = 249 249 + [ 250 250 + ("yaml anchor", `Quick, test_yaml_anchor); 251 251 + ("yaml alias", `Quick, test_yaml_alias); 252 252 + ] 222 253 223 254 (** Multiline scalar tests *) 224 255 ··· 230 261 |} in 231 262 let result = of_string yaml in 232 263 match result with 233 233 - | `O [("description", `String _)] -> () 264 264 + | `O [ ("description", `String _) ] -> () 234 265 | _ -> Alcotest.fail "expected mapping with literal block" 235 266 236 267 let test_folded_block () = ··· 241 272 |} in 242 273 let result = of_string yaml in 243 274 match result with 244 244 - | `O [("description", `String _)] -> () 275 275 + | `O [ ("description", `String _) ] -> () 245 276 | _ -> Alcotest.fail "expected mapping with folded block" 246 277 247 247 - let multiline_tests = [ 248 248 - "literal block", `Quick, test_literal_block; 249 249 - "folded block", `Quick, test_folded_block; 250 250 - ] 278 278 + let multiline_tests = 279 279 + [ 280 280 + ("literal block", `Quick, test_literal_block); 281 281 + ("folded block", `Quick, test_folded_block); 282 282 + ] 251 283 252 284 (** Error handling tests *) 253 285 ··· 255 287 try 256 288 let _ = of_string "key: [unclosed" in 257 289 Alcotest.fail "expected error" 258 258 - with 259 259 - | Yamlrw_error e -> 260 260 - Alcotest.(check bool) "has span" true (e.span <> None) 290 290 + with Yamlrw_error e -> Alcotest.(check bool) "has span" true (e.span <> None) 261 291 262 262 - let error_tests = [ 263 263 - "error position", `Quick, test_error_position; 264 264 - ] 292 292 + let error_tests = [ ("error position", `Quick, test_error_position) ] 265 293 266 294 (** Alias expansion limit tests (billion laughs protection) *) 267 295 268 296 let test_node_limit () = 269 297 (* Small bomb that would expand to 9^4 = 6561 nodes *) 270 270 - let yaml = {| 298 298 + let yaml = 299 299 + {| 271 300 a: &a [1,2,3,4,5,6,7,8,9] 272 301 b: &b [*a,*a,*a,*a,*a,*a,*a,*a,*a] 273 302 c: &c [*b,*b,*b,*b,*b,*b,*b,*b,*b] 274 303 d: &d [*c,*c,*c,*c,*c,*c,*c,*c,*c] 275 275 - |} in 304 304 + |} 305 305 + in 276 306 (* Should fail with a small node limit *) 277 307 try 278 308 let _ = of_string ~max_nodes:100 yaml in 279 309 Alcotest.fail "expected node limit error" 280 280 - with 281 281 - | Yamlrw_error e -> 282 282 - (match e.Error.kind with 283 283 - | Error.Alias_expansion_node_limit _ -> () 284 284 - | _ -> Alcotest.fail "expected Alias_expansion_node_limit error") 310 310 + with Yamlrw_error e -> ( 311 311 + match e.Error.kind with 312 312 + | Error.Alias_expansion_node_limit _ -> () 313 313 + | _ -> Alcotest.fail "expected Alias_expansion_node_limit error") 285 314 286 315 let test_depth_limit () = 287 316 (* Create deeply nested alias chain: 288 317 *e -> [*d,*d] -> [*c,*c] -> [*b,*b] -> [*a,*a] -> [x,y,z] 289 318 Each alias resolution increases depth by 1 *) 290 290 - let yaml = {| 319 319 + let yaml = 320 320 + {| 291 321 a: &a [x, y, z] 292 322 b: &b [*a, *a] 293 323 c: &c [*b, *b] 294 324 d: &d [*c, *c] 295 325 e: &e [*d, *d] 296 326 result: *e 297 297 - |} in 327 327 + |} 328 328 + in 298 329 (* Should fail with a small depth limit (depth 3 means max 3 alias hops) *) 299 330 try 300 331 let _ = of_string ~max_depth:3 yaml in 301 332 Alcotest.fail "expected depth limit error" 302 302 - with 303 303 - | Yamlrw_error e -> 304 304 - (match e.Error.kind with 305 305 - | Error.Alias_expansion_depth_limit _ -> () 306 306 - | _ -> Alcotest.fail ("expected Alias_expansion_depth_limit error, got: " ^ Error.kind_to_string e.Error.kind)) 333 333 + with Yamlrw_error e -> ( 334 334 + match e.Error.kind with 335 335 + | Error.Alias_expansion_depth_limit _ -> () 336 336 + | _ -> 337 337 + Alcotest.fail 338 338 + ("expected Alias_expansion_depth_limit error, got: " 339 339 + ^ Error.kind_to_string e.Error.kind)) 307 340 308 341 let test_normal_aliases_work () = 309 342 (* Normal alias usage should work fine *) 310 310 - let yaml = {| 343 343 + let yaml = 344 344 + {| 311 345 defaults: &defaults 312 346 timeout: 30 313 347 retries: 3 314 348 production: 315 349 <<: *defaults 316 350 port: 8080 317 317 - |} in 351 351 + |} 352 352 + in 318 353 let result = of_string yaml in 319 319 - match result with 320 320 - | `O _ -> () 321 321 - | _ -> Alcotest.fail "expected mapping" 354 354 + match result with `O _ -> () | _ -> Alcotest.fail "expected mapping" 322 355 323 356 let test_resolve_aliases_false () = 324 357 (* With resolve_aliases=false, aliases should remain unresolved *) ··· 329 362 let result = yaml_of_string ~resolve_aliases:false yaml in 330 363 (* Check that alias is preserved *) 331 364 match result with 332 332 - | `O map -> 365 365 + | `O map -> ( 333 366 let pairs = Mapping.members map in 334 334 - (match List.assoc_opt (`Scalar (Scalar.make "b")) pairs with 335 335 - | Some (`Alias "anchor") -> () 336 336 - | _ -> Alcotest.fail "expected alias to be preserved") 367 367 + match List.assoc_opt (`Scalar (Scalar.make "b")) pairs with 368 368 + | Some (`Alias "anchor") -> () 369 369 + | _ -> Alcotest.fail "expected alias to be preserved") 337 370 | _ -> Alcotest.fail "expected mapping" 338 371 339 339 - let alias_limit_tests = [ 340 340 - "node limit", `Quick, test_node_limit; 341 341 - "depth limit", `Quick, test_depth_limit; 342 342 - "normal aliases work", `Quick, test_normal_aliases_work; 343 343 - "resolve_aliases false", `Quick, test_resolve_aliases_false; 344 344 - ] 372 372 + let alias_limit_tests = 373 373 + [ 374 374 + ("node limit", `Quick, test_node_limit); 375 375 + ("depth limit", `Quick, test_depth_limit); 376 376 + ("normal aliases work", `Quick, test_normal_aliases_work); 377 377 + ("resolve_aliases false", `Quick, test_resolve_aliases_false); 378 378 + ] 345 379 346 380 (** Bug fix regression tests 347 381 These tests verify that issues fixed in ocaml-yaml don't occur in ocaml-yamlrw *) ··· 411 445 let test_parse_special_floats () = 412 446 let inf_result = of_string ".inf" in 413 447 (match inf_result with 414 414 - | `Float f when Float.is_inf f && f > 0.0 -> () 448 448 + | `Float f when Float.is_infinite f && f > 0.0 -> () 415 449 | _ -> Alcotest.fail "expected positive infinity"); 416 450 let neg_inf_result = of_string "-.inf" in 417 451 (match neg_inf_result with 418 418 - | `Float f when Float.is_inf f && f < 0.0 -> () 452 452 + | `Float f when Float.is_infinite f && f < 0.0 -> () 419 453 | _ -> Alcotest.fail "expected negative infinity"); 420 454 let nan_result = of_string ".nan" in 421 455 (match nan_result with ··· 485 519 (** Run all tests *) 486 520 487 521 let () = 488 488 - Alcotest.run "yamlrw" [ 489 489 - "scanner", scanner_tests; 490 490 - "parser", parser_tests; 491 491 - "value", value_tests; 492 492 - "emitter", emitter_tests; 493 493 - "yaml", yaml_tests; 494 494 - "multiline", multiline_tests; 495 495 - "errors", error_tests; 496 496 - "alias_limits", alias_limit_tests; 497 497 - "bugfix_regression", bugfix_regression_tests; 498 498 - ] 522 522 + Alcotest.run "yamlrw" 523 523 + [ 524 524 + ("scanner", scanner_tests); 525 525 + ("parser", parser_tests); 526 526 + ("value", value_tests); 527 527 + ("emitter", emitter_tests); 528 528 + ("yaml", yaml_tests); 529 529 + ("multiline", multiline_tests); 530 530 + ("errors", error_tests); 531 531 + ("alias_limits", alias_limit_tests); 532 532 + ("bugfix_regression", bugfix_regression_tests); 533 533 + ]