Fix lookup of paragraphs

A paragraph-name does not need to be qualified when its target is
defined in the same section.

src/lsp/cobol_lsp/lsp_lookup.ml

@@ -29,10 +29,20 @@ module TYPES = struct
       enclosing_compilation_unit_name: string option;
     }
   and element_in_context =
-    | Data_name of Cobol_ptree.qualname
-    | Data_full_name of Cobol_ptree.qualname
-    | Data_item of { full_qn: Cobol_ptree.qualname option; def_loc: srcloc }
-    | Proc_name of Cobol_ptree.qualname
+    | Data_name of
+        Cobol_ptree.qualname
+    | Data_full_name of
+        Cobol_ptree.qualname
+    | Data_item of
+        {
+          full_qn: Cobol_ptree.qualname option;
+          def_loc: srcloc;
+        }
+    | Proc_name of
+        {
+          qn: Cobol_ptree.qualname;
+          in_section: Cobol_unit.Types.procedure_section option;
+        }
 
   type name_definition =
     {
@@ -109,7 +119,7 @@ let element_at_position ~uri pos group : element_at_position =
       }
     and context =
       | Data_decls
-      | Procedure
+      | Procedure of Cobol_unit.Types.procedure_section option
 
     let init =
       {
@@ -137,9 +147,12 @@ let element_at_position ~uri pos group : element_at_position =
     { acc with
       elt = { elt with element_at_position = Some (Data_item { full_qn;
                                                                def_loc }) } }
-  and on_proc_name qn ({ elt; _ } as acc) =
-    { acc with
-      elt = { elt with element_at_position = Some (Proc_name qn) } }
+  and on_proc_name qn ({ elt; context } as acc) =
+    let element_at_position = match context with
+      | Data_decls -> Some (Proc_name { qn; in_section = None })   (* unlikely *)
+      | Procedure in_section -> Some (Proc_name { qn; in_section })
+    in
+    { acc with elt = { elt with element_at_position } }
   in
 
   Cobol_unit.Visitor.fold_unit_group object
@@ -153,8 +166,8 @@ let element_at_position ~uri pos group : element_at_position =
         elt = { elt with enclosing_compilation_unit_name = Some name } }
 
     method! fold_data_definitions _ = enter_context Data_decls
-
-    method! fold_procedure _ = enter_context Procedure
+    method! fold_procedure _ = enter_context (Procedure None)
+    method! fold_procedure_section s = enter_context (Procedure (Some s))
 
     method! fold_item_definition' def acc =
       Visitor.do_children @@ match ~&def.item_qualname with
@@ -180,7 +193,7 @@ let element_at_position ~uri pos group : element_at_position =
       Visitor.skip_children @@ match acc.context with
       | Data_decls ->            (* always fully qualified in data definitions *)
           on_data_full_name qn acc
-      | Procedure ->              (* for now, no more info, data-name expected *)
+      | Procedure _ ->            (* for now, no more info, data-name expected *)
           on_data_name qn acc
 
     method! fold_procedure_name qn acc =

src/lsp/cobol_lsp/lsp_request.ml

@@ -100,10 +100,12 @@ let find_data_definition Lsp_position.{ location_of; location_of_srcloc }
       Lsp_notify.ambiguous "data-name" qn ~matching_qualnames;
       []
 
-let find_proc_definition Lsp_position.{ location_of; _ }
+let find_proc_definition
+    Lsp_position.{ location_of; _ }
     ?(allow_notifications = true)
+    ?(in_section: Cobol_unit.Types.procedure_section option)
     (qn: Cobol_ptree.qualname) (cu: Cobol_unit.Types.cobol_unit) =
-  match Cobol_unit.Qualmap.find qn cu.unit_procedure.named with
+  match Cobol_unit.Procedure.find ?in_section qn cu.unit_procedure with
   | Paragraph { payload = { paragraph_name = Some qn; _ }; _ }
     when focus_on_name_in_defintions ->
       [location_of qn]
@@ -134,8 +136,9 @@ let find_definitions ?allow_notifications loc_translator
         find_data_definition loc_translator ?allow_notifications qn cu
     | Data_item { full_qn = None; def_loc } ->
         [loc_translator.location_of_srcloc def_loc]
