(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 ) check-within ;; syntax : (check-within ) check-error ;; syntax : (check-error ) 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, 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 (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)))) )