Finishing touches to the rewindable parser, with some tests

Author: nberth

src/lsp/cobol_lsp/lsp_document.ml

@@ -169,18 +169,9 @@ let reparse_and_analyze ?position ({ copybook; rewinder; textdoc; _ } as doc) =
       { doc with artifacts = no_artifacts; rewinder = None; parsed = None }
   | Some position, Some rewinder ->
       extract_parsed_infos doc @@
-      Cobol_parser.rewind_and_parse rewinder ~position
-        begin fun ?new_position pp ->
-          let contents = Lsp.Text_document.text textdoc in
-          let contents = match new_position with
-            | None -> contents
-            | Some (Lexing.{ pos_cnum; _ } as _pos) ->
-                EzString.after contents (pos_cnum - 1)
-          in
-          (* Pretty.error "contents = %S@." contents; *)
-          Cobol_preproc.reset_preprocessor ?new_position pp
-            (String { contents; filename = Lsp.Uri.to_path (uri doc) })
-        end
+      Cobol_parser.rewind_and_parse rewinder ~position @@
+      Cobol_preproc.reset_preprocessor_for_string @@
+      Lsp.Text_document.text textdoc
 
 (** Creates a record for a document that is not yet parsed or analyzed. *)
 let blank ~project ?copybook textdoc =

src/lsp/cobol_parser/parser_engine.ml

@@ -519,9 +519,12 @@ module Make (Config: Cobol_config.T) = struct
   and ('a, 'm) rewindable_history_event =
     {
       preproc_position: Lexing.position;
-      event_stage: ('a, 'm) interim_stage;
+      event_stage: ('a, 'm) interim_stage_without_tokens;
     }
 
+  and ('a, 'm) interim_stage_without_tokens =
+    'm state * 'a Grammar_interpr.env         (* Always valid input_needed env. *)
+
   let init_rewindable_parse ps ~make_checkpoint =
     {
       init = ps;
@@ -530,17 +533,23 @@ module Make (Config: Cobol_config.T) = struct
     }
 
   (** Stores a stage as part of the memorized rewindable history events. *)
-  let save_history_event ((ps, _, _) as stage) (store: _ rewindable_history) =
+  let save_interim_stage (ps, _, env) (store: _ rewindable_history) =
     let preproc_position = Cobol_preproc.position ps.preproc.pp in
     match store with
+    | store'
+      when preproc_position.pos_cnum <> preproc_position.pos_bol ->
+        (* We must only save positions that correspond to beginning of lines;
+           this should only make us skip recording events at the end of
+           inputs. *)
+        store'
     | { preproc_position = prev_pos; _ } :: store'
       when prev_pos.pos_cnum  = preproc_position.pos_cnum  &&
            prev_pos.pos_fname = preproc_position.pos_fname ->
         (* Preprocessor did not advance further since last save: replace event
            with new parser state: *)
-        { preproc_position; event_stage = stage } :: store'
+        { preproc_position; event_stage = (ps, env) } :: store'
     | store' ->
-        { preproc_position; event_stage = stage } :: store'
+        { preproc_position; event_stage = (ps, env) } :: store'
 
   let rewindable_parser_state = function
     | { stage = Final (_, ps) | Trans (ps, _, _); _ } -> ps
@@ -560,7 +569,7 @@ module Make (Config: Cobol_config.T) = struct
       | Trans ((ps, _, _) as state) ->
           let store, count =
             if count = save_stage then store, succ count
-            else save_history_event state store, 0
+            else save_interim_stage state store, 0
           and stage =
             try on_interim_stage state with e -> on_exn ps e
           in
@@ -574,15 +583,23 @@ module Make (Config: Cobol_config.T) = struct
         pos
     | Indexed { line; char } ->
         let ps = rewindable_parser_state rwps in
-        let lexpos = Cobol_preproc.position ps.preproc.pp in
         let newline_cnums = Cobol_preproc.newline_cnums ps.preproc.pp in
