Handle tabs in input

src/lsp/cobol_common/srcloc.ml

@@ -349,16 +349,87 @@ type raw_loc = string * (int * int) * (int * int)
 let pp_file_loc ppf ((file, pos1, pos2): raw_loc) =
   Pretty.print ppf "%s:%a" file Fmt.text_loc (pos1, pos2)
 
+(** Retrieve the character position of a column number in a line that was
+      tab expanded *)
+let original_col_of_expanded ?(tab_stop = 8) ~fname ~line expanded_col =
+  try
+    let lines = retrieve_file_lines fname in
+    let original_line = lines.(line - 1) in
+    let n = String.length original_line in
+    let orig_col = ref 0 in
+    let exp_col = ref 0 in
+    while !orig_col < n && !exp_col < expanded_col do
+      let c = String.get original_line !orig_col in
+      let advance =
+        if c = '\t' then
+          tab_stop - (!exp_col mod tab_stop)
+        else
+          1
+      in
+      exp_col := !exp_col + advance;
+      incr orig_col
+    done;
+    !orig_col
+  with _ ->
+    expanded_col
+
+(** Creates an underline of `^` for a line with tab expansion for
+    the width of the underline *)
+let tab_underline ?(tab_stop = 8) ~lo ~hi line =
+  let buf = Buffer.create (hi + 2) in
+  let visual_col = ref 0 in
+  String.iter
+    (fun c ->
+      let w =
+        if c = '\t' then
+          tab_stop - (!visual_col mod tab_stop)
+        else
+          1
+      in
+      for dv = 0 to w - 1 do
+        let v = !visual_col + dv in
+        if v <= hi then
+          Buffer.add_char buf (if v > lo then '^' else ' ')
+      done;
+      visual_col := !visual_col + w )
+    line;
+  while !visual_col <= hi do
+    Buffer.add_char buf (if !visual_col > lo then '^' else ' ');
+    incr visual_col
+  done;
+  Buffer.contents buf
+
+(** Creates an underline of `^` for a line until its end with tab
+   expansion for the width of the underline *)
+let tab_underline_to_end ?(tab_stop = 8) ~lo line =
+  let buf = Buffer.create (String.length line + 1) in
+  let vcol = ref 0 in
+  String.iter
+    (fun c ->
+      let w =
+        if c = '\t' then
+          tab_stop - (!vcol mod tab_stop)
+        else
+          1
+      in
+      for dv = 0 to w - 1 do
+        Buffer.add_char buf (if !vcol + dv > lo then '^' else ' ')
+      done;
+      vcol := !vcol + w )
+    line;
+  Buffer.add_char buf (if !vcol > lo then '^' else ' ');
+  Buffer.contents buf
+
 (** Note this should always end with a newline character *)
-let pp_raw_loc: raw_loc Pretty.printer =
+let pp_raw_loc ?(tab_stop = 8) () : raw_loc Pretty.printer =
   let b = lazy (Buffer.create 1000) in
   let find_source (file, pos1, pos2) =
     let line1 = fst pos1 in
     let line2 = fst pos2 in
     let col1 = snd pos1 in
     let col2 = snd pos2 in
-    let col2, pad2 =
-      if line1 == line2 && col1 == col2 then succ col2, 1 else col2, 0 in
+    let col2 =
+      if line1 == line2 && col1 == col2 then succ col2 else col2 in
     let lines = retrieve_file_lines file in
     let b = Lazy.force b in
     Buffer.clear b;
@@ -369,29 +440,20 @@ let pp_raw_loc: raw_loc Pretty.printer =
         (if l>=line1 && l<=line2 then '>' else ' ')
         line;
       if l = line1 && l = line2 then
-        let str =
-          String.mapi
-            (fun idx c -> if idx > col1 && idx <= col2 then '^' else c)
-            (String.make (min (len + 1 + pad2) (col2 + 1)) ' ')
-        in
-        Printf.bprintf b "----  %s\n" str;
+        Printf.bprintf b "----  %s\n"
+          (tab_underline ~tab_stop ~lo:col1 ~hi:col2 line)
       else if l = line1 then
-        let str =
-          String.mapi
-            (fun idx c -> if idx > col1 then '^' else c)
-            (String.make (len + 1) ' ')
-        in
-        Printf.bprintf b "----  %s\n" str;
+        Printf.bprintf b "----  %s\n"
+          (tab_underline_to_end
+          ~tab_stop
+          ~lo:col1
+          line)
       else if l > line1 && l < line2 then
         let str = String.make (len + 1) '^' in
         Printf.bprintf b "----  %s\n" str;
       else if l = line2 then
