From 59a89d9004f3c95f41451b7eda3fb77d75924d71 Mon Sep 17 00:00:00 2001 From: xvw Date: Tue, 11 Jun 2024 10:11:41 +0200 Subject: [PATCH 1/5] Add Document.Merlin.with_configurable_pipeline_exn Enables a pipeline to be run with a pre-calculated configuration (useful for tunneling when modifying the active configuration with flags). --- ocaml-lsp-server/src/document.ml | 24 ++++++++++++++++++++++-- ocaml-lsp-server/src/document.mli | 8 ++++++++ 2 files changed, 30 insertions(+), 2 deletions(-) diff --git a/ocaml-lsp-server/src/document.ml b/ocaml-lsp-server/src/document.ml index 1d95fe7d2..8627fc827 100644 --- a/ocaml-lsp-server/src/document.ml +++ b/ocaml-lsp-server/src/document.ml @@ -131,13 +131,20 @@ module Single_pipeline : sig -> config:Merlin_config.t -> f:(Mpipeline.t -> 'a) -> ('a, Exn_with_backtrace.t) result Fiber.t + + val use_with_config : + ?name:string + -> t + -> doc:Text_document.t + -> config:Mconfig.t + -> f:(Mpipeline.t -> 'a) + -> ('a, Exn_with_backtrace.t) result Fiber.t end = struct type t = { thread : Lev_fiber.Thread.t } [@@unboxed] let create thread = { thread } - let use ?name t ~doc ~config ~f = - let* config = Merlin_config.config config in + let use_with_config ?name t ~doc ~config ~f = let make_pipeline = let source = Msource.make (Text_document.text doc) in fun () -> Mpipeline.make config source @@ -173,6 +180,10 @@ end = struct in let+ () = Metrics.report event in Ok res + + let use ?name t ~doc ~config ~f = + let* config = Merlin_config.config config in + use_with_config ?name t ~doc ~config ~f end type merlin = @@ -276,6 +287,9 @@ module Merlin = struct let with_pipeline ?name (t : t) f = Single_pipeline.use ?name t.pipeline ~doc:t.tdoc ~config:t.merlin_config ~f + let with_configurable_pipeline ?name ~config (t : t) f = + Single_pipeline.use_with_config ?name t.pipeline ~doc:t.tdoc ~config ~f + let mconfig (t : t) = Merlin_config.config t.merlin_config let with_pipeline_exn ?name doc f = @@ -284,6 +298,12 @@ module Merlin = struct | Ok s -> s | Error exn -> Exn_with_backtrace.reraise exn + let with_configurable_pipeline_exn ?name ~config doc f = + let+ res = with_configurable_pipeline ?name ~config doc f in + match res with + | Ok s -> s + | Error exn -> Exn_with_backtrace.reraise exn + let dispatch ?name t command = with_pipeline ?name t (fun pipeline -> Query_commands.dispatch pipeline command) diff --git a/ocaml-lsp-server/src/document.mli b/ocaml-lsp-server/src/document.mli index 8e1e2cb5d..6760c4c38 100644 --- a/ocaml-lsp-server/src/document.mli +++ b/ocaml-lsp-server/src/document.mli @@ -53,8 +53,16 @@ module Merlin : sig val timer : t -> Lev_fiber.Timer.Wheel.task + (** uses a single pipeline, provisioned by the configuration attached to the + merlin document (via {!type:t}). *) val with_pipeline_exn : ?name:string -> t -> (Mpipeline.t -> 'a) -> 'a Fiber.t + (** Like {!val:with_pipeline_exn} but where the merlin configuration is + supplied manually. If, for example, it is computed outside the execution + of the pipeline.*) + val with_configurable_pipeline_exn : + ?name:string -> config:Mconfig.t -> t -> (Mpipeline.t -> 'a) -> 'a Fiber.t + val dispatch : ?name:string -> t From 6af9c69b4eee6117d26f4407b795604fbebb8777 Mon Sep 17 00:00:00 2001 From: xvw Date: Tue, 11 Jun 2024 10:12:58 +0200 Subject: [PATCH 2/5] Add custom request for invoking merlin (tunneling) --- .../req_merlin_call_compatible.ml | 176 ++++++++++++++++++ .../req_merlin_call_compatible.mli | 7 + ocaml-lsp-server/src/dune | 1 + 3 files changed, 184 insertions(+) create mode 100644 ocaml-lsp-server/src/custom_requests/req_merlin_call_compatible.ml create mode 100644 ocaml-lsp-server/src/custom_requests/req_merlin_call_compatible.mli diff --git a/ocaml-lsp-server/src/custom_requests/req_merlin_call_compatible.ml b/ocaml-lsp-server/src/custom_requests/req_merlin_call_compatible.ml new file mode 100644 index 000000000..a5c83113a --- /dev/null +++ b/ocaml-lsp-server/src/custom_requests/req_merlin_call_compatible.ml @@ -0,0 +1,176 @@ +open Import + +let capability = ("handleMerlinCallCompatible", `Bool true) + +let meth = "ocamllsp/merlinCallCompatible" + +module Request_params = struct + type t = + { uri : Uri.t + ; result_as_sexp : bool + ; command : string + ; args : string list + } + + let expected = + `Assoc + [ ("uri", `String "") + ; ("resultAsSexp?", `String "") + ; ("command", `String "") + ; ("args?", `String "[] | Object") + ] + + let as_sexp_of_yojson params = + match List.assoc_opt "resultAsSexp" params with + | Some (`Bool value) -> value + | _ -> + (* If the parameter is incorrectly formatted or missing, it is assumed that + the result is not requested in the form of Sexp *) + false + + let command_of_yojson params = + match List.assoc_opt "command" params with + | Some (`String command_name) -> Some command_name + | _ -> + (* If the parameter is incorrectly formatted or missing, we refuse to build + the parameter, [command] is mandatory. *) + None + + let uri_of_yojson params = + match List.assoc_opt "uri" params with + | Some uri -> Some (Uri.t_of_yojson uri) + | _ -> + (* If the parameter is incorrectly formatted or missing, we refuse to build + the parameter, [uri] is mandatory. *) + None + + let stringish_of_yojson = + (* The function is relatively optimistic and attempts to treat literal data as + strings of characters. *) + function + | `String s -> Some s + | `Bool b -> Some (string_of_bool b) + | `Float f -> Some (string_of_float f) + | `Int i -> Some (string_of_int i) + | `Intlit i -> Some i + | _ -> None + + let args_of_yojson_list args = + let open Option.O in + let+ args = + List.fold_left + ~f:(fun acc x -> + let* acc in + let+ x = stringish_of_yojson x in + x :: acc) + ~init:(Some []) + args + in + List.rev args + + let args_of_yojson_assoc args = + let open Option.O in + let+ args = + List.fold_left + ~f:(fun acc (key, value) -> + let key = "-" ^ key in + let* acc in + let+ x = stringish_of_yojson value in + x :: key :: acc) + ~init:(Some []) + args + in + List.rev args + + let args_of_yojson params = + match List.assoc_opt "args" params with + | Some (`List args) -> args_of_yojson_list args + | Some (`Assoc args) -> args_of_yojson_assoc args + | _ -> + (* If args is not a list or is absent, it should fail. *) + None + + let t_of_yojson = function + | `Assoc params -> + let result_as_sexp = as_sexp_of_yojson params in + let open Option.O in + let* command = command_of_yojson params in + let* args = args_of_yojson params in + let* uri = uri_of_yojson params in + Some { result_as_sexp; command; args; uri } + | _ -> None +end + +let raise_invalid_params ?data ~message () = + let open Jsonrpc.Response.Error in + raise @@ make ?data ~code:Code.InvalidParams ~message () + +let from_structured_json_exn = function + | None -> raise_invalid_params ~message:"Expected params but received none" () + | Some params -> ( + match Request_params.t_of_yojson params with + | Some params -> params + | None -> + let data = + `Assoc + [ ("expectedParams", Request_params.expected) + ; ("receivedParams", (params :> Json.t)) + ] + in + raise_invalid_params ~data ~message:"Unexpected params format" ()) + +let with_pipeline state uri specs raw_args cmd_args f = + let doc = Document_store.get state.State.store uri in + match Document.kind doc with + | `Other -> Fiber.return `Null + | `Merlin merlin -> + let open Fiber.O in + let* config = Document.Merlin.mconfig merlin in + let specs = List.map ~f:snd specs in + let config, args = + Mconfig.parse_arguments + ~wd:(Sys.getcwd ()) + ~warning:ignore + specs + raw_args + config + cmd_args + in + Document.Merlin.with_configurable_pipeline_exn ~config merlin (f args) + +let perform_query action params pipeline = + let action () = action pipeline params in + let class_, output = + match action () with + | result -> ("return", result) + | exception Failure message -> ("failure", `String message) + | exception exn -> + let message = Printexc.to_string exn in + ("exception", `String message) + in + `Assoc [ ("class", `String class_); ("value", output) ] + +let on_request ~params state = + Fiber.of_thunk (fun () -> + let Request_params.{ result_as_sexp; command; args; uri } = + from_structured_json_exn params + in + match + Merlin_commands.New_commands.(find_command command all_commands) + with + | Merlin_commands.New_commands.Command (_name, _doc, specs, params, action) + -> + let open Fiber.O in + let+ json = + with_pipeline state uri specs args params @@ perform_query action + in + let result = + if result_as_sexp then + Merlin_utils.(json |> Sexp.of_json |> Sexp.to_string) + else json |> Yojson.Basic.to_string + in + `Assoc + [ ("resultAsSexp", `Bool result_as_sexp); ("result", `String result) ] + | exception Not_found -> + let data = `Assoc [ ("command", `String command) ] in + raise_invalid_params ~data ~message:"Unexpected command name" ()) diff --git a/ocaml-lsp-server/src/custom_requests/req_merlin_call_compatible.mli b/ocaml-lsp-server/src/custom_requests/req_merlin_call_compatible.mli new file mode 100644 index 000000000..5dfe607fc --- /dev/null +++ b/ocaml-lsp-server/src/custom_requests/req_merlin_call_compatible.mli @@ -0,0 +1,7 @@ +open Import + +val capability : string * Json.t + +val meth : string + +val on_request : params:Jsonrpc.Structured.t option -> State.t -> Json.t Fiber.t diff --git a/ocaml-lsp-server/src/dune b/ocaml-lsp-server/src/dune index 90f17a714..129c9d8a9 100644 --- a/ocaml-lsp-server/src/dune +++ b/ocaml-lsp-server/src/dune @@ -25,6 +25,7 @@ merlin-lib.ocaml_utils merlin-lib.utils merlin-lib.extend + merlin-lib.commands cmarkit odoc_parser ppx_yojson_conv_lib From 2f046d87a71740b78b2f84bbe01b6040155947ae Mon Sep 17 00:00:00 2001 From: xvw Date: Tue, 11 Jun 2024 10:13:54 +0200 Subject: [PATCH 3/5] Add merlinCallCompatible (activation+specs) - add change entry - fix start_stop test --- CHANGES.md | 5 ++ .../ocamllsp/merlinCallCompatible-specs.md | 64 +++++++++++++++++++ ocaml-lsp-server/src/ocaml_lsp_server.ml | 2 + ocaml-lsp-server/test/e2e-new/start_stop.ml | 3 +- 4 files changed, 73 insertions(+), 1 deletion(-) create mode 100644 ocaml-lsp-server/docs/ocamllsp/merlinCallCompatible-specs.md diff --git a/CHANGES.md b/CHANGES.md index d2e7e049b..ec7790ea3 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -38,6 +38,11 @@ - Add an `update-signature` code action to update the types of elements that were already present in the signature (#1289) +- Add custom + [`ocamllsp/merlinCallCompatible`](https://github.com/ocaml/ocaml-lsp/blob/e165f6a3962c356adc7364b9ca71788e93489dd0/ocaml-lsp-server/docs/ocamllsp/merlinCallCompatible-spec.md) + request (#1265) + + ## Fixes - Detect document kind by looking at merlin's `suffixes` config. diff --git a/ocaml-lsp-server/docs/ocamllsp/merlinCallCompatible-specs.md b/ocaml-lsp-server/docs/ocamllsp/merlinCallCompatible-specs.md new file mode 100644 index 000000000..0734855a2 --- /dev/null +++ b/ocaml-lsp-server/docs/ocamllsp/merlinCallCompatible-specs.md @@ -0,0 +1,64 @@ +# Merlin Call Compatible Request + +## Description + +Allows Merlin commands to be invoked from LSP, in the same way as the +`ocamlmerlin` binary, using a custom request. Invoking this command returns the +result in the form of a character string (which can be JSON or SEXP) +representing the result of a Merlin command. This makes it possible to implement +clients capable of fallbacking on Merlin in the event of a missing feature. + +### Why this custom request needed + +It allows editor plugin to communicate with the ocaml-lsp-server using the +merlin protocol, it will be useful for text-based editors that want to preserve +the classic Merlin UI while using ocaml-lsp-server. (It is a temporary solution +that will progressively be replaced by tailored custom requests filling the gaps +in the protocol) + +## Client capability + +There is no client capability relative to this request + +## Server capability + +property name: `handleMerlinCallCompatible` + +property type: `boolean` + +## Request + +- method: `ocamllsp/merlinCallCompatible` +- params: + +```json +{ + "uri": DocumentUri, + "command": string, + "args": string[], + "resultAsSexp": boolean +} +``` + +- `uri`: is the reference of the current document +- `command`: is the name of the command invoked (ie: `case-analysis`) +- `args`: all the parameters passed to the command, by default: `[]` +- `resultAsSexp`: a flag indicating whether the result should be returned in + SEXP (`true`) or JSON (`false`), by default: `false` + +For an exhaustive description of what the query returns, please refer to the +[Merlin +protocol](https://github.com/ocaml/merlin/blob/master/doc/dev/PROTOCOL.md) + +## Response + +```json +{ + "resultAsSexp": boolean, + "result": string +} +``` + +- `resultAsSexp`: `true` if the command was invoked with the `resultAsSexp` flag, + `false` otherwise +- `result`: the result in string (in JSON or SEXP) diff --git a/ocaml-lsp-server/src/ocaml_lsp_server.ml b/ocaml-lsp-server/src/ocaml_lsp_server.ml index 674cf227d..8a7f3e655 100644 --- a/ocaml-lsp-server/src/ocaml_lsp_server.ml +++ b/ocaml-lsp-server/src/ocaml_lsp_server.ml @@ -98,6 +98,7 @@ let initialize_info (client_capabilities : ClientCapabilities.t) : ; Req_wrapping_ast_node.capability ; Dune.view_promotion_capability ; Req_hover_extended.capability + ; Req_merlin_call_compatible.capability ] ) ] in @@ -519,6 +520,7 @@ let on_request : Fiber.return (Req_switch_impl_intf.on_request ~params state)) ) ; (Req_infer_intf.meth, Req_infer_intf.on_request) ; (Req_typed_holes.meth, Req_typed_holes.on_request) + ; (Req_merlin_call_compatible.meth, Req_merlin_call_compatible.on_request) ; (Req_wrapping_ast_node.meth, Req_wrapping_ast_node.on_request) ; ( Semantic_highlighting.Debug.meth_request_full , Semantic_highlighting.Debug.on_request_full ) diff --git a/ocaml-lsp-server/test/e2e-new/start_stop.ml b/ocaml-lsp-server/test/e2e-new/start_stop.ml index dd8ab0dfe..dab3b1580 100644 --- a/ocaml-lsp-server/test/e2e-new/start_stop.ml +++ b/ocaml-lsp-server/test/e2e-new/start_stop.ml @@ -91,7 +91,8 @@ let%expect_test "start/stop" = "handleTypedHoles": true, "handleWrappingAstNode": true, "diagnostic_promotions": true, - "handleHoverExtended": true + "handleHoverExtended": true, + "handleMerlinCallCompatible": true } }, "foldingRangeProvider": true, From d237c4605bbcbe35df530a629cb278bbeaff4b86 Mon Sep 17 00:00:00 2001 From: xvw Date: Tue, 11 Jun 2024 10:14:57 +0200 Subject: [PATCH 4/5] Add test for merlinCallCompatible --- ocaml-lsp-server/test/e2e-new/dune | 1 + .../test/e2e-new/merlin_call_compatible.ml | 127 ++++++++++++++++++ 2 files changed, 128 insertions(+) create mode 100644 ocaml-lsp-server/test/e2e-new/merlin_call_compatible.ml diff --git a/ocaml-lsp-server/test/e2e-new/dune b/ocaml-lsp-server/test/e2e-new/dune index fe4d8b125..62954baec 100644 --- a/ocaml-lsp-server/test/e2e-new/dune +++ b/ocaml-lsp-server/test/e2e-new/dune @@ -52,6 +52,7 @@ for_ppx hover_extended inlay_hints + merlin_call_compatible metrics semantic_hl_data semantic_hl_helpers diff --git a/ocaml-lsp-server/test/e2e-new/merlin_call_compatible.ml b/ocaml-lsp-server/test/e2e-new/merlin_call_compatible.ml new file mode 100644 index 000000000..049275302 --- /dev/null +++ b/ocaml-lsp-server/test/e2e-new/merlin_call_compatible.ml @@ -0,0 +1,127 @@ +open Test.Import + +let call_merlin_compatible client command args result_as_sexp = + let uri = DocumentUri.of_path "test.ml" in + let params = + `Assoc + [ ("uri", DocumentUri.yojson_of_t uri) + ; ("command", `String command) + ; ("args", args) + ; ("resultAsSexp", `Bool result_as_sexp) + ] + in + let params = Some (Jsonrpc.Structured.t_of_yojson params) in + let req = + Lsp.Client_request.UnknownRequest + { meth = "ocamllsp/merlinCallCompatible"; params } + in + Client.request client req + +let print_merin_call_compatible result = + result |> Yojson.Safe.pretty_to_string ~std:false |> print_endline + +let list l = `List (List.map ~f:(fun x -> `String x) l) + +let obj l = `Assoc (List.map ~f:(fun (k, v) -> (k, `String v)) l) + +let%expect_test "case-analysis on simple example" = + let source = + {|type t = {a: int * int; b: string} +let f ({a; b} : t) = assert false|} + in + let request client = + let open Fiber.O in + let args = list [ "-start"; "2:9"; "-end"; "2:9" ] in + let+ response = call_merlin_compatible client "case-analysis" args false in + print_merin_call_compatible response + in + Helpers.test source request; + [%expect + {| + { + "resultAsSexp": false, + "result": "{\"class\":\"return\",\"value\":[{\"start\":{\"line\":2,\"col\":8},\"end\":{\"line\":2,\"col\":9}},\"a = (_, _)\"]}" + } |}] + +let%expect_test "case-analysis on simple example using object instead of args" = + let source = + {|type t = {a: int * int; b: string} +let f ({a; b} : t) = assert false|} + in + let request client = + let open Fiber.O in + let args = obj [ ("start", "2:9"); ("end", "2:9") ] in + let+ response = call_merlin_compatible client "case-analysis" args false in + print_merin_call_compatible response + in + Helpers.test source request; + [%expect + {| + { + "resultAsSexp": false, + "result": "{\"class\":\"return\",\"value\":[{\"start\":{\"line\":2,\"col\":8},\"end\":{\"line\":2,\"col\":9}},\"a = (_, _)\"]}" + } |}] + +let%expect_test "case-analysis on empty example" = + let source = {||} in + let request client = + let open Fiber.O in + let args = list [ "-start"; "2:9"; "-end"; "2:9" ] in + let+ response = call_merlin_compatible client "case-analysis" args false in + print_merin_call_compatible response + in + Helpers.test source request; + [%expect + {| + { + "resultAsSexp": false, + "result": "{\"class\":\"exception\",\"value\":\"Merlin_analysis.Destruct.Nothing_to_do\"}" + } |}] + +let%expect_test "case-analysis on simple example with result as sexp" = + let source = + {|type t = {a: int * int; b: string} +let f ({a; b} : t) = assert false|} + in + let request client = + let open Fiber.O in + let args = list [ "-start"; "2:9"; "-end"; "2:9" ] in + let+ response = call_merlin_compatible client "case-analysis" args true in + print_merin_call_compatible response + in + Helpers.test source request; + [%expect + {| + { + "resultAsSexp": true, + "result": "((assoc) (class . \"return\") (value ((assoc) (start (assoc) (line . 2) (col . 8)) (end (assoc) (line . 2) (col . 9))) \"a = (_, _)\"))" + } |}] + +let%expect_test "errors: warning is shown" = + let source = {|let () = match Some 3 with | None -> ()|} in + let request client = + let open Fiber.O in + let args = list [] in + let+ response = call_merlin_compatible client "errors" args false in + print_merin_call_compatible response + in + Helpers.test source request; + [%expect + {| + { + "resultAsSexp": false, + "result": "{\"class\":\"return\",\"value\":[{\"start\":{\"line\":1,\"col\":9},\"end\":{\"line\":1,\"col\":39},\"type\":\"warning\",\"sub\":[],\"valid\":true,\"message\":\"Warning 8: this pattern-matching is not exhaustive.\\nHere is an example of a case that is not matched:\\nSome _\"}]}" + } |}] + +let%expect_test "errors: warning is disabled" = + let source = {|let () = match Some 3 with | None -> ()|} in + let request client = + let open Fiber.O in + let args = list [ "-w"; "-8" ] in + let+ response = call_merlin_compatible client "errors" args false in + print_merin_call_compatible response + in + Helpers.test source request; + [%expect + {| + { "resultAsSexp": false, "result": "{\"class\":\"return\",\"value\":[]}" } |}] From 3ecc06690072de746d6b697fad45f8b11dc0d075 Mon Sep 17 00:00:00 2001 From: xvw Date: Tue, 11 Jun 2024 10:52:09 +0200 Subject: [PATCH 5/5] Bump dependencies --- dune-project | 2 +- ocaml-lsp-server.opam | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/dune-project b/dune-project index 381278bd7..2a161a3bf 100644 --- a/dune-project +++ b/dune-project @@ -69,7 +69,7 @@ possible and does not make any assumptions about IO. (ocamlformat-rpc-lib (>= 0.21.0)) (odoc :with-doc) (ocaml (and (>= 4.14) (< 5.2))) - (merlin-lib (and (>= 4.14) (< 5.0))))) + (merlin-lib (and (>= 4.16) (< 5.0))))) (package (name jsonrpc) diff --git a/ocaml-lsp-server.opam b/ocaml-lsp-server.opam index 39f9dfb7c..a3fd5abf5 100644 --- a/ocaml-lsp-server.opam +++ b/ocaml-lsp-server.opam @@ -45,7 +45,7 @@ depends: [ "ocamlformat-rpc-lib" {>= "0.21.0"} "odoc" {with-doc} "ocaml" {>= "4.14" & < "5.2"} - "merlin-lib" {>= "4.14" & < "5.0"} + "merlin-lib" {>= "4.16" & < "5.0"} ] dev-repo: "git+https://github.com/ocaml/ocaml-lsp.git" build: [