-        let pos_bol =
-          try List.nth newline_cnums (line - 1)
-          with Not_found | Invalid_argument _ -> 0
-        in
-        Lexing.{ lexpos with pos_bol;
-                             pos_cnum = pos_bol + char;
-                             pos_lnum = line + 1 }
+        if newline_cnums = []
+        then raise Not_found (* no complete line was processed yet; just skip *)
+        else
+          let lexpos = Cobol_preproc.position ps.preproc.pp in
+          try
+            let pos_bol =
+              try List.nth newline_cnums (line - 1)
+              with Not_found | Invalid_argument _ -> 0
+            in
+            Lexing.{ lexpos with pos_bol;
+                                 pos_cnum = pos_bol + char;
+                                 pos_lnum = line + 1 }
+          with Failure _ ->
+            (* The given line exceeds what was already processed, so we restart
+               from the current preprocessor position. *)
+            lexpos
 
   let find_history_event_preceding ~position ({ store; _ } as rwps) =
     let lexpos = lexing_postion_of ~position rwps in
@@ -608,10 +625,11 @@ module Make (Config: Cobol_config.T) = struct
     let rwps =
       try
         let event, store = find_history_event_preceding ~position rwps in
-        let ps, tokens, env = event.event_stage in
+        let ps, env = event.event_stage in
         let pp = ps.preproc.pp in
-        let pp = pp_rewind ?new_position:(Some event.preproc_position) pp in
+        let pp = pp_rewind ~new_position:event.preproc_position pp in
         let ps = { ps with preproc = { ps.preproc with pp } } in
+        let ps, tokens = produce_tokens ps in
         { rwps with stage = Trans (ps, tokens, env); store }
       with Not_found ->                   (* rewinding before first checkpoint *)
         let pp = pp_rewind rwps.init.preproc.pp in

src/lsp/cobol_parser/parser_engine.mli

@@ -29,8 +29,8 @@ open Parser_outputs
     i.e,} {!Cobol_common.Diagnostics.Set.has_errors} holds).  This is in
     particular the case when the resulting parse-tree is provided and recovery
     is enabled ([options.recovery <> DisableRecovery]), as in such a case, the
-    parse-tree returned may contain dummy nodes and source locations produced
-    using the recovery mechanism. *)
+    parse-tree returned may contain dummy nodes and source locations produced by
+    the recovery mechanism. *)
 
 (** {1 Basic (one-shot) parsing} *)
 
