Over approximate ppx in .merlin

CHANGES.md

@@ -1,3 +1,11 @@
+unreleased
+----------
+
+- Warn when generated `.merlin` does not reflect the preprocessing
+  specification. This occurs when multiple stanzas in the same directory use
+  different preprocessing specifications. This warning can now be disabled with
+  `allow_approx_merlin` (#1947, fix #1946, @rgrinberg)
+
 1.8.2 (10/03/2019)
 ------------------
 

src/action_dune_lang.ml

@@ -22,6 +22,15 @@ let upgrade_to_dune =
 
 let encode_and_upgrade a = encode (upgrade_to_dune a)
 
+let remove_locs =
+  let dir = String_with_vars.make_text Loc.none "" in
+  let f_program ~dir:_ = String_with_vars.remove_locs in
+  let f_path ~dir:_ = String_with_vars.remove_locs in
+  let f_string ~dir:_ = String_with_vars.remove_locs in
+  Mapper.map ~dir ~f_program ~f_path ~f_string
+
+let compare_no_locs t1 t2 = compare (remove_locs t1) (remove_locs t2)
+
 open Dune_lang.Decoder
 let decode =
   if_list

src/action_dune_lang.mli

@@ -1,3 +1,5 @@
+open Stdune
+
 (* This module is to be used in Dune_file. It should not introduce any
     dependencies unless they're already dependencies of Dune_file *)
 include Action_intf.Ast
@@ -14,3 +16,5 @@ include Action_intf.Helpers
   type program = String_with_vars.t and
   type string = String_with_vars.t and
   type path = String_with_vars.t
+
+val compare_no_locs : t -> t -> Ordering.t

src/dune_project.ml

@@ -166,6 +166,7 @@ type t =
   ; parsing_context : Univ_map.t
   ; implicit_transitive_deps : bool
   ; dune_version    : Syntax.Version.t
+  ; allow_approx_merlin : bool
   }
 
 let packages t = t.packages
@@ -175,10 +176,12 @@ let root t = t.root
 let stanza_parser t = t.stanza_parser
 let file t = t.project_file.file
 let implicit_transitive_deps t = t.implicit_transitive_deps
+let allow_approx_merlin t = t.allow_approx_merlin
 
 let pp fmt { name ; root ; version ; project_file ; parsing_context = _
            ; extension_args = _; stanza_parser = _ ; packages
-           ; implicit_transitive_deps ; dune_version } =
+           ; implicit_transitive_deps ; dune_version
+           ; allow_approx_merlin } =
   Fmt.record fmt
     [ "name", Fmt.const Name.pp name
     ; "root", Fmt.const Path.Local.pp root
@@ -191,6 +194,8 @@ let pp fmt { name ; root ; version ; project_file ; parsing_context = _
     ; "implicit_transitive_deps",
       Fmt.const Format.pp_print_bool implicit_transitive_deps
     ; "dune_version", Fmt.const Syntax.Version.pp dune_version
+    ; "allow_approx_merlin"
+    , Fmt.const Format.pp_print_bool allow_approx_merlin
     ]
 
 let find_extension_args t key =
@@ -424,7 +429,8 @@ let key =
   Univ_map.Key.create ~name:"dune-project"
     (fun { name; root; version; project_file
          ; stanza_parser = _; packages = _ ; extension_args = _
-         ; parsing_context ; implicit_transitive_deps ; dune_version } ->
+         ; parsing_context ; implicit_transitive_deps ; dune_version
+         ; allow_approx_merlin } ->
       Sexp.Encoder.record
         [ "name", Name.to_sexp name
         ; "root", Path.Local.to_sexp root
@@ -433,6 +439,8 @@ let key =
         ; "parsing_context", Univ_map.to_sexp parsing_context
         ; "implicit_transitive_deps", Sexp.Encoder.bool implicit_transitive_deps
         ; "dune_version", Syntax.Version.to_sexp dune_version
+        ; "allow_approx_merlin"
+        , Sexp.Encoder.bool allow_approx_merlin
         ])
 
 let set t = Dune_lang.Decoder.set key t
