From 7f4824bed6fa1e439f4686101b0481b033a9dea2 Mon Sep 17 00:00:00 2001 From: vbot Date: Tue, 30 Jul 2024 15:20:51 +0200 Subject: [PATCH] adapt existing errors to changes --- compiler/shared_ast/typing.ml | 2 +- compiler/surface/lexer_common.ml | 5 +- compiler/surface/lexer_common.mli | 2 + compiler/surface/parser_driver.ml | 91 +++++++++++++++++-------------- 4 files changed, 56 insertions(+), 44 deletions(-) diff --git a/compiler/shared_ast/typing.ml b/compiler/shared_ast/typing.ml index ab6bf8d6..5b0c02a3 100644 --- a/compiler/shared_ast/typing.ml +++ b/compiler/shared_ast/typing.ml @@ -224,7 +224,7 @@ let record_type_error _ctx (A.AnyExpr e) t1 t2 = t2_pos ); ] in - Message.delayed_error () ~fmt_pos + Message.delayed_error ~kind:Typing () ~fmt_pos "Error during typechecking, incompatible types:@\n\ @[@{@<2>%s@} @[%a@]@,\ @{@<2>%s@} @[%a@]@]" "─➤" pp_typ t1_repr "─➤" pp_typ t2_repr diff --git a/compiler/surface/lexer_common.ml b/compiler/surface/lexer_common.ml index 166eea20..547e59b5 100644 --- a/compiler/surface/lexer_common.ml +++ b/compiler/surface/lexer_common.ml @@ -58,10 +58,11 @@ let code_buffer : Buffer.t = Buffer.create 4000 let update_acc (lexbuf : lexbuf) : unit = Buffer.add_string code_buffer (Utf8.lexeme lexbuf) +exception Lexing_error of (Pos.t * string) + (** Error-generating helper *) let raise_lexer_error (loc : Pos.t) (token : string) = - Message.error ~pos:loc - "Parsing error after token \"%s\": what comes after is unknown" token + raise (Lexing_error (loc, token)) (** Associative list matching each punctuation string part of the Catala syntax with its {!module: Surface.Parser} token. Same for all the input languages diff --git a/compiler/surface/lexer_common.mli b/compiler/surface/lexer_common.mli index d9273b80..33319fe5 100644 --- a/compiler/surface/lexer_common.mli +++ b/compiler/surface/lexer_common.mli @@ -31,6 +31,8 @@ val code_buffer : Buffer.t val update_acc : Sedlexing.lexbuf -> unit (** Updates {!val:code_buffer} with the current lexeme *) +exception Lexing_error of (Catala_utils.Pos.t * string) + val raise_lexer_error : Catala_utils.Pos.t -> string -> 'a (** Error-generating helper *) diff --git a/compiler/surface/parser_driver.ml b/compiler/surface/parser_driver.ml index d944f041..c317db7b 100644 --- a/compiler/surface/parser_driver.ml +++ b/compiler/surface/parser_driver.ml @@ -97,8 +97,7 @@ module ParserAux (LocalisedLexer : Lexer_common.LocalisedLexer) = struct let error_loc = Pos.from_lpos (lexing_positions lexbuf) in let wrong_token = Utf8.lexeme lexbuf in let msg = custom_menhir_message in - Message.delayed_error () ?suggestion - ~extra_pos:["", error_loc] + Message.delayed_error ~kind:Parsing () ?suggestion ~pos:error_loc "@[Syntax error at %a:@ %t@]" (fun ppf string -> Format.fprintf ppf "@{\"%s\"@}" string) wrong_token msg @@ -264,12 +263,12 @@ module ParserAux (LocalisedLexer : Lexer_common.LocalisedLexer) = struct let target_rule = target_rule (fst @@ Sedlexing.lexing_positions lexbuf) in - Message.with_delayed_errors - @@ fun () -> loop lexer_buffer token_list lexbuf None target_rule - with Sedlexing.MalFormed | Sedlexing.InvalidCodepoint _ -> - Lexer_common.raise_lexer_error - (Pos.from_lpos (lexing_positions lexbuf)) - (Utf8.lexeme lexbuf) + loop lexer_buffer token_list lexbuf None target_rule + with Lexer_common.Lexing_error (pos, token) -> + (* The encapsulating [Message.with_delayed_errors] will raise an + exception: we are safe returning a dummy value. *) + Message.delayed_error ~kind:Lexing [] ~pos + "Parsing error after token \"%s\": what comes after is unknown" token let commands_or_includes (lexbuf : lexbuf) : Ast.source_file = sedlex_with_menhir LocalisedLexer.lexer LocalisedLexer.token_list @@ -349,7 +348,7 @@ and expand_includes (source_file : string) (commands : Ast.law_structure list) : match acc.Ast.program_module, name_opt with | opt, None | None, opt -> opt | Some id1, Some id2 -> - Message.error + Message.error ~kind:Parsing ~extra_pos: ["", Mark.get id1.module_name; "", Mark.get id2.module_name] "Multiple definitions of the module name" @@ -374,36 +373,44 @@ and expand_includes (source_file : string) (commands : Ast.law_structure list) : | Ast.LawInclude (Ast.CatalaFile inc_file) -> let source_dir = Filename.dirname source_file in let sub_source = File.(source_dir / Mark.remove inc_file) in - with_sedlex_file sub_source - @@ fun lexbuf -> - let includ_program = parse_source lexbuf in - let () = - includ_program.Ast.program_module - |> Option.iter - @@ fun id -> - Message.error - ~extra_pos: - [ - "File include", Mark.get inc_file; - "Module declaration", Mark.get id.Ast.module_name; - ] - "A file that declares a module cannot be used through the raw \ - '@{> Include@}'@ directive.@ You should use it as a \ - module with@ '@{> Use @{%s@}@}'@ instead." - (Mark.remove id.Ast.module_name) - in - { - Ast.program_module = acc.program_module; - Ast.program_source_files = - List.rev_append includ_program.program_source_files - acc.Ast.program_source_files; - Ast.program_items = - List.rev_append includ_program.program_items acc.Ast.program_items; - Ast.program_used_modules = - List.rev_append includ_program.program_used_modules - acc.Ast.program_used_modules; - Ast.program_lang = language; - } + let pos = Mark.get inc_file in + if File.check_file sub_source = None then + Message.delayed_error ~kind:Parsing ~pos acc + "Included file '%s' is not a regular file or does not exist." + sub_source + else + with_sedlex_file sub_source + @@ fun lexbuf -> + let includ_program = parse_source lexbuf in + let () = + includ_program.Ast.program_module + |> Option.iter + @@ fun id -> + Message.error ~kind:Parsing + ~extra_pos: + [ + "File include", Mark.get inc_file; + "Module declaration", Mark.get id.Ast.module_name; + ] + "A file that declares a module cannot be used through the \ + raw '@{> Include@}'@ directive.@ You should use it \ + as a module with@ '@{> Use @{%s@}@}'@ \ + instead." + (Mark.remove id.Ast.module_name) + in + { + Ast.program_module = acc.program_module; + Ast.program_source_files = + List.rev_append includ_program.program_source_files + acc.Ast.program_source_files; + Ast.program_items = + List.rev_append includ_program.program_items + acc.Ast.program_items; + Ast.program_used_modules = + List.rev_append includ_program.program_used_modules + acc.Ast.program_used_modules; + Ast.program_lang = language; + } | Ast.LawHeading (heading, commands') -> let { Ast.program_module; @@ -490,7 +497,7 @@ let check_modname program source_file = | ( Some { module_name = mname, pos; _ }, (Global.FileName file | Global.Contents (_, file) | Global.Stdin file) ) when not File.(equal mname Filename.(remove_extension (basename file))) -> - Message.error ~pos + Message.error ~kind:Parsing ~pos "Module declared as@ @{%s@},@ which@ does@ not@ match@ the@ file@ \ name@ %a.@ Rename the module to@ @{%s@}@ or@ the@ file@ to@ %a." mname File.format file @@ -512,7 +519,7 @@ let load_interface ?default_module_name source_file = module_external = false; } | None, None -> - Message.error + Message.error ~kind:Parsing "%a doesn't define a module name. It should contain a '@{> \ Module %s@}' directive." File.format @@ -530,6 +537,8 @@ let load_interface ?default_module_name source_file = } let parse_top_level_file (source_file : File.t Global.input_src) : Ast.program = + Message.with_delayed_errors + @@ fun () -> let program = with_sedlex_source source_file parse_source in check_modname program source_file; {