Configurable Unix system command

CHANGES.md

@@ -8,6 +8,8 @@ unreleased
       the upcoming `project-wide-occurrences` feature (#1596)
     - Construct bool-typed holes as `false` instead of `true` in the
       `construct` command, for consistency (#1599).
+    - Add a hook to configure system command for spawning ppxes when Merlin is
+      used as a library. (#1585)
   + test suite
     - Add missing dependency to a test using ppxlib (#1583)
 

src/ocaml/driver/pparse.ml

@@ -38,29 +38,29 @@ let report_error = function
     log ~title:"report_error"
       "External preprocessor does not produce a valid file. Command line: %s" cmd
 
-
-external windows_merlin_system_command : string -> cwd:string -> int = "ml_merlin_system_command"
-
-let merlin_system_command =
-  if Sys.win32 then
-    windows_merlin_system_command
-  else
-    fun cmd ~cwd ->
-      Sys.command (Printf.sprintf "cd %s && %s" (Filename.quote cwd) cmd)
-
-let ppx_commandline cmd fn_in fn_out =
-  Printf.sprintf "%s %s %s%s"
-    cmd (Filename.quote fn_in) (Filename.quote fn_out)
-    (if Sys.win32 then "" else " 1>&2")
+let commandline prog args =
+  Filename.quote_command prog args
 
 let apply_rewriter magic ppx (fn_in, failures) =
   let title = "apply_rewriter" in
   let fn_out = Filename.temp_file "camlppx" "" in
-  let comm = ppx_commandline ppx.workval fn_in fn_out in
+  let args = [fn_in; fn_out] in
+  let comm = commandline ppx.workval args in
   log ~title "running %s from directory %S" comm ppx.workdir;
   Logger.log_flush ();
+  let ok =
+    match
+      !System.run_in_directory
+        ~prog:ppx.workval
+        ~prog_is_quoted:true
+        ~args
+        ~cwd:ppx.workdir
+        ()
+    with
+    | `Finished 0 -> true
+    | `Finished _ | `Cancelled -> false
+  in
   let failure =
-    let ok = merlin_system_command comm ~cwd:ppx.workdir = 0 in
     if not ok then Some (CannotRun comm)
     else if not (Sys.file_exists fn_out) then
       Some (WrongMagic comm)
@@ -143,10 +143,6 @@ let apply_rewriters ~ppx ?restore ~tool_name = function
   | `Implementation ast ->
     `Implementation (apply_rewriters_str ~ppx ?restore ~tool_name ast)
 
-let pp_commandline cmd fn_in fn_out =
-  Printf.sprintf "%s %s 1>%s"
-    cmd (Filename.quote fn_in) (Filename.quote fn_out)
-
 (* FIXME: remove this once we drop support for 4.02 *)
 type ('a, 'b) res = Ok of 'a | Error of 'b
 
@@ -158,8 +154,21 @@ let apply_pp ~workdir ~filename ~source ~pp =
     close_out oc
   end;
   let fn_out = fn_in ^ ".out" in
-  let comm = pp_commandline pp fn_in fn_out in
-  let ok = merlin_system_command comm ~cwd:workdir = 0 in
+  let args = [fn_in] in
+  let comm = commandline pp args in
+  let ok =
+    match
+      !System.run_in_directory
+        ~prog:pp
+        ~prog_is_quoted:true
+        ~args
+        ~stdout:fn_out
+        ~cwd:workdir
+        ()
+    with
+    | `Finished 0 -> true
+    | `Finished _ | `Cancelled -> false
+  in
   Misc.remove_file fn_in;
   if not ok then begin
     Misc.remove_file fn_out;

src/utils/lib_config.ml

@@ -7,4 +7,9 @@ let program_name () = !program_name
 module Json = struct
   let set_pretty_to_string f =
     Std.Json.pretty_to_string := f
-end
+end
+
+module System = struct
+  let set_run_in_directory f =
+    Std.System.run_in_directory := f
+end

src/utils/lib_config.mli

@@ -15,3 +15,41 @@ module Json : sig
         is [Yojson.Basic.pretty_to_string].  *)
     val set_pretty_to_string : (Std.json -> string) -> unit
 end
+
+(** Merlin spawns child processes for preprocessors (pp and ppx), which can be
+    customized via [System] *)
+module System : sig
+  (** [set_run_in_directory] sets an implementation for spawning external
+        programs. This is used by Merlin to spawn preprocessors and ppxes. For
+        compatibility reasons, there are currently some limitations to how this
+        should be implemented:
+
+      - Implementation should expect [prog] to be already quoted and contain
+        arguments. This is due to how ppx configuration is passed to Merlin. In
+        order to prepare a future transition to more sane argument passing, the
+        implementation can look at the [prog_is_quoted] argument to know if it
+        is actually safe to quote the command normally (using
+        [Filename.quote_command] for example).
+
+      - [prog] might contain shell expansions, command substitutions etc. It
+        should therefore be ran under a shell for maximum compatibility. However
+        this should never happen when the configuration is generated by Dune.
+
+      - Programs runned by this function should never output on stdout since it
+        is the channel used by Merlin to communicate with the editor. One way to
+        enforce that is to redirect stdout to stderr.
+
+      - As of today Merlin handles the [`Cancelled] return case identically as
+        other error codes. *)
+  val set_run_in_directory
+    : (prog:string
+    -> prog_is_quoted:bool
+    -> args:string list
+    -> cwd:string
+    -> ?stdin:string
+    -> ?stdout:string
+    -> ?stderr:string
+    -> unit
+    -> [ `Finished of int | `Cancelled ])
+    -> unit
+end

src/utils/std.ml

@@ -751,6 +751,43 @@ module Shell = struct
     List.rev !comps
 end
 
+module System = struct
+  external windows_merlin_system_command : string -> cwd:string -> int =
+    "ml_merlin_system_command"
+
+  let run_in_directory
+    : (prog:string
+    -> prog_is_quoted:bool
+    -> args:string list
+    -> cwd:string
+    -> ?stdin:string
+    -> ?stdout:string
+    -> ?stderr:string
+    -> unit
+    -> [ `Finished of int | `Cancelled ]) ref = ref @@
+    fun ~prog ~prog_is_quoted:_ ~args ~cwd ?stdin:_ ?stdout ?stderr:_ () ->
+      (* Currently we assume that [prog] is always quoted and might contain
+      arguments such as [-as-ppx]. This is due to the way Merlin gets its
+      configuration. Thus we cannot rely on [Filename.quote_command]. *)
+      let args = String.concat ~sep:" " @@ List.map ~f:Filename.quote args in
+      let args = match stdout with
+        | Some file -> Format.sprintf "%s 1>%s" args (Filename.quote file)
+        | None ->
+          (* Runned program should never output on stdout since it is the
+             channel used by Merlin to communicate with the editor *)
+          if Sys.win32 then args else Format.sprintf "%s 1>&2" args
+      in
+      let cmd = Format.sprintf "%s %s" prog args in
+      let exit_code =
+        if Sys.win32 then
+          (* Note: the following function will never output to stdout *)
+          windows_merlin_system_command cmd ~cwd
+        else
+          Sys.command (Printf.sprintf "cd %s && %s" (Filename.quote cwd) cmd)
+      in
+      `Finished exit_code
+end
+
   (* [modules_in_path ~ext path] lists ocaml modules corresponding to
    * filenames with extension [ext] in given [path]es.
    * For instance, if there is file "a.ml","a.mli","b.ml" in ".":