@@ -473,6 +481,7 @@ let anonymous = lazy (
   ; extension_args
   ; parsing_context
   ; dune_version = lang.version
+  ; allow_approx_merlin = true
   })
 
 let default_name ~dir ~packages =
@@ -518,6 +527,9 @@ let parse ~dir ~lang ~packages ~file =
      and+ implicit_transitive_deps =
        field_o_b "implicit_transitive_deps"
          ~check:(Syntax.since Stanza.syntax (1, 7))
+     and+ allow_approx_merlin =
+       field_o_b "allow_approximate_merlin"
+         ~check:(Syntax.since Stanza.syntax (1, 9))
      and+ () = Versioned_file.no_more_lang
      in
      let project_file : Project_file.t =
@@ -532,6 +544,8 @@ let parse ~dir ~lang ~packages ~file =
      let implicit_transitive_deps =
        Option.value implicit_transitive_deps ~default:true
      in
+     let allow_approx_merlin =
+       Option.value ~default:false allow_approx_merlin in
      { name
      ; root = get_local_path dir
      ; version
@@ -542,6 +556,7 @@ let parse ~dir ~lang ~packages ~file =
      ; parsing_context
      ; implicit_transitive_deps
      ; dune_version = lang.version
+     ; allow_approx_merlin
      })
 
 let load_dune_project ~dir packages =
@@ -571,6 +586,7 @@ let make_jbuilder_project ~dir packages =
   ; parsing_context
   ; implicit_transitive_deps = true
   ; dune_version = lang.version
+  ; allow_approx_merlin = true
   }
 
 let read_name file =

src/dune_project.mli

@@ -45,6 +45,7 @@ val version : t -> string option
 val name : t -> Name.t
 val root : t -> Path.Local.t
 val stanza_parser : t -> Stanza.t list Dune_lang.Decoder.t
+val allow_approx_merlin : t -> bool
 
 (** Return the path of the project file. *)
 val file : t -> Path.t

src/gen_rules.ml

@@ -146,13 +146,17 @@ module Gen(P : Install_rules.Params) = struct
               ~f:(fun acc a -> For_stanza.cons acc (for_stanza a))
             |> For_stanza.rev
     in
