Commit 329790ab authored by POGODALLA Sylvain's avatar POGODALLA Sylvain
Browse files

Fix #22 (uncaught exception in some case of missing semi-colon)

parent 2997a8a2
......@@ -248,3 +248,21 @@ let get_loc_error = function
| Env_error (_,(s,e))
| Lexicon_error (_,(s,e)) -> (s,e)
| (Version_error _ | System_error _) -> failwith "Bug: should not occur"
let get_string_error = function
| Parse_error (er,pos) -> parse_error_to_string er,pos
| Lexer_error (er,pos) -> lex_error_to_string er,pos
| Type_error (er,pos) -> type_error_to_string er,pos
| Env_error (er,pos) -> env_error_to_string er,pos
| Lexicon_error (er,pos) -> lexicon_error_to_string er,pos
| (Version_error _ | System_error _) -> failwith "Bug: should not occur"
let change_loc err pos =
match err with
| Parse_error (er,_) -> Parse_error (er,pos)
| Lexer_error (er,_) -> Lexer_error (er,pos)
| Type_error (er,_) -> Type_error (er,pos)
| Env_error (er,_) -> Env_error (er,pos)
| Lexicon_error (er,_) -> Lexicon_error (er,pos)
| (Version_error _ | System_error _) -> failwith "Bug: should not occur"
......@@ -117,11 +117,6 @@ val unset_infix : unit -> unit
while the file [filename] is being processed *)
val error_msg : error -> string -> string
(** [dyp_error lexbuf] returns an exception {!Error.Error} so
that it can be caught in a uniform way. [lexbuf] is
used to set correctly the location information of the parse error *)
(* val dyp_error : Lexing.lexbuf -> exn *)
(** [warnings_to_string filname ws] returns a string describing the
warnings and their location for the file [filename] *)
val warnings_to_string : string -> warning list -> string
......@@ -130,4 +125,10 @@ val warnings_to_string : string -> warning list -> string
error *)
val get_loc_error : error -> (Lexing.position * Lexing.position)
(** [get_string_error e] returns the string describing the error and
its position *)
val get_string_error : error -> string * (Lexing.position * Lexing.position)
val change_loc : error -> (Lexing.position * Lexing.position) -> error
val compute_comment_for_position : Lexing.position -> Lexing.position -> string
......@@ -70,6 +70,13 @@ let supplier lexbuf =
sup
*)
let _term_parser_supplier lexbuf =
try
core_supplier lexbuf
with
| Failure f when f="lexing: empty token" ->
raise AcgData.Error.(Error (Lexer_error (Expect "Bad end of input. ';'",(Lexing.lexeme_start_p lexbuf,Lexing.lexeme_end_p lexbuf))))
let supplier = core_supplier
let parse_data ?(overwrite=false) ?(output=false) filename includes env =
......@@ -107,7 +114,7 @@ let parse_data ?(overwrite=false) ?(output=false) filename includes env =
let () = Logs.err (fun m -> m "%s" (Error.error_msg e filename)) in
None
let pp_error ~color er t =
let pp_error ?parsing_context ~color er t =
let () = Utils.sformat "@." in
let _ = Format.flush_str_formatter () in
let s,e = Error.get_loc_error er in
......@@ -121,9 +128,16 @@ let pp_error ~color er t =
let end_start_index = (s' + (e'-s')) in
let t_end = String.sub t end_start_index ((String.length t) - end_start_index) in
let () = Logs.err (fun m -> m "%s%s%s" t_init t_error t_end) in
Logs.err (fun m -> m "%s" (Error.error_msg er "stdin"))
match parsing_context with
| None -> Logs.err (fun m -> m "%s" (Error.error_msg er "stdin"))
| Some (file,(p1,_p2)) ->
let new_er_pos = Lexing.(p1,{p1 with
pos_cnum=e'+p1.pos_cnum;}) in
(* let new_er_pos = (p1,p2) in *)
let new_er = Error.change_loc er new_er_pos in
Logs.err (fun m -> m "%s" (Error.error_msg new_er file))
let parse_term ?(output=false) ~color t sg =
let parse_term ?(output=false) ?parsing_context ~color t sg =
let lexbuf = Lexing.from_string t in
try
let abs_term,abs_type = I.loop_handle (fun x -> x) (fail lexbuf) (supplier lexbuf) (Data_parser.Incremental.term_alone lexbuf.Lexing.lex_curr_p) sg in
......@@ -150,7 +164,7 @@ let parse_term ?(output=false) ~color t sg =
Some (abs_term,abs_type)
with
| Error.Error er ->
let () = pp_error ~color er t in
let () = pp_error ~color ?parsing_context er t in
None
| End_of_file -> None
......
......@@ -20,7 +20,7 @@ val parse_data : ?overwrite:bool -> ?output:bool -> string -> string list -> Env
correspond to [s]. If [col] is true, then, in case of error, the
substring corrresponding to this error in the error message is
colored.*)
val parse_term : ?output:bool -> color:bool -> string -> Environment.Signature1.t -> (Lambda.term*Lambda.stype) option
val parse_term : ?output:bool -> ?parsing_context:(string * (Lexing.position * Lexing.position)) -> color:bool -> string -> Environment.Signature1.t -> (Lambda.term*Lambda.stype) option
(** [parse_term ~out ~col s lex] parses the term and type contained in
sthe string [s] (in the form of [<term>:<stype>]) according to the
......
......@@ -83,7 +83,7 @@ let parse_files dirs svg_output no_color no_pp _no_svg svg_config filenames =
match svg_config with
| None -> Rendering_config.default
| Some conf_file -> Rendering_config.get_config conf_file dirs in
let ctx = F.make_context ~wait:false ~colored_output:(not no_color) ~pretty_printed_output:(not no_pp) ~echo:true ~svg:svg_output ~dirs:dirs ~rendering_config ~parse_fun:P.parse_file in
let ctx = F.make_context ?script_filename:None ~wait:false ~colored_output:(not no_color) ~pretty_printed_output:(not no_pp) ~echo:true ~svg:svg_output ~dirs:dirs ~rendering_config ~parse_fun:P.parse_file in
let env = AcgData.Environment.Environment.empty in
(* ANSITerminal get the size info from stdin, In case of redirection,
the latter may not be set. That's why it is first duplicated and
......
......@@ -119,7 +119,7 @@
fun (ctx,e) ->
let name,loc = id in
let () = echo ctx l in
ctx,F.select name loc e}
ctx,F.(select ctx name loc e)}
| SELECT HELP l = SEMICOLONN {
fun (ctx,e) ->
......@@ -142,7 +142,7 @@
| t = TRACE l = SEMICOLONN {
fun (ctx,e) ->
let () = echo ctx l in
let () = F.trace t in
let () = F.trace ctx t in
ctx,e}
| TRACE HELP l = SEMICOLONN {
......@@ -154,7 +154,7 @@
| d = DONT t = TRACE l = SEMICOLONN {
fun (ctx,e) ->
let () = echo ctx l in
let () = F.dont_trace (new_loc d t) in
let () = F.dont_trace ctx (new_loc d t) in
ctx,e}
| DONT TRACE HELP l = SEMICOLONN {
......@@ -168,8 +168,8 @@
let () = echo ctx l in
let () =
match name with
| None -> F.print e p
| Some (n,l) -> F.print ~name:n e l in
| None -> F.print ctx e p
| Some (n,l) -> F.print ~name:n ctx e l in
ctx,e}
| IDENTT? PRINT HELP l = SEMICOLONN {
......@@ -262,8 +262,8 @@
let () = echo ctx l in
let () =
match name with
| None -> F.idb e p
| Some (n,l) -> F.idb ~name:n e l in
| None -> F.idb ctx e p
| Some (n,l) -> F.idb ~name:n ctx e l in
ctx,e}
| IDENTT? IDB HELP l = SEMICOLONN {
......@@ -286,7 +286,7 @@
| COMPOSE n1 = IDENTT n2 = IDENTT AS n3 = IDENTT l = SEMICOLONN {
fun (ctx,e) ->
let () = echo ctx l in
ctx,F.compose n1 n2 n3 e}
ctx,F.compose ctx n1 n2 n3 e}
| COMPOSE HELP l = SEMICOLONN {
fun (ctx,e) ->
let () = echo ctx l in
......@@ -368,19 +368,19 @@
| CREATE_LEX n = IDENTT n1 = IDENTT n2 = IDENTT l = SEMICOLONN {
fun (ctx,e) ->
let () = echo ctx l in
ctx,F.create_lex ~abs:n1 ~obj:n2 n e}
ctx,F.create_lex ~abs:n1 ~obj:n2 ctx n e}
| params = SAVE {
fun (ctx,e) ->
let filename,l,line = params in
let () = echo ctx line in
let () = F.save filename e l in
let () = F.save ctx filename e l in
ctx,e}
| names = IDENTT+ params = SAVE {
fun (ctx,e) ->
let filename,l,line = params in
let () = echo ctx line in
let () = F.save ~names filename e l in
let () = F.save ~names ctx filename e l in
ctx,e}
This diff is collapsed.
......@@ -69,14 +69,14 @@ sig
val list : context -> env -> unit
val select : string -> (Lexing.position * Lexing.position) -> env -> env
val select : context -> string -> (Lexing.position * Lexing.position) -> env -> env
val unselect : env -> env
val trace : (Lexing.position * Lexing.position) -> unit
val dont_trace : (Lexing.position * Lexing.position) -> unit
val trace : context -> (Lexing.position * Lexing.position) -> unit
val dont_trace : context -> (Lexing.position * Lexing.position) -> unit
val print : ?name:string -> env -> (Lexing.position * Lexing.position) -> unit
val print : context -> ?name:string -> env -> (Lexing.position * Lexing.position) -> unit
val analyse : context -> ?names:(string * (Lexing.position * Lexing.position)) list -> env -> string -> (Lexing.position * Lexing.position) -> unit
......@@ -88,18 +88,18 @@ sig
val parse : context -> ?name:string -> env -> string -> (Lexing.position * Lexing.position) -> unit
val idb : ?name:string -> env -> (Lexing.position * Lexing.position) -> unit
val idb : ?name:string -> context -> env -> (Lexing.position * Lexing.position) -> unit
val query : ?name:string -> context -> env -> string -> (Lexing.position * Lexing.position) -> unit
val add : ?names:(string * (Lexing.position * Lexing.position)) list -> context -> env -> string -> (Lexing.position * Lexing.position) -> env
val compose :
val compose : context ->
string * (Lexing.position * Lexing.position) ->
string * (Lexing.position * Lexing.position) ->
string * (Lexing.position * Lexing.position) -> env -> env
val make_context : wait:bool -> colored_output:bool -> pretty_printed_output:bool -> echo:bool -> svg:string option -> dirs:string list -> rendering_config:Rendering_config.config -> parse_fun:(string -> context -> Environment.t -> context * Environment.t) -> context
val make_context : ?script_filename:string -> wait:bool -> colored_output:bool -> pretty_printed_output:bool -> echo:bool -> svg:string option -> dirs:string list -> rendering_config:Rendering_config.config -> parse_fun:(string -> context -> Environment.t -> context * Environment.t) -> context
val wait : context -> context
......@@ -123,10 +123,12 @@ sig
val create_sig : (string * (Lexing.position * Lexing.position)) -> env -> env
val create_lex : abs:(string * (Lexing.position * Lexing.position)) -> obj:(string * (Lexing.position * Lexing.position)) -> (string * (Lexing.position * Lexing.position)) -> env -> env
val create_lex : abs:(string * (Lexing.position * Lexing.position)) -> obj:(string * (Lexing.position * Lexing.position)) -> context -> (string * (Lexing.position * Lexing.position)) -> env -> env
val save : ?names:(string * (Lexing.position * Lexing.position)) list -> string -> env -> (Lexing.position * Lexing.position) -> unit
val save : ?names:(string * (Lexing.position * Lexing.position)) list -> context -> string -> env -> (Lexing.position * Lexing.position) -> unit
val get_filename : context -> string option
val set_filename : string option -> context -> context
end
......
......@@ -38,12 +38,19 @@ let parse_file filename ctx env =
open_in fullname in
let lexbuf = Lexing.from_channel in_ch in
let () = Logs.app (fun m -> m "Parsing script file \"%s\"..." filename) in
let ctx',new_env= (I.loop_handle
succeed
(fail lexbuf)
(supplier lexbuf)
(Command_parser.Incremental.commands lexbuf.Lexing.lex_curr_p))
(ctx,env) in
let l_ctx = Functions.set_filename (Some filename) ctx in
let l_ctx',new_env=
try
(I.loop_handle
succeed
(fail lexbuf)
(supplier lexbuf)
(Command_parser.Incremental.commands lexbuf.Lexing.lex_curr_p))
(l_ctx,env)
with
| Failure f when f="lexing: empty token" ->
raise AcgData.Error.(Error (Lexer_error (Expect "Bad end of input. ';'",(Lexing.lexeme_end_p lexbuf,Lexing.lexeme_end_p lexbuf)))) in
let ctx' = Functions.set_filename (Functions.get_filename ctx) l_ctx' in
let () = Logs.app (fun m -> m "Done.") in
ctx',new_env
with
......@@ -61,8 +68,8 @@ let parse_file filename ctx env =
let () = Logs.err (fun m -> m "%s" (AcgData.Error.error_msg e filename)) in
let _ = Script_lexer.reset_echo () in
ctx,env
| Scripting_errors.Error (e,p) ->
let () = Logs.err (fun m -> m "%s" (Scripting_errors.error_msg e p)) in
| Scripting_errors.Error (e,p,f) ->
let () = Logs.err (fun m -> m "%s" (Scripting_errors.error_msg e p f)) in
let _ = Script_lexer.reset_echo () in
ctx,env
......@@ -123,12 +130,12 @@ let parse_entry ~resize in_ch ctx env =
| Functions.Quit -> Stop (ctx,env)
| Functions.Stop -> Stop (ctx,env)
| Failure f when f="lexing: empty token" -> Continue (ctx,env)
| AcgData.Error.Error e ->
(* | AcgData.Error.Error e ->
let () = Logs.err (fun m -> m "%s" (AcgData.Error.error_msg e "stdin")) in
let _ = Script_lexer.reset_echo () in
Continue (ctx,env)
| Scripting_errors.Error (e,p) ->
let () = Logs.err (fun m -> m "%s" (Scripting_errors.error_msg e p)) in
Continue (ctx,env) *)
| Scripting_errors.Error (e,p,f) ->
let () = Logs.err (fun m -> m "%s" (Scripting_errors.error_msg e p f)) in
let _ = Script_lexer.reset_echo () in
Continue (ctx,env)
......@@ -87,15 +87,17 @@ let string = (letter|digit|'_')*
optional_string (fun x l -> match x with
| None -> ANALYSE_HELP
| Some x -> ANALYSE (strip_trailing_space x,l,let () = echo_str (x^";") in reset_echo ())) lexbuf}
| "check" as c {let () = echo_str c in let () = Buffer.reset string_content in
| "check" as c {let () = echo_str c in let () = Buffer.reset string_content in
optional_string (fun x l -> match x with
| None -> CHECK_HELP
| Some x -> CHECK (strip_trailing_space x,l,let () = echo_str (x^";") in reset_echo ())) lexbuf}
| "realize" as c {let () = echo_str c in let () = Buffer.reset string_content in
optional_string (fun x l -> match x with
| None -> REALIZE_HELP
| Some x -> REALIZE (strip_trailing_space x,l,let () = echo_str (x^";") in reset_echo ())) lexbuf}
| "realize_show" as c {let () = echo_str c in let () = Buffer.reset string_content in
| "realize" as c {let () = echo_str c in
let () = Buffer.reset string_content in
optional_string (fun x l ->
match x with
| None -> REALIZE_HELP
| Some x -> REALIZE (strip_trailing_space x,l,let () = echo_str (x^";") in reset_echo ())) lexbuf}
| "realize_show" as c {let () = echo_str c in let () = Buffer.reset string_content in
optional_string (fun x l -> match x with
| None -> REALIZE_SHOW_HELP
| Some x -> REALIZE_SHOW (strip_trailing_space x,l,let () = echo_str (x^";") in reset_echo ())) lexbuf}
......@@ -122,7 +124,7 @@ let string = (letter|digit|'_')*
| None -> SAVE_HELP
| Some x -> SAVE (strip_trailing_space x,l,let () = echo_str (x^";") in reset_echo ())) lexbuf}
| letter string as c {let () = echo_str c in IDENTT (Lexing.lexeme lexbuf,loc lexbuf)}
| _ {raise (Scripting_errors.Error (Scripting_errors.Command_expected,loc lexbuf))}
(* | _ {raise (Scripting_errors.Error (Scripting_errors.Command_expected,loc lexbuf))} *)
and comment f_parser = parse
| newline {let () = Error.update_loc lexbuf None in f_parser lexbuf}
| _ {comment f_parser lexbuf}
......@@ -130,7 +132,9 @@ let string = (letter|digit|'_')*
| [' ' '\t'] {optional_string f lexbuf}
| "help" {let () = echo_str ("help") in
f None (loc lexbuf)}
| _ as c {let () = Buffer.add_char string_content c in string f lexbuf}
| _ as c {let () = Buffer.add_char string_content c in
let start_pos,_ = loc lexbuf in
string (fun x (_,e) -> f x (start_pos,e)) lexbuf}
and string f = parse
| ";" {f (Some (Buffer.contents string_content)) (loc lexbuf)}
| "#" {comment (string f) lexbuf}
......@@ -140,7 +144,9 @@ let string = (letter|digit|'_')*
| [' ' '\t'] {optional_string f lexbuf}
| "help" {let () = echo_str ("help") in
f None (loc lexbuf)}
| _ as c {let () = Buffer.add_char string_content c in string_wo_space f lexbuf}
| _ as c {let () = Buffer.add_char string_content c in
let start_pos,_ = loc lexbuf in
string_wo_space (fun x (_,e) -> f x (start_pos,e)) lexbuf}
and string_wo_space f = parse
| ";" {f (Some (Buffer.contents string_content)) (loc lexbuf)}
| "#" {comment (string_wo_space f) lexbuf}
......@@ -171,7 +177,7 @@ let string = (letter|digit|'_')*
| "s" as c {let () = echo_chr c in let () = Buffer.reset string_content in
string_wo_space (fun x l ->
let x = extract x in LOAD_SCRIPT (strip_trailing_space x,l,let () = echo_str (x^";") in reset_echo ())) lexbuf}
| _ {raise (Scripting_errors.Error (Scripting_errors.Missing_option Scripting_errors.Load,loc lexbuf))}
(* | _ {raise (Scripting_errors.Error (Scripting_errors.Missing_option Scripting_errors.Load,loc lexbuf))} *)
and create_options = parse
| [' ' '\t'] {create_options lexbuf}
| "help" {CREATE_HELP}
......
......@@ -31,13 +31,18 @@ type error =
| Not_yet_implemented of string
| No_focus
| Accept_only of data_type * string
| Parsing of string
and data_type =
| Lex of string
| Sg of string
exception Error of (error * Abstract_syntax.location)
exception Error of (error * Abstract_syntax.location * string option)
let error_msg er (s,e) =
let error_msg er (s,e) filename =
let file_info =
match filename with
| None -> ""
| Some s -> Printf.sprintf "File \"%s\" " s in
let loc = Error.compute_comment_for_position s e in
let msg = match er with
| Missing_option Load -> "Option (\"data\" or \"d\" or \"script\" or \"s\") is missing to the load command"
......@@ -47,5 +52,6 @@ let error_msg er (s,e) =
| No_focus -> "No data on which to apply the command"
| Accept_only (Lex s,cmd) -> Printf.sprintf "The %s command can only apply to lexicons. Here it is applied to a signature: \"%s\"" cmd s
| Accept_only (Sg s,cmd) -> Printf.sprintf "The %s command can only apply to signatures. Here it is applied to a lexicon: \"%s\"" cmd s
| Not_yet_implemented s -> Printf.sprintf "\"%s\": Command not yet implemented" s in
Printf.sprintf "%s:\n%s\n%!" loc msg
| Not_yet_implemented s -> Printf.sprintf "\"%s\": Command not yet implemented" s
| Parsing s -> s in
Printf.sprintf "%s%s:\n%s\n%!" file_info loc msg
......@@ -28,13 +28,14 @@ type error =
| Not_yet_implemented of string
| No_focus
| Accept_only of data_type * string
| Parsing of string
and data_type =
| Lex of string
| Sg of string
exception Error of (error * (Lexing.position * Lexing.position))
exception Error of (error * (Lexing.position * Lexing.position) * string option)
val error_msg : error -> (Lexing.position * Lexing.position) -> string
val error_msg : error -> (Lexing.position * Lexing.position) -> string option -> string
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