@@ -92,8 +92,8 @@ type position =
       Lexing.position                                 (** raw lexing position *)
   | Indexed of
       {
-        line: int;               (** line number (starting at 0) *)
-        char: int;               (** character number in line (starting at 0) *)
+        line: int;             (** line number (starting from 0) *)
+        char: int;             (** character number in line (starting from 0) *)
       }
 
 (** [rewind_and_parse rewinder preprocessor_rewind ~position] uses [rewinder] to

src/lsp/cobol_parser/text_lexer.ml

@@ -109,15 +109,16 @@ module Make (Words: module type of Text_keywords) = struct
   let silenced_keywords =
     StringSet.of_list Words.silenced_keywords
 
-  let reserve_words: Cobol_config.words_spec -> unit =
+  let reserve_words: Cobol_config.words_spec -> DIAGS.Set.t =
     let on_token_handle_of kwd descr ~f =
-      try f @@ handle_of_keyword kwd with
+      try f @@ handle_of_keyword kwd; DIAGS.Set.none with
       | Not_found when StringSet.mem kwd silenced_keywords ->
-          ()                                        (* Ignore silently? Warn? *)
+          DIAGS.Set.none                            (* Ignore silently? Warn? *)
       | Not_found ->
-          Pretty.error "@[Unable@ to@ %s@ keyword:@ %s@]@." descr kwd
+          DIAGS.Set.error "@[Unable@ to@ %s@ keyword:@ %s@]@." descr kwd
     in
-    List.iter begin fun (w, word_spec) -> match word_spec with
+    List.fold_left begin fun diags (w, word_spec) ->
+      DIAGS.Set.union diags @@ match word_spec with
       | Cobol_config.ReserveWord { preserve_context_sensitivity } ->
           on_token_handle_of w "reserve" ~f:begin fun h ->
             if preserve_context_sensitivity
@@ -132,7 +133,7 @@ module Make (Words: module type of Text_keywords) = struct
           end
       | NotReserved ->
           on_token_handle_of w "unreserve" ~f:unreserve_token
-    end
+    end DIAGS.Set.none
 
   let enable_tokens tokens =
     TokenHandles.iter enable_token tokens

src/lsp/cobol_parser/text_lexer.mli

@@ -31,7 +31,7 @@ val show_token_of_handle: token_handle -> string
 (* --- *)
 
 val handle_of_token: Grammar_tokens.token -> token_handle
-val reserve_words: Cobol_config.words_spec -> unit
+val reserve_words: Cobol_config.words_spec -> Cobol_common.Diagnostics.Set.t
 val enable_tokens: TokenHandles.t -> unit
 val disable_tokens: TokenHandles.t -> unit
 

src/lsp/cobol_parser/text_tokenizer.ml

@@ -303,12 +303,11 @@ module Make (Config: Cobol_config.T) = struct
   let amnesic = Amnesic
   let eidetic = Eidetic []
   let init memory ~context_sensitive_tokens =
-    init_text_lexer ~context_sensitive_tokens;
     {
       expect_picture_string = false;
       leftover_tokens = [];
       memory;
-      diags = DIAGS.Set.none;
+      diags = init_text_lexer ~context_sensitive_tokens;
       lexing_options = Text_lexer.default_lexing_options;
     }
 

src/lsp/cobol_preproc/preproc.ml

@@ -101,9 +101,9 @@ let srclex_from_channel = make_srclex Lexing.from_channel
 let srclex_from_file ~source_format filename : any_srclexer =
   srclex_from_string ~source_format ~filename (EzFile.read_file filename)
 
-(** Note: If given, assumes [position] corresponds to the begining of the
-    input. If absent, restarts from first position.  File name is kept from the
-    previous input. *)
+(** Note: If given, assumes [position] corresponds to the beginning of the
+    input, which {e must} also be at the beginning of a line.  If absent,
+    restarts from first position.  File name is kept from the previous input. *)
 let srclex_restart make_lexing ?position input (Plx (s, prev_lexbuf)) =
   let lexbuf = make_lexing ?with_positions:(Some true) input in
   let pos_fname = match position with

src/lsp/cobol_preproc/preproc_engine.ml

@@ -390,6 +390,13 @@ let pp_pptokens: pptokens Pretty.printer =
 let reset_preprocessor ?new_position pp input =
   preprocessor input (`ResetPosition (pp, new_position))
 
+let reset_preprocessor_for_string string ?new_position pp =
+  let contents = match new_position with
+    | Some Lexing.{ pos_cnum; _ } -> EzString.after string (pos_cnum - 1)
+    | None -> string
+  in                                                   (* filename is ignored *)
+  reset_preprocessor ?new_position pp @@ String { contents; filename = "" }
+
 (* --- *)
 
 let preprocessor ?(options = Preproc_options.default) input =

src/lsp/cobol_preproc/preproc_engine.mli

@@ -27,6 +27,12 @@ val reset_preprocessor
   -> preprocessor
   -> input
   -> preprocessor
+val reset_preprocessor_for_string
+  : string
+  -> ?new_position:Lexing.position
+  -> preprocessor
+  -> preprocessor
+
 
 (* --- *)
 

test/cobol_parsing/dune

@@ -3,12 +3,28 @@
   (modules test_picture_parsing test_combined_relations_parsing)
   (libraries alcotest cobol_parser cobol_data))
 
+(library
+ (name parser_testing)
+ (modules Parser_testing)
+ (libraries cobol_parser)
+ )
+
 (library
  (name test_cobol_parser)
- (modules cS_tokens decimal_point tokens parser_testing)
+ (modules cS_tokens decimal_point tokens)
  (preprocess
   (pps ppx_expect))
  (inline_tests
   (modes best)) ; add js for testing with nodejs
- (libraries cobol_parser)
+ (libraries parser_testing)
+ )
+
+(library
+ (name test_cobol_parser_rewind)
+ (modules test_appending test_appending_large test_cutnpaste_large)
+ (preprocess
+  (pps ppx_expect))
+ (inline_tests
+  (modes best)) ; add js for testing with nodejs
+ (libraries parser_testing testsuite_utils)
  )