diff --git a/src/lsp/cobol_common/srcloc.ml b/src/lsp/cobol_common/srcloc.ml index 461de793..0f994816 100644 --- a/src/lsp/cobol_common/srcloc.ml +++ b/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 diff --git a/src/lsp/cobol_common/srcloc.mli b/src/lsp/cobol_common/srcloc.mli index 2d511b5a..9fb57d8d 100644 --- a/src/lsp/cobol_common/srcloc.mli +++ b/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 diff --git a/src/lsp/cobol_lsp/lsp_completion.ml b/src/lsp/cobol_lsp/lsp_completion.ml index fbb84cf3..eefbda03 100644 --- a/src/lsp/cobol_lsp/lsp_completion.ml +++ b/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 diff --git a/src/lsp/cobol_lsp/lsp_document.ml b/src/lsp/cobol_lsp/lsp_document.ml index 0b51da84..c60f3d05 100644 --- a/src/lsp/cobol_lsp/lsp_document.ml +++ b/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 diff --git a/src/lsp/cobol_parser/parser_engine.ml b/src/lsp/cobol_parser/parser_engine.ml index 6d94e84c..e6feeabb 100644 --- a/src/lsp/cobol_parser/parser_engine.ml +++ b/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 *) diff --git a/src/lsp/cobol_parser/parser_engine.mli b/src/lsp/cobol_parser/parser_engine.mli index 8cbc36fb..d9eac21d 100644 --- a/src/lsp/cobol_parser/parser_engine.mli +++ b/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} *) diff --git a/src/lsp/cobol_parser/text_tokenizer.ml b/src/lsp/cobol_parser/text_tokenizer.ml index feb40585..5bdd7ee2 100644 --- a/src/lsp/cobol_parser/text_tokenizer.ml +++ b/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 || diff --git a/src/lsp/cobol_preproc/src_overlay.ml b/src/lsp/cobol_preproc/src_overlay.ml index 6ab3650b..aa4c6927 100644 --- a/src/lsp/cobol_preproc/src_overlay.ml +++ b/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 *) diff --git a/test/cobol_parsing/tokens.ml b/test/cobol_parsing/tokens.ml index f23b3d67..c58785e5 100644 --- a/test/cobol_parsing/tokens.ml +++ b/test/cobol_parsing/tokens.ml @@ -50,3 +50,18 @@ let%expect_test "token-locations" = DIGITS[1]@ )@ EOF@ |}];; + +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@ + DIVISION@ + .@ + AUTHOR@ + .@ + COMMENT_ENTRY[]@ + EOF@ |}];; diff --git a/test/lsp/lsp_completion.ml b/test/lsp/lsp_completion.ml index 272fc357..620124cf 100644 --- a/test/lsp/lsp_completion.ml +++ b/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 "@.@[Basic (%d entries):@;%a@]@\n" - (List.length items) - (Fmt.list ~sep:Fmt.sp escaped_string) - items + Pretty.out "@.@[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 "@[Eager (%d entries):@;%a@]@\n" - (List.length items) - (Fmt.list ~sep:Fmt.sp escaped_string) - items; + Pretty.out "@[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 .","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 + |}] diff --git a/test/lsp/lsp_inspect.ml b/test/lsp/lsp_inspect.ml index d1bf6af5..52a0ad35 100644 --- a/test/lsp/lsp_inspect.ml +++ b/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 ->