[MLton] cvs commit: Added val MLton.Exn.addExnMessager: (exn -> string option) -> unit
Stephen Weeks
sweeks@mlton.org
Thu, 1 Jul 2004 10:26:09 -0700
sweeks 04/07/01 10:26:03
Modified: basis-library/general general.sig general.sml option.sml
basis-library/io io.sml
basis-library/libs build
basis-library/misc primitive.sml
basis-library/mlton exn.sig exn.sml
basis-library/posix error.sml
basis-library/text string.sml
doc changelog
doc/user-guide extensions.tex
Log:
MAIL Added val MLton.Exn.addExnMessager: (exn -> string option) -> unit
It is implemented in the General structure along with exnMessage. The
implementation is as Matthew described. Keep a (exn -> string option)
list ref of exception message extensions; addExnMessager adds a new
exception message to the list. exnMessage iterates through the list
to see if there is an installed exception messager; if not, it returns
the exception name.
The messagers for IO and SysErr are installed immediately after each
of their exception declarations. The messager for Fail had to be
delayed a bit after its definition, until concat is defined.
Revision Changes Path
1.5 +8 -0 mlton/basis-library/general/general.sig
Index: general.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/general/general.sig,v
retrieving revision 1.4
retrieving revision 1.5
diff -u -r1.4 -r1.5
--- general.sig 24 Nov 2002 01:19:35 -0000 1.4
+++ general.sig 1 Jul 2004 17:25:59 -0000 1.5
@@ -13,6 +13,7 @@
exception Size
exception Span
exception Subscript
+
val exnName: exn -> string
val exnMessage: exn -> string
@@ -28,4 +29,11 @@
signature GENERAL =
sig
include GENERAL_GLOBAL
+ end
+
+signature GENERAL_EXTRA =
+ sig
+ include GENERAL
+
+ val addExnMessager: (exn -> string option) -> unit
end
1.9 +26 -19 mlton/basis-library/general/general.sml
Index: general.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/general/general.sml,v
retrieving revision 1.8
retrieving revision 1.9
diff -u -r1.8 -r1.9
--- general.sml 16 Feb 2004 22:43:18 -0000 1.8
+++ general.sml 1 Jul 2004 17:25:59 -0000 1.9
@@ -5,7 +5,7 @@
* MLton is released under the GNU General Public License (GPL).
* Please see the file MLton-LICENSE for license information.
*)
-structure General =
+structure General: GENERAL_EXTRA =
struct
type unit = unit
@@ -20,8 +20,7 @@
exception Size = Size
exception Span
exception Subscript
- val exnName = Primitive.Exn.name
-
+
datatype order = LESS | EQUAL | GREATER
val ! = Primitive.Ref.deref
@@ -29,21 +28,29 @@
fun (f o g) x = f (g x)
fun x before () = x
fun ignore _ = ()
+ val exnName = Primitive.Exn.name
+
+ local
+ val messagers: (exn -> string option) list ref = ref []
+ in
+ val addExnMessager: (exn -> string option) -> unit =
+ fn f => messagers := f :: !messagers
+
+ val rec exnMessage: exn -> string =
+ fn e =>
+ let
+ val rec find =
+ fn [] => exnName e
+ | m :: ms =>
+ case m e of
+ NONE => find ms
+ | SOME s => s
+ in
+ find (!messagers)
+ end
+ end
end
-local
- open General
-in
- datatype order = datatype order
- exception Chr = Chr
- exception Div = Div
- exception Domain = Domain
- exception Span = Span
- exception Subscript = Subscript
- val ! = !
- val op := = op :=
- val op before = op before
- val exnName = exnName
- val ignore = ignore
- val op o = op o
-end
+structure GeneralGlobal: GENERAL_GLOBAL = General
+open GeneralGlobal
+
1.7 +1 -1 mlton/basis-library/general/option.sml
Index: option.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/general/option.sml,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -r1.6 -r1.7
--- option.sml 13 Feb 2004 17:05:54 -0000 1.6
+++ option.sml 1 Jul 2004 17:25:59 -0000 1.7
@@ -7,7 +7,7 @@
structure Option: OPTION =
struct
-datatype 'a option = NONE | SOME of 'a
+datatype option = datatype option
exception Option
1.4 +13 -0 mlton/basis-library/io/io.sml
Index: io.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/io/io.sml,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- io.sml 6 Jun 2003 00:36:29 -0000 1.3
+++ io.sml 1 Jul 2004 17:25:59 -0000 1.4
@@ -8,11 +8,24 @@
structure IO: IO =
struct
exception BlockingNotSupported
+
exception ClosedStream
+
exception Io of {cause : exn,
function : string,
name : string}
+
+ val _ =
+ General.addExnMessager
+ (fn e =>
+ case e of
+ Io {cause, function, name, ...} =>
+ SOME (concat ["Io: ", function, " \"", name, "\" failed with ",
+ exnMessage cause])
+ | _ => NONE)
+
exception NonblockingNotSupported
+
exception RandomAccessNotSupported
datatype buffer_mode = NO_BUF | LINE_BUF | BLOCK_BUF
1.34 +1 -1 mlton/basis-library/libs/build
Index: build
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/libs/build,v
retrieving revision 1.33
retrieving revision 1.34
diff -u -r1.33 -r1.34
--- build 5 Mar 2004 03:50:50 -0000 1.33
+++ build 1 Jul 2004 17:26:00 -0000 1.34
@@ -9,9 +9,9 @@
misc/dynamic-wind.sml
general/general.sig
general/general.sml
-misc/util.sml
general/option.sig
general/option.sml
+misc/util.sml
list/list.sig
list/list.sml
list/list-pair.sig
1.114 +2 -0 mlton/basis-library/misc/primitive.sml
Index: primitive.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/misc/primitive.sml,v
retrieving revision 1.113
retrieving revision 1.114
diff -u -r1.113 -r1.114
--- primitive.sml 13 Jun 2004 03:54:57 -0000 1.113
+++ primitive.sml 1 Jul 2004 17:26:00 -0000 1.114
@@ -151,6 +151,8 @@
exception Overflow = Overflow
exception Size
+datatype 'a option = NONE | SOME of 'a
+
structure Primitive =
struct
val detectOverflow = _build_const "MLton_detectOverflow": bool;
1.4 +1 -0 mlton/basis-library/mlton/exn.sig
Index: exn.sig
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/exn.sig,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -r1.3 -r1.4
--- exn.sig 10 Feb 2004 03:22:07 -0000 1.3
+++ exn.sig 1 Jul 2004 17:26:01 -0000 1.4
@@ -1,5 +1,6 @@
signature MLTON_EXN =
sig
+ val addExnMessager: (exn -> string option) -> unit
val history: exn -> string list
val topLevelHandler: exn -> 'a (* does not return *)
end
1.12 +2 -22 mlton/basis-library/mlton/exn.sml
Index: exn.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/mlton/exn.sml,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- exn.sml 11 Jun 2004 12:37:42 -0000 1.11
+++ exn.sml 1 Jul 2004 17:26:01 -0000 1.12
@@ -4,6 +4,8 @@
type t = exn
+ val addExnMessager = General.addExnMessager
+
val history: t -> string list =
if keepHistory
then (setInitExtra ([]: extra)
@@ -11,18 +13,6 @@
; extra)
else fn _ => []
- val rec exnMessage: t -> string =
- fn Fail s => concat ["Fail: ", s]
- | IO.Io {cause, function, name, ...} =>
- concat ["Io: ", function, " \"", name, "\" failed with ",
- exnMessage cause]
- | PosixError.SysErr (s, eo) =>
- concat ["SysErr: ", s,
- case eo of
- NONE => ""
- | SOME e => concat [" [", PosixError.errorName e, "]"]]
- | e => exnName e
-
local
val message = Primitive.Stdio.print
in
@@ -40,13 +30,3 @@
; raise Fail "bug")
end
end
-
-structure General: GENERAL =
- struct
- open General
-
- val exnMessage = MLtonExn.exnMessage
- end
-
-structure GeneralGlobal: GENERAL_GLOBAL = General
-open GeneralGlobal
1.12 +11 -0 mlton/basis-library/posix/error.sml
Index: error.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/posix/error.sml,v
retrieving revision 1.11
retrieving revision 1.12
diff -u -r1.11 -r1.12
--- error.sml 18 May 2004 00:35:40 -0000 1.11
+++ error.sml 1 Jul 2004 17:26:01 -0000 1.12
@@ -22,6 +22,17 @@
NONE => "<UNKNOWN>"
| SOME (_, s) => s
+ val _ =
+ General.addExnMessager
+ (fn e =>
+ case e of
+ SysErr (s, eo) =>
+ SOME (concat ["SysErr: ", s,
+ case eo of
+ NONE => ""
+ | SOME e => concat [" [", errorName e, "]"]])
+ | _ => NONE)
+
fun syserror s =
case List.find (fn (_, s') => s = s') errorNames of
NONE => NONE
1.8 +8 -0 mlton/basis-library/text/string.sml
Index: string.sml
===================================================================
RCS file: /cvsroot/mlton/mlton/basis-library/text/string.sml,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -r1.7 -r1.8
--- string.sml 20 Feb 2004 19:17:33 -0000 1.7
+++ string.sml 1 Jul 2004 17:26:02 -0000 1.8
@@ -52,6 +52,14 @@
structure StringGlobal: STRING_GLOBAL = String
open StringGlobal
+(* Now that concat is defined, we can add the exnMessager for Fail. *)
+val _ =
+ General.addExnMessager
+ (fn e =>
+ case e of
+ Fail s => SOME (concat ["Fail: ", s])
+ | _ => NONE)
+
structure NullString =
struct
open NullString
1.129 +3 -0 mlton/doc/changelog
Index: changelog
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/changelog,v
retrieving revision 1.128
retrieving revision 1.129
diff -u -r1.128 -r1.129
--- changelog 23 Jun 2004 17:18:01 -0000 1.128
+++ changelog 1 Jul 2004 17:26:03 -0000 1.129
@@ -1,5 +1,8 @@
Here are the changes since version 20040227.
+* 2004-07-01
+ - Added val MLton.Exn.addExnMessager: (exn -> string option) -> unit
+
* 2004-06-23
- Runtime system options that take memory sizes now accept a "g"
suffix indicating gigabytes. They also now take a real instead of
1.66 +5 -0 mlton/doc/user-guide/extensions.tex
Index: extensions.tex
===================================================================
RCS file: /cvsroot/mlton/mlton/doc/user-guide/extensions.tex,v
retrieving revision 1.65
retrieving revision 1.66
diff -u -r1.65 -r1.66
--- extensions.tex 19 May 2004 00:22:35 -0000 1.65
+++ extensions.tex 1 Jul 2004 17:26:03 -0000 1.66
@@ -172,12 +172,17 @@
\begin{verbatim}
signature MLTON_EXN =
sig
+ val addExnMessager: (exn -> string option) -> unit
val history: exn -> string list
val topLevelHandler: exn -> 'a
end
\end{verbatim}
\begin{description}
+
+\entry{addExnMessager}
+add a pretty-printer to be used by {\tt General.exnMessage} for
+converting exceptions to strings.
\entry{history e}
returns the file positions that have raised the exception {\tt e}, in reverse