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

---
 lib/qparser/analyzer.ml | 80 +++++++++++++++++++++++++++++++------------------
 1 file changed, 51 insertions(+), 29 deletions(-)

(limited to 'lib/qparser/analyzer.ml')

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
-- 
cgit v1.2.3