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

61
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
(apply string-append
(add-between (reverse (list* "" prefix))
" > ")))
(define str (define str
(regexp-replace #rx"\n" (regexp-replace #rx"\n" (apply format fmt args) "\n "))
(apply format fmt args) (string-join (reverse (cons (format "test failure in ~.s\n ~a" qe str)
"\n ")) prefix))
(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))]