276 lines
12 KiB
Scheme
276 lines
12 KiB
Scheme
(module testing mzscheme
|
|
|
|
(require (lib "teachprims.ss" "lang" "private")
|
|
(lib "mred.ss" "mred")
|
|
(lib "framework.ss" "framework")
|
|
(lib "pretty.ss")
|
|
(lib "pconvert.ss")
|
|
(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 (* 5 (send my-text line-end-position num-failed-tests #f))) 1000)
|
|
(min (+ 200 (* 5 num-failed-tests)) 1000)))
|
|
(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 " differs from ")
|
|
(insert-value text (unequal-actual fail))
|
|
(send text insert ", the expected value.\n")]
|
|
[(outofrange? fail)
|
|
(send text insert "Actual value ")
|
|
(insert-value text (outofrange-test fail))
|
|
(send text insert (format " is 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, but instead received the 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
|
|
(cond
|
|
[(is-a? value snip%)
|
|
(send value set-style (send (send text get-style-list)
|
|
find-named-style "Standard"))
|
|
value]
|
|
[(or (pair? value) (struct? value))
|
|
(parameterize ([constructor-style-printing #t]
|
|
[pretty-print-columns 40])
|
|
(let* ([text* (new (editor:standard-style-list-mixin text%))]
|
|
[text-snip (new editor-snip% [editor text*])])
|
|
(pretty-print (print-convert value) (open-output-text-editor text*))
|
|
(send text* lock #t)
|
|
(send text-snip set-style (send (send text get-style-list)
|
|
find-named-style "Standard"))
|
|
text-snip))]
|
|
[else (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 " (path->string (src-file src)) " at "))
|
|
((is-a? (src-file src) editor<%>) "at "))
|
|
"line " (number->string (src-line src))
|
|
" column " (number->string (src-col src))))
|
|
|
|
|
|
)
|