Fix generation of -pp in .merlin

First of all, we are going to be more strict and error out if we can't expand
any variables for the .merlin. If this happens, then it's really a bug that we
should catch.

The functions that swallow expansion errors are removed because they're too easy
to misuse.

Signed-off-by: Rudi Grinberg <rudi.grinberg@gmail.com>

CHANGES.md

@@ -51,6 +51,8 @@ unreleased
   create duplicates of the default context with different settings. (#2098,
   @TheLortex, review by @diml, @rgrinberg and @aalekseyev)
 
+- Fix generation of the `-pp` flag in .merlin (#2142, @rgrinberg)
+
 1.9.3 (06/05/2019)
 ------------------
 

src/dune_file.ml

@@ -325,6 +325,12 @@ module Preprocess = struct
          Future_syntax loc)
       ]
 
+  let loc = function
+    | No_preprocessing -> None
+    | Action (loc, _)
+    | Pps { loc; _ }
+    | Future_syntax loc -> Some loc
+
   let pps = function
     | Pps { pps; _ } -> pps
     | _ -> []

src/dune_file.mli

@@ -24,6 +24,8 @@ module Preprocess : sig
       | Pps    of pps
   end
 
+  val loc : t -> Loc.t option
+
   val remove_future_syntax : t -> Ocaml_version.t -> Without_future_syntax.t
 end
 

src/expander.ml

@@ -521,30 +521,3 @@ let expand_and_eval_set t set ~standard =
 let eval_blang t = function
   | Blang.Const x -> x (* common case *)
   | blang -> Blang.eval blang ~dir:t.dir ~f:(expand_var_exn t)
-
-module Option = struct
-  exception Not_found
-
-  let expand_var_exn t var syn =
-    t.expand_var t var syn
-    |> Option.map ~f:(function
-      | Ok s -> s
-      | Error _ -> raise_notrace Not_found)
-
-  let expand t ~mode ~template =
-    match
-      String_with_vars.expand ~dir:t.dir ~mode template
-        ~f:(expand_var_exn t)
-    with
-    | exception Not_found -> None
-    | s -> Some s
-
-  let expand_path t sw =
-    expand t ~mode:Single ~template:sw
-    |> Option.map ~f:(
-      Value.to_path ~error_loc:(String_with_vars.loc sw) ~dir:t.dir)
-
-  let expand_str t sw =
-    expand t ~mode:Single ~template:sw
-    |> Option.map ~f:(Value.to_string ~dir:t.dir)
-end

src/expander.mli

@@ -64,11 +64,6 @@ val expand_with_reduced_var_set
   :  context:Context.t
   -> reduced_var_result String_with_vars.expander
 
-module Option : sig
-  val expand_path : t -> String_with_vars.t -> Path.t option
-  val expand_str : t -> String_with_vars.t -> string option
-end
-
 module Resolved_forms : sig
   type t
 

src/lib_rules.ml

@@ -162,7 +162,7 @@ module Gen (P : sig val sctx : Super_context.t end) = struct
 
   let build_c_file (lib : Library.t) ~dir ~expander ~includes (loc, src, dst) =
     let src = C.Source.path src in
