.merlin: add a SUFFIX directive for each dialect

Signed-off-by: Jérôme Vouillon <[email protected]>

src/dune_engine/dialect.ml

@@ -186,6 +186,8 @@ module DB = struct
         (dialect, kind))
       (String.Map.find by_extension extension)
 
+  let fold { by_name; _ } = String.Map.fold by_name
+
   let to_dyn { by_name; _ } = String.Map.to_dyn to_dyn by_name
 
   let builtin = of_list [ ocaml; reason ]

src/dune_engine/dialect.mli

@@ -51,6 +51,8 @@ module DB : sig
 
   val find_by_extension : t -> string -> (dialect * Ml_kind.t) option
 
+  val fold : t -> init:'a -> f:(dialect -> 'a -> 'a) -> 'a
+
   val to_dyn : t -> Dyn.t
 
   val builtin : t

src/dune_rules/exe_rules.ml

@@ -182,7 +182,8 @@ let executables_rules ~sctx ~dir ~expander ~dir_contents ~scope ~compile_info
   ( cctx
   , Merlin.make () ~requires:requires_compile ~flags ~modules
       ~preprocess:(Preprocess.Per_module.single_preprocess preprocess)
-      ~obj_dir )
+      ~obj_dir
+      ~dialects:(Dune_project.dialects (Scope.project scope)) )
 
 let compile_info ~scope (exes : Dune_file.Executables.t) =
   let dune_version = Scope.project scope |> Dune_project.dune_version in

src/dune_rules/lib_rules.ml

@@ -422,7 +422,8 @@ let library_rules (lib : Library.t) ~cctx ~source_modules ~dir_contents
   ( cctx
   , Merlin.make () ~requires:requires_compile ~flags ~modules
       ~preprocess:(Preprocess.Per_module.single_preprocess preprocess)
-      ~libname:(snd lib.name) ~obj_dir )
+      ~libname:(snd lib.name) ~obj_dir
+      ~dialects:(Dune_project.dialects (Scope.project scope)) )
 
 let rules (lib : Library.t) ~sctx ~dir_contents ~dir ~expander ~scope :
     Compilation_context.t * Merlin.t =

src/dune_rules/merlin.ml

@@ -5,6 +5,14 @@ open Build.O
 open! No_io
 module SC = Super_context
 
+module Extensions = Comparable.Make (struct
+  type t = string * string
+
+  let compare = Tuple.T2.compare String.compare String.compare
+
+  let to_dyn = Tuple.T2.to_dyn String.to_dyn String.to_dyn
+end)
+
 let warn_dropped_pp loc ~allow_approx_merlin ~reason =
   if not allow_approx_merlin then
     User_warning.emit ~loc
@@ -73,11 +81,11 @@ let quote_for_merlin s =
 module Dot_file = struct
   let b = Buffer.create 256
 
-  let printf = Printf.bprintf b
+  let printf f = Printf.bprintf b f
 
   let print = Buffer.add_string b
 
-  let to_string ~obj_dirs ~src_dirs ~flags ~pp ~remaindir =
+  let to_string ~obj_dirs ~src_dirs ~flags ~pp ~remaindir ~extensions =
     let serialize_path = Path.reach ~from:(Path.source remaindir) in
     Buffer.clear b;
     print "EXCLUDE_QUERY_DIR\n";
@@ -90,6 +98,8 @@ module Dot_file = struct
       print "FLG";
       List.iter flags ~f:(fun f -> printf " %s" (quote_for_merlin f));
       print "\n" );
+    Extensions.Set.iter extensions ~f:(fun (impl, intf) ->
+        printf "SUFFIX %s %s\n" (quote_for_merlin impl) (quote_for_merlin intf));
     Buffer.contents b
 end
 
@@ -100,10 +110,12 @@ type t =
   ; libname : Lib_name.Local.t option
   ; source_dirs : Path.Source.Set.t
   ; objs_dirs : Path.Set.t
+  ; extensions : Extensions.Set.t
   }
 
 let make ?(requires = Ok []) ~flags ?(preprocess = Preprocess.No_preprocessing)
-    ?libname ?(source_dirs = Path.Source.Set.empty) ~modules ~obj_dir () =
+    ?libname ?(source_dirs = Path.Source.Set.empty) ~modules ~obj_dir ~dialects
+    () =
   (* Merlin shouldn't cause the build to fail, so we just ignore errors *)
   let requires =
     match requires with
@@ -122,12 +134,22 @@ let make ?(requires = Ok []) ~flags ?(preprocess = Preprocess.No_preprocessing)
         flags
       |> Ocaml_flags.common
   in
+  let extensions =
+    Dialect.DB.fold dialects ~init:Extensions.Set.empty ~f:(fun d s ->
+        let impl = Dialect.extension d Ml_kind.Impl in
+        let intf = Dialect.extension d Ml_kind.Intf in
+        if impl = ".ml" && intf = ".mli" then
+          s
+        else
+          Extensions.Set.add s (impl, intf))
+  in
   { requires
   ; flags = Build.catch flags ~on_error:(fun _ -> [])
   ; preprocess
   ; libname
   ; source_dirs
   ; objs_dirs
+  ; extensions
   }
 
 let merlin_file_name = ".merlin"
@@ -217,8 +239,8 @@ let lib_src_dirs ~sctx lib =
     Path.Set.map ~f:Path.drop_optional_build_context
       (Modules.source_dirs modules)
 
-let dot_merlin sctx ~dir ~more_src_dirs ~expander ({ requires; flags; _ } as t)
-    =
+let dot_merlin sctx ~dir ~more_src_dirs ~expander
+    ({ requires; flags; extensions; _ } as t) =
   Path.Build.drop_build_context dir
   |> Option.iter ~f:(fun remaindir ->
          let open Build.With_targets.O in
@@ -256,7 +278,8 @@ let dot_merlin sctx ~dir ~more_src_dirs ~expander ({ requires; flags; _ } as t)
                 Path.Set.union src_dirs
                   (Path.Set.of_list_map ~f:Path.source more_src_dirs)
               in
-              Dot_file.to_string ~remaindir ~pp ~flags ~src_dirs ~obj_dirs)
+              Dot_file.to_string ~remaindir ~pp ~flags ~src_dirs ~obj_dirs
+                ~extensions)
          in
          SC.add_rule sctx ~dir
            ~mode:(Promote { lifetime = Until_clean; into = None; only = None })
@@ -275,6 +298,7 @@ let merge_two ~allow_approx_merlin a b =
       | None -> b.libname )
   ; source_dirs = Path.Source.Set.union a.source_dirs b.source_dirs
   ; objs_dirs = Path.Set.union a.objs_dirs b.objs_dirs
+  ; extensions = Extensions.Set.union a.extensions b.extensions
   }
 
 let merge_all ~allow_approx_merlin = function

src/dune_rules/merlin.mli

@@ -14,6 +14,7 @@ val make :
   -> ?source_dirs:Path.Source.Set.t
   -> modules:Modules.t
   -> obj_dir:Path.Build.t Obj_dir.t
+  -> dialects:Dialect.DB.t
   -> unit
   -> t