Destruct custom request

CHANGES.md

@@ -7,6 +7,7 @@
 - Add `typeExpression` custom request (#1576)
 - Add `locate` custom request (#1576)
 - Add `phrase` custom request (#1576)
+- Add `destruct` custom request (#1583)
 
 ## Fixes
 

ocaml-lsp-server/docs/ocamllsp/destruct-spec.md

@@ -0,0 +1,38 @@
+# Construct Request
+
+## Description
+
+Provides a query to performs `case analysis` on pattern matching
+clauses.
+
+## Client Capability
+
+There is no client capability relative to this request.
+
+## Server capability
+
+- property name: `handleDestruct`
+- property type: `boolean`
+
+## Request
+
+- method: `ocamllsp/destruct`
+- params:
+
+  ```json
+  {
+    "uri": TextDocumentIdentifier,
+    "range": Range
+  }
+  ```
+
+## Response
+
+```json
+{
+  "range": Range,
+  "content": string
+}
+```
+
+Contain the `range` to be substitute and the `content`.

ocaml-lsp-server/src/custom_requests/custom_request.ml

@@ -13,3 +13,4 @@ module Merlin_jump = Req_merlin_jump
 module Phrase = Req_phrase
 module Type_expression = Req_type_expression
 module Locate = Req_locate
+module Destruct = Req_destruct

ocaml-lsp-server/src/custom_requests/custom_request.mli

@@ -15,3 +15,4 @@ module Merlin_jump = Req_merlin_jump
 module Phrase = Req_phrase
 module Type_expression = Req_type_expression
 module Locate = Req_locate
+module Destruct = Req_destruct

ocaml-lsp-server/src/custom_requests/req_destruct.ml

@@ -0,0 +1,72 @@
+open Import
+
+let capability = "handleDestruct", `Bool true
+let meth = "ocamllsp/destruct"
+
+module Request_params = struct
+  type t =
+    { text_document : TextDocumentIdentifier.t
+    ; range : Range.t
+    }
+
+  let create ~text_document ~range () = { text_document; range }
+
+  let yojson_of_t { text_document; range } =
+    match TextDocumentIdentifier.yojson_of_t text_document with
+    | `Assoc assoc -> `Assoc (("range", Range.yojson_of_t range) :: assoc)
+    | _ -> (* unreachable *) assert false
+  ;;
+
+  let t_of_yojson json =
+    let open Yojson.Safe.Util in
+    let text_document = json |> TextDocumentIdentifier.t_of_yojson in
+    let range = json |> member "range" |> Range.t_of_yojson in
+    create ~text_document ~range ()
+  ;;
+end
+
+type t =
+  { range : Range.t
+  ; content : string
+  }
+
+let t_of_yojson json =
+  let open Yojson.Safe.Util in
+  let range = json |> member "range" |> Range.t_of_yojson
+  and content = json |> member "content" |> to_string in
+  { range; content }
+;;
+
+let yojson_of_t { range; content } =
+  `Assoc [ "range", Range.yojson_of_t range; "content", `String content ]
+;;
+
+let with_pipeline state uri f =
+  let doc = Document_store.get state.State.store uri in
+  match Document.kind doc with
+  | `Other -> Fiber.return `Null
+  | `Merlin merlin ->
+    (match Document.Merlin.kind merlin with
+     | Document.Kind.Intf ->
+       (* Destruct makes no sense if its called from an interface. *)
+       Fiber.return `Null
+     | Document.Kind.Impl -> Document.Merlin.with_pipeline_exn merlin f)
+;;
+
+let make_destruct_command start stop = Query_protocol.Case_analysis (start, stop)
+
+let dispatch_destruct range pipeline =
+  let start = range.Range.start |> Position.logical
+  and stop = range.Range.end_ |> Position.logical in
+  let command = make_destruct_command start stop in
+  let loc, content = Query_commands.dispatch pipeline command in
+  yojson_of_t { content; range = Range.of_loc loc }
+;;
+
+let on_request ~params state =
+  Fiber.of_thunk (fun () ->
+    let params = (Option.value ~default:(`Assoc []) params :> Json.t) in
+    let Request_params.{ text_document; range } = Request_params.t_of_yojson params in
+    let uri = text_document.uri in
+    with_pipeline state uri @@ dispatch_destruct range)
+;;

ocaml-lsp-server/src/custom_requests/req_destruct.mli

@@ -0,0 +1,15 @@
+open Import
+
+module Request_params : sig
+  type t
+
+  val create : text_document:Import.TextDocumentIdentifier.t -> range:Range.t -> unit -> t
+  val yojson_of_t : t -> Json.t
+end
+
+type t
+
+val t_of_yojson : Json.t -> t
+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/ocaml_lsp_server.ml

@@ -102,6 +102,7 @@ let initialize_info (client_capabilities : ClientCapabilities.t) : InitializeRes
               ; Req_phrase.capability
               ; Req_type_expression.capability
               ; Req_locate.capability
+              ; Req_destruct.capability
               ] )
         ]
     in
