Commit | Line | Data |
---|---|---|
7f918cf1 CE |
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 |