From 70c01749b294a8284ce885509a4afc6edae612ee Mon Sep 17 00:00:00 2001
From: Louis Gesbert <louis.gesbert@ocamlpro.com>
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. *)