Merge 3ecc066 into 1391b2b

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.

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)

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

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)

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

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

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 )

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