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

testing added

Browse Source 
svn: r5222
This commit is contained in:
Matthias Felleisen 2007-01-04 22:31:35 +00:00
parent 5cc51c18dd
commit 271897e467
1 changed files with 264 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

264
collects/htdp/testing.scm Normal file
View File

@ -0,0 +1,264 @@
(module testing mzscheme
(require (lib "teachprims.ss" "lang" "private")
(lib "mred.ss" "mred")
(lib "framework.ss" "framework")
(lib "class.ss"))
(provide
check-expect ;; syntax : (check-expect <expression> <expression>)
check-within ;; syntax : (check-within <expression> <expression> <expression>)
check-error ;; syntax : (check-error <expression> <expression>)
generate-report ;; -> true
)
(define INEXACT-NUMBERS-FMT
"check-expect cannot compare inexact numbers. Try (check-within test ~a range).")
(define CHECK-ERROR-STR-FMT
"check-error requires a string for the second argument, representing the expected error message. Given ~s")
(define CHECK-WITHIN-INEXACT-FMT
"check-within requires an inexact number for the range. ~a is not inexact.")
(define-for-syntax CHECK-EXPECT-STR
"check-expect requires two expressions. Try (check-expect test expected).")
(define-for-syntax CHECK-ERROR-STR
"check-error requires two expressions. Try (check-error test message).")
(define-for-syntax CHECK-WITHIN-STR
"check-within requires three expressions. Try (check-within test expected range).")
;(make-src (U editor file-name) int int int)
(define-struct src (file line col pos span))
(define-struct check-fail (src))
;(make-unexpected-error src string)
(define-struct (unexpected-error check-fail) (expected message))
;(make-unequal src scheme-val scheme-val)
(define-struct (unequal check-fail) (test actual))
;(make-outofrange src scheme-val scheme-val inexact)
(define-struct (outofrange check-fail) (test actual range))
;(make-incorrect-error src string)
(define-struct (incorrect-error check-fail) (expected message))
;(make-expected-error src string scheme-val)
(define-struct (expected-error check-fail) (message value))
(define-syntax (check-expect stx)
(syntax-case stx ()
((_ test actual)
#`(define #,(gensym 'test)
(check-values-expected
(lambda () test) actual (make-src #,@(list (syntax-source stx)
(syntax-line stx)
(syntax-column stx)
(syntax-position stx)
(syntax-span stx))))))
((_ test)
(raise-syntax-error 'check-expect CHECK-EXPECT-STR))
((_ test actual extra ...)
(raise-syntax-error 'check-expect CHECK-EXPECT-STR))))
;check-values-expected: (-> scheme-val) scheme-val src -> void
(define (check-values-expected test actual src)
(error-check (lambda (v) (if (number? v) (exact? v) #t))
actual INEXACT-NUMBERS-FMT)
(update-num-checks)
(run-and-check (lambda (v1 v2 _) (beginner-equal? v1 v2))
(lambda (src v1 v2 _) (make-unequal src v1 v2))
test actual #f src))
(define-syntax (check-within stx)
(syntax-case stx ()
((_ test actual within)
#`(define #,(gensym 'test-within)
(check-values-within (lambda () test) actual within
(make-src #,@(list (syntax-source stx)
(syntax-line stx)
(syntax-column stx)
(syntax-position stx)
(syntax-span stx))))))
((_ test actual)
(raise-syntax-error 'check-within CHECK-WITHIN-STR))
((_ test)
(raise-syntax-error 'check-within CHECK-WITHIN-STR))
((_ test actual within extra ...)
(raise-syntax-error 'check-within CHECK-WITHIN-STR))))
(define (check-values-within test actual within src)
(error-check number? within CHECK-WITHIN-INEXACT-FMT)
(update-num-checks)
(run-and-check beginner-equal~? make-outofrange test actual within src))
(define-syntax (check-error stx)
(syntax-case stx ()
((_ test error)
#`(define #,(gensym 'test-error)
(check-values-error (lambda () test) error (make-src #,@(list (syntax-source stx)
(syntax-line stx)
(syntax-column stx)
(syntax-position stx)
(syntax-span stx))))))
((_ test)
(raise-syntax-error 'check-error CHECK-ERROR-STR))))
(define (check-values-error test error src)
(error-check string? error CHECK-ERROR-STR-FMT)
(update-num-checks)
(let ([result (with-handlers ((exn?
(lambda (e)
(or (equal? (exn-message e) error)
(make-incorrect-error src error (exn-message e))))))
(let ([test-val (test)])
(make-expected-error src error test-val)))])
(when (check-fail? result) (update-failed-checks result))))
(define (error-check pred? actual fmt)
(unless (pred? actual)
(raise (make-exn:fail:contract (string->immutable-string (format fmt actual))
(current-continuation-marks)))))
;run-and-check: (scheme-val scheme-val scheme-val -> boolean)
; (scheme-val scheme-val scheme-val -> check-fail)
; ( -> scheme-val) scheme-val scheme-val -> void
(define (run-and-check check maker test expect range src)
(let ([result
(with-handlers ((exn? (lambda (e) (make-unexpected-error src expect (exn-message e)))))
(let ([test-val (test)])
(or (check test-val expect range)
(maker src test-val expect range))))])
(when (check-fail? result) (update-failed-checks result))))
(define (update-num-checks) (set! num-checks (add1 num-checks)))
(define num-checks 0)
(define failed-check null)
(define (update-failed-checks failure) (set! failed-check (cons failure failed-check)))
(define (generate-report)
(let* ([num-failed-tests (length failed-check)]
[my-text (new (editor:standard-style-list-mixin text%))]
[my-frame (new frame% [label "Test Results"][width 300] [height 200])]
[my-editor (new editor-canvas% [editor my-text] [parent my-frame]
[style '(auto-hscroll auto-vscroll)])])
(send my-text insert
(format "Recorded ~a check~a. ~a"
num-checks
(if (= 1 num-checks) "" "s")
(if (= num-failed-tests 0)
"All checks succeeded!"
(format "~a check~a failed."
num-failed-tests (if (= 1 num-failed-tests) "" "s")))))
(unless (null? failed-check)
(send my-text insert "\n")
(for-each (lambda (f) (report-check-failure f my-text))
(reverse failed-check))
(send my-frame resize
(min (+ 300 (* 3 (send my-text line-end-position num-failed-tests #f))) 900)
(min (+ 200 (* 5 num-failed-tests)) 900)))
(printf "~a~n" (send my-text line-end-position num-failed-tests #f))
(send my-text move-position 'home)
(send my-text lock #t)
(send my-frame show #t)
#t))
(define (report-check-failure fail text)
(make-link text (check-fail-src fail))
(send text insert "\n ")
(cond
[(unexpected-error? fail)
(send text insert "check encountered the following error instead of the expected value ")
(insert-value text (unexpected-error-expected fail))
(send text insert (format ". ~n :: ~a~n" (unexpected-error-message fail)))]
[(unequal? fail)
(send text insert "Actual value ")
(insert-value text (unequal-test fail))
(send text insert " was not equal to expected value ")
(insert-value text (unequal-actual fail))
(send text insert ".\n")]
[(outofrange? fail)
(send text insert "Actual value ")
(insert-value text (outofrange-test fail))
(send text insert (format "was not within ~v of expected value " (outofrange-range fail)))
(insert-value text (outofrange-actual fail))
(send text insert ".\n")]
[(incorrect-error? fail)
(send text insert
(format "check-error encountered the following error instead of the expected ~a~n :: ~a ~n"
(incorrect-error-expected fail) (incorrect-error-message fail)))]
[(expected-error? fail)
(send text insert "check-error expected the following error, instead received value ")
(insert-value text (expected-error-value fail))
(send text insert (format ".~n ~a~n" (expected-error-message fail)))]))
(define (insert-value text value)
(send text insert
(if (is-a? value snip%)
(begin
(send value set-style (send (send text get-style-list)
find-named-style "Standard"))
value)
(format "~v" value))))
;make-link: text% (listof (U string snip%)) src -> void
(define (make-link text dest)
(let ((start (send text get-end-position)))
(send text insert "check failed ")
(send text insert (format-src dest))
(send text set-clickback
start (send text get-end-position)
(lambda (t s e)
(open-and-highlight-in-file dest))
#f #f)
(let ((end (send text get-end-position))
(c (new style-delta%)))
(send text insert " ")
(send text change-style (make-object style-delta% 'change-underline #t)
start end #f)
(send c set-delta-foreground "royalblue")
(send text change-style c start end #f))))
(define (open-and-highlight-in-file srcloc)
(let* ([position (src-pos srcloc)]
[span (src-span srcloc)]
[rep/ed (get-editor srcloc #t)])
(when rep/ed
(let ((highlight
(lambda ()
(send (car rep/ed) highlight-error (cadr rep/ed) position (+ position span)))))
(queue-callback highlight)))))
(define (get-editor src rep?)
(let* ([source (src-file src)]
[frame (cond
[(path? source) (handler:edit-file source)]
[(is-a? source editor<%>)
(let ([canvas (send source get-canvas)])
(and canvas
(send canvas get-top-level-window)))])]
[editor (cond
[(path? source)
(cond
[(and frame (is-a? frame #;drscheme:unit:frame<%>))
(send frame get-definitions-text)]
[(and frame (is-a? frame frame:editor<%>))
(send frame get-editor)]
[else #f])]
[(is-a? source editor<%>) source])]
[rep (and frame
#;(is-a? frame drscheme:unit:frame%)
(send frame get-interactions-text))])
(when frame
(unless (send frame is-shown?) (send frame show #t)))
(if (and rep? rep editor)
(list rep editor)
(and rep editor))))
(define (format-src src)
(string-append (cond
((path? (src-file src)) (string-append "in " (src-file src) " at "))
((is-a? (src-file src) editor<%>) "at "))
"line " (number->string (src-line src))
" column " (number->string (src-col src))))
)