Merge branch 'master' into fix/failing-completion

CHANGELOG.md

@@ -4,6 +4,7 @@
 
 ### Added
 - Completion for more grammar constructs [#322](https://github.com/OCamlPro/superbol-studio-oss/pull/322)
+- Support for LSP request `textDocument/codeLens` [#349](https://github.com/OCamlPro/superbol-studio-oss/pull/349)
 - Show display example of `NUMERIC-EDITED` data on hover [#337](https://github.com/OCamlPro/superbol-studio-oss/pull/337)
 - Support for dump and listing files, along with a task attribute for outputting the latter [#347](https://github.com/OCamlPro/superbol-studio-oss/pull/347)
 - Improved information shown on completion [#336](https://github.com/OCamlPro/superbol-studio-oss/pull/336)

src/lsp/cobol_lsp/lsp_capabilities.ml

@@ -47,6 +47,7 @@ let reply (_: ClientCapabilities.t) =
     ServerCapabilities.create_workspace ()
       ~workspaceFolders
   in
+  let codeLensProvider = CodeLensOptions.create () in
   ServerCapabilities.create ()
     ~textDocumentSync:(`TextDocumentSyncOptions sync)
     ~definitionProvider:(`Bool true)
@@ -59,3 +60,4 @@ let reply (_: ClientCapabilities.t) =
     ~completionProvider:completion_option
     ~workspace
     ~documentSymbolProvider:(`Bool true)
+    ~codeLensProvider

src/lsp/cobol_lsp/lsp_request.ml

@@ -586,6 +586,97 @@ let handle_document_symbol registry (params: DocumentSymbolParams.t) =
       Some (`DocumentSymbol symbols)
     end
 
+(** { Document Code Lens } *)
+
+module Positions = Set.Make (struct
+    type t = Position.t
+    let compare (p1: t) (p2: t) =
+      let c = p2.line - p1.line in
+      if c <> 0 then c else p2.character - p1.character
+  end)
+
+let codelens_positions ~uri group =
+  let filename = Lsp.Uri.to_path uri in
+  let open struct
+    include Cobol_common.Visitor
+    include Cobol_data.Visitor
+    type context =
+      | ProcedureDiv
+      | DataDiv
+      | None
+  end in
+  let set_context context (old, acc) =
+    do_children_and_then (context, acc) (fun (_, acc) -> (old, acc))
+  in
+  let take_when_in context { loc; _ } (current, acc) =
+    if context <> current
+    then skip (current, acc)
+    else
+      let range = Lsp_position.range_of_srcloc_in ~filename loc in
+      skip (context, Positions.add range.start acc)
+  in
+  Cobol_unit.Visitor.fold_unit_group
+    object (v)
+      inherit [_] Cobol_unit.Visitor.folder
+      method! fold_procedure _ = set_context ProcedureDiv
+      method! fold_data_definitions _ = set_context DataDiv
+      method! fold_paragraph' _ = skip
+      method! fold_procedure_name' = take_when_in ProcedureDiv
+      method! fold_qualname' = take_when_in DataDiv
+      method! fold_record_renaming { renaming_name; _ } =
+        take_when_in DataDiv renaming_name
+      method! fold_field_definition { field_qualname; field_redefines;
+                                      field_leading_ranges;
+                                      field_offset; field_size; field_layout;
+                                      field_conditions; field_redefinitions;
+                                      field_length = _ } acc =
+        ignore(field_redefines, field_leading_ranges, field_offset, field_size);
+        skip @@ begin acc
+          |> Cobol_ptree.Terms_visitor.fold_qualname'_opt v field_qualname
+          |> fold_field_layout v field_layout
+          |> fold_condition_names v field_conditions
+          |> fold_item_redefinitions v field_redefinitions
+        end
+      method! fold_table_definition { table_field; table_offset; table_size;
+                                      table_range; table_init_values;
+                                      table_redefines; table_redefinitions } acc =
+        ignore(table_offset, table_size, table_init_values, table_redefines);
+        skip @@ begin acc
+          |> fold_field_definition' v table_field
+          |> fold_table_range v table_range
+          |> fold_item_redefinitions v table_redefinitions
+        end
+    end group (None, Positions.empty)
+  |> snd
+
+let handle_codelens registry ({ textDocument; _ }: CodeLensParams.t) =
+  try_with_main_document_data registry textDocument
+    ~f:begin fun ~doc checked_doc ->
+      let uri = Lsp.Text_document.documentUri doc.textdoc in
+      let rootdir = Lsp_project.(string_of_rootdir @@ rootdir doc.project) in
+      let context = ReferenceContext.create ~includeDeclaration:true in
+      codelens_positions ~uri checked_doc.group
+      |> Positions.to_seq
+      |> Seq.map begin fun position ->
+        let params =
+          ReferenceParams.create ~context ~position ~textDocument () in
+        let ref_count =
+          lookup_references_in_doc ~rootdir params checked_doc
+          |> Option.fold ~none:0 ~some:List.length in
+        let title = string_of_int ref_count
+                    ^ " reference"
+                    ^ if ref_count > 1 then "s" else "" in
+        let range = Range.create ~end_:position ~start:position in
+        let uri = DocumentUri.yojson_of_t textDocument.uri in
+        let command = Command.create () ~title
+            ~command:"superbol.editor.action.findReferences"
+            ~arguments:[uri; Position.yojson_of_t position] in
+        CodeLens.create ~command ~range ()
+      end
+      |> List.of_seq |> Option.some
+    end
+  |> Option.value ~default:[]
+
 (** {3 Generic handling} *)
 
 let shutdown: state -> unit = function
@@ -633,10 +724,11 @@ let on_request
         Ok (handle_shutdown registry, ShuttingDown)
     | DocumentSymbol  (* DocumentSymbolParams.t.t *) params ->
         Ok (handle_document_symbol registry params, state)
+    | TextDocumentCodeLens (* CodeLensParams.t.t *) params ->
+        Ok (handle_codelens registry params, state)
     | TextDocumentDeclaration  (* TextDocumentPositionParams.t.t *) _
     | TextDocumentTypeDefinition  (* TypeDefinitionParams.t.t *) _
     | TextDocumentImplementation  (* ImplementationParams.t.t *) _
-    | TextDocumentCodeLens  (* CodeLensParams.t.t *) _
     | TextDocumentCodeLensResolve  (* CodeLens.t.t *) _
     | TextDocumentPrepareCallHierarchy  (* CallHierarchyPrepareParams.t.t *) _
     | TextDocumentPrepareRename  (* PrepareRenameParams.t.t *) _
@@ -705,6 +797,7 @@ module INTERNAL = struct
   let lookup_references = handle_references
   let hover = handle_hover
   let completion = handle_completion
+  let codelens = handle_codelens
   let document_symbol = handle_document_symbol
   let formatting = handle_formatting
 end

src/lsp/cobol_lsp/lsp_request.mli

@@ -41,4 +41,8 @@ module INTERNAL: sig
     : Lsp_server.t
     -> Lsp.Types.DocumentSymbolParams.t
     -> [> `DocumentSymbol of Lsp.Types.DocumentSymbol.t list ] option
+  val codelens
+    : Lsp_server.t
+    -> Lsp.Types.CodeLensParams.t
+    -> Lsp.Types.CodeLens.t list
 end

src/lsp/cobol_typeck/typeck_procedure.ml

@@ -182,7 +182,7 @@ let references ~(data_definitions: Cobol_unit.Types.data_definitions) procedure
     { acc with diags = Proc_error err :: acc.diags }
   in
 
-  let visitor = object
+  let visitor = object (v)
     inherit [acc] Cobol_unit.Visitor.folder
 
     method! fold_qualname qn acc =                (* TODO: data_name' instead *)
@@ -212,10 +212,19 @@ let references ~(data_definitions: Cobol_unit.Types.data_definitions) procedure
           error acc @@ Ambiguous_data_name { given_qualname = qn &@ loc;
                                              matching_qualnames }
 
-    method! fold_procedure_section s ({ current_section; _ } as acc) =
-      Visitor.do_children_and_then
-        { acc with current_section = Some s }
-        (fun acc -> { acc with current_section })
+    method! fold_procedure_section ({ section_paragraphs; _ } as s)
+        ({ current_section; _ } as acc) =
+      let acc =
+        Visitor.fold_list v section_paragraphs.list
+          ~fold:Cobol_unit.Visitor.fold_procedure_paragraph'
+          { acc with current_section = Some s }
+      in
+      Visitor.skip { acc with current_section }
+
+    method! fold_procedure_paragraph { paragraph; _ } acc =
+      Visitor.skip @@
+      Cobol_ptree.Proc_division_visitor.fold_paragraph' v paragraph acc
+
 
     method! fold_procedure_name' ({ loc; _ } as qn)
         ({ current_section = in_section; _ } as acc) =

src/vscode/superbol-vscode-platform/superbol_commands.ml

@@ -27,13 +27,40 @@ type t =
     handler: handler;
   }
 
+let extension_oc : Vscode.OutputChannel.t Lazy.t =
+  lazy (Vscode.Window.createOutputChannel ~name:"SuperBOL Studio Extension")
+
 let commands = ref []
 
 let command id handler =
   let command = { id; handler } in
   commands := command :: !commands;
   command
 
+let _editor_action_findReferences =
+  let command_name = "superbol.editor.action.findReferences"  in
+  command command_name @@ Instance
+    begin fun _instance ~args ->
+      match args with
+      | [arg1; arg2] ->
+        let uri = Uri.t_to_js @@ Uri.parse (Ojs.string_of_js arg1) () in
+        let pos =
+          let line = Ojs.get_prop_ascii arg2 "line" |> Ojs.int_of_js in
+          let character = Ojs.get_prop_ascii arg2 "character" |> Ojs.int_of_js in
+          Position.t_to_js @@ Position.make ~line ~character in
+        let _ = Commands.executeCommand
+            ~command:"editor.action.findReferences"
+            ~args:[uri; pos]
+        in ()
+      | _ ->
+        let types_given = List.map Ojs.type_of args |> String.concat ", " in
+        let lazy oc = extension_oc in
+        let value = Printf.sprintf
+            "Internal warning: unexpected arguments given to %s: \
+             expected uri & position, got [%s]" command_name types_given in
+        OutputChannel.appendLine oc ~value
+    end
+
 let _restart_language_server =
   command "superbol.server.restart" @@ Instance
     begin fun instance ~args:_ ->