Implement reversing the dependencies for tests

build_system/clerk_driver.ml

@@ -171,7 +171,7 @@ let readdir_sort (dirname : string) : string array =
     let dirs = Sys.readdir dirname in
     Array.fast_sort String.compare dirs;
     dirs
-  with Sys_error _ -> Array.make 0 ""
+  with Sys_error _ -> [||]
 
 type test = {
   text_before : string;
@@ -184,81 +184,148 @@ type test = {
 }
 
 type file_tests = {
+  filename : string;
   tests : test list;
   text_after : string;  (** Verbatim of everything following the last test *)
 }
 
-let inline_test_start_key = "```catala-test-inline"
+(* Matches both test starts and includes; discriminate by checking [Group.get g
+   1], which will be defined only for includes (and equal to the included
+   file) *)
+let test_scan_rex =
+  let open Re in
+  let inline_test_start_key = str "```catala-test-inline" in
+  let include_regexp =
+    (* TODO: we match on "Inclu*" which will work for now but may not scale to
+       new languages. The reasonable alternative would be to run the appropriate
+       lexer on all files, but it might not yet be worth the added complexity
+       (?) *)
+    seq
+      [
+        char '>';
+        rep1 blank;
+        str "Inclu";
+        rep1 alpha;
+        rep blank;
+        char ':';
+        rep blank;
+        group (rep1 notnl);
+      ]
+  in
+  compile
+    (seq [bol; alt [inline_test_start_key; include_regexp]; rep blank; eol])
+
+let checkfile parents file =
+  let file = try Unix.realpath file with Unix.Unix_error _ -> file in
+  if List.mem file parents then
+    Message.raise_error "@[<hv 2>Cyclic file inclusion:@ %a@]"
+      (Format.pp_print_list
+         ~pp_sep:(fun ppf () -> Format.fprintf ppf " %a@ " String.format "→")
+         Format.pp_print_string)
+      (List.rev (file :: parents));
+  (file :: parents), file
+
+let with_in_channel_safe parents file f =
+  try File.with_in_channel file f
+  with Sys_error err ->
+    Message.raise_error "Could not open file %S:@ %s@ %a" file err
+      (Format.pp_print_list ~pp_sep:Format.pp_print_space (fun ppf f ->
+           Format.fprintf ppf "included from %S" f))
+      parents
 
-let has_inline_tests (file : string) : bool =
+let rec has_inline_tests ?(parents = []) (file : string) : bool =
+  let parents, file = checkfile parents file in
   let rec aux ic =
     match input_line ic with
     | exception End_of_file -> false
-    | li -> String.starts_with ~prefix:inline_test_start_key li || aux ic
+    | li -> (
+      match Re.exec_opt test_scan_rex li with
+      | None -> aux ic
+      | Some gr -> (
+        match Re.Group.get_opt gr 1 with
+        | None -> true
+        | Some incl ->
+          let incl_file = File.(Filename.dirname file / incl) in
+          aux ic
+          ||
+          (close_in ic;
+           has_inline_tests ~parents incl_file)))
   in
-  File.with_in_channel file aux
+  with_in_channel_safe parents file aux
 
-let [@ocamlformat "disable"] scan_for_inline_tests (file : string)
-  : file_tests option =
-  File.with_in_channel file
-  @@ fun ic ->
-  (* Matches something of the form: {v
+let [@ocamlformat "disable"] rec scan_for_inline_tests ?(parents=[]) (file : string)
+  : file_tests list =
+  let parents, file = checkfile parents file in
+  let read_file ic =
+    (* Matches something of the form: {v
      ```catala-test-inline
-    $ catala Interpret -s A
-    ... output from catala ...
-    #return code 10#
-    ```
-    v} *)
-  let test_start_rex =
-    Re.(compile (seq [bol; str inline_test_start_key; rep space; char '\n']))
-  in
-  let test_content_rex =
-    Re.compile
-      Re.(
-        seq
-          [
-            seq [char '$'; rep space; str "catala"; group (rep1 notnl);
-                 char '\n'];
-            group (non_greedy (rep any));
-            seq [bol; str "```\n"];
-          ])
-  in
-  let file_str = really_input_string ic (in_channel_length ic) in
-  let rec scan acc pos0 =
-    try
-      let header = Re.exec ~pos:pos0 test_start_rex file_str in
-      let pos = Re.Group.stop header 0 in
-      let test_contents =
-        try Re.exec ~pos test_content_rex file_str
-        with Not_found ->
-          let line =
-            String.fold_left
-              (fun n -> function '\n' -> n + 1 | _ -> n)
-              1
-              (String.sub file_str 0 pos)
+     $ catala Interpret -s A
+     ... output from catala ...
+     #return code 10#
+     ```
+     v} *)
+    let test_content_rex =
+      Re.(compile @@
+          seq
+            [
+              seq [char '$'; rep space; str "catala"; group (rep1 notnl);
+                   char '\n'];
+              group (non_greedy (rep any));
+              seq [bol; str "```\n"];
+            ])
+    in
+    let file_str = really_input_string ic (in_channel_length ic) in
+    let rec scan incls acc pos_scan pos_block =
+      try
+        let scan_grp = Re.exec ~pos:pos_scan test_scan_rex file_str in
+        let pos = Re.Group.stop scan_grp 0 in
+        match Re.Group.get_opt scan_grp 1 with
+        | Some incl ->
+          let incl_file = File.(Filename.dirname file / incl) in
+          scan (incl_file::incls) acc (Re.Group.stop scan_grp 0) pos_block
+        | None ->
+          let test_contents =
+            try Re.exec ~pos test_content_rex file_str
+            with Not_found ->
+              let line =
+                String.fold_left
+                  (fun n -> function '\n' -> n + 1 | _ -> n)
+                  1
+                  (String.sub file_str 0 pos)
+              in
+              Message.raise_error "Bad inline-test format at %s line %d" file line
           in
-          Message.raise_error "Bad inline-test format at %s line %d" file line
-      in
-      let params =
-        List.filter (( <> ) "")
-          (String.split_on_char ' ' (Re.Group.get test_contents 1))
-      in
-      let out_start = Re.Group.start test_contents 2 in
-      let test =
-        { text_before = String.sub file_str pos0 (out_start - pos0); params }
-      in
-      scan (test :: acc) (Re.Group.stop test_contents 2)
-    with Not_found -> (
-      match acc with
-      | [] -> None
-      | tests ->
-        Some
-          {
-            tests = List.rev tests;
-            text_after = String.sub file_str pos0 (String.length file_str - pos0);
-          })
+          let params =
+            List.filter (( <> ) "")
+              (String.split_on_char ' ' (Re.Group.get test_contents 1))
+          in
+          let out_start = Re.Group.start test_contents 2 in
+          let test =
+            { text_before = String.sub file_str pos_block (out_start - pos_block);
+              params }
+          in
+          let pos_next = Re.Group.stop test_contents 2 in
+          scan incls (test :: acc) pos_next pos_next
+      with Not_found -> (
+          match acc with
+          | [] -> List.rev incls, []
+          | tests ->
+            List.rev incls,
+            [{
+              filename = file;
+              tests = List.rev tests;
+              text_after =
+                String.sub file_str pos_block
+                  (String.length file_str - pos_block);
+            }])
+    in
+    scan [] [] 0 0
   in
-  scan [] 0
+  let incls, tests = with_in_channel_safe parents file read_file in
+  List.fold_left (fun tests incfile ->
+      List.rev_append (scan_for_inline_tests ~parents incfile) tests)
+    (List.rev tests) incls
+  |> List.rev
 
 (** Given a file, looks in the relative [output] directory if there are files
     with the same base name that contain expected outputs for different *)
@@ -617,9 +684,13 @@ let run_inline_tests
     (catala_exe : string)
     (catala_opts : string list) =
   match scan_for_inline_tests file with
-  | None -> Message.emit_warning "No inline tests found in %s" file
-  | Some file_tests ->
-    let run oc =
+  | [] -> Message.emit_warning "No inline tests found in %s" file
+  | file_tests ->
+    Message.emit_debug "@[<v 2>Running tests:@ %a@]"
+      (Format.pp_print_list (fun ppf t -> Format.fprintf ppf "- @[<hov>%s:@ %d tests@]"
+                                t.filename (List.length t.tests)))
+      file_tests;
+    let run test oc =
       List.iter
         (fun test ->
           output_string oc test.text_before;
@@ -664,18 +735,21 @@ let run_inline_tests
           in
           if return_code <> 0 then
             Printf.fprintf oc "#return code %d#\n" return_code)
-        file_tests.tests;
-      output_string oc file_tests.text_after;
+        test.tests;
+      output_string oc test.text_after;
       flush oc
     in
-    if reset then (
-      let out = file ^ ".out" in
-      (try File.with_out_channel out run
-       with e ->
-         Sys.remove out;
-         raise e);
-      Sys.rename out file)
-    else run stdout
+    List.iter
+      (fun test ->
+        if reset then (
+          let out = test.filename ^ ".out" in
+          (try File.with_out_channel out (run test)
+           with e ->
+             Sys.remove out;
+             raise e);
+          Sys.rename out test.filename)
+        else run test stdout)
+      file_tests
 
 (**{1 Running}*)
 

examples/Makefile

@@ -9,16 +9,16 @@ CLERK=_build/default/build_system/clerk.exe --exe "_build/default/compiler/catal
 ################################
 
 pass_all_tests:
-	@cd ..;OCAMLRUNPARAM= $(CLERK) examples
+	@cd ..; $(CLERK) examples
 
 reset_all_tests: CLERK_OPTS+=--reset
 reset_all_tests:
-	@cd ..;OCAMLRUNPARAM= $(CLERK) examples
+	@cd ..; $(CLERK) examples
 
 %.catala_en %.catala_fr %.catala_pl: .FORCE
     # Here we cd to the root of the Catala repository such that the paths \
 	# displayed in error messages start with `examples/` uniformly.
-	@cd ..;OCAMLRUNPARAM= $(CLERK) examples/$@
+	@cd ..; $(CLERK) examples/$@
 
 .FORCE:
 

tests/Makefile

@@ -17,8 +17,8 @@ CLERK=_build/default/build_system/clerk.exe --exe "_build/default/compiler/catal
 	@cd ..; $(CLERK) tests/$@
 
 pass_all_tests:
-	@cd ..;OCAMLRUNPARAM= $(CLERK) tests
+	@cd ..; $(CLERK) tests
 
 reset_all_tests: CLERK_OPTS+=--reset
 reset_all_tests:
-	@cd ..;OCAMLRUNPARAM= $(CLERK) tests
+	@cd ..; $(CLERK) tests