From 916d37b93c8ad0e2fbe98377093726baf051b708 Mon Sep 17 00:00:00 2001 From: Chimrod <> Date: Mon, 5 Feb 2024 09:32:10 +0100 Subject: Ignore the global checkers if there is a syntax error; ignore error during recovery after a syntax error --- bin/qsp_parser.ml | 37 +++++++++++++--------- lib/qparser/analyzer.ml | 80 ++++++++++++++++++++++++++++++------------------ lib/qparser/analyzer.mli | 4 ++- lib/qparser/lexbuf.ml | 15 +++++++-- lib/qparser/lexbuf.mli | 9 +++++- lib/qparser/lexer.ml | 4 +-- lib/syntax/S.ml | 6 ++++ test/location.ml | 28 +++++++++++++++++ test/make_checkTest.ml | 39 ++++++++++++++++++----- test/qsp_parser_test.ml | 1 + test/syntax.ml | 5 +-- 11 files changed, 168 insertions(+), 60 deletions(-) create mode 100644 test/location.ml diff --git a/bin/qsp_parser.ml b/bin/qsp_parser.ml index 30c0ac0..ebf4738 100644 --- a/bin/qsp_parser.ml +++ b/bin/qsp_parser.ml @@ -12,7 +12,7 @@ let filter_report : Args.filters -> Report.t list -> Report.t -> Report.t list = match is_ok with true -> r :: reports | _ -> reports -type ctx = { error_nb : int; warn_nb : int; debug_nb : int } +type ctx = { error_nb : int; warn_nb : int; debug_nb : int; fatal_error : bool } (* List all the controls to apply @@ -98,8 +98,9 @@ let parse_location : fun ~ctx (module Check) context lexbuf filters -> let result = Qparser.Analyzer.parse (module Check) lexbuf context - |> Result.map (fun (_, f) -> - List.fold_left f ~init:[] ~f:(filter_report filters) + |> Result.map (fun f -> + List.fold_left f.Qparser.Analyzer.report ~init:[] + ~f:(filter_report filters) |> List.sort ~cmp:Report.compare) in match result with @@ -120,7 +121,7 @@ let parse_location : let start_position, _ = Qparser.Lexbuf.positions lexbuf in Format.fprintf Format.std_formatter "Location@ %s@;@[%a]@." start_position.Lexing.pos_fname Report.pp e; - ctx := { !ctx with error_nb = succ !ctx.error_nb } + ctx := { !ctx with error_nb = succ !ctx.error_nb; fatal_error = true } let () = let file_names, parameters = @@ -156,7 +157,9 @@ let () = (* Initialize all the checkers before parsing the source *) let (module Check) = Lazy.force checkers in let check_context = Check.initialize () in - let ctx = ref { error_nb = 0; warn_nb = 0; debug_nb = 0 } in + let ctx = + ref { error_nb = 0; warn_nb = 0; debug_nb = 0; fatal_error = false } + in let () = try @@ -168,16 +171,22 @@ let () = with Qparser.Lexer.EOF -> () in - (* If the parsing was global, extract the result for the whole test *) - let global_report = Check.finalize check_context in - List.iter global_report ~f:(fun (f_name, report) -> - Format.fprintf Format.std_formatter "Location@ %s@;@[%a@]@." f_name - Report.pp report; + (match !ctx.fatal_error with + | true -> + Format.fprintf Format.std_formatter + "(Ignoring global checkers because of the previous syntax errors)@." + | false -> + (* If the parsing was global and we didn’t got parsing error, extract the + result for the whole test *) + let global_report = Check.finalize check_context in + List.iter global_report ~f:(fun (f_name, report) -> + Format.fprintf Format.std_formatter "Location@ %s@;@[%a@]@." f_name + Report.pp report; - match report.Report.level with - | Error -> ctx := { !ctx with error_nb = succ !ctx.error_nb } - | Warn -> ctx := { !ctx with warn_nb = succ !ctx.warn_nb } - | Debug -> ctx := { !ctx with debug_nb = succ !ctx.debug_nb }); + match report.Report.level with + | Error -> ctx := { !ctx with error_nb = succ !ctx.error_nb } + | Warn -> ctx := { !ctx with warn_nb = succ !ctx.warn_nb } + | Debug -> ctx := { !ctx with debug_nb = succ !ctx.debug_nb })); match (!ctx.error_nb, !ctx.warn_nb) with | 0, 0 -> ( diff --git a/lib/qparser/analyzer.ml b/lib/qparser/analyzer.ml index 6d09021..7d9b7d2 100644 --- a/lib/qparser/analyzer.ml +++ b/lib/qparser/analyzer.ml @@ -1,16 +1,18 @@ +type 'a result = { content : 'a; report : Qsp_syntax.Report.t list } + (** Run the QSP parser and apply the analyzer over it. See [syntax/S] *) -let parse : +let rec parse : type a context. (module Qsp_syntax.S.Analyzer with type Location.t = a and type context = context) -> Lexbuf.t -> context -> - (a * Qsp_syntax.Report.t list, Qsp_syntax.Report.t) Result.t = + (a result, Qsp_syntax.Report.t) Result.t = fun (module S : Qsp_syntax.S.Analyzer with type Location.t = a and type context = context) -> @@ -41,33 +43,53 @@ let parse : Error err in - (* Then apply the checks over the result of the parsing *) - evaluation - |> Result.map (fun r -> - let r' = r context in - (r', S.Location.v r')) - |> Result.map_error (fun e -> - let message = - match e.IncrementalParser.code with - | Interpreter.InvalidSyntax -> "Invalid Syntax" - | Interpreter.UnrecoverableError -> "UnrecoverableError" - | Interpreter.Custom msg -> msg - | Interpreter.MenhirCode c -> - let message_content = - try Parser_messages.message c - with Not_found -> - String.concat "" [ "(Error code "; string_of_int c; ")" ] - in + (* Then evaluate the result *) + match (evaluation, Lexbuf.is_recovery l) with + | Ok r, _ -> + (* We have been able to read the syntax, apply the checkers over the + Tree *) + let content = r context in + Ok { content; report = S.Location.v content } + | _, true -> + (* This pattern can occur after recovering from an error. The + application attempt to start from a clean state in the next + location, but may fail to detect the correct position. If so, we + just start again until we hook the next location *) + parse (module S) l context + | Error e, _ -> + let message = + match e.IncrementalParser.code with + | Interpreter.UnrecoverableError -> "UnrecoverableError" + | Interpreter.InvalidSyntax -> "Invalid Syntax" + | Interpreter.Custom msg -> msg + | Interpreter.MenhirCode c -> + let message_content = + try Parser_messages.message c + with Not_found -> + String.concat "" [ "(Error code "; string_of_int c; ")" ] + in + String.concat "" [ String.trim message_content ] + in + + let report = Qsp_syntax.Report.error (e.start_pos, e.end_pos) message in + (* Rollback the buffer from the latest errror before discarding until + the end of the location. This ensure we will read the marker + for the end location in the case the error was actually in + this line itsef. + + Example : + + # location + - String.concat "" [ String.trim @@ message_content ] - in - let report = - Qsp_syntax.Report.error (e.start_pos, e.end_pos) message - in + ! ------- a + --- location --------------------------------- + *) + Lexbuf.rollback l; - (* Discard the remaining file to read. The parser is now in a blank - state, it does not make sense to keep feeding it with the new - tokens. *) - let () = try Lexer.discard l with _ -> () in + (* Discard the remaining file to read. The parser is now in a blank + state, it does not make sense to keep feeding it with the new + tokens. *) + let () = try Lexer.discard l with _ -> () in - report) + Error report diff --git a/lib/qparser/analyzer.mli b/lib/qparser/analyzer.mli index 8033601..949db16 100644 --- a/lib/qparser/analyzer.mli +++ b/lib/qparser/analyzer.mli @@ -1,10 +1,12 @@ +type 'a result = { content : 'a; report : Qsp_syntax.Report.t list } + val parse : (module Qsp_syntax.S.Analyzer with type Location.t = 'a and type context = 'context) -> Lexbuf.t -> 'context -> - ('a * Qsp_syntax.Report.t list, Qsp_syntax.Report.t) Result.t + ('a result, Qsp_syntax.Report.t) Result.t (** Read the source and build a analyzis over it. This method make the link between the source file and how to read it diff --git a/lib/qparser/lexbuf.ml b/lib/qparser/lexbuf.ml index 1d93f67..afc3bac 100644 --- a/lib/qparser/lexbuf.ml +++ b/lib/qparser/lexbuf.ml @@ -5,6 +5,7 @@ type t = { mutable start_p : Lexing.position option; state : state Stack.t; reset_line : bool; + mutable recovering : bool; } and lexer = t -> Tokens.token @@ -50,7 +51,8 @@ let start : t -> unit = Sedlexing.set_position t.buffer { end_pos with Lexing.pos_lnum = 1 } in Stack.clear t.state; - t.start_p <- None + t.start_p <- None; + t.recovering <- false let positions : t -> Lexing.position * Lexing.position = fun t -> @@ -62,7 +64,13 @@ let content : t -> string = fun t -> Sedlexing.Utf8.lexeme t.buffer let from_lexbuf : ?reset_line:bool -> Sedlexing.lexbuf -> t = fun ?(reset_line = true) t -> - { buffer = t; start_p = None; reset_line; state = Stack.create () } + { + buffer = t; + start_p = None; + reset_line; + state = Stack.create (); + recovering = false; + } let set_start_position : t -> Lexing.position -> unit = fun t position -> @@ -97,3 +105,6 @@ let overlay : t -> lexer -> lexer = match layer with | String wraper | EndString wraper -> wraper.start_string acc | _ -> acc) + +let start_recovery : t -> unit = fun t -> t.recovering <- true +let is_recovery : t -> bool = fun t -> t.recovering diff --git a/lib/qparser/lexbuf.mli b/lib/qparser/lexbuf.mli index f9812a7..4283db1 100644 --- a/lib/qparser/lexbuf.mli +++ b/lib/qparser/lexbuf.mli @@ -7,7 +7,7 @@ val from_lexbuf : ?reset_line:bool -> Sedlexing.lexbuf -> t (** Create a new buffer *) val start : t -> unit -(** Intialize a new run *) +(** Intialize a new run. *) val buffer : t -> Sedlexing.lexbuf (** Extract the sedlex buffer. Required in each rule. *) @@ -82,3 +82,10 @@ val leave_state : t -> unit (** Leave the current state *) val overlay : t -> lexer -> lexer + +val start_recovery : t -> unit +(** Set the lexer in recovery mode, the lexer raise this mode after an error, + in order to ignore the further errors until a new location *) + +val is_recovery : t -> bool +(** Check if the lexer is in recovery mode *) diff --git a/lib/qparser/lexer.ml b/lib/qparser/lexer.ml index 5c093b1..e3524cc 100644 --- a/lib/qparser/lexer.ml +++ b/lib/qparser/lexer.ml @@ -277,6 +277,7 @@ let main buffer = parser buffer let rec discard buffer = + let () = Lexbuf.start_recovery buffer in let lexbuf = Lexbuf.buffer buffer in match%sedlex lexbuf with @@ -291,8 +292,5 @@ let rec discard buffer = (for example a missing quote). *) leave_expression buffer; () - | '!' -> - ignore @@ skip_comment buffer; - discard buffer | any -> discard buffer | _ -> raise EOF diff --git a/lib/syntax/S.ml b/lib/syntax/S.ml index e691b38..b467863 100644 --- a/lib/syntax/S.ml +++ b/lib/syntax/S.ml @@ -114,6 +114,12 @@ module type Analyzer = sig (** Is the test active or not *) val is_global : bool + (** Declare the checker as global. It requires to run over the whole file and + will be disabled if the application only check a single location. + + Also, the test will be disabled if a syntax error is reported during the + parsing, because this tell that I haven’t been able to analyse the whole + source code. *) type context (** Context used to keep information during the whole test *) diff --git a/test/location.ml b/test/location.ml new file mode 100644 index 0000000..5072164 --- /dev/null +++ b/test/location.ml @@ -0,0 +1,28 @@ +module Check = Make_checkTest.M (Qsp_syntax.Locations) + +let _position = (Lexing.dummy_pos, Lexing.dummy_pos) + +let error_message = + [ + ( "Location", + Check. + { + level = Error; + loc = _position; + message = "The location unknown_place does not exists"; + } ); + ] + +let ok () = Check.global_check "gt 'location'" [] +let ok_upper () = Check.global_check "gt 'LOCATION'" [] +let missing_gt () = Check.global_check "gt 'unknown_place'" error_message +let missing_gs () = Check.global_check "gs 'unknown_place'" error_message + +let test = + ( "Locations", + [ + Alcotest.test_case "Ok" `Quick ok; + Alcotest.test_case "Ok upper" `Quick ok_upper; + Alcotest.test_case "Missing GT" `Quick missing_gt; + Alcotest.test_case "Missing GS" `Quick missing_gs; + ] ) diff --git a/test/make_checkTest.ml b/test/make_checkTest.ml index d428b45..d3ad358 100644 --- a/test/make_checkTest.ml +++ b/test/make_checkTest.ml @@ -15,27 +15,32 @@ module M (Check : Qsp_syntax.S.Analyzer) = struct } [@@deriving show, eq] - let report : Qsp_syntax.Report.t list Alcotest.testable = + let report : t list Alcotest.testable = Alcotest.list @@ Alcotest.testable Qsp_syntax.Report.pp equal + let report_global : (string * t) list Alcotest.testable = + Alcotest.list + @@ Alcotest.pair Alcotest.string + (Alcotest.testable Qsp_syntax.Report.pp equal) + let parse : + ?context:Check.context -> string -> - (Check.Location.t * Qsp_syntax.Report.t list, Qsp_syntax.Report.t) result - = - fun content -> + (Check.Location.t Qparser.Analyzer.result, t) result = + fun ?context content -> let lexing = Sedlexing.Latin1.from_string content |> Qparser.Lexbuf.from_lexbuf in - let context = Check.initialize () in + let context = Option.value context ~default:(Check.initialize ()) in Qparser.Analyzer.parse (module Check) lexing context let get_report : - (Check.Location.t * Qsp_syntax.Report.t list, Qsp_syntax.Report.t) result -> + (Check.Location.t Qparser.Analyzer.result, Qsp_syntax.Report.t) result -> Qsp_syntax.Report.t list = function - | Ok (_, report) -> report + | Ok v -> v.report | Error _ -> failwith "Error" - let _test_instruction : string -> Qsp_syntax.Report.t list -> unit = + let _test_instruction : string -> t list -> unit = fun literal expected -> let _location = Printf.sprintf {|# Location %s @@ -43,4 +48,22 @@ module M (Check : Qsp_syntax.S.Analyzer) = struct let actual = get_report @@ parse _location and msg = literal in Alcotest.(check' report ~msg ~expected ~actual) + + (** Run a test over the whole file. + The parsing of the content shall not report any error. + *) + let global_check : string -> (string * t) list -> unit = + fun literal expected -> + let _location = Printf.sprintf {|# Location +%s +------- |} literal in + let context = Check.initialize () in + let actual = get_report @@ parse ~context _location in + let () = + Alcotest.( + check' report ~msg:"Error reported during parsing" ~expected:[] ~actual) + in + let msg = literal in + let actual = Check.finalize context in + Alcotest.(check' report_global ~msg ~expected ~actual) end diff --git a/test/qsp_parser_test.ml b/test/qsp_parser_test.ml index a86df13..609da3f 100644 --- a/test/qsp_parser_test.ml +++ b/test/qsp_parser_test.ml @@ -7,4 +7,5 @@ let () = Type_of.test; Dead_end.test; Nested_string.test; + Location.test; ] diff --git a/test/syntax.ml b/test/syntax.ml index 87fe2ab..aa3eecb 100644 --- a/test/syntax.ml +++ b/test/syntax.ml @@ -29,10 +29,11 @@ let parse : string -> (S.pos location, Qsp_syntax.Report.t) result = in let context = Parser.initialize () in Qparser.Analyzer.parse (module Parser) lexing context - |> Result.map (fun (location, _report) -> + |> Result.map (fun v -> (* Uncatched excteptions here, but we are in the tests… If it’s fail here I have an error in the code. *) - Array.get location 0 |> Check.get location_id |> Option.get) + Array.get v.Qparser.Analyzer.content 0 + |> Check.get location_id |> Option.get) let location : S.pos location Alcotest.testable = let equal = equal_location (fun _ _ -> true) in -- cgit v1.2.3