-    | Proc_name qn ->
-        find_proc_definition loc_translator ?allow_notifications qn cu
+    | Proc_name { qn; in_section } ->
+        find_proc_definition loc_translator ?allow_notifications ?in_section
+          qn cu
   with Not_found -> []
 
 let lookup_definition_in_doc
@@ -157,15 +160,26 @@ let handle_definition registry (params: DefinitionParams.t) =
 
 (** {3 References} *)
 
-let find_full_qn ~kind qn qmap =
-  try Some (Cobol_unit.Qualmap.find_binding qn qmap).full_qn with
+let lookup_qn ~kind ~lookup qn =
+  try Some (lookup qn) with
   | Not_found ->
       Lsp_notify.unknown kind qn;
       None
   | Cobol_unit.Qualmap.Ambiguous (lazy matching_qualnames) ->
       Lsp_notify.ambiguous kind qn ~matching_qualnames;
       None
 
+let find_full_qn ~kind qn qmap =
+  lookup_qn ~kind qn
+    ~lookup:(fun qn -> (Cobol_unit.Qualmap.find_binding qn qmap).full_qn)
+
+let find_proc_qn ~kind qn ?in_section cu =
+  lookup_qn ~kind qn
+    ~lookup:begin fun qn ->
+      Cobol_unit.Procedure.full_qn ?in_section qn
+        cu.Cobol_unit.Types.unit_procedure
+    end
+
 let lookup_references_in_doc
     ReferenceParams.{ textDocument = doc; position; context; _ }
     Cobol_typeck.Outputs.{ group; artifacts = { references }; _ }
@@ -203,9 +217,9 @@ let lookup_references_in_doc
           | Data_name qn ->
               Option.fold ~none:[] ~some:data_refs @@
               find_full_qn qn ~&cu.unit_data.data_items.named ~kind:"data-name"
-          | Proc_name qn ->
+          | Proc_name { qn; in_section } ->
               Option.fold ~none:[] ~some:proc_refs @@
-              find_full_qn qn ~&cu.unit_procedure.named ~kind:"procedure-name"
+              find_proc_qn qn ?in_section ~&cu ~kind:"procedure-name"
         with Not_found -> []
       in
       Some (def_locs @ ref_locs)

src/lsp/cobol_typeck/typeck_procedure.ml

@@ -31,9 +31,13 @@ let procedure_of_compilation_unit cu' =
       {
         blocks: procedure_block Qualmap.t;
         block_list: procedure_block list;
-        current_section: section_under_construction option;
+        current_section: section_under_construction with_loc option;
+      }
+    and section_under_construction =
+      {
+        sec_name: Cobol_ptree.procedure_name with_loc;
+        sec_paragraphs: procedure_paragraph with_loc list;
       }
