Source file clerk_runtest.ml
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
open Catala_utils
type output_buf = { oc : out_channel; mutable pos : Lexing.position }
let pos0 pos_fname =
{ Lexing.pos_fname; pos_cnum = 0; pos_lnum = 1; pos_bol = 0 }
let with_output file_opt f =
match file_opt with
| Some file ->
File.with_out_channel file @@ fun oc -> f { oc; pos = pos0 file }
| None -> f { oc = stdout; pos = pos0 "<stdout>" }
let out_line output_buf str =
let len = String.length str in
let has_nl = str <> "" && str.[len - 1] = '\n' in
output_string output_buf.oc str;
if not has_nl then output_char output_buf.oc '\n';
let pos_cnum = output_buf.pos.pos_cnum + len + if has_nl then 0 else 1 in
output_buf.pos <-
{
output_buf.pos with
Lexing.pos_cnum;
pos_lnum = output_buf.pos.pos_lnum + 1;
pos_bol = pos_cnum;
}
let sanitize =
let re_endtest = Re.(compile @@ seq [bol; str "```"]) in
let re_modhash =
Re.(
compile
@@ seq
[
str "\"CM0|";
repn xdigit 8 (Some 8);
char '|';
repn xdigit 8 (Some 8);
char '|';
repn xdigit 8 (Some 8);
char '"';
])
in
fun str ->
str
|> Re.replace_string re_endtest ~by:"\\```"
|> Re.replace_string re_modhash ~by:"\"CMX|XXXXXXXX|XXXXXXXX|XXXXXXXX\""
let catala_test_command test_flags catala_exe catala_opts args out =
let catala_exe =
if String.contains catala_exe Filename.dir_sep.[0] then
Unix.realpath catala_exe
else catala_exe
in
match args with
| "latex" :: flags ->
Some
(Array.of_list
((catala_exe :: "latex" :: flags)
@ List.filter
(fun s -> not (String.starts_with ~prefix:"--stdlib=" s))
catala_opts))
| cmd0 :: flags -> (
try
let cmd0, flags =
match String.lowercase_ascii cmd0, flags, test_flags with
| "test-scope", scope_name :: flags, test_flags ->
"interpret", flags @ test_flags @ ["--scope=" ^ scope_name]
| "test-scope", [], _ ->
out_line out
"[INVALID TEST] Invalid test command syntax, the 'test-scope' \
pseudo-command takes a scope name as first argument\n";
"interpret", test_flags
| cmd0, flags, [] -> cmd0, flags
| _, _, _ :: _ ->
raise Exit
in
Some (Array.of_list ((catala_exe :: cmd0 :: catala_opts) @ flags))
with Exit -> None)
| [] -> Some (Array.of_list (catala_exe :: catala_opts))
let catala_test_env () =
Unix.environment ()
|> Array.to_seq
|> Seq.filter (fun s ->
not
(String.starts_with ~prefix:"OCAMLRUNPARAM=" s
|| String.starts_with ~prefix:"CATALA_" s))
|> Seq.cons "CATALA_OUT=-"
|> Seq.cons "CATALA_COLOR=never"
|> Seq.cons "CATALA_PLUGINS="
|> Array.of_seq
let run_catala_test filename cmd program expected out_line =
let cmd_in_rd, cmd_in_wr = Unix.pipe ~cloexec:true () in
let cmd_out_rd, cmd_out_wr = Unix.pipe ~cloexec:true () in
let command_oc = Unix.out_channel_of_descr cmd_in_wr in
let command_ic = Unix.in_channel_of_descr cmd_out_rd in
let env = catala_test_env () in
let cmd = Array.append cmd [| "--name=" ^ filename; "-" |] in
let pid =
Unix.create_process_env cmd.(0) cmd env cmd_in_rd cmd_out_wr cmd_out_wr
in
Unix.close cmd_in_rd;
Unix.close cmd_out_wr;
Seq.iter (output_string command_oc) program;
close_out command_oc;
let out_lines =
Seq.of_dispenser (fun () -> In_channel.input_line command_ic)
in
let success, expected =
Seq.fold_left
(fun (success, expected) result_line ->
let result_line = sanitize result_line ^ "\n" in
out_line result_line;
match Seq.uncons expected with
| Some (l, expected) -> success && String.equal result_line l, expected
| None -> false, Seq.empty)
(true, expected) out_lines
in
let return_code =
match Unix.waitpid [] pid with
| _, Unix.WEXITED n -> n
| _, (Unix.WSIGNALED n | Unix.WSTOPPED n) -> 128 - n
in
let success, expected =
if return_code = 0 then success, expected
else
let line = Printf.sprintf "#return code %d#\n" return_code in
out_line line;
match Seq.uncons expected with
| Some (l, expected) when String.equal l line -> success, expected
| Some (_, expected) -> false, expected
| None -> false, Seq.empty
in
success && Seq.is_empty expected
let get_pos pos_fname pos_lnum col =
let pos_bol = -1 in
{ Lexing.pos_fname; pos_lnum; pos_bol; pos_cnum = pos_bol + col }
let run_catala_test_scopes test_flags catala_exe catala_opts filename =
let cmd_out_rd, cmd_out_wr = Unix.pipe ~cloexec:true () in
let command_ic = Unix.in_channel_of_descr cmd_out_rd in
let env = catala_test_env () in
let cmd =
Array.of_list
(catala_exe
:: "interpret"
:: "--quiet"
:: "--message-format=gnu"
:: filename
:: catala_opts
@ test_flags)
in
let pid =
Unix.create_process_env catala_exe cmd env Unix.stdin cmd_out_wr cmd_out_wr
in
Unix.close cmd_out_wr;
let out_lines =
Seq.of_dispenser (fun () -> In_channel.input_line command_ic)
in
let parse_error line =
let re_error =
let open Re in
compile
@@ whole_string
@@ seq
[
bos;
group ~name:"file" @@ rep1 (diff any (char ':'));
char ':';
group ~name:"line0" @@ rep1 digit;
char '.';
group ~name:"col0" @@ rep1 digit;
char '-';
group ~name:"line1" @@ rep1 digit;
char '.';
group ~name:"col1" @@ rep1 digit;
str ": [ERROR]";
rep (alt [set " :/"; digit]);
group ~name:"message" @@ rep1 any;
]
in
match Re.exec_opt re_error line with
| Some g ->
let gets label =
Re.Group.get g (List.assoc label (Re.group_names re_error))
in
let file = gets "file" in
let pos = get_pos file in
let geti label = int_of_string (gets label) in
Some
( (pos (geti "line0") (geti "col0"), pos (geti "line1") (geti "col1")),
gets "message" )
| None -> None
in
let re_line =
let open Re in
compile
@@ whole_string
@@ seq
[
group (rep1 (diff any (char ':')));
str ": ";
group (alt [str "passed"; str "failed"]);
]
in
let errs, scopes_results =
Seq.fold_left
(fun (errs, acc) line ->
match Re.exec_opt re_line line with
| Some g ->
let scope = Re.Group.get g 1 in
let result =
match Re.Group.get g 2 with
| "passed" -> true
| "failed" -> false
| _ -> assert false
in
( [],
{
Clerk_report.s_name = scope;
s_success = result;
s_command_line =
(catala_exe :: "interpret" :: filename :: catala_opts)
@ test_flags
@ ["--scope=" ^ scope];
s_errors = List.rev errs;
}
:: acc )
| None -> (
match parse_error line with
| Some (pos, err) -> (pos, err) :: errs, acc
| None ->
Message.debug
"Ignored unrecognised output line from 'catala interpret':@ %S"
line;
errs, acc))
([], []) out_lines
in
let return_code =
match Unix.waitpid [] pid with
| _, Unix.WEXITED n -> n
| _, (Unix.WSIGNALED n | Unix.WSTOPPED n) -> 128 - n
in
let scopes_results =
if
return_code <> 0
&& List.filter (fun t -> not t.Clerk_report.s_success) scopes_results = []
then
{
Clerk_report.s_name = "compilation";
s_success = false;
s_command_line =
(catala_exe :: "interpret" :: filename :: catala_opts) @ test_flags;
s_errors = errs;
}
:: scopes_results
else scopes_results
in
List.rev scopes_results
(** Directly runs the test (not using ninja, this will be called by ninja rules
through the "clerk runtest" command) *)
let run_tests ~catala_exe ~catala_opts ~test_flags ~report ~out filename =
let module L = Surface.Lexer_common in
let lang =
match Clerk_scan.get_lang filename with
| Some l -> l
| None ->
Message.error "Can't infer catala dialect from file extension of %a"
File.format filename
in
let lines = Surface.Parser_driver.lines filename lang in
with_output out
@@ fun out ->
let lines_until_now = Queue.create () in
let push_line str =
out_line out str;
Queue.add str lines_until_now
in
let rtests : Clerk_report.inline_test list ref = ref [] in
let rec skip_block lines =
match Seq.uncons lines with
| Some ((l, tok, _), lines) ->
push_line l;
if tok = L.LINE_BLOCK_END then lines else skip_block lines
| None -> Seq.empty
in
let rec get_block acc lines =
let return lines acc =
let endpos =
match acc with
| (_, _, (_, epos)) :: _ -> epos
| [] -> { Lexing.dummy_pos with pos_fname = filename }
in
let block = List.rev acc in
let startpos =
match block with
| (_, _, (spos, _)) :: _ -> spos
| [] -> { Lexing.dummy_pos with pos_fname = filename }
in
lines, block, (startpos, endpos)
in
match Seq.uncons lines with
| None -> return Seq.empty acc
| Some ((_, L.LINE_BLOCK_END, _), lines) -> return lines acc
| Some (li, lines) -> get_block (li :: acc) lines
in
let broken_test msg =
let opos_start = out.pos in
push_line msg;
{
Clerk_report.i_success = false;
i_command_line = [];
i_expected =
( { Lexing.dummy_pos with pos_fname = filename },
{ Lexing.dummy_pos with pos_fname = filename } );
i_result = opos_start, out.pos;
}
in
let get_test_command lines =
match Seq.uncons lines with
| None ->
let t =
broken_test
"[INVALID TEST] Missing test command, use '$ catala <args>'\n"
in
rtests := t :: !rtests;
None, Seq.empty
| Some ((str, L.LINE_BLOCK_END, _), lines) ->
let t =
broken_test
"[INVALID TEST] Missing test command, use '$ catala <args>'\n"
in
rtests := t :: !rtests;
push_line str;
None, lines
| Some ((str, _, _), lines) -> (
push_line str;
match Clerk_scan.test_command_args str with
| None ->
let t =
broken_test
"[INVALID TEST] Invalid test command syntax, must match '$ catala \
<args>'\n"
in
let lines, _, ipos = get_block [] lines in
push_line "```\n";
rtests := { t with Clerk_report.i_expected = ipos } :: !rtests;
None, lines
| Some args -> (
let args = String.split_on_char ' ' args in
let program =
let rec drop_last seq () =
match seq () with
| Seq.Nil -> assert false
| Seq.Cons (x, next) -> (
match next () with
| Seq.Nil -> Seq.Nil
| Seq.Cons _ as s -> Seq.Cons (x, drop_last (fun () -> s)))
in
Queue.to_seq lines_until_now |> drop_last |> drop_last
in
let opos_start = out.pos in
match
catala_test_command test_flags catala_exe catala_opts args out
with
| Some cmd -> Some (cmd, program, opos_start), lines
| None -> None, skip_block lines))
in
let run_inline_test lines =
match get_test_command lines with
| None, lines -> lines
| Some (cmd, program, opos_start), lines ->
let lines, expected, ipos = get_block [] lines in
let expected = Seq.map (fun (s, _, _) -> s) (List.to_seq expected) in
let i_success = run_catala_test filename cmd program expected push_line in
let opos_end = out.pos in
push_line "```\n";
rtests :=
{
Clerk_report.i_success;
i_command_line = Array.to_list cmd @ [filename];
i_result = opos_start, opos_end;
i_expected = ipos;
}
:: !rtests;
lines
in
let rec process ~has_test_scopes ~includes lines =
match Seq.uncons lines with
| Some ((str, L.LINE_INLINE_TEST, _), lines) ->
push_line str;
let lines = run_inline_test lines in
process ~has_test_scopes ~includes lines
| Some ((str, L.LINE_TEST_ATTRIBUTE, _), lines) ->
push_line str;
process ~has_test_scopes:true ~includes lines
| Some ((str, L.LINE_INCLUDE f, _), lines) ->
push_line str;
let f = if Filename.is_relative f then File.(filename /../ f) else f in
process ~has_test_scopes ~includes:(f :: includes) lines
| Some ((str, _, _), lines) ->
push_line str;
process ~has_test_scopes ~includes lines
| None -> has_test_scopes, includes
in
let has_test_scopes, includes =
process ~has_test_scopes:false ~includes:[] lines
in
let has_test_scopes =
has_test_scopes || List.exists (Clerk_scan.find_test_scope ~lang) includes
in
let scopes_results =
if has_test_scopes then
run_catala_test_scopes test_flags catala_exe catala_opts filename
else []
in
let successful_test_scopes, failed_test_scopes =
List.fold_left
(fun (nsucc, nfail) t ->
if t.Clerk_report.s_success then nsucc + 1, nfail else nsucc, nfail + 1)
(0, 0) scopes_results
in
let num_test_scopes = successful_test_scopes + failed_test_scopes in
let tests_report =
List.fold_left
Clerk_report.(
fun tests t ->
{
tests with
total = tests.total + 1;
successful = (tests.successful + if t.i_success then 1 else 0);
tests = t :: tests.tests;
})
{
Clerk_report.name = filename;
successful = successful_test_scopes;
total = num_test_scopes;
tests = [];
scopes = scopes_results;
}
!rtests
in
match report with
| Some file -> Clerk_report.write_to file tests_report
| None -> ()