Execute preprocess commands using the system shell

.gitignore

@@ -2,3 +2,4 @@ _build
 *.install
 boot.exe
 .merlin
+boot.ml

bootstrap.ml

@@ -291,6 +291,16 @@ end
 
 let () = generate_file_with_all_the_sources ()
 
+let cleanup ~keep_ml_file =
+  try
+    Array.iter (Sys.readdir ".") ~f:(fun fn ->
+      if fn <> "boot.exe" &&
+         starts_with fn ~prefix:"boot." &&
+         (fn <> "boot.ml" || not keep_ml_file) then
+        Sys.remove fn)
+  with _ ->
+    ()
+
 let () =
   let lib_ext =
     match mode with
@@ -298,15 +308,9 @@ let () =
     | Byte   -> "cma"
   in
   let n =
-    protectx ()
-      ~f:(fun () ->
-        exec "%s -w -40 -o boot.exe unix.%s %s" compiler lib_ext generated_file)
-      ~finally:(fun () ->
-        try
-          Array.iter (Sys.readdir ".") ~f:(fun fn ->
-            if fn <> "boot.exe" && starts_with fn ~prefix:"boot." then
-              Sys.remove fn)
-        with _ ->
-          ())
+    match exec "%s -w -40 -o boot.exe unix.%s %s" compiler lib_ext generated_file with
+    | n -> n
+    | exception e -> cleanup ~keep_ml_file:true; raise e
   in
+  cleanup ~keep_ml_file:(n <> 0);
   if n <> 0 then exit n

doc/manual.org

@@ -708,6 +708,13 @@ Jbuilder accept three kinds of pre-processing:
 Note that in any cases, files are pre-processed only once. Jbuilder
 doesn't use the =-pp= or =-ppx= of the various OCaml tools.
 
+However, in the case of =(command <shell-command>)=, the shell command
+is still interpreted in the same way as if it was passed to the =-pp=
+option. In particular it is executed using the system shell (=sh= or
+=cmd= depending on the OS). Note that you shouldn't make assumption
+about where the command is run from, this is an implementation detail
+of Jbuilder and might change in the Future.
+
 =<ppx-rewriters-and-flags>= is expected to be a list where each
 element is either a command line flag if starting with a =-= or the
 name of a library implementing an OCaml AST rewriter. These must be
@@ -809,8 +816,9 @@ of these two forms:
 - using a small DSL, that is interpreted by jbuilder directly and
   doesn't require an external shell
 
-In both case, each atom in the argument supports [[Variables expansion][variables
-expansion]]. Moreover, you don't need to specify dependencies
+In both case, all atoms in the argument of this field supports
+[[Variables
+ expansion][variables expansion]]. Moreover, you don't need to specify dependencies
 explicitely for the special =${exe:...}=, =${bin:...}= or
 =${findlib:...}= forms, these are recognized automatically by
 Jbuilder.
@@ -831,8 +839,9 @@ The following constructions are available:
 - =(echo <string>)= to output a string on stdout
 - =(cat <file>)= to print the contents of a file to stdout
 - =(copy <src> <dst>)= to copy a file
-- =(copy-and-add-line-directive <src> <dst>)= to copy a file and add a
-  line directive at the beginning
+- =(copy-and-add-line-directive <src> <dst>)= to copy a file and add a line directive at the beginning
+- =(system <cmd>)= to execute a command using the system shell: =sh=
+  on Unix and =cmd= on Windows
 
 * Usage
 

src/action.ml

@@ -11,6 +11,7 @@ module Mini_shexp = struct
     | Echo           of 'a
     | Cat            of 'a
     | Copy_and_add_line_directive of 'a * 'a
+    | System         of 'a
 
   let rec t a sexp =
     sum
@@ -25,6 +26,7 @@ module Mini_shexp = struct
           With_stdout_to (dst, Cat src))
       ; cstr "copy-and-add-line-directive" (a @> a @> nil) (fun src dst ->
           Copy_and_add_line_directive (src, dst))
+      ; cstr "system" (a @> nil) (fun cmd -> System cmd)
       ]
       sexp
 
@@ -38,6 +40,7 @@ module Mini_shexp = struct
     | Echo x -> Echo (f x)
     | Cat x -> Cat (f x)
     | Copy_and_add_line_directive (x, y) -> Copy_and_add_line_directive (f x, f y)
+    | System x -> System (f x)
 
   let rec fold t ~init:acc ~f =
     match t with
@@ -49,6 +52,7 @@ module Mini_shexp = struct
     | Echo x -> f acc x
     | Cat x -> f acc x
     | Copy_and_add_line_directive (x, y) -> f (f acc x) y
