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

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

@ -1,4 +1,4 @@
#lang scheme/base
#lang racket/base
(require scheme/match scheme/list scheme/string
(for-syntax scheme/base scheme/match))
@ -18,37 +18,33 @@
(define show
(match-lambda
[(list 'values x) (format "~e" x)]
[(list 'values xs ...) (format "~e" (cons 'values xs))]
[(list 'values x)
(format "~e" x)]
[(list 'values xs ...)
(string-append "(values "
(string-join (map (lambda (x) (format "~e" x)) xs) " ")
")")]
[(list 'error err val)
(cond [(procedure? err) (format "error satisfying ~s" err)]
[(regexp? err) (format "error matching ~s" err)]
[err (format "error: ~a" err)]
[else (format "a raised non-exception ~s" val)])]
[x (format "INTERNAL ERROR, unexpected value: ~s" x)]))
(cond [(procedure? err) (format "error satisfying ~.s" err)]
[(regexp? err) (format "error matching ~.s" err)]
[err (format "error: ~.a" err)]
[else (format "a raised non-exception ~.s" val)])]
[x (format "INTERNAL ERROR, unexpected value: ~.s" x)]))
(define test-context (make-parameter #f))
(define failure-format
(make-parameter
(lambda (prefix qe fmt . args)
(define prefix-str
(apply string-append
(add-between (reverse (list* "" prefix))
" > ")))
(define str
(regexp-replace #rx"\n"
(apply format fmt args)
"\n "))
(format "~atest failure in ~e\n ~a"
prefix-str qe str))))
(regexp-replace #rx"\n" (apply format fmt args) "\n "))
(string-join (reverse (cons (format "test failure in ~.s\n ~a" qe str)
prefix))
" > "))))
(define (make-failure-message msg)
(define str
(regexp-replace #rx"\n" msg "\n "))
(define real-msg
(format "test failure\n ~a" str))
(lambda (prefix qe fmt . args)
real-msg))
(define str (regexp-replace #rx"\n" msg "\n "))
(define real-msg (format "test failure\n ~a" str))
(lambda (prefix qe fmt . args) real-msg))
(define failure-prefix-mark (gensym 'failure-prefix))
(define-syntax (test-thunk stx)
@ -63,8 +59,8 @@
[else "?"])))))
(with-syntax ([e e] [fmt fmt] [(arg ...) args] [loc loc])
#'(let* ([form (failure-format)]
[prefix
(continuation-mark-set->list (current-continuation-marks) failure-prefix-mark)])
[prefix (continuation-mark-set->list (current-continuation-marks)
failure-prefix-mark)])
(error 'loc (form prefix 'e fmt arg ...)))))
(define (t1 x)
#`(let ([x (safe #,x)])
@ -119,15 +115,16 @@
[(list* #:failure-prefix msg r)
(let ([r (tloop r)])
(if (pair? r)
(cons
#`(with-continuation-mark failure-prefix-mark #,msg #,(car r))
(cons #`(with-continuation-mark failure-prefix-mark
#,msg #,(car r))
(cdr r))
r))]
[(list* #:failure-message msg r)
(let ([r (tloop r)])
(if (pair? r)
(cons
#`(parameterize ([failure-format (make-failure-message #,msg)])
#`(parameterize ([failure-format
(make-failure-message #,msg)])
#,(car r))
(cdr r))
r))]