@@ -560,6 +561,7 @@ let on_request
          ; Req_phrase.meth, Req_phrase.on_request
          ; Req_type_expression.meth, Req_type_expression.on_request
          ; Req_locate.meth, Req_locate.on_request
+         ; Req_destruct.meth, Req_destruct.on_request
          ]
          meth
      with

ocaml-lsp-server/test/e2e-new/destruct.ml

@@ -0,0 +1,83 @@
+open Test.Import
+module Req = Ocaml_lsp_server.Custom_request.Destruct
+
+module Util = struct
+  let call_destruct client range =
+    let uri = DocumentUri.of_path "test.ml" in
+    let text_document = TextDocumentIdentifier.create ~uri in
+    let params =
+      Req.Request_params.create ~text_document ~range ()
+      |> Req.Request_params.yojson_of_t
+      |> Jsonrpc.Structured.t_of_yojson
+      |> Option.some
+    in
+    let req = Lsp.Client_request.UnknownRequest { meth = Req.meth; params } in
+    Client.request client req
+  ;;
+
+  let test pos source =
+    let range =
+      match pos with
+      | `Pos start ->
+        Range.create ~start ~end_:Position.{ start with character = start.character + 1 }
+      | `Range range -> range
+    in
+    let request client =
+      let open Fiber.O in
+      let+ response = call_destruct client range in
+      Test.print_result response
+    in
+    Helpers.test source request
+  ;;
+end
+
+let%expect_test "Perform `destruct` as custom request - 1" =
+  let source =
+    {|
+let _ =
+  match (None : unit option) with
+    | None -> ()
+    | Some _ -> ()
+|}
+  in
+  let pos = Position.create ~line:4 ~character:11 in
+  Util.test (`Pos pos) source;
+  [%expect
+    {|
+    {
+      "range": {
+        "end": { "character": 12, "line": 4 },
+        "start": { "character": 11, "line": 4 }
+      },
+      "content": "()"
+    }
+    |}]
+;;
+
+let%expect_test "Perform `destruct` as custom request - 2" =
+  let source =
+    {|
+type t =
+  | Foo
+  | Bar
+  | Baz of int option
+let f: t -> unit = function Foo -> ()
+|}
+  in
+  let pos =
+    let start = Position.create ~line:5 ~character:28
+    and end_ = Position.create ~line:5 ~character:31 in
+    Range.create ~start ~end_
+  in
+  Util.test (`Range pos) source;
+  [%expect
+    {|
+    {
+      "range": {
+        "end": { "character": 37, "line": 5 },
+        "start": { "character": 37, "line": 5 }
+      },
+      "content": "\n| Bar | Baz _ -> _"
+    }
+    |}]
+;;

ocaml-lsp-server/test/e2e-new/diagnostics_filter.ml

@@ -97,3 +97,44 @@ let%expect_test "shorten diagnostics - false" =
     ((8, 12), (10, 16))
     |}]
 ;;
+
+let%expect_test "Truncated error messages" =
+  let source =
+    {ocaml|let x = 10
+
+module F
+    (K : Map.OrderedType)
+    (V : sig
+      type value
+    end) =
+struct
+  module S = Map.Make (K)
+
+  type t = V.value S.t
+end
+
+module Val = struct
+  type value = string
+end
+
+module IValMap = F (Val)
+
+|ocaml}
+  in
+  print_diagnostics
+    ~prep:(fun client ->
+      change_config
+        client
+        (DidChangeConfigurationParams.create
+           ~settings:
+             (`Assoc [ "shortenMerlinDiagnostics", `Assoc [ "enable", `Bool false ] ])))
+    source;
+  [%expect
+    {|
+    This application of the functor F is ill-typed.
+    These arguments:
+      Val
+    do not match these parameters:
+      (K : Map.OrderedType) (V : ...) -> ...
+    |}]
+;;

ocaml-lsp-server/test/e2e-new/dune

@@ -58,6 +58,7 @@
     jump_to_typed_hole
     merlin_call_compatible
     diagnostics_filter
+    destruct
     metrics
     semantic_hl_data
     semantic_hl_helpers

ocaml-lsp-server/test/e2e-new/start_stop.ml

@@ -99,7 +99,8 @@ let%expect_test "start/stop" =
             "handleJump": true,
             "handlePhrase": true,
             "handleTypeExpression": true,
-            "handleLocate": true
+            "handleLocate": true,
+            "handleDestruct": true
           }
         },
         "foldingRangeProvider": true,