From 12390fb891ee65ed3c83efe074252c7135f78c67 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 5 Aug 2008 11:36:33 +0000 Subject: [PATCH] improvements svn: r11078 --- collects/drscheme/private/module-language.ss | 21 ++- collects/tests/lazy/testing.ss | 183 +++++++++++++++---- 2 files changed, 155 insertions(+), 49 deletions(-) diff --git a/collects/drscheme/private/module-language.ss b/collects/drscheme/private/module-language.ss index 05e21bb84f..871d5ecf21 100644 --- a/collects/drscheme/private/module-language.ss +++ b/collects/drscheme/private/module-language.ss @@ -200,17 +200,20 @@ (λ () (uncaught-exception-handler (λ (e) + (define e1 #f) (uncaught-exception-handler default-handler) - (parameterize ([current-namespace ns]) - (with-handlers ([void (λ (e) (raise-hopeless-syntax-error - "invalid language" lang))]) - (namespace-require (syntax->datum lang))) - (unless (memq '#%top-interaction (namespace-mapped-symbols ns)) - (raise-hopeless-syntax-error - "invalid language (existing module, but no language bindings)" - lang))) + ;; use this to catch the error so it can be raised instead of e + (with-handlers ([void (lambda (e) (set! e1 e))]) + (parameterize ([current-namespace ns]) + (with-handlers ([void (λ (e) (raise-hopeless-syntax-error + "invalid language" lang))]) + (namespace-require (syntax->datum lang))) + (unless (memq '#%top-interaction (namespace-mapped-symbols ns)) + (raise-hopeless-syntax-error + "invalid language (existing module, but no language bindings)" + lang)))) (thread-cell-set! hopeless-repl #f) - (default-handler e)))) + (default-handler (or e1 e))))) module-expr (λ () (uncaught-exception-handler default-handler)) ; restore handler #`(current-module-declare-name #f) diff --git a/collects/tests/lazy/testing.ss b/collects/tests/lazy/testing.ss index 74667001aa..4e93377ad2 100644 --- a/collects/tests/lazy/testing.ss +++ b/collects/tests/lazy/testing.ss @@ -1,6 +1,7 @@ #lang scheme/base -(require (for-syntax scheme/base scheme/match)) +(require scheme/match scheme/list scheme/string + (for-syntax scheme/base scheme/match)) (define-syntax (safe stx) (syntax-case stx () @@ -10,61 +11,163 @@ #'(with-handlers ([exn? (lambda (e) (list 'error (exn-message e)))]) - (cons 'value + (cons 'values (call-with-values (lambda () expr) list))))]) x))])) +(define (show value) + (match value + [(list 'error msg) (format "error: ~a" msg)] + [(list 'values x) (format "~e" x)] + [(list 'values xs ...) (format "~e" value)])) + +(define test-context + (make-parameter + (lambda (num exns) + (if (null? exns) + (printf "~a tests passed\n" num) + (error 'test "~a/~a test failures:~a" (length exns) num + (string-append* + (append-map (lambda (e) (list "\n" (exn-message e))) + (reverse exns)))))))) + +(define-for-syntax (loc stx) + (string->symbol + (format "~a:~a" (syntax-source stx) + (let ([l (syntax-line stx)] [c (syntax-column stx)]) + (cond [(and l c) (format "~a:~a" l c)] + [l l] + [(syntax-position stx) => (lambda (p) (format "#~a" p))] + [else "?"]))))) + (provide test) (define-syntax (test stx) - (define (check test blame fmt . args) - (with-syntax ([test test] [blame blame] [fmt fmt] [(arg ...) args] - [loc (string->symbol - (format "~a:~a:~a" (syntax-source blame) - (syntax-line blame) (syntax-column blame)))]) - #'(unless test - (error 'loc "test failure in ~e\n ~a" 'blame - (format fmt arg ...))))) + (define (blame e fmt . args) + (with-syntax ([e e] [fmt fmt] [(arg ...) args] [loc (loc e)]) + #'(error 'loc "test failure in ~e\n ~a" 'e (format fmt arg ...)))) (define (t1 x) #`(let ([x (safe #,x)]) - #,(check #`(and (eq? 'value (car x)) (cadr x)) x - "expected non-#f, got~a: ~e" - #'(if (eq? 'value (car x)) "" " an error") #'(cadr x)))) + (unless (and (eq? 'values (car x)) (= 2 (length x)) (cadr x)) + #,(blame x "expected non-#f single value; got: ~a" #'(show x))))) (define (t2 x y) - #`(let ([x (safe #,x)] [y #,y]) - #,(check #'(and (eq? 'value (car x)) (equal? (cadr x) y)) x - "expected ~e, got~a: ~e" - #'y #'(if (eq? 'value (car x)) "" " an error") #'(cadr x)))) - (define (te x y) - #`(let ([x (safe #,x)] [y #,y]) - #,(check #'(eq? 'error (car x)) x - "expected an error, got ~e" #'(cadr x)) - #,(check #'(regexp-match? y (cadr x)) x - "bad error message expected ~e, got ~e" #'y #'(cadr x)))) + #`(let ([x (safe #,x)] [y (safe #,y)]) + (cond [(and (eq? 'error (car y)) (eq? 'values (car x))) + #,(blame x "expected an error; got ~a" #'(show x))] + [(and (eq? 'error (car x)) (eq? 'error (car y))) + (unless (regexp-match (regexp-quote (cadr y)) (cadr x)) + #,(blame x "bad error message, expected ~s; got ~s" + #'(cadr y) #'(cadr x)))] + [(not (equal? x y)) + #,(blame x "expected ~a; got: ~a" #'(show y) #'(show x))]))) + (define (te x y) (t2 x #`(error #,y))) + (define (try t . args) + #`(with-handlers ([exn? (lambda (e) (set! exns (cons e exns)))]) + (set! num (add1 num)) + #,(apply t args))) + (define (tb x) + #`(parameterize ([test-context (lambda (n es) + (set! num (+ n num)) + (set! exns (append es exns)))]) + #,x)) (let loop ([xs (map (lambda (x) - (if (memq (syntax-e x) '(=> <= =error> <= =error> list stx)))] [r '()]) (let ([t (match xs - [(list* x '=> y r) (cons (t2 x y) r)] - [(list* y '<= x r) (cons (t2 x y) r)] - [(list* x '=error> y r) (cons (te x y) r)] - [(list* y ' y r) (cons (try t2 x y) r)] + [(list* y '<= x r) (cons (try t2 x y) r)] + [(list* x '=error> y r) (cons (try te x y) r)] + [(list* y ' 3 - (car '()) =error> "expects argument of type" - (if 1) =error> "if: bad syntax" - (test (/ 0)) =error> "expected non-#f" - (test 1 => 2) =error> "expected 2" - (test 1 =error> "") =error> "expected an error" - (test (/ 0) =error> "zzz") =error> "bad error message" - ) +(test + ;; test usage + 1 => 1 + #t + (< 1 2) + (+ 1 2) => 3 + (+ 1 2) <= 3 + ;; multiple values + (values 1) => 1 + (values 1) <= 1 + (quotient/remainder 10 3) => (values 3 1) + ;; runtime errors + (car '()) =error> "expects argument of type" + (car '()) => (error "expects argument of type") + ;; syntax errors + (if 1) =error> "if: bad syntax" + + ;; test `test' errors + (test (/ 0)) =error> "expected non-#f single value" + (test 1 => 2) =error> "expected 2" + (test 1 =error> "") =error> "expected an error" + (test (/ 0) =error> "zzz") =error> "bad error message" + ) + +;; SchemeUnit stuff +;; (examples that should fail modified to ones that shouldn't) +#| + +;; Quick Start example +(define (file-tests) + ;; Tests for file.scm + ;; (=> source location is sufficient, no need for test names in the code) + (test + (+ 1 1) => 2 + (* 1 2) => 2 + ;; List has length 4 and all elements even + do (let ([lst (list 2 4 6 8)]) + (test (length lst) => 4 + do (for ([x lst]) (test (even? x))))))) +(file-tests) + +;; API listing +(test + ;; (check < 2 3) + (< 2 3) + ;; (check-eq? 1 1 "allocated data not eq?") + (eq? 1 1) + ;; (check-not-eq? (list 1) (list 1) "integers are eq?") + (not (eq? (list 1) (list 1))) + ;; (check-eqv? 1.0 1.0 "not eqv?") + (eqv? 1.0 1.0) + ;; (check-equal? 1.0 1.0 "not equal?") + (equal? 1.0 1.0) + 1.0 => 1.0 ; alternative + ;; (check-not-equal? 1 1.0 "equal?") + (not (equal? 1 1.0)) + ;; (check-pred string? "I work") + (string? "I work") + ;; (check-= 1.0 1.001 0.01 "I work") + (< (abs (- 1.0 1.001)) 0.01) + ;; (check-true (< 1 2)) + (eq? #t (< 1 2)) + ;; (check-false (< 2 1)) + (not (< 2 1)) + ;; (check-not-false (< 1 2)) + (< 1 2) + ;; (check-exn exn? + ;; (lambda () + ;; (raise (make-exn "Hi there" + ;; (current-continuation-marks))))) + (raise (make-exn "Hi there" (current-continuation-marks))) + =error> "" + ;; (check-not-exn (lambda () 1)) + (void 1) + ;; (fail) + ;; (error "foo") -> no real equivalent, since `fail' doesn't throw an error + ;; (check-regexp-match "a+bba" "aaaaaabba") + (regexp-match "a+bba" "aaaaaabba") + ) +|#