diff --git a/.gitmodules b/.gitmodules index cc44af833..e69de29bb 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,5 +0,0 @@ -[submodule "submodules/dune"] - path = submodules/dune - url = https://github.com/rgrinberg/jbuilder - branch=lsp - ignore=dirty diff --git a/CHANGES.md b/CHANGES.md index e8250c826..36d616230 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -1,7 +1,19 @@ -# Unreleased +# 1.14.1 + +## Fixes + +- Fix various server crashes when opening non OCaml/Reason files. Files such as + dune, cram, etc. would cause the server to crash. (#884, fixes #871) + +- Ignore unknown tags in merlin configuration to improve forward compatibility + with Dune. (#883) + +# 1.14.0 ## Features +- Code action for inlining let bindings within a module or expression. (#847) + - Tag "unused code" and "deprecated" warnings, allowing clients to better display them. (#848) diff --git a/Makefile b/Makefile index aef5f1c32..aa3c4de71 100644 --- a/Makefile +++ b/Makefile @@ -17,7 +17,7 @@ all: # results in a conflict .PHONY: install-test-deps install-test-deps: - opam install 'menhir>20211230' cinaps 'ppx_expect>=v0.15.0' \ + opam install --yes 'menhir>20211230' cinaps 'ppx_expect>=v0.15.0' \ ocamlformat.$$(awk -F = '$$1 == "version" {print $$2}' .ocamlformat) ocamlformat-rpc .PHONY: dev @@ -48,7 +48,7 @@ check: dune build @check .PHONY: test-e2e -test-e2e: +test-e2e: yarn-install dune build @install && dune exec -- ocaml-lsp-server/test/run_test_e2e.exe .PHONY: promote-e2e diff --git a/README.md b/README.md index 6f1974756..e65c71ca5 100644 --- a/README.md +++ b/README.md @@ -57,8 +57,26 @@ For an example of usage of the server in a VS Code extension, see OCaml Platform Extension implementation [here](https://github.com/ocamllabs/vscode-ocaml-platform/blob/master/src/vscode_ocaml_platform.ml). +### Merlin configuration (advanced) + +If you would like OCaml-LSP to respect your `.merlin` files, OCaml-LSP needs to +be invoked with `--fallback-read-dot-merlin` argument passed to it. + ## Features + + The server supports the following LSP requests: - [x] `textDocument/completion` @@ -85,6 +103,125 @@ The server supports the following LSP requests: Note that degrees of support for each LSP request are varying. +### Semantic highlighting + +OCaml-LSP implements experimental semantic highlighting support (also known as +semantic tokens support). The support can be activated by passing an evironment +variable to OCaml-LSP: + +- To enable non-incremental (expectedly slower but more stable) version, pass + `OCAMLLSP_SEMANTIC_HIGHLIGHTING=full` environment variable to OCaml-LSP. + +- To enable incremental (potentially faster but more error-prone, at least on VS + Code) version, pass `OCAMLLSP_SEMANTIC_HIGHLIGHTING=full/delta` to OCaml-LSP. + +Tip (for VS Code OCaml Platform users): You can use `ocaml.server.extraEnv` +setting in VS Code to pass various environment variables to OCaml-LSP. + +```json +{ + "ocaml.server.extraEnv": { + "OCAMLLSP_SEMANTIC_HIGHLIGHTING": "full" + }, +} +``` + +### LSP Extensions + +The server also supports a number of OCaml specific extensions to the protocol: +- [Switch to implementation/interface](ocaml-lsp-server/docs/ocamllsp/switchImplIntf-spec.md) +- [Infer interface](ocaml-lsp-server/docs/ocamllsp/inferIntf-spec.md) +- [Locate typed holes](ocaml-lsp-server/docs/ocamllsp/typedHoles-spec.md) +- [Find wrapping AST node](ocaml-lsp-server/docs/ocamllsp/wrappingAstNode-spec.md) + +Note that editor support for these extensions varies. In general, the OCaml Platform extension for Visual Studio Code will have the best support. + +### Unorthodox features + +#### Destructing a value + +OCaml-LSP has a code action that allows to generate an exhaustive pattern +matching for values. For example, placing a cursor near a value `(Some 10)|` +where `|` is your cursor, OCaml-LSP will offer a code action "Destruct", which +replaces `(Some 10)` with `(match Some with | None -> _ | Some _ -> _)`. +Importantly, one can only destruct a value if OCaml-LSP can infer the value's +precise type. The value can be type-annotated, e.g., if it's a function argument +with polymorphic (or yet unknown) type in this context. In the code snippet +below, we type-annotate the function parameter `v` because when we type `let f v += v|`, the type of `v` is polymorphic, so we can't destruct it. + +You can also usually destruct the value by placing the cursor on the wildcard +(`_`) pattern in a pattern-match. For example, + +```ocaml +type t = A | B of string option + +let f (v : t) = match v with | A -> _ | B _| -> _ +``` + +invoking destruct near the cursor (`|`) in the snippet above, you get + +```ocaml +type t = A | B of string option + +let f (v : t) = match v with | A -> _ | B (None) | B (Some _) -> _ +``` + +Importantly, note the undescores in place of expressions in each branch of the +pattern match above. The underscores that occur in place of expressions are +called "typed holes" - a concept explained below. + +Tip (formatting): generated code may not be greatly formatted. If your project +uses a formatter such as OCamlFormat, you can run formatting and get a +well-formatted document (OCamlFormat supports typed holes formatting). + +Tip (for VS Code OCaml Platform users): You can destruct a value using a keybinding +Alt+D or on MacOS Option+D + +#### Typed holes + +OCaml-LSP has a concept of a "typed hole" syntactically represented as `_` +(underscore). A typed hole represents a well-typed "substitute" for an +expression. OCaml-LSP considers these underscores that occur in place of +expressions as a valid well-typed OCaml program: `let foo : int = _` (the typed +hole has type `int` here) or `let bar = _ 10` (the hole has type `int -> 'a`). +One can use such holes during development as temporary substitutes for +expressions and "plug" the holes later with appropriate expressions. + +Note, files that incorporate typed holes are *not* considered valid OCaml by the +OCaml compiler and, hence, cannot be compiled. + +Also, an underscore occurring in place of a pattern (for example `let _ = 10`) +should not be confused with a typed hole that occurs in place of an expression, +e.g., `let a = _`. + +#### Constructing values by type (experimental) + +OCaml-LSP can "construct" expressions based on the type required and offer them +during auto-completion. For example, typing `_` (typed hole) in the snippet +below will trigger auto-completion (`|` is your cursor): + +```ocaml +(* file foo.ml *) +type t = A | B of string option + +(* file bar.ml *) +let v : Foo.t = _| +``` + +The auto-completion offers completions `Foo.A` and `Foo.B _`. You can further +construct values by placing the cursor as such: `Foo.B _|` and triggering code +action "Construct an expression" which offers completions `None` and `Some _`. +Trigger the same code action in `Some _|` will offer `""` - one of the possible +expressions to replace the typed hole with. + +Constructing a value is thus triggered either by typing `_` in place of an +expression or trigger the code action "Construct an Expression". Also, the type +of the value needs to be non-polymorphic to construct a meaningful value. + +Tip (for VS Code OCaml Platform users): You can construct a value using a keybinding +Alt+C or on MacOS Option+C + ## Integration with other tools ### Source file formatting: OCamlFormat & Refmt @@ -96,7 +233,7 @@ formatting support. Note, however, that OCaml-LSP requires presence of OCamlFormat configuration file, called `.ocamlformat`, in the project root to be able to format source files in your project. -### Formatting code on hover +### Formatting code on hover When you hover the cursor over OCaml code, the extension shows you the type of the symbol. To get nicely formatted types, install @@ -118,11 +255,13 @@ for errors such as logged exceptions. # clone repo with submodules git clone --recursive git@github.com:ocaml/ocaml-lsp.git +cd ocaml-lsp + # if you already cloned, pull submodules git submodule update --init --recursive # create local switch (or use global one) -opam switch create . ocaml-base-compiler.4.14.0 +opam switch --yes create . ocaml-base-compiler.4.14.0 # don't forget to set your environment to use the local switch eval $(opam env) @@ -164,8 +303,9 @@ the lsp protocol covers a wider scope than merlin. ## Comparison to other LSP Servers for OCaml -Note that the comparisons below makes no claims of being objective and may be -entirely out of date: +Note that the comparisons below make no claims of being objective and may be +entirely out of +date. Also, both servers seem deprecated. - [reason-language-server](https://github.com/jaredly/reason-language-server) This server supports diff --git a/dune-project b/dune-project index 9f198d9ac..92e58166f 100644 --- a/dune-project +++ b/dune-project @@ -58,6 +58,7 @@ possible and does not make any assumptions about IO. ordering dune-build-info spawn + (ocamlc-loc (>= 3.5.0)) (omd (and (>= 1.3.2) (< 2.0.0~alpha1))) (octavius (>= 1.2.2)) (uutf (>= 1.0.2)) diff --git a/flake.lock b/flake.lock index 05e46ad4b..b04aad6b0 100644 --- a/flake.lock +++ b/flake.lock @@ -81,27 +81,27 @@ }, "nixpkgs": { "locked": { - "lastModified": 1657802959, - "narHash": "sha256-9+JWARSdlL8KiH3ymnKDXltE1vM+/WEJ78F5B1kjXys=", + "lastModified": 1666424192, + "narHash": "sha256-rb/a7Kg9s31jqkvdOQHFrUc5ig5kB+O2ZKB8mjU2kW8=", "owner": "nixos", "repo": "nixpkgs", - "rev": "4a01ca36d6bfc133bc617e661916a81327c9bbc8", + "rev": "4f8287f3d597c73b0d706cfad028c2d51821f64d", "type": "github" }, "original": { "owner": "nixos", - "ref": "nixos-unstable", + "ref": "nixpkgs-unstable", "repo": "nixpkgs", "type": "github" } }, "nixpkgs_2": { "locked": { - "lastModified": 1640418986, - "narHash": "sha256-a8GGtxn2iL3WAkY5H+4E0s3Q7XJt6bTOvos9qqxT5OQ=", - "owner": "NixOS", + "lastModified": 1657802959, + "narHash": "sha256-9+JWARSdlL8KiH3ymnKDXltE1vM+/WEJ78F5B1kjXys=", + "owner": "nixos", "repo": "nixpkgs", - "rev": "5c37ad87222cfc1ec36d6cd1364514a9efc2f7f2", + "rev": "4a01ca36d6bfc133bc617e661916a81327c9bbc8", "type": "github" }, "original": { @@ -116,7 +116,7 @@ "flake-compat": "flake-compat", "flake-utils": "flake-utils_2", "mirage-opam-overlays": "mirage-opam-overlays", - "nixpkgs": "nixpkgs", + "nixpkgs": "nixpkgs_2", "opam-overlays": "opam-overlays", "opam-repository": [ "opam-repository" @@ -124,11 +124,11 @@ "opam2json": "opam2json" }, "locked": { - "lastModified": 1663958540, - "narHash": "sha256-5IFRW65Bonu0KphZig1pT2EJvm4lLLUYddHGZiQTYDA=", + "lastModified": 1666349768, + "narHash": "sha256-5aq31gf/CBH/N75PPgmGfl7zwSslwwI6zfEkycYchKQ=", "owner": "tweag", "repo": "opam-nix", - "rev": "c7430da9ade302bad75f7e4cfacd9eca12783cca", + "rev": "877c1175d47c540fdef1caeb48dbb30448c2635f", "type": "github" }, "original": { @@ -156,11 +156,11 @@ "opam-repository": { "flake": false, "locked": { - "lastModified": 1664888712, - "narHash": "sha256-lOsurp/727wZv1LQ1NEKE/lpxXkrRNi62RSjQuvdcRs=", + "lastModified": 1666348254, + "narHash": "sha256-CBGnheemS5frVA4YE43y3Omd+GpiyUy9sBjI6XBQFlU=", "owner": "ocaml", "repo": "opam-repository", - "rev": "127acdff77b608ce60174e2dbf2e17362f3688f8", + "rev": "a5e83808328a0905a297cae4d1581b31e4494b13", "type": "github" }, "original": { @@ -171,14 +171,17 @@ }, "opam2json": { "inputs": { - "nixpkgs": "nixpkgs_2" + "nixpkgs": [ + "opam-nix", + "nixpkgs" + ] }, "locked": { - "lastModified": 1651529032, - "narHash": "sha256-fe8bm/V/4r2iNxgbitT2sXBqDHQ0GBSnSUSBg/1aXoI=", + "lastModified": 1665671715, + "narHash": "sha256-7f75C6fIkiLzfkwLpJxlQIKf+YORGsXGV8Dr2LDDi+A=", "owner": "tweag", "repo": "opam2json", - "rev": "e8e9f2fa86ef124b9f7b8db41d3d19471c1d8901", + "rev": "32fa2dcd993a27f9e75ee46fb8b78a7cd5d05113", "type": "github" }, "original": { @@ -191,10 +194,7 @@ "inputs": { "flake-utils": "flake-utils", "git-subrepo-src": "git-subrepo-src", - "nixpkgs": [ - "opam-nix", - "nixpkgs" - ], + "nixpkgs": "nixpkgs", "opam-nix": "opam-nix", "opam-repository": "opam-repository" } diff --git a/flake.nix b/flake.nix index dd58b6ab5..c67af0eb1 100644 --- a/flake.nix +++ b/flake.nix @@ -1,7 +1,7 @@ { inputs = { flake-utils.url = "github:numtide/flake-utils"; - nixpkgs.follows = "opam-nix/nixpkgs"; + nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable"; opam-nix = { url = "github:tweag/opam-nix"; inputs.opam-repository.follows = "opam-repository"; @@ -17,7 +17,7 @@ }; }; - outputs = { self, flake-utils, opam-nix, nixpkgs, ... }@inputs: + outputs = { self, flake-utils, opam-nix, opam-repository, nixpkgs, ... }@inputs: let package = "ocaml-lsp-server"; in flake-utils.lib.eachDefaultSystem (system: let @@ -33,7 +33,6 @@ ppx_yojson_conv = "*"; cinaps = "*"; ppx_expect = "*"; - ocamlformat-rpc = "*"; ocamlfind = "1.9.2"; }; packagesFromNames = set: @@ -44,7 +43,13 @@ ( let scope = - on.buildOpamProject { resolveArgs = { with-test = true; }; } package + on.buildOpamProject + { + repos = [ opam-repository ]; + inherit pkgs; + resolveArgs = { with-test = true; }; + } + package ./. (allPackages); overlay = final: prev: { @@ -73,6 +78,7 @@ git-subrepo ocamlformat_0_21_0 yarn + dune-release ]) ++ packagesFromNames devPackages; inputsFrom = [ self.packages.${system}.default ] ++ packagesFromNames localPackages; diff --git a/ocaml-lsp-server.opam b/ocaml-lsp-server.opam index 5d7ce84f8..0e72df06e 100644 --- a/ocaml-lsp-server.opam +++ b/ocaml-lsp-server.opam @@ -32,6 +32,7 @@ depends: [ "ordering" "dune-build-info" "spawn" + "ocamlc-loc" {>= "3.5.0"} "omd" {>= "1.3.2" & < "2.0.0~alpha1"} "octavius" {>= "1.2.2"} "uutf" {>= "1.0.2"} diff --git a/ocaml-lsp-server/docs/ocamllsp/inferIntf-spec.md b/ocaml-lsp-server/docs/ocamllsp/inferIntf-spec.md index ae88f2415..1da302e65 100644 --- a/ocaml-lsp-server/docs/ocamllsp/inferIntf-spec.md +++ b/ocaml-lsp-server/docs/ocamllsp/inferIntf-spec.md @@ -1,4 +1,4 @@ -#### Infer Interface Request +# Infer Interface Request Infer Interface Request is sent from the client to the server to get the infered interface for a given module implementation. @@ -10,21 +10,21 @@ If the file cannot be found in the document store, an error will be returned. Warning: this custom request is meant to be consumed by `ocaml-vscode-platform` exclusively, it can be removed any time and should not be relied on. -##### Client capability +## Client capability nothing that should be noted -##### Server capability +## Server capability property name: `handleInferIntf` property type: `boolean` -##### Request +## Request - method: `ocamllsp/inferIntf` - params: `DocumentUri` (see [`DocumentUri`](https://microsoft.github.io/language-server-protocol/specifications/specification-current/#uri) in LSP specification) -##### Response +## Response - result: String - error: code and message set in case an exception happens during the processing of the request. diff --git a/ocaml-lsp-server/docs/ocamllsp/switchImplIntf-spec.md b/ocaml-lsp-server/docs/ocamllsp/switchImplIntf-spec.md index 819b885ac..9eef06f95 100644 --- a/ocaml-lsp-server/docs/ocamllsp/switchImplIntf-spec.md +++ b/ocaml-lsp-server/docs/ocamllsp/switchImplIntf-spec.md @@ -1,4 +1,4 @@ -#### Switch Implementation/Interface Request +# Switch Implementation/Interface Request Switch Implementation/Interface Request is sent from client to server to get URI(s) of the file(s) that the current file can switch to, e.g., if the user @@ -12,22 +12,22 @@ for creation is returned, e.g., if a user wants to switch from "foo.ml", but no files already exist in the project that could be returned, a URI for "foo.mli" is returned. -##### Client capability +## Client capability nothing that should be noted -##### Server capability +## Server capability property name: `handleSwitchImplIntf` property type: `boolean` -##### Request +## Request - method: `ocamllsp/switchImplIntf` - params: `DocumentUri` (see [`DocumentUri`](https://microsoft.github.io/language-server-protocol/specifications/specification-current/#uri) in LSP specification) -##### Response +## Response - result: DocumentUri[] (non-empty) - error: code and message set in case an exception happens during the `ocamllsp/switchImplIntf` request. diff --git a/ocaml-lsp-server/docs/ocamllsp/wrappingAstNode-spec.md b/ocaml-lsp-server/docs/ocamllsp/wrappingAstNode-spec.md index cbb562ed1..3a3525d7c 100644 --- a/ocaml-lsp-server/docs/ocamllsp/wrappingAstNode-spec.md +++ b/ocaml-lsp-server/docs/ocamllsp/wrappingAstNode-spec.md @@ -1,4 +1,6 @@ -#### Wrapping AST Node +# Wrapping AST Node + +## Description (Could also be named `Enclosing AST Node`) @@ -30,16 +32,16 @@ The document URI in the request has to be open before sending a the request. If Note: stability of this custom request is not guaranteed. Talk to the maintainers if you want to depend on it. -##### Client capability +## Client capability nothing that should be noted -##### Server capability +## Server capability property name: `handleWrappingAstNode` property type: `boolean` -##### Request +## Request - method: `ocamllsp/wrappingAstNode` - params: @@ -51,7 +53,7 @@ property type: `boolean` } ``` -##### Response +## Response - result: `Range | null` - error: code and message set in case an exception happens during the processing of the request. diff --git a/ocaml-lsp-server/src/code_actions.ml b/ocaml-lsp-server/src/code_actions.ml index 2b5785ce3..fb834270c 100644 --- a/ocaml-lsp-server/src/code_actions.ml +++ b/ocaml-lsp-server/src/code_actions.ml @@ -90,6 +90,7 @@ let compute server (params : CodeActionParams.t) = ; Action_add_rec.t ; Action_mark_remove_unused.mark ; Action_mark_remove_unused.remove + ; Action_inline.t ] in List.concat diff --git a/ocaml-lsp-server/src/code_actions/action_add_rec.ml b/ocaml-lsp-server/src/code_actions/action_add_rec.ml index d1e3634f0..04d36eceb 100644 --- a/ocaml-lsp-server/src/code_actions/action_add_rec.ml +++ b/ocaml-lsp-server/src/code_actions/action_add_rec.ml @@ -65,25 +65,28 @@ let code_action_add_rec uri diagnostics doc loc = () let code_action doc (params : CodeActionParams.t) = - let pos_start = Position.logical params.range.start in - let m_diagnostic = - List.find params.context.diagnostics ~f:(fun d -> - let is_unbound () = - String.is_prefix d.Diagnostic.message ~prefix:"Unbound value" - and in_range () = - match Position.compare_inclusion params.range.start d.range with - | `Outside _ -> false - | `Inside -> true - in - in_range () && is_unbound ()) - in - match m_diagnostic with - | None -> Fiber.return None - | Some d -> - let+ loc = - Document.with_pipeline_exn doc (fun pipeline -> - has_missing_rec pipeline pos_start) + match Document.kind doc with + | `Other -> Fiber.return None + | `Merlin merlin -> ( + let pos_start = Position.logical params.range.start in + let m_diagnostic = + List.find params.context.diagnostics ~f:(fun d -> + let is_unbound () = + String.is_prefix d.Diagnostic.message ~prefix:"Unbound value" + and in_range () = + match Position.compare_inclusion params.range.start d.range with + | `Outside _ -> false + | `Inside -> true + in + in_range () && is_unbound ()) in - Option.map loc ~f:(code_action_add_rec params.textDocument.uri [ d ] doc) + match m_diagnostic with + | None -> Fiber.return None + | Some d -> + let+ loc = + Document.Merlin.with_pipeline_exn merlin (fun pipeline -> + has_missing_rec pipeline pos_start) + in + Option.map loc ~f:(code_action_add_rec params.textDocument.uri [ d ] doc)) let t = { Code_action.kind = QuickFix; run = code_action } diff --git a/ocaml-lsp-server/src/code_actions/action_construct.ml b/ocaml-lsp-server/src/code_actions/action_construct.ml index 197364785..d9f2d7330 100644 --- a/ocaml-lsp-server/src/code_actions/action_construct.ml +++ b/ocaml-lsp-server/src/code_actions/action_construct.ml @@ -5,8 +5,9 @@ let action_kind = "construct" let code_action doc (params : CodeActionParams.t) = match Document.kind doc with - | Intf -> Fiber.return None - | Impl -> + | `Other -> Fiber.return None + | `Merlin m when Document.Merlin.kind m = Intf -> Fiber.return None + | `Merlin merlin -> 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 *) @@ -17,7 +18,7 @@ let code_action doc (params : CodeActionParams.t) = if not (Typed_hole.can_be_hole prefix) then Fiber.return None else let+ structures = - Document.with_pipeline_exn doc (fun pipeline -> + Document.Merlin.with_pipeline_exn merlin (fun pipeline -> let typedtree = let typer = Mpipeline.typer_result pipeline in Mtyper.get_typedtree typer diff --git a/ocaml-lsp-server/src/code_actions/action_destruct.ml b/ocaml-lsp-server/src/code_actions/action_destruct.ml index 129782dea..74a8a8fe1 100644 --- a/ocaml-lsp-server/src/code_actions/action_destruct.ml +++ b/ocaml-lsp-server/src/code_actions/action_destruct.ml @@ -40,14 +40,15 @@ 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 -> Fiber.return None + | `Merlin m when Document.Merlin.kind m = Intf -> Fiber.return None + | `Merlin merlin -> ( let command = let start = Position.logical params.range.start in let finish = Position.logical params.range.end_ in Query_protocol.Case_analysis (start, finish) in - let* res = Document.dispatch doc command in + let* res = Document.Merlin.dispatch merlin command in match res with | Ok (loc, newText) -> let+ newText = 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..57b98213f 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,9 @@ 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 -> Fiber.return None + | `Merlin m when Document.Merlin.kind m = Impl -> Fiber.return None + | `Merlin _ -> ( let* intf = Inference.infer_intf state doc in match intf with | None -> Fiber.return None diff --git a/ocaml-lsp-server/src/code_actions/action_inline.ml b/ocaml-lsp-server/src/code_actions/action_inline.ml new file mode 100644 index 000000000..d5816132d --- /dev/null +++ b/ocaml-lsp-server/src/code_actions/action_inline.ml @@ -0,0 +1,460 @@ +open Import +module H = Ocaml_parsing.Ast_helper + +let action_title = "Inline into uses" + +type inline_task = + { inlined_var : Ident.t + ; inlined_expr : Typedtree.expression (** the expression to inline *) + } + +let find_path_by_name id env = + try Some (fst (Ocaml_typing.Env.find_value_by_name id env)) + with Not_found -> None + +let check_shadowing (inlined_expr : Typedtree.expression) new_env = + let module I = Ocaml_typing.Tast_iterator in + let orig_env = inlined_expr.exp_env in + let exception Env_mismatch of (Longident.t * [ `Unbound | `Shadowed ]) in + let expr_iter (iter : I.iterator) (expr : Typedtree.expression) = + match expr.exp_desc with + | Texp_ident (path, { txt = ident; _ }, _) -> ( + let in_orig_env = + find_path_by_name ident orig_env + |> Option.map ~f:(Path.same path) + |> Option.value ~default:false + in + if in_orig_env then + match find_path_by_name ident new_env with + | Some path' -> + if not (Path.same path path') then + raise_notrace (Env_mismatch (ident, `Shadowed)) + | None -> raise_notrace (Env_mismatch (ident, `Unbound))) + | _ -> I.default_iterator.expr iter expr + in + let iter = { I.default_iterator with expr = expr_iter } in + try + iter.expr iter inlined_expr; + Ok () + with Env_mismatch m -> Error m + +let string_of_error (ident, reason) = + let reason = + match reason with + | `Unbound -> "unbound" + | `Shadowed -> "shadowed" + in + Format.asprintf + "'%a' is %s in inlining context" + Pprintast.longident + ident + reason + +let contains loc pos = + match Position.compare_inclusion pos (Range.of_loc loc) with + | `Outside _ -> false + | `Inside -> true + +let find_inline_task typedtree pos = + let exception Found of inline_task in + let module I = Ocaml_typing.Tast_iterator in + let expr_iter (iter : I.iterator) (expr : Typedtree.expression) = + if contains expr.exp_loc pos then + match expr.exp_desc with + | Texp_let + ( Nonrecursive + , [ { vb_pat = { pat_desc = Tpat_var (inlined_var, { loc; _ }); _ } + ; vb_expr = inlined_expr + ; _ + } + ] + , _ ) + when contains loc pos -> + raise_notrace (Found { inlined_var; inlined_expr }) + | _ -> I.default_iterator.expr iter expr + in + let structure_item_iter (iter : I.iterator) (item : Typedtree.structure_item) + = + if contains item.str_loc pos then + match item.str_desc with + | Tstr_value + ( Nonrecursive + , [ { vb_pat = { pat_desc = Tpat_var (inlined_var, { loc; _ }); _ } + ; vb_expr = inlined_expr + ; _ + } + ] ) + when contains loc pos -> + raise_notrace (Found { inlined_var; inlined_expr }) + | _ -> I.default_iterator.structure_item iter item + in + let iterator = + { I.default_iterator with + expr = expr_iter + ; structure_item = structure_item_iter + } + in + try + iterator.structure iterator typedtree; + None + with Found task -> Some task + +(** [find_parsetree_loc pl loc] finds an expression node in the parsetree with + location [loc] *) +let find_parsetree_loc pipeline loc = + let exception Found of Parsetree.expression in + try + let expr_iter (iter : Ast_iterator.iterator) (expr : Parsetree.expression) = + if Loc.compare expr.pexp_loc loc = 0 then raise_notrace (Found expr) + else Ast_iterator.default_iterator.expr iter expr + in + let iterator = { Ast_iterator.default_iterator with expr = expr_iter } in + (match Mpipeline.reader_parsetree pipeline with + | `Implementation s -> iterator.structure iterator s + | `Interface _ -> ()); + None + with Found e -> Some e + +let find_parsetree_loc_exn pipeline loc = + Option.value_exn (find_parsetree_loc pipeline loc) + +(** [strip_attribute name e] removes all instances of the attribute called + [name] in [e]. *) +let strip_attribute attr_name expr = + let module M = Ocaml_parsing.Ast_mapper in + let expr_map (map : M.mapper) expr = + { (M.default_mapper.expr map expr) with + pexp_attributes = + List.filter expr.pexp_attributes ~f:(fun (a : Parsetree.attribute) -> + not (String.equal a.attr_name.txt attr_name)) + } + in + let mapper = { M.default_mapper with expr = expr_map } in + mapper.expr mapper expr + +(** Overapproximation of the number of uses of a [Path.t] in an expression. *) +module Uses : sig + type t + + val find : t -> Path.t -> int option + + val of_typedtree : Typedtree.expression -> t +end = struct + type t = int Path.Map.t + + let find m k = Path.Map.find_opt k m + + let of_typedtree (expr : Typedtree.expression) = + let module I = Ocaml_typing.Tast_iterator in + let uses = ref Path.Map.empty in + let expr_iter (iter : I.iterator) (expr : Typedtree.expression) = + match expr.exp_desc with + | Texp_ident (path, _, _) -> + uses := + Path.Map.update + path + (function + | Some c -> Some (c + 1) + | None -> Some 1) + !uses + | _ -> I.default_iterator.expr iter expr + in + let iterator = { I.default_iterator with expr = expr_iter } in + iterator.expr iterator expr; + !uses +end + +(** Mapping from [Location.t] to [Path.t]. Computed from the typedtree. Useful + for determining whether two parsetree identifiers refer to the same path. *) +module Paths : sig + type t + + val find : t -> Loc.t -> Path.t option + + val of_typedtree : Typedtree.expression -> t + + val same_path : t -> Loc.t -> Loc.t -> bool +end = struct + type t = Path.t Loc.Map.t + + let find = Loc.Map.find + + let of_typedtree (expr : Typedtree.expression) = + let module I = Ocaml_typing.Tast_iterator in + let paths = ref Loc.Map.empty in + let expr_iter (iter : I.iterator) (expr : Typedtree.expression) = + match expr.exp_desc with + | Texp_ident (path, { loc; _ }, _) -> paths := Loc.Map.set !paths loc path + | _ -> I.default_iterator.expr iter expr + in + let pat_iter (type k) (iter : I.iterator) + (pat : k Typedtree.general_pattern) = + match pat.pat_desc with + | Tpat_var (id, { loc; _ }) -> paths := Loc.Map.set !paths loc (Pident id) + | Tpat_alias (pat, id, { loc; _ }) -> + paths := Loc.Map.set !paths loc (Pident id); + I.default_iterator.pat iter pat + | _ -> I.default_iterator.pat iter pat + in + let iterator = + { I.default_iterator with expr = expr_iter; pat = pat_iter } + in + iterator.expr iterator expr; + !paths + + let same_path ps l l' = + match (find ps l, find ps l') with + | Some p, Some p' -> Path.same p p' + | _ -> false +end + +let subst same subst_expr subst_id body = + let module M = Ocaml_parsing.Ast_mapper in + let expr_map (map : M.mapper) (expr : Parsetree.expression) = + match expr.pexp_desc with + | Pexp_ident id when same subst_id id -> subst_expr + | _ -> M.default_mapper.expr map expr + in + let mapper = { M.default_mapper with expr = expr_map } in + mapper.expr mapper body + +(** Rough check for expressions that can be duplicated without duplicating any + side effects. *) +let rec is_pure (expr : Parsetree.expression) = + match expr.pexp_desc with + | Pexp_ident _ | Pexp_constant _ | Pexp_hole | Pexp_unreachable -> true + | Pexp_field (e, _) | Pexp_constraint (e, _) -> is_pure e + | _ -> false + +let rec find_map_remove ~f = function + | [] -> (None, []) + | x :: xs -> ( + match f x with + | Some x' -> (Some x', xs) + | None -> + let ret, xs' = find_map_remove ~f xs in + (ret, x :: xs')) + +let rec beta_reduce (uses : Uses.t) (paths : Paths.t) + (app : Parsetree.expression) = + let rec beta_reduce_arg (pat : Parsetree.pattern) body arg = + let default () = + H.Exp.let_ Nonrecursive [ H.Vb.mk pat arg ] (beta_reduce uses paths body) + in + match pat.ppat_desc with + | Ppat_any | Ppat_construct ({ txt = Lident "()"; _ }, _) -> + beta_reduce uses paths body + | Ppat_var param | Ppat_constraint ({ ppat_desc = Ppat_var param; _ }, _) + -> ( + let open Option.O in + let m_uses = + let* path = Paths.find paths param.loc in + Uses.find uses path + in + let same_path paths (id : _ H.with_loc) (id' : _ H.with_loc) = + Paths.same_path paths id.loc id'.loc + in + match m_uses with + | Some 0 -> beta_reduce uses paths body + | Some 1 -> + beta_reduce uses paths (subst (same_path paths) arg param body) + | Some _ | None -> + if is_pure arg then + beta_reduce uses paths (subst (same_path paths) arg param body) + else + (* if the parameter is used multiple times in the body, introduce a + let binding so that the parameter is evaluated only once *) + default ()) + | Ppat_tuple pats -> ( + match arg.pexp_desc with + | Pexp_tuple args -> + List.fold_left2 + ~f:(fun body pat arg -> beta_reduce_arg pat body arg) + ~init:body + pats + args + | _ -> default ()) + | _ -> default () + in + let apply func args = + if List.is_empty args then func else H.Exp.apply func args + in + match app.pexp_desc with + | Pexp_apply + ( { pexp_desc = Pexp_fun (Nolabel, None, pat, body); _ } + , (Nolabel, arg) :: args' ) -> beta_reduce_arg pat (apply body args') arg + | Pexp_apply + ({ pexp_desc = Pexp_fun ((Labelled l as lbl), None, pat, body); _ }, args) + -> ( + let m_matching_arg, args' = + find_map_remove args ~f:(function + | Asttypes.Labelled l', e when String.equal l l' -> Some e + | _ -> None) + in + match m_matching_arg with + | Some arg -> beta_reduce_arg pat (apply body args') arg + | None -> H.Exp.fun_ lbl None pat (beta_reduce uses paths (apply body args)) + ) + | _ -> app + +let inlined_text pipeline task = + let open Option.O in + let+ expr = find_parsetree_loc pipeline task.inlined_expr.exp_loc in + let expr = strip_attribute "merlin.loc" expr in + Format.asprintf "(%a)" Pprintast.expression expr + +(** [inline_edits pipeline task] returns a list of inlining edits and an + optional error value. An error will be generated if any of the potential + inlinings is not allowed due to shadowing. The successful edits will still + be returned *) +let inline_edits pipeline task = + let module I = Ocaml_typing.Tast_iterator in + let open Option.O in + let+ newText = inlined_text pipeline task in + let make_edit newText loc = + TextEdit.create ~newText ~range:(Range.of_loc loc) + in + let edits = Queue.create () in + let error = ref None in + + let insert_edit newText loc = Queue.push edits (make_edit newText loc) in + let not_shadowed env = + match check_shadowing task.inlined_expr env with + | Ok () -> true + | Error e -> + error := Some e; + false + in + + (* inlining into an argument context has some special cases *) + let arg_iter env (iter : I.iterator) (label : Asttypes.arg_label) + (m_arg_expr : Typedtree.expression option) = + match (label, m_arg_expr) with + (* handle the labeled argument shorthand `f ~x` when inlining `x` *) + | ( Labelled name + , Some { exp_desc = Texp_ident (Pident id, { loc; _ }, _); _ } ) + (* inlining is allowed for optional arguments that are being passed a Some + parameter, i.e. `x` may be inlined in `let x = 1 in (fun ?(x = 0) -> x) + ~x` *) + | ( Optional name + , Some + { exp_desc = + (* construct is part of desugaring, assumed to be Some *) + Texp_construct + ( _ + , _ + , [ { exp_desc = Texp_ident (Pident id, { loc; _ }, _); _ } ] ) + ; _ + } ) + when Ident.same task.inlined_var id && not_shadowed env -> + let newText = sprintf "%s:%s" name newText in + insert_edit newText loc + | Optional _, Some ({ exp_desc = Texp_construct _; _ } as arg_expr) -> + iter.expr iter arg_expr + (* inlining is _not_ allowed for optional arguments that are being passed an + optional parameter i.e. `x` may _not_ be inlined in `let x = Some 1 in + (fun ?(x = 0) -> x) ?x` *) + | Optional _, Some _ -> () + | _, _ -> Option.iter m_arg_expr ~f:(iter.expr iter) + in + + let uses = Uses.of_typedtree task.inlined_expr in + let paths = Paths.of_typedtree task.inlined_expr in + let inlined_pexpr = + find_parsetree_loc_exn pipeline task.inlined_expr.exp_loc + in + + let expr_iter (iter : I.iterator) (expr : Typedtree.expression) = + match expr.exp_desc with + (* when inlining into an application context, attempt to beta reduce the + result *) + | Texp_apply ({ exp_desc = Texp_ident (Pident id, _, _); _ }, _) + when Ident.same task.inlined_var id && not_shadowed expr.exp_env -> + let reduced_pexpr = + let app_pexpr = find_parsetree_loc_exn pipeline expr.exp_loc in + match app_pexpr.pexp_desc with + | Pexp_apply ({ pexp_desc = Pexp_ident _; _ }, args) -> + beta_reduce uses paths (H.Exp.apply inlined_pexpr args) + | _ -> app_pexpr + in + let newText = + Format.asprintf "(%a)" Pprintast.expression + @@ strip_attribute "merlin.loc" reduced_pexpr + in + insert_edit newText expr.exp_loc + | Texp_apply (func, args) -> + iter.expr iter func; + List.iter args ~f:(fun (l, e) -> arg_iter expr.exp_env iter l e) + | Texp_ident (Pident id, { loc; _ }, _) + when Ident.same task.inlined_var id && not_shadowed expr.exp_env -> + insert_edit newText loc + | _ -> I.default_iterator.expr iter expr + in + let iterator = { I.default_iterator with expr = expr_iter } in + + let edits = + match Mtyper.get_typedtree (Mpipeline.typer_result pipeline) with + | `Interface _ -> [] + | `Implementation structure -> + iterator.structure iterator structure; + Queue.to_list edits + in + (edits, !error) + +let code_action doc (params : CodeActionParams.t) = + let open Option.O in + match Document.kind doc with + | `Other -> Fiber.return None + | `Merlin merlin -> + Document.Merlin.with_pipeline_exn merlin (fun pipeline -> + let* typedtree = + match Mtyper.get_typedtree (Mpipeline.typer_result pipeline) with + | `Interface _ -> None + | `Implementation x -> Some x + in + let* task = find_inline_task typedtree params.range.start in + inline_edits pipeline task) + |> Fiber.map ~f:(fun m_edits -> + let* edits, m_error = m_edits in + match (edits, m_error) with + | [], None -> None + | [], Some error -> + let action = + CodeAction.create + ~title:action_title + ~kind:CodeActionKind.RefactorInline + ~isPreferred:false + ~disabled: + (CodeAction.create_disabled ~reason:(string_of_error error)) + () + in + Some action + | _ :: _, (Some _ | None) -> + let edit = + let version = Document.version doc in + let textDocument = + OptionalVersionedTextDocumentIdentifier.create + ~uri:params.textDocument.uri + ~version + () + in + let edit = + TextDocumentEdit.create + ~textDocument + ~edits:(List.map edits ~f:(fun e -> `TextEdit e)) + in + WorkspaceEdit.create + ~documentChanges:[ `TextDocumentEdit edit ] + () + in + let action = + CodeAction.create + ~title:action_title + ~kind:CodeActionKind.RefactorInline + ~edit + ~isPreferred:false + () + in + Some action) + +let t = { Code_action.kind = RefactorInline; run = code_action } diff --git a/ocaml-lsp-server/src/code_actions/action_inline.mli b/ocaml-lsp-server/src/code_actions/action_inline.mli new file mode 100644 index 000000000..0caac27b3 --- /dev/null +++ b/ocaml-lsp-server/src/code_actions/action_inline.mli @@ -0,0 +1 @@ +val t : Code_action.t diff --git a/ocaml-lsp-server/src/code_actions/action_mark_remove_unused.ml b/ocaml-lsp-server/src/code_actions/action_mark_remove_unused.ml index 9fd8712cb..f999edeb0 100644 --- a/ocaml-lsp-server/src/code_actions/action_mark_remove_unused.ml +++ b/ocaml-lsp-server/src/code_actions/action_mark_remove_unused.ml @@ -71,7 +71,7 @@ let rec mark_value_unused_edit name contexts = let code_action_mark_value_unused doc (diagnostic : Diagnostic.t) = let open Option.O in - Document.with_pipeline_exn doc (fun pipeline -> + Document.Merlin.with_pipeline_exn (Document.merlin_exn doc) (fun pipeline -> let var_name = slice doc diagnostic.range in let pos = diagnostic.range.start in let+ text_edit = @@ -125,10 +125,9 @@ let code_action_remove_range doc (diagnostic : Diagnostic.t) range = (* Create a code action that removes the value mentioned in [diagnostic]. *) let code_action_remove_value doc pos (diagnostic : Diagnostic.t) = - Document.with_pipeline_exn doc (fun pipeline -> + Document.Merlin.with_pipeline_exn (Document.merlin_exn doc) (fun pipeline -> let var_name = slice doc diagnostic.range in - enclosing_pos pipeline pos - |> List.map ~f:(fun (_, x) -> x) + enclosing_pos pipeline pos |> List.map ~f:snd |> enclosing_value_binding_range var_name |> Option.map ~f:(fun range -> code_action_remove_range doc diagnostic range)) diff --git a/ocaml-lsp-server/src/code_actions/action_refactor_open.ml b/ocaml-lsp-server/src/code_actions/action_refactor_open.ml index 9cb080d24..b03c10736 100644 --- a/ocaml-lsp-server/src/code_actions/action_refactor_open.ml +++ b/ocaml-lsp-server/src/code_actions/action_refactor_open.ml @@ -3,30 +3,33 @@ open Fiber.O let code_action (mode : [ `Qualify | `Unqualify ]) (action_kind : string) doc (params : CodeActionParams.t) = - let+ res = - let command = - let pos_start = Position.logical params.range.start in - Query_protocol.Refactor_open (mode, pos_start) + match Document.kind doc with + | `Other -> Fiber.return None + | `Merlin doc -> ( + let+ res = + let command = + let pos_start = Position.logical params.range.start in + Query_protocol.Refactor_open (mode, pos_start) + in + Document.Merlin.dispatch_exn doc command in - Document.dispatch_exn doc command - in - match res with - | [] -> None - | changes -> - let code_action = - let edit : WorkspaceEdit.t = - let edits = - List.map changes ~f:(fun (newText, loc) -> - { TextEdit.newText; range = Range.of_loc loc }) + match res with + | [] -> None + | changes -> + let code_action = + let edit : WorkspaceEdit.t = + let edits = + List.map changes ~f:(fun (newText, loc) -> + { TextEdit.newText; range = Range.of_loc loc }) + in + let uri = params.textDocument.uri in + WorkspaceEdit.create ~changes:[ (uri, edits) ] () in - let uri = params.textDocument.uri in - WorkspaceEdit.create ~changes:[ (uri, edits) ] () + let kind = CodeActionKind.Other action_kind in + let title = String.capitalize_ascii action_kind in + CodeAction.create ~title ~kind ~edit ~isPreferred:false () in - let kind = CodeActionKind.Other action_kind in - let title = String.capitalize_ascii action_kind in - CodeAction.create ~title ~kind ~edit ~isPreferred:false () - in - Some code_action + Some code_action) let unqualify = let action_kind = "remove module name from identifiers" in diff --git a/ocaml-lsp-server/src/code_actions/action_type_annotate.ml b/ocaml-lsp-server/src/code_actions/action_type_annotate.ml index 9c0809777..cf7f41006 100644 --- a/ocaml-lsp-server/src/code_actions/action_type_annotate.ml +++ b/ocaml-lsp-server/src/code_actions/action_type_annotate.ml @@ -44,25 +44,31 @@ let code_action_of_type_enclosing uri doc (loc, typ) = () let code_action doc (params : CodeActionParams.t) = - let pos_start = Position.logical params.range.start in - let+ res = - Document.with_pipeline_exn doc (fun pipeline -> - let context = check_typeable_context pipeline pos_start in - match context with - | `Invalid -> None - | `Valid -> - let command = Query_protocol.Type_enclosing (None, pos_start, None) in - let config = Mpipeline.final_config pipeline in - let config = - { config with query = { config.query with verbosity = 0 } } - in - let pipeline = Mpipeline.make config (Document.source doc) in - Some (Query_commands.dispatch pipeline command)) - in - match res with - | None | Some [] | Some ((_, `Index _, _) :: _) -> None - | Some ((location, `String value, _) :: _) -> - code_action_of_type_enclosing params.textDocument.uri doc (location, value) + match Document.kind doc with + | `Other -> Fiber.return None + | `Merlin merlin -> ( + let pos_start = Position.logical params.range.start in + let+ res = + Document.Merlin.with_pipeline_exn merlin (fun pipeline -> + let context = check_typeable_context pipeline pos_start in + match context with + | `Invalid -> None + | `Valid -> + let command = + Query_protocol.Type_enclosing (None, pos_start, None) + in + let config = Mpipeline.final_config pipeline in + let config = + { config with query = { config.query with verbosity = 0 } } + in + let pipeline = Mpipeline.make config (Document.source doc) in + Some (Query_commands.dispatch pipeline command)) + in + match res with + | None | Some [] | Some ((_, `Index _, _) :: _) -> None + | Some ((location, `String value, _) :: _) -> + code_action_of_type_enclosing params.textDocument.uri doc (location, value) + ) let t = { Code_action.kind = CodeActionKind.Other action_kind; run = code_action } diff --git a/ocaml-lsp-server/src/compl.ml b/ocaml-lsp-server/src/compl.ml index dbcc1a2af..c1af60dd5 100644 --- a/ocaml-lsp-server/src/compl.ml +++ b/ocaml-lsp-server/src/compl.ml @@ -163,7 +163,10 @@ module Complete_by_prefix = struct let logical_pos = Position.logical pos in range_prefix pos - (prefix_of_position ~short_path:true (Document.source doc) logical_pos) + (prefix_of_position + ~short_path:true + (Document.Merlin.source doc) + logical_pos) in let completion_entries = match completion.context with @@ -183,7 +186,8 @@ module Complete_by_prefix = struct following [completionItem/resolve] requests *) let compl_params = let textDocument = - TextDocumentIdentifier.create ~uri:(Document.uri doc) + TextDocumentIdentifier.create + ~uri:(Document.uri (Document.Merlin.to_doc doc)) in CompletionParams.create ~textDocument ~position:pos () |> CompletionParams.yojson_of_t @@ -195,7 +199,7 @@ module Complete_by_prefix = struct let complete doc prefix pos = let+ (completion : Query_protocol.completions) = let logical_pos = Position.logical pos in - Document.with_pipeline_exn doc (dispatch_cmd ~prefix logical_pos) + Document.Merlin.with_pipeline_exn doc (dispatch_cmd ~prefix logical_pos) in process_dispatch_resp doc pos completion end @@ -252,54 +256,58 @@ let complete (state : State.t) ({ textDocument = { uri }; position = pos; _ } : CompletionParams.t) = Fiber.of_thunk (fun () -> let doc = Document_store.get state.store uri in - let+ items = - let position = Position.logical pos in - let prefix = - prefix_of_position ~short_path:false (Document.source doc) position - in - if not (Typed_hole.can_be_hole prefix) then - Complete_by_prefix.complete doc prefix pos - else - let reindex_sortText completion_items = - List.mapi completion_items ~f:(fun idx (ci : CompletionItem.t) -> - let sortText = Some (sortText_of_index idx) in - { ci with sortText }) - in - let preselect_first = function - | [] -> [] - | ci :: rest -> - { ci with CompletionItem.preselect = Some true } :: rest - in - let+ construct_cmd_resp, compl_by_prefix_resp = - Document.with_pipeline_exn doc (fun pipeline -> - let construct_cmd_resp = - Complete_with_construct.dispatch_cmd position pipeline - in - let compl_by_prefix_resp = - Complete_by_prefix.dispatch_cmd ~prefix position pipeline - in - (construct_cmd_resp, compl_by_prefix_resp)) + match Document.kind doc with + | `Other -> Fiber.return None + | `Merlin merlin -> + let+ items = + let position = Position.logical pos in + let prefix = + prefix_of_position ~short_path:false (Document.source doc) position in - let construct_completionItems = - let supportsJumpToNextHole = - State.experimental_client_capabilities state - |> Client.Experimental_capabilities.supportsJumpToNextHole + if not (Typed_hole.can_be_hole prefix) then + Complete_by_prefix.complete merlin prefix pos + else + let reindex_sortText completion_items = + List.mapi completion_items ~f:(fun idx (ci : CompletionItem.t) -> + let sortText = Some (sortText_of_index idx) in + { ci with sortText }) in - Complete_with_construct.process_dispatch_resp - ~supportsJumpToNextHole - construct_cmd_resp - in - let compl_by_prefix_completionItems = - Complete_by_prefix.process_dispatch_resp - doc - pos - compl_by_prefix_resp - in - construct_completionItems @ compl_by_prefix_completionItems - |> reindex_sortText |> preselect_first - in - Some - (`CompletionList (CompletionList.create ~isIncomplete:false ~items ()))) + let preselect_first = function + | [] -> [] + | ci :: rest -> + { ci with CompletionItem.preselect = Some true } :: rest + in + let+ construct_cmd_resp, compl_by_prefix_resp = + Document.Merlin.with_pipeline_exn merlin (fun pipeline -> + let construct_cmd_resp = + Complete_with_construct.dispatch_cmd position pipeline + in + let compl_by_prefix_resp = + Complete_by_prefix.dispatch_cmd ~prefix position pipeline + in + (construct_cmd_resp, compl_by_prefix_resp)) + in + let construct_completionItems = + let supportsJumpToNextHole = + State.experimental_client_capabilities state + |> Client.Experimental_capabilities.supportsJumpToNextHole + in + Complete_with_construct.process_dispatch_resp + ~supportsJumpToNextHole + construct_cmd_resp + in + let compl_by_prefix_completionItems = + Complete_by_prefix.process_dispatch_resp + merlin + pos + compl_by_prefix_resp + in + construct_completionItems @ compl_by_prefix_completionItems + |> reindex_sortText |> preselect_first + in + Some + (`CompletionList + (CompletionList.create ~isIncomplete:false ~items ()))) let format_doc ~markdown doc = match markdown with @@ -324,7 +332,7 @@ let resolve doc (compl : CompletionItem.t) (resolve : Resolve.t) query_doc let prefix = prefix_of_position ~short_path:true - (Document.source doc) + (Document.Merlin.source doc) logical_position in { position with @@ -333,7 +341,7 @@ let resolve doc (compl : CompletionItem.t) (resolve : Resolve.t) query_doc in let end_ = let suffix = - suffix_of_position (Document.source doc) logical_position + suffix_of_position (Document.Merlin.source doc) logical_position in { position with character = position.character + String.length suffix @@ -342,10 +350,12 @@ let resolve doc (compl : CompletionItem.t) (resolve : Resolve.t) query_doc let range = Range.create ~start ~end_ in TextDocumentContentChangeEvent.create ~range ~text:compl.label () in - Document.update_text doc [ complete ] + Document.update_text (Document.Merlin.to_doc doc) [ complete ] in let+ documentation = - let+ documentation = query_doc doc logical_position in + let+ documentation = + query_doc (Document.merlin_exn doc) logical_position + in Option.map ~f:(format_doc ~markdown) documentation in { compl with documentation; data = None }) diff --git a/ocaml-lsp-server/src/compl.mli b/ocaml-lsp-server/src/compl.mli index 3021f4f4f..8d094e9ca 100644 --- a/ocaml-lsp-server/src/compl.mli +++ b/ocaml-lsp-server/src/compl.mli @@ -19,10 +19,10 @@ val complete : (** creates a server response for ["completionItem/resolve"] *) val resolve : - Document.t + Document.Merlin.t -> CompletionItem.t -> Resolve.t - -> (Document.t -> [> `Logical of int * int ] -> string option Fiber.t) + -> (Document.Merlin.t -> [> `Logical of int * int ] -> string option Fiber.t) -> markdown:bool -> CompletionItem.t Fiber.t diff --git a/ocaml-lsp-server/src/custom_requests/req_typed_holes.ml b/ocaml-lsp-server/src/custom_requests/req_typed_holes.ml index 6763f97ed..a26038bef 100644 --- a/ocaml-lsp-server/src/custom_requests/req_typed_holes.ml +++ b/ocaml-lsp-server/src/custom_requests/req_typed_holes.ml @@ -62,7 +62,9 @@ let on_request ~(params : Jsonrpc.Structured.t option) (state : State.t) = (Uri.to_string uri)) () | Some doc -> - let+ holes = Document.dispatch_exn doc Holes in + let+ holes = + Document.Merlin.dispatch_exn (Document.merlin_exn doc) Holes + in Json.yojson_of_list (fun (loc, _type) -> loc |> Range.of_loc |> Range.yojson_of_t) holes) diff --git a/ocaml-lsp-server/src/custom_requests/req_wrapping_ast_node.ml b/ocaml-lsp-server/src/custom_requests/req_wrapping_ast_node.ml index 97664ea37..d1378f268 100644 --- a/ocaml-lsp-server/src/custom_requests/req_wrapping_ast_node.ml +++ b/ocaml-lsp-server/src/custom_requests/req_wrapping_ast_node.ml @@ -34,34 +34,42 @@ let on_request ~params state = Request_params.of_jsonrpc_params_exn params in let doc = Document_store.get state.State.store text_document_uri in - let pos = Position.logical cursor_position in - let+ node = - Document.with_pipeline_exn doc (fun pipeline -> - let typer = Mpipeline.typer_result pipeline in - let pos = Mpipeline.get_lexing_pos pipeline pos in - let enclosing_nodes (* from smallest node to largest *) = - Mbrowse.enclosing - pos - [ Mbrowse.of_typedtree (Mtyper.get_typedtree typer) ] - in - let loc_of_structure_item { Typedtree.str_loc; _ } = str_loc in - let find_fst_structure_item_or_structure = function - | _, Browse_raw.Structure_item (str_item, _) -> - Some (loc_of_structure_item str_item) - | _, Structure { str_items; _ } -> ( - match str_items with - | [] -> None - | hd :: rest -> - let last = List.last rest |> Option.value ~default:hd in - let { Loc.loc_start; _ } = loc_of_structure_item hd in - let { Loc.loc_end; _ } = loc_of_structure_item last in - Some { Loc.loc_start; loc_end; loc_ghost = false }) - | _ -> None - in - List.find_map - enclosing_nodes - ~f:find_fst_structure_item_or_structure) - in - match node with - | None -> `Null - | Some loc -> Range.of_loc loc |> Range.yojson_of_t) + match Document.kind doc with + | `Other -> + Jsonrpc.Response.Error.raise + (Jsonrpc.Response.Error.make + ~code:InvalidRequest + ~message:"not a merlin document" + ()) + | `Merlin doc -> ( + let pos = Position.logical cursor_position in + let+ node = + Document.Merlin.with_pipeline_exn doc (fun pipeline -> + let typer = Mpipeline.typer_result pipeline in + let pos = Mpipeline.get_lexing_pos pipeline pos in + let enclosing_nodes (* from smallest node to largest *) = + Mbrowse.enclosing + pos + [ Mbrowse.of_typedtree (Mtyper.get_typedtree typer) ] + in + let loc_of_structure_item { Typedtree.str_loc; _ } = str_loc in + let find_fst_structure_item_or_structure = function + | _, Browse_raw.Structure_item (str_item, _) -> + Some (loc_of_structure_item str_item) + | _, Structure { str_items; _ } -> ( + match str_items with + | [] -> None + | hd :: rest -> + let last = List.last rest |> Option.value ~default:hd in + let { Loc.loc_start; _ } = loc_of_structure_item hd in + let { Loc.loc_end; _ } = loc_of_structure_item last in + Some { Loc.loc_start; loc_end; loc_ghost = false }) + | _ -> None + in + List.find_map + enclosing_nodes + ~f:find_fst_structure_item_or_structure) + in + match node with + | None -> `Null + | Some loc -> Range.of_loc loc |> Range.yojson_of_t)) diff --git a/ocaml-lsp-server/src/diagnostics.ml b/ocaml-lsp-server/src/diagnostics.ml index 5d83cc7ef..9095e9ec3 100644 --- a/ocaml-lsp-server/src/diagnostics.ml +++ b/ocaml-lsp-server/src/diagnostics.ml @@ -215,28 +215,10 @@ let tags_of_message ~src message = let extract_related_errors uri raw_message = match Ocamlc_loc.parse_raw raw_message with | `Message message :: related -> - let string_of_message message = - String.trim - (match (message : Ocamlc_loc.message) with - | Raw s -> s - | Structured { message; severity; file_excerpt = _ } -> - let severity = - match severity with - | Error -> "Error" - | Warning { code; name } -> - sprintf - "Warning %s" - (match (code, name) with - | None, Some name -> sprintf "[%s]" name - | Some code, None -> sprintf "%d" code - | Some code, Some name -> sprintf "%d [%s]" code name - | None, None -> assert false) - in - sprintf "%s: %s" severity message) - in + let string_of_message message = String.trim message in let related = let rec loop acc = function - | `Loc (_, loc) :: `Message m :: xs -> loop ((loc, m) :: acc) xs + | `Loc loc :: `Message m :: xs -> loop ((loc, m) :: acc) xs | [] -> List.rev acc | _ -> (* give up when we see something unexpected *) @@ -250,13 +232,13 @@ let extract_related_errors uri raw_message = match related with | [] -> None | related -> - let make_related ({ Ocamlc_loc.path = _; line; chars }, message) = + let make_related ({ Ocamlc_loc.path = _; lines; chars }, message) = let location = let start, end_ = let line_start, line_end = - match line with - | `Single i -> (i, i) - | `Range (i, j) -> (i, j) + match lines with + | Single i -> (i, i) + | Range (i, j) -> (i, j) in let char_start, char_end = match chars with @@ -277,7 +259,8 @@ let extract_related_errors uri raw_message = (string_of_message message, related) | _ -> (raw_message, None) -let merlin_diagnostics diagnostics doc = +let merlin_diagnostics diagnostics merlin = + let doc = Document.Merlin.to_doc merlin in let uri = Document.uri doc in let create_diagnostic = Diagnostic.create ~source:ocamllsp_source in let open Fiber.O in @@ -285,7 +268,7 @@ let merlin_diagnostics diagnostics doc = let command = Query_protocol.Errors { lexing = true; parsing = true; typing = true } in - Document.with_pipeline_exn doc (fun pipeline -> + Document.Merlin.with_pipeline_exn merlin (fun pipeline -> match Query_commands.dispatch pipeline command with | exception Merlin_extend.Extend_main.Handshake.Error error -> let message = diff --git a/ocaml-lsp-server/src/diagnostics.mli b/ocaml-lsp-server/src/diagnostics.mli index 8e30f4953..121bee5f5 100644 --- a/ocaml-lsp-server/src/diagnostics.mli +++ b/ocaml-lsp-server/src/diagnostics.mli @@ -36,7 +36,7 @@ val disconnect : t -> Dune.t -> unit val tags_of_message : src:[< `Dune | `Merlin ] -> string -> DiagnosticTag.t list option -val merlin_diagnostics : t -> Document.t -> unit Fiber.t +val merlin_diagnostics : t -> Document.Merlin.t -> unit Fiber.t (** Exposed for testing *) diff --git a/ocaml-lsp-server/src/document.ml b/ocaml-lsp-server/src/document.ml index 919336eef..afa2e5870 100644 --- a/ocaml-lsp-server/src/document.ml +++ b/ocaml-lsp-server/src/document.ml @@ -14,7 +14,7 @@ module Kind = struct Jsonrpc.Response.Error.raise (Jsonrpc.Response.Error.make ~code:InvalidRequest - ~message:(Printf.sprintf "unsupported file extension") + ~message:"unsupported file extension" ~data:(`Assoc [ ("extension", `String ext) ]) ()) end @@ -86,19 +86,21 @@ module Syntax = struct | None -> Text_document.documentUri td |> Uri.to_path |> of_fname end +type merlin = + { tdoc : Text_document.t + ; pipeline : Mpipeline.t Lazy_fiber.t + ; merlin : Lev_fiber.Thread.t + ; timer : Lev_fiber.Timer.Wheel.task + ; merlin_config : Merlin_config.t + ; syntax : Syntax.t + } + type t = | Other of { tdoc : Text_document.t ; syntax : Syntax.t } - | Merlin of - { tdoc : Text_document.t - ; pipeline : Mpipeline.t Lazy_fiber.t - ; merlin : Lev_fiber.Thread.t - ; timer : Lev_fiber.Timer.Wheel.task - ; merlin_config : Merlin_config.t - ; syntax : Syntax.t - } + | Merlin of merlin let tdoc = function | Other d -> d.tdoc @@ -106,22 +108,10 @@ let tdoc = function let uri t = Text_document.documentUri (tdoc t) -let is_merlin = function - | Other _ -> false - | 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" [] - let syntax = function | Merlin m -> m.syntax | Other t -> t.syntax -let timer = function - | Other _ -> Code_error.raise "Document.dune" [] - | Merlin m -> m.timer - let text t = Text_document.text (tdoc t) let source t = Msource.make (text t) @@ -156,46 +146,6 @@ let await task = in raise (Jsonrpc.Response.Error.E e)) -let with_pipeline (t : t) f = - match t with - | Other _ -> Code_error.raise "Document.dune" [] - | Merlin t -> ( - let* pipeline = Lazy_fiber.force t.pipeline in - let* task = - match - Lev_fiber.Thread.task t.merlin ~f:(fun () -> - let start = Unix.time () in - let res = Mpipeline.with_pipeline pipeline (fun () -> f pipeline) in - let stop = Unix.time () in - let event = - let module Event = Chrome_trace.Event in - let dur = Event.Timestamp.of_float_seconds (stop -. start) in - let fields = - Event.common_fields - ~ts:(Event.Timestamp.of_float_seconds start) - ~name:"merlin" - () - in - Event.complete ~dur fields - in - (event, res)) - with - | Error `Stopped -> Fiber.never - | Ok task -> Fiber.return task - in - let* res = await task in - match res with - | Ok (event, result) -> - let+ () = Metrics.report event in - Ok result - | Error e -> Fiber.return (Error e)) - -let with_pipeline_exn doc f = - let+ res = with_pipeline doc f in - match res with - | Ok s -> s - | Error exn -> Exn_with_backtrace.reraise exn - let version t = Text_document.version (tdoc t) let make_pipeline merlin_config thread tdoc = @@ -254,50 +204,122 @@ let update_text ?version t changes = let pipeline = make_pipeline merlin_config merlin tdoc in Merlin { t with tdoc; pipeline }) -let dispatch t command = - with_pipeline t (fun pipeline -> Query_commands.dispatch pipeline command) +module Merlin = struct + type t = merlin + + let to_doc t = Merlin t + + let source t = Msource.make (text (Merlin t)) + + let timer (t : t) = t.timer -let dispatch_exn t command = - with_pipeline_exn t (fun pipeline -> Query_commands.dispatch pipeline command) + let kind t = Kind.of_fname (Uri.to_path (uri (Merlin t))) -let doc_comment pipeline pos = - let res = - let command = Query_protocol.Document (None, pos) in - Query_commands.dispatch pipeline command + let with_pipeline (t : t) f = + let* pipeline = Lazy_fiber.force t.pipeline in + let* task = + match + Lev_fiber.Thread.task t.merlin ~f:(fun () -> + let start = Unix.time () in + let res = Mpipeline.with_pipeline pipeline (fun () -> f pipeline) in + let stop = Unix.time () in + let event = + let module Event = Chrome_trace.Event in + let dur = Event.Timestamp.of_float_seconds (stop -. start) in + let fields = + Event.common_fields + ~ts:(Event.Timestamp.of_float_seconds start) + ~name:"merlin" + () + in + Event.complete ~dur fields + in + (event, res)) + with + | Error `Stopped -> Fiber.never + | Ok task -> Fiber.return task + in + let* res = await task in + match res with + | Ok (event, result) -> + let+ () = Metrics.report event in + Ok result + | Error e -> Fiber.return (Error e) + + let with_pipeline_exn doc f = + let+ res = with_pipeline doc f in + match res with + | Ok s -> s + | Error exn -> Exn_with_backtrace.reraise exn + + let dispatch t command = + with_pipeline t (fun pipeline -> Query_commands.dispatch pipeline command) + + let dispatch_exn t command = + with_pipeline_exn t (fun pipeline -> + Query_commands.dispatch pipeline command) + + let doc_comment pipeline pos = + let res = + let command = Query_protocol.Document (None, pos) in + Query_commands.dispatch pipeline command + in + match res with + | `Found s | `Builtin s -> Some s + | _ -> None + + type type_enclosing = + { loc : Loc.t + ; typ : string + ; doc : string option + } + + let type_enclosing doc pos verbosity = + with_pipeline_exn doc (fun pipeline -> + let command = Query_protocol.Type_enclosing (None, pos, None) in + let pipeline = + match verbosity with + | 0 -> pipeline + | verbosity -> + let source = source doc in + let config = Mpipeline.final_config pipeline in + let config = + { config with query = { config.query with verbosity } } + in + Mpipeline.make config source + in + let res = Query_commands.dispatch pipeline command in + match res with + | [] | (_, `Index _, _) :: _ -> None + | (loc, `String typ, _) :: _ -> + let doc = doc_comment pipeline pos in + Some { loc; typ; doc }) + + let doc_comment doc pos = + with_pipeline_exn doc (fun pipeline -> doc_comment pipeline pos) +end + +let edit t text_edit = + let version = version t in + let textDocument = + OptionalVersionedTextDocumentIdentifier.create ~uri:(uri t) ~version () in - match res with - | `Found s | `Builtin s -> Some s - | _ -> None - -type type_enclosing = - { loc : Loc.t - ; typ : string - ; doc : string option - } + let edit = + TextDocumentEdit.create ~textDocument ~edits:[ `TextEdit text_edit ] + in + WorkspaceEdit.create ~documentChanges:[ `TextDocumentEdit edit ] () -let type_enclosing doc pos verbosity = - with_pipeline_exn doc (fun pipeline -> - let command = Query_protocol.Type_enclosing (None, pos, None) in - let pipeline = - match verbosity with - | 0 -> pipeline - | verbosity -> - let source = source doc in - let config = Mpipeline.final_config pipeline in - let config = - { config with query = { config.query with verbosity } } - in - Mpipeline.make config source - in - let res = Query_commands.dispatch pipeline command in - match res with - | [] | (_, `Index _, _) :: _ -> None - | (loc, `String typ, _) :: _ -> - let doc = doc_comment pipeline pos in - Some { loc; typ; doc }) +let kind = function + | Merlin merlin -> `Merlin merlin + | Other _ -> `Other -let doc_comment doc pos = - with_pipeline_exn doc (fun pipeline -> doc_comment pipeline pos) +let merlin_exn t = + match kind t with + | `Merlin m -> m + | `Other -> + Code_error.raise + "Document.merlin_exn" + [ ("t", Dyn.string @@ DocumentUri.to_string @@ uri t) ] let close t = match t with @@ -342,13 +364,3 @@ let get_impl_intf_counterparts uri = | to_switch_to -> to_switch_to in List.map ~f:Uri.of_path files_to_switch_to - -let edit t text_edit = - let version = version t in - let textDocument = - OptionalVersionedTextDocumentIdentifier.create ~uri:(uri t) ~version () - in - let edit = - TextDocumentEdit.create ~textDocument ~edits:[ `TextEdit text_edit ] - in - WorkspaceEdit.create ~documentChanges:[ `TextDocumentEdit edit ] () diff --git a/ocaml-lsp-server/src/document.mli b/ocaml-lsp-server/src/document.mli index 806a4e57c..3ae62bbd2 100644 --- a/ocaml-lsp-server/src/document.mli +++ b/ocaml-lsp-server/src/document.mli @@ -22,10 +22,6 @@ module Kind : sig | Impl end -val is_merlin : t -> bool - -val kind : t -> Kind.t - val syntax : t -> Syntax.t val make : @@ -35,26 +31,57 @@ val make : -> DidOpenTextDocumentParams.t -> t Fiber.t -val timer : t -> Lev_fiber.Timer.Wheel.task - val uri : t -> Uri.t val text : t -> string val source : t -> Msource.t -val with_pipeline_exn : t -> (Mpipeline.t -> 'a) -> 'a Fiber.t +module Merlin : sig + type doc := t + + type t + + val source : t -> Msource.t + + val timer : t -> Lev_fiber.Timer.Wheel.task + + val with_pipeline_exn : t -> (Mpipeline.t -> 'a) -> 'a Fiber.t + + val dispatch : + t -> 'a Query_protocol.t -> ('a, Exn_with_backtrace.t) result Fiber.t + + val dispatch_exn : t -> 'a Query_protocol.t -> 'a Fiber.t + + val doc_comment : + t -> Msource.position -> (* doc string *) string option Fiber.t + + type type_enclosing = + { loc : Loc.t + ; typ : string + ; doc : string option + } + + val type_enclosing : + t + -> Msource.position + -> (* verbosity *) int + -> type_enclosing option Fiber.t + + val kind : t -> Kind.t + + val to_doc : t -> doc +end + +val kind : t -> [ `Merlin of Merlin.t | `Other ] + +val merlin_exn : t -> Merlin.t val version : t -> int val update_text : ?version:int -> t -> TextDocumentContentChangeEvent.t list -> t -val dispatch : - t -> 'a Query_protocol.t -> ('a, Exn_with_backtrace.t) result Fiber.t - -val dispatch_exn : t -> 'a Query_protocol.t -> 'a Fiber.t - val close : t -> unit Fiber.t (** [get_impl_intf_counterparts uri] returns the implementation/interface @@ -64,15 +91,3 @@ val close : t -> unit Fiber.t val get_impl_intf_counterparts : Uri.t -> Uri.t list val edit : t -> TextEdit.t -> WorkspaceEdit.t - -val doc_comment : - t -> Msource.position -> (* doc string *) string option Fiber.t - -type type_enclosing = - { loc : Loc.t - ; typ : string - ; doc : string option - } - -val type_enclosing : - t -> Msource.position -> (* verbosity *) int -> type_enclosing option Fiber.t diff --git a/ocaml-lsp-server/src/document_symbol.ml b/ocaml-lsp-server/src/document_symbol.ml index 2fdfdebed..07ca6cd01 100644 --- a/ocaml-lsp-server/src/document_symbol.ml +++ b/ocaml-lsp-server/src/document_symbol.ml @@ -13,28 +13,26 @@ let outline_kind kind : SymbolKind.t = | `Class -> Class | `Method -> Method -let range item = Range.of_loc item.Query_protocol.location - -let rec symbol item = - let children = List.map item.Query_protocol.children ~f:symbol in - let range : Range.t = range item in +let rec symbol (item : Query_protocol.item) = + let children = List.map item.children ~f:symbol in + let range = Range.of_loc item.location in let kind = outline_kind item.outline_kind in DocumentSymbol.create - ~name:item.Query_protocol.outline_name + ~name:item.outline_name ~kind - ?detail:item.Query_protocol.outline_type + ?detail:item.outline_type ~deprecated:item.deprecated ~range ~selectionRange:range ~children () -let rec symbol_info ?containerName uri item = - let location = { Location.uri; range = range item } in +let rec symbol_info ?containerName uri (item : Query_protocol.item) = let info = let kind = outline_kind item.outline_kind in + let location = { Location.uri; range = Range.of_loc item.location } in SymbolInformation.create - ~name:item.Query_protocol.outline_name + ~name:item.outline_name ~kind ~deprecated:false ~location @@ -50,23 +48,18 @@ let symbols_of_outline uri outline = List.concat_map ~f:(symbol_info uri) outline let run (client_capabilities : ClientCapabilities.t) doc uri = - let command = Query_protocol.Outline in - let+ outline = Document.dispatch_exn doc command in - let symbols = - let hierarchicalDocumentSymbolSupport = - let open Option.O in - Option.value - (let* textDocument = client_capabilities.textDocument in - let* ds = textDocument.documentSymbol in - ds.hierarchicalDocumentSymbolSupport) - ~default:false - in - match hierarchicalDocumentSymbolSupport with - | true -> - let symbols = List.map outline ~f:symbol in - `DocumentSymbol symbols - | false -> - let symbols = symbols_of_outline uri outline in - `SymbolInformation symbols - in - symbols + match Document.kind doc with + | `Other -> Fiber.return None + | `Merlin doc -> + let+ outline = Document.Merlin.dispatch_exn doc Outline in + Some + (match + Option.value + ~default:false + (let open Option.O in + let* textDocument = client_capabilities.textDocument in + let* ds = textDocument.documentSymbol in + ds.hierarchicalDocumentSymbolSupport) + with + | true -> `DocumentSymbol (List.map outline ~f:symbol) + | false -> `SymbolInformation (symbols_of_outline uri outline)) diff --git a/ocaml-lsp-server/src/document_symbol.mli b/ocaml-lsp-server/src/document_symbol.mli index 1decffee2..f074d3784 100644 --- a/ocaml-lsp-server/src/document_symbol.mli +++ b/ocaml-lsp-server/src/document_symbol.mli @@ -10,4 +10,5 @@ val run : -> [> `DocumentSymbol of DocumentSymbol.t list | `SymbolInformation of SymbolInformation.t list ] + option Fiber.t diff --git a/ocaml-lsp-server/src/dune b/ocaml-lsp-server/src/dune index c9ed549c5..415cd4720 100644 --- a/ocaml-lsp-server/src/dune +++ b/ocaml-lsp-server/src/dune @@ -34,6 +34,6 @@ yojson dune-rpc ocamlformat-rpc-lib - ocamlc_loc)) + ocamlc-loc)) (include_subdirs unqualified) diff --git a/ocaml-lsp-server/src/dune.ml b/ocaml-lsp-server/src/dune.ml index 406d54c00..880518f18 100644 --- a/ocaml-lsp-server/src/dune.ml +++ b/ocaml-lsp-server/src/dune.ml @@ -257,12 +257,12 @@ end = struct | Failed | Interrupted | Success -> let* () = Document_store.change_all document_store ~f:(fun doc -> - match Document.is_merlin doc with - | false -> Fiber.return doc - | true -> + match Document.kind doc with + | `Other -> Fiber.return doc + | `Merlin merlin -> let doc = Document.update_text doc [] in let+ () = - Diagnostics.merlin_diagnostics diagnostics doc + Diagnostics.merlin_diagnostics diagnostics merlin in doc) in diff --git a/ocaml-lsp-server/src/folding_range.ml b/ocaml-lsp-server/src/folding_range.ml index 5609492b4..799ae8eed 100644 --- a/ocaml-lsp-server/src/folding_range.ml +++ b/ocaml-lsp-server/src/folding_range.ml @@ -303,9 +303,12 @@ let fold_over_parsetree (parsetree : Mreader.parsetree) = let compute (state : State.t) (params : FoldingRangeParams.t) = Fiber.of_thunk (fun () -> let doc = Document_store.get state.store params.textDocument.uri in - let+ ranges = - Document.with_pipeline_exn doc (fun pipeline -> - let parsetree = Mpipeline.reader_parsetree pipeline in - fold_over_parsetree parsetree) - in - Some ranges) + match Document.kind doc with + | `Other -> Fiber.return None + | `Merlin m -> + let+ ranges = + Document.Merlin.with_pipeline_exn m (fun pipeline -> + let parsetree = Mpipeline.reader_parsetree pipeline in + fold_over_parsetree parsetree) + in + Some ranges) diff --git a/ocaml-lsp-server/src/hover_req.ml b/ocaml-lsp-server/src/hover_req.ml index 8adb1face..f93954207 100644 --- a/ocaml-lsp-server/src/hover_req.ml +++ b/ocaml-lsp-server/src/hover_req.ml @@ -39,71 +39,77 @@ let handle server { HoverParams.textDocument = { uri }; position; _ } mode = let store = state.store in Document_store.get store uri in - let verbosity = - let mode = - match (mode, Sys.getenv_opt "OCAMLLSP_HOVER_IS_EXTENDED") with - | Default, Some "true" -> Extended_variable - | x, _ -> x - in - match mode with - | Default -> 0 - | Extended_fixed v -> - state.hover_extended.history <- None; - v - | Extended_variable -> - let v = - match state.hover_extended.history with - | None -> 0 - | Some (h_uri, h_position, h_verbosity) -> - if - Uri.equal uri h_uri - && Ordering.is_eq (Position.compare position h_position) - then succ h_verbosity - else 0 - in - state.hover_extended.history <- Some (uri, position, v); - v - in - let pos = Position.logical position in - let* type_enclosing = Document.type_enclosing doc pos verbosity in - match type_enclosing with - | None -> Fiber.return None - | Some { Document.loc; typ; doc = documentation } -> - let syntax = Document.syntax doc in - let+ typ = - (* We ask Ocamlformat to format this type *) - let* result = - Ocamlformat_rpc.format_type state.ocamlformat_rpc ~typ + match Document.kind doc with + | `Other -> Fiber.return None + | `Merlin merlin -> ( + let verbosity = + let mode = + match (mode, Sys.getenv_opt "OCAMLLSP_HOVER_IS_EXTENDED") with + | Default, Some "true" -> Extended_variable + | x, _ -> x in - match result with - | Ok v -> - (* OCamlformat adds an unnecessay newline at the end of the type *) - Fiber.return (String.trim v) - | Error `No_process -> Fiber.return typ - | Error (`Msg message) -> - (* We log OCamlformat errors and display the unformated type *) - let+ () = - let message = - sprintf - "An error occured while querying ocamlformat:\n\ - Input type: %s\n\n\ - Answer: %s" - typ - message - in - State.log_msg server ~type_:Warning ~message + match mode with + | Default -> 0 + | Extended_fixed v -> + state.hover_extended.history <- None; + v + | Extended_variable -> + let v = + match state.hover_extended.history with + | None -> 0 + | Some (h_uri, h_position, h_verbosity) -> + if + Uri.equal uri h_uri + && Ordering.is_eq (Position.compare position h_position) + then succ h_verbosity + else 0 in - typ + state.hover_extended.history <- Some (uri, position, v); + v in - let contents = - let markdown = - let client_capabilities = State.client_capabilities state in - ClientCapabilities.markdown_support - client_capabilities - ~field:(fun td -> - Option.map td.hover ~f:(fun h -> h.contentFormat)) - in - format_contents ~syntax ~markdown ~typ ~doc:documentation + let pos = Position.logical position in + let* type_enclosing = + Document.Merlin.type_enclosing merlin pos verbosity in - let range = Range.of_loc loc in - Some (Hover.create ~contents ~range ())) + match type_enclosing with + | None -> Fiber.return None + | Some { Document.Merlin.loc; typ; doc = documentation } -> + let syntax = Document.syntax doc in + let+ typ = + (* We ask Ocamlformat to format this type *) + let* result = + Ocamlformat_rpc.format_type state.ocamlformat_rpc ~typ + in + match result with + | Ok v -> + (* OCamlformat adds an unnecessay newline at the end of the + type *) + Fiber.return (String.trim v) + | Error `No_process -> Fiber.return typ + | Error (`Msg message) -> + (* We log OCamlformat errors and display the unformated type *) + let+ () = + let message = + sprintf + "An error occured while querying ocamlformat:\n\ + Input type: %s\n\n\ + Answer: %s" + typ + message + in + State.log_msg server ~type_:Warning ~message + in + typ + in + let contents = + let markdown = + let client_capabilities = State.client_capabilities state in + ClientCapabilities.markdown_support + client_capabilities + ~field:(fun td -> + Option.map td.hover ~f:(fun h -> h.contentFormat)) + in + format_contents ~syntax ~markdown ~typ ~doc:documentation + in + let range = Range.of_loc loc in + Some (Hover.create ~contents ~range ()))) diff --git a/ocaml-lsp-server/src/import.ml b/ocaml-lsp-server/src/import.ml index dc3df96e2..80eb584ba 100644 --- a/ocaml-lsp-server/src/import.ml +++ b/ocaml-lsp-server/src/import.ml @@ -110,15 +110,42 @@ module Ast_iterator = Ocaml_parsing.Ast_iterator module Asttypes = Ocaml_parsing.Asttypes module Cmt_format = Ocaml_typing.Cmt_format module Ident = Ocaml_typing.Ident +module Env = Ocaml_typing.Env module Loc = struct - include Ocaml_parsing.Location - include Ocaml_parsing.Location_aux + module T = struct + include Ocaml_parsing.Location + include Ocaml_parsing.Location_aux + end + + include T + + module Map = Map.Make (struct + include T + + let compare x x' = Ordering.of_int (compare x x') + + let position_to_dyn (pos : Lexing.position) = + Dyn.Record + [ ("pos_fname", Dyn.String pos.pos_fname) + ; ("pos_lnum", Dyn.Int pos.pos_lnum) + ; ("pos_bol", Dyn.Int pos.pos_bol) + ; ("pos_cnum", Dyn.Int pos.pos_cnum) + ] + + let to_dyn loc = + Dyn.Record + [ ("loc_start", position_to_dyn loc.loc_start) + ; ("loc_end", position_to_dyn loc.loc_end) + ; ("loc_ghost", Dyn.Bool loc.loc_ghost) + ] + end) end module Longident = Ocaml_parsing.Longident module Parsetree = Ocaml_parsing.Parsetree module Path = Ocaml_typing.Path +module Pprintast = Ocaml_parsing.Pprintast module Typedtree = Ocaml_typing.Typedtree module Types = Ocaml_typing.Types module Warnings = Ocaml_utils.Warnings diff --git a/ocaml-lsp-server/src/inference.ml b/ocaml-lsp-server/src/inference.ml index 2c9e57253..8edc4ddf0 100644 --- a/ocaml-lsp-server/src/inference.ml +++ b/ocaml-lsp-server/src/inference.ml @@ -3,12 +3,16 @@ 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 m when Document.Merlin.kind m = Intf -> Code_error.raise "expected an implementation document, got an interface instead" [] - | Impl -> - Document.with_pipeline_exn doc (fun pipeline -> + | `Merlin doc -> + Document.Merlin.with_pipeline_exn doc (fun pipeline -> let typer = Mpipeline.typer_result pipeline in let sig_ : Types.signature = let typedtree = Mtyper.get_typedtree typer in @@ -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 m when Document.Merlin.kind m = Impl -> + Code_error.raise "the provided document is not an interface." [] + | `Merlin _ -> Fiber.of_thunk (fun () -> let intf_uri = Document.uri doc in let impl_uri = diff --git a/ocaml-lsp-server/src/merlin_config.ml b/ocaml-lsp-server/src/merlin_config.ml index 28d332994..7a7bf4c37 100644 --- a/ocaml-lsp-server/src/merlin_config.ml +++ b/ocaml-lsp-server/src/merlin_config.ml @@ -110,7 +110,10 @@ module Config = struct | `STDLIB path -> ({ config with stdlib = Some path }, errors) | `READER reader -> ({ config with reader }, errors) | `EXCLUDE_QUERY_DIR -> ({ config with exclude_query_dir = true }, errors) - | `UNKNOWN_TAG s -> (config, sprintf "Unknown tag %S" s :: errors) + | `UNKNOWN_TAG _ -> + (* For easier forward compatibility we ignore unknown configuration tags + when they are provided by dune *) + (config, errors) | `ERROR_MSG str -> (config, str :: errors)) let postprocess = diff --git a/ocaml-lsp-server/src/ocaml_lsp_server.ml b/ocaml-lsp-server/src/ocaml_lsp_server.ml index f957dc723..f6bc0ea51 100644 --- a/ocaml-lsp-server/src/ocaml_lsp_server.ml +++ b/ocaml-lsp-server/src/ocaml_lsp_server.ml @@ -38,6 +38,7 @@ let initialize_info (client_capabilities : ClientCapabilities.t) : ; Action_refactor_open.unqualify ; Action_refactor_open.qualify ; Action_add_rec.t + ; Action_inline.t ] |> List.sort_uniq ~compare:Poly.compare in @@ -150,38 +151,43 @@ let ocamlmerlin_reason = "ocamlmerlin-reason" let set_diagnostics detached diagnostics doc = let uri = Document.uri doc in - let async send = - let+ () = - task_if_running detached ~f:(fun () -> - let timer = Document.timer doc in - let* () = Lev_fiber.Timer.Wheel.cancel timer in - let* () = Lev_fiber.Timer.Wheel.reset timer in - let* res = Lev_fiber.Timer.Wheel.await timer in - match res with - | `Cancelled -> Fiber.return () - | `Ok -> send ()) - in - () - in - match Document.syntax doc with - | Dune | Cram | Menhir | Ocamllex -> Fiber.return () - | Reason when Option.is_none (Bin.which ocamlmerlin_reason) -> - let no_reason_merlin = - let message = - sprintf "Could not detect %s. Please install reason" ocamlmerlin_reason + match Document.kind doc with + | `Other -> Fiber.return () + | `Merlin merlin -> ( + let async send = + let+ () = + task_if_running detached ~f:(fun () -> + let timer = Document.Merlin.timer merlin in + let* () = Lev_fiber.Timer.Wheel.cancel timer in + let* () = Lev_fiber.Timer.Wheel.reset timer in + let* res = Lev_fiber.Timer.Wheel.await timer in + match res with + | `Cancelled -> Fiber.return () + | `Ok -> send ()) in - Diagnostic.create - ~source:Diagnostics.ocamllsp_source - ~range:Range.first_line - ~message - () + () in - Diagnostics.set diagnostics (`Merlin (uri, [ no_reason_merlin ])); - async (fun () -> Diagnostics.send diagnostics (`One uri)) - | Reason | Ocaml -> - async (fun () -> - let* () = Diagnostics.merlin_diagnostics diagnostics doc in - Diagnostics.send diagnostics (`One uri)) + match Document.syntax doc with + | Dune | Cram | Menhir | Ocamllex -> Fiber.return () + | Reason when Option.is_none (Bin.which ocamlmerlin_reason) -> + let no_reason_merlin = + let message = + sprintf + "Could not detect %s. Please install reason" + ocamlmerlin_reason + in + Diagnostic.create + ~source:Diagnostics.ocamllsp_source + ~range:Range.first_line + ~message + () + in + Diagnostics.set diagnostics (`Merlin (uri, [ no_reason_merlin ])); + async (fun () -> Diagnostics.send diagnostics (`One uri)) + | Reason | Ocaml -> + async (fun () -> + let* () = Diagnostics.merlin_diagnostics diagnostics merlin in + Diagnostics.send diagnostics (`One uri))) let on_initialize server (ip : InitializeParams.t) = let state : State.t = Server.state server in @@ -269,7 +275,8 @@ module Formatter = struct let run rpc doc = let state : State.t = Server.state rpc in - if Document.is_merlin doc then + match Document.kind doc with + | `Merlin _ -> ( let* res = let* res = Ocamlformat_rpc.format_doc state.ocamlformat_rpc doc in match res with @@ -289,8 +296,8 @@ module Formatter = struct task_if_running state.detached ~f:(fun () -> Server.notification rpc (ShowMessage msg)) in - Jsonrpc.Response.Error.raise error - else + Jsonrpc.Response.Error.raise error) + | `Other -> ( match Dune.for_doc (State.dune state) doc with | [] -> let message = @@ -314,7 +321,7 @@ module Formatter = struct State.log_msg rpc ~type_:MessageType.Warning ~message in let+ to_ = Dune.Instance.format_dune_file dune doc in - Some (Diff.edit ~from:(Document.text doc) ~to_) + Some (Diff.edit ~from:(Document.text doc) ~to_)) end let location_of_merlin_loc uri : _ -> (_, string) result = function @@ -369,72 +376,78 @@ let signature_help (state : State.t) Compl.prefix_of_position (Document.source doc) pos ~short_path:true in (* TODO use merlin resources efficiently and do everything in 1 thread *) - let* application_signature = - if Document.is_merlin doc then - Document.with_pipeline_exn doc (fun pipeline -> + match Document.kind doc with + | `Other -> + let help = SignatureHelp.create ~signatures:[] () in + Fiber.return help + | `Merlin merlin -> ( + let* application_signature = + Document.Merlin.with_pipeline_exn merlin (fun pipeline -> let typer = Mpipeline.typer_result pipeline in let pos = Mpipeline.get_lexing_pos pipeline pos in let node = Mtyper.node_at typer pos in Signature_help.application_signature node ~prefix) - else Fiber.return None - in - match application_signature with - | None -> - let help = SignatureHelp.create ~signatures:[] () in - Fiber.return help - | Some application_signature -> - let prefix = - let fun_name = - Option.value ~default:"_" application_signature.function_name - in - sprintf "%s : " fun_name in - let offset = String.length prefix in - let+ doc = - Document.doc_comment doc application_signature.function_position - in - let info = - let parameters = - List.map - application_signature.parameters - ~f:(fun (p : Signature_help.parameter_info) -> - let label = - `Offset (offset + p.param_start, offset + p.param_end) - in - ParameterInformation.create ~label ()) + match application_signature with + | None -> + let help = SignatureHelp.create ~signatures:[] () in + Fiber.return help + | Some application_signature -> + let prefix = + let fun_name = + Option.value ~default:"_" application_signature.function_name + in + sprintf "%s : " fun_name in - let documentation = - let open Option.O in - let+ doc in - let markdown = - ClientCapabilities.markdown_support - (State.client_capabilities state) - ~field:(fun td -> - let* sh = td.signatureHelp in - let+ si = sh.signatureInformation in - si.documentationFormat) + let offset = String.length prefix in + let+ doc = + Document.Merlin.doc_comment + merlin + application_signature.function_position + in + let info = + let parameters = + List.map + application_signature.parameters + ~f:(fun (p : Signature_help.parameter_info) -> + let label = + `Offset (offset + p.param_start, offset + p.param_end) + in + ParameterInformation.create ~label ()) in - format_doc ~markdown ~doc + let documentation = + let open Option.O in + let+ doc in + let markdown = + ClientCapabilities.markdown_support + (State.client_capabilities state) + ~field:(fun td -> + let* sh = td.signatureHelp in + let+ si = sh.signatureInformation in + si.documentationFormat) + in + format_doc ~markdown ~doc + in + let label = prefix ^ application_signature.signature in + SignatureInformation.create ~label ?documentation ~parameters () in - let label = prefix ^ application_signature.signature in - SignatureInformation.create ~label ?documentation ~parameters () - in - SignatureHelp.create - ~signatures:[ info ] - ~activeSignature:0 - ?activeParameter:application_signature.active_param - () + SignatureHelp.create + ~signatures:[ info ] + ~activeSignature:0 + ?activeParameter:application_signature.active_param + ()) let text_document_lens (state : State.t) { CodeLensParams.textDocument = { uri }; _ } = let store = state.store in let doc = Document_store.get store uri in match Document.kind doc with - | Intf -> Fiber.return [] - | Impl -> + | `Other -> Fiber.return [] + | `Merlin m when Document.Merlin.kind m = Intf -> Fiber.return [] + | `Merlin doc -> let+ outline = let command = Query_protocol.Outline in - Document.dispatch_exn doc command + Document.Merlin.dispatch_exn doc command in let rec symbol_info_of_outline_item item = let children = @@ -458,130 +471,157 @@ let text_document_lens (state : State.t) let rename (state : State.t) { RenameParams.textDocument = { uri }; position; newName; _ } = let doc = Document_store.get state.store uri in - let command = - Query_protocol.Occurrences (`Ident_at (Position.logical position)) - in - let+ locs = Document.dispatch_exn doc command in - let version = Document.version doc in - let source = Document.source doc in - let edits = - List.map locs ~f:(fun (loc : Warnings.loc) -> - let range = Range.of_loc loc in - let make_edit () = TextEdit.create ~range ~newText:newName in - match - let occur_start_pos = - Position.of_lexical_position loc.loc_start |> Option.value_exn - in - occur_start_pos - with - | { character = 0; _ } -> make_edit () - | pos -> ( - let mpos = Position.logical pos in - let (`Offset index) = Msource.get_offset source mpos in - assert (index > 0) - (* [index = 0] if we pass [`Logical (1, 0)], but we handle the case - when [character = 0] in a separate matching branch *); - let source_txt = Msource.text source in - match source_txt.[index - 1] with - | '~' (* the occurrence is a named argument *) - | '?' (* is an optional argument *) -> - let empty_range_at_occur_end = - let occur_end_pos = range.Range.end_ in - { range with start = occur_end_pos } + match Document.kind doc with + | `Other -> Fiber.return (WorkspaceEdit.create ()) + | `Merlin merlin -> + let command = + Query_protocol.Occurrences (`Ident_at (Position.logical position)) + in + let+ locs = Document.Merlin.dispatch_exn merlin command in + let version = Document.version doc in + let source = Document.source doc in + let edits = + List.map locs ~f:(fun (loc : Warnings.loc) -> + let range = Range.of_loc loc in + let make_edit () = TextEdit.create ~range ~newText:newName in + match + let occur_start_pos = + Position.of_lexical_position loc.loc_start |> Option.value_exn in - TextEdit.create - ~range:empty_range_at_occur_end - ~newText:(":" ^ newName) - | _ -> make_edit ())) - in - let workspace_edits = - let documentChanges = - let open Option.O in - Option.value - ~default:false - (let client_capabilities = State.client_capabilities state in - let* workspace = client_capabilities.workspace in - let* edit = workspace.workspaceEdit in - edit.documentChanges) + occur_start_pos + with + | { character = 0; _ } -> make_edit () + | pos -> ( + let mpos = Position.logical pos in + let (`Offset index) = Msource.get_offset source mpos in + assert (index > 0) + (* [index = 0] if we pass [`Logical (1, 0)], but we handle the case + when [character = 0] in a separate matching branch *); + let source_txt = Msource.text source in + match source_txt.[index - 1] with + | '~' (* the occurrence is a named argument *) + | '?' (* is an optional argument *) -> + let empty_range_at_occur_end = + let occur_end_pos = range.Range.end_ in + { range with start = occur_end_pos } + in + TextEdit.create + ~range:empty_range_at_occur_end + ~newText:(":" ^ newName) + | _ -> make_edit ())) in - if documentChanges then - let textDocument = - OptionalVersionedTextDocumentIdentifier.create ~uri ~version () + let workspace_edits = + let documentChanges = + let open Option.O in + Option.value + ~default:false + (let client_capabilities = State.client_capabilities state in + let* workspace = client_capabilities.workspace in + let* edit = workspace.workspaceEdit in + edit.documentChanges) in - let edits = List.map edits ~f:(fun e -> `TextEdit e) in - WorkspaceEdit.create - ~documentChanges: - [ `TextDocumentEdit (TextDocumentEdit.create ~textDocument ~edits) ] - () - else WorkspaceEdit.create ~changes:[ (uri, edits) ] () - in - workspace_edits + if documentChanges then + let textDocument = + OptionalVersionedTextDocumentIdentifier.create ~uri ~version () + in + let edits = List.map edits ~f:(fun e -> `TextEdit e) in + WorkspaceEdit.create + ~documentChanges: + [ `TextDocumentEdit (TextDocumentEdit.create ~textDocument ~edits) ] + () + else WorkspaceEdit.create ~changes:[ (uri, edits) ] () + in + workspace_edits let selection_range (state : State.t) { SelectionRangeParams.textDocument = { uri }; positions; _ } = - let selection_range_of_shapes (cursor_position : Position.t) - (shapes : Query_protocol.shape list) : SelectionRange.t option = - let rec ranges_of_shape parent s = - let selectionRange = - let range = Range.of_loc s.Query_protocol.shape_loc in - { SelectionRange.range; parent } + let doc = Document_store.get state.store uri in + match Document.kind doc with + | `Other -> Fiber.return [] + | `Merlin merlin -> + let selection_range_of_shapes (cursor_position : Position.t) + (shapes : Query_protocol.shape list) : SelectionRange.t option = + let rec ranges_of_shape parent s = + let selectionRange = + let range = Range.of_loc s.Query_protocol.shape_loc in + { SelectionRange.range; parent } + in + match s.Query_protocol.shape_sub with + | [] -> [ selectionRange ] + | xs -> List.concat_map xs ~f:(ranges_of_shape (Some selectionRange)) in - match s.Query_protocol.shape_sub with - | [] -> [ selectionRange ] - | xs -> List.concat_map xs ~f:(ranges_of_shape (Some selectionRange)) + (* try to find the nearest range inside first, then outside *) + let nearest_range = + let ranges = List.concat_map ~f:(ranges_of_shape None) shapes in + List.min ranges ~f:(fun r1 r2 -> + let inc (r : SelectionRange.t) = + Position.compare_inclusion cursor_position r.range + in + match (inc r1, inc r2) with + | `Outside x, `Outside y -> Position.compare x y + | `Outside _, `Inside -> Gt + | `Inside, `Outside _ -> Lt + | `Inside, `Inside -> Range.compare_size r1.range r2.range) + in + nearest_range in - (* try to find the nearest range inside first, then outside *) - let nearest_range = - let ranges = List.concat_map ~f:(ranges_of_shape None) shapes in - List.min ranges ~f:(fun r1 r2 -> - let inc (r : SelectionRange.t) = - Position.compare_inclusion cursor_position r.range + let+ ranges = + Fiber.sequential_map positions ~f:(fun x -> + let+ shapes = + let command = Query_protocol.Shape (Position.logical x) in + Document.Merlin.dispatch_exn merlin command in - match (inc r1, inc r2) with - | `Outside x, `Outside y -> Position.compare x y - | `Outside _, `Inside -> Gt - | `Inside, `Outside _ -> Lt - | `Inside, `Inside -> Range.compare_size r1.range r2.range) + selection_range_of_shapes x shapes) in - nearest_range - in - let doc = Document_store.get state.store uri in - let+ ranges = - Fiber.sequential_map positions ~f:(fun x -> - let+ shapes = - let command = Query_protocol.Shape (Position.logical x) in - Document.dispatch_exn doc command - in - selection_range_of_shapes x shapes) - in - List.filter_opt ranges + List.filter_opt ranges let references (state : State.t) { ReferenceParams.textDocument = { uri }; position; _ } = let doc = Document_store.get state.store uri in - let command = - Query_protocol.Occurrences (`Ident_at (Position.logical position)) - in - let+ locs = Document.dispatch_exn doc command in - Some - (List.map locs ~f:(fun loc -> - let range = Range.of_loc loc in - (* using original uri because merlin is looking only in local file *) - { Location.uri; range })) + match Document.kind doc with + | `Other -> Fiber.return None + | `Merlin doc -> + let command = + Query_protocol.Occurrences (`Ident_at (Position.logical position)) + in + let+ locs = Document.Merlin.dispatch_exn doc command in + Some + (List.map locs ~f:(fun loc -> + let range = Range.of_loc loc in + (* using original uri because merlin is looking only in local file *) + { Location.uri; range })) -let definition_query server (state : State.t) uri position merlin_request = +let definition_query kind (state : State.t) uri position = + let* () = Fiber.return () in let doc = Document_store.get state.store uri in - let position = Position.logical position in - let command = merlin_request position in - let* result = Document.dispatch_exn doc command in - match location_of_merlin_loc uri result with - | Ok s -> Fiber.return s - | Error message -> - let+ () = - let message = sprintf "Locate failed. %s" message in - State.log_msg server ~type_:Error ~message + match Document.kind doc with + | `Other -> Fiber.return None + | `Merlin doc -> ( + let command = + let pos = Position.logical position in + match kind with + | `Definition -> Query_protocol.Locate (None, `ML, pos) + | `Declaration -> Query_protocol.Locate (None, `MLI, pos) + | `Type_definition -> Query_protocol.Locate_type pos in - None + let* result = Document.Merlin.dispatch_exn doc command in + match location_of_merlin_loc uri result with + | Ok s -> Fiber.return s + | Error err_msg -> + let kind = + match kind with + | `Definition -> "definition" + | `Declaration -> "declaration" + | `Type_definition -> "type definition" + in + Jsonrpc.Response.Error.raise + (Jsonrpc.Response.Error.make + ~code:Jsonrpc.Response.Error.Code.RequestFailed + ~message:(sprintf "Request \"Jump to %s\" failed." kind) + ~data: + (`String + (sprintf "'Locate' query to merlin returned error: %s" err_msg)) + ())) let workspace_symbol server (state : State.t) (params : WorkspaceSymbolParams.t) = @@ -653,29 +693,29 @@ let highlight (state : State.t) { DocumentHighlightParams.textDocument = { uri }; position; _ } = let store = state.store in let doc = Document_store.get store uri in - let command = - Query_protocol.Occurrences (`Ident_at (Position.logical position)) - in - let+ locs = Document.dispatch_exn doc command in - let lsp_locs = - List.map locs ~f:(fun loc -> - let range = Range.of_loc loc in - (* using the default kind as we are lacking info to make a difference - between assignment and usage. *) - DocumentHighlight.create ~range ~kind:DocumentHighlightKind.Text ()) - in - Some lsp_locs + match Document.kind doc with + | `Other -> Fiber.return None + | `Merlin m -> + let command = + Query_protocol.Occurrences (`Ident_at (Position.logical position)) + in + let+ locs = Document.Merlin.dispatch_exn m command in + let lsp_locs = + List.map locs ~f:(fun loc -> + let range = Range.of_loc loc in + (* using the default kind as we are lacking info to make a difference + between assignment and usage. *) + DocumentHighlight.create ~range ~kind:DocumentHighlightKind.Text ()) + in + Some lsp_locs let document_symbol (state : State.t) uri = - let+ symbols = - let doc = - let store = state.store in - Document_store.get store uri - in - let client_capabilities = State.client_capabilities state in - Document_symbol.run client_capabilities doc uri + let doc = + let store = state.store in + Document_store.get store uri in - Some symbols + let client_capabilities = State.client_capabilities state in + Document_symbol.run client_capabilities doc uri let on_request : type resp. @@ -764,12 +804,15 @@ let on_request : let resolve = Compl.Resolve.of_completion_item ci in match resolve with | None -> Fiber.return ci - | Some resolve -> + | Some resolve -> ( let doc = let uri = Compl.Resolve.uri resolve in Document_store.get state.store uri in - Compl.resolve doc ci resolve Document.doc_comment ~markdown) + match Document.kind doc with + | `Other -> Fiber.return ci + | `Merlin doc -> + Compl.resolve doc ci resolve Document.Merlin.doc_comment ~markdown)) () | CodeAction params -> Code_actions.compute server params | TextDocumentColor _ -> now [] @@ -784,22 +827,12 @@ let on_request : | TextDocumentHighlight req -> later highlight req | DocumentSymbol { textDocument = { uri }; _ } -> later document_symbol uri | TextDocumentDeclaration { textDocument = { uri }; position } -> - later - (fun state () -> - definition_query rpc state uri position (fun pos -> - Query_protocol.Locate (None, `MLI, pos))) - () + later (fun state () -> definition_query `Declaration state uri position) () | TextDocumentDefinition { textDocument = { uri }; position; _ } -> - later - (fun state () -> - definition_query rpc state uri position (fun pos -> - Query_protocol.Locate (None, `ML, pos))) - () + later (fun state () -> definition_query `Definition state uri position) () | TextDocumentTypeDefinition { textDocument = { uri }; position; _ } -> later - (fun state () -> - definition_query rpc state uri position (fun pos -> - Query_protocol.Locate_type pos)) + (fun state () -> definition_query `Type_definition state uri position) () | TextDocumentCompletion params -> later (fun _ () -> Compl.complete state params) () @@ -808,16 +841,19 @@ let on_request : later (fun _ () -> let doc = Document_store.get store uri in - let command = - Query_protocol.Occurrences (`Ident_at (Position.logical position)) - in - let+ locs = Document.dispatch_exn doc command in - let loc = - List.find_opt locs ~f:(fun loc -> - let range = Range.of_loc loc in - Position.compare_inclusion position range = `Inside) - in - Option.map loc ~f:Range.of_loc) + match Document.kind doc with + | `Other -> Fiber.return None + | `Merlin doc -> + let command = + Query_protocol.Occurrences (`Ident_at (Position.logical position)) + in + let+ locs = Document.Merlin.dispatch_exn doc command in + let loc = + List.find_opt locs ~f:(fun loc -> + let range = Range.of_loc loc in + Position.compare_inclusion position range = `Inside) + in + Option.map loc ~f:Range.of_loc) () | TextDocumentRename req -> later rename req | TextDocumentFoldingRange req -> later Folding_range.compute req diff --git a/ocaml-lsp-server/src/ocamlformat.ml b/ocaml-lsp-server/src/ocamlformat.ml index 59057d113..1570e9d32 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 m -> Document.Merlin.kind m + | `Other -> Code_error.raise "unable to format non merlin document" [])) let exec cancel bin args stdin = let refmt = Fpath.to_string bin in diff --git a/ocaml-lsp-server/src/semantic_highlighting.ml b/ocaml-lsp-server/src/semantic_highlighting.ml index d096d01e6..a87ab4e2c 100644 --- a/ocaml-lsp-server/src/semantic_highlighting.ml +++ b/ocaml-lsp-server/src/semantic_highlighting.ml @@ -896,7 +896,9 @@ let gen_new_id = string_of_int x let compute_tokens doc = - let+ parsetree = Document.with_pipeline_exn doc Mpipeline.reader_parsetree in + let+ parsetree = + Document.Merlin.with_pipeline_exn doc Mpipeline.reader_parsetree + in let module Fold = Parsetree_fold () in Fold.apply parsetree @@ -920,13 +922,21 @@ module Debug = struct (meth_request_full ^ " expects an argument but didn't receive any") () - | Some (`Assoc _ as json) | Some (`List _ as json) -> + | Some (`Assoc _ as json) | Some (`List _ as json) -> ( let params = SemanticTokensParams.t_of_yojson json in let store = state.store in let uri = params.textDocument.uri in let doc = Document_store.get store uri in - let+ tokens = compute_tokens doc in - Tokens.yojson_of_t tokens) + match Document.kind doc with + | `Other -> + Jsonrpc.Response.Error.raise + @@ Jsonrpc.Response.Error.make + ~code:Jsonrpc.Response.Error.Code.InvalidParams + ~message:"expected a merlin document" + () + | `Merlin merlin -> + let+ tokens = compute_tokens merlin in + Tokens.yojson_of_t tokens)) end let on_request_full : @@ -936,10 +946,13 @@ let on_request_full : let store = state.store in let uri = params.textDocument.uri in let doc = Document_store.get store uri in - let+ tokens = compute_encoded_tokens doc in - let resultId = gen_new_id () in - Document_store.update_semantic_tokens_cache store uri ~resultId ~tokens; - Some { SemanticTokens.resultId = Some resultId; data = tokens }) + match Document.kind doc with + | `Other -> Fiber.return None + | `Merlin doc -> + let+ tokens = compute_encoded_tokens doc in + let resultId = gen_new_id () in + Document_store.update_semantic_tokens_cache store uri ~resultId ~tokens; + Some { SemanticTokens.resultId = Some resultId; data = tokens }) (* TODO: refactor [find_diff] and write (inline?) tests *) @@ -999,22 +1012,25 @@ let on_request_full_delta : let store = state.store in let uri = params.textDocument.uri in let doc = Document_store.get store uri in - let+ tokens = compute_encoded_tokens doc in - let resultId = gen_new_id () in - let cached_token_info = - Document_store.get_semantic_tokens_cache - state.store - params.textDocument.uri - in - Document_store.update_semantic_tokens_cache store uri ~resultId ~tokens; - match cached_token_info with - | Some cached_v - when String.equal cached_v.resultId params.previousResultId -> - let edits = find_diff ~old:cached_v.tokens ~new_:tokens in - Some - (`SemanticTokensDelta - { SemanticTokensDelta.resultId = Some resultId; edits }) - | Some _ | None -> - Some - (`SemanticTokens - { SemanticTokens.resultId = Some resultId; data = tokens })) + match Document.kind doc with + | `Other -> Fiber.return None + | `Merlin doc -> ( + let+ tokens = compute_encoded_tokens doc in + let resultId = gen_new_id () in + let cached_token_info = + Document_store.get_semantic_tokens_cache + state.store + params.textDocument.uri + in + Document_store.update_semantic_tokens_cache store uri ~resultId ~tokens; + match cached_token_info with + | Some cached_v + when String.equal cached_v.resultId params.previousResultId -> + let edits = find_diff ~old:cached_v.tokens ~new_:tokens in + Some + (`SemanticTokensDelta + { SemanticTokensDelta.resultId = Some resultId; edits }) + | Some _ | None -> + Some + (`SemanticTokens + { SemanticTokens.resultId = Some resultId; data = tokens }))) diff --git a/ocaml-lsp-server/test/e2e-new/action_inline.ml b/ocaml-lsp-server/test/e2e-new/action_inline.ml new file mode 100644 index 000000000..daff1816c --- /dev/null +++ b/ocaml-lsp-server/test/e2e-new/action_inline.ml @@ -0,0 +1,518 @@ +open Test.Import +open Code_actions + +let parse_cursor src = + let cursor = + String.split_lines src + |> List.find_mapi ~f:(fun lnum line -> + match String.index line '$' with + | Some cnum -> Some (Position.create ~character:cnum ~line:lnum) + | None -> None) + |> Option.value_exn + in + ( String.filter_map src ~f:(function + | '$' -> None + | c -> Some c) + , Range.create ~start:cursor ~end_:cursor ) + +let offset_of_position src (pos : Position.t) = + let line_offset = + String.split_lines src |> List.take pos.line + |> List.fold_left ~init:0 ~f:(fun s l -> s + String.length l) + in + line_offset + pos.line (* account for line endings *) + pos.character + +let apply_edit (edit : TextEdit.t) src = + let start_offset = offset_of_position src edit.range.start in + let end_offset = offset_of_position src edit.range.end_ in + let start = String.take src start_offset in + let end_ = String.drop src end_offset in + start ^ edit.newText ^ end_ + +let apply_inline_action src range = + let open Option.O in + let code_actions = ref None in + iter_code_actions src range (fun ca -> code_actions := Some ca); + let* m_code_actions = !code_actions in + let* code_actions = m_code_actions in + let* { documentChanges; _ } = + List.find_map code_actions ~f:(function + | `CodeAction { kind = Some RefactorInline; edit = Some edit; _ } -> + Some edit + | _ -> None) + in + let+ documentChanges in + let edits = + List.filter_map documentChanges ~f:(function + | `TextDocumentEdit e -> Some e + | _ -> None) + in + match edits with + | [] -> src + | [ { edits = [ `TextEdit e ]; _ } ] -> apply_edit e src + | _ -> failwith "expected one edit" + +let inline_test src = + let src, range = parse_cursor src in + Option.iter (apply_inline_action src range) ~f:print_string + +let%expect_test "" = + inline_test {| +let _ = + let $x = 0 in + x + 1 +|}; + [%expect {| + let _ = + let x = 0 in + (0) + 1 |}] + +let%expect_test "shadow-1" = + inline_test + {| +let _ = + let y = 1 in + let $x = y in + let y = 0 in + x + 1 +|}; + [%expect {| |}] + +let%expect_test "shadow-2" = + inline_test + {| +let _ = + let y = 1 in + let $x y = y in + let y = 0 in + x y + 1 +|}; + [%expect + {| + let _ = + let y = 1 in + let x y = y in + let y = 0 in + (y) + 1 |}] + +let%expect_test "shadow-3" = + inline_test + {| +let _ = + let y = 1 in + let $x z = y + z in + let y = 0 in + x y + 1 +|}; + [%expect {| |}] + +let%expect_test "shadow-4" = + inline_test + {| +module M = struct + let y = 1 +end +let _ = + let $x = M.y in + let module M = struct + let y = 2 + end in + x +|}; + [%expect {| |}] + +let%expect_test "shadow-5" = + inline_test + {| +module M = struct + let y = 1 +end +let _ = + let $x = M.y in + let module N = struct + let y = 2 + end in + x +|}; + [%expect + {| + module M = struct + let y = 1 + end + let _ = + let x = M.y in + let module N = struct + let y = 2 + end in + (M.y) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $x = 0 + 1 in + (fun x -> x) x +|}; + [%expect {| + let _ = + let x = 0 + 1 in + (fun x -> x) (0 + 1) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $x = 0 + 1 in + (fun ~x -> x) ~x +|}; + [%expect + {| + let _ = + let x = 0 + 1 in + (fun ~x -> x) ~x:(0 + 1) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $x = 0 + 1 in + (fun ?(x = 2) -> x) ~x +|}; + [%expect + {| + let _ = + let x = 0 + 1 in + (fun ?(x = 2) -> x) ~x:(0 + 1) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $x = Some 0 in + (fun ?(x = 2) -> x) ?x +|}; + [%expect {| |}] + +let%expect_test "" = + inline_test {| +let _ = + let $x = 0 in + (fun ~x -> x) ~x:(x + 1) +|}; + [%expect + {| + let _ = + let x = 0 in + (fun ~x -> x) ~x:((0) + 1) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $x = 0 in + (fun ?(x = 1) -> x) ~x:(x + 1) +|}; + [%expect + {| + let _ = + let x = 0 in + (fun ?(x = 1) -> x) ~x:((0) + 1) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f x = x in + f 1 +|}; + [%expect {| + let _ = + let f x = x in + (1) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f _ = 0 in + f 1 +|}; + [%expect {| + let _ = + let f _ = 0 in + (0) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f x = x + x in + f 1 +|}; + [%expect {| + let _ = + let f x = x + x in + (1 + 1) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f x = x + x in + f (g 1) +|}; + [%expect + {| + let _ = + let f x = x + x in + (let x = g 1 in x + x) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f x y = x + y in + f 0 +|}; + [%expect {| + let _ = + let f x y = x + y in + (fun y -> 0 + y) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f x ~y = x + y in + f ~y:0 +|}; + [%expect + {| + let _ = + let f x ~y = x + y in + ((fun x ~y -> x + y) ~y:0) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f ~x y = x + y in + f ~x:0 +|}; + [%expect {| + let _ = + let f ~x y = x + y in + (fun y -> 0 + y) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f ~x ~y = x + y in + f ~y:0 +|}; + [%expect + {| + let _ = + let f ~x ~y = x + y in + (fun ~x -> x + 0) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f (x : int) = x + 1 in + f 0 +|}; + [%expect {| + let _ = + let f (x : int) = x + 1 in + (0 + 1) |}] + +(* TODO: allow beta reduction with locally abstract types *) +let%expect_test "" = + inline_test {| +let _ = + let $f (type a) (x : a) = x in + f 0 +|}; + [%expect + {| + let _ = + let f (type a) (x : a) = x in + ((fun (type a) -> fun (x : a) -> x) 0) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f : int -> int = fun x -> x in + f 0 +|}; + [%expect {| + let _ = + let f : int -> int = fun x -> x in + (0) |}] + +let%expect_test "" = + inline_test + {| +let _ = + let $f = function Some x -> x | None -> 0 in + f (Some 1) +|}; + [%expect + {| + let _ = + let f = function Some x -> x | None -> 0 in + ((function | Some x -> x | None -> 0) (Some 1)) |}] + +(* TODO: allow beta reduction with `as` *) +let%expect_test "" = + inline_test {| +let _ = + let $f (x as y) = y + 1 in + f 1 +|}; + [%expect + {| + let _ = + let f (x as y) = y + 1 in + (let x as y = 1 in y + 1) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f 1 = 2 in + f 2 +|}; + [%expect {| + let _ = + let f 1 = 2 in + (let 1 = 2 in 2) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f (x, y) = x + y in + f (1, 2) +|}; + [%expect {| + let _ = + let f (x, y) = x + y in + (1 + 2) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f (x, y) = x + y + y in + f (1, 2 + 3) +|}; + [%expect + {| + let _ = + let f (x, y) = x + y + y in + (let y = 2 + 3 in (1 + y) + y) |}] + +let%expect_test "" = + inline_test + {| +let _ = + let $f (x, y) = x + y + y in + let z = (1, 2) in + f z +|}; + [%expect + {| + let _ = + let f (x, y) = x + y + y in + let z = (1, 2) in + (let (x, y) = z in (x + y) + y) |}] + +(* TODO *) +let%expect_test "" = + inline_test + {| +type t = { x : int; y : int } +let _ = + let $f { x; y } = x + y in + f { x = 1; y = 1 } +|}; + [%expect + {| + type t = { x : int; y : int } + let _ = + let f { x; y } = x + y in + (let { x; y } = { x = 1; y = 1 } in x + y) |}] + +(* TODO: beta reduce record literals as with tuples *) +let%expect_test "" = + inline_test + {| +type t = { x : int; y : int } +let _ = + let $f { x; _ } = x + 1 in + f { x = 1; y = 1 } +|}; + [%expect + {| + type t = { x : int; y : int } + let _ = + let f { x; _ } = x + 1 in + (let { x;_} = { x = 1; y = 1 } in x + 1) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f x = [%test] x in + f 1 +|}; + [%expect {| + let _ = + let f x = [%test] x in + (([%test ]) 1) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f x = x in + [%test] (f 1) +|}; + [%expect {| + let _ = + let f x = x in + [%test] (1) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f x = (* test comment *) x in + f 1 +|}; + [%expect {| + let _ = + let f x = (* test comment *) x in + (1) |}] + +let%expect_test "" = + inline_test {| +let _ = + let $f x = x in + (* test comment *) f 1 +|}; + [%expect {| + let _ = + let f x = x in + (* test comment *) (1) |}] + +let%expect_test "" = + inline_test {| +let $f x = x +let g y = f y +|}; + [%expect {| + let f x = x + let g y = (y) |}] + +(* TODO *) +let%expect_test "" = + inline_test + {| +module M = struct + let $f x = x + let g y = f y +end +let h = M.f +|}; + [%expect + {| + module M = struct + let f x = x + let g y = (y) + end + let h = M.f |}] diff --git a/ocaml-lsp-server/test/e2e-new/code_actions.ml b/ocaml-lsp-server/test/e2e-new/code_actions.ml index 68b65c44c..292973ddd 100644 --- a/ocaml-lsp-server/test/e2e-new/code_actions.ml +++ b/ocaml-lsp-server/test/e2e-new/code_actions.ml @@ -1,54 +1,47 @@ open Test.Import -let%expect_test "code actions" = - let source = {ocaml| -let foo = 123 -|ocaml} in +let iter_code_actions ?(path = "foo.ml") source range k = let handler = Client.Handler.make ~on_notification:(fun _ _ -> Fiber.return ()) () in - ( Test.run ~handler @@ fun client -> - let run_client () = - let capabilities = - let window = - let showDocument = - ShowDocumentClientCapabilities.create ~support:true - in - WindowClientCapabilities.create ~showDocument () + Test.run ~handler @@ fun client -> + let run_client () = + let capabilities = + let window = + let showDocument = + ShowDocumentClientCapabilities.create ~support:true in - ClientCapabilities.create ~window () + WindowClientCapabilities.create ~showDocument () in - Client.start client (InitializeParams.create ~capabilities ()) + ClientCapabilities.create ~window () in - let run = - let* (_ : InitializeResult.t) = Client.initialized client in - let uri = DocumentUri.of_path "foo.ml" in - let* () = - let textDocument = - TextDocumentItem.create - ~uri - ~languageId:"ocaml" - ~version:0 - ~text:source - in - Client.notification - client - (TextDocumentDidOpen (DidOpenTextDocumentParams.create ~textDocument)) + Client.start client (InitializeParams.create ~capabilities ()) + in + let run = + let* (_ : InitializeResult.t) = Client.initialized client in + let uri = DocumentUri.of_path path in + let* () = + let textDocument = + TextDocumentItem.create ~uri ~languageId:"ocaml" ~version:0 ~text:source in - let+ resp = - let range = - let start = Position.create ~line:1 ~character:5 in - let end_ = Position.create ~line:1 ~character:7 in - Range.create ~start ~end_ - in - let context = CodeActionContext.create ~diagnostics:[] () in - let request = - let textDocument = TextDocumentIdentifier.create ~uri in - CodeActionParams.create ~textDocument ~range ~context () - in - Client.request client (CodeAction request) + Client.notification + client + (TextDocumentDidOpen (DidOpenTextDocumentParams.create ~textDocument)) + in + let+ resp = + let context = CodeActionContext.create ~diagnostics:[] () in + let request = + let textDocument = TextDocumentIdentifier.create ~uri in + CodeActionParams.create ~textDocument ~range ~context () in - match resp with + Client.request client (CodeAction request) + in + k resp + in + Fiber.fork_and_join_unit run_client (fun () -> run >>> Client.stop client) + +let print_code_actions ?(path = "foo.ml") source range = + iter_code_actions ~path source range (function | None -> print_endline "no code actions" | Some code_actions -> print_endline "Code actions:"; @@ -58,10 +51,18 @@ let foo = 123 | `Command command -> Command.yojson_of_t command | `CodeAction ca -> CodeAction.yojson_of_t ca in - Yojson.Safe.pretty_to_string ~std:false json |> print_endline) - in - Fiber.fork_and_join_unit run_client (fun () -> run >>> Client.stop client) - ); + Yojson.Safe.pretty_to_string ~std:false json |> print_endline)) + +let%expect_test "code actions" = + let source = {ocaml| +let foo = 123 +|ocaml} in + let range = + let start = Position.create ~line:1 ~character:5 in + let end_ = Position.create ~line:1 ~character:7 in + Range.create ~start ~end_ + in + print_code_actions source range; [%expect {| Code actions: diff --git a/ocaml-lsp-server/test/e2e-new/start_stop.ml b/ocaml-lsp-server/test/e2e-new/start_stop.ml index 8e9694627..e1dca8c58 100644 --- a/ocaml-lsp-server/test/e2e-new/start_stop.ml +++ b/ocaml-lsp-server/test/e2e-new/start_stop.ml @@ -35,8 +35,8 @@ let%expect_test "start/stop" = "capabilities": { "codeActionProvider": { "codeActionKinds": [ - "quickfix", "construct", "destruct", "inferred_intf", - "put module name in identifiers", + "quickfix", "refactor.inline", "construct", "destruct", + "inferred_intf", "put module name in identifiers", "remove module name from identifiers", "type-annotate" ] }, diff --git a/ocaml-lsp-server/test/e2e-new/test.ml b/ocaml-lsp-server/test/e2e-new/test.ml index fba7ed7e9..45be35b55 100644 --- a/ocaml-lsp-server/test/e2e-new/test.ml +++ b/ocaml-lsp-server/test/e2e-new/test.ml @@ -1,5 +1,32 @@ module Import = struct - include Stdune + include struct + include Stdune + + module List = struct + include List + + let find_mapi ~f l = + let rec k i = function + | [] -> None + | x :: xs -> ( + match f i x with + | Some x' -> Some x' + | None -> (k [@tailcall]) (i + 1) xs) + in + k 0 l + + let take n l = + let rec take acc n l = + if n = 0 then acc + else + match l with + | [] -> failwith "list shorter than n" + | x :: xs -> (take [@tailcall]) (x :: acc) (n - 1) xs + in + List.rev (take [] n l) + end + end + include Fiber.O module Client = Lsp_fiber.Client include Lsp.Types diff --git a/ocaml-lsp-server/vendor/dune b/ocaml-lsp-server/vendor/dune deleted file mode 100644 index a184ff68b..000000000 --- a/ocaml-lsp-server/vendor/dune +++ /dev/null @@ -1,5 +0,0 @@ -(subdir ocamlc_loc - (copy_files %{project_root}/submodules/dune/src/ocamlc_loc/*.{ml,mli}) - (library - (name ocamlc_loc) - (libraries re dyn stdune))) diff --git a/submodules/dune b/submodules/dune deleted file mode 160000 index 26fe675d7..000000000 --- a/submodules/dune +++ /dev/null @@ -1 +0,0 @@ -Subproject commit 26fe675d7bb4eb1e1ece8109415c9b0b51166ca5