-    Option.iter (Merlin.merge_all merlins) ~f:(fun m ->
-      let more_src_dirs =
-        List.map (Dir_contents.dirs dir_contents) ~f:(fun dc ->
-          Path.drop_optional_build_context (Dir_contents.dir dc))
-      in
-      Merlin.add_rules sctx ~dir:ctx_dir ~more_src_dirs ~expander ~dir_kind
-        (Merlin.add_source_dir m src_dir));
+    let allow_approx_merlin =
+      let dune_project = Scope.project scope in
+      Dune_project.allow_approx_merlin dune_project in
+    Option.iter (Merlin.merge_all ~allow_approx_merlin merlins)
+      ~f:(fun m ->
+        let more_src_dirs =
+          List.map (Dir_contents.dirs dir_contents) ~f:(fun dc ->
+            Path.drop_optional_build_context (Dir_contents.dir dc))
+        in
+        Merlin.add_rules sctx ~dir:ctx_dir ~more_src_dirs ~expander ~dir_kind
+          (Merlin.add_source_dir m src_dir));
     List.iter stanzas ~f:(fun stanza ->
       match (stanza : Stanza.t) with
       | Menhir.T m when Expander.eval_blang expander m.enabled_if ->

src/merlin.ml

@@ -5,29 +5,46 @@ open! No_io
 
 module SC = Super_context
 
+let warn_dropped_pp loc ~allow_approx_merlin ~reason =
+  if not allow_approx_merlin then
+    Errors.warn loc
+      ".merlin generated is inaccurate. %s.\n\
+        Split the stanzas into different directories or silence this warning \
+        by adding (allow_approximate_merlin) to your dune-project."
+      reason
+
 module Preprocess = struct
-  let merge (a : Dune_file.Preprocess.t) (b : Dune_file.Preprocess.t) =
+
+  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, pp
     | pp, No_preprocessing -> pp
-    | (Action _ as action), _
-    | _, (Action _ as action) -> action
     | (Future_syntax _ as future_syntax), _
     | _, (Future_syntax _ as future_syntax) -> future_syntax
-    | Pps { loc = _; pps = pps1; flags = flags1; staged = s1 },
+    | Action (loc, a1), Action (_, a2) ->
+      if Action_dune_lang.compare_no_locs a1 a2 <> Ordering.Eq then
+        warn_dropped_pp loc ~allow_approx_merlin
+          ~reason:"this action preprocessor is not equivalent to other \
+                   preproocessor specifications.";
+      Action (loc, a1)
+    | Pps _, Action (loc, _)
+    | Action (loc, _), Pps _ ->
+      warn_dropped_pp loc ~allow_approx_merlin
+        ~reason:"cannot mix action and pps preprocessors";
+      No_preprocessing
+    | Pps { loc ; pps = pps1; flags = flags1; staged = s1 },
       Pps { loc = _; pps = pps2; flags = flags2; staged = s2 } ->
-      match
-        match Bool.compare s1 s2 with
-        | Gt| Lt as ne -> ne
-        | Eq ->
-          match List.compare flags1 flags2 ~compare:String.compare with
-          | Gt | Lt as ne -> ne
-          | Eq ->
-            List.compare pps1 pps2 ~compare:(fun (_, a) (_, b) ->
-              Lib_name.compare a b)
-      with
-      | Eq -> a
-      | _  -> No_preprocessing
+      if Bool.(<>) s1 s2
+      || List.compare flags1 flags2 ~compare:String.compare <> Eq
+      || List.compare pps1 pps2 ~compare:(fun (_, x) (_, y) ->
+        Lib_name.compare x y) <> Eq
+      then
+        warn_dropped_pp loc ~allow_approx_merlin
+          ~reason:"pps specification isn't identical in all stanzas";
+      No_preprocessing
 end
 
 let quote_for_merlin s =
@@ -193,10 +210,10 @@ let dot_merlin sctx ~dir ~more_src_dirs ~expander ~dir_kind
       >>>
       Build.write_file_dyn merlin_file)
 
