1 files changed, 70 insertions, 0 deletions
diff --git a/lib/interpreter.ml b/lib/interpreter.ml
new file mode 100644
index 0000000..b41d74e
--- /dev/null
+++ b/lib/interpreter.ml
@@ -0,0 +1,70 @@
+(** 
+    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_lexer] which return the error code in
+    case of invalid syntax.
+ *)
+
+type error_code = InvalidSyntax | MenhirCode of int
+
+type error = {
+  code : error_code;
+  start_pos : Lexing.position;
+  end_pos : Lexing.position;
+}
+
+module Interpreter (MI : MenhirLib.IncrementalEngine.INCREMENTAL_ENGINE) =
+struct
+  module E = MenhirLib.ErrorReports
+  module L = MenhirLib.LexerUtil
+
+  let range_message start_pos end_pos code = { code; start_pos; end_pos }
+
+  let get_parse_error default_position env : error =
+    match MI.stack env with
+    | (lazy Nil) ->
+        range_message default_position.Lexing.lex_start_p
+          default_position.Lexing.lex_curr_p InvalidSyntax
+    | (lazy (Cons (MI.Element (state, _, start_pos, end_pos), _))) ->
+        range_message start_pos end_pos (MenhirCode (MI.number state))
+
+  let rec _parse :
+      (Lexing.lexbuf -> MI.token) ->
+      Lexing.lexbuf ->
+      'a MI.checkpoint ->
+      ('a, error) Result.t =
+   fun get_token (lexbuf : Lexing.lexbuf) (checkpoint : 'a MI.checkpoint) ->
+    match checkpoint with
+    | MI.InputNeeded _env ->
+        let token = get_token lexbuf in
+        let startp = lexbuf.Lexing.lex_start_p and endp = lexbuf.lex_curr_p in
+        let checkpoint = MI.offer checkpoint (token, startp, endp) in
+        _parse get_token lexbuf checkpoint
+    | MI.Shifting _ | MI.AboutToReduce _ ->
+        let checkpoint = MI.resume checkpoint in
+        _parse get_token lexbuf checkpoint
+    | MI.HandlingError _env ->
+        let err = get_parse_error lexbuf _env in
+        Error err
+    | MI.Accepted v -> Ok v
+    | MI.Rejected ->
+        let err =
+          range_message lexbuf.lex_start_p lexbuf.lex_curr_p InvalidSyntax
+        in
+        Error err
+
+  type 'a builder = Lexing.position -> 'a MI.checkpoint
+
+  let of_lexbuf :
+      Lexing.lexbuf ->
+      (Lexing.lexbuf -> MI.token) ->
+      'a builder ->
+      ('a, error) result =
+   fun lexbuf lexer f ->
+    let init = f lexbuf.lex_curr_p in
+    _parse lexer lexbuf init
+end