[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