refactor: get doc kind info from merlin (#1237)

CHANGES.md

@@ -8,6 +8,13 @@
 
 - Support folding of `ifthenelse` expressions (#1031)
 
+## Fixes
+
+- Detect document kind by looking at merlin's `suffixes` config.
+
+  This enables more lsp features for non-.ml/.mli files. Though it still
+  depends on merlin's support. (#1237)
+
 # 1.17.0
 
 ## Fixes

ocaml-lsp-server/src/code_actions.ml

@@ -113,7 +113,7 @@ let compute server (params : CodeActionParams.t) =
         let* window = (State.client_capabilities state).window in
         window.showDocument
       in
-      Action_open_related.for_uri capabilities uri
+      Action_open_related.for_uri capabilities doc
     in
     match Document.syntax doc with
     | Ocamllex | Menhir | Cram | Dune ->

ocaml-lsp-server/src/code_actions/action_open_related.ml

@@ -28,11 +28,17 @@ let available (capabilities : ShowDocumentClientCapabilities.t option) =
   | None | Some { support = false } -> false
   | Some { support = true } -> true
 
-let for_uri (capabilities : ShowDocumentClientCapabilities.t option) uri =
+let for_uri (capabilities : ShowDocumentClientCapabilities.t option) doc =
+  let uri = Document.uri doc in
+  let merlin_doc =
+    match Document.kind doc with
+    | `Merlin doc -> Some doc
+    | `Other -> None
+  in
   match available capabilities with
   | false -> []
   | true ->
-    Document.get_impl_intf_counterparts uri
+    Document.get_impl_intf_counterparts merlin_doc uri
     |> List.map ~f:(fun uri ->
            let path = Uri.to_path uri in
            let exists = Sys.file_exists path in

ocaml-lsp-server/src/code_actions/action_open_related.mli

@@ -7,4 +7,4 @@ val available : ShowDocumentClientCapabilities.t option -> bool
 val command_run : _ Server.t -> ExecuteCommandParams.t -> Json.t Fiber.t
 
 val for_uri :
-  ShowDocumentClientCapabilities.t option -> DocumentUri.t -> CodeAction.t list
+  ShowDocumentClientCapabilities.t option -> Document.t -> CodeAction.t list

ocaml-lsp-server/src/custom_requests/req_switch_impl_intf.ml

@@ -5,15 +5,30 @@ let capability = ("handleSwitchImplIntf", `Bool true)
 let meth = "ocamllsp/switchImplIntf"
 
 (** see the spec for [ocamllsp/switchImplIntf] *)
-let switch (param : DocumentUri.t) : Json.t =
-  let files_to_switch_to = Document.get_impl_intf_counterparts param in
+let switch merlin_doc (param : DocumentUri.t) : Json.t =
+  let files_to_switch_to =
+    Document.get_impl_intf_counterparts merlin_doc param
+  in
   Json.yojson_of_list Uri.yojson_of_t files_to_switch_to
 
-let on_request ~(params : Jsonrpc.Structured.t option) =
+let on_request ~(params : Jsonrpc.Structured.t option) (state : State.t) =
   match params with
-  | Some (`List [ file_uri ]) ->
-    let file_uri = DocumentUri.t_of_yojson file_uri in
-    switch file_uri
+  | Some (`List [ json_uri ]) -> (
+    let uri = DocumentUri.t_of_yojson json_uri in
+    match Document_store.get_opt state.store uri with
+    | Some doc -> (
+      match Document.kind doc with
+      | `Merlin merlin_doc -> switch (Some merlin_doc) uri
+      | `Other ->
+        Jsonrpc.Response.Error.raise
+          (Jsonrpc.Response.Error.make
+             ~code:InvalidRequest
+             ~message:
+               "Document with this URI is not supported by \
+                ocamllsp/switchImplIntf"
+             ~data:(`Assoc [ ("param", (json_uri :> Json.t)) ])
+             ()))
+    | None -> switch None uri)
   | Some json ->
     Jsonrpc.Response.Error.raise
       (Jsonrpc.Response.Error.make

ocaml-lsp-server/src/custom_requests/req_switch_impl_intf.mli

@@ -4,4 +4,4 @@ val capability : string * Json.t
 
 val meth : string
 
-val on_request : params:Jsonrpc.Structured.t option -> Json.t
+val on_request : params:Jsonrpc.Structured.t option -> State.t -> Json.t

ocaml-lsp-server/src/document.ml

@@ -6,17 +6,20 @@ 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 ->
-      Jsonrpc.Response.Error.raise
-        (Jsonrpc.Response.Error.make
-           ~code:InvalidRequest
-           ~message:"unsupported file extension"
-           ~data:(`Assoc [ ("extension", `String ext) ])
-           ())
+    | ".ml" | ".eliom" | ".re" -> Some Impl
+    | ".mli" | ".eliomi" | ".rei" -> Some Intf
+    | _ -> None
+
+  let unsupported uri =
+    let p = Uri.to_path uri in
+    Jsonrpc.Response.Error.raise
+      (Jsonrpc.Response.Error.make
+         ~code:InvalidRequest
+         ~message:"unsupported file extension"
+         ~data:(`Assoc [ ("extension", `String (Filename.extension p)) ])
+         ())
 end
 
 module Syntax = struct
