Fix source location management during completion

Removes a potential infinite loop with comment entries that are not
terminated (reaching end of input); also avoids source location errors
during parser exploration by LSP completion code.

src/lsp/cobol_common/srcloc.ml

@@ -69,16 +69,17 @@ include TYPES
 
 (* For debugging: *)
 
+let pp_lexpos ppf Lexing.{ pos_fname; pos_lnum; pos_cnum; pos_bol } =
+  Pretty.print ppf "%s:%d-%d" pos_fname pos_lnum (pos_cnum - pos_bol)
+
 let pp_srcloc_struct: srcloc Pretty.printer =
-  let pp_lexloc ppf Lexing.{ pos_fname; pos_lnum; pos_cnum; pos_bol } =
-    Pretty.print ppf "%s:%d-%d" pos_fname pos_lnum (pos_cnum - pos_bol)
-  and pp_lexloc' ppf Lexing.{ pos_lnum; pos_cnum; pos_bol; _ } =
+  let pp_lexpos' ppf Lexing.{ pos_lnum; pos_cnum; pos_bol; _ } =
     Pretty.print ppf "%d-%d" pos_lnum (pos_cnum - pos_bol)
   in
   let rec pp: type t. t slt Pretty.printer = fun ppf -> function
     | Raw (s, e, _) ->
         Pretty.print ppf "<%a|%a>"
-          pp_lexloc s pp_lexloc' e
+          pp_lexpos s pp_lexpos' e
     | Cpy { copied; _ } ->
         Pretty.print ppf "Cpy { copied = %a }"
           pp copied

src/lsp/cobol_common/srcloc.mli

@@ -39,6 +39,7 @@ module INFIX: sig
   val ( ~&@ ): 'a with_loc -> 'a * srcloc
 end
 
+val pp_lexpos: Lexing.position Pretty.printer
 val pp_srcloc: srcloc Pretty.printer
 val pp_srcloc_struct: srcloc Pretty.printer
 val pp_file_loc: srcloc Pretty.printer

src/lsp/cobol_lsp/lsp_completion.ml

@@ -201,9 +201,9 @@ let get_nthline s n =
 let word_delimiters = [' '; '\t'; '.'; '('; ')']
 let rec first_delimiter_index_before text idx =
   if idx == 0 then 0 else
-  if List.mem (String.get text (idx-1)) word_delimiters
+  if List.mem text.[idx - 1] word_delimiters
   then idx
-  else first_delimiter_index_before text (idx-1)
+  else first_delimiter_index_before text (idx - 1)
 
 let range_n_case case (pos:Position.t) text =
   let { line; character = caret_column }: Position.t = pos in
@@ -284,25 +284,20 @@ let expected_comp_entries_in ~env ~eager =
 
 let expected_tokens ?(eager=true) base_env =
   let rec inner acc env  =
-    let pos = match Menhir.top env with
-      | None -> snd (Srcloc.as_lexloc Srcloc.dummy)
-      | Some Menhir.Element (_, _, _, pos) -> pos in
-    let acc =
-      CompEntrySet.add_seq (expected_comp_entries_in ~env ~eager) acc in
-    Expect.actions_in ~env
-    |> List.filter_map begin function
+    let _, pos = Menhir.positions env in
+    let expected_tokens_after_action = function
       | Expect.Reduce prod ->
-        begin
-          try Some ( Menhir.force_reduction prod env )
-          with Invalid_argument _ -> None
-        end
+          (try Some (Menhir.force_reduction prod env)
+           with Invalid_argument _ -> None)
       | Feed nt ->
