From 86fd78a5ab65015a9c18ad601856f1b16ed90fa9 Mon Sep 17 00:00:00 2001
From: Chimrod <>
Date: Fri, 19 Jan 2024 11:55:15 +0100
Subject: Wait to get a valid syntax before considering a new location

---
 lib/qparser/lexer.ml   | 12 ++++++++----
 lib/qparser/parser.mly |  9 ++++++++-
 lib/qparser/tokens.mly |  2 +-
 test/make_checkTest.ml |  2 --
 test/syntax_error.ml   | 29 ++++++++++++++++++++++++++---
 5 files changed, 43 insertions(+), 11 deletions(-)

diff --git a/lib/qparser/lexer.ml b/lib/qparser/lexer.ml
index 30d151b..4e9aa27 100644
--- a/lib/qparser/lexer.ml
+++ b/lib/qparser/lexer.ml
@@ -188,16 +188,20 @@ let rec parse_token : Lexbuf.t -> token =
   | '#', Star space, location ->
       (* Extract the location name *)
       let ident = Lexbuf.content buffer in
-      let () =
+      let ident_name =
         match Str.string_match location_name ident 0 with
-        | false -> ()
-        | true -> Sedlexing.set_filename lexbuf (Str.matched_group 1 ident)
+        | false -> ident
+        | true -> Str.matched_group 1 ident
       in
 
       (* Restart the line number (new location here) *)
       Lexbuf.start buffer;
 
-      LOCATION_START ident
+      LOCATION_START
+        (fun () ->
+          Sedlexing.set_filename lexbuf ident_name;
+          (* Restart the line number (new location here) *)
+          ident_name)
   | '_', Star space, eol, Star space ->
       (* The _ character can be used to break lines *)
       parse_token buffer
diff --git a/lib/qparser/parser.mly b/lib/qparser/parser.mly
index 73d77b7..6fc9b8f 100644
--- a/lib/qparser/parser.mly
+++ b/lib/qparser/parser.mly
@@ -25,7 +25,7 @@
 
 main: 
     | before_location*
-      LOCATION_START
+      start_location
       EOL+
       instructions = line_statement*
       LOCATION_END
@@ -38,6 +38,13 @@ before_location:
     | EOL {}
     | COMMENT EOL { }
 
+(* Defer the registration here, and ensure we get a valid rule. *)
+start_location:
+    | l = LOCATION_START
+  {
+      ignore (l ())
+  }
+
 (* All these statement should terminate with EOL *)
 line_statement:
     | COMMENT EOL+ { Analyzer.Instruction.comment $loc }
diff --git a/lib/qparser/tokens.mly b/lib/qparser/tokens.mly
index ddbc4cf..90e9e14 100644
--- a/lib/qparser/tokens.mly
+++ b/lib/qparser/tokens.mly
@@ -1,4 +1,4 @@
-%token <string>LOCATION_START
+%token <unit -> string>LOCATION_START
 %token LOCATION_END
 
 %token PLUS
diff --git a/test/make_checkTest.ml b/test/make_checkTest.ml
index 308d309..2066c22 100644
--- a/test/make_checkTest.ml
+++ b/test/make_checkTest.ml
@@ -1,5 +1,3 @@
-let _position = (Lexing.dummy_pos, Lexing.dummy_pos)
-
 (** Build a parser for a specific check module *)
 module M (Check : Qsp_syntax.S.Analyzer) = struct
   module S = Qsp_syntax.S
diff --git a/test/syntax_error.ml b/test/syntax_error.ml
index e8d29a2..04b91ad 100644
--- a/test/syntax_error.ml
+++ b/test/syntax_error.ml
@@ -17,14 +17,16 @@ let get_report :
   | Ok _ -> failwith "No error"
   | Error { level; loc; message } -> { level; loc; message }
 
-let _test_instruction : string -> S.pos report -> unit =
- fun literal expected ->
+let _test_instruction :
+    ?k:(S.pos report -> unit) -> string -> S.pos report -> unit =
+ fun ?k literal expected ->
   let _location = Printf.sprintf {|# Location
 %s
 ------- |} literal in
   let actual = get_report @@ Syntax.parse _location and msg = literal in
 
-  Alcotest.(check' report ~msg ~expected ~actual)
+  let () = Alcotest.(check' report ~msg ~expected ~actual) in
+  match k with None -> () | Some f -> f actual
 
 let else_column () =
   _test_instruction
@@ -186,6 +188,26 @@ let missing_comparable () =
   _test_instruction "1 <= or 0" result;
   _test_instruction "1 = or 0" result
 
+(** This code looks like a new location, but is actualy invalid. 
+    The application should report the old location.
+ *)
+let location_change () =
+  let result =
+    {
+      level = Error;
+      loc = _position;
+      message = "Missing boolean after operator";
+    }
+  in
+  _test_instruction "1 and >= # invalid" result ~k:(fun actual ->
+      let actual = (fst actual.loc).Lexing.pos_fname in
+
+      Alcotest.(
+        check' ~msg:"The location name is not valid" string ~actual
+          ~expected:"Location"))
+
+(* The location name *)
+
 let test =
   ( "Syntax Errors",
     [
@@ -202,4 +224,5 @@ let test =
       Alcotest.test_case "Unclosed block" `Quick unclosed_block;
       Alcotest.test_case "Unclosed block" `Quick comment_as_operator;
       Alcotest.test_case "Missing comparable" `Quick missing_comparable;
+      Alcotest.test_case "Location change" `Quick location_change;
     ] )
-- 
cgit v1.2.3