Fix size shown for data items with yet-unsupported usage or erroneous definitions

CHANGELOG.md

@@ -8,6 +8,7 @@
 - Warnings on unsupported usage, where the reported data item size may be be wrong [#570](https://github.com/OCamlPro/superbol-studio-oss/pull/570)
 
 ### Fixed
+- Details shown on hover of data items with definition issues [#575](https://github.com/OCamlPro/superbol-studio-oss/pull/575)
 - Handling of alphanumeric literals with UTF-8 characters in fixed-format COBOL code [#564](https://github.com/OCamlPro/superbol-studio-oss/pull/564)
 - Handling of queries about `LINKAGE` items given in `USING` phrases [#561](https://github.com/OCamlPro/superbol-studio-oss/pull/561)
 - Parsing of LSP CLI arguments, that notably prevented caching in global storage [#549](https://github.com/OCamlPro/superbol-studio-oss/pull/549) (fix for [Issue #547](https://github.com/OCamlPro/superbol-studio-oss/issues/547))

src/lsp/cobol_common/basics.ml

@@ -77,6 +77,9 @@ module LIST = struct
     List.rev l
   let hd = List.hd
   let tl = List.tl
+  let exists ?loc f l =
+    check_10 "exists" ~loc l;
+    List.exists f l
   let split ?loc l =
     check_10 "split" ~loc l;
     List.split l

src/lsp/cobol_data/data_item.ml

@@ -93,3 +93,9 @@ let def_offset: data_definition -> Data_memory.offset = function
   | Data_renaming { def; _} -> ~&def.renaming_offset
   | Data_condition { field; _} -> ~&field.field_offset
   | Table_index { table; _ } -> ~&table.table_offset
+
+let def_has_issues: data_definition -> bool = function
+  | Data_field { def; _ } -> ~&def.field_has_definition_issues
+  | Data_renaming _ -> false
+  | Data_condition { field; _ } -> ~&field.field_has_definition_issues
+  | Table_index { table; _ } -> ~&table.table_has_definition_issues

src/lsp/cobol_data/data_printer.ml

@@ -163,6 +163,8 @@ and pp_field_definition: field_definition Pretty.printer = fun ppf x ->
     I ((fun x -> x.field_qualname <> None),
        Fmt.field "qualname" (fun x -> x.field_qualname) pp_qualname'_opt,
        Fmt.(styled `Yellow @@ any "filler"));
+    C ((fun x -> x.field_has_definition_issues),
+       Fmt.any "/!\\ with_errors /!\\");
     C ((fun x -> x.field_redefines <> None),
        Fmt.field "redefines" (fun x -> x.field_redefines) pp_qualname'_opt);
     C ((fun x -> x.field_leading_ranges <> []),
@@ -204,6 +206,8 @@ and pp_field_layout: field_layout Pretty.printer = fun ppf -> function
 and pp_table_definition: table_definition Pretty.printer = fun ppf x ->
   Pretty.record_with_conditional_fields [
     T Fmt.(styled `Yellow @@ any "table");
+    C ((fun x -> x.table_has_definition_issues),
+       Fmt.any "/!\\ with_errors /!\\");
     C ((fun x -> x.table_redefines <> None),
        Fmt.field "redefines" (fun x -> x.table_redefines) pp_qualname'_opt);
     T (Fmt.field "offset" (fun x -> x.table_offset) pp_offset);
@@ -251,6 +255,8 @@ let pp_renamed_item_layout: renamed_item_layout Pretty.printer = fun ppf -> func
 let pp_record_renaming: record_renaming Pretty.printer =
   Pretty.record_with_conditional_fields [
     T (Fmt.field "qualname" (fun r -> r.renaming_name) Cobol_ptree.pp_qualname');
+    C ((fun r -> r.renaming_has_definition_issues),
+       Fmt.any "/!\\ with_errors /!\\");
     T (Fmt.field "from" (fun r -> r.renaming_from) Cobol_ptree.pp_qualname');
     C ((fun r -> r.renaming_thru <> None),
        Fmt.field "thru" (fun r -> r.renaming_thru) pp_qualname'_opt);

src/lsp/cobol_data/data_types.ml

@@ -91,6 +91,7 @@ and field_definition =
     field_length_variability: length_variability;
     field_conditions: condition_names;
     field_redefinitions: item_redefinitions;
+    field_has_definition_issues: bool;
   }
 
 and field_layout =
@@ -113,6 +114,7 @@ and table_definition =
     table_init_values: Cobol_ptree.literal with_loc list;     (* list for now *)
     table_redefines: Cobol_ptree.qualname with_loc option;    (* redef only *)
     table_redefinitions: item_redefinitions;
+    table_has_definition_issues: bool;
   }
 and table_range =
   {
@@ -169,6 +171,7 @@ and record_renaming =
     renaming_size: Data_memory.size;
     renaming_from: Cobol_ptree.qualname with_loc;
     renaming_thru: Cobol_ptree.qualname with_loc option;
+    renaming_has_definition_issues: bool;
   }
 and renamed_item_layout =
   | Renamed_elementary of

src/lsp/cobol_data/data_visitor.ml

@@ -171,7 +171,8 @@ and fold_field_definition (v: _ #folder) =
                           field_leading_ranges;
                           field_offset; field_size; field_layout;
                           field_conditions; field_redefinitions;
-                          field_length_variability = _ } x -> x
+                          field_length_variability = _;
+                          field_has_definition_issues = _ } x -> x
       >> Cobol_ptree.Terms_visitor.fold_qualname'_opt v field_qualname
       >> Cobol_ptree.Terms_visitor.fold_qualname'_opt v field_redefines
       >> fold_list ~fold:fold_table_range v field_leading_ranges
@@ -199,7 +200,8 @@ and fold_table_definition (v: _ #folder) =
   handle v#fold_table_definition
     ~continue:begin fun { table_field; table_offset; table_size;
                           table_range; table_init_values;
-                          table_redefines; table_redefinitions } x -> x
+                          table_redefines; table_redefinitions;
+                          table_has_definition_issues = _ } x -> x
       >> fold_field_definition' v table_field
       >> fold_memory_offset v table_offset
       >> fold_memory_size v table_size
@@ -249,7 +251,8 @@ let fold_record_renaming (v: _ #folder) =
   handle v#fold_record_renaming
     ~continue:begin fun { renaming_name; renaming_layout;
                           renaming_offset; renaming_size;
-                          renaming_from; renaming_thru } x -> x
+                          renaming_from; renaming_thru;
+                          renaming_has_definition_issues = _ } x -> x
       >> Cobol_ptree.Terms_visitor.fold_qualname' v renaming_name
       >> fold_renamed_item_layout v renaming_layout
       >> fold_memory_offset v renaming_offset

src/lsp/cobol_lsp/lsp_data_info_printer.ml

@@ -16,7 +16,19 @@ open Cobol_data.Types
 open Cobol_common.Srcloc.TYPES
 open Cobol_common.Srcloc.INFIX
 
-let pp_size = Fmt.(any "Size: " ++ Cobol_data.Memory.pp_size ++ any " bits")
+let pp_readable_size ppf size =
+  try
+    let bits = Cobol_data.Memory.as_bits size in
+    if Int.rem bits 8 = 0 then
+      let bytes = bits / 8 in
+      Fmt.pf ppf "%u byte%s" bytes (if bytes > 1 then "s" else "")
+    else
+      Fmt.pf ppf "%u bit%s" bits (if bits > 1 then "s" else "")
+  with Cobol_data.Memory.NOT_SCALAR _ ->
+    Fmt.pf ppf "*variable*"
+
+let pp_size =
+  Fmt.(any "Size: " ++ pp_readable_size)
 
 let pp_int' = Cobol_ptree.pp_with_loc Fmt.int
 
@@ -170,17 +182,32 @@ and pp_field_layout: field_layout Pretty.printer = fun ppf x ->
       Fmt.const pp_struct subfields ppf x
 
 and pp_field_definition: field_definition Pretty.printer = fun ppf x ->
-  let pp_qualname_opt_in_block' = pp_cobol_block Fmt.(option ~none:(any "FILLER") Cobol_ptree.pp_qualname')  in
-  Fmt.(
-    const pp_qualname_opt_in_block' x.field_qualname
-    ++ any "\n\n"
-    ++ const pp_field_layout x.field_layout
-    ++ (match x.field_layout with
-    | Struct_field _ -> any "  \n" ++ const pp_size x.field_size
-    | _ -> nop)
-    ++ any "  \n"
-    ++ const (option (any "Redefines:\n" ++ pp_cobol_block Cobol_ptree.pp_qualname')) x.field_redefines)
-  ppf x
+  let definition_has_issues = x.field_has_definition_issues in
+  let pp_qualname_opt_in_block' =
+    pp_cobol_block Fmt.(option ~none:(any "FILLER") Cobol_ptree.pp_qualname')
+  and pp_size ppf x =
+    match x.field_layout with
+    | Struct_field _ when not x.field_has_definition_issues ->
+        Fmt.fmt "  \n%a" ppf pp_size x.field_size
+    | _ ->
+        ()
+  in
+  match x.field_layout with
+  | Elementary_field _ when definition_has_issues ->
+      Fmt.(const pp_qualname_opt_in_block' x.field_qualname ++ any "\n\n" ++
+           any "*(layout omitted due to issues in item definition)*  \n" ++
+           const (option @@
+                  any "Redefines:\n" ++ pp_cobol_block Cobol_ptree.pp_qualname')
+             x.field_redefines)
+        ppf x
+  | _ ->
+      Fmt.(const pp_qualname_opt_in_block' x.field_qualname ++ any "\n\n" ++
+           const pp_field_layout x.field_layout ++
+           const pp_size x ++ any "  \n" ++
+           const (option @@
+                  any "Redefines:\n" ++ pp_cobol_block Cobol_ptree.pp_qualname')
+             x.field_redefines)
+        ppf x
 
 and pp_field_definition': field_definition with_loc Pretty.printer = fun ppf ->
   Cobol_ptree.pp_with_loc pp_field_definition ppf
@@ -221,18 +248,21 @@ let pp_renamed_item_layout: renamed_item_layout Pretty.printer = fun ppf x ->
       Fmt.const pp_struct subfields ppf x
 
 let pp_record_renaming: record_renaming Pretty.printer = fun ppf r ->
-  Fmt.(
-    pp_cobol_block (
-      const Cobol_ptree.pp_qualname' r.renaming_name
-      ++ any "\nRENAMES "
-      ++ const Cobol_ptree.pp_qualname' r.renaming_from
-      ++ const (option (any "\nTHRU " ++ Cobol_ptree.pp_qualname')) r.renaming_thru)
-    ++ any "\n\n"
-    ++ const pp_renamed_item_layout r.renaming_layout
-    ++ (match r.renaming_layout with
-    | Renamed_struct _ -> any "  \n" ++ const pp_size r.renaming_size
-    | _ -> nop) )
-  ppf r
+  let open Fmt in begin
+    pp_cobol_block begin
+      const Cobol_ptree.pp_qualname' r.renaming_name ++ any "\n" ++
+      if r.renaming_has_definition_issues then nop else
+        any "RENAMES " ++
+        const Cobol_ptree.pp_qualname' r.renaming_from ++
+        const (option (any "\nTHRU " ++ Cobol_ptree.pp_qualname'))
+          r.renaming_thru
+    end ++ any "\n\n" ++
+    if r.renaming_has_definition_issues then nop else
+      const pp_renamed_item_layout r.renaming_layout ++
+      match r.renaming_layout with
+      | Renamed_struct _ -> any "  \n" ++ const pp_size r.renaming_size
+      | _ -> nop
+  end ppf r
 
 let pp_record_renaming': record_renaming with_loc Pretty.printer = fun ppf ->
   Cobol_ptree.pp_with_loc pp_record_renaming ppf

src/lsp/cobol_lsp/lsp_request.ml

@@ -553,44 +553,46 @@ let handle_semtoks_full,
 (** {3 Hover} *)
 
 let doc_of_datadef ~rev_comments ~filename data_def =
-  let open Cobol_preproc.Text in
-  let loc = Cobol_data.Item.def_loc data_def in
-  let def_filename = (fst @@ Cobol_common.Srcloc.as_lexloc loc).pos_fname in
-  if not (String.equal filename def_filename) (** def is in copybook *)
+  let definition_loc = Cobol_data.Item.def_loc data_def in
+  let definition_lexloc = Cobol_common.Srcloc.as_lexloc definition_loc in
+  let definition_filename = (fst definition_lexloc).pos_fname in
+  if not (String.equal filename definition_filename)      (* def is in copybook *)
   then ""
   else
-    let def_range = Lsp_position.range_of_srcloc_in ~filename loc in
-    let (inline, full_line) =
-      List.fold_left begin fun acc { comment_loc; comment_kind; comment_contents } ->
-        let com_range = Lsp_position.range_of_lexloc comment_loc in
-        if def_range.start.line = com_range.start.line
-        then (Some comment_contents, snd acc)
-        else if def_range.start.line = com_range.start.line + 1
-             && comment_kind == `Line
-        then (fst acc, Some comment_contents)
-        else acc
-      end (None, None) rev_comments
+    let definition_range =
+      Lsp_position.range_of_srcloc_in ~filename definition_loc
     in
-    match inline, full_line with
-    | Some comment, _ -> "\n---\n" ^ String.sub comment 2 (String.length comment - 2)
-    | None, Some comment -> "\n---\n" ^ String.sub comment 1 (String.length comment - 1)
-    | _ -> ""
-
-let lookup_data_definition_for_hover cu_name element_at_pos group =
+    let definition_line = definition_range.start.line in
+    List.find_map begin fun Cobol_preproc.Text.{ comment_loc; comment_kind;
+                                                 comment_contents = c } ->
+      let comment_range = Lsp_position.range_of_lexloc comment_loc in
+      let comment_line = comment_range.start.line in
+      if definition_line = comment_line
+      then Some (String.sub c 2 (String.length c - 2))
+      else if definition_line = comment_line + 1 && comment_kind == `Line
+      then Some (String.sub c 1 (String.length c - 1))
+      else None
+    end rev_comments |> function
+    | Some c -> c
+    | None -> ""
+
+let lookup_data_definition cu_name element_at_pos group =
   let { payload = cu; _ } = CUs.find_by_name cu_name group in
   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
+        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
+        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_definition_text_in_data_div = false) ~rev_comments
-    ~uri position (checked_doc : Cobol_typeck.Outputs.t) =
+let describe_data_definition_at_pos
+    ?(always_show_hover_definition_text_in_data_div = false)
+    ~rev_comments ~uri position (checked_doc : Cobol_typeck.Outputs.t) =
   let Cobol_typeck.Outputs.{ group; _ } = checked_doc in
   let filename = Lsp.Uri.to_path uri in
   match Lsp_lookup.element_at_position ~uri position group with
@@ -601,25 +603,30 @@ let data_definition_on_hover
       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
+          = lookup_data_definition cu_name ele_at_pos group in
+        let data_def_loc = Cobol_data.Item.def_loc data_def in
         let doc_comments = doc_of_datadef ~rev_comments ~filename data_def in
+        let pp_documentation ppf =
+          if doc_comments <> ""
+          then Pretty.print ppf "\n---\n%s" doc_comments
+        in
         let text =
           if always_show_hover_definition_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%s"
-                       Lsp_data_info_printer.pp_data_definition data_def doc_comments)
+             not (Lsp_position.is_in_srcloc ~filename position data_def_loc)
+          then Some (Pretty.to_string "%a%t"
+                       Lsp_data_info_printer.pp_data_definition data_def
+                       pp_documentation)
           else None
         in
         Some (text, hover_loc)
       with Not_found ->
         None
 
-let data_references_on_hover ~rootdir ~textDocument position checked_doc =
+let data_references ~rootdir ~textDocument position checked_doc =
   let context = ReferenceContext.create ~includeDeclaration:true in
   let params = ReferenceParams.create ~context ~position ~textDocument () in
+  Option.map List.length @@
   lookup_references_in_doc ~rootdir params checked_doc
-  |> Option.map List.length
 
 
 let hover_markdown ~filename ~loc value =
@@ -671,11 +678,13 @@ let handle_hover ?always_show_hover_definition_text_in_data_div
     ~f:begin fun ~doc:{ project; artifacts = { pplog; rev_comments; _ }; _ } checked_doc ->
       let rootdir = Lsp_project.(string_of_rootdir @@ rootdir project) in
       let ref_count () =
-        data_references_on_hover ~rootdir ~textDocument:doc position checked_doc
+        data_references ~rootdir ~textDocument:doc position checked_doc
       in
-      match data_definition_on_hover ~uri:doc.uri position checked_doc
-              ?always_show_hover_definition_text_in_data_div ~rev_comments,
-            preproc_info_on_hover ~filename position pplog with
+      match
+        describe_data_definition_at_pos ~uri:doc.uri position checked_doc
+          ?always_show_hover_definition_text_in_data_div ~rev_comments,
+        preproc_info_on_hover ~filename position pplog
+      with
       | None, None ->
           None
       | Some (None, loc), None ->
@@ -778,7 +787,8 @@ let codelens_positions ~uri group =
                                       field_leading_ranges;
                                       field_offset; field_size; field_layout;
                                       field_conditions; field_redefinitions;
-                                      field_length_variability = _ } acc =
+                                      field_length_variability = _;
+                                      field_has_definition_issues = _ } acc =
         ignore(field_redefines, field_leading_ranges, field_offset, field_size);
         skip @@ begin acc
           |> Cobol_ptree.Terms_visitor.fold_qualname'_opt v field_qualname
@@ -788,8 +798,10 @@ let codelens_positions ~uri group =
         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);
+                                      table_redefines; table_redefinitions;
+                                      table_has_definition_issues } acc =
+        ignore(table_offset, table_size, table_init_values, table_redefines,
+               table_has_definition_issues);
         skip @@ begin acc
           |> fold_field_definition' v table_field
           |> fold_table_range v table_range