diff --git a/src/passes/1-parser/cameligo.ml b/src/passes/1-parser/cameligo.ml index ed0830312..8a4eb33f9 100644 --- a/src/passes/1-parser/cameligo.ml +++ b/src/passes/1-parser/cameligo.ml @@ -6,107 +6,93 @@ module ParserLog = Parser_cameligo.ParserLog module LexToken = Parser_cameligo.LexToken module Lexer = Lexer.Make(LexToken) +module Errors = struct + + let lexer_error (e: Lexer.error AST.reg) = + let title () = "lexer error" in + let message () = Lexer.error_to_string e.value in + let data = [ + ("parser_loc", + fun () -> Format.asprintf "%a" Location.pp_lift @@ e.region + ) + ] in + error ~data title message + + let parser_error start end_ = + let title () = "parser error" in + let message () = "" in + let loc = Region.make + ~start:(Pos.from_byte start) + ~stop:(Pos.from_byte end_) + in + let data = [ + ("parser_loc", + fun () -> Format.asprintf "%a" Location.pp_lift @@ loc + ) + ] in + error ~data title message + + let unrecognized_error start end_ = + let title () = "unrecognized error" in + let message () = "" in + let loc = Region.make + ~start:(Pos.from_byte start) + ~stop:(Pos.from_byte end_) + in + let data = [ + ("unrecognized_loc", + fun () -> Format.asprintf "%a" Location.pp_lift @@ loc + ) + ] in + error ~data title message + +end + +open Errors + +type 'a parser = (Lexing.lexbuf -> LexToken.token) -> Lexing.lexbuf -> 'a + +let parse (parser: 'a parser) lexbuf = + let Lexer.{read ; close ; _} = Lexer.open_token_stream None in + let result = + try + ok (parser read lexbuf) + with + | Parser.Error -> + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + fail @@ (parser_error start end_) + | Lexer.Error e -> + fail @@ (lexer_error e) + | _ -> + let _ = Printexc.print_backtrace Pervasives.stdout in + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + fail @@ (unrecognized_error start end_) + in + close (); + result + let parse_file (source: string) : AST.t result = let pp_input = - let prefix = Filename.(source |> basename |> remove_extension) - and suffix = ".pp.mligo" - in prefix ^ suffix in + let prefix = Filename.(source |> basename |> remove_extension) + and suffix = ".pp.mligo" + in prefix ^ suffix in let cpp_cmd = Printf.sprintf "cpp -traditional-cpp %s > %s" - source pp_input in - let%bind () = sys_command cpp_cmd in + source pp_input in + let%bind () = sys_command cpp_cmd in let%bind channel = generic_try (simple_error "error opening file") @@ (fun () -> open_in pp_input) in let lexbuf = Lexing.from_channel channel in - let Lexer.{read ; close ; _} = - Lexer.open_token_stream None in - specific_try (function - | Parser.Error -> ( - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Parse error at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n" - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) - start.pos_fname source - in - simple_error str - ) - | exn -> - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Unrecognized error (%s) at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n" - (Printexc.to_string exn) - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) - start.pos_fname source - in - simple_error str - ) @@ (fun () -> - let raw = Parser.contract read lexbuf in - close () ; - raw - ) >>? fun raw -> - ok raw + parse (Parser.contract) lexbuf let parse_string (s:string) : AST.t result = let lexbuf = Lexing.from_string s in - let Lexer.{read ; close ; _} = - Lexer.open_token_stream None in - specific_try (function - | Parser.Error -> ( - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n" - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in - simple_error str - ) - | _ -> simple_error "unrecognized parse_ error" - ) @@ (fun () -> - let raw = Parser.contract read lexbuf in - close () ; - raw - ) >>? fun raw -> - ok raw + parse (Parser.contract) lexbuf let parse_expression (s:string) : AST.expr result = - let lexbuf = Lexing.from_string s in - let Lexer.{read ; close; _} = - Lexer.open_token_stream None in - specific_try (function - | Parser.Error -> ( - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n" - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in - simple_error str - ) - | exn -> - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Unrecognized error (%s) at \"%s\" from (%d, %d) to (%d, %d). In expression \"%s|%s\"\n" - (Printexc.to_string exn) - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) - start.pos_fname s - in - simple_error str - ) @@ (fun () -> - let raw = Parser.interactive_expr read lexbuf in - close () ; - raw - ) >>? fun raw -> - ok raw + let lexbuf = Lexing.from_string s in + parse (Parser.interactive_expr) lexbuf \ No newline at end of file diff --git a/src/passes/1-parser/pascaligo.ml b/src/passes/1-parser/pascaligo.ml index 62d56ab8b..05c0af4df 100644 --- a/src/passes/1-parser/pascaligo.ml +++ b/src/passes/1-parser/pascaligo.ml @@ -6,6 +6,73 @@ module ParserLog = Parser_pascaligo.ParserLog module LexToken = Parser_pascaligo.LexToken module Lexer = Lexer.Make(LexToken) +module Errors = struct + + let lexer_error (e: Lexer.error AST.reg) = + let title () = "lexer error" in + let message () = Lexer.error_to_string e.value in + let data = [ + ("parser_loc", + fun () -> Format.asprintf "%a" Location.pp_lift @@ e.region + ) + ] in + error ~data title message + + let parser_error start end_ = + let title () = "parser error" in + let message () = "" in + let loc = Region.make + ~start:(Pos.from_byte start) + ~stop:(Pos.from_byte end_) + in + let data = [ + ("parser_loc", + fun () -> Format.asprintf "%a" Location.pp_lift @@ loc + ) + ] in + error ~data title message + + let unrecognized_error start end_ = + let title () = "unrecognized error" in + let message () = "" in + let loc = Region.make + ~start:(Pos.from_byte start) + ~stop:(Pos.from_byte end_) + in + let data = [ + ("unrecognized_loc", + fun () -> Format.asprintf "%a" Location.pp_lift @@ loc + ) + ] in + error ~data title message + +end + +open Errors + +type 'a parser = (Lexing.lexbuf -> LexToken.token) -> Lexing.lexbuf -> 'a + +let parse (parser: 'a parser) lexbuf = + let Lexer.{read ; close ; _} = Lexer.open_token_stream None in + let result = + try + ok (parser read lexbuf) + with + | Parser.Error -> + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + fail @@ (parser_error start end_) + | Lexer.Error e -> + fail @@ (lexer_error e) + | _ -> + let _ = Printexc.print_backtrace Pervasives.stdout in + let start = Lexing.lexeme_start_p lexbuf in + let end_ = Lexing.lexeme_end_p lexbuf in + fail @@ (unrecognized_error start end_) + in + close (); + result + let parse_file (source: string) : AST.t result = let pp_input = let prefix = Filename.(source |> basename |> remove_extension) @@ -20,93 +87,12 @@ let parse_file (source: string) : AST.t result = generic_try (simple_error "error opening file") @@ (fun () -> open_in pp_input) in let lexbuf = Lexing.from_channel channel in - let Lexer.{read ; close ; _} = - Lexer.open_token_stream None in - specific_try (function - | Parser.Error -> ( - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Parse error at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n" - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) - start.pos_fname source - in - simple_error str - ) - | exn -> - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Unrecognized error (%s) at \"%s\" from (%d, %d) to (%d, %d). In file \"%s|%s\"\n" - (Printexc.to_string exn) - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) - start.pos_fname source - in - simple_error str - ) @@ (fun () -> - let raw = Parser.contract read lexbuf in - close () ; - raw - ) >>? fun raw -> - ok raw + parse (Parser.contract) lexbuf let parse_string (s:string) : AST.t result = let lexbuf = Lexing.from_string s in - let Lexer.{read ; close ; _} = - Lexer.open_token_stream None in - specific_try (function - | Parser.Error -> ( - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n" - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in - simple_error str - ) - | _ -> simple_error "unrecognized parse_ error" - ) @@ (fun () -> - let raw = Parser.contract read lexbuf in - close () ; - raw - ) >>? fun raw -> - ok raw + parse (Parser.contract) lexbuf let parse_expression (s:string) : AST.expr result = - let lexbuf = Lexing.from_string s in - let Lexer.{read ; close; _} = - Lexer.open_token_stream None in - specific_try (function - | Parser.Error -> ( - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Parse error at \"%s\" from (%d, %d) to (%d, %d)\n" - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) in - simple_error str - ) - | exn -> - let start = Lexing.lexeme_start_p lexbuf in - let end_ = Lexing.lexeme_end_p lexbuf in - let str = Format.sprintf - "Unrecognized error (%s) at \"%s\" from (%d, %d) to (%d, %d). In expression \"%s|%s\"\n" - (Printexc.to_string exn) - (Lexing.lexeme lexbuf) - start.pos_lnum (start.pos_cnum - start.pos_bol) - end_.pos_lnum (end_.pos_cnum - end_.pos_bol) - start.pos_fname s - in - simple_error str - ) @@ (fun () -> - let raw = Parser.interactive_expr read lexbuf in - close () ; - raw - ) >>? fun raw -> - ok raw + let lexbuf = Lexing.from_string s in + parse (Parser.interactive_expr) lexbuf