From 2e41a214e4c2a2984ad3b2afa3d80178d227927f Mon Sep 17 00:00:00 2001
From: Chimrod <>
Date: Fri, 29 Sep 2023 19:06:41 +0200
Subject: Added a global line counter (off by default)
---
bin/qsp_parser.ml | 26 +++++++++++++++++++-------
lib/analyzer.ml | 5 ++---
lib/analyzer.mli | 2 +-
lib/lexbuf.ml | 11 ++++++++---
lib/lexbuf.mli | 2 +-
test/qsp_parser_test.ml | 5 +++--
6 files changed, 34 insertions(+), 17 deletions(-)
diff --git a/bin/qsp_parser.ml b/bin/qsp_parser.ml
index ffb1bd5..fb0c1c8 100644
--- a/bin/qsp_parser.ml
+++ b/bin/qsp_parser.ml
@@ -9,6 +9,7 @@ module Args = struct
let usage = "qsp_parser input_file"
let anon_fun filename = input_files := filename :: !input_files
let level_value = ref None
+ let reset_line = ref false
let level : string -> unit =
fun str_level ->
@@ -19,12 +20,18 @@ module Args = struct
exit 1
let speclist =
- [ ("--level", Arg.String level, "Message level [debug, warn, error]") ]
+ [
+ ("--level", Arg.String level, "Message level [debug, warn, error]");
+ ( "--global",
+ Arg.Set reset_line,
+ "Each line is refered from the begining of the file and not the \
+ location" );
+ ]
let parse () =
let () = Arg.parse speclist anon_fun usage in
let filters = { level = !level_value } in
- (!input_files, filters)
+ (!input_files, !reset_line, filters)
end
(** Filter the results given by the analysis *)
@@ -41,7 +48,7 @@ let filter_report : filters -> Report.t list -> Report.t -> Report.t list =
(** Read the source file until getting a report (the whole location has been
read properly), or until the first syntax error.
*)
-let parse_location : Sedlexing.lexbuf -> filters -> unit =
+let parse_location : Qparser.Lexbuf.t -> filters -> unit =
fun lexbuf filters ->
let result = Qparser.Analyzer.parse (module Qsp_syntax.Type_of) lexbuf in
@@ -56,17 +63,17 @@ let parse_location : Sedlexing.lexbuf -> filters -> unit =
match report with
| [] -> ()
| _ ->
- let start_position, _ = Sedlexing.lexing_positions lexbuf in
+ let start_position, _ = Qparser.Lexbuf.positions lexbuf in
Format.fprintf Format.std_formatter "Location %s@;@[%a@]@."
start_position.Lexing.pos_fname pp_result report;
())
| Error e ->
- let start_position, _ = Sedlexing.lexing_positions lexbuf in
+ let start_position, _ = Qparser.Lexbuf.positions lexbuf in
Format.fprintf Format.std_formatter "Location %s@;@[%a]@."
start_position.Lexing.pos_fname Report.pp e
let () =
- let file_names, filters = Args.parse () in
+ let file_names, reset_line, filters = Args.parse () in
let file_name = List.hd file_names in
let ic = Stdlib.open_in_bin file_name in
@@ -78,6 +85,7 @@ let () =
| ".txt" -> Sedlexing.Utf16.from_channel ic (Some Little_endian)
| _ -> raise (Failure "unknown extension")
in
+ let lexer = Qparser.Lexbuf.from_lexbuf ~reset_line lexer in
let () =
try
@@ -87,6 +95,10 @@ let () =
with Qparser.Lexer.EOF -> ()
in
let () =
- match Sys.os_type with "Win32" -> ignore @@ read_line () | _ -> ()
+ match Sys.os_type with
+ | "Win32" ->
+ print_endline "Press <Enter> to terminate";
+ ignore @@ read_line ()
+ | _ -> ()
in
()
diff --git a/lib/analyzer.ml b/lib/analyzer.ml
index 547b3da..7a64cab 100644
--- a/lib/analyzer.ml
+++ b/lib/analyzer.ml
@@ -5,14 +5,13 @@
*)
let parse :
(module Qsp_syntax.S.Analyzer with type Location.repr = 'a) ->
- Sedlexing.lexbuf ->
+ Lexbuf.t ->
('a, Qsp_syntax.Report.t) Result.t =
fun (type a) (module S : Qsp_syntax.S.Analyzer with type Location.repr = a) ->
let module Parser = Parser.Make (S) in
let module IncrementalParser =
Interpreter.Interpreter (Parser.MenhirInterpreter) in
- fun lexbuf ->
- let l = Lexbuf.from_lexbuf lexbuf in
+ fun l ->
let lexer = Lexbuf.tokenize Lexer.token l in
let init = Parser.Incremental.main (fst (Lexbuf.positions l)) in
diff --git a/lib/analyzer.mli b/lib/analyzer.mli
index d79ea76..30b6625 100644
--- a/lib/analyzer.mli
+++ b/lib/analyzer.mli
@@ -1,6 +1,6 @@
val parse :
(module Qsp_syntax.S.Analyzer with type Location.repr = 'a) ->
- Sedlexing.lexbuf ->
+ Lexbuf.t ->
('a, Qsp_syntax.Report.t) Result.t
(** Read the source and build a analyzis over it.
diff --git a/lib/lexbuf.ml b/lib/lexbuf.ml
index 6059c8a..3f0b186 100644
--- a/lib/lexbuf.ml
+++ b/lib/lexbuf.ml
@@ -2,6 +2,7 @@ type t = {
buffer : Sedlexing.lexbuf;
mutable start_p : Lexing.position option;
mutable expression_level : int;
+ reset_line : bool;
}
let buffer : t -> Sedlexing.lexbuf = fun t -> t.buffer
@@ -9,7 +10,10 @@ let buffer : t -> Sedlexing.lexbuf = fun t -> t.buffer
let start : t -> unit =
fun t ->
let _start_pos, end_pos = Sedlexing.lexing_positions t.buffer in
- Sedlexing.set_position t.buffer { end_pos with Lexing.pos_lnum = 1 };
+ let () =
+ if not t.reset_line then
+ Sedlexing.set_position t.buffer { end_pos with Lexing.pos_lnum = 1 }
+ in
t.start_p <- None;
t.expression_level <- 0
@@ -18,8 +22,9 @@ let positions : t -> Lexing.position * Lexing.position =
let content : t -> string = fun t -> Sedlexing.Utf8.lexeme t.buffer
-let from_lexbuf : Sedlexing.lexbuf -> t =
- fun t -> { buffer = t; start_p = None; expression_level = 0 }
+let from_lexbuf : ?reset_line:bool -> Sedlexing.lexbuf -> t =
+ fun ?(reset_line = true) t ->
+ { buffer = t; start_p = None; expression_level = 0; reset_line }
let set_start_position : t -> Lexing.position -> unit =
fun t position -> t.start_p <- Some position
diff --git a/lib/lexbuf.mli b/lib/lexbuf.mli
index 918c011..41f07d1 100644
--- a/lib/lexbuf.mli
+++ b/lib/lexbuf.mli
@@ -1,6 +1,6 @@
type t
-val from_lexbuf : Sedlexing.lexbuf -> t
+val from_lexbuf : ?reset_line:bool -> Sedlexing.lexbuf -> t
(** Create a new buffer *)
val start : t -> unit
diff --git a/test/qsp_parser_test.ml b/test/qsp_parser_test.ml
index d827099..652ef75 100644
--- a/test/qsp_parser_test.ml
+++ b/test/qsp_parser_test.ml
@@ -10,8 +10,9 @@ type 'a location = 'a * 'a Ast.statement list [@@deriving eq, show]
(** Run the parser with the given expression and return the result *)
let parse : string -> T.pos location =
fun content ->
- let lexing = Sedlexing.Latin1.from_string content in
-
+ let lexing =
+ Sedlexing.Latin1.from_string content |> Qparser.Lexbuf.from_lexbuf
+ in
match Qparser.Analyzer.parse (module Qsp_syntax.Tree) lexing with
| Ok e -> e
| Error e ->
--
cgit v1.2.3