-    and section_under_construction = procedure_section with_loc
 
     let init =
       {
@@ -51,16 +55,26 @@ let procedure_of_compilation_unit cu' =
     let name n : Cobol_ptree.qualname = Name n
     let qual n q : Cobol_ptree.qualname = Qual (n, q)
 
-    let section_block ({ payload = suc; loc }: section_under_construction) =
-      Section ({ suc with
-                 section_paragraphs = List.rev suc.section_paragraphs } &@ loc)
+    let section_block
+        ({ payload = suc; loc }: section_under_construction with_loc) =
+      let section_paragraphs =
+        List.fold_left begin fun ({ named; list } as paragraphs) paragraph ->
+          match ~&paragraph.paragraph_name with
+          | None ->
+              { paragraphs with list = paragraph :: list }
+          | Some qn ->
+              { named = Cobol_unit.Qualmap.add ~&qn paragraph named;
+                list = paragraph :: list }
+        end { named = Cobol_unit.Qualmap.empty; list = [] } suc.sec_paragraphs
+      in
+      Section ({ section_name = suc.sec_name; section_paragraphs } &@ loc)
 
     let simple_paragraph (p: Cobol_ptree.paragraph with_loc) acc =
       match acc.current_section, ~&p.paragraph_name with
       | None, Some n ->
           { paragraph_name = Some (name n &@<- n);
             paragraph = p } &@<- p
-      | Some { payload = { section_name = qn; _ }; _ }, Some n ->
+      | Some { payload = { sec_name = qn; _ }; _ }, Some n ->
           { paragraph_name = Some (qual n ~&qn &@<- n);
             paragraph = p } &@<- p
       | _, None ->
@@ -72,7 +86,7 @@ let procedure_of_compilation_unit cu' =
 
     let commit_section acc =
       match acc.current_section with
-      | Some ({ payload = { section_name = qn; _ }; _ } as section) ->
+      | Some ({ payload = { sec_name = qn; _ }; _ } as section) ->
           let section = section_block section in
           { blocks = Qualmap.add ~&qn section acc.blocks;
             block_list = section :: acc.block_list;
@@ -82,10 +96,10 @@ let procedure_of_compilation_unit cu' =
 
     let start_new_section n s acc =
       let acc = commit_section acc in
-      let section_paragraphs = [simple_paragraph s acc] in
+      let sec_paragraphs = [simple_paragraph s acc] in
       { acc with
-        current_section = Some ({ section_name = name n &@<- n;
-                                  section_paragraphs } &@<- s) }
+        current_section = Some ({ sec_name = name n &@<- n;
+                                  sec_paragraphs } &@<- s) }
 
     let named_paragraph n p acc =
       let p = simple_paragraph p acc in
@@ -97,10 +111,10 @@ let procedure_of_compilation_unit cu' =
             None
         | Some s ->
             let loc = Cobol_common.Srcloc.concat ~@s ~@p in
-            let section_paragraphs = p :: ~&s.section_paragraphs in
-            qual n ~&(~&s.section_name),
+            let sec_paragraphs = p :: ~&s.sec_paragraphs in
+            qual n ~&(~&s.sec_name),
             acc.block_list,
-            Some ({ ~&s with section_paragraphs } &@ loc)
+            Some ({ ~&s with sec_paragraphs } &@ loc)
       in
       { blocks = Qualmap.add qn (paragraph_block p) acc.blocks;
         block_list;
@@ -146,15 +160,17 @@ let references ~(data_definitions: Cobol_unit.Types.data_definitions) procedure
     (* TODO: add a context, and gather references to procedures, etc. *)
     type acc =
       {
+        current_section: Cobol_unit.Types.procedure_section option;
         refs: Typeck_outputs.references_in_unit;
         diags: Typeck_diagnostics.t;
       }
     let init =
       {
+        current_section = None;
         refs = Typeck_outputs.no_refs;
         diags = Typeck_diagnostics.none;
       }
-    let references { refs; diags } = refs, diags
+    let references { refs; diags; _ } = refs, diags
   end in
 
   let baseloc_of_qualname: Cobol_ptree.qualname -> srcloc = function
@@ -188,9 +204,15 @@ let references ~(data_definitions: Cobol_unit.Types.data_definitions) procedure
           error acc @@ Ambiguous_data_name { given_qualname = qn &@ loc;
                                              matching_qualnames }
 
-    method! fold_procedure_name' ({ loc; _ } as qn) acc =
+    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_name' ({ loc; _ } as qn)
+        ({ current_section = in_section; _ } as acc) =
       Visitor.skip_children @@
-      match Cobol_unit.Qualmap.find ~&qn procedure.named with
+      match Cobol_unit.Procedure.find ~&qn ?in_section procedure with
       | block ->
           { acc with
             refs = Typeck_outputs.register_procedure_ref ~loc block acc.refs }

src/lsp/cobol_unit/cobol_unit.ml

@@ -20,6 +20,7 @@ module Types = struct
 end
 
 module Group = Unit_group
+module Procedure = Unit_procedure
 module Collections = Unit_collections
 module Printer = Unit_printer
 module Visitor = Unit_visitor

src/lsp/cobol_unit/unit_procedure.ml

@@ -0,0 +1,42 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                        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.                                                   *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Utilities to deal with sections/paragraphs of PROCEDURE DIVISIONs *)
+
+open Unit_types
+
+let rec find
+    ?(in_section: procedure_section option)
+    (procedure_name: Cobol_ptree.procedure_name)
+    (procedure: procedure)
+  : procedure_block =
+  match in_section with
+  | None ->
+      Unit_qualmap.find procedure_name procedure.named
+  | Some { section_paragraphs; _ } ->
+      try
+        Paragraph (Unit_qualmap.find procedure_name section_paragraphs.named)
+      with Not_found -> find procedure_name procedure
+
+let rec full_qn
+    ?(in_section: procedure_section option)
+    (procedure_name: Cobol_ptree.procedure_name)
+    (procedure: procedure)
+  =
+  match in_section with
+  | None ->
+      (Unit_qualmap.find_binding procedure_name procedure.named).full_qn
+  | Some { section_paragraphs; _ } ->
+      try
+        (Unit_qualmap.find_binding procedure_name section_paragraphs.named).full_qn
+      with Not_found -> full_qn procedure_name procedure

src/lsp/cobol_unit/unit_procedure.mli

@@ -0,0 +1,26 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                        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.                                                   *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Utilities to deal with sections/paragraphs of PROCEDURE DIVISIONs *)
+
+val find
+  : ?in_section: Unit_types.procedure_section
+  -> Cobol_ptree.qualname
+  -> Unit_types.procedure
+  -> Unit_types.procedure_block
+
+val full_qn
+  : ?in_section: Unit_types.procedure_section
+  -> Cobol_ptree.qualname
+  -> Unit_types.procedure
+  -> Cobol_ptree.qualname

