feature: communicate dialects READER to merlin

If dialect defined (merlin_reader) thenwe configure merlin with it.

Signed-off-by: Andrey Popp <8mayday@gmail.com>

src/dune_rules/dialect.ml

@@ -10,9 +10,10 @@ module File_kind = struct
     ; extension : string
     ; preprocess : (Loc.t * Action.t) option
     ; format : (Loc.t * Action.t * string list) option
+    ; merlin_reader : (Loc.t * string list) option
     }
 
-  let encode { kind; extension; preprocess; format } =
+  let encode { kind; extension; preprocess; format; merlin_reader } =
     let open Dune_lang.Encoder in
     let kind =
       string
@@ -28,16 +29,18 @@ module File_kind = struct
             [ field "extension" string extension
             ; field_o "preprocess" Action.encode (Option.map ~f:snd preprocess)
             ; field_o "format" Action.encode (Option.map ~f:(fun (_, x, _) -> x) format)
+            ; field_o "merlin_reader" (list string) (Option.map ~f:snd merlin_reader)
             ])
   ;;
 
-  let to_dyn { kind; extension; preprocess; format } =
+  let to_dyn { kind; extension; preprocess; format; merlin_reader } =
     let open Dyn in
     record
       [ "kind", Ml_kind.to_dyn kind
       ; "extension", string extension
       ; "preprocess", option (fun (_, x) -> Action.to_dyn x) preprocess
       ; "format", option (fun (_, x, y) -> pair Action.to_dyn (list string) (x, y)) format
+      ; "merlin_reader", option (fun (_, x) -> list string x) merlin_reader
       ]
   ;;
 end
@@ -78,13 +81,17 @@ let decode =
       field_o
         "format"
         (map ~f:(fun (loc, x) -> loc, x, []) (located Action.decode_dune_file))
+    and+ merlin_reader =
+      field_o
+        "merlin_reader"
+        (Dune_lang.Syntax.since Stanza.syntax (3, 11) >>> located (repeat1 string))
     and+ syntax_ver = Syntax.get_exn Stanza.syntax in
     let ver = 3, 9 in
     if syntax_ver < ver && Option.is_some (String.index_from extension 1 '.')
     then (
       let what = "the possibility of defining extensions containing periods" in
       Syntax.Error.since loc Stanza.syntax ver ~what);
-    { File_kind.kind; extension; preprocess; format }
+    { File_kind.kind; extension; preprocess; format; merlin_reader }
   in
   fields
     (let+ name = field "name" string
@@ -130,6 +137,13 @@ let format { file_kinds; _ } ml_kind =
   x.format
 ;;
 
+let merlin_reader { file_kinds; _ } ml_kind =
+  let open Option.O in
+  let* x = Ml_kind.Dict.get file_kinds ml_kind in
+  let+ _, merlin_reader = x.merlin_reader in
+  x.extension, merlin_reader
+;;
+
 let ocaml =
   let format kind =
     let flag_of_kind = function
@@ -154,6 +168,7 @@ let ocaml =
           ( Loc.none
           , format kind
           , [ ".ocamlformat"; ".ocamlformat-ignore"; ".ocamlformat-enable" ] )
+    ; merlin_reader = None
     }
   in
   let intf = Some (file_kind Ml_kind.Intf ".mli") in
@@ -179,6 +194,7 @@ let reason =
     ; extension
     ; preprocess = Some (Loc.none, preprocess)
     ; format = Some (Loc.none, format, [])
+    ; merlin_reader = None
     }
   in
   let intf = Some (file_kind Ml_kind.Intf ".rei") in
@@ -207,6 +223,7 @@ let rescript =
     ; extension
     ; preprocess = Some (Loc.none, preprocess)
     ; format = Some (Loc.none, format, [])
+    ; merlin_reader = None
     }
   in
   let intf = Some (file_kind Ml_kind.Intf ".resi") in
@@ -227,43 +244,61 @@ module DB = struct
   type t =
     { by_name : dialect String.Map.t
     ; by_extension : dialect String.Map.t
-    ; mutable extensions_for_merlin : string option Ml_kind.Dict.t list option
+    ; for_merlin : for_merlin Lazy.t
+    }
+
+  and for_merlin =
+    { extensions : string option Ml_kind.Dict.t list
+    ; readers : string list String.Map.t
     }
 
   let fold { by_name; _ } = String.Map.fold by_name
 
   let empty =
     { by_name = String.Map.empty
     ; by_extension = String.Map.empty
-    ; extensions_for_merlin = None
+    ; for_merlin = lazy { extensions = []; readers = String.Map.empty }
     }
   ;;
 
