[MLton] MLton.Exn.setTopLevelHandler

[Vesa Karvonen]

AFAICT, MLton doesn't currently expose the functionality to set the
top-level handler to a user-defined function.  We ran into a case
where this would be desirable.  Is there some reason why functionality
equivalent to Primitive.TopLevel.setHandler is not exposed?

Below is a patch that exposes setHandler as
MLton.Exn.setTopLevelHandler.  It wraps the handler with a function
that exits.  The wrapping is not absolutely necessary, but probably
makes it easier to use.  Any objections to applying this patch (with
or without the wrapping)?

-Vesa Karvonen

Index: basis-library/mlton/exn.sig
===================================================================
--- basis-library/mlton/exn.sig	(revision 5616)
+++ basis-library/mlton/exn.sig	(working copy)
@@ -9,5 +9,6 @@
    sig
       val addExnMessager: (exn -> string option) -> unit
       val history: exn -> string list
+      val setTopLevelHandler: (exn -> unit) -> unit
       val topLevelHandler: exn -> 'a (* does not return *)
    end
Index: basis-library/mlton/exn.sml
===================================================================
--- basis-library/mlton/exn.sml	(revision 5616)
+++ basis-library/mlton/exn.sml	(working copy)
@@ -43,15 +43,8 @@

       local
          val message = PrimitiveFFI.Stdio.print
-      in
-         fun 'a topLevelHandler (exn: exn): 'a =
-            (message (concat ["unhandled exception: ", exnMessage exn, "\n"])
-             ; (case history exn of
-                   [] => ()
-                 | l =>
-                      (message "with history:\n"
-                       ; (List.app (fn s => message (concat ["\t", s, "\n"]))
-                          l)))
+         fun wrapHandler (handler : exn -> unit) exn =
+            (handler exn
              ; Exit.exit Exit.Status.failure)
             handle _ => (message "Toplevel handler raised exception.\n"
                          ; Primitive.MLton.halt Exit.Status.failure
@@ -59,5 +52,18 @@
                           * so that the expression is of type 'a.
                           *)
                          ; raise Fail "bug")
+      in
+         val setTopLevelHandler = Primitive.TopLevel.setHandler o wrapHandler
+         fun 'a topLevelHandler (exn: exn): 'a =
+            wrapHandler
+            (fn exn =>
+             (message (concat ["unhandled exception: ", exnMessage exn, "\n"])
+              ; case history exn of
+                   [] => ()
+                 | l =>
+                      (message "with history:\n"
+                       ; (List.app (fn s => message (concat ["\t", s, "\n"]))
+                          l))))
+            exn
       end
    end