Fix #657

CHANGES.md

@@ -32,6 +32,10 @@ next
   directories that include .odoc files, rather than the include flags of the
   libraries. (#652 fixes #651 @rgrinberg)
 
+- Fix a regression introduced by beta19 where the generated merlin
+  files didn't include the right `-ppx` flags in some cases (#658
+  fixess #657 @diml)
+
 1.0+beta19.1 (21/03/2018)
 -------------------------
 

src/jbuild.mli

@@ -47,6 +47,7 @@ module Pp : sig
   type t = private string
   val of_string : string -> t
   val to_string : t -> string
+  val compare : t -> t -> Ordering.t
 end
 
 module Preprocess : sig

src/merlin.ml

@@ -4,10 +4,37 @@ open! No_io
 
 module SC = Super_context
 
+module Preprocess = struct
+  type t =
+    | Pps of Jbuild.Preprocess.pps
+    | Other
+
+  let make : Jbuild.Preprocess.t -> t = function
+    | Pps pps -> Pps pps
+    | _       -> Other
+
+  let merge a b =
+    match a, b with
+    | Other, Other -> Other
+    | Pps _, Other -> a
+    | Other, Pps _ -> b
+    | Pps { pps = pps1; flags = flags1 },
+      Pps { pps = pps2; flags = flags2 } ->
+      match
+        match List.compare flags1 flags2 ~compare:String.compare with
+        | Eq ->
+          List.compare pps1 pps2 ~compare:(fun (_, a) (_, b) ->
+            Jbuild.Pp.compare a b)
+        | ne -> ne
+      with
+      | Eq -> a
+      | _  -> Other
+end
+
 type t =
   { requires   : (unit, Lib.t list) Build.t
   ; flags      : (unit, string list) Build.t
-  ; preprocess : Jbuild.Preprocess.t
+  ; preprocess : Preprocess.t
   ; libname    : string option
   ; source_dirs: Path.Set.t
   ; objs_dirs  : Path.Set.t
@@ -22,9 +49,9 @@ let make
       ?(objs_dirs=Path.Set.empty)
       () =
   (* Merlin shouldn't cause the build to fail, so we just ignore errors *)
-  { requires = Build.catch requires ~on_error:(fun _ -> [])
-  ; flags    = Build.catch flags    ~on_error:(fun _ -> [])
-  ; preprocess
+  { requires   = Build.catch requires ~on_error:(fun _ -> [])
+  ; flags      = Build.catch flags    ~on_error:(fun _ -> [])
+  ; preprocess = Preprocess.make preprocess
   ; libname
   ; source_dirs
   ; objs_dirs
@@ -46,7 +73,7 @@ let ppx_flags sctx ~dir:_ ~scope ~src_dir:_ { preprocess; libname; _ } =
       |> String.concat ~sep:" "
     in
     [sprintf "FLG -ppx %s" (Filename.quote command)]
-  | _ -> []
+  | Other -> []
 
 let dot_merlin sctx ~dir ~scope ({ requires; flags; _ } as t) =
   match Path.drop_build_context dir with
@@ -125,11 +152,7 @@ let merge_two a b =
        >>^ fun (x, y) ->
        Lib.L.remove_dups (x @ y))
   ; flags = a.flags &&& b.flags >>^ (fun (a, b) -> a @ b)
-  ; preprocess =
-      if a.preprocess = b.preprocess then
-        a.preprocess
-      else
-        No_preprocessing
+  ; preprocess = Preprocess.merge a.preprocess b.preprocess
   ; libname =
       (match a.libname with
        | Some _ as x -> x

src/stdune/list.ml

@@ -87,3 +87,13 @@ let sort t ~compare =
 
 let stable_sort t ~compare =
   stable_sort t ~cmp:(fun a b -> Ordering.to_int (compare a b))
+
+let rec compare a b ~compare:f : Ordering.t =
+  match a, b with
+  | [], [] -> Eq
+  | [], _ :: _ -> Lt
+  | _ :: _, [] -> Gt
+  | x :: a, y :: b ->
+    match (f x y : Ordering.t) with
+    | Eq -> compare a b ~compare:f
+    | ne -> ne

src/stdune/list.mli

@@ -34,3 +34,5 @@ val last : 'a t -> 'a option
 
 val        sort : 'a t -> compare:('a -> 'a -> Ordering.t) -> 'a t
 val stable_sort : 'a t -> compare:('a -> 'a -> Ordering.t) -> 'a t
+
+val compare : 'a t -> 'a t -> compare:('a -> 'a -> Ordering.t) -> Ordering.t

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

@@ -23,6 +23,7 @@
   B $LIB_PREFIX/lib/findlib
   B $LIB_PREFIX/lib/ocaml
   FLG -open Foo -w -40 -open Bar -w -40
+  FLG -ppx '$PPX/fooppx@/ppx.exe --as-ppx --cookie '\''library-name="foo"'\'''
   S .
   S $LIB_PREFIX/lib/bytes
   S $LIB_PREFIX/lib/findlib
@@ -31,4 +32,3 @@
 Make sure a ppx directive is generated
 
   $ grep -q ppx lib/.merlin
-  [1]