From 6f4c16479388622be04f85f1901035b3b450bb39 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Mon, 1 Feb 2010 15:39:33 +0000
Subject: [PATCH] improved the implementation of error in the teaching
 languages, added test casees

svn: r17923
---
 collects/lang/private/beginner-funs.ss |  2 +-
 collects/lang/private/teachprims.ss    | 28 ++++++++------------------
 collects/tests/mzscheme/beg-adv.ss     |  9 +++++++++
 collects/tests/mzscheme/htdp-test.ss   |  2 +-
 4 files changed, 19 insertions(+), 22 deletions(-)

diff --git a/collects/lang/private/beginner-funs.ss b/collects/lang/private/beginner-funs.ss
index 35b4ced974..6b8313f0a0 100644
--- a/collects/lang/private/beginner-funs.ss
+++ b/collects/lang/private/beginner-funs.ss
@@ -468,7 +468,7 @@
     ("Misc"
       (identity (any -> any)
 	"to return the argument unchanged")
-      ((beginner-error error) (any ... -> void) "to signal an error, turning the given values into an error message ")
+      ((beginner-error error) (any ... -> void) "to signal an error, combining the given values into an error message.\n\nIf any of the values' printed representations is too long, it is truncated and ``...'' is put into the string. If the first value is a symbol, it is treated specially; it is suffixed with a colon and a space (the intention is that the symbol is the name of the function signalling the error).")
       ((beginner-struct? struct?) (any -> boolean)
        "to determine whether some value is a structure")
       ((beginner-equal? equal?) (any any -> boolean)
diff --git a/collects/lang/private/teachprims.ss b/collects/lang/private/teachprims.ss
index 83d9800aa9..e1c1be29e0 100644
--- a/collects/lang/private/teachprims.ss
+++ b/collects/lang/private/teachprims.ss
@@ -2,7 +2,7 @@
 collects/tests/mzscheme/beginner.ss
                     .../beginner-abbr.ss
                     .../intermediate.ss
-                    .../intermediate-lam.ss
+                    .../intermediate-lambda.ss
                     .../advanced.ss
 
 Each one has to run separately, since they mangle the top-level
@@ -197,25 +197,13 @@ namespace.
       (if (and (cons? stuff0) (symbol? (first stuff0)))
           (values (first stuff0) (rest stuff0))
           (values false stuff0)))
-    (define str
-      (let loop ([stuff stuff1][frmt ""][pieces '()])
-        (cond
-          [(empty? stuff) (apply format frmt (reverse pieces))]
-          [else 
-           (let ([f (first stuff)]
-                 [r (rest stuff)])
-             (if (string? f)
-                 (loop r (string-append frmt f) pieces)
-                 (loop r (string-append frmt "~e") (cons f pieces))))])))
-    (if f (error f str) (error str)))
-  #;
-  (lambda (str)
-    (unless (string? str)
-      (raise
-       (make-exn:fail:contract
-        (format "error: expected a string, got ~e and ~e" str)
-        (current-continuation-marks))))
-    (error str)))
+    (error (apply
+            string-append
+            (if f (format "~a: " f) "")
+            (for/list ([ele (in-list stuff1)])
+              (if (string? ele)
+                  ele
+                  (format "~e" ele)))))))
 
 (define-teach beginner struct?
   (lambda (x)
diff --git a/collects/tests/mzscheme/beg-adv.ss b/collects/tests/mzscheme/beg-adv.ss
index 7789e80e39..edfe0e1a0e 100644
--- a/collects/tests/mzscheme/beg-adv.ss
+++ b/collects/tests/mzscheme/beg-adv.ss
@@ -387,6 +387,15 @@
 (htdp-test false 'string-lower-case? (string-lower-case? "ab\t"))
 (htdp-test true 'string-lower-case? (string-lower-case? "abc"))
 
+(htdp-err/rt-test (error "a" "a") #rx"^aa$")
+(htdp-err/rt-test (error 'a "a") #rx"^a: a$")
+(htdp-err/rt-test (error "This is" " an err" "or" " message with a number: " 5)
+                  #rx"^This is an error message with a number: 5$")
+(htdp-err/rt-test (error "several numbers " 1 2 3 4 5 6 7)
+                  #rx"^several numbers 1234567$")
+(htdp-err/rt-test (error "several numbers " 1 " 2 " 3 " 4")
+                  #rx"^several numbers 1 2 3 4$")
+
 (htdp-top (require scheme/match))
 (htdp-test 17 'match (match 'x ['x 17]))
 (htdp-test 'x 'match (match 'x ['y 17][z z]))
diff --git a/collects/tests/mzscheme/htdp-test.ss b/collects/tests/mzscheme/htdp-test.ss
index 2fb33f8062..afa4284440 100644
--- a/collects/tests/mzscheme/htdp-test.ss
+++ b/collects/tests/mzscheme/htdp-test.ss
@@ -94,7 +94,7 @@
      #'(void)]))
 
 (define (htdp-string-to-pred exn?/rx)
-  (if (string? exn?/rx)
+  (if (or (regexp? exn?/rx) (string? exn?/rx))
       (lambda (x)
 	(regexp-match exn?/rx (exn-message x)))
       exn?/rx))