-        try
-          let default_value = Expect.default_nonterminal_value nt in
-          Some ( Menhir.feed (N nt) pos default_value pos env )
-        with Not_found -> None
-    end
-    |> List.fold_left inner acc
+          (try
+             let default_value = Expect.default_nonterminal_value nt in
+             Some (Menhir.feed (N nt) pos default_value pos env)
+           with Not_found -> None)
+    in
+    let acc = CompEntrySet.add_seq (expected_comp_entries_in ~env ~eager) acc in
+    List.fold_left inner acc @@
+    List.filter_map expected_tokens_after_action (Expect.actions_in ~env)
   in
   inner CompEntrySet.empty base_env
 
@@ -318,21 +313,23 @@ let config ?(eager=true) ?(case=Auto) () =
     case;
   }
 
-let contextual ~config
-    (doc:Lsp_document.t)
-    Cobol_typeck.Outputs.{ group; _ }
-    (pos:Position.t) =
+let contextual ~config (doc: Lsp_document.t) Cobol_typeck.Outputs.{ group; _ }
+    (pos: Position.t)
+  =
   let filename = Lsp.Uri.to_path (Lsp.Text_document.documentUri doc.textdoc) in
   let range, case = range_n_case config.case pos doc.textdoc in
-  let pointwise = range.start.character == range.end_.character in
-  begin match Lsp_document.inspect_at ~position:(range.start) doc with
-    | Some Env env ->
-      let items =
-        map_completion_items ~range ~case ~group ~filename
-        @@ expected_tokens ~eager:config.eager env
-      in
-      CompletionList.create () ~isIncomplete:pointwise ~items
-    | _ ->
-      CompletionList.create () ~isIncomplete:true ~items:[]
-  end
-
+  let items, incomplete =
+    Option.value ~default:([], true) @@
+    Lsp_document.inspect_at ~position:(range.start) doc
+      ~f:begin function
+        | Env env ->
+            let items =
+              map_completion_items ~range ~case ~group ~filename @@
+              expected_tokens ~eager:config.eager env
+            in
+            items, range.start.character == range.end_.character
+        | Sink ->
+            [], true
+      end
+  in
+  CompletionList.create () ~isIncomplete:incomplete ~items

src/lsp/cobol_lsp/lsp_document.ml

@@ -134,14 +134,15 @@ let reparse_and_analyze ?position ({ copybook; rewinder; textdoc; _ } as doc) =
       Cobol_preproc.reset_preprocessor_for_string @@
       Lsp.Text_document.text textdoc
 
-(** [inspect_at ~position doc] returns the state that is reached by the parser
-    at [position] in [doc].  Returns [None] on copybooks. *)
-let rec inspect_at ~position ({ copybook; rewinder; textdoc; _ } as doc) =
+(** [inspect_at ~position ~f doc] passes to [f] the state that is reached by the
+    parser at [position] in [doc].  Returns [None] on copybooks, or [Some r] for
+    [r] the result of [f]. *)
+let rec inspect_at ~position ~f ({ copybook; rewinder; textdoc; _ } as doc) =
   match rewinder with
   | None | Some _ when copybook ->                                     (* skip *)
       None
   | None ->
-      inspect_at ~position @@ parse_and_analyze doc
+      inspect_at ~position ~f @@ parse_and_analyze doc
   | Some rewinder ->
       let Lsp.Types.Position.{ line; character = char } = position in
       let exception FAILURE in
@@ -160,6 +161,7 @@ let rec inspect_at ~position ({ copybook; rewinder; textdoc; _ } as doc) =
         Option.some @@
         Cobol_parser.rewind_for_inspection rewinder preproc_rewind
           ~position:(Indexed { line; char })
+          ~inspect:f
       with FAILURE ->
         None
 

src/lsp/cobol_parser/parser_engine.ml

@@ -722,13 +722,14 @@ let rewind_and_parse { rewind_n_parse; _ } rewind_preproc ~position =
 
 (* Rewinding for inspection *)
 
