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