-  let set_extensions_for_merlin t =
-    let v =
-      fold t ~init:[] ~f:(fun d s ->
-        let impl = extension d Ml_kind.Impl in
-        let intf = extension d Ml_kind.Intf in
-        if (* Only include dialects with no preprocessing and skip default file
-              extensions *)
-           preprocess d Ml_kind.Impl <> None
-           || preprocess d Ml_kind.Intf <> None
-           || (impl = extension ocaml Ml_kind.Impl && intf = extension ocaml Ml_kind.Intf)
-        then s
-        else { Ml_kind.Dict.impl; intf } :: s)
+  let compute_for_merlin by_name =
+    let extensions =
+      String.Map.fold by_name ~init:[] ~f:(fun d s ->
+        let ext_for kind =
+          let ext = extension d kind in
+          if ext = extension ocaml kind
+          then (* this is standard dialect, exclude *) None
+          else if merlin_reader d kind <> None
+          then (* we have merlin reader defined, it will handle these files *) ext
+          else if preprocess d kind <> None
+          then (* we have preprocessor defined *) None
+          else ext
+        in
+        let impl = ext_for Ml_kind.Impl in
+        let intf = ext_for Ml_kind.Intf in
+        match impl, intf with
+        | None, None -> s
+        | _ -> { Ml_kind.Dict.impl; intf } :: s)
       |> List.sort ~compare:(Ml_kind.Dict.compare (Option.compare String.compare))
     in
-    t.extensions_for_merlin <- Some v;
-    v
+    let readers =
+      String.Map.fold by_name ~init:String.Map.empty ~f:(fun d s ->
+        let add kind s =
+          match merlin_reader d kind with
+          | None -> s
+          | Some (extension, reader) ->
+            (* Ok to use [add_exn] here as we are validating below in [add]
+               function that we have extensions registered only once. *)
+            String.Map.add_exn s extension reader
+        in
+        s |> add Ml_kind.Impl |> add Ml_kind.Intf)
+    in
+    { extensions; readers }
   ;;
 
-  let extensions_for_merlin t =
-    match t.extensions_for_merlin with
-    | Some s -> s
-    | None -> set_extensions_for_merlin t
-  ;;
+  let for_merlin t = Lazy.force t.for_merlin
 
-  let add { by_name; by_extension; extensions_for_merlin = _ } ~loc dialect =
+  let add { by_name; by_extension; for_merlin = _ } ~loc dialect =
     let by_name =
       match String.Map.add by_name dialect.name dialect with
       | Ok by_name -> by_name
@@ -287,7 +322,7 @@ module DB = struct
     let by_extension =
       add_ext (add_ext by_extension dialect.file_kinds.intf) dialect.file_kinds.impl
     in
-    { by_name; by_extension; extensions_for_merlin = None }
+    { by_name; by_extension; for_merlin = lazy (compute_for_merlin by_name) }
   ;;
 
   let of_list dialects = List.fold_left ~f:(add ~loc:Loc.none) ~init:empty dialects

src/dune_rules/dialect.mli

@@ -42,8 +42,14 @@ module DB : sig
   val find_by_name : t -> string -> dialect option
   val find_by_extension : t -> string -> (dialect * Ml_kind.t) option
   val fold : t -> init:'a -> f:(dialect -> 'a -> 'a) -> 'a
-  val extensions_for_merlin : t -> string option Ml_kind.Dict.t list
   val to_dyn : t -> Dyn.t
   val builtin : t
   val is_default : t -> bool
+
+  type for_merlin =
+    { extensions : string option Ml_kind.Dict.t list
+    ; readers : string list String.Map.t
+    }
+
+  val for_merlin : t -> for_merlin
 end

src/dune_rules/merlin/merlin.ml

@@ -73,11 +73,16 @@ module Processed = struct
   type module_config =
     { opens : Module_name.t list
     ; module_ : Module.t
+    ; reader : string list option
     }
 
-  let dyn_of_module_config { opens; module_ } =
+  let dyn_of_module_config { opens; module_; reader } =
     let open Dyn in
-    record [ "opens", list Module_name.to_dyn opens; "module_", Module.to_dyn module_ ]
+    record
+      [ "opens", list Module_name.to_dyn opens
+      ; "module_", Module.to_dyn module_
+      ; "reader", option (list string) reader
+      ]
   ;;
 
   (* ...but modules can have different preprocessing specifications*)
@@ -150,7 +155,11 @@ module Processed = struct
     | None, None -> None
   ;;
 
-  let to_sexp ~opens ~pp { stdlib_dir; obj_dirs; src_dirs; flags; extensions; melc_flags }
+  let to_sexp
+    ~opens
+    ~pp
+    ~reader
+    { stdlib_dir; obj_dirs; src_dirs; flags; extensions; melc_flags }
     =
     let make_directive tag value = Sexp.List [ Atom tag; value ] in
     let make_directive_of_path tag path =
@@ -201,8 +210,16 @@ module Processed = struct
         let+ impl, intf = get_ext x in
         make_directive "SUFFIX" (Sexp.Atom (Printf.sprintf "%s %s" impl intf)))
     in
+    let reader =
+      match reader with
+      | Some reader ->
+        [ make_directive "READER" (Sexp.List (List.map ~f:(fun r -> Sexp.Atom r) reader))
+        ]
+      | None -> []
+    in
     Sexp.List
