···
1
+
(*---------------------------------------------------------------------------
2
+
Copyright (c) 2024 The yamlrw programmers. All rights reserved.
3
+
SPDX-License-Identifier: ISC
4
+
---------------------------------------------------------------------------*)
6
+
(** Test location and layout preservation options with Yamlt codec *)
8
+
(* Helper to read file *)
10
+
let ic = open_in path in
11
+
let len = in_channel_length ic in
12
+
let s = really_input_string ic len in
16
+
(* Helper to show results *)
17
+
let show_result label = function
18
+
| Ok _ -> Printf.printf "%s: OK\n" label
19
+
| Error e -> Printf.printf "%s:\n%s\n" label e
21
+
(* Test: Compare error messages with and without locs *)
22
+
let test_error_precision file =
23
+
let yaml = read_file file in
25
+
(* Define a codec that will fail on type mismatch *)
27
+
Jsont.Object.map ~kind:"Person" (fun name age -> (name, age))
28
+
|> Jsont.Object.mem "name" Jsont.string ~enc:fst
29
+
|> Jsont.Object.mem "age" Jsont.int ~enc:snd
30
+
|> Jsont.Object.finish
33
+
Printf.printf "=== Without locs (default) ===\n";
34
+
let result_no_locs = Yamlt.decode_string ~locs:false codec yaml in
35
+
show_result "Error message" result_no_locs;
37
+
Printf.printf "\n=== With locs=true ===\n";
38
+
let result_with_locs = Yamlt.decode_string ~locs:true codec yaml in
39
+
show_result "Error message" result_with_locs
41
+
(* Test: Show error locations for nested structures *)
42
+
let test_nested_error file =
43
+
let yaml = read_file file in
45
+
(* Nested object codec *)
47
+
Jsont.Object.map ~kind:"Address" (fun street city zip -> (street, city, zip))
48
+
|> Jsont.Object.mem "street" Jsont.string ~enc:(fun (s,_,_) -> s)
49
+
|> Jsont.Object.mem "city" Jsont.string ~enc:(fun (_,c,_) -> c)
50
+
|> Jsont.Object.mem "zip" Jsont.int ~enc:(fun (_,_,z) -> z)
51
+
|> Jsont.Object.finish
55
+
Jsont.Object.map ~kind:"Employee" (fun name address -> (name, address))
56
+
|> Jsont.Object.mem "name" Jsont.string ~enc:fst
57
+
|> Jsont.Object.mem "address" address_codec ~enc:snd
58
+
|> Jsont.Object.finish
61
+
Printf.printf "=== Without locs (default) ===\n";
62
+
let result_no_locs = Yamlt.decode_string ~locs:false codec yaml in
63
+
show_result "Nested error" result_no_locs;
65
+
Printf.printf "\n=== With locs=true ===\n";
66
+
let result_with_locs = Yamlt.decode_string ~locs:true codec yaml in
67
+
show_result "Nested error" result_with_locs
69
+
(* Test: Array element error locations *)
70
+
let test_array_error file =
71
+
let yaml = read_file file in
75
+
Jsont.Object.map ~kind:"Numbers" (fun nums -> nums)
76
+
|> Jsont.Object.mem "values" (Jsont.array Jsont.int) ~enc:(fun n -> n)
77
+
|> Jsont.Object.finish
80
+
Printf.printf "=== Without locs (default) ===\n";
81
+
let result_no_locs = Yamlt.decode_string ~locs:false codec yaml in
82
+
show_result "Array error" result_no_locs;
84
+
Printf.printf "\n=== With locs=true ===\n";
85
+
let result_with_locs = Yamlt.decode_string ~locs:true codec yaml in
86
+
show_result "Array error" result_with_locs
88
+
(* Test: Layout preservation - check if we can decode with layout info *)
89
+
let test_layout_preservation file =
90
+
let yaml = read_file file in
93
+
Jsont.Object.map ~kind:"Config" (fun host port -> (host, port))
94
+
|> Jsont.Object.mem "host" Jsont.string ~enc:fst
95
+
|> Jsont.Object.mem "port" Jsont.int ~enc:snd
96
+
|> Jsont.Object.finish
99
+
Printf.printf "=== Without layout (default) ===\n";
100
+
(match Yamlt.decode_string ~layout:false codec yaml with
101
+
| Ok (host, port) ->
102
+
Printf.printf "Decoded: host=%s, port=%d\n" host port;
103
+
Printf.printf "Meta preserved: no\n"
104
+
| Error e -> Printf.printf "Error: %s\n" e);
106
+
Printf.printf "\n=== With layout=true ===\n";
107
+
(match Yamlt.decode_string ~layout:true codec yaml with
108
+
| Ok (host, port) ->
109
+
Printf.printf "Decoded: host=%s, port=%d\n" host port;
110
+
Printf.printf "Meta preserved: yes (style info available for round-tripping)\n"
111
+
| Error e -> Printf.printf "Error: %s\n" e)
113
+
(* Test: Round-trip with layout preservation *)
114
+
let test_roundtrip_layout file =
115
+
let yaml = read_file file in
118
+
Jsont.Object.map ~kind:"Data" (fun items -> items)
119
+
|> Jsont.Object.mem "items" (Jsont.array Jsont.string) ~enc:(fun x -> x)
120
+
|> Jsont.Object.finish
123
+
Printf.printf "=== Original YAML ===\n";
124
+
Printf.printf "%s\n" (String.trim yaml);
126
+
Printf.printf "\n=== Decode without layout, re-encode ===\n";
127
+
(match Yamlt.decode_string ~layout:false codec yaml with
129
+
(match Yamlt.encode_string ~format:Yamlt.Block codec items with
130
+
| Ok yaml_out -> Printf.printf "%s" yaml_out
131
+
| Error e -> Printf.printf "Encode error: %s\n" e)
132
+
| Error e -> Printf.printf "Decode error: %s\n" e);
134
+
Printf.printf "\n=== Decode with layout=true, re-encode with Layout format ===\n";
135
+
(match Yamlt.decode_string ~layout:true codec yaml with
137
+
(match Yamlt.encode_string ~format:Yamlt.Layout codec items with
138
+
| Ok yaml_out -> Printf.printf "%s" yaml_out
139
+
| Error e -> Printf.printf "Encode error: %s\n" e)
140
+
| Error e -> Printf.printf "Decode error: %s\n" e)
142
+
(* Test: File path in error messages *)
143
+
let test_file_path () =
144
+
let yaml = "name: Alice\nage: not-a-number\n" in
147
+
Jsont.Object.map ~kind:"Person" (fun name age -> (name, age))
148
+
|> Jsont.Object.mem "name" Jsont.string ~enc:fst
149
+
|> Jsont.Object.mem "age" Jsont.int ~enc:snd
150
+
|> Jsont.Object.finish
153
+
Printf.printf "=== Without file path ===\n";
154
+
let result1 = Yamlt.decode_string ~locs:true codec yaml in
155
+
show_result "Error" result1;
157
+
Printf.printf "\n=== With file path ===\n";
158
+
let result2 = Yamlt.decode_string ~locs:true ~file:"test.yml" codec yaml in
159
+
show_result "Error" result2
161
+
(* Test: Missing field error with locs *)
162
+
let test_missing_field file =
163
+
let yaml = read_file file in
166
+
Jsont.Object.map ~kind:"Complete" (fun a b c -> (a, b, c))
167
+
|> Jsont.Object.mem "field_a" Jsont.string ~enc:(fun (a,_,_) -> a)
168
+
|> Jsont.Object.mem "field_b" Jsont.int ~enc:(fun (_,b,_) -> b)
169
+
|> Jsont.Object.mem "field_c" Jsont.bool ~enc:(fun (_,_,c) -> c)
170
+
|> Jsont.Object.finish
173
+
Printf.printf "=== Without locs ===\n";
174
+
let result_no_locs = Yamlt.decode_string ~locs:false codec yaml in
175
+
show_result "Missing field" result_no_locs;
177
+
Printf.printf "\n=== With locs=true ===\n";
178
+
let result_with_locs = Yamlt.decode_string ~locs:true codec yaml in
179
+
show_result "Missing field" result_with_locs
181
+
(* Test: Both locs and layout together *)
182
+
let test_combined_options file =
183
+
let yaml = read_file file in
186
+
Jsont.Object.map ~kind:"Settings" (fun timeout retries -> (timeout, retries))
187
+
|> Jsont.Object.mem "timeout" Jsont.int ~enc:fst
188
+
|> Jsont.Object.mem "retries" Jsont.int ~enc:snd
189
+
|> Jsont.Object.finish
192
+
Printf.printf "=== locs=false, layout=false (defaults) ===\n";
193
+
(match Yamlt.decode_string ~locs:false ~layout:false codec yaml with
194
+
| Ok (timeout, retries) ->
195
+
Printf.printf "OK: timeout=%d, retries=%d\n" timeout retries
196
+
| Error e -> Printf.printf "Error: %s\n" e);
198
+
Printf.printf "\n=== locs=true, layout=false ===\n";
199
+
(match Yamlt.decode_string ~locs:true ~layout:false codec yaml with
200
+
| Ok (timeout, retries) ->
201
+
Printf.printf "OK: timeout=%d, retries=%d (with precise locations)\n" timeout retries
202
+
| Error e -> Printf.printf "Error: %s\n" e);
204
+
Printf.printf "\n=== locs=false, layout=true ===\n";
205
+
(match Yamlt.decode_string ~locs:false ~layout:true codec yaml with
206
+
| Ok (timeout, retries) ->
207
+
Printf.printf "OK: timeout=%d, retries=%d (with layout metadata)\n" timeout retries
208
+
| Error e -> Printf.printf "Error: %s\n" e);
210
+
Printf.printf "\n=== locs=true, layout=true (both enabled) ===\n";
211
+
(match Yamlt.decode_string ~locs:true ~layout:true codec yaml with
212
+
| Ok (timeout, retries) ->
213
+
Printf.printf "OK: timeout=%d, retries=%d (with locations and layout)\n" timeout retries
214
+
| Error e -> Printf.printf "Error: %s\n" e)
217
+
let usage = "Usage: test_locations <command> [args...]" in
219
+
if Stdlib.Array.length Sys.argv < 2 then begin
220
+
prerr_endline usage;
224
+
match Sys.argv.(1) with
225
+
| "error-precision" when Array.length Sys.argv = 3 ->
226
+
test_error_precision Sys.argv.(2)
228
+
| "nested-error" when Array.length Sys.argv = 3 ->
229
+
test_nested_error Sys.argv.(2)
231
+
| "array-error" when Array.length Sys.argv = 3 ->
232
+
test_array_error Sys.argv.(2)
234
+
| "layout" when Array.length Sys.argv = 3 ->
235
+
test_layout_preservation Sys.argv.(2)
237
+
| "roundtrip" when Array.length Sys.argv = 3 ->
238
+
test_roundtrip_layout Sys.argv.(2)
243
+
| "missing-field" when Array.length Sys.argv = 3 ->
244
+
test_missing_field Sys.argv.(2)
246
+
| "combined" when Array.length Sys.argv = 3 ->
247
+
test_combined_options Sys.argv.(2)
250
+
prerr_endline usage;
251
+
prerr_endline "Commands:";
252
+
prerr_endline " error-precision <file> - Compare error messages with/without locs";
253
+
prerr_endline " nested-error <file> - Test error locations in nested objects";
254
+
prerr_endline " array-error <file> - Test error locations in arrays";
255
+
prerr_endline " layout <file> - Test layout preservation";
256
+
prerr_endline " roundtrip <file> - Test round-tripping with layout";
257
+
prerr_endline " file-path - Test file path in error messages";
258
+
prerr_endline " missing-field <file> - Test missing field errors with locs";
259
+
prerr_endline " combined <file> - Test locs and layout together";
anil.recoil.org