-let rewind_for_inspection { rewind_n_parse; _ } rewind_preproc ~position =
-  let { result = _, { last_env_stage; _ }; _ } =
-    Overlay_manager.with_temporary_copy ~f:begin fun () ->
+let rewind_for_inspection { rewind_n_parse; _ } rewind_preproc
+    ~position ~inspect =
+  Overlay_manager.with_temporary_copy ~f:begin fun () ->
+    let { result = _, { last_env_stage; _ }; _ } =
       rewind_n_parse ~stop_before_eof:true rewind_preproc ~position
-    end ()
-  in
-  last_env_stage
+    in
+    inspect last_env_stage
+  end ()
 
 (* Extracting artifacts *)
 

src/lsp/cobol_parser/parser_engine.mli

@@ -125,11 +125,12 @@ type inspectable_parser_state =
   | Env: 'a Grammar.MenhirInterpreter.env -> inspectable_parser_state
   | Sink
 
+(** Note: given parser state should not escapre [inspect]. *)
 val rewind_for_inspection
   : 'x rewinder
   -> preprocessor_rewind
   -> position: position
-  -> inspectable_parser_state
+  -> inspect: (inspectable_parser_state -> 'a) -> 'a
 
 (** {1 Accessing artifacts} *)
 

src/lsp/cobol_parser/text_tokenizer.ml

@@ -88,7 +88,7 @@ let preproc_n_combine_tokens ~intrinsics_enabled ~source_format =
       let error = Missing { loc = hd l; stuff = Continuation_of str } in
       aux (p', l', Parser_diagnostics.add_error error diags) pl
     and comment_entry_after n =
-      let acc, ((p, _) as suff) = skip acc (p, l) n in
+      let acc, ((p, l) as suff) = skip acc (p, l) n in
       if p = [] then Result.Error `MissingInputs else
         let consume_comment = match comment_entry_termination with
           | Newline ->
@@ -98,8 +98,7 @@ let preproc_n_combine_tokens ~intrinsics_enabled ~source_format =
           | AreaB { first_area_b_column } ->
               comment_paragraph ~stop_column:first_area_b_column
         and at_end ~loc ~revtoks (p', l', diags) =
-          let p', l' = comment_entry revtoks :: p', loc :: l' in
-          p', l', diags
+          comment_entry revtoks :: p', loc :: l', diags
         in
         consume_comment ~loc:(hd l) ~revtoks:[] ~at_end
           Comment_entry acc suff
@@ -215,6 +214,8 @@ let preproc_n_combine_tokens ~intrinsics_enabled ~source_format =
   and comment_line ~init_pos ~loc ~revtoks ~at_end descr acc = function
     | [], _ ->                  (* found no word starting on anther line (yet) *)
         Result.Error `MissingInputs
+    | EOF :: _ as p, l ->                                (* non-terminated line *)
+        aux (at_end ~loc ~revtoks acc) (p, l)
     | p, (p_loc :: _ as l)
       when (let Lexing.{ pos_fname; pos_bol; _ } = start_pos p_loc in
             pos_bol > init_pos.Lexing.pos_bol ||

src/lsp/cobol_preproc/src_overlay.ml

@@ -17,11 +17,11 @@ let debug_oc = ref None
 
 (*
 let message fmt =
-  Printf.kprintf (fun s ->
+  Format.kasprintf (fun s ->
       match !debug_oc with
       | None -> ()
       | Some oc ->
-        Printf.fprintf oc "OVERLAY: %s\n%!" s) fmt
+          Printf.fprintf oc "OVERLAY: %s\n%!" s) fmt
 *)
 
 module TYPES = struct
@@ -116,9 +116,9 @@ let limits: manager -> srcloc -> limit * limit = fun ctx loc ->
       HLnks.add ctx.right_of left (loc, right);
       left, right
 
-(** WLnks token limits *)
+(** Links token limits *)
 let link_limits ctx left right =
-  (* Replace to deal with overriding of limits during recovery. *)
+  (* Replace to deal with overriding of limits during recovery/rewind. *)
   HLnks.replace ctx.over_right_gap left right
 
 (** Returns a source location that spans between two given limits; returns a
@@ -166,12 +166,11 @@ let join_limits: manager -> limit * limit -> srcloc = fun ctx (s, e) ->
     else try_cache_from s
   in
   let join_failure (s, e) =
-    let loc = Cobol_common.Srcloc.raw (s, e) in
     Pretty.error "@[<2>%a:@ Internal@ warning:@ unable@ to@ join@ locations@ \
                   via@ limits@ in@ `%s.join_limits`@ [ctx=%s]@]@."
-      Cobol_common.Srcloc.pp_file_loc loc __MODULE__ ctx.id;
+      Cobol_common.Srcloc.pp_lexpos s __MODULE__ ctx.id;
     (* Printexc.(print_raw_backtrace Stdlib.stderr @@ get_callstack 10); *)
-    loc
+    Cobol_common.Srcloc.raw (e, e)
   in
   try   (* first attempt assumes proper token limits: `s` is a left and `e` is a
            right of tokens *)

test/cobol_parsing/tokens.ml

@@ -50,3 +50,18 @@ let%expect_test "token-locations" =
     DIGITS[1]@<prog.cob:1-5|1-6>
     )@<prog.cob:1-6|1-7>
     EOF@<prog.cob:1-7|1-7> |}];;
