(** 
    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 = 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 env : error =
    match MI.stack env with
    | (lazy Nil) ->
        (* The parser is in its initial state. We should not get an
           error here *)
        let positions = Sedlexing.lexing_positions lexbuf in
        range_message positions InvalidSyntax
    | (lazy (Cons (MI.Element (state, _, start_pos, end_pos), _))) ->
        range_message (start_pos, end_pos) (MenhirCode (MI.number state))

  let rec _parse :
      (Sedlexing.lexbuf -> unit -> step) ->
      Sedlexing.lexbuf ->
      'a MI.checkpoint ->
      ('a, error) Result.t =
   fun get_token (lexbuf : Sedlexing.lexbuf) (checkpoint : 'a MI.checkpoint) ->
    match checkpoint with
    | MI.InputNeeded _env ->
        let token, startp, endp = get_token lexbuf () 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 positions = Sedlexing.lexing_positions lexbuf in
        let err = range_message positions InvalidSyntax in
        Error err

  type 'a builder = Lexing.position -> 'a MI.checkpoint

  let of_lexbuf :
      Sedlexing.lexbuf ->
      (Sedlexing.lexbuf -> unit -> step) ->
      'a builder ->
      ('a, error) result =
   fun lexbuf lexer f ->
    let init = f (fst (Sedlexing.lexing_positions lexbuf)) in
    _parse lexer lexbuf init
end