Move to Trace.error instead of simple_error.

src/passes/1-parser/reasonligo.ml

@@ -5,6 +5,73 @@ module AST = Parser_cameligo.AST
 module ParserLog = Parser_cameligo.ParserLog
 module LexToken = Parser_reasonligo.LexToken
 module Lexer = Lexer.Make(LexToken)
+module SyntaxError = Parser_reasonligo.SyntaxError
+
+module Errors = struct
+
+  let wrong_function_arguments expr =
+    let title () = "wrong function arguments" in
+    let message () = "" in
+    let expression_loc = AST.expr_to_region expr in
+    let data = [
+      ("expression_loc",
+       fun () -> Format.asprintf "%a" Location.pp_lift @@ expression_loc)
+    ] 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 
+      | SyntaxError.Error (WrongFunctionArguments e) -> 
+        fail @@ (wrong_function_arguments e)
+      | Parser.Error ->
+        let start = Lexing.lexeme_start_p lexbuf in
+        let end_ = Lexing.lexeme_end_p lexbuf in
+        fail @@ (parser_error start end_)
+      | _ ->
+        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 =
@@ -20,104 +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 ; _} =
+  parse (Parser.contract) lexbuf
-    Lexer.open_token_stream None in
-  specific_try (function      
-      | SyntaxError.Error WrongFunctionArguments -> 
-          let start = Lexing.lexeme_start_p lexbuf in
-          let end_ = Lexing.lexeme_end_p lexbuf in
-          let str = Format.sprintf
-              "Incorrect function arguments 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
-      | 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
 
 let parse_string (s:string) : AST.t result =
   let lexbuf = Lexing.from_string s in
-  let Lexer.{read ; close ; _} =
+  parse (Parser.contract) lexbuf
-    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
 
 let parse_expression (s:string) : AST.expr result =
-  let lexbuf = Lexing.from_string s in
+  let lexbuf = Lexing.from_string s in  
-  let Lexer.{read ; close; _} =
+  parse (Parser.interactive_expr) lexbuf
-    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

src/passes/1-parser/reasonligo/Parser.mly

@@ -424,7 +424,7 @@ fun_expr:
           {p.value with inside = arg_to_pattern p.value.inside}
         in PPar {p with value}
     | EUnit u -> PUnit u
-    | _ -> raise (SyntaxError.Error WrongFunctionArguments)
+    | e -> raise (SyntaxError.Error (WrongFunctionArguments e))
     in
     let fun_args_to_pattern = function
       EAnnot {
@@ -453,7 +453,7 @@ fun_expr:
           in arg_to_pattern (fst fun_args), bindings
       | EUnit e ->
           arg_to_pattern (EUnit e), []
-      | _ -> raise (SyntaxError.Error WrongFunctionArguments)
+      | e -> raise (SyntaxError.Error (WrongFunctionArguments e))
     in
     let binders = fun_args_to_pattern $1 in
     let f = {kwd_fun;

src/passes/1-parser/reasonligo/SyntaxError.ml

@@ -1,4 +1,4 @@
 type error = 
-  | WrongFunctionArguments
+  | WrongFunctionArguments of AST.expr
 
 exception Error of error

src/passes/1-parser/reasonligo/SyntaxError.mli

@@ -1,4 +1,4 @@
 type error = 
-  | WrongFunctionArguments
+  | WrongFunctionArguments of AST.expr
 
 exception Error of error

src/passes/1-parser/reasonligo/dune

@@ -8,7 +8,7 @@
 (library
  (name parser_reasonligo)
  (public_name ligo.parser.reasonligo)
- (modules reasonligo LexToken Parser)
+ (modules SyntaxError reasonligo LexToken Parser)
  (libraries
    menhirLib
    parser_shared

src/passes/1-parser/reasonligo/reasonligo.ml

@@ -3,3 +3,4 @@ module AST = Parser_cameligo.AST
 module Lexer = Lexer
 module LexToken = LexToken
 module ParserLog = Parser_cameligo.ParserLog
+module SyntaxError = SyntaxError

src/passes/1-parser/shared/dune

@@ -15,8 +15,8 @@
     Markup
     FQueue
     EvalOpt
-    Version
+    Version  
-    SyntaxError))
+    ))
 
 
 (rule