Merge pull request OCamlPro#316 from nberth/ux-adjustments

Various UX adjustments

src/lsp/cobol_lsp/lsp_request.ml

@@ -454,106 +454,100 @@ let handle_semtoks_full,
 
 (** {3 Hover} *)
 
-let always_show_hover_text_in_data_div = true
-
-let get_hover_text_and_defloc (qn: Cobol_ptree.qualname) (cu: Cobol_unit.Types.cobol_unit) =
-  let data_def =
-    try Cobol_unit.Qualmap.find qn cu.unit_data.data_items.named
-    with _ -> raise Not_found
-  in
-  Pretty.to_string "%a" Lsp_data_info_printer.pp_data_definition data_def,
-  Cobol_data.Item.def_loc data_def
-
-let get_hover_info cu_name element_at_pos group =
+let lookup_data_definition_for_hover cu_name element_at_pos group =
   let { payload = cu; _ } = CUs.find_by_name cu_name group in
-    match element_at_pos with
-      | Data_item { full_qn = Some qn; def_loc } ->
-          let text, _ = get_hover_text_and_defloc qn cu in
-          text, def_loc, def_loc
-      | Data_full_name qn | Data_name qn ->
-          let text, def_loc = get_hover_text_and_defloc qn cu in
-          text, def_loc, Lsp_lookup.baseloc_of_qualname qn
-      | Data_item _ | Proc_name _ ->
-          raise Not_found
-
-let lookup_hover_definition_in_doc
-    HoverParams.{ textDocument = doc; position; _ }
-    Cobol_typeck.Outputs.{ group; _ } =
-      let filename = Lsp.Uri.to_path doc.uri in
-      match Lsp_lookup.element_at_position ~uri:doc.uri position group with
-        | { element_at_position = None; _ }
-        | { enclosing_compilation_unit_name = None; _ } ->
-            raise Not_found
-        | { element_at_position = Some ele_at_pos;
-            enclosing_compilation_unit_name = Some cu_name } ->
-            let hover_text, def_loc, hover_loc =
-              get_hover_info cu_name ele_at_pos group in
-            if always_show_hover_text_in_data_div ||
-               not (Lsp_position.is_in_srcloc ~filename position def_loc)
-            then hover_text, hover_loc
-            else raise Not_found
-
-let handle_hover registry (params: HoverParams.t) =
-  let filename = Lsp.Uri.to_path params.textDocument.uri in
-  let find_hovered_pplog_event pplog =
-    List.find_opt begin function
-      | Cobol_preproc.Trace.Replace _
-      | CompilerDirective _
-      | Exec_block _
-      | Ignored _ ->
-          false
-      | Replacement { matched_loc = loc; _ }
-      | FileCopy { copyloc = loc; _ } ->
-          try         (* Some locations in the pre-processor log may not involve
+  let named_data_defs = cu.unit_data.data_items.named in
+  try match element_at_pos with
+    | Data_item { full_qn = Some qn; def_loc } ->
+        Cobol_unit.Qualmap.find qn named_data_defs, def_loc
+    | Data_full_name qn | Data_name qn ->
+        Cobol_unit.Qualmap.find qn named_data_defs, Lsp_lookup.baseloc_of_qualname qn
+    | Data_item _ | Proc_name _ ->
+        raise Not_found
+  with Cobol_unit.Qualmap.Ambiguous _ -> raise Not_found
+
+let data_definition_on_hover
+    ?(always_show_hover_text_in_data_div = false)
+    ~uri position Cobol_typeck.Outputs.{ group; _ } =
+  let filename = Lsp.Uri.to_path uri in
+  match Lsp_lookup.element_at_position ~uri position group with
+  | { element_at_position = None; _ }
+  | { enclosing_compilation_unit_name = None; _ } ->
+      None
+  | { element_at_position = Some ele_at_pos;
+      enclosing_compilation_unit_name = Some cu_name } ->
+      try
+        let data_def, hover_loc
+          = lookup_data_definition_for_hover cu_name ele_at_pos group in
+        if always_show_hover_text_in_data_div ||
+           not (Lsp_position.is_in_srcloc ~filename position @@
+                Cobol_data.Item.def_loc data_def)
+        then Some (Pretty.to_string
+                     "%a" Lsp_data_info_printer.pp_data_definition data_def,
+                   hover_loc)
+        else None
+      with Not_found ->
+        None
+
+
+let hover_markdown ~filename ~loc value =
+  let content = MarkupContent.create ~kind:MarkupKind.Markdown ~value in
+  let range = Lsp_position.range_of_srcloc_in ~filename loc in
+  Some (Hover.create () ~contents:(`MarkupContent content) ~range)
+
+let cobol_code fmt =                                   (* TODO: ensure no ``` *)
+  Pretty.to_string ("```cobol\n" ^^ fmt ^^ "\n```")
+
+let find_hovered_pplog_event ~filename position pplog =
+  List.find_opt begin function
+    | Cobol_preproc.Trace.Replace _
+    | CompilerDirective _
+    | Exec_block _
+    | Ignored _ ->
+        false
+    | Replacement { matched_loc = loc; _ }
+    | FileCopy { copyloc = loc; _ } ->
+        try           (* Some locations in the pre-processor log may not involve
                          [filename], so we need to catch those cases. *)
-            Lsp_position.is_in_lexloc params.position
-              (Cobol_common.Srcloc.lexloc_in ~filename loc)
-          with Invalid_argument _ -> false
-    end (Cobol_preproc.Trace.events pplog)
-  in
-  let hover_markdown ~loc value =
-    let content = MarkupContent.create ~kind:MarkupKind.Markdown ~value in
-    let range = Lsp_position.range_of_srcloc_in ~filename loc in
-    Some (Hover.create () ~contents:(`MarkupContent content) ~range)
-  in
-  try_with_main_document_data registry params.textDocument
+          Lsp_position.is_in_lexloc position
+            (Cobol_common.Srcloc.lexloc_in ~filename loc)
+        with Invalid_argument _ -> false
+  end (Cobol_preproc.Trace.events pplog)
+
+let preproc_info_on_hover ~filename position pplog =
+  match find_hovered_pplog_event ~filename position pplog with
+  | Some Replacement { matched_loc = loc; replacement_text = []; _ } ->
+      Some ("empty text", loc)
+  | Some Replacement { matched_loc = loc; replacement_text; _ } ->
+      Some (cobol_code "%a" Cobol_preproc.Text.pp_text replacement_text, loc)
+  | Some FileCopy { copyloc = loc; status = CopyDone lib | CyclicCopy lib } ->
+      (match EzFile.read_file lib with
+       | "" -> None
+       | text -> Some (cobol_code "%s" text, loc))
+  | Some FileCopy { status = MissingCopy _; _ }
+  | Some Replace _
+  | Some CompilerDirective _
+  | Some Exec_block _
+  | Some Ignored _
+  | None ->
+      None
+
+let handle_hover ?always_show_hover_text_in_data_div
+    registry HoverParams.{ textDocument = doc; position; _ } =
+  let filename = Lsp.Uri.to_path doc.uri in
+  try_with_main_document_data registry doc
     ~f:begin fun ~doc:{ artifacts = { pplog; _ }; _ } checked_doc ->
-      let pp_hover_text_and_loc =
-        match find_hovered_pplog_event pplog with
-          | Some Replacement { matched_loc = loc; replacement_text = []; _ } ->
-              Some ("empty text", loc)
-          | Some Replacement { matched_loc = loc; replacement_text; _ } ->
-              (* TODO: ensure no ``` *)
-              Some (Pretty.to_string "```cobol\n%a\n```\
-                                     " Cobol_preproc.Text.pp_text replacement_text,
-                    loc)
-          | Some FileCopy { copyloc = loc; status = CopyDone lib | CyclicCopy lib } ->
-              begin match EzFile.read_file lib with
-                | "" -> None
-                (* TODO: ensure no ``` *)
-                | text -> Some (Pretty.to_string "```cobol\n%s\n```" text, loc)
-              end
-          | Some FileCopy { status = MissingCopy _; _ }
-          | Some Replace _
-          | Some CompilerDirective _
-          | Some Exec_block _
-          | Some Ignored _
-          | None ->
-              None
-      in
-      let info_hover_text_and_loc =
-        try Some (lookup_hover_definition_in_doc params checked_doc)
-        with Not_found -> None
-      in
-      match info_hover_text_and_loc, pp_hover_text_and_loc with
-        | None, None ->
-            None
-        | None, Some (text, loc) | Some (text, loc), None ->
-            hover_markdown ~loc text
-        | Some(info_text, loc), Some(pp_text, _) ->
-            hover_markdown ~loc @@
-            Pretty.to_string "%s\n---\nAdditional pre-processing information:\n%s"
-              info_text pp_text
+      match data_definition_on_hover ~uri:doc.uri position checked_doc
+              ?always_show_hover_text_in_data_div,
+            preproc_info_on_hover ~filename position pplog with
+      | None, None ->
+          None
+      | None, Some (text, loc) | Some (text, loc), None ->
+          hover_markdown ~filename ~loc text
+      | Some(info_text, loc), Some(pp_text, _) ->
+          hover_markdown ~filename ~loc @@
+          Pretty.to_string "%s\n---\nAdditional pre-processing:\n%s"
+            info_text pp_text
     end
 
 (** {3 Completion} *)

src/lsp/cobol_lsp/lsp_request.mli

@@ -24,7 +24,8 @@ module INTERNAL: sig
     -> Lsp.Types.ReferenceParams.t
     -> Lsp.Types.Location.t list option
   val hover
-    : Lsp_server.t
+    : ?always_show_hover_text_in_data_div: bool
+    -> Lsp_server.t
     -> Lsp.Types.HoverParams.t
     -> Lsp.Types.Hover.t option
   val completion

src/lsp/superbol_preprocs/main.ml

@@ -16,7 +16,10 @@ module EXEC_MAP = Cobol_preproc.Options.EXEC_MAP
 let exec_scanners =
   Cobol_parser.Options.{
     exec_scanner_fallback = Generic.scanner;  (* for now; TODO: Call.scanner? *)
-    exec_scanners = Cobol_preproc.Options.EXEC_MAP.singleton "SQL" Esql.scanner;
+    (* NB: Kept empty for now (the LSP does not yet benefit from this
+       preprocessor) *)
+    exec_scanners = Cobol_preproc.Options.EXEC_MAP.empty;
+    (* exec_scanners = Cobol_preproc.Options.EXEC_MAP.singleton "SQL" Esql.scanner; *)
   }
 
 let more scanners =

test/cobol_parsing/exec_blocks.ml

@@ -11,8 +11,15 @@
 (*                                                                        *)
 (**************************************************************************)
 
+let exec_scanners =
+  Superbol_preprocs.more [
+    "SQL", Superbol_preprocs.Esql.scanner;
+  ]
+
 let%expect_test "exec-block-with-cobol-separators" =
-  Parser_testing.show_parsed_tokens {|
+  Parser_testing.show_parsed_tokens
+    ~parser_options:(Parser_testing.options ~exec_scanners ()) @@
+  {|
        PROGRAM-ID.        prog.
        PROCEDURE          DIVISION.
            EXEC SQL
@@ -35,7 +42,9 @@ let%expect_test "exec-block-with-invalid-percentage-character" =
       "NO-%", Superbol_preprocs.No_percentage_toy.scanner;
     ]
   in
-  Parser_testing.show_diagnostics ~exec_scanners {|
+  Parser_testing.show_diagnostics
+    ~parser_options:(Parser_testing.options ~exec_scanners ()) @@
+  {|
        PROGRAM-ID.        prog.
        PROCEDURE          DIVISION.
            EXEC NO-%

test/cobol_parsing/parser_testing.ml

@@ -27,47 +27,36 @@ let preproc
         source_format
       }
 
-let default_parser_options =
-  Cobol_parser.Options.default
-    ~exec_scanners: Superbol_preprocs.exec_scanners
+let options
+    ?(verbose = false)
+    ?(exec_scanners = Superbol_preprocs.exec_scanners) () =
+  {
+    (Cobol_parser.Options.default ~exec_scanners) with
+    verbose;
+    recovery = EnableRecovery { silence_benign_recoveries = true }
+  }
 
-let show_parsed_tokens ?(verbose = false) ?(with_locations = false)
-    ?source_format ?filename contents =
+
+let show_parsed_tokens ?(parser_options = options ())
+    ?(with_locations = false) ?source_format ?filename contents =
   let { result = WithArtifacts (_, { tokens; _ }); _ } =
     preproc ?source_format ?filename contents |>
-    Cobol_parser.parse_with_artifacts
-      ~options: {
-        default_parser_options with
-        verbose;
-        recovery = EnableRecovery { silence_benign_recoveries = true };
-      }
+    Cobol_parser.parse_with_artifacts ~options:parser_options
   in
   (if with_locations
    then Cobol_parser.INTERNAL.pp_tokens' ~fsep:"@\n"
    else Cobol_parser.INTERNAL.pp_tokens) Fmt.stdout (Lazy.force tokens)
 
-let show_diagnostics ?(verbose = false) ?source_format ?filename
-    ?(exec_scanners = Superbol_preprocs.exec_scanners) contents =
+let show_diagnostics ?(parser_options = options ())
+    ?source_format ?filename contents =
   preproc ?source_format ?filename contents |>
-  Cobol_parser.parse_simple
-    ~options: {
-      default_parser_options with
-      verbose;
-      exec_scanners;
-      recovery = EnableRecovery { silence_benign_recoveries = true };
-    } |>
+  Cobol_parser.parse_simple ~options:parser_options |>
   Cobol_parser.Outputs.sink_result ~set_status:false ~ppf:Fmt.stdout
 
-let just_parse ?(verbose = false) ?source_format ?filename
-    ?(exec_scanners = Superbol_preprocs.exec_scanners) contents =
+let just_parse ?(parser_options = options ())
+    ?source_format ?filename contents =
   preproc ?source_format ?filename contents |>
-  Cobol_parser.parse_simple
-    ~options: {
-      default_parser_options with
-      verbose;
-      exec_scanners;
-      recovery = EnableRecovery { silence_benign_recoveries = true };
-    } |>
+  Cobol_parser.parse_simple ~options:parser_options |>
   ignore
 
 (* --- *)
@@ -158,7 +147,7 @@ let triplewise positions =
 (** Note: won't show detailed source locations as the openned file is neither
     actually on disk nor registered via {!Srcloc.register_file_contents}. *)
 let rewindable_parse
-    ?(verbose = false)
+    ?(parser_options = options ())
     ?(source_format = Cobol_config.(SF SFFixed))
     ?config
     prog
@@ -167,16 +156,17 @@ let rewindable_parse
     String { filename = "prog.cob"; contents = prog } |>
     Cobol_preproc.preprocessor
       ~options:Cobol_preproc.Options.{
-          verbose; libpath = []; source_format;
+          verbose = parser_options.verbose;
+          libpath = []; source_format;
           exec_preprocs = EXEC_MAP.empty;
           env = Cobol_preproc.Env.empty;
           config = Option.value config ~default:default.config;
         } |>
     Cobol_parser.rewindable_parse_simple
       ~options: {
-        default_parser_options with
-        verbose; recovery = DisableRecovery;
-        config = Option.value config ~default:default_parser_options.config;
+        parser_options with
+        recovery = DisableRecovery;
+        config = Option.value config ~default:parser_options.config;
       }
   in
   ptree, diags, rewinder
@@ -289,7 +279,8 @@ let iteratively_append_chunks_stuttering ?config ~f
 let simulate_cut_n_paste ?config ~f0 ~f ?verbose ?(repeat = 1)
     (prog, positions) =
   Random.init 42;
-  let ptree0, diags, rewinder = rewindable_parse ?verbose ?config prog in
+  let parser_options = options ?verbose () in
+  let ptree0, diags, rewinder = rewindable_parse ~parser_options ?config prog in
   f0 ~ptree0 diags;
   let positions = Array.of_list positions.pos_anonymous in
   let num_chunks = Array.length positions - 1 in

test/cobol_parsing/tokens.ml

@@ -40,7 +40,7 @@ let%expect_test "tokens-after-syntax-errors" =
 
 let%expect_test "token-locations" =
   Parser_testing.show_parsed_tokens ~source_format:Auto ~with_locations:true
-    ~verbose:true
+    ~parser_options:(Parser_testing.options ~verbose:true ())
     {|(TMP:1)|};
   [%expect {|
     Tks: (, WORD[TMP], :, DIGITS[1], ), EOF

test/cobol_typeck/typeck_testing.ml

@@ -15,15 +15,11 @@ open Parser_testing
 
 module DIAGS = Cobol_common.Diagnostics
 
-let show_diagnostics ?(show_data = false) ?(verbose = false)
+let show_diagnostics ?(show_data = false)
+    ?(parser_options = Parser_testing.options ())
     ?source_format ?filename contents =
   preproc ?source_format ?filename contents |>
-  Cobol_parser.parse_simple
-    ~options: {
-      default_parser_options with
-      verbose;
-      recovery = EnableRecovery { silence_benign_recoveries = true };
-    } |>
+  Cobol_parser.parse_simple ~options:parser_options |>
   Cobol_parser.Outputs.translate_diags |>
   DIAGS.map_result ~f:Cobol_typeck.compilation_group |>
   DIAGS.more_result ~f:Cobol_typeck.Results.translate_diags |>