Whole new representation for COBOL units, restoration of LSP features

src/lsp/cobol_common/basics.ml

@@ -51,6 +51,16 @@ module NEL = struct
   type 'a t =
     | One of 'a
     | (::) of 'a * 'a t
+  let compare cmp a b =
+    let rec aux a b = match a, b with
+      | One a, One b -> cmp a b
+      | One _, _ -> -1
+      | _, One _ -> 1
+      | a :: a', b :: b' ->
+          let c = cmp a b in
+          if c = 0 then aux a' b' else c
+    in
+    aux a b
   let hd = function
     | One x
     | x :: _ -> x
@@ -98,3 +108,5 @@ module NEL = struct
     Pretty.list ?fopen ?fsep ?fclose pp_e ppf (to_list list)
 end
 type 'a nel = 'a NEL.t
+let pp_nel pp = NEL.pp pp
+let compare_nel = NEL.compare

src/lsp/cobol_common/srcloc.ml

@@ -290,21 +290,27 @@ let scan ?(kind: [`TopDown | `BottomUp] = `TopDown) ~cpy ~rpl =
 
 (** {2 Pretty-printing} *)
 
-let retrieve_file_lines =
+let retrieve_file_lines, register_file_contents =
   let module Cache =
     Ephemeron.K1.Make (struct
       include String
       let hash = Hashtbl.hash
     end)
   in
   let file_cache = lazy (Cache.create 3) in
-  fun file ->
+  begin fun file ->
     let file_cache = Lazy.force file_cache in
     try Cache.find file_cache file
     with Not_found ->
       let lines = EzFile.read_lines file in
       Cache.add file_cache file lines;
       lines
+  end,
+  begin fun ~filename contents ->
+    let file_cache = Lazy.force file_cache in
+    let lines = Array.of_list @@ String.split_on_char '\n' contents in
+    Cache.replace file_cache filename lines
+  end
 
 type raw_loc = string * (int * int) * (int * int)
 
@@ -683,6 +689,12 @@ let copy_from ~filename ~copyloc { payload; loc } =
 
 (* --- *)
 
+module TESTING = struct
+  let register_file_contents = register_file_contents
+end
+
+(* --- *)
+
 let no_copy: copylocs = []
 let new_copy ~copyloc filename = List.cons { filename; copyloc }
 let mem_copy f  = List.exists (fun { filename; _ } -> filename = f)

src/lsp/cobol_common/srcloc.mli

@@ -120,6 +120,10 @@ val concat_locs: _ with_loc list -> srcloc option
 val concat_strings_with_loc: string with_loc -> string with_loc -> string with_loc
 val copy_from: filename:string -> copyloc:srcloc -> 'a with_loc -> 'a with_loc
 
+module TESTING: sig
+  val register_file_contents: filename:string -> string -> unit
+end
+
 val no_copy: copylocs
 val new_copy: copyloc:srcloc -> string -> copylocs -> copylocs
 val mem_copy: string -> copylocs -> bool

src/lsp/cobol_common/visitor.ml

@@ -122,6 +122,7 @@ module Fold = struct
     method fold_string: string -> 'a -> 'a action = default
     method fold_option: 'x. 'x option -> 'a -> 'a action = default
     method fold_list: 'x. 'x list -> 'a -> 'a action = default
+    method fold_nel: 'x. 'x Basics.NEL.t -> 'a -> 'a action = default
     method fold': 'x. 'x with_loc -> 'a -> 'a action = default
   end
 
@@ -142,9 +143,16 @@ module Fold = struct
     handle v#fold_list
       ~continue:(fun l x -> List.fold_left (fun x a -> fold v a x) x l)
 
+  let fold_nel ~fold (v: _ #folder) =
+    handle v#fold_nel
+      ~continue:(fun l x -> Basics.NEL.fold_left ~f:(fun x a -> fold v a x) x l)
+
   let fold' ~fold (v: _ #folder) =
     handle v#fold' ~continue:(fun { payload; _ } -> fold v payload)
 
+  let fold_int' (v: _#folder) =
+    fold' ~fold:fold_int v
+
   let fold_string' (v: _ #folder) =
     fold' ~fold:fold_string v
 
@@ -156,11 +164,15 @@ module Fold = struct
 
   (** Helper to shorten definitions for traversal of nodes with source
       locations *)
-  (* NOTE: we consider the traversal of `t with_loc` as a whole before the
-     generic traversal of `_ with_loc` via [fold'].  Maybe doing it the other
-     way round would be more intuitive? *)
-  let handle' vfold ~fold (v: _ #folder) =
-    handle vfold ~continue:(fold' ~fold v)
+  let handle'
+      (vfold: 'a with_loc -> 'x -> 'x action) ~(fold: 'c -> 'a -> 'x -> 'x)
+      (v: 'x #folder as 'c) : 'a with_loc -> 'x -> 'x =
+    (* NOTE: The commented line below "visits" `t with_loc` as a whole before
+       the generic traversal of `_ with_loc` via [fold'].  The actual code does
+       it the other way round so the behavior is more intuitive. *)
+    (* handle vfold ~continue:(fold' ~fold v) *)
+    handle v#fold'
+      ~continue:(handle vfold ~continue:(fun { payload; _ } -> fold v payload))
 
   let leaf' vfold =
     handle' vfold ~fold:(fun _ _ -> Fun.id)

src/lsp/cobol_data/cobol_data.ml

@@ -37,3 +37,4 @@ module Types = Data_types
 module Item = Data_item
 module Picture = Data_picture
 module Printer = Data_printer
+module Visitor = Data_visitor

src/lsp/cobol_data/data_item.ml

@@ -14,17 +14,20 @@
 open Data_types
 open Cobol_common.Srcloc.INFIX
 
-(* ignores redefs *)
-let fold_definitions ~f def acc =
+(* ignores redefs by default *)
+let fold_definitions ?(fold_redefinitions = false) ~f def acc =
   let rec aux acc def =
-    structure ~&(def.item_layout) (f def acc)
+    structure ~&def.item_layout (f def acc) |>
+    if fold_redefinitions
+    then fun acc -> List.fold_left aux acc ~&def.item_redefinitions
+    else Fun.id
   and structure = function
-    | Elementary _ ->
+    | Elementary_item _ ->
         Fun.id
-    | Struct { fields = items }
-    | FixedTable { items; _ }
-    | DependingTable { items; _ }
-    | DynamicTable { items; _ } ->
+    | Struct_item { fields = items }
+    | Fixed_table { items; _ }
+    | Depending_table { items; _ }
+    | Dynamic_table { items; _ } ->
         fun acc -> NEL.fold_left ~f:aux acc items
   in
   aux acc def