From cd0aa2c265dfbb6d94895da8a350c96f5a1c9805 Mon Sep 17 00:00:00 2001 From: Andrey Popp <8mayday@gmail.com> Date: Mon, 1 Apr 2024 15:02:23 +0300 Subject: [PATCH] refactor: get doc kind info from merlin --- CHANGES.md | 7 ++ ocaml-lsp-server/src/code_actions.ml | 2 +- .../src/code_actions/action_open_related.ml | 10 ++- .../src/code_actions/action_open_related.mli | 2 +- .../custom_requests/req_switch_impl_intf.ml | 27 ++++++-- .../custom_requests/req_switch_impl_intf.mli | 2 +- ocaml-lsp-server/src/document.ml | 66 +++++++++++++------ ocaml-lsp-server/src/document.mli | 2 +- ocaml-lsp-server/src/inference.ml | 4 +- ocaml-lsp-server/src/ocaml_lsp_server.ml | 4 +- 10 files changed, 91 insertions(+), 35 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 6777c1a59..723cd725d 100644 --- a/CHANGES.md +++ b/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 diff --git a/ocaml-lsp-server/src/code_actions.ml b/ocaml-lsp-server/src/code_actions.ml index 5400ab280..1f4ce57ad 100644 --- a/ocaml-lsp-server/src/code_actions.ml +++ b/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 -> diff --git a/ocaml-lsp-server/src/code_actions/action_open_related.ml b/ocaml-lsp-server/src/code_actions/action_open_related.ml index 893dac1e5..463f24104 100644 --- a/ocaml-lsp-server/src/code_actions/action_open_related.ml +++ b/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 diff --git a/ocaml-lsp-server/src/code_actions/action_open_related.mli b/ocaml-lsp-server/src/code_actions/action_open_related.mli index d1d594b7a..a9739f1c5 100644 --- a/ocaml-lsp-server/src/code_actions/action_open_related.mli +++ b/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 diff --git a/ocaml-lsp-server/src/custom_requests/req_switch_impl_intf.ml b/ocaml-lsp-server/src/custom_requests/req_switch_impl_intf.ml index 99eb46c70..3d3140889 100644 --- a/ocaml-lsp-server/src/custom_requests/req_switch_impl_intf.ml +++ b/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 diff --git a/ocaml-lsp-server/src/custom_requests/req_switch_impl_intf.mli b/ocaml-lsp-server/src/custom_requests/req_switch_impl_intf.mli index c8833a5d7..dadd40f0d 100644 --- a/ocaml-lsp-server/src/custom_requests/req_switch_impl_intf.mli +++ b/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 diff --git a/ocaml-lsp-server/src/document.ml b/ocaml-lsp-server/src/document.ml index 4bbcf81e5..24add529f 100644 --- a/ocaml-lsp-server/src/document.ml +++ b/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 ] diff --git a/ocaml-lsp-server/src/document.mli b/ocaml-lsp-server/src/document.mli index eb5e65f02..b059ce6a2 100644 --- a/ocaml-lsp-server/src/document.mli +++ b/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]. *) diff --git a/ocaml-lsp-server/src/inference.ml b/ocaml-lsp-server/src/inference.ml index 837197d28..25ec007a6 100644 --- a/ocaml-lsp-server/src/inference.ml +++ b/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 diff --git a/ocaml-lsp-server/src/ocaml_lsp_server.ml b/ocaml-lsp-server/src/ocaml_lsp_server.ml index f831f6734..5d2b8ebe8 100644 --- a/ocaml-lsp-server/src/ocaml_lsp_server.ml +++ b/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)