Ignore the global checkers if there is a syntax error; ignore error during recovery after a syntax error

11 files changed, 168 insertions, 60 deletions

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
+            <ERROR HERE>
 
-                 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