Move to Trace.error instead of simple_error.

2019-12-19 13:50:57 +00:00 · 2019-12-19 13:50:57 +00:00 · 7ea6aadc2c
commit 7ea6aadc2c
parent 32c5fcd6b4 600ae2d4f6
7 changed files with 79 additions and 103 deletions
--- a/src/passes/1-parser/reasonligo.ml
+++ b/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 ; _} =
-    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
+  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
+  parse (Parser.interactive_expr) lexbuf
--- a/src/passes/1-parser/reasonligo/Parser.mly
+++ b/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;
--- a/src/passes/1-parser/reasonligo/SyntaxError.ml
+++ b/src/passes/1-parser/reasonligo/SyntaxError.ml
@ -1,4 +1,4 @@
 type error = 
-  | WrongFunctionArguments
+  | WrongFunctionArguments of AST.expr

 exception Error of error
--- a/src/passes/1-parser/reasonligo/SyntaxError.mli
+++ b/src/passes/1-parser/reasonligo/SyntaxError.mli
@ -1,4 +1,4 @@
 type error = 
-  | WrongFunctionArguments
+  | WrongFunctionArguments of AST.expr

 exception Error of error
--- a/src/passes/1-parser/reasonligo/dune
+++ b/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
--- a/src/passes/1-parser/reasonligo/reasonligo.ml
+++ b/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
--- a/src/passes/1-parser/shared/dune
+++ b/src/passes/1-parser/shared/dune
@ -16,7 +16,7 @@
    FQueue
    EvalOpt
    Version  
-    SyntaxError))
+    ))


 (rule