-      (List.concat [ stdlib_dir; exclude_query_dir; obj_dirs; src_dirs; flags; suffixes ])
+      (List.concat
+         [ stdlib_dir; exclude_query_dir; obj_dirs; src_dirs; flags; suffixes; reader ])
   ;;
 
   let quote_for_dot_merlin s =
@@ -251,7 +268,7 @@ module Processed = struct
     (* We only match the first part of the filename : foo.ml -> foo foo.cppo.ml
        -> foo *)
     let open Option.O in
-    let+ { module_; opens } =
+    let+ { module_; opens; reader } =
       let find file =
         match Path.Build.Map.find per_module_config file with
         | Some _ as s -> s
@@ -262,25 +279,32 @@ module Processed = struct
       | None -> Copy_line_directive.DB.follow_while file ~f:find
     in
     let pp = Module_name.Per_item.get pp_config (Module.name module_) in
-    to_sexp ~opens ~pp config
+    to_sexp ~opens ~pp ~reader config
   ;;
 
   let print_file path =
     match load_file path with
     | Error msg -> Printf.eprintf "%s\n" msg
     | Ok { per_module_config; pp_config; config } ->
-      let pp_one { module_; opens } =
+      let pp_one name sexp =
         let open Pp.O in
+        Pp.vbox (Pp.text name) ++ Pp.newline ++ Pp.vbox (Sexp.pp sexp)
+      in
+      let pp_module { module_; opens; reader } =
         let name = Module.name module_ in
         let pp = Module_name.Per_item.get pp_config name in
-        let sexp = to_sexp ~opens ~pp config in
-        Pp.vbox (Pp.text (Module_name.to_string name))
-        ++ Pp.newline
-        ++ Pp.vbox (Sexp.pp sexp)
+        let sexps =
+          List.map (Module.sources module_) ~f:(fun path ->
+            Path.basename path, to_sexp ~opens ~pp ~reader config)
+          |> List.sort ~compare:(fun (a, _) (b, _) -> String.compare a b)
+        in
+        match sexps with
+        | [ (_, sexp) ] -> pp_one (Module_name.to_string name) sexp
+        | many -> Pp.concat_map ~sep:Pp.cut ~f:(fun (name, sexp) -> pp_one name sexp) many
       in
       let pp =
         Path.Build.Map.values per_module_config
-        |> Pp.concat_map ~sep:Pp.cut ~f:pp_one
+        |> Pp.concat_map ~sep:Pp.cut ~f:pp_module
         |> Pp.vbox
       in
       Format.printf "%a@." Pp.to_fmt pp
@@ -361,6 +385,7 @@ module Unprocessed = struct
     ; source_dirs : Path.Source.Set.t
     ; objs_dirs : Path.Set.t
     ; extensions : string option Ml_kind.Dict.t list
+    ; readers : string list String.Map.t
     ; mode : Lib_mode.t
     }
 
@@ -399,7 +424,7 @@ module Unprocessed = struct
       Path.Set.singleton @@ obj_dir_of_lib `Private mode (Obj_dir.of_local obj_dir)
     in
     let flags = Ocaml_flags.get flags mode in
-    let extensions = Dialect.DB.extensions_for_merlin dialects in
+    let { Dialect.DB.extensions; readers } = Dialect.DB.for_merlin dialects in
     let config =
       { stdlib_dir
       ; mode
@@ -410,6 +435,7 @@ module Unprocessed = struct
       ; source_dirs
       ; objs_dirs
       ; extensions
+      ; readers
       }
     in
     { ident; config; modules = source_modules }
@@ -515,6 +541,7 @@ module Unprocessed = struct
      ; config =
          { stdlib_dir
          ; extensions
+         ; readers
          ; flags
          ; objs_dirs
          ; source_dirs
@@ -610,6 +637,7 @@ module Unprocessed = struct
           let config =
             { Processed.module_ = Module.set_pp m None
             ; opens = Modules.alias_for modules m |> List.map ~f:Module.name
+            ; reader = String.Map.find readers (Path.Build.extension src)
             }
           in
           (src, config) :: acc))

test/blackbox-tests/test-cases/merlin/dialect.t/dune-project

@@ -0,0 +1,10 @@
+(lang dune 3.11)
+
+(using melange 0.1)
+
+(dialect
+ (name mlx)
+ (implementation
+  (extension mlx)
+  (preprocess (run cat %{input-file}))
+  (merlin_reader mlx)))

test/blackbox-tests/test-cases/merlin/dialect.t/exe/dune

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

test/blackbox-tests/test-cases/merlin/dialect.t/lib/dune

@@ -0,0 +1,2 @@
+(library
+ (name x))

test/blackbox-tests/test-cases/merlin/dialect.t/melange/dune

@@ -0,0 +1,3 @@
+(library
+ (modes melange)
+ (name x_mel))