From 6da002c6f17b942b110beebe2f5753f13f8d3ac7 Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Thu, 20 Oct 2022 11:56:22 -0600 Subject: [PATCH] fix: handle incorrect document types instead of crashing, we return no code actions Signed-off-by: Rudi Grinberg ps-id: 5f932001-91c4-4ab8-97ce-3460e4001c2a --- CHANGES.md | 7 +++++-- .../src/code_actions/action_construct.ml | 4 ++-- .../src/code_actions/action_destruct.ml | 4 ++-- .../src/code_actions/action_inferred_intf.ml | 4 ++-- ocaml-lsp-server/src/document.ml | 4 ++-- ocaml-lsp-server/src/document.mli | 2 +- ocaml-lsp-server/src/inference.ml | 15 +++++++++++---- ocaml-lsp-server/src/ocaml_lsp_server.ml | 4 ++-- ocaml-lsp-server/src/ocamlformat.ml | 7 ++++++- 9 files changed, 33 insertions(+), 18 deletions(-) diff --git a/CHANGES.md b/CHANGES.md index 36d3c3079..cfaa5fe1c 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,6 +1,9 @@ -# Unreleased +# 1.14.1 -## Features +## Fixes + +- Do no crash server when code actions when merlin code actions are asked for + merlin documents (#884, fixes #871) - Ignore unknown tags in merlin configuration to improve forward compatibility with Dune. (#883) diff --git a/ocaml-lsp-server/src/code_actions/action_construct.ml b/ocaml-lsp-server/src/code_actions/action_construct.ml index 197364785..c4ec457f0 100644 --- a/ocaml-lsp-server/src/code_actions/action_construct.ml +++ b/ocaml-lsp-server/src/code_actions/action_construct.ml @@ -5,8 +5,8 @@ let action_kind = "construct" let code_action doc (params : CodeActionParams.t) = match Document.kind doc with - | Intf -> Fiber.return None - | Impl -> + | `Other | `Merlin Intf -> Fiber.return None + | `Merlin Impl -> let pos = Position.logical params.range.Range.end_ in (* we want this predicate to quickly eliminate prefixes that don't fit to be a hole *) diff --git a/ocaml-lsp-server/src/code_actions/action_destruct.ml b/ocaml-lsp-server/src/code_actions/action_destruct.ml index 129782dea..c45105dac 100644 --- a/ocaml-lsp-server/src/code_actions/action_destruct.ml +++ b/ocaml-lsp-server/src/code_actions/action_destruct.ml @@ -40,8 +40,8 @@ let code_action_of_case_analysis ~supportsJumpToNextHole doc uri (loc, newText) let code_action (state : State.t) doc (params : CodeActionParams.t) = let uri = params.textDocument.uri in match Document.kind doc with - | Intf -> Fiber.return None - | Impl -> ( + | `Other | `Merlin Intf -> Fiber.return None + | `Merlin Impl -> ( let command = let start = Position.logical params.range.start in let finish = Position.logical params.range.end_ in diff --git a/ocaml-lsp-server/src/code_actions/action_inferred_intf.ml b/ocaml-lsp-server/src/code_actions/action_inferred_intf.ml index 2d5069d2c..63c5121b0 100644 --- a/ocaml-lsp-server/src/code_actions/action_inferred_intf.ml +++ b/ocaml-lsp-server/src/code_actions/action_inferred_intf.ml @@ -26,8 +26,8 @@ let code_action_of_intf doc intf range = let code_action (state : State.t) doc (params : CodeActionParams.t) = match Document.kind doc with - | Impl -> Fiber.return None - | Intf -> ( + | `Other | `Merlin Impl -> Fiber.return None + | `Merlin Intf -> ( let* intf = Inference.infer_intf state doc in match intf with | None -> Fiber.return None diff --git a/ocaml-lsp-server/src/document.ml b/ocaml-lsp-server/src/document.ml index 2e3b741fa..e7986d524 100644 --- a/ocaml-lsp-server/src/document.ml +++ b/ocaml-lsp-server/src/document.ml @@ -111,8 +111,8 @@ let is_merlin = function | Merlin _ -> true let kind = function - | Merlin _ as t -> Kind.of_fname (Uri.to_path (uri t)) - | Other _ -> Code_error.raise "non merlin document has no kind" [] + | Merlin _ as t -> `Merlin (Kind.of_fname (Uri.to_path (uri t))) + | Other _ -> `Other let syntax = function | Merlin m -> m.syntax diff --git a/ocaml-lsp-server/src/document.mli b/ocaml-lsp-server/src/document.mli index 9e73deb19..96d80090f 100644 --- a/ocaml-lsp-server/src/document.mli +++ b/ocaml-lsp-server/src/document.mli @@ -24,7 +24,7 @@ end val is_merlin : t -> bool -val kind : t -> Kind.t +val kind : t -> [ `Merlin of Kind.t | `Other ] val syntax : t -> Syntax.t diff --git a/ocaml-lsp-server/src/inference.ml b/ocaml-lsp-server/src/inference.ml index 2c9e57253..abd0ef064 100644 --- a/ocaml-lsp-server/src/inference.ml +++ b/ocaml-lsp-server/src/inference.ml @@ -3,11 +3,15 @@ open Fiber.O let infer_intf_for_impl doc = match Document.kind doc with - | Intf -> + | `Other -> + Code_error.raise + "expected an implementation document, got a non merlin document" + [] + | `Merlin Intf -> Code_error.raise "expected an implementation document, got an interface instead" [] - | Impl -> + | `Merlin Impl -> Document.with_pipeline_exn doc (fun pipeline -> let typer = Mpipeline.typer_result pipeline in let sig_ : Types.signature = @@ -59,8 +63,11 @@ let open_document_from_file (state : State.t) uri = let infer_intf (state : State.t) doc = match Document.kind doc with - | Impl -> Code_error.raise "the provided document is not an interface." [] - | Intf -> + | `Other -> + Code_error.raise "the provided document is not a merlin source." [] + | `Merlin Impl -> + Code_error.raise "the provided document is not an interface." [] + | `Merlin Intf -> Fiber.of_thunk (fun () -> let intf_uri = Document.uri doc in let impl_uri = diff --git a/ocaml-lsp-server/src/ocaml_lsp_server.ml b/ocaml-lsp-server/src/ocaml_lsp_server.ml index 76a026031..6eb07d24c 100644 --- a/ocaml-lsp-server/src/ocaml_lsp_server.ml +++ b/ocaml-lsp-server/src/ocaml_lsp_server.ml @@ -430,8 +430,8 @@ let text_document_lens (state : State.t) let store = state.store in let doc = Document_store.get store uri in match Document.kind doc with - | Intf -> Fiber.return [] - | Impl -> + | `Other | `Merlin Intf -> Fiber.return [] + | `Merlin Impl -> let+ outline = let command = Query_protocol.Outline in Document.dispatch_exn doc command diff --git a/ocaml-lsp-server/src/ocamlformat.ml b/ocaml-lsp-server/src/ocamlformat.ml index 59057d113..3523998d2 100644 --- a/ocaml-lsp-server/src/ocamlformat.ml +++ b/ocaml-lsp-server/src/ocamlformat.ml @@ -132,7 +132,12 @@ let formatter doc = match Document.syntax doc with | (Dune | Cram | Ocamllex | Menhir) as s -> Error (Unsupported_syntax s) | Ocaml -> Ok (Ocaml (Document.uri doc)) - | Reason -> Ok (Reason (Document.kind doc)) + | Reason -> + Ok + (Reason + (match Document.kind doc with + | `Merlin i -> i + | `Other -> Code_error.raise "unable to format non merlin document" [])) let exec cancel bin args stdin = let refmt = Fpath.to_string bin in