Add a custom query for raw invocation of Merlin (#1265)

* 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).

.github/workflows/build-and-test.yml

@@ -20,7 +20,7 @@ jobs:
           - ubuntu-latest
         ocaml-compiler:
           - "4.14"
-          - "5.0"
+          # - "5.0"
           - "5.1"
         include:
           - os: macos-latest

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.

Makefile

@@ -42,7 +42,8 @@ bench: ##
 
 .PHONY: test-ocaml
 test-ocaml: ## Run the unit tests
-	dune build @lsp/test/runtest @lsp-fiber/runtest @jsonrpc-fiber/runtest @ocaml-lsp-server/runtest
+	# FIXME: Find another approach to prevent competing test runs from causing errors
+	dune build  -j 1 @lsp/test/runtest @lsp-fiber/runtest @jsonrpc-fiber/runtest @ocaml-lsp-server/runtest
 
 .PHONY: promote
 promote:
@@ -105,5 +106,6 @@ coverage-deps:
 
 .PHONY: test-coverage
 test-coverage:
-	dune build --instrument-with bisect_ppx --force @lsp/test/runtest @lsp-fiber/runtest @jsonrpc-fiber/runtest @ocaml-lsp-server/runtest
+	# FIXME: Find another approach to prevent competing test runs from causing errors
+	dune build -j 1 --instrument-with bisect_ppx --force @lsp/test/runtest @lsp-fiber/runtest @jsonrpc-fiber/runtest @ocaml-lsp-server/runtest
 	bisect-ppx-report send-to Coveralls

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)

flake.nix

@@ -3,11 +3,11 @@
     flake-utils.url = "github:numtide/flake-utils";
     nixpkgs.url = "github:nixos/nixpkgs/nixpkgs-unstable";
     merlin4_14 = {
-      url = "github:ocaml/merlin/v4.14-414";
+      url = "github:ocaml/merlin/v4.16-414";
       flake = false;
     };
     merlin5_1 = {
-      url = "github:ocaml/merlin/v4.14-501";
+      url = "github:ocaml/merlin/v4.16-501";
       flake = false;
     };
   };

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: [

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)

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 "<DocumentUri>")
+      ; ("resultAsSexp?", `String "<true | false>")
+      ; ("command", `String "<MerlinCommand>")
+      ; ("args?", `String "<string | bool | float | int | intLit>[] | 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" ())

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