feat: support for textDocument/rename

src/lsp/cobol_lsp/lsp_capabilities.ml

@@ -46,8 +46,7 @@ let reply (_: ClientCapabilities.t) =
     in
     ServerCapabilities.create_workspace ()
       ~workspaceFolders
-  in
-  let codeLensProvider = CodeLensOptions.create () in
+  and codeLensProvider = CodeLensOptions.create () in
   ServerCapabilities.create ()
     ~textDocumentSync:(`TextDocumentSyncOptions sync)
     ~definitionProvider:(`Bool true)
@@ -61,3 +60,4 @@ let reply (_: ClientCapabilities.t) =
     ~workspace
     ~documentSymbolProvider:(`Bool true)
     ~codeLensProvider
+    ~renameProvider:(`Bool true)

src/lsp/cobol_lsp/lsp_imports.ml

@@ -15,4 +15,10 @@
 
 module CUs = Cobol_unit.Collections.SET
 module CUMap = Cobol_unit.Collections.MAP
-module URIMap = Map.Make (Lsp.Uri)
+module URIMap = struct
+  include Map.Make (Lsp.Uri)
+
+  let add_to_list x data m =
+      let add = function None -> Some [data] | Some l -> Some (data :: l) in
+      update x add m
+end

src/lsp/cobol_lsp/lsp_request.ml

@@ -580,7 +580,7 @@ let handle_folding_range registry (params: FoldingRangeParams.t) =
 
 let handle_document_symbol registry (params: DocumentSymbolParams.t) =
   try_with_main_document_data registry params.textDocument
