suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

improvements

Browse Source 
svn: r11078
This commit is contained in:
Eli Barzilay 2008-08-05 11:36:33 +00:00
parent f6037ca1c6
commit 12390fb891
2 changed files with 155 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
collects/drscheme/private/module-language.ss
View File

@ -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)

183
collects/tests/lazy/testing.ss
View File

@ -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=))
(if (memq (syntax-e x) '(do => <= =error> <error=))
(syntax-e x) x))
(cdr (syntax->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 '<error= x r) (cons (te x y) r)]
[(list* x r) (cons (t1 x) r)]
[(list* 'do x r) (cons (tb x) r)]
[(list* x '=> 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 '<error= x r) (cons (try te x y) r)]
[(list* x r) (cons (try t1 x) r)]
[(list) '()])])
(if (pair? t)
(loop (cdr t) (cons (car t) r))
#`(begin #,@(reverse r))))))
#`(let ([num 0] [exns '()])
#,@(reverse r)
((test-context) num exns))))))
;; test the `test' macro
#; ;; test the `test' macro
(test (< 1 2)
(+ 1 2) => 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")
)
|#