-    let c_flags = (SC.c_flags sctx ~dir ~expander ~lib).c in
+    let c_flags = (SC.c_flags sctx ~dir ~expander ~flags:lib.c_flags).c in
     SC.add_rule sctx ~loc ~dir
       (c_flags
        >>>
@@ -188,7 +188,7 @@ module Gen (P : sig val sctx : Super_context.t end) = struct
       else
         [A "-o"; Target dst]
     in
-    let cxx_flags = (SC.c_flags sctx ~dir ~expander ~lib).cxx in
+    let cxx_flags = (SC.c_flags sctx ~dir ~expander ~flags:lib.c_flags).cxx in
     SC.add_rule sctx ~loc ~dir
       (cxx_flags
        >>>

src/merlin.ml

@@ -18,10 +18,17 @@ module Preprocess = struct
   let merge ~allow_approx_merlin
         (a : Dune_file.Preprocess.t) (b : Dune_file.Preprocess.t) =
     match a, b with
-    (* the 2 cases below aren't entirely correct as it means that we have merlin
-       preprocess files that don't need to be preprocessed *)
+    | No_preprocessing, No_preprocessing ->
+      Dune_file.Preprocess.No_preprocessing
     | No_preprocessing, pp
-    | pp, No_preprocessing -> pp
+    | pp, No_preprocessing ->
+      let loc =
+        Dune_file.Preprocess.loc pp
+        |> Option.value_exn (* only No_preprocessing has no loc*)
+      in
+      warn_dropped_pp loc ~allow_approx_merlin
+        ~reason:"Cannot mix preprocessed and non preprocessed specificiations";
+      Dune_file.Preprocess.No_preprocessing
     | (Future_syntax _ as future_syntax), _
     | _, (Future_syntax _ as future_syntax) -> future_syntax
     | Action (loc, a1), Action (_, a2) ->
@@ -121,14 +128,65 @@ let make
 let add_source_dir t dir =
   { t with source_dirs = Path.Source.Set.add t.source_dirs dir }
 
-let pp_flags sctx ~expander ~dir_kind { preprocess; libname; _ } =
+let pp_flag_of_action sctx ~expander ~loc ~action
+  : (unit, string option) Build.t =
+  match (action : Action_dune_lang.t) with
+  | Run (exe, args) ->
+    let args =
+      let open Option.O in
+      let* (args, input_file) = List.destruct_last args in
+      if String_with_vars.is_var input_file ~name:"input-file" then
+        Some args
+      else
+        None
+    in
+    begin match args with
+    | None -> Build.return None
+    | Some args ->
+      let action : (Path.t Bindings.t, Action.t) Build.t =
+        let targets_dir = Expander.dir expander in
+        let targets = Expander.Targets.Forbidden "preprocessing actions" in
+        let action = Preprocessing.chdir (Run (exe, args)) in
+        Super_context.Action.run sctx
+          ~loc
+          ~expander
+          ~dep_kind:Optional
+          ~targets
+          ~targets_dir
+          action
+      in
+      let pp_of_action exe args =
+        match exe with
+        | Error _ -> None
+        | Ok exe ->
+          (Path.to_absolute_filename exe :: args)
+          |> List.map ~f:quote_for_merlin
+          |> String.concat ~sep:" "
+          |> Filename.quote
+          |> sprintf "FLG -pp %s"
+          |> Option.some
+      in
+      Build.return Bindings.empty
+      >>>
+      action
+      >>^ begin function
+      | Run (exe, args) -> pp_of_action exe args
+      | Chdir (_, Run (exe, args)) -> pp_of_action exe args
+      | Chdir (_, Chdir (_, Run (exe, args))) -> pp_of_action exe args
+      | _ -> None
+      end
+    end
+  | _ -> Build.return None
+
+let pp_flags sctx ~expander ~dir_kind { preprocess; libname; _ }
+  : (unit, string option) Build.t =
   let scope = Expander.scope expander in
   match Dune_file.Preprocess.remove_future_syntax preprocess
           (Super_context.context sctx).version
   with
   | Pps { loc = _; pps; flags; staged = _ } -> begin
     match Preprocessing.get_ppx_driver sctx ~scope ~dir_kind pps with
-    | Error _ -> None
+    | Error _ -> Build.return None
     | Ok exe ->
       let flags = List.map ~f:(Expander.expand_str expander) flags in
       (Path.to_absolute_filename exe
@@ -140,33 +198,12 @@ let pp_flags sctx ~expander ~dir_kind { preprocess; libname; _ } =
       |> Filename.quote
       |> sprintf "FLG -ppx %s"
       |> Option.some
+      |> Build.return
   end
-  | Action (_, (action : Action_dune_lang.t)) ->
-    begin match action with
-    | Run (exe, args) ->
-      let open Option.O in
-      let* (args, input_file) = List.destruct_last args in
-      let* args =
-        if String_with_vars.is_var input_file ~name:"input-file" then
-          Some args
-        else
-          None
-      in
-      let* exe = Expander.Option.expand_path expander exe in
-      let* args =
-        List.map ~f:(Expander.Option.expand_str expander) args
-        |> Option.List.all
-      in
-      (Path.to_absolute_filename exe :: args)
-      |> List.map ~f:quote_for_merlin
-      |> String.concat ~sep:" "
-      |> Filename.quote
-      |> sprintf "FLG -pp %s"
-      |> Option.some
-    | _ -> None
-    end
+  | Action (loc, (action : Action_dune_lang.t)) ->
+    pp_flag_of_action sctx ~expander ~loc ~action
   | No_preprocessing ->
-    None
+    Build.return None
 
 let dot_merlin sctx ~dir ~more_src_dirs ~expander ~dir_kind
       ({ requires; flags; _ } as t) =
@@ -188,14 +225,15 @@ let dot_merlin sctx ~dir ~more_src_dirs ~expander ~dir_kind
        Build.create_file (Path.relative dir ".merlin-exists"));
     Path.Set.singleton merlin_file
     |> Build_system.Alias.add_deps (Alias.check ~dir);
+    let pp_flags = pp_flags sctx ~expander ~dir_kind t in
     SC.add_rule sctx ~dir
       ~mode:(Promote
                { lifetime = Until_clean
                ; into = None
                ; only = None
                }) (
-      flags
-      >>^ (fun flags ->
+      flags &&& pp_flags
+      >>^ (fun (flags, pp) ->
         let (src_dirs, obj_dirs) =
           Lib.Set.fold requires ~init:(
             (Path.Source.Set.to_list t.source_dirs
@@ -216,7 +254,7 @@ let dot_merlin sctx ~dir ~more_src_dirs ~expander ~dir_kind
         in
         Dot_file.to_string
           ~remaindir
-          ~pp:(pp_flags sctx ~expander ~dir_kind t)
+          ~pp
           ~flags
           ~src_dirs
           ~obj_dirs)

src/preprocessing.ml

@@ -533,8 +533,10 @@ let promote_correction fn build ~suffix =
            (Path.extend_basename fn ~suffix))
     ]
 
+let chdir action = Action_unexpanded.Chdir (workspace_root_var, action)
+
 let action_for_pp sctx ~dep_kind ~loc ~expander ~action ~src ~target =
-  let action = Action_unexpanded.Chdir (workspace_root_var, action) in
+  let action = chdir action in
   let bindings = Pform.Map.input_file src in
   let expander = Expander.add_bindings expander ~bindings in
   let targets = Expander.Targets.Forbidden "preprocessing actions" in

src/preprocessing.mli

@@ -66,3 +66,5 @@ val get_compat_ppx_exe
 val cookie_library_name : Lib_name.Local.t option -> string list
 
 val gen_rules : Super_context.t -> string list -> unit
+
+val chdir : Action_unexpanded.t -> Action_unexpanded.t

src/super_context.ml

@@ -271,10 +271,9 @@ let ocaml_flags t ~dir (x : Dune_file.Buildable.t) =
     ~default:(Env.ocaml_flags t ~dir)
     ~eval:(Expander.expand_and_eval_set expander)
 
-let c_flags t ~dir ~expander ~(lib : Dune_file.Library.t) =
+let c_flags t ~dir ~expander ~flags =
   let t = t.env_context in
   let ccg = Context.cc_g t.context in
-  let flags = lib.c_flags in
   let default = Env.c_flags t ~dir in
   C.Kind.Dict.mapi flags ~f:(fun ~kind flags ->
     let name = C.Kind.to_string kind in

src/super_context.mli

@@ -60,7 +60,7 @@ val c_flags
   :  t
   -> dir:Path.t
   -> expander:Expander.t
-  -> lib:Library.t
+  -> flags:Ordered_set_lang.Unexpanded.t C.Kind.Dict.t
   -> (unit, string list) Build.t C.Kind.Dict.t
 
 (** Binaries that are symlinked in the associated .bin directory of [dir]. This
@@ -182,6 +182,8 @@ module Pkg_version : sig
     -> Package.t
     -> (unit, string option) Build.t
     -> (unit, string option) Build.t
+
+  val read : t -> Package.t -> (unit, string option) Build.t
 end
 
 module Scope_key : sig

test/blackbox-tests/test-cases/dune-ppx-driver-system/run.t

@@ -112,6 +112,11 @@ Test using installed drivers
 
   $ OCAMLPATH=driver/_build/install/default/lib dune build --root replaces driveruser.cma
   Entering directory 'replaces'
+  File "dune", line 13, characters 13-57:
+  13 |  (preprocess (pps -arg1 replacesdriver -arg2 -- -foo bar)))
+                    ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+  Warning: .merlin generated is inaccurate. Cannot mix preprocessed and non preprocessed specificiations.
+  Split the stanzas into different directories or silence this warning by adding (allow_approximate_merlin) to your dune-project.
            ppx driveruser.pp.ml
   replacesdriver
   .ppx/97c3bec0ca445d915914eed462990a46/ppx.exe

test/blackbox-tests/test-cases/external-lib-deps/run.t

@@ -1,6 +1,11 @@
 Expected: a, b, ..., j (required) and optional (optional)
 
   $ dune external-lib-deps @all
+  File "dune", line 5, characters 13-24:
+  5 |  (preprocess (pps d e f)))
+                   ^^^^^^^^^^^
+  Warning: .merlin generated is inaccurate. Cannot mix preprocessed and non preprocessed specificiations.
+  Split the stanzas into different directories or silence this warning by adding (allow_approximate_merlin) to your dune-project.
   These are the external library dependencies in the default context:
   - a
   - b

test/blackbox-tests/test-cases/merlin-tests/dune

@@ -2,3 +2,8 @@
  (name print-merlins)
  (deps lib/.merlin exe/.merlin)
  (action (run ./sanitize-dot-merlin/sanitize_dot_merlin.exe %{deps})))
+
+(alias
+ (name print-merlins-pp)
+ (deps pp-with-expand/.merlin)
+ (action (run ./sanitize-dot-merlin/sanitize_dot_merlin.exe %{deps})))

test/blackbox-tests/test-cases/merlin-tests/exe/dune

@@ -1,4 +1,4 @@
 (executable
  (name x)
- (preprocess (action (run ./foo-bar %{input-file})))
+ (preprocess (action (run pp/pp.exe %{input-file})))
  (libraries foo))

test/blackbox-tests/test-cases/merlin-tests/pp-with-expand/dune

@@ -0,0 +1,5 @@
+(rule (with-stdout-to dummy (echo "-nothing")))
+
+(executable
+ (name foobar)
+ (preprocess (action (run %{exe:../pp/pp.exe} %{read:dummy} %{input-file}))))

test/blackbox-tests/test-cases/merlin-tests/pp/dune

@@ -0,0 +1,2 @@
+(executable
+ (name pp))

test/blackbox-tests/test-cases/merlin-tests/run.t

@@ -1,4 +1,8 @@
   $ dune build @print-merlins --display short --profile release
+      ocamldep pp/.pp.eobjs/pp.ml.d
+        ocamlc pp/.pp.eobjs/byte/pp.{cmi,cmo,cmt}
+      ocamlopt pp/.pp.eobjs/native/pp.{cmx,o}
+      ocamlopt pp/pp.exe
       ocamldep sanitize-dot-merlin/.sanitize_dot_merlin.eobjs/sanitize_dot_merlin.ml.d
         ocamlc sanitize-dot-merlin/.sanitize_dot_merlin.eobjs/byte/sanitize_dot_merlin.{cmi,cmo,cmt}
       ocamlopt sanitize-dot-merlin/.sanitize_dot_merlin.eobjs/native/sanitize_dot_merlin.{cmx,o}
@@ -16,7 +20,7 @@
   S $LIB_PREFIX/lib/ocaml
   S .
   S ../lib
-  FLG -pp '$PP/_build/default/exe/foo-bar'
+  FLG -pp '$PP/_build/default/pp/pp.exe'
   FLG -w -40
   # Processing lib/.merlin
   EXCLUDE_QUERY_DIR
@@ -36,3 +40,14 @@ Make sure a ppx directive is generated
 
   $ grep -q ppx lib/.merlin
   [1]
+
+Make sure pp flag is correct and variables are expanded
+
+  $ dune build @print-merlins-pp
+  sanitize_dot_merlin alias print-merlins-pp
+  # Processing pp-with-expand/.merlin
+  EXCLUDE_QUERY_DIR
+  B ../_build/default/pp-with-expand/.foobar.eobjs/byte
+  S .
+  FLG -pp '$PP/_build/default/pp/pp.exe -nothing'
+  FLG -w @a-4-29-40-41-42-44-45-48-58-59-60-40 -strict-sequence -strict-formats -short-paths -keep-locs

test/blackbox-tests/test-cases/meta-gen/run.t

@@ -1,4 +1,9 @@
   $ dune runtest --force --display short
+  File "dune", line 42, characters 13-34:
+  42 |  (preprocess (pps foobar_rewriter)))
+                    ^^^^^^^^^^^^^^^^^^^^^
+  Warning: .merlin generated is inaccurate. Cannot mix preprocessed and non preprocessed specificiations.
+  Split the stanzas into different directories or silence this warning by adding (allow_approximate_merlin) to your dune-project.
   description = "contains \"quotes\""
   requires = "bytes"
   archive(byte) = "foobar.cma"

test/blackbox-tests/test-cases/multi-dir/run.t

@@ -59,6 +59,11 @@ Test for (include_subdir unqualified) with (preprocess (action ...))
 
   $ dune build --display short --root test4 @all
   Entering directory 'test4'
+  File "dune", line 7, characters 21-51:
+  7 |  (preprocess (action (run ./main.exe %{input-file})))
+                           ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+  Warning: .merlin generated is inaccurate. Cannot mix preprocessed and non preprocessed specificiations.
+  Split the stanzas into different directories or silence this warning by adding (allow_approximate_merlin) to your dune-project.
       ocamldep .main.eobjs/main.ml.d
         ocamlc .main.eobjs/byte/main.{cmi,cmo,cmt}
       ocamlopt .main.eobjs/native/main.{cmx,o}