-        let str =
-          String.mapi
-            (fun idx c -> if idx <= col2 then '^' else c )
-            (String.make (min (len + 1 + pad2) (col2 + 1)) ' ')
-        in
-        Printf.bprintf b "----  %s\n" str;
+        Printf.bprintf b "----  %s\n"
+          (tab_underline ~tab_stop ~lo:(-1) ~hi:col2 line)
     done;
     Buffer.contents b
   in
@@ -449,7 +511,7 @@ let pp_srcloc: srcloc Pretty.printer =
   fun ppf loc ->
     let toplevel_transforms, loc = toplevel_transform_stack loc in
     let lexloc = as_lexloc loc in
-    pp_raw_loc ppf (to_raw_loc lexloc);
+    pp_raw_loc () ppf (to_raw_loc lexloc);
     pp_transform_operations ~partial:false ppf toplevel_transforms;
     pp_transform_operations ~partial:true ppf (partial_transform_operations loc)
 

src/lsp/cobol_common/srcloc.mli

@@ -100,6 +100,13 @@ val start_pos: srcloc -> Lexing.position    (* only suitable for Area A checks *
 val start_pos_in: filename: string -> srcloc -> Lexing.position
 val end_pos_in: filename: string -> srcloc -> Lexing.position
 
+val original_col_of_expanded
+  : ?tab_stop:int
+  -> fname:string
+  -> line:int
+  -> int
+  -> int
+
 val concat: srcloc -> srcloc -> srcloc
 val concat_srclocs: srcloc list -> srcloc option
 val prefix: int -> srcloc -> srcloc
@@ -110,7 +117,7 @@ val sub : srcloc -> pos:int -> len:int -> srcloc
 
 val pp: 'a Pretty.printer -> 'a with_loc Pretty.printer
 val pp_with_loc: 'a Pretty.printer -> 'a with_loc Pretty.printer
-val pp_raw_loc: (string * (int * int) * (int * int)) Pretty.printer
+val pp_raw_loc: ?tab_stop:int -> unit -> (string * (int * int) * (int * int)) Pretty.printer
 val flagit: 'a -> srcloc -> 'a with_loc
 val payload: 'a with_loc -> 'a
 val loc: 'a with_loc -> srcloc

src/lsp/cobol_lsp/lsp_position.ml

@@ -32,14 +32,18 @@ let pointwise_range_at_start =
 let start_of_lexloc ((start_pos, _end_pos): lexloc) =
   Position.create           (* NOTE: Line numbers start at 0 in LSP protocol. *)
     ~line:(start_pos.pos_lnum - 1)
-    ~character:(start_pos.pos_cnum - start_pos.pos_bol)
+    ~character:(Srcloc.original_col_of_expanded
+                  ~fname:start_pos.pos_fname ~line:start_pos.pos_lnum
+                  (start_pos.pos_cnum - start_pos.pos_bol))
 
 (** [end_of_lexloc] creates a representation of the end of the given lexical
     location that is suitable for the LSP library. *)
 let end_of_lexloc ((_start_pos, end_pos): lexloc) =
   Position.create           (* NOTE: Line numbers start at 0 in LSP protocol. *)
     ~line:(end_pos.pos_lnum - 1)
-    ~character:(end_pos.pos_cnum - end_pos.pos_bol)
+    ~character:(Srcloc.original_col_of_expanded
+                  ~fname:end_pos.pos_fname ~line:end_pos.pos_lnum
+                  (end_pos.pos_cnum - end_pos.pos_bol))
 
 (** [range_of_lexloc] creates a representation of the given lexical location
     that is suitable for the LSP library. *)

src/lsp/cobol_lsp/lsp_semtoks.ml

@@ -681,10 +681,10 @@ let ensure_sorted name ~filename cmp l =
   | Some (x, y) ->
       Pretty.error "@[<2>** Internal@ note:@ semantic@ tokens@ in@ %s@ are@ \
                     not@ sorted.@ Two@ offenders@ are:@]@\n%a%a@." name
-        Srcloc.pp_raw_loc (filename,
+        (Srcloc.pp_raw_loc ()) (filename,
                            (x.line + 1, x.start),
                            (x.line + 1, x.start + x.length))
-        Srcloc.pp_raw_loc (filename,
+        (Srcloc.pp_raw_loc ()) (filename,
                            (y.line + 1, y.start),
                            (y.line + 1, y.start + y.length));
       List.fast_sort cmp l

src/lsp/cobol_parser/package.toml

@@ -86,7 +86,7 @@ dune-trailer = """
 (menhir (modules grammar_tokens grammar_common grammar)
         (merge_into grammar)
         (flags --inspection --cmly --table --strict
-
+               --explain
                --external-tokens Grammar_tokens
                --unused-tokens))
 

src/lsp/cobol_preproc/src_lexer.mll

@@ -176,17 +176,16 @@
 
 let newline = '\r'* '\n'
 let nnl = _ # ['\r' '\n']                             (* anything but newline *)
-let sna = nnl nnl nnl nnl nnl nnl              (* 6 chars; TODO: exclude tabs *)
-let spaces = ([' ' '\t']*)
+let sna = nnl nnl nnl nnl nnl nnl                     (* 6 chars *)
+let spaces = ' '*
 let    blank        = [' ' '\009' '\r']
 let nonblank        = nnl # blank
-let    blanks       =(blank+ | '\t')
-let    blank_area_A = blank blank blank blanks | '\t'
+let    blanks       = blank+
+let    blank_area_A = blank blank blank blanks
 let nonblank_area_A =(nonblank nnl nnl nnl |
                       blank nonblank nnl nnl |
                       blank blank nonblank nnl |
                       blank blank blank nonblank)
-let nonblank = nonblank # ['\t']    (* now, also exclude tab from blank chars *)
 let separator = [ ',' ';' ]
 let epsilon = ""
 let letter = [ 'a'-'z' 'A'-'Z' ]                      (* TODO: '\128'-'\255'? *)
@@ -255,10 +254,6 @@ rule fixed_line state
       {
         fixed_indicator (Src_lexing.sna state lexbuf) lexbuf
       }
-  | '\t'
-      {
-        fixed_nominal_line (Src_lexing.flush_continued state) lexbuf
-      }
   | (nnl* newline)                                  (* blank line (too short) *)
       {
         Src_lexing.new_line (Src_lexing.sna state lexbuf) lexbuf
@@ -269,7 +264,7 @@ rule fixed_line state
       }
 and fixed_indicator state
   = parse
-  | ' ' | '\t' (* second tab *)                                    (* nominal *)
+  | ' '
       {
         fixed_nominal_line (Src_lexing.flush_continued state) lexbuf
       }
@@ -360,7 +355,7 @@ and xopen_or_crt_or_acutrm_followup state
       }
 and cobolx_line state                                 (* COBOLX format (GCOS) *)
   = parse
-  | [' ' '\t']                                                     (* nominal *)
+  | ' '                                                 (* nominal *)
       {
         fixed_nominal_line (Src_lexing.flush_continued state) lexbuf
       }
@@ -593,7 +588,7 @@ and fixed_continue_quoted_ebcdics state
 
 and free_line state
   = parse
-  | blanks | '\t'
+  | blanks
       {
         free_line state lexbuf
       }

src/lsp/cobol_preproc/src_lexing.ml

@@ -675,3 +675,4 @@ let separator' ~char ~k = free_text (free_separator ~char) ~k
 let alphanum_lit' ~k = free_text free_alphanum_lit ~k
 
 (* --- *)
+

src/lsp/cobol_preproc/src_lexing.mli

@@ -11,6 +11,8 @@
 (*                                                                        *)
 (**************************************************************************)
 
+(** -- *)
+
 type 'k state
 
 val init_state: 'k Src_format.source_format -> 'k state
@@ -99,3 +101,4 @@ val unexpected
   -> ?severity: [`Error | `Warn]
   -> k: ('k state -> Lexing.lexbuf -> 'b)
   -> 'k state -> Lexing.lexbuf -> 'b
+

src/lsp/cobol_preproc/src_reader.ml

@@ -250,6 +250,9 @@ let make make_lexing ?filename ~source_format input =
 
 let from_string = make Lexing.from_string
 let from_channel = make Lexing.from_channel
+let from_channel_no_tabs ?(tab_stop=8) =
+    make (Src_rewriting.from_channel_expanding_tabs ~tab_stop)
+
 
 let fill buff ~lookup_len (input: Src_input.t) =
   match input with
@@ -276,9 +279,9 @@ let from ?source_format (input: Src_input.t) =
   let source_format, input = start_reading input ?source_format in
   match input with
   | String { contents; filename } ->
-      from_string ~source_format ~filename contents
+      from_string ~source_format ~filename (Src_rewriting.expand_tabs contents)
   | Channel { ic; filename } ->
-      from_channel ~source_format ~filename ic
+      from_channel_no_tabs ~source_format ~filename ic
 
 (* --- *)