src/lsp/cobol_unit/unit_types.ml

@@ -17,6 +17,8 @@ open Cobol_common.Srcloc.TYPES
 
 (* utils *)
 
+(** A type to manage sets of items in both named and ordered form.  Note that in
+    many cases anonymous elements of [list] many not belong to [named]. *)
 type 'a named_n_ordered =
   {
     named: 'a Unit_qualmap.t;
@@ -51,7 +53,7 @@ type procedure_paragraph =
 type procedure_section =
   {
     section_name: Cobol_ptree.procedure_name with_loc;
-    section_paragraphs: procedure_paragraph with_loc list;            (* nel? *)
+    section_paragraphs: procedure_paragraph with_loc named_n_ordered;
   }
 
 type procedure_block =

src/lsp/cobol_unit/unit_visitor.ml

@@ -60,7 +60,7 @@ let fold_procedure_section (v: _ #folder) =
   handle v#fold_procedure_section
     ~continue:begin fun { section_name; section_paragraphs } x -> x
       >> Cobol_ptree.Terms_visitor.fold_procedure_name' v section_name
-      >> fold_list v section_paragraphs ~fold:fold_procedure_paragraph'
+      >> fold_list v section_paragraphs.list ~fold:fold_procedure_paragraph'
     end
 
 let fold_procedure_section' (v: _ #folder) =

test/cobol_typeck/ko_proc_names.ml

@@ -18,20 +18,23 @@ let dotest = Typeck_testing.show_diagnostics
 let%expect_test "ambiguous-proc-names" =
   dotest @@ prog "ambiguous-proc-names"
     ~procedure:{|
+       MAIN SECTION.
+          PERFORM SUB-1.
        MAIN-1 SECTION.
        SUB-1.
           DISPLAY 1.
        MAIN-2 SECTION.
        SUB-1.
-          PERFORM SUB-1.
+          DISPLAY 2.
     |};
   [%expect {|
-    prog.cob:9.18-9.23:
-       6             DISPLAY 1.
-       7          MAIN-2 SECTION.
-       8          SUB-1.
-       9 >           PERFORM SUB-1.
+    prog.cob:5.18-5.23:
+       2          DATA DIVISION.
+       3          PROCEDURE DIVISION.
+       4          MAIN SECTION.
+       5 >           PERFORM SUB-1.
     ----                     ^^^^^
-      10
+       6          MAIN-1 SECTION.
+       7          SUB-1.
     >> Error: Ambiguous procedure-name 'SUB-1'; known matching names are 'SUB-1
               IN MAIN-2', 'SUB-1 IN MAIN-1' |}];;