-    ~f:begin fun ~doc { ptree; _ }->
+    ~f:begin fun ~doc { ptree; _ } ->
       let uri = Lsp.Text_document.documentUri doc.textdoc in
       let symbols = Lsp_document_symbol.from_ptree_at ~uri ptree in
       Some (`DocumentSymbol symbols)
@@ -677,6 +677,35 @@ let handle_codelens registry ({ textDocument; _ }: CodeLensParams.t) =
     end
   |> Option.value ~default:[]
 
+(** { Rename } *)
+
+exception CopybookRenameError
+
+let handle_rename registry (params: RenameParams.t) =
+  let { textDocument; position; newName = newText; _ }: RenameParams.t = params in
+  let doc = Lsp_server.find_document params.textDocument registry in
+  let checked_doc = Lsp_document.checked doc in
+  let rootdir = Lsp_project.(string_of_rootdir @@ rootdir doc.project) in
+  let locations = Option.value ~default:[] @@
+    let context = ReferenceContext.create ~includeDeclaration:true in
+    let params = ReferenceParams.create
+        ~context ~position ~textDocument () in
+    lookup_references_in_doc ~rootdir params checked_doc in
+  try
+    let changes = List.fold_left begin fun acc ({ range; uri }: Location.t) ->
+        if DocumentUri.compare uri params.textDocument.uri <> 0
+        then raise CopybookRenameError
+        else
+          let textEdit = TextEdit.create ~newText ~range in
+          URIMap.add_to_list uri textEdit acc
+      end URIMap.empty locations
+                  |> URIMap.to_seq
+                  |> List.of_seq
+    in
+    Ok(WorkspaceEdit.create ~changes ())
+  with CopybookRenameError ->
+    Error "Reference of variable found in copybook, aborting rename"
+
 (** {3 Generic handling} *)
 
 let shutdown: state -> unit = function
@@ -722,17 +751,21 @@ let on_request
         Ok (handle_folding_range registry params, state)
     | Shutdown ->
         Ok (handle_shutdown registry, ShuttingDown)
-    | DocumentSymbol  (* DocumentSymbolParams.t.t *) params ->
+    | DocumentSymbol params ->
         Ok (handle_document_symbol registry params, state)
     | TextDocumentCodeLens (* CodeLensParams.t.t *) params ->
         Ok (handle_codelens registry params, state)
+    | TextDocumentRename params ->
+        begin match handle_rename registry params with
+          | Ok workspaceEdit -> Ok (workspaceEdit, state)
+          | Error _ -> Error (CopybookRenamingForbidden)
+        end
     | TextDocumentDeclaration  (* TextDocumentPositionParams.t.t *) _
     | TextDocumentTypeDefinition  (* TypeDefinitionParams.t.t *) _
     | TextDocumentImplementation  (* ImplementationParams.t.t *) _
     | TextDocumentCodeLensResolve  (* CodeLens.t.t *) _
     | TextDocumentPrepareCallHierarchy  (* CallHierarchyPrepareParams.t.t *) _
     | TextDocumentPrepareRename  (* PrepareRenameParams.t.t *) _
-    | TextDocumentRename  (* RenameParams.t.t *) _
     | TextDocumentLink  (* DocumentLinkParams.t.t *) _
     | TextDocumentLinkResolve  (* DocumentLink.t.t *) _
     | TextDocumentMoniker  (* MonikerParams.t.t *) _
@@ -800,4 +833,5 @@ module INTERNAL = struct
   let codelens = handle_codelens
   let document_symbol = handle_document_symbol
   let formatting = handle_formatting
+  let rename = handle_rename
 end

src/lsp/cobol_lsp/lsp_request.mli

@@ -45,4 +45,8 @@ module INTERNAL: sig
     : Lsp_server.t
     -> Lsp.Types.CodeLensParams.t
     -> Lsp.Types.CodeLens.t list
+  val rename
+    : Lsp_server.t
+    -> Lsp.Types.RenameParams.t
+    -> (Lsp.Types.WorkspaceEdit.t, string) result
 end

src/lsp/cobol_lsp/lsp_server.ml

@@ -82,6 +82,7 @@ module TYPES = struct
   and exit_status = (unit, string) result
 
   type 'a error =
+    | CopybookRenamingForbidden
     | InvalidStatus of state
     | UnhandledRequest of 'a Lsp.Client_request.t
     | UnknownRequest of string
@@ -735,5 +736,7 @@ let jsonrpc_of_error error method_ =
         RequestFailed, Fmt.str "Unhandled request: %s" method_
     | UnknownRequest method_ ->
         MethodNotFound, Fmt.str "Unknown request method: %s" method_
+    | CopybookRenamingForbidden ->
+        RequestFailed, Fmt.str "Cancelled rename of variable contained in a copybook"
   in
   Jsonrpc.Response.Error.make ~code ~message ()

src/lsp/cobol_lsp/lsp_server.mli

@@ -53,6 +53,7 @@ module TYPES: sig
   and exit_status = (unit, string) result
 
   type 'a error =
+    | CopybookRenamingForbidden
     | InvalidStatus of state
     | UnhandledRequest of 'a Lsp.Client_request.t
     | UnknownRequest of string

test/lsp/lsp_rename.ml

@@ -0,0 +1,191 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                        SuperBOL OSS Studio                             *)
+(*                                                                        *)
+(*  Copyright (c) 2022-2023 OCamlPro SAS                                  *)
+(*                                                                        *)
+(* All rights reserved.                                                   *)
+(* This source code is licensed under the GNU Affero General Public       *)
+(* License version 3 found in the LICENSE.md file in the root directory   *)
+(* of this source tree.                                                   *)
+(*                                                                        *)
+(**************************************************************************)
+
+open EzCompat                                                    (* StringMap *)
+open Lsp.Types
+open Lsp_testing
+
+let pp_assoc_elem ppf ((uri, edits): DocumentUri.t * TextEdit.t list) =
+  let pp_range ppf range =
+  let location_as_srcloc = new srcloc_resuscitator_cache in
+  location_as_srcloc#pp ppf @@ Location.create ~range ~uri
+  in
+  let pp_edit ppf (edit: TextEdit.t) =
+    Fmt.pf ppf "%s at " edit.newText;
+    pp_range ppf edit.range
+  in
+  Fmt.(list pp_edit) ppf edits
+
+let count l =
+  List.fold_left begin fun acc (_, t) -> acc + List.length t end 0 l
+
+let rename_positions ?(copybooks=[]) (doc, positions) : string -> unit =
+  let { end_with_postproc; projdir }, server = make_lsp_project () in
+  let server = List.fold_left begin fun server (name, document) ->
+      add_cobol_doc server ~projdir name document
+      |> fst
+    end server copybooks in
+  let server, prog = add_cobol_doc server ~projdir "prog.cob" doc in
+  let rename_at_position ?key (position: Position.t) =
+    let params = RenameParams.create ~newName:"aNewName" ~position ~textDocument:prog () in
+    Pretty.out "%a(line %d, character %d):\n"
+      Fmt.(option ~none:nop (string ++ sp)) key
+      position.line position.character;
+    begin
+      try
+      match LSP.Request.rename server params with
+      | Error e ->
+        Pretty.out "Renamed failed: %S@." e
+      | Ok { changes = None; _ } ->
+        Pretty.out "No renames@."
+      | Ok { changes = Some assoc; _ } ->
+        Pretty.out "@.@[<hv 4>%d rename entries:@;%a@]@\n"
+          (count assoc)
+          (Fmt.list ~sep:Fmt.sp pp_assoc_elem) assoc
+      with _ -> Pretty.out "Failed rename@."
+    end
+  in
+  StringMap.iter (fun n p -> rename_at_position ~key:n p) positions.pos_map;
+  List.iter (fun p -> rename_at_position p) positions.pos_anonymous;
+  end_with_postproc
+
+let%expect_test "rename" =
+  let end_with_postproc = rename_positions @@ extract_position_markers {cobol|
+        IDENTIFICATION DIVISION.
+        PROGRAM-ID. prog.
+        DATA DIVISION.
+        WORKING-STORAGE SECTION.
+        01 o_|_ld-name PIC 9.
+        PROCEDURE DIVISION.
+          MOVE 1 TO old-na_|_me.
+          S_|_TOP RUN.
+  |cobol}
+  in
+  end_with_postproc [%expect.output];
+  [%expect {|
+    {"params":{"diagnostics":[],"uri":"file://__rootdir__/prog.cob"},"method":"textDocument/publishDiagnostics","jsonrpc":"2.0"}
+    (line 5, character 12):
+    2 rename entries:
+        aNewName at __rootdir__/prog.cob:8.20-8.28:
+           5           WORKING-STORAGE SECTION.
+       6           01 old-name PIC 9.
+       7           PROCEDURE DIVISION.
+       8 >           MOVE 1 TO old-name.
+    ----                       ^^^^^^^^
+       9             STOP RUN.
+      10
+    aNewName at __rootdir__/prog.cob:6.11-6.19:
+       3           PROGRAM-ID. prog.
+       4           DATA DIVISION.
+       5           WORKING-STORAGE SECTION.
+       6 >         01 old-name PIC 9.
+    ----              ^^^^^^^^
+       7           PROCEDURE DIVISION.
+       8             MOVE 1 TO old-name.
+    (line 7, character 26):
+    2 rename entries:
+        aNewName at __rootdir__/prog.cob:8.20-8.28:
+           5           WORKING-STORAGE SECTION.
+       6           01 old-name PIC 9.
+       7           PROCEDURE DIVISION.
+       8 >           MOVE 1 TO old-name.
+    ----                       ^^^^^^^^
+       9             STOP RUN.
+      10
+    aNewName at __rootdir__/prog.cob:6.11-6.19:
+       3           PROGRAM-ID. prog.
+       4           DATA DIVISION.
+       5           WORKING-STORAGE SECTION.
+       6 >         01 old-name PIC 9.
+    ----              ^^^^^^^^
+       7           PROCEDURE DIVISION.
+       8             MOVE 1 TO old-name.
+    (line 8, character 11):
+    0 rename entries: |}]
+
+let%expect_test "rename-copybook" =
+  let copybooks = [
+    ("lib.cpy", {cobol|
+        01 copied-var pic 9.|cobol})
+  ] in
+  let end_with_postproc = rename_positions ~copybooks @@ extract_position_markers {cobol|
+        IDENTIFICATION DIVISION.
+        PROGRAM-ID. prog.
+        DATA DIVISION.
+        WORKING-STORAGE SECTION.
+        COPY "lib.cpy".
+        PROCEDURE DIVISION.
+          MOVE 1 TO c_|_opied-var.
+          STOP RUN.
+  |cobol}
+  in
+  end_with_postproc [%expect.output];
+  [%expect {|
+    {"params":{"diagnostics":[],"uri":"file://__rootdir__/lib.cpy"},"method":"textDocument/publishDiagnostics","jsonrpc":"2.0"}
+    {"params":{"diagnostics":[],"uri":"file://__rootdir__/prog.cob"},"method":"textDocument/publishDiagnostics","jsonrpc":"2.0"}
+    (line 7, character 21):
+    Renamed failed: "Reference of variable found in copybook, aborting rename" |}]
+
+let%expect_test "rename-procedure" =
+  let end_with_postproc = rename_positions @@ extract_position_markers {cobol|
+        IDENTIFICATION DIVISION.
+        PROGRAM-ID. prog.
+        PROCEDURE DIVISION.
+          s_|newSectionName|_ec SECTION.
+          PERFORM sec.
+          GO par_|_a.
+          para.
+          STOP RUN.
+  |cobol}
+  in
+  end_with_postproc [%expect.output];
+  [%expect {|
+    {"params":{"diagnostics":[],"uri":"file://__rootdir__/prog.cob"},"method":"textDocument/publishDiagnostics","jsonrpc":"2.0"}
+    newSectionName
+    (line 4, character 11):
+    2 rename entries:
+        aNewName at __rootdir__/prog.cob:6.18-6.21:
+           3           PROGRAM-ID. prog.
+       4           PROCEDURE DIVISION.
+       5             sec SECTION.
+       6 >           PERFORM sec.
+    ----                     ^^^
+       7             GO para.
+       8             para.
+    aNewName at __rootdir__/prog.cob:5.10-5.13:
+       2           IDENTIFICATION DIVISION.
+       3           PROGRAM-ID. prog.
+       4           PROCEDURE DIVISION.
+       5 >           sec SECTION.
+    ----             ^^^
+       6             PERFORM sec.
+       7             GO para.
+    (line 6, character 16):
+    2 rename entries:
+        aNewName at __rootdir__/prog.cob:7.13-7.17:
+           4           PROCEDURE DIVISION.
+       5             sec SECTION.
+       6             PERFORM sec.
+       7 >           GO para.
+    ----                ^^^^
+       8             para.
+       9             STOP RUN.
+    aNewName at __rootdir__/prog.cob:8.10-8.14:
+       5             sec SECTION.
+       6             PERFORM sec.
+       7             GO para.
+       8 >           para.
+    ----             ^^^^
+       9             STOP RUN.
+      10 |}]
+