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

Switch to `racket/base', change some "~e"s to "~.s"s, also reformat and

Browse Source 
a few minor improvements.
This commit is contained in:
Eli Barzilay 2010-08-25 13:56:42 -04:00
parent f04a60da61
commit e179449d0e
1 changed files with 34 additions and 37 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

71
collects/tests/eli-tester.rkt
View File

@ -1,4 +1,4 @@
#lang scheme/base #lang racket/base
(require scheme/match scheme/list scheme/string (require scheme/match scheme/list scheme/string
(for-syntax scheme/base scheme/match)) (for-syntax scheme/base scheme/match))
@ -18,37 +18,33 @@
(define show (define show
(match-lambda (match-lambda
[(list 'values x) (format "~e" x)] [(list 'values x)
[(list 'values xs ...) (format "~e" (cons 'values xs))] (format "~e" x)]
[(list 'values xs ...)
(string-append "(values "
(string-join (map (lambda (x) (format "~e" x)) xs) " ")
")")]
[(list 'error err val) [(list 'error err val)
(cond [(procedure? err) (format "error satisfying ~s" err)] (cond [(procedure? err) (format "error satisfying ~.s" err)]
[(regexp? err) (format "error matching ~s" err)] [(regexp? err) (format "error matching ~.s" err)]
[err (format "error: ~a" err)] [err (format "error: ~.a" err)]
[else (format "a raised non-exception ~s" val)])] [else (format "a raised non-exception ~.s" val)])]
[x (format "INTERNAL ERROR, unexpected value: ~s" x)])) [x (format "INTERNAL ERROR, unexpected value: ~.s" x)]))
(define test-context (make-parameter #f)) (define test-context (make-parameter #f))
(define failure-format (define failure-format
(make-parameter (make-parameter
(lambda (prefix qe fmt . args) (lambda (prefix qe fmt . args)
(define prefix-str (define str
(apply string-append (regexp-replace #rx"\n" (apply format fmt args) "\n "))
(add-between (reverse (list* "" prefix)) (string-join (reverse (cons (format "test failure in ~.s\n ~a" qe str)
" > "))) prefix))
(define str " > "))))
(regexp-replace #rx"\n"
(apply format fmt args)
"\n "))
(format "~atest failure in ~e\n ~a"
prefix-str qe str))))
(define (make-failure-message msg) (define (make-failure-message msg)
(define str (define str (regexp-replace #rx"\n" msg "\n "))
(regexp-replace #rx"\n" msg "\n ")) (define real-msg (format "test failure\n ~a" str))
(define real-msg (lambda (prefix qe fmt . args) real-msg))
(format "test failure\n ~a" str))
(lambda (prefix qe fmt . args)
real-msg))
(define failure-prefix-mark (gensym 'failure-prefix)) (define failure-prefix-mark (gensym 'failure-prefix))
(define-syntax (test-thunk stx) (define-syntax (test-thunk stx)
@ -63,8 +59,8 @@
[else "?"]))))) [else "?"])))))
(with-syntax ([e e] [fmt fmt] [(arg ...) args] [loc loc]) (with-syntax ([e e] [fmt fmt] [(arg ...) args] [loc loc])
#'(let* ([form (failure-format)] #'(let* ([form (failure-format)]
[prefix [prefix (continuation-mark-set->list (current-continuation-marks)
(continuation-mark-set->list (current-continuation-marks) failure-prefix-mark)]) failure-prefix-mark)])
(error 'loc (form prefix 'e fmt arg ...))))) (error 'loc (form prefix 'e fmt arg ...)))))
(define (t1 x) (define (t1 x)
#`(let ([x (safe #,x)]) #`(let ([x (safe #,x)])
@ -73,7 +69,7 @@
#'(show x))))) #'(show x)))))
(define (t2 x y [eval2? #t]) (define (t2 x y [eval2? #t])
#`(let* ([x (safe #,x)] [xtag (car x)] #`(let* ([x (safe #,x)] [xtag (car x)]
[y #,(if eval2? #`(safe #,y) y)] [ytag (car y)]) [y #,(if eval2? #`(safe #,y) y)] [ytag (car y)])
(cond (cond
[(eq? ytag 'values) [(eq? ytag 'values)
(unless (equal? x y) (unless (equal? x y)
@ -119,15 +115,16 @@
[(list* #:failure-prefix msg r) [(list* #:failure-prefix msg r)
(let ([r (tloop r)]) (let ([r (tloop r)])
(if (pair? r) (if (pair? r)
(cons (cons #`(with-continuation-mark failure-prefix-mark
#`(with-continuation-mark failure-prefix-mark #,msg #,(car r)) #,msg #,(car r))
(cdr r)) (cdr r))
r))] r))]
[(list* #:failure-message msg r) [(list* #:failure-message msg r)
(let ([r (tloop r)]) (let ([r (tloop r)])
(if (pair? r) (if (pair? r)
(cons (cons
#`(parameterize ([failure-format (make-failure-message #,msg)]) #`(parameterize ([failure-format
(make-failure-message #,msg)])
#,(car r)) #,(car r))
(cdr r)) (cdr r))
r))] r))]
@ -188,7 +185,7 @@
(car '()) => (error "expects argument of type") (car '()) => (error "expects argument of type")
;; syntax errors ;; syntax errors
(if 1) =error> "if: bad syntax" (if 1) =error> "if: bad syntax"
;; error (and non-exception raises) predicates ;; error (and non-exception raises) predicates
(+ 1 "2") =error> exn:fail:contract? (+ 1 "2") =error> exn:fail:contract?
(+ 1 "2") =error> (lambda (x) (not (exn:fail:filesystem? x))) (+ 1 "2") =error> (lambda (x) (not (exn:fail:filesystem? x)))
@ -196,7 +193,7 @@
(error "1") =error> exn? (error "1") =error> exn?
(raise 1) =error> number? (raise 1) =error> number?
(raise "1") =error> string? (raise "1") =error> string?
;; test `test' errors ;; test `test' errors
(test* (/ 0)) =error> "expected: non-#f single value" (test* (/ 0)) =error> "expected: non-#f single value"
(test* 1 => 2) =error> "expected: 2" (test* 1 => 2) =error> "expected: 2"
@ -206,7 +203,7 @@
(test* #:failure-message "FOO" (/ 0) => 1) =error> "FOO" (test* #:failure-message "FOO" (/ 0) => 1) =error> "FOO"
(test* #:failure-message "FOO" (/ 0)) =error> "FOO" (test* #:failure-message "FOO" (/ 0)) =error> "FOO"
(test* #:failure-prefix "FOO" (/ 0)) =error> "FOO" (test* #:failure-prefix "FOO" (/ 0)) =error> "FOO"
;; test possitive message ;; test possitive message
(let ([o (open-output-bytes)]) (let ([o (open-output-bytes)])
(list (begin (parameterize ([current-output-port o]) (test* 1 => 1)) (list (begin (parameterize ([current-output-port o]) (test* 1 => 1))