2019-12-26 18:57:02 +01:00
|
|
|
(* Generic parser for LIGO *)
|
2019-12-26 18:17:57 +01:00
|
|
|
|
|
|
|
(* Main functor *)
|
|
|
|
|
|
|
|
module Make (Lexer: Lexer.S with module Token := LexToken)
|
|
|
|
(Parser: module type of Parser)
|
|
|
|
(ParErr: sig val message : int -> string end) =
|
|
|
|
struct
|
|
|
|
module I = Parser.MenhirInterpreter
|
|
|
|
module S = MenhirLib.General (* Streams *)
|
|
|
|
|
|
|
|
(* The call [stack checkpoint] extracts the parser's stack out of
|
|
|
|
a checkpoint. *)
|
|
|
|
|
|
|
|
let stack = function
|
|
|
|
I.HandlingError env -> I.stack env
|
|
|
|
| _ -> assert false
|
|
|
|
|
|
|
|
(* The call [state checkpoint] extracts the number of the current
|
|
|
|
state out of a parser checkpoint. *)
|
|
|
|
|
|
|
|
let state checkpoint : int =
|
|
|
|
match Lazy.force (stack checkpoint) with
|
|
|
|
S.Nil -> 0 (* WARNING: Hack. The first state should be 0. *)
|
|
|
|
| S.Cons (I.Element (s,_,_,_),_) -> I.number s
|
|
|
|
|
|
|
|
(* The parser has successfully produced a semantic value. *)
|
|
|
|
|
|
|
|
let success v = v
|
|
|
|
|
|
|
|
(* The parser has suspended itself because of a syntax error. Stop. *)
|
|
|
|
|
2019-12-26 18:57:02 +01:00
|
|
|
type message = string
|
|
|
|
type valid = Lexer.token
|
|
|
|
type invalid = Lexer.token
|
|
|
|
type error = message * valid option * invalid
|
|
|
|
|
|
|
|
exception Point of error
|
|
|
|
|
2019-12-26 18:17:57 +01:00
|
|
|
let failure get_win checkpoint =
|
|
|
|
let message = ParErr.message (state checkpoint) in
|
|
|
|
match get_win () with
|
|
|
|
Lexer.Nil -> assert false
|
|
|
|
| Lexer.One invalid ->
|
|
|
|
raise (Point (message, None, invalid))
|
|
|
|
| Lexer.Two (invalid, valid) ->
|
|
|
|
raise (Point (message, Some valid, invalid))
|
|
|
|
|
2019-12-26 18:57:02 +01:00
|
|
|
(* The two Menhir APIs are called from the following two functions. *)
|
2019-12-26 18:17:57 +01:00
|
|
|
|
|
|
|
let incr_contract Lexer.{read; buffer; get_win; close; _} : AST.t =
|
|
|
|
let supplier = I.lexer_lexbuf_to_supplier read buffer
|
|
|
|
and failure = failure get_win in
|
|
|
|
let parser = Parser.Incremental.contract buffer.Lexing.lex_curr_p in
|
|
|
|
let ast = I.loop_handle success failure supplier parser
|
|
|
|
in close (); ast
|
|
|
|
|
|
|
|
let mono_contract = Parser.contract
|
2019-12-26 18:57:02 +01:00
|
|
|
|
|
|
|
(* Errors *)
|
|
|
|
|
|
|
|
let format_error ?(offsets=true) mode (message, valid_opt, invalid) =
|
|
|
|
let invalid_lexeme = LexToken.to_lexeme invalid in
|
|
|
|
let invalid_region = LexToken.to_region invalid in
|
|
|
|
let header =
|
|
|
|
"Parse error " ^
|
|
|
|
invalid_region#to_string ~offsets mode in
|
|
|
|
let after =
|
|
|
|
match valid_opt with
|
|
|
|
None -> ","
|
|
|
|
| Some valid ->
|
|
|
|
let valid_lexeme = LexToken.to_lexeme valid
|
|
|
|
in Printf.sprintf ", after \"%s\" and" valid_lexeme in
|
|
|
|
let header = header ^ after in
|
|
|
|
let before = Printf.sprintf " before \"%s\"" invalid_lexeme in
|
|
|
|
let header = header ^ before in
|
|
|
|
header ^ (if message = "" then ".\n" else ":\n" ^ message)
|
|
|
|
|
2019-12-26 18:17:57 +01:00
|
|
|
end
|