package catala

  1. Overview
  2. Docs
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

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
(* This file is part of the Catala build system, a specification language for
   tax and social benefits computation rules. Copyright (C) 2022-2023 Inria,
   contributors: Louis Gesbert <louis.gesbert@inria.fr>

   Licensed under the Apache License, Version 2.0 (the "License"); you may not
   use this file except in compliance with the License. You may obtain a copy of
   the License at

   http://www.apache.org/licenses/LICENSE-2.0

   Unless required by applicable law or agreed to in writing, software
   distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
   WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
   License for the specific language governing permissions and limitations under
   the License. *)

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 the exe name contains directories, make it absolute. Otherwise don't
       modify it so that it can be looked up in PATH. *)
    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 (* Skip other tests when test-flags is specified *)
      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

(* Note: the line number is enough for now, we ignore the rest (recomputing the
   cnum would require reading the file) *)
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 =
    (* Add a fake results in case some scopes failed to run *)
    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 -> ()