+
+let%expect_test "token-locations-with-missing-comment-paragraph" =
+  Parser_testing.show_parsed_tokens ~source_format:Auto ~with_locations:true
+    ~parser_options:(Parser_testing.options ~verbose:true ())
+    "IDENTIFICATION DIVISION.\nAUTHOR.";
+  [%expect {|
+    Tks: IDENTIFICATION, DIVISION, .
+    Tks: AUTHOR, ., COMMENT_ENTRY[], EOF
+    IDENTIFICATION@<prog.cob:1-0|1-14>
+    DIVISION@<prog.cob:1-15|1-23>
+    .@<prog.cob:1-23|1-24>
+    AUTHOR@<prog.cob:2-0|2-6>
+    .@<prog.cob:2-6|2-7>
+    COMMENT_ENTRY[]@<prog.cob:2-7|2-7>
+    EOF@<prog.cob:2-7|2-7> |}];;

test/lsp/lsp_completion.ml

@@ -39,25 +39,29 @@ let completion_positions (doc, positions) : string -> unit =
     begin
       match LSP.Request.completion ~eager:false server params with
       | None ->
-        Pretty.out "Failed completion@."
+          Pretty.out "Failed completion@."
       | Some `CompletionList { items; _ } when items == [] ->
-        Pretty.out "Empty completion list@."
+          Pretty.out "Empty completion list@."
       | Some `CompletionList { items; _ } ->
-        Pretty.out "@.@[<hv 4>Basic (%d entries):@;%a@]@\n"
-          (List.length items)
-          (Fmt.list ~sep:Fmt.sp escaped_string)
-          items
+          Pretty.out "@.@[<hv 4>Basic (%d entries):@;%a@]@\n"
+            (List.length items)
+            (Fmt.list ~sep:Fmt.sp escaped_string)
+            items
+      | exception Jsonrpc.Response.Error.E { message; _ } ->
+          Pretty.out "%s@;" message
     end;
     match LSP.Request.completion ~eager:true server params with
     | None ->
-      Pretty.out "Failed eager-completion@."
+        Pretty.out "Failed eager-completion@."
     | Some `CompletionList { items; _ } when items == [] ->
-      Pretty.out "Empty eager-completion list@."
+        Pretty.out "Empty eager-completion list@."
     | Some `CompletionList { items; _ } ->