+    | System x -> f acc x
 
   let rec sexp_of_t f : _ -> Sexp.t = function
     | Run (a, xs) -> List (Atom "run" :: f a :: List.map xs ~f)
@@ -60,6 +64,7 @@ module Mini_shexp = struct
     | Cat x -> List [Atom "cat"; f x]
     | Copy_and_add_line_directive (x, y) ->
       List [Atom "copy-and-add-line-directive"; f x; f y]
+    | System x -> List [Atom "system"; f x]
 end
 
 module T = struct

src/build.ml

@@ -233,6 +233,15 @@ module Shexp = struct
           Printf.fprintf oc "# 1 %S\n" (Path.to_string fn);
           copy_channels ic oc));
       return ()
+    | System cmd ->
+      let path, arg, err =
+        Utils.system_shell ~needed_to:"interpret (system ...) actions"
+      in
+      match err with
+      | Some err -> err.fail ()
+      | None ->
+        exec ~dir ~env ~env_extra ~stdout_to ~tail
+          (Run (Path.to_string path, [arg; cmd]))
 
   and exec_list l ~dir ~env ~env_extra ~stdout_to ~tail =
     match l with

src/gen_rules.ml

@@ -282,6 +282,16 @@ module Gen(P : Params) = struct
     let bash ?dir ?stdout_to ?env ?extra_targets cmd =
       run (Dep (Path.absolute "/bin/bash")) ?dir ?stdout_to ?env ?extra_targets
         [ As ["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd] ]
+
+    let system ?dir ?stdout_to ?env ?extra_targets cmd ~needed_to =
+      let path, arg, fail = Utils.system_shell ~needed_to in
+      let build =
+        run (Dep path) ?dir ?stdout_to ?env ?extra_targets
+          [ As [arg; cmd] ]
+      in
+      match fail with
+      | None -> build
+      | Some fail -> Build.fail fail >>> build
   end
 
   module Alias = struct
@@ -622,12 +632,14 @@ module Gen(P : Params) = struct
       | No_preprocessing -> m
       | Command cmd ->
         pped_module m ~dir ~f:(fun _kind src dst ->
+          let dir = ctx.build_dir in
           add_rule
             (preprocessor_deps
              >>>
              Build.path src
              >>>
-             Build.bash ~stdout_to:dst ~dir
+             Build.system ~stdout_to:dst ~dir
+               ~needed_to:"run preprocessor commands"
                (sprintf "%s %s" (expand_vars ~dir cmd)
                   (Filename.quote (Path.reach src ~from:dir)))))
       | Pps { pps; flags } ->
@@ -1400,7 +1412,8 @@ module Gen(P : Params) = struct
       let src = Path.relative dir (name ^ ".mll"   ) in
       let dst = Path.relative dir (name ^ ".ml"    ) in
       add_rule
-        (Build.run (Dep ctx.ocamllex) [A "-q"; A "-o"; Target dst; Dep src]))
+        (Build.run ~dir:ctx.build_dir (Dep ctx.ocamllex)
+           [A "-q"; A "-o"; Target dst; Dep src]))
 
   let ocamlyacc_rules (conf : Ocamlyacc.t) ~dir =
     List.iter conf.names ~f:(fun name ->
@@ -1408,7 +1421,7 @@ module Gen(P : Params) = struct
       let dst  = Path.relative dir (name ^ ".ml"     ) in
       let dsti = Path.relative dir (name ^ ".mli"    ) in
       add_rule
-        (Build.run ~extra_targets:[dst; dsti]
+        (Build.run ~extra_targets:[dst; dsti] ~dir:ctx.build_dir
            (Dep ctx.ocamlyacc)
            [ Dep src ]))
 

src/utils.ml

@@ -0,0 +1,20 @@
+open Import
+
+let system_shell =
+  let cmd, arg, os =
+    if Sys.win32 then
+      ("cmd", "/c", "on Windows")
+    else
+      ("sh", "-c", "")
+  in
+  let bin = lazy (Bin.which cmd) in
+  fun ~needed_to ->
+    match Lazy.force bin with
+    | Some path -> (path, arg, None)
+    | None ->
+      (Path.absolute ("/" ^ cmd),
+       arg,
+       Some { fail = fun () ->
+         die "I need %s to %s but I couldn't find it :(\n\
+              Who doesn't have %s%s??!"
+           cmd needed_to cmd os })

src/utils.mli

@@ -0,0 +1,7 @@
+(** Utilities that can't go in [Import] *)
+
+open Import
+
+(** Return the absolute path to the shell, the argument to pass it (-c or /c) and a
+    failure in case the shell can't be found. *)
+val system_shell : needed_to:string -> Path.t * string * fail option