@@ -178,6 +181,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 +208,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
-  Merlin { merlin_config; tdoc; pipeline; timer; syntax }
+  let kind =
+    match kind with
+    | Some _ as k -> k
+    | None -> Kind.of_fname_opt path
+  in
+  Fiber.return (Merlin { merlin_config; tdoc; pipeline; timer; syntax; kind })
 
 let make wheel config pipeline (doc : DidOpenTextDocumentParams.t)
     ~position_encoding =
@@ -252,7 +268,10 @@ 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 -> Kind.unsupported (Text_document.documentUri t.tdoc)
 
   let with_pipeline ?name (t : t) f =
     Single_pipeline.use ?name t.pipeline ~doc:t.tdoc ~config:t.merlin_config ~f
@@ -346,21 +365,30 @@ let close t =
       (fun () -> Merlin_config.destroy t.merlin_config)
       (fun () -> Lev_fiber.Timer.Wheel.cancel t.timer)
 
-let get_impl_intf_counterparts uri =
+let get_impl_intf_counterparts m uri =
   let fpath = Uri.to_path uri in
   let fname = Filename.basename fpath in
   let ml, mli, eliom, eliomi, re, rei, mll, mly =
     ("ml", "mli", "eliom", "eliomi", "re", "rei", "mll", "mly")
   in
   let exts_to_switch_to =
+    let kind =
+      match m with
+      | Some m -> Merlin.kind m
+      | None -> (
+        (* still try to guess the kind *)
+        match Kind.of_fname_opt fpath with
+        | Some k -> k
+        | None -> Kind.unsupported uri)
+    in
     match Syntax.of_fname fname with
     | Dune | Cram -> []
     | Ocaml -> (
-      match Kind.of_fname fname with
+      match kind with
       | Intf -> [ ml; mly; mll; eliom; re ]
       | Impl -> [ mli; mly; mll; eliomi; rei ])
     | Reason -> (
-      match Kind.of_fname fname with
+      match kind with
       | Intf -> [ re; ml ]
       | Impl -> [ rei; mli ])
     | Ocamllex -> [ mli; rei ]

ocaml-lsp-server/src/document.mli

@@ -97,7 +97,7 @@ val close : t -> unit Fiber.t
     counterparts for the URI [uri].
 
     For instance, the counterparts of the file [/file.ml] are [/file.mli]. *)
-val get_impl_intf_counterparts : Uri.t -> Uri.t list
+val get_impl_intf_counterparts : Merlin.t option -> Uri.t -> Uri.t list
 
 (** [edits t edits] creates a [WorkspaceEdit.t] that applies edits [edits] to
     the document [t]. *)

ocaml-lsp-server/src/inference.ml

@@ -69,11 +69,11 @@ let infer_intf (state : State.t) doc =
     Code_error.raise "the provided document is not a merlin source." []
   | `Merlin m when Document.Merlin.kind m = Impl ->
     Code_error.raise "the provided document is not an interface." []
-  | `Merlin _ ->
+  | `Merlin m ->
     Fiber.of_thunk (fun () ->
         let intf_uri = Document.uri doc in
         let impl_uri =
-          Document.get_impl_intf_counterparts intf_uri |> List.hd
+          Document.get_impl_intf_counterparts (Some m) intf_uri |> List.hd
         in
         let* impl =
           match Document_store.get_opt state.store impl_uri with

ocaml-lsp-server/src/ocaml_lsp_server.ml

@@ -500,9 +500,9 @@ let on_request :
   | Client_request.UnknownRequest { meth; params } -> (
     match
       [ ( Req_switch_impl_intf.meth
-        , fun ~params _ ->
+        , fun ~params state ->
             Fiber.of_thunk (fun () ->
-                Fiber.return (Req_switch_impl_intf.on_request ~params)) )
+                Fiber.return (Req_switch_impl_intf.on_request ~params state)) )
       ; (Req_infer_intf.meth, Req_infer_intf.on_request)
       ; (Req_typed_holes.meth, Req_typed_holes.on_request)
       ; (Req_wrapping_ast_node.meth, Req_wrapping_ast_node.on_request)