(* Generic parser for LIGO *) (* 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. *) type message = string type valid = Lexer.token type invalid = Lexer.token type error = message * valid option * invalid exception Point of error 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)) (* The two Menhir APIs are called from the following two functions. *) 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 (* Errors *) let format_error ?(offsets=true) mode (msg, valid_opt, invalid) = let invalid_region = LexToken.to_region invalid in let header = "Parse error " ^ invalid_region#to_string ~offsets mode in let trailer = match valid_opt with None -> if LexToken.is_eof invalid then "" else let invalid_lexeme = LexToken.to_lexeme invalid in Printf.sprintf ", before \"%s\"" invalid_lexeme | Some valid -> let valid_lexeme = LexToken.to_lexeme valid in let s = Printf.sprintf ", after \"%s\"" valid_lexeme in if LexToken.is_eof invalid then s else let invalid_lexeme = LexToken.to_lexeme invalid in Printf.sprintf "%s and before \"%s\"" s invalid_lexeme in let header = header ^ trailer in header ^ (if msg = "" then ".\n" else ":\n" ^ msg) end