refactor: get doc kind info from merlin

ocaml-lsp-server/src/document.ml

@@ -6,16 +6,21 @@ module Kind = struct
     | Intf
     | Impl
 
-  let of_fname p =
+  let of_fname_opt p =
     match Filename.extension p with
-    | ".ml" | ".eliom" | ".re" -> Impl
-    | ".mli" | ".eliomi" | ".rei" -> Intf
-    | ext ->
+    | ".ml" | ".eliom" | ".re" -> Some Impl
+    | ".mli" | ".eliomi" | ".rei" -> Some Intf
+    | _ -> None
+
+  let of_fname p =
+    match of_fname_opt p with
+    | Some k -> k
+    | None ->
       Jsonrpc.Response.Error.raise
         (Jsonrpc.Response.Error.make
            ~code:InvalidRequest
            ~message:"unsupported file extension"
-           ~data:(`Assoc [ ("extension", `String ext) ])
+           ~data:(`Assoc [ ("extension", `String (Filename.extension p)) ])
            ())
 end
 
@@ -178,6 +183,7 @@ type merlin =
   ; timer : Lev_fiber.Timer.Wheel.task
   ; merlin_config : Merlin_config.t
   ; syntax : Syntax.t
+  ; kind : Kind.t option
   }
 
 type t =
@@ -204,12 +210,24 @@ let source t = Msource.make (text t)
 let version t = Text_document.version (tdoc t)
 
 let make_merlin wheel merlin_db pipeline tdoc syntax =
-  let+ timer = Lev_fiber.Timer.Wheel.task wheel in
-  let merlin_config =
-    let uri = Text_document.documentUri tdoc in
-    Merlin_config.DB.get merlin_db uri
+  let* timer = Lev_fiber.Timer.Wheel.task wheel in
+  let uri = Text_document.documentUri tdoc in
+  let path = Uri.to_path uri in
+  let merlin_config = Merlin_config.DB.get merlin_db uri in
+  let* mconfig = Merlin_config.config merlin_config in
+  let kind =
+    let ext = Filename.extension path in
+    List.find_map mconfig.merlin.suffixes ~f:(fun (impl, intf) ->
+        if String.equal ext intf then Some Kind.Intf
+        else if String.equal ext impl then Some Kind.Impl
+        else None)
+  in
+  let kind =
+    match kind with
+    | Some _ as k -> k
+    | None -> Kind.of_fname_opt path
   in
-  Merlin { merlin_config; tdoc; pipeline; timer; syntax }
+  Fiber.return (Merlin { merlin_config; tdoc; pipeline; timer; syntax; kind })
 
 let make wheel config pipeline (doc : DidOpenTextDocumentParams.t)
     ~position_encoding =
@@ -252,7 +270,17 @@ module Merlin = struct
 
   let timer (t : t) = t.timer
 
-  let kind t = Kind.of_fname (Uri.to_path (uri (Merlin t)))
+  let kind t =
+    match t.kind with
+    | Some k -> k
+    | None ->
+      let p = Text_document.documentUri t.tdoc |> Uri.to_path in
+      Jsonrpc.Response.Error.raise
+        (Jsonrpc.Response.Error.make
+           ~code:InvalidRequest
+           ~message:"unsupported file extension"
+           ~data:(`Assoc [ ("extension", `String (Filename.extension p)) ])
+           ())
 
   let with_pipeline ?name (t : t) f =
     Single_pipeline.use ?name t.pipeline ~doc:t.tdoc ~config:t.merlin_config ~f