-let merge_two a b =
+let merge_two ~allow_approx_merlin a b =
   { requires = Lib.Set.union a.requires b.requires
   ; flags = a.flags &&& b.flags >>^ (fun (a, b) -> a @ b)
-  ; preprocess = Preprocess.merge a.preprocess b.preprocess
+  ; preprocess = Preprocess.merge ~allow_approx_merlin a.preprocess b.preprocess
   ; libname =
       (match a.libname with
        | Some _ as x -> x
@@ -205,9 +222,10 @@ let merge_two a b =
   ; objs_dirs = Path.Set.union a.objs_dirs b.objs_dirs
   }
 
-let merge_all = function
+let merge_all ~allow_approx_merlin = function
   | [] -> None
-  | init::ts -> Some (List.fold_left ~init ~f:merge_two ts)
+  | init :: ts ->
+    Some (List.fold_left ~init ~f:(merge_two ~allow_approx_merlin) ts)
 
 let add_rules sctx ~dir ~more_src_dirs ~expander ~dir_kind merlin =
   if (SC.context sctx).merlin then

src/merlin.mli

@@ -17,7 +17,7 @@ val make
 
 val add_source_dir : t -> Path.t -> t
 
-val merge_all : t list -> t option
+val merge_all : allow_approx_merlin:bool -> t list -> t option
 
 (** Add rules for generating the .merlin in a directory *)
 val add_rules

src/stanza.ml

@@ -9,7 +9,7 @@ end
 let syntax =
   Syntax.create ~name:"dune" ~desc:"the dune language"
     [ (0, 0) (* Jbuild syntax *)
-    ; (1, 8)
+    ; (1, 9)
     ]
 
 module File_kind = struct

src/stdune/bool.ml

@@ -1,12 +1,15 @@
-type t = bool
-
 let compare x y =
   match x, y with
   | true, true
   | false, false -> Ordering.Eq
   | true, false -> Gt
   | false, true -> Lt
 
+include Comparable.Operators(struct
+    type nonrec t = bool
+    let compare = compare
+  end)
+
 let to_string = string_of_bool
 
 let of_string s = Option.try_with (fun () -> bool_of_string s)

src/stdune/bool.mli

@@ -2,6 +2,8 @@ type t = bool
 
 val compare : t -> t -> Ordering.t
 
+include Comparable.OPS with type t := t
+
 val to_string : t -> string
 
 val of_string : string -> t option

src/stdune/comparable.ml

@@ -11,6 +11,7 @@ module type OPS = sig
   val (>) : t -> t -> bool
   val (<=) : t -> t -> bool
   val (<) : t -> t -> bool
+  val (<>) : t -> t -> bool
 end
 
 module Operators (X : S) = struct
@@ -22,6 +23,7 @@ module Operators (X : S) = struct
     | Gt | Lt -> false
 
   let equal = (=)
+  let (<>) a b = not (a = b)
 
   let (>=) a b =
     match X.compare a b with

src/stdune/comparable.mli

@@ -11,6 +11,7 @@ module type OPS = sig
   val (>) : t -> t -> bool
   val (<=) : t -> t -> bool
   val (<) : t -> t -> bool
+  val (<>) : t -> t -> bool
 end
 
 module Operators (X : S) : OPS with type t = X.t

src/stdune/loc.ml

@@ -40,6 +40,14 @@ let sexp_of_position_no_file (p : Lexing.position) =
     ; "pos_cnum", int p.pos_cnum
     ]
 
+let dyn_of_position_no_file (p : Lexing.position) =
+  let open Dyn in
+  Record
+    [ "pos_lnum", Int p.pos_lnum
+    ; "pos_bol", Int p.pos_bol
+    ; "pos_cnum", Int p.pos_cnum
+    ]
+
 let to_sexp t =
   let open Sexp.Encoder in
   record (* TODO handle when pos_fname differs *)
@@ -48,6 +56,14 @@ let to_sexp t =
     ; "stop", sexp_of_position_no_file t.stop
     ]
 
+let to_dyn t =
+  let open Dyn in
+  Record
+    [ "pos_fname", String t.start.pos_fname
+    ; "start", dyn_of_position_no_file t.start
+    ; "stop", dyn_of_position_no_file t.stop
+    ]
+
 let equal_position
       { Lexing.pos_fname = f_a; pos_lnum = l_a
       ; pos_bol = b_a; pos_cnum = c_a }

src/stdune/loc.mli

@@ -14,6 +14,8 @@ val of_lexbuf : Lexing.lexbuf -> t
 
 val to_sexp : t -> Sexp.t
 
+val to_dyn : t -> Dyn.t
+
 val sexp_of_position_no_file : Lexing.position -> Sexp.t
 
 val equal : t -> t -> bool

test/blackbox-tests/dune.inc

@@ -555,6 +555,14 @@
    test-cases/github1856
    (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected)))))
 
+(alias
+ (name github1946)
+ (deps (package dune) (source_tree test-cases/github1946))
+ (action
+  (chdir
+   test-cases/github1946
+   (progn (run %{exe:cram.exe} -test run.t) (diff? run.t run.t.corrected)))))
+
 (alias
  (name github20)
  (deps (package dune) (source_tree test-cases/github20))
@@ -1383,6 +1391,7 @@
   (alias github1616)
   (alias github1811)
   (alias github1856)
+  (alias github1946)
   (alias github20)
   (alias github24)
   (alias github25)
@@ -1540,6 +1549,7 @@
   (alias github1616)
   (alias github1811)
   (alias github1856)
+  (alias github1946)
   (alias github20)
   (alias github24)
   (alias github25)