diff --git a/ocaml-lsp-server/src/document.ml b/ocaml-lsp-server/src/document.ml index 4bbcf81e5..5421c41f9 100644 --- a/ocaml-lsp-server/src/document.ml +++ b/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