Une MAJ de sécurité est nécessaire sur notre version actuelle. Elle sera effectuée lundi 02/08 entre 12h30 et 13h. L'interruption de service devrait durer quelques minutes (probablement moins de 5 minutes).

Commit 1951673d authored by POGODALLA Sylvain's avatar POGODALLA Sylvain
Browse files

Improve error management

parent f705c3af
......@@ -4,4 +4,4 @@ type err =
module E : UtilsLib.ErrorMg.E with type t = err
module Error : UtilsLib.ErrorMg.ERROR with type t = E.t UtilsLib.ErrorMg.error
module Error : UtilsLib.ErrorMg.ERROR with type synt_error = E.t
{
open Dl_parser
open UtilsLib
let loc lexbuf = Lexing.lexeme_start_p lexbuf,Lexing.lexeme_end_p lexbuf
}
......@@ -15,7 +14,7 @@ rule lexer = parse
| [' ' '\t'] {lexer lexbuf}
| newline {let () = Lexing.new_line lexbuf in lexer lexbuf}
| "(*" {comment [loc lexbuf] lexbuf}
| "*)" {raise (DlError.Error.Error (ErrorMg.LexError ErrorMg.Unstarted_comment,loc lexbuf))}
| "*)" {raise (DlError.Error.(Error (LexError Unstarted_comment,loc lexbuf)))}
| eof {EOI}
| "," {COMMA(loc lexbuf)}
| "." {DOT(loc lexbuf)}
......@@ -32,8 +31,8 @@ and comment depth = parse
| "*)" {match depth with
| [_] -> lexer lexbuf
| _::tl -> comment tl lexbuf
| [] -> raise (DlError.Error.Error (ErrorMg.LexError ErrorMg.Unstarted_comment,loc lexbuf))}
| [] -> raise (DlError.Error.(Error (LexError Unstarted_comment,loc lexbuf)))}
| "(*" {comment ((loc lexbuf)::depth) lexbuf}
| eof {raise (DlError.Error.Error (ErrorMg.LexError ErrorMg.Unclosed_comment, List.hd depth))}
| eof {raise (DlError.Error.(Error (LexError Unclosed_comment, List.hd depth)))}
| newline {let () = Lexing.new_line lexbuf in comment depth lexbuf}
| _ {comment depth lexbuf}
......@@ -15,7 +15,7 @@ let fail lexbuf c =
| I.HandlingError env ->
let loc = Lexing.lexeme_start_p lexbuf,Lexing.lexeme_end_p lexbuf in
let current_state_num = I.current_state_number env in
raise (DlError.Error.Error (ErrorMg.SyntError (DlError.ParseError (Messages.message current_state_num)),loc))
raise DlError.(Error.(Error (SyntError (ParseError (Messages.message current_state_num)),loc)))
| _ -> failwith "Should not happen. Always fails with a HandlingError"
let core_supplier lexbuf = I.lexer_lexbuf_to_supplier Dl_lexer.lexer lexbuf
......@@ -29,10 +29,10 @@ type entry =
| String of string
let generic_parse ~entry f =
let input =
let input,input_name =
match entry with
| File f -> f
| String _ -> "stdin" in
| File f -> Some f,f
| String q -> None,q in
try
let lexbuf,from_file =
match entry with
......@@ -42,7 +42,7 @@ let generic_parse ~entry f =
open_in fullname in
Lexing.from_channel in_ch,true
| String s -> Lexing.from_string s,false in
let () = if from_file then Logs.app (fun m -> m "Parsing \"%s\"..." input) else () in
let () = if from_file then Logs.app (fun m -> m "Parsing \"%s\"..." input_name) else () in
let starting_parse_time = Sys.time () in
let e = I.loop_handle succeed (fail lexbuf) (supplier lexbuf) (f lexbuf.Lexing.lex_curr_p) in
let ending_parse_time = Sys.time () in
......@@ -50,15 +50,20 @@ let generic_parse ~entry f =
Some e
with
| Utils.No_file(f,msg) ->
let e = ErrorMg.SysError (Printf.sprintf "No such file \"%s\" in %s" f msg) in
let e = DlError.Error.SysError (Printf.sprintf "No such file \"%s\" in %s" f msg) in
let () = Logs.err (fun m -> m "%s" (DlError.Error.error_msg (e,dummy_loc) ~filename:f)) in
None
| Sys_error s ->
let e = ErrorMg.SysError s in
let () = Logs.err (fun m -> m "%s" (DlError.Error.error_msg (e,dummy_loc) ~filename:input)) in
let e = DlError.Error.SysError s in
let () = Logs.err (fun m -> m "%s" (DlError.Error.error_msg (e,dummy_loc) ?filename:input)) in
None
| DlError.Error.Error e ->
let () = Logs.err (fun m -> m "%s" (DlError.Error.error_msg e ~filename:input)) in
| DlError.Error.Error e ->
let () =
match entry with
| File _ -> ()
| String s ->
Logs.err (fun m -> m "Error while parsing \"%s\"." s) in
let () = Logs.err (fun m -> m "%s" (DlError.Error.error_msg e ?filename:input)) in
None
let parse_program filename =
......
......@@ -8,7 +8,7 @@
match arity with
| Some a when a<>length ->
let () = Logs.info (fun m -> m "Found arity %d" a) in
raise DlError.(Error.Error (ErrorMg.SyntError (BadArity (pred_sym,a,length)),loc))
raise DlError.(Error.(Error (SyntError (BadArity (pred_sym,a,length)),loc)))
| _ -> ()
......
......@@ -18,44 +18,35 @@ module type E =
val to_string : t -> string
end
type bracket =
| Round
| Square
| Curly
let kind_to_char = function
| Round -> '('
| Square -> '['
| Curly -> '{'
type lex_error =
| Unstarted_comment
| Unstarted_bracket
| Mismatch_parentheses of bracket
| Unclosed_comment
| Expect of string
| Bad_token
module type ERROR =
sig
type bracket =
| Round
| Square
| Curly
type 'a error =
| SyntError of 'a
| LexError of lex_error
| SysError of string
type lex_error =
| Unstarted_comment
| Unstarted_bracket
| Mismatch_parentheses of bracket
| Unclosed_comment
| Expect of string
| Bad_token
module type ERROR =
sig
type synt_error
type error =
| SyntError of synt_error
| LexError of lex_error
| SysError of string
type t
(** The exception that should be raised when an error occur *)
exception Error of (t * location)
exception Error of (error * location)
(** [error_msg e ~filename] returns a string describing the error
[e] while the file [filename] is being processed *)
val error_msg : (t * location) -> filename:string -> string
val error_msg : ?filename:string -> (error * location) -> string
val empty_bracket_stack : (bracket * location) list
......@@ -74,6 +65,24 @@ module type ERROR =
module Make(E:E) =
struct
type bracket =
| Round
| Square
| Curly
let kind_to_char = function
| Round -> '('
| Square -> '['
| Curly -> '{'
type lex_error =
| Unstarted_comment
| Unstarted_bracket
| Mismatch_parentheses of bracket
| Unclosed_comment
| Expect of string
| Bad_token
let lex_error_to_string = function
| Unstarted_comment -> "Syntax error: No comment opened before this closing of comment"
| Unstarted_bracket -> "Syntax error: No bracket opened before this right bracket"
......@@ -82,10 +91,19 @@ module Make(E:E) =
| Expect s -> Printf.sprintf "Syntax error: %s expected" s
| Bad_token -> "Lexing error: no such token allowed"
type synt_error = E.t
type t = E.t error
exception Error of (t * location)
type error =
| SyntError of synt_error
| LexError of lex_error
| SysError of string
exception Error of (error * location)
let compute_comment_for_location (pos1,pos2) =
let line2 = pos2.Lexing.pos_lnum in
......@@ -99,15 +117,19 @@ module Make(E:E) =
Printf.sprintf "line %d, character %d to line %d, character %d" line1 col1 line2 col2
let error_msg (err,loc) ~filename =
let error_msg ?filename (err,loc) =
let input =
match filename with
| None -> ""
| Some f -> Printf.sprintf "File \"%s\"," f in
let msg =
match err with
| LexError e -> lex_error_to_string e
| SysError e -> e
| SyntError e -> E.to_string e in
Printf.sprintf
"File \"%s\", %s\n%s"
filename
"%s%s\n%s"
input
(compute_comment_for_location loc)
msg
......
......@@ -10,35 +10,36 @@ module type E =
val to_string : t -> string
end
type bracket =
| Round
| Square
| Curly
type lex_error =
| Unstarted_comment
| Unstarted_bracket
| Mismatch_parentheses of bracket
| Unclosed_comment
| Expect of string
| Bad_token
type 'a error =
| SyntError of 'a
| LexError of lex_error
| SysError of string
module type ERROR =
sig
type t
type bracket =
| Round
| Square
| Curly
type lex_error =
| Unstarted_comment
| Unstarted_bracket
| Mismatch_parentheses of bracket
| Unclosed_comment
| Expect of string
| Bad_token
type synt_error
type error =
| SyntError of synt_error
| LexError of lex_error
| SysError of string
(** The exception that should be raised when an error occur *)
exception Error of (t * location)
exception Error of (error * location)
(** [error_msg e ~filename] returns a string describing the error
[e] while the file [filename] is being processed *)
val error_msg : (t * location) -> filename:string -> string
val error_msg : ?filename:string -> (error * location) -> string
val empty_bracket_stack : (bracket * location) list
......@@ -51,4 +52,4 @@ module type ERROR =
end
module Make (E:E) : ERROR with type t = 'a error constraint 'a = E.t
module Make (E:E) : ERROR with type synt_error = E.t
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment