basis-library/mlton/exn.sml

   1 (* Copyright (C) 2001-2008 Henry Cejtin, Matthew Fluet, Suresh
   2  *    Jagannathan, and Stephen Weeks.
   3  *
   4  * MLton is released under a BSD-style license.
   5  * See the file MLton-LICENSE for details.
   6  *)
   7
   8 structure MLtonExn =
   9    struct
  10       open Primitive.MLton.Exn
  11
  12       type t = exn
  13
  14       val addExnMessager = General.addExnMessager
  15
  16       val history: t -> string list =
  17          if keepHistory then
  18             (setExtendExtra (fn e =>
  19                              case e of
  20                                 NONE => SOME (MLtonCallStack.current ())
  21                               | SOME _ => e)
  22              ; (fn e =>
  23                 case extra e of
  24                    NONE => []
  25                  | SOME cs =>
  26                       let
  27                          (* Gets rid of the anonymous function passed to
  28                           * setExtendExtra above.
  29                           *)
  30                          fun loop xs =
  31                             case xs of
  32                                [] => []
  33                              | x :: xs =>
  34                                   if String.isPrefix "MLtonExn.fn " x then
  35                                      xs
  36                                   else
  37                                      loop xs
  38                       in
  39                          loop (MLtonCallStack.toStrings cs)
  40                       end))
  41          else fn _ => []
  42
  43       local
  44          val message = PrimitiveFFI.Stdio.print
  45          fun 'a wrapHandler (handler: exn -> unit) exn : 'a =
  46             (handler exn
  47              ; message "Top-level handler returned.\n"
  48              ; Exit.exit Exit.Status.failure)
  49             handle _ => (message "Top-level handler raised exception.\n"
  50                          ; Exit.halt Exit.Status.failure
  51                          ; raise Fail "MLton.Exn.wrapHandler")
  52          val defaultHandler = fn exn =>
  53             (message (concat ["unhandled exception: ", exnMessage exn, "\n"])
  54              ; (case history exn of
  55                    [] => ()
  56                  | l =>
  57                       (message "with history:\n"
  58                        ; List.app (fn s => message (concat ["\t", s, "\n"])) l))
  59              ; Exit.exit Exit.Status.failure)
  60       in
  61          val getTopLevelHandler = Primitive.TopLevel.getHandler
  62          val setTopLevelHandler = Primitive.TopLevel.setHandler o wrapHandler
  63          fun 'a defaultTopLevelHandler (exn: exn): 'a =
  64             wrapHandler defaultHandler exn
  65          fun 'a topLevelHandler (exn: exn) : 'a =
  66             (getTopLevelHandler () exn
  67              ; raise Fail "MLton.Exn.topLevelHandler")
  68       end
  69    end