ocaml · rgrinberg · Jul 23, 2023 · Jun 10, 2023 · Jun 10, 2023 · Jun 10, 2023
diff --git a/CHANGES.md b/CHANGES.md
@@ -12,6 +12,9 @@ Unreleased
 - Add `dune build --dump-gc-stats FILE` argument to dump garbage collection
   stats to a named file. (#8072, @Alizter)
 
+- Fix bug with ppx and Reason syntax due to missing dependency in sandboxed
+  action (#7932, fixes #7930, @Alizter)
+
 3.9.1 (2023-07-06)
 ------------------
 

diff --git a/src/dune_rules/preprocessing.ml b/src/dune_rules/preprocessing.ml
@@ -699,6 +699,10 @@ let pp_one_module sctx ~lib_name ~scope ~preprocessor_deps
                            ; Path (Path.build dst)
                            ; Command.Ml_kind.ppx_driver_flag ml_kind
                            ; Dep (Path.build src)
+                           ; Hidden_deps
+                               (Module.source m ~ml_kind |> Option.value_exn
+                              |> Module.File.path |> Dep.file
+                              |> Dep.Set.singleton)
                            ; As flags
                            ]
                          >>| Action.Full.add_sandbox sandbox))))

diff --git a/test/blackbox-tests/test-cases/dune b/test/blackbox-tests/test-cases/dune
@@ -6,7 +6,8 @@
   (binaries
    ../utils/dune_cmd.exe
    ../utils/dunepp.exe
-   ../utils/melc_stdlib_prefix.exe)))
+   ../utils/melc_stdlib_prefix.exe
+   ../utils/refmt.exe)))
 
 (cram
  (applies_to pp-cwd)
@@ -137,3 +138,13 @@
  (enabled_if
   (= %{system} linux))
  (deps %{bin:strace}))
+
+(cram
+ (applies_to reason-expect)
+ (deps
+  (package ppx_expect)
+  %{bin:refmt}))
+
+(cram
+ (applies_to reason)
+ (deps %{bin:refmt}))
diff --git a/test/blackbox-tests/test-cases/reason-expect.t/run.t b/test/blackbox-tests/test-cases/reason-expect.t/run.t
@@ -0,0 +1,28 @@
+Testing the interaction of reason syntax and ppx expect
+
+  $ cat > dune << EOF
+  > (library
+  >  (name test)
+  >  (inline_tests)
+  >  (preprocess (pps ppx_expect)))
+  > EOF
+
+  $ cat > test.re << EOF
+  > let%expect_test _ =
+  >   print_endline("Hello, world!");
+  >   [%expect {| |}]
+  > EOF
+
+In https://github.com/ocaml/dune/issues/7930 there is an issue where reason
+syntax and ppx_expect break at dune lang 3.3 due to the sandboxing of ppx.
+
+  $ cat > dune-project << EOF
+  > (lang dune 3.9)
+  > EOF
+  $ dune test 2>&1 | head -n 6
+  File "dune", line 3, characters 1-15:
+  3 |  (inline_tests)
+       ^^^^^^^^^^^^^^
+  Fatal error: exception ("Expect test evaluator bug"
+    (exn (Invalid_argument "pos + len past end: 78 + 1 > 72"))
+    (backtrace
diff --git a/test/blackbox-tests/test-cases/reason.t/refmt/dune b/test/blackbox-tests/test-cases/reason.t/refmt/dune
diff --git a/test/blackbox-tests/test-cases/reason.t/run.t b/test/blackbox-tests/test-cases/reason.t/run.t
@@ -19,7 +19,6 @@ We make sure to install reason source files:
     "_build/install/default/lib/rlib/hello.rei"
     "_build/install/default/lib/rlib/pped.re"
     "_build/install/default/lib/rlib/pped.rei"
-    "_build/install/default/bin/refmt"
 
 virtual libraries in reason
   $ PATH="_build/install/default/bin:$PATH" dune build --root vlib-impl @all

diff --git a/test/blackbox-tests/utils/dune b/test/blackbox-tests/utils/dune
@@ -18,3 +18,7 @@
  (modules melc_stdlib_prefix)
  (name melc_stdlib_prefix)
  (libraries stdune))
+
+(executable
+ (name refmt)
+ (modules refmt))
diff --git a/...-tests/test-cases/reason.t/refmt/refmt.ml → test/blackbox-tests/utils/refmt.ml b/...-tests/test-cases/reason.t/refmt/refmt.ml → test/blackbox-tests/utils/refmt.ml
@@ -6,12 +6,9 @@ type ('impl, 'intf) intf_or_impl =
 
 module File = struct
   let of_filename s =
-    if Filename.check_suffix s ".re" then
-      Impl s
-    else if Filename.check_suffix s ".rei" then
-      Intf s
-    else
-      failwith (sprintf "unknown filename %S" s)
+    if Filename.check_suffix s ".re" then Impl s
+    else if Filename.check_suffix s ".rei" then Intf s
+    else failwith (sprintf "unknown filename %S" s)
 
   let output_fn = function
     | Impl fn -> fn ^ ".ml"
@@ -23,10 +20,7 @@ let () =
     | "binary" -> ()
     | _ -> failwith "Only the value 'binary' is allowed for --print"
   in
-  let args =
-    [ "--print", Arg.String set_binary, ""
-    ]
-  in
+  let args = [ ("--print", Arg.String set_binary, "") ] in
   let source = ref None in
   let anon s =
     match !source with
@@ -43,10 +37,13 @@ let () =
   let source_file = File.of_filename source in
   let out_fn = File.output_fn source_file in
   let out = open_out_bin out_fn in
+  output_string out (sprintf "# 1 %S\n" source);
   let rec loop () =
     match input_char ic with
     | exception End_of_file -> ()
-    | s -> output_char out s; loop ()
+    | s ->
+      output_char out s;
+      loop ()
   in
   loop ();
   close_out_noerr out