Moved qparser and syntax in the library folder

1 files changed, 67 insertions, 0 deletions

diff --git a/lib/qparser/interpreter.ml b/lib/qparser/interpreter.ml
new file mode 100644
index 0000000..b719600
--- /dev/null
+++ b/lib/qparser/interpreter.ml
@@ -0,0 +1,67 @@
+(** 
+    This module provide a way to build the syntax parser with the menhir
+    incremental engine. This feature allow to see the state of the parser, and
+    get detailed error message but is not intended to be used directly. 
+
+    Refer to the menhir manual in order to see the values.
+
+    The interresting function here is [of_lexbuf] which return the error code in
+    case of invalid syntax.
+ *)
+
+type error_code = UnrecoverableError | InvalidSyntax | MenhirCode of int
+
+module Interpreter (MI : MenhirLib.IncrementalEngine.INCREMENTAL_ENGINE) =
+struct
+  type error = {
+    code : error_code;
+    start_pos : Lexing.position;
+    end_pos : Lexing.position;
+  }
+
+  module E = MenhirLib.ErrorReports
+  module L = MenhirLib.LexerUtil
+
+  type step = MI.token * Lexing.position * Lexing.position
+
+  let range_message (start_pos, end_pos) : error_code -> error =
+   fun code -> { code; start_pos; end_pos }
+
+  let get_parse_error : Lexbuf.t -> 'a MI.env -> error =
+   fun buffer env ->
+    match MI.stack env with
+    | (lazy Nil) ->
+        (* The parser is in its initial state. We should not get an
+           error here *)
+        let positions = Lexbuf.positions buffer in
+
+        range_message positions UnrecoverableError
+    | (lazy (Cons (MI.Element (state, _, start_pos, end_pos), _))) ->
+        range_message (start_pos, end_pos) (MenhirCode (MI.number state))
+
+  let rec _parse :
+      Lexbuf.t -> (unit -> step) -> 'a MI.checkpoint -> ('a, error) Result.t =
+   fun buffer get_token (checkpoint : 'a MI.checkpoint) ->
+    match checkpoint with
+    | MI.InputNeeded _env ->
+        let token, startp, endp = get_token () in
+        let checkpoint = MI.offer checkpoint (token, startp, endp) in
+        _parse buffer get_token checkpoint
+    | MI.Shifting _ | MI.AboutToReduce _ ->
+        let checkpoint = MI.resume checkpoint in
+        _parse buffer get_token checkpoint
+    | MI.HandlingError _env ->
+        let err = get_parse_error buffer _env in
+        Error err
+    | MI.Accepted v -> Ok v
+    | MI.Rejected ->
+        let positions = Lexbuf.positions buffer in
+        let err = range_message positions InvalidSyntax in
+        Error err
+
+  type 'a builder = Lexing.position -> 'a MI.checkpoint
+
+  let of_lexbuf :
+      (unit -> step) -> Lexbuf.t -> 'a MI.checkpoint -> ('a, error) result =
+   fun lexer buffer init -> _parse buffer lexer init
+end