-      Pretty.out "@[<hv 4>Eager (%d entries):@;%a@]@\n"
-        (List.length items)
-        (Fmt.list ~sep:Fmt.sp escaped_string)
-        items;
+        Pretty.out "@[<hv 4>Eager (%d entries):@;%a@]@\n"
+          (List.length items)
+          (Fmt.list ~sep:Fmt.sp escaped_string)
+          items;
+    | exception Jsonrpc.Response.Error.E { message; _ } ->
+        Pretty.out "%s@;" message
   in
   StringMap.iter (fun n p -> completions_at_position ~key:n p) positions.pos_map;
   List.iter (fun p -> completions_at_position p) positions.pos_anonymous;
@@ -5370,3 +5374,72 @@ let%expect_test "string-concat-completion" =
     (line 7, character 23):
     Basic (1 entries): TO
     Eager (1 entries): TO |}];;
+
+let%expect_test "preproc-interaction" =
+  let end_with_postproc = completion_positions @@ extract_position_markers
+      "IDENTIFICATION DIVISION.\nAUTHOR._|_ foo\n_|_\n"
+  in
+  end_with_postproc [%expect.output];
+  [%expect {|
+    {"params":{"diagnostics":[{"message":"Invalid syntax","range":{"end":{"character":0,"line":3},"start":{"character":0,"line":3}},"severity":1},{"message":"Missing PROGRAM_ID <word> .","range":{"end":{"character":11,"line":1},"start":{"character":11,"line":1}},"severity":4}],"uri":"file://__rootdir__/prog.cob"},"method":"textDocument/publishDiagnostics","jsonrpc":"2.0"}
+    __rootdir__/prog.cob:2.7:
+       1   IDENTIFICATION DIVISION.
+       2 > AUTHOR. foo
+    ----          ^
+       3
+    (line 1, character 7):
+    Basic (11 entries):
+        AUTHOR
+        CLASS-ID
+        DATE-COMPILED
+        DATE-MODIFIED
+        DATE-WRITTEN
+        FUNCTION-ID
+        INSTALLATION
+        INTERFACE-ID
+        PROGRAM-ID
+        REMARKS
+        SECURITY
+    Eager (11 entries):
+        AUTHOR.\n
+        CLASS-ID.\n
+        DATE-COMPILED.\n
+        DATE-MODIFIED.\n
+        DATE-WRITTEN.\n
+        FUNCTION-ID
+        INSTALLATION.\n
+        INTERFACE-ID.\n
+        PROGRAM-ID
+        REMARKS.\n
+        SECURITY.\n
+    __rootdir__/prog.cob:3.0:
+       1   IDENTIFICATION DIVISION.
+       2   AUTHOR. foo
+       3 >
+    ----   ^
+    (line 2, character 0):
+    Basic (11 entries):
+        AUTHOR
+        CLASS-ID
+        DATE-COMPILED
+        DATE-MODIFIED
+        DATE-WRITTEN
+        FUNCTION-ID
+        INSTALLATION
+        INTERFACE-ID
+        PROGRAM-ID
+        REMARKS
+        SECURITY
+    Eager (11 entries):
+        AUTHOR.\n
+        CLASS-ID.\n
+        DATE-COMPILED.\n
+        DATE-MODIFIED.\n
+        DATE-WRITTEN.\n
+        FUNCTION-ID
+        INSTALLATION.\n
+        INTERFACE-ID.\n
+        PROGRAM-ID
+        REMARKS.\n
+        SECURITY.\n
+  |}]

test/lsp/lsp_inspect.ml

@@ -30,7 +30,10 @@ let inspect_positions (doc, positions) : string -> unit =
       location_as_srcloc#pp location
       Fmt.(option ~none:nop (string ++ sp)) position_name
       position.line position.character;
-    match LSP.Document.inspect_at ~position doc with
+    (* Note: parser state escapes [f], but that should be avoided to avoid
+       messing up with the internal overlay manager.  Ok for these simple tests
+       though. *)
+    match LSP.Document.inspect_at ~position doc ~f:Fun.id with
     | None ->
         Pretty.error "failed inspection@."
     | Some Sink ->