From 896898f1bd22e0b48cf8cfe7d96a3dae9dff3960 Mon Sep 17 00:00:00 2001
From: Rudi Grinberg <rudi.grinberg@gmail.com>
Date: Tue, 28 May 2019 18:18:01 +0700
Subject: [PATCH] Fix generation of merlin with equal ppx pp

Previously, if the pps were all ppx and equivalent, then they would
be dropped.

Fix #2206

Signed-off-by: Rudi Grinberg <rudi.grinberg@gmail.com>
---
 CHANGES.md                                    |  3 ++
 src/dune_file.ml                              | 32 ++++++++++++++-----
 src/dune_file.mli                             | 20 +++++++-----
 src/merlin.ml                                 | 20 ++++++------
 .../test-cases/merlin-tests/run.t             |  2 +-
 5 files changed, 50 insertions(+), 27 deletions(-)

diff --git a/CHANGES.md b/CHANGES.md
index e7feba4e866..3f18b12224b 100644
--- a/CHANGES.md
+++ b/CHANGES.md
@@ -84,6 +84,9 @@ unreleased
   would be undetected whenever the project was nested in another workspace.
   (#2194, @rgrinberg)
 
+- Fix generation of `.merlin` whenever there's more than one stanza with the
+  same ppx preprocessing specification (#2209 ,fixes #2206, @rgrinberg)
+
 1.9.3 (06/05/2019)
 ------------------
 
diff --git a/src/dune_file.ml b/src/dune_file.ml
index 3e24293db99..e5f2378c484 100644
--- a/src/dune_file.ml
+++ b/src/dune_file.ml
@@ -291,16 +291,32 @@ module Dep_conf = struct
 end
 
 module Preprocess = struct
-  type pps =
-    { loc : Loc.t
-    ; pps : (Loc.t * Lib_name.t) list
-    ; flags : String_with_vars.t list
-    ; staged : bool
-    }
+  module Pps = struct
+    type t =
+      { loc : Loc.t
+      ; pps : (Loc.t * Lib_name.t) list
+      ; flags : String_with_vars.t list
+      ; staged : bool
+      }
+
+    let compare_no_locs { loc = _ ; pps = pps1; flags = flags1; staged = s1 }
+          { loc = _; pps = pps2; flags = flags2; staged = s2 } =
+      match Bool.compare s1 s2 with
+      | Lt | Gt as t -> t
+      | Eq ->
+        match
+          List.compare flags1 flags2 ~compare:String_with_vars.compare_no_loc
+        with
+        | Lt | Gt as t -> t
+        | Eq ->
+          List.compare pps1 pps2 ~compare:(fun (_, x) (_, y) ->
+            Lib_name.compare x y)
+  end
+
   type t =
     | No_preprocessing
     | Action of Loc.t * Action_dune_lang.t
-    | Pps    of pps
+    | Pps    of Pps.t
     | Future_syntax of Loc.t
 
   let decode =
@@ -339,7 +355,7 @@ module Preprocess = struct
     type t =
       | No_preprocessing
       | Action of Loc.t * Action_dune_lang.t
-      | Pps    of pps
+      | Pps    of Pps.t
   end
 
   let remove_future_syntax t v : Without_future_syntax.t =
diff --git a/src/dune_file.mli b/src/dune_file.mli
index fb4b8969ef4..4a5c7ef4054 100644
--- a/src/dune_file.mli
+++ b/src/dune_file.mli
@@ -4,24 +4,28 @@ open! Stdune
 open Import
 
 module Preprocess : sig
-  type pps =
-    { loc   : Loc.t
-    ; pps   : (Loc.t * Lib_name.t) list
-    ; flags : String_with_vars.t list
-    ; staged : bool
-    }
+  module Pps : sig
+    type t =
+      { loc   : Loc.t
+      ; pps   : (Loc.t * Lib_name.t) list
+      ; flags : String_with_vars.t list
+      ; staged : bool
+      }
+
+    val compare_no_locs : t -> t -> Ordering.t
+  end
 
   type t =
     | No_preprocessing
     | Action of Loc.t * Action_dune_lang.t
-    | Pps    of pps
+    | Pps    of Pps.t
     | Future_syntax of Loc.t
 
   module Without_future_syntax : sig
     type t =
       | No_preprocessing
       | Action of Loc.t * Action_dune_lang.t
-      | Pps    of pps
+      | Pps    of Pps.t
   end
 
   val loc : t -> Loc.t option
diff --git a/src/merlin.ml b/src/merlin.ml
index 378464719be..f92cac49316 100644
--- a/src/merlin.ml
+++ b/src/merlin.ml
@@ -42,16 +42,15 @@ module Preprocess = struct
       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 } ->
-      if Bool.(<>) s1 s2
-      || List.compare flags1 flags2 ~compare:String_with_vars.compare_no_loc <> Eq
-      || List.compare pps1 pps2 ~compare:(fun (_, x) (_, y) ->
-        Lib_name.compare x y) <> Eq
-      then
-        warn_dropped_pp loc ~allow_approx_merlin
+    | Pps pp1 as pp, Pps pp2 ->
+      if Ordering.neq (Dune_file.Preprocess.Pps.compare_no_locs pp1 pp2)
+      then begin
+        warn_dropped_pp pp1.loc ~allow_approx_merlin
           ~reason:"pps specification isn't identical in all stanzas";
-      No_preprocessing
+        No_preprocessing
+      end
+      else
+        pp
 end
 
 let quote_for_merlin s =
@@ -188,7 +187,8 @@ let pp_flags sctx ~expander ~dir_kind { preprocess; libname; _ }
     match Preprocessing.get_ppx_driver sctx ~loc ~expander ~lib_name:libname
             ~flags ~scope ~dir_kind pps
     with
-    | Error _ -> Build.return None
+    | Error _exn ->
+      Build.return None
     | Ok (exe, flags) ->
       (Path.to_absolute_filename (Path.build exe)
        :: "--as-ppx" :: flags)
diff --git a/test/blackbox-tests/test-cases/merlin-tests/run.t b/test/blackbox-tests/test-cases/merlin-tests/run.t
index 5cad485c0fd..3c7733511cd 100644
--- a/test/blackbox-tests/test-cases/merlin-tests/run.t
+++ b/test/blackbox-tests/test-cases/merlin-tests/run.t
@@ -34,12 +34,12 @@
   S $LIB_PREFIX/lib/ocaml
   S .
   S subdir
+  FLG -ppx '$PPX/fcfe04ecb8bb41c1143a3b9acec18678/ppx.exe --as-ppx --cookie '\''library-name="foo"'\'''
   FLG -open Foo -w -40 -open Bar -w -40
 
 Make sure a ppx directive is generated
 
   $ grep -q ppx lib/.merlin
-  [1]
 
 Make sure pp flag is correct and variables are expanded