From 70c01749b294a8284ce885509a4afc6edae612ee Mon Sep 17 00:00:00 2001 From: Louis Gesbert Date: Fri, 21 Jun 2024 12:04:07 +0200 Subject: [PATCH] Fix regression on internal typing errors reported as user errors --- compiler/driver.ml | 16 +++++----------- compiler/shared_ast/typing.ml | 25 ++++++++++++++++++++++--- compiler/shared_ast/typing.mli | 5 ++++- 3 files changed, 31 insertions(+), 15 deletions(-) diff --git a/compiler/driver.ml b/compiler/driver.ml index a5991918..c4431660 100644 --- a/compiler/driver.ml +++ b/compiler/driver.ml @@ -202,15 +202,9 @@ module Passes = struct in let (prg : ty Dcalc.Ast.program) = match typed with - | Typed _ -> ( + | Typed _ -> Message.debug "Typechecking again..."; - try Typing.program prg - with Message.CompilerError error_content -> - let bt = Printexc.get_raw_backtrace () in - Printexc.raise_with_backtrace - (Message.CompilerError - (Message.Content.to_internal_error error_content)) - bt) + Typing.program ~internal_check:true prg | Untyped _ -> prg | Custom _ -> assert false in @@ -269,7 +263,7 @@ module Passes = struct let prg = if not closure_conversion then ( Message.debug "Retyping lambda calculus..."; - Typing.program ~fail_on_any:false prg) + Typing.program ~fail_on_any:false ~internal_check:true prg) else ( Message.debug "Performing closure conversion..."; let prg = Lcalc.Closure_conversion.closure_conversion prg in @@ -280,14 +274,14 @@ module Passes = struct else prg in Message.debug "Retyping lambda calculus..."; - Typing.program ~fail_on_any:false prg) + Typing.program ~fail_on_any:false ~internal_check:true prg) in let prg, type_ordering = if monomorphize_types then ( Message.debug "Monomorphizing types..."; let prg, type_ordering = Lcalc.Monomorphize.program prg in Message.debug "Retyping lambda calculus..."; - let prg = Typing.program ~fail_on_any:false ~assume_op_types:true prg in + let prg = Typing.program ~fail_on_any:false ~assume_op_types:true ~internal_check:true prg in prg, type_ordering) else prg, type_ordering in diff --git a/compiler/shared_ast/typing.ml b/compiler/shared_ast/typing.ml index dc9d84d5..91cce748 100644 --- a/compiler/shared_ast/typing.ml +++ b/compiler/shared_ast/typing.ml @@ -1103,6 +1103,25 @@ let program ?fail_on_any ?assume_op_types prg = }; } -let program ?fail_on_any ?assume_op_types prg = - Message.with_delayed_errors (fun () -> - program ?fail_on_any ?assume_op_types prg) +let program ?fail_on_any ?assume_op_types ?(internal_check=false) prg = + let wrap = + if internal_check then + fun f -> + try Message.with_delayed_errors f with + | Message.CompilerErrors errs -> + let bt = Printexc.get_raw_backtrace () in + Printexc.raise_with_backtrace + (Message.CompilerErrors + (List.map Message.Content.to_internal_error errs)) + bt + | Message.CompilerError err -> + let bt = Printexc.get_raw_backtrace () in + Printexc.raise_with_backtrace + (Message.CompilerError + (Message.Content.to_internal_error err)) + bt + else + fun f -> Message.with_delayed_errors f + in + wrap @@ fun () -> + program ?fail_on_any ?assume_op_types prg diff --git a/compiler/shared_ast/typing.mli b/compiler/shared_ast/typing.mli index e8d6b32f..7122e8e5 100644 --- a/compiler/shared_ast/typing.mli +++ b/compiler/shared_ast/typing.mli @@ -97,6 +97,7 @@ val check_expr : val program : ?fail_on_any:bool -> ?assume_op_types:bool -> + ?internal_check:bool -> ('a, 'm) gexpr program -> ('a, typed) gexpr program (** Typing on whole programs (as defined in Shared_ast.program, i.e. for the @@ -104,4 +105,6 @@ val program : Any existing type annotations are checked for unification. Use [Program.untype] to remove them beforehand if this is not the desired - behaviour. *) + behaviour. + + If [internal_check] is set to [true], typing errors will be marked as internal, and the faulty program will be printed if '--debug' is set. *)