scheme -> racket in test-engine
This commit is contained in:
Sam Tobin-Hochstadt
parent
e74e929a92
commit
84eae2b5e3
57
collects/test-engine/racket-gui.rkt
Normal file
57
collects/test-engine/racket-gui.rkt
Normal file
|
|
@ -0,0 +1,57 @@
|
|||
(module scheme-gui scheme/base
|
||||
|
||||
(require mred framework scheme/class
|
||||
mzlib/pconvert mzlib/pretty
|
||||
(for-syntax scheme/base))
|
||||
|
||||
(require (except-in "scheme-tests.ss" test) "test-display.scm")
|
||||
|
||||
(define (make-formatter printer)
|
||||
(lambda (value)
|
||||
(let* ([text* (new (editor:standard-style-list-mixin text%))]
|
||||
[text-snip (new editor-snip% [editor text*])])
|
||||
(printer value (open-output-text-editor text* 0))
|
||||
(send text* delete (send text* get-end-position) 'back)
|
||||
(send text* lock #t)
|
||||
text-snip)))
|
||||
|
||||
(define (format-value value)
|
||||
(parameterize ([constructor-style-printing #t]
|
||||
[pretty-print-columns 40])
|
||||
(make-formatter (lambda (v o) (pretty-print (print-convert v) o)))))
|
||||
|
||||
#;(define (format-value value)
|
||||
(cond
|
||||
[(is-a? value snip%) 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)
|
||||
text-snip))]
|
||||
[else (format "~v" value)]))
|
||||
|
||||
(define (test*)
|
||||
(run-tests)
|
||||
(pop-up))
|
||||
|
||||
(define-syntax (test stx)
|
||||
(syntax-case stx ()
|
||||
[(_)
|
||||
(syntax-property
|
||||
#'(test*)
|
||||
'test-call #t)]))
|
||||
|
||||
(define (pop-up)
|
||||
(let ([test-info (namespace-variable-value 'test~object #f builder (current-namespace))])
|
||||
(parameterize ([test-format format-value])
|
||||
(and test-info
|
||||
(send test-info refine-display-class test-display%)
|
||||
(send test-info setup-display #f #f)
|
||||
(send test-info summarize-results (current-output-port))))))
|
||||
|
||||
(provide test format-value make-formatter (all-from-out "scheme-tests.ss"))
|
||||
|
||||
)
|
||||
369
collects/test-engine/racket-tests.rkt
Normal file
369
collects/test-engine/racket-tests.rkt
Normal file
|
|
@ -0,0 +1,369 @@
|
|||
#lang mzscheme
|
||||
|
||||
(require lang/private/teachprims
|
||||
scheme/class
|
||||
scheme/match
|
||||
(only scheme/base for memf)
|
||||
"test-engine.scm"
|
||||
"test-info.scm"
|
||||
)
|
||||
|
||||
(require-for-syntax stepper/private/shared)
|
||||
|
||||
(provide
|
||||
check-expect ;; syntax : (check-expect <expression> <expression>)
|
||||
check-within ;; syntax : (check-within <expression> <expression> <expression>)
|
||||
check-member-of ;; syntax : (check-member-of <expression> <expression>)
|
||||
check-range ;; syntax : (check-range <expression> <expression> <expression>)
|
||||
check-error ;; syntax : (check-error <expression> <expression>)
|
||||
)
|
||||
|
||||
; for other modules implementing check-expect-like forms
|
||||
(provide
|
||||
(for-syntax check-expect-maker))
|
||||
|
||||
(define INEXACT-NUMBERS-FMT
|
||||
"check-expect cannot compare inexact numbers. Try (check-within test ~a range).")
|
||||
(define FUNCTION-FMT
|
||||
"check-expect cannot compare functions.")
|
||||
(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 CHECK-WITHIN-FUNCTION-FMT
|
||||
"check-within cannot compare functions.")
|
||||
(define LIST-FMT
|
||||
"check-member-of requires a list for the second argument, containing the possible outcomes. Given ~s")
|
||||
(define CHECK-MEMBER-OF-FUNCTION-FMT
|
||||
"check-member-of cannot compare functions.")
|
||||
(define RANGE-MIN-FMT
|
||||
"check-range requires a number for the minimum value. Given ~a")
|
||||
(define RANGE-MAX-FMT
|
||||
"check-range requires a number for the maximum value. Given ~a")
|
||||
(define CHECK-RANGE-FUNCTION-FMT
|
||||
"check-range cannot compare functions.")
|
||||
|
||||
|
||||
(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).")
|
||||
(define-for-syntax CHECK-MEMBER-OF-STR
|
||||
"check-member-of requires at least two expressions. Try (check-member-of test option options ...).")
|
||||
(define-for-syntax CHECK-RANGE-STR
|
||||
"chech-range requires three expressions. Try (check-range test min max).")
|
||||
|
||||
(define-for-syntax CHECK-EXPECT-DEFN-STR
|
||||
"found a test that is not at the top level")
|
||||
(define-for-syntax CHECK-WITHIN-DEFN-STR
|
||||
CHECK-EXPECT-DEFN-STR)
|
||||
(define-for-syntax CHECK-ERROR-DEFN-STR
|
||||
CHECK-EXPECT-DEFN-STR)
|
||||
|
||||
;; check-expect-maker : syntax? syntax? (listof syntax?) symbol? -> syntax?
|
||||
;; the common part of all three test forms.
|
||||
(define-for-syntax (check-expect-maker
|
||||
stx checker-proc-stx test-expr embedded-stxes hint-tag)
|
||||
(define bogus-name
|
||||
(stepper-syntax-property #`#,(gensym 'test) 'stepper-hide-completed #t))
|
||||
(define src-info
|
||||
(with-stepper-syntax-properties (['stepper-skip-completely #t])
|
||||
#`(list #,@(list #`(quote #,(syntax-source stx))
|
||||
(syntax-line stx)
|
||||
(syntax-column stx)
|
||||
(syntax-position stx)
|
||||
(syntax-span stx)))))
|
||||
(if (eq? 'module (syntax-local-context))
|
||||
#`(define #,bogus-name
|
||||
#,(stepper-syntax-property
|
||||
#`(let ([test-info (namespace-variable-value
|
||||
'test~object #f builder (current-namespace))])
|
||||
(when test-info
|
||||
(insert-test test-info
|
||||
(lambda ()
|
||||
#,(with-stepper-syntax-properties
|
||||
(['stepper-hint hint-tag]
|
||||
['stepper-hide-reduction #t]
|
||||
['stepper-use-val-as-final #t])
|
||||
(quasisyntax/loc stx
|
||||
(#,checker-proc-stx
|
||||
#,(with-stepper-syntax-properties
|
||||
(['stepper-hide-reduction #t])
|
||||
#`(car
|
||||
#,(with-stepper-syntax-properties
|
||||
(['stepper-hide-reduction #t])
|
||||
#`(list
|
||||
(lambda () #,test-expr)
|
||||
#,(syntax/loc stx (void))))))
|
||||
#,@embedded-stxes
|
||||
#,src-info
|
||||
#,(with-stepper-syntax-properties
|
||||
(['stepper-no-lifting-info #t]
|
||||
['stepper-hide-reduction #t])
|
||||
#'test-info))))))))
|
||||
'stepper-skipto
|
||||
(append skipto/third ;; let
|
||||
skipto/third skipto/second ;; unless (it expands into a begin)
|
||||
skipto/cdr skipto/third ;; application of insert-test
|
||||
'(syntax-e cdr cdr syntax-e car) ;; lambda
|
||||
)))
|
||||
#`(begin
|
||||
(let ([test-info (namespace-variable-value
|
||||
'test~object #f builder (current-namespace))])
|
||||
(when test-info
|
||||
(begin
|
||||
(send test-info reset-info)
|
||||
(insert-test test-info
|
||||
(lambda ()
|
||||
#,(with-stepper-syntax-properties
|
||||
(['stepper-hint hint-tag]
|
||||
['stepper-hide-reduction #t]
|
||||
['stepper-use-val-as-final #t])
|
||||
(quasisyntax/loc stx
|
||||
(#,checker-proc-stx
|
||||
#,(with-stepper-syntax-properties
|
||||
(['stepper-hide-reduction #t])
|
||||
#`(car
|
||||
#,(with-stepper-syntax-properties
|
||||
(['stepper-hide-reduction #t])
|
||||
#`(list
|
||||
(lambda () #,test-expr)
|
||||
#,(syntax/loc stx (void))))))
|
||||
#,@embedded-stxes
|
||||
#,src-info
|
||||
#,(with-stepper-syntax-properties
|
||||
(['stepper-no-lifting-info #t]
|
||||
['stepper-hide-reduction #t])
|
||||
#'test-info)))))))))
|
||||
(test))))
|
||||
|
||||
(define-for-syntax (check-context?)
|
||||
(let ([c (syntax-local-context)])
|
||||
(memq c '(module top-level))))
|
||||
|
||||
;; check-expect
|
||||
(define-syntax (check-expect stx)
|
||||
(unless (check-context?)
|
||||
(raise-syntax-error 'check-expect CHECK-EXPECT-DEFN-STR stx))
|
||||
(syntax-case stx ()
|
||||
[(_ test actual)
|
||||
(check-expect-maker stx #'check-values-expected #`test (list #`actual)
|
||||
'comes-from-check-expect)]
|
||||
[_ (raise-syntax-error 'check-expect CHECK-EXPECT-STR stx)]))
|
||||
|
||||
;; check-values-expected: (-> scheme-val) scheme-val src test-object -> void
|
||||
(define (check-values-expected test actual src test-info)
|
||||
(error-check (lambda (v) (if (number? v) (exact? v) #t))
|
||||
actual INEXACT-NUMBERS-FMT #t)
|
||||
(error-check (lambda (v) (not (procedure? v))) actual FUNCTION-FMT #f)
|
||||
(send (send test-info get-info) add-check)
|
||||
(run-and-check (lambda (v1 v2 _) (beginner-equal? v1 v2))
|
||||
(lambda (src format v1 v2 _) (make-unequal src format v1 v2))
|
||||
test actual #f src test-info 'check-expect))
|
||||
|
||||
;;check-within
|
||||
(define-syntax (check-within stx)
|
||||
(unless (check-context?)
|
||||
(raise-syntax-error 'check-within CHECK-WITHIN-DEFN-STR stx))
|
||||
(syntax-case stx ()
|
||||
[(_ test actual within)
|
||||
(check-expect-maker stx #'check-values-within #`test (list #`actual #`within)
|
||||
'comes-from-check-within)]
|
||||
[_ (raise-syntax-error 'check-within CHECK-WITHIN-STR stx)]))
|
||||
|
||||
;; check-values-within: (-> scheme-val) scheme-val number src test-object -> void
|
||||
(define (check-values-within test actual within src test-info)
|
||||
(error-check number? within CHECK-WITHIN-INEXACT-FMT #t)
|
||||
(error-check (lambda (v) (not (procedure? v))) actual CHECK-WITHIN-FUNCTION-FMT #f)
|
||||
(send (send test-info get-info) add-check)
|
||||
(run-and-check beginner-equal~? make-outofrange test actual within src
|
||||
test-info
|
||||
'check-within))
|
||||
|
||||
;; check-error
|
||||
(define-syntax (check-error stx)
|
||||
(unless (check-context?)
|
||||
(raise-syntax-error 'check-error CHECK-ERROR-DEFN-STR stx))
|
||||
(syntax-case stx ()
|
||||
[(_ test error)
|
||||
(check-expect-maker stx #'check-values-error #`test (list #`error)
|
||||
'comes-from-check-error)]
|
||||
[_ (raise-syntax-error 'check-error CHECK-ERROR-STR stx)]))
|
||||
|
||||
;; check-values-error: (-> scheme-val) scheme-val src test-object -> void
|
||||
(define (check-values-error test error src test-info)
|
||||
(error-check string? error CHECK-ERROR-STR-FMT #t)
|
||||
(send (send test-info get-info) add-check)
|
||||
(let ([result (with-handlers ([exn?
|
||||
(lambda (e)
|
||||
(or (equal? (exn-message e) error)
|
||||
(make-incorrect-error src (test-format) error
|
||||
(exn-message e) e)))])
|
||||
(let ([test-val (test)])
|
||||
(make-expected-error src (test-format) error test-val)))])
|
||||
(if (check-fail? result)
|
||||
(begin
|
||||
(send (send test-info get-info) check-failed
|
||||
result (check-fail-src result)
|
||||
(and (incorrect-error? result) (incorrect-error-exn result)))
|
||||
#f)
|
||||
#t)))
|
||||
|
||||
|
||||
;;error-check: (scheme-val -> boolean) format-string boolean) -> void : raise exn:fail:contract
|
||||
(define (error-check pred? actual fmt fmt-act?)
|
||||
(unless (pred? actual)
|
||||
(raise (make-exn:fail:contract (if fmt-act? (format fmt actual) fmt)
|
||||
(current-continuation-marks)))))
|
||||
|
||||
;;check-member-of
|
||||
(define-syntax (check-member-of stx)
|
||||
(unless (check-context?)
|
||||
(raise-syntax-error 'check-member-of CHECK-EXPECT-DEFN-STR stx))
|
||||
(syntax-case stx ()
|
||||
[(_ test actual actuals ...)
|
||||
(check-expect-maker stx #'check-member-of-values-expected #`test (list #`actual #`(list actuals ...))
|
||||
'comes-from-check-member-of)]
|
||||
[_ (raise-syntax-error 'check-member-of CHECK-MEMBER-OF-STR stx)]))
|
||||
|
||||
;; check-member-of-values-expected: (-> scheme-val) scheme-val src test-object -> void
|
||||
(define (check-member-of-values-expected test first-actual actuals src test-info)
|
||||
(error-check (lambda (v) (not (procedure? v))) first-actual CHECK-MEMBER-OF-FUNCTION-FMT #f)
|
||||
(send (send test-info get-info) add-check)
|
||||
(run-and-check (lambda (v2 v1 _) (memf (lambda (i) (beginner-equal? v1 i)) v2))
|
||||
(lambda (src format v1 v2 _) (make-not-mem src format v1 v2))
|
||||
test (cons first-actual actuals) #f src test-info 'check-member-of))
|
||||
|
||||
;;check-range
|
||||
(define-syntax (check-range stx)
|
||||
(unless (check-context?)
|
||||
(raise-syntax-error 'check-member-of CHECK-EXPECT-DEFN-STR stx))
|
||||
(syntax-case stx ()
|
||||
[(_ test min max)
|
||||
(check-expect-maker stx #'check-range-values-expected #`test (list #`min #`max)
|
||||
'comes-from-check-range)]
|
||||
[_ (raise-syntax-error 'check-range CHECK-RANGE-STR stx)]))
|
||||
|
||||
;; check-range-values-expected: (-> scheme-val) scheme-val src test-object -> void
|
||||
(define (check-range-values-expected test min max src test-info)
|
||||
(error-check number? min RANGE-MIN-FMT #t)
|
||||
(error-check number? max RANGE-MAX-FMT #t)
|
||||
(error-check (lambda (v) (not (procedure? v))) min CHECK-RANGE-FUNCTION-FMT #f)
|
||||
(error-check (lambda (v) (not (procedure? v))) max CHECK-RANGE-FUNCTION-FMT #f)
|
||||
(send (send test-info get-info) add-check)
|
||||
(run-and-check (lambda (v2 v1 v3) (and (number? v1) (and (<= v2 v1) (<= v1 v3))))
|
||||
(lambda (src format v1 v2 v3) (make-not-range src format v1 v2 v3))
|
||||
test min max src test-info 'check-range))
|
||||
|
||||
|
||||
;; run-and-check: (scheme-val scheme-val scheme-val -> boolean)
|
||||
;; (src format scheme-val scheme-val scheme-val -> check-fail)
|
||||
;; ( -> scheme-val) scheme-val scheme-val object symbol? -> void
|
||||
(define (run-and-check check maker test expect range src test-info kind)
|
||||
(match-let ([(list result result-val exn)
|
||||
(with-handlers ([exn:fail?
|
||||
(lambda (e)
|
||||
(let ([display (error-display-handler)])
|
||||
(list (make-unexpected-error src (test-format) expect
|
||||
(exn-message e)
|
||||
e)
|
||||
'error
|
||||
e)))])
|
||||
(let ([test-val (test)])
|
||||
(cond [(check expect test-val range) (list #t test-val #f)]
|
||||
[else
|
||||
(list (maker src (test-format) test-val expect range) test-val #f)])))])
|
||||
(cond [(check-fail? result)
|
||||
(send (send test-info get-info) check-failed result (check-fail-src result) exn)
|
||||
(if exn
|
||||
(raise exn)
|
||||
#f)]
|
||||
[else
|
||||
#t])))
|
||||
|
||||
(define (builder)
|
||||
(let ([te (build-test-engine)])
|
||||
(namespace-set-variable-value! 'test~object te (current-namespace))
|
||||
te))
|
||||
|
||||
(define-syntax (test stx)
|
||||
(syntax-case stx ()
|
||||
[(_)
|
||||
(syntax-property
|
||||
#'(test*)
|
||||
'test-call #t)]))
|
||||
|
||||
(define (test*)
|
||||
(dynamic-wind
|
||||
values
|
||||
(lambda () (run-tests))
|
||||
(lambda () (display-results))))
|
||||
|
||||
(define-syntax (run-tests stx)
|
||||
(syntax-case stx ()
|
||||
[(_)
|
||||
(syntax-property
|
||||
#'(run)
|
||||
'test-call #t)]))
|
||||
|
||||
(define (run)
|
||||
(let ([test-info
|
||||
(namespace-variable-value 'test~object #f builder (current-namespace))])
|
||||
(and test-info (send test-info run))))
|
||||
|
||||
(define (display-results*)
|
||||
(let ([test-info (namespace-variable-value 'test~object #f builder (current-namespace))])
|
||||
(and test-info
|
||||
(let ([display-data (scheme-test-data)])
|
||||
(when (caddr display-data)
|
||||
(send test-info refine-display-class (caddr display-data)))
|
||||
(send test-info setup-display (car display-data) (cadr display-data))
|
||||
(send test-info summarize-results (current-output-port))))))
|
||||
|
||||
(define-syntax (display-results stx)
|
||||
(syntax-case stx ()
|
||||
[(_)
|
||||
(syntax-property
|
||||
#'(display-results*)
|
||||
'test-call #t)]))
|
||||
|
||||
(provide run-tests display-results test builder)
|
||||
|
||||
(define (build-test-engine)
|
||||
(let ([engine (make-object scheme-test%)])
|
||||
(send engine setup-info 'test-check)
|
||||
engine))
|
||||
|
||||
(define (insert-test test-info test) (send test-info add-test test))
|
||||
|
||||
(define scheme-test-data (make-parameter (list #f #f #f)))
|
||||
|
||||
(define scheme-test%
|
||||
(class* test-engine% ()
|
||||
(super-instantiate ())
|
||||
(inherit-field test-info test-display)
|
||||
(inherit setup-info)
|
||||
|
||||
(field [tests null]
|
||||
[test-objs null])
|
||||
|
||||
(define/public (add-test tst)
|
||||
(set! tests (cons tst tests)))
|
||||
(define/public (get-info)
|
||||
(unless test-info (send this setup-info 'check-require))
|
||||
test-info)
|
||||
(define/public (reset-info)
|
||||
(set! tests null)
|
||||
#;(send this setup-info 'check-require))
|
||||
|
||||
(define/augment (run)
|
||||
(inner (void) run)
|
||||
(for ([t (reverse tests)]) (run-test t)))
|
||||
|
||||
(define/augment (run-test test)
|
||||
(test)
|
||||
(inner (void) run-test test))))
|
||||
|
||||
(provide scheme-test-data test-format test-execute test-silence error-handler)
|
||||
|
|
@ -1,57 +1,3 @@
|
|||
(module scheme-gui scheme/base
|
||||
|
||||
(require mred framework scheme/class
|
||||
mzlib/pconvert mzlib/pretty
|
||||
(for-syntax scheme/base))
|
||||
|
||||
(require (except-in "scheme-tests.ss" test) "test-display.scm")
|
||||
|
||||
(define (make-formatter printer)
|
||||
(lambda (value)
|
||||
(let* ([text* (new (editor:standard-style-list-mixin text%))]
|
||||
[text-snip (new editor-snip% [editor text*])])
|
||||
(printer value (open-output-text-editor text* 0))
|
||||
(send text* delete (send text* get-end-position) 'back)
|
||||
(send text* lock #t)
|
||||
text-snip)))
|
||||
|
||||
(define (format-value value)
|
||||
(parameterize ([constructor-style-printing #t]
|
||||
[pretty-print-columns 40])
|
||||
(make-formatter (lambda (v o) (pretty-print (print-convert v) o)))))
|
||||
|
||||
#;(define (format-value value)
|
||||
(cond
|
||||
[(is-a? value snip%) 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)
|
||||
text-snip))]
|
||||
[else (format "~v" value)]))
|
||||
|
||||
(define (test*)
|
||||
(run-tests)
|
||||
(pop-up))
|
||||
|
||||
(define-syntax (test stx)
|
||||
(syntax-case stx ()
|
||||
[(_)
|
||||
(syntax-property
|
||||
#'(test*)
|
||||
'test-call #t)]))
|
||||
|
||||
(define (pop-up)
|
||||
(let ([test-info (namespace-variable-value 'test~object #f builder (current-namespace))])
|
||||
(parameterize ([test-format format-value])
|
||||
(and test-info
|
||||
(send test-info refine-display-class test-display%)
|
||||
(send test-info setup-display #f #f)
|
||||
(send test-info summarize-results (current-output-port))))))
|
||||
|
||||
(provide test format-value make-formatter (all-from-out "scheme-tests.ss"))
|
||||
|
||||
)
|
||||
#lang racket/base
|
||||
(require "racket-gui.rkt")
|
||||
(provide (all-from-out "racket-gui.rkt"))
|
||||
|
|
@ -1,369 +1,3 @@
|
|||
#lang mzscheme
|
||||
|
||||
(require lang/private/teachprims
|
||||
scheme/class
|
||||
scheme/match
|
||||
(only scheme/base for memf)
|
||||
"test-engine.scm"
|
||||
"test-info.scm"
|
||||
)
|
||||
|
||||
(require-for-syntax stepper/private/shared)
|
||||
|
||||
(provide
|
||||
check-expect ;; syntax : (check-expect <expression> <expression>)
|
||||
check-within ;; syntax : (check-within <expression> <expression> <expression>)
|
||||
check-member-of ;; syntax : (check-member-of <expression> <expression>)
|
||||
check-range ;; syntax : (check-range <expression> <expression> <expression>)
|
||||
check-error ;; syntax : (check-error <expression> <expression>)
|
||||
)
|
||||
|
||||
; for other modules implementing check-expect-like forms
|
||||
(provide
|
||||
(for-syntax check-expect-maker))
|
||||
|
||||
(define INEXACT-NUMBERS-FMT
|
||||
"check-expect cannot compare inexact numbers. Try (check-within test ~a range).")
|
||||
(define FUNCTION-FMT
|
||||
"check-expect cannot compare functions.")
|
||||
(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 CHECK-WITHIN-FUNCTION-FMT
|
||||
"check-within cannot compare functions.")
|
||||
(define LIST-FMT
|
||||
"check-member-of requires a list for the second argument, containing the possible outcomes. Given ~s")
|
||||
(define CHECK-MEMBER-OF-FUNCTION-FMT
|
||||
"check-member-of cannot compare functions.")
|
||||
(define RANGE-MIN-FMT
|
||||
"check-range requires a number for the minimum value. Given ~a")
|
||||
(define RANGE-MAX-FMT
|
||||
"check-range requires a number for the maximum value. Given ~a")
|
||||
(define CHECK-RANGE-FUNCTION-FMT
|
||||
"check-range cannot compare functions.")
|
||||
|
||||
|
||||
(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).")
|
||||
(define-for-syntax CHECK-MEMBER-OF-STR
|
||||
"check-member-of requires at least two expressions. Try (check-member-of test option options ...).")
|
||||
(define-for-syntax CHECK-RANGE-STR
|
||||
"chech-range requires three expressions. Try (check-range test min max).")
|
||||
|
||||
(define-for-syntax CHECK-EXPECT-DEFN-STR
|
||||
"found a test that is not at the top level")
|
||||
(define-for-syntax CHECK-WITHIN-DEFN-STR
|
||||
CHECK-EXPECT-DEFN-STR)
|
||||
(define-for-syntax CHECK-ERROR-DEFN-STR
|
||||
CHECK-EXPECT-DEFN-STR)
|
||||
|
||||
;; check-expect-maker : syntax? syntax? (listof syntax?) symbol? -> syntax?
|
||||
;; the common part of all three test forms.
|
||||
(define-for-syntax (check-expect-maker
|
||||
stx checker-proc-stx test-expr embedded-stxes hint-tag)
|
||||
(define bogus-name
|
||||
(stepper-syntax-property #`#,(gensym 'test) 'stepper-hide-completed #t))
|
||||
(define src-info
|
||||
(with-stepper-syntax-properties (['stepper-skip-completely #t])
|
||||
#`(list #,@(list #`(quote #,(syntax-source stx))
|
||||
(syntax-line stx)
|
||||
(syntax-column stx)
|
||||
(syntax-position stx)
|
||||
(syntax-span stx)))))
|
||||
(if (eq? 'module (syntax-local-context))
|
||||
#`(define #,bogus-name
|
||||
#,(stepper-syntax-property
|
||||
#`(let ([test-info (namespace-variable-value
|
||||
'test~object #f builder (current-namespace))])
|
||||
(when test-info
|
||||
(insert-test test-info
|
||||
(lambda ()
|
||||
#,(with-stepper-syntax-properties
|
||||
(['stepper-hint hint-tag]
|
||||
['stepper-hide-reduction #t]
|
||||
['stepper-use-val-as-final #t])
|
||||
(quasisyntax/loc stx
|
||||
(#,checker-proc-stx
|
||||
#,(with-stepper-syntax-properties
|
||||
(['stepper-hide-reduction #t])
|
||||
#`(car
|
||||
#,(with-stepper-syntax-properties
|
||||
(['stepper-hide-reduction #t])
|
||||
#`(list
|
||||
(lambda () #,test-expr)
|
||||
#,(syntax/loc stx (void))))))
|
||||
#,@embedded-stxes
|
||||
#,src-info
|
||||
#,(with-stepper-syntax-properties
|
||||
(['stepper-no-lifting-info #t]
|
||||
['stepper-hide-reduction #t])
|
||||
#'test-info))))))))
|
||||
'stepper-skipto
|
||||
(append skipto/third ;; let
|
||||
skipto/third skipto/second ;; unless (it expands into a begin)
|
||||
skipto/cdr skipto/third ;; application of insert-test
|
||||
'(syntax-e cdr cdr syntax-e car) ;; lambda
|
||||
)))
|
||||
#`(begin
|
||||
(let ([test-info (namespace-variable-value
|
||||
'test~object #f builder (current-namespace))])
|
||||
(when test-info
|
||||
(begin
|
||||
(send test-info reset-info)
|
||||
(insert-test test-info
|
||||
(lambda ()
|
||||
#,(with-stepper-syntax-properties
|
||||
(['stepper-hint hint-tag]
|
||||
['stepper-hide-reduction #t]
|
||||
['stepper-use-val-as-final #t])
|
||||
(quasisyntax/loc stx
|
||||
(#,checker-proc-stx
|
||||
#,(with-stepper-syntax-properties
|
||||
(['stepper-hide-reduction #t])
|
||||
#`(car
|
||||
#,(with-stepper-syntax-properties
|
||||
(['stepper-hide-reduction #t])
|
||||
#`(list
|
||||
(lambda () #,test-expr)
|
||||
#,(syntax/loc stx (void))))))
|
||||
#,@embedded-stxes
|
||||
#,src-info
|
||||
#,(with-stepper-syntax-properties
|
||||
(['stepper-no-lifting-info #t]
|
||||
['stepper-hide-reduction #t])
|
||||
#'test-info)))))))))
|
||||
(test))))
|
||||
|
||||
(define-for-syntax (check-context?)
|
||||
(let ([c (syntax-local-context)])
|
||||
(memq c '(module top-level))))
|
||||
|
||||
;; check-expect
|
||||
(define-syntax (check-expect stx)
|
||||
(unless (check-context?)
|
||||
(raise-syntax-error 'check-expect CHECK-EXPECT-DEFN-STR stx))
|
||||
(syntax-case stx ()
|
||||
[(_ test actual)
|
||||
(check-expect-maker stx #'check-values-expected #`test (list #`actual)
|
||||
'comes-from-check-expect)]
|
||||
[_ (raise-syntax-error 'check-expect CHECK-EXPECT-STR stx)]))
|
||||
|
||||
;; check-values-expected: (-> scheme-val) scheme-val src test-object -> void
|
||||
(define (check-values-expected test actual src test-info)
|
||||
(error-check (lambda (v) (if (number? v) (exact? v) #t))
|
||||
actual INEXACT-NUMBERS-FMT #t)
|
||||
(error-check (lambda (v) (not (procedure? v))) actual FUNCTION-FMT #f)
|
||||
(send (send test-info get-info) add-check)
|
||||
(run-and-check (lambda (v1 v2 _) (beginner-equal? v1 v2))
|
||||
(lambda (src format v1 v2 _) (make-unequal src format v1 v2))
|
||||
test actual #f src test-info 'check-expect))
|
||||
|
||||
;;check-within
|
||||
(define-syntax (check-within stx)
|
||||
(unless (check-context?)
|
||||
(raise-syntax-error 'check-within CHECK-WITHIN-DEFN-STR stx))
|
||||
(syntax-case stx ()
|
||||
[(_ test actual within)
|
||||
(check-expect-maker stx #'check-values-within #`test (list #`actual #`within)
|
||||
'comes-from-check-within)]
|
||||
[_ (raise-syntax-error 'check-within CHECK-WITHIN-STR stx)]))
|
||||
|
||||
;; check-values-within: (-> scheme-val) scheme-val number src test-object -> void
|
||||
(define (check-values-within test actual within src test-info)
|
||||
(error-check number? within CHECK-WITHIN-INEXACT-FMT #t)
|
||||
(error-check (lambda (v) (not (procedure? v))) actual CHECK-WITHIN-FUNCTION-FMT #f)
|
||||
(send (send test-info get-info) add-check)
|
||||
(run-and-check beginner-equal~? make-outofrange test actual within src
|
||||
test-info
|
||||
'check-within))
|
||||
|
||||
;; check-error
|
||||
(define-syntax (check-error stx)
|
||||
(unless (check-context?)
|
||||
(raise-syntax-error 'check-error CHECK-ERROR-DEFN-STR stx))
|
||||
(syntax-case stx ()
|
||||
[(_ test error)
|
||||
(check-expect-maker stx #'check-values-error #`test (list #`error)
|
||||
'comes-from-check-error)]
|
||||
[_ (raise-syntax-error 'check-error CHECK-ERROR-STR stx)]))
|
||||
|
||||
;; check-values-error: (-> scheme-val) scheme-val src test-object -> void
|
||||
(define (check-values-error test error src test-info)
|
||||
(error-check string? error CHECK-ERROR-STR-FMT #t)
|
||||
(send (send test-info get-info) add-check)
|
||||
(let ([result (with-handlers ([exn?
|
||||
(lambda (e)
|
||||
(or (equal? (exn-message e) error)
|
||||
(make-incorrect-error src (test-format) error
|
||||
(exn-message e) e)))])
|
||||
(let ([test-val (test)])
|
||||
(make-expected-error src (test-format) error test-val)))])
|
||||
(if (check-fail? result)
|
||||
(begin
|
||||
(send (send test-info get-info) check-failed
|
||||
result (check-fail-src result)
|
||||
(and (incorrect-error? result) (incorrect-error-exn result)))
|
||||
#f)
|
||||
#t)))
|
||||
|
||||
|
||||
;;error-check: (scheme-val -> boolean) format-string boolean) -> void : raise exn:fail:contract
|
||||
(define (error-check pred? actual fmt fmt-act?)
|
||||
(unless (pred? actual)
|
||||
(raise (make-exn:fail:contract (if fmt-act? (format fmt actual) fmt)
|
||||
(current-continuation-marks)))))
|
||||
|
||||
;;check-member-of
|
||||
(define-syntax (check-member-of stx)
|
||||
(unless (check-context?)
|
||||
(raise-syntax-error 'check-member-of CHECK-EXPECT-DEFN-STR stx))
|
||||
(syntax-case stx ()
|
||||
[(_ test actual actuals ...)
|
||||
(check-expect-maker stx #'check-member-of-values-expected #`test (list #`actual #`(list actuals ...))
|
||||
'comes-from-check-member-of)]
|
||||
[_ (raise-syntax-error 'check-member-of CHECK-MEMBER-OF-STR stx)]))
|
||||
|
||||
;; check-member-of-values-expected: (-> scheme-val) scheme-val src test-object -> void
|
||||
(define (check-member-of-values-expected test first-actual actuals src test-info)
|
||||
(error-check (lambda (v) (not (procedure? v))) first-actual CHECK-MEMBER-OF-FUNCTION-FMT #f)
|
||||
(send (send test-info get-info) add-check)
|
||||
(run-and-check (lambda (v2 v1 _) (memf (lambda (i) (beginner-equal? v1 i)) v2))
|
||||
(lambda (src format v1 v2 _) (make-not-mem src format v1 v2))
|
||||
test (cons first-actual actuals) #f src test-info 'check-member-of))
|
||||
|
||||
;;check-range
|
||||
(define-syntax (check-range stx)
|
||||
(unless (check-context?)
|
||||
(raise-syntax-error 'check-member-of CHECK-EXPECT-DEFN-STR stx))
|
||||
(syntax-case stx ()
|
||||
[(_ test min max)
|
||||
(check-expect-maker stx #'check-range-values-expected #`test (list #`min #`max)
|
||||
'comes-from-check-range)]
|
||||
[_ (raise-syntax-error 'check-range CHECK-RANGE-STR stx)]))
|
||||
|
||||
;; check-range-values-expected: (-> scheme-val) scheme-val src test-object -> void
|
||||
(define (check-range-values-expected test min max src test-info)
|
||||
(error-check number? min RANGE-MIN-FMT #t)
|
||||
(error-check number? max RANGE-MAX-FMT #t)
|
||||
(error-check (lambda (v) (not (procedure? v))) min CHECK-RANGE-FUNCTION-FMT #f)
|
||||
(error-check (lambda (v) (not (procedure? v))) max CHECK-RANGE-FUNCTION-FMT #f)
|
||||
(send (send test-info get-info) add-check)
|
||||
(run-and-check (lambda (v2 v1 v3) (and (number? v1) (and (<= v2 v1) (<= v1 v3))))
|
||||
(lambda (src format v1 v2 v3) (make-not-range src format v1 v2 v3))
|
||||
test min max src test-info 'check-range))
|
||||
|
||||
|
||||
;; run-and-check: (scheme-val scheme-val scheme-val -> boolean)
|
||||
;; (src format scheme-val scheme-val scheme-val -> check-fail)
|
||||
;; ( -> scheme-val) scheme-val scheme-val object symbol? -> void
|
||||
(define (run-and-check check maker test expect range src test-info kind)
|
||||
(match-let ([(list result result-val exn)
|
||||
(with-handlers ([exn:fail?
|
||||
(lambda (e)
|
||||
(let ([display (error-display-handler)])
|
||||
(list (make-unexpected-error src (test-format) expect
|
||||
(exn-message e)
|
||||
e)
|
||||
'error
|
||||
e)))])
|
||||
(let ([test-val (test)])
|
||||
(cond [(check expect test-val range) (list #t test-val #f)]
|
||||
[else
|
||||
(list (maker src (test-format) test-val expect range) test-val #f)])))])
|
||||
(cond [(check-fail? result)
|
||||
(send (send test-info get-info) check-failed result (check-fail-src result) exn)
|
||||
(if exn
|
||||
(raise exn)
|
||||
#f)]
|
||||
[else
|
||||
#t])))
|
||||
|
||||
(define (builder)
|
||||
(let ([te (build-test-engine)])
|
||||
(namespace-set-variable-value! 'test~object te (current-namespace))
|
||||
te))
|
||||
|
||||
(define-syntax (test stx)
|
||||
(syntax-case stx ()
|
||||
[(_)
|
||||
(syntax-property
|
||||
#'(test*)
|
||||
'test-call #t)]))
|
||||
|
||||
(define (test*)
|
||||
(dynamic-wind
|
||||
values
|
||||
(lambda () (run-tests))
|
||||
(lambda () (display-results))))
|
||||
|
||||
(define-syntax (run-tests stx)
|
||||
(syntax-case stx ()
|
||||
[(_)
|
||||
(syntax-property
|
||||
#'(run)
|
||||
'test-call #t)]))
|
||||
|
||||
(define (run)
|
||||
(let ([test-info
|
||||
(namespace-variable-value 'test~object #f builder (current-namespace))])
|
||||
(and test-info (send test-info run))))
|
||||
|
||||
(define (display-results*)
|
||||
(let ([test-info (namespace-variable-value 'test~object #f builder (current-namespace))])
|
||||
(and test-info
|
||||
(let ([display-data (scheme-test-data)])
|
||||
(when (caddr display-data)
|
||||
(send test-info refine-display-class (caddr display-data)))
|
||||
(send test-info setup-display (car display-data) (cadr display-data))
|
||||
(send test-info summarize-results (current-output-port))))))
|
||||
|
||||
(define-syntax (display-results stx)
|
||||
(syntax-case stx ()
|
||||
[(_)
|
||||
(syntax-property
|
||||
#'(display-results*)
|
||||
'test-call #t)]))
|
||||
|
||||
(provide run-tests display-results test builder)
|
||||
|
||||
(define (build-test-engine)
|
||||
(let ([engine (make-object scheme-test%)])
|
||||
(send engine setup-info 'test-check)
|
||||
engine))
|
||||
|
||||
(define (insert-test test-info test) (send test-info add-test test))
|
||||
|
||||
(define scheme-test-data (make-parameter (list #f #f #f)))
|
||||
|
||||
(define scheme-test%
|
||||
(class* test-engine% ()
|
||||
(super-instantiate ())
|
||||
(inherit-field test-info test-display)
|
||||
(inherit setup-info)
|
||||
|
||||
(field [tests null]
|
||||
[test-objs null])
|
||||
|
||||
(define/public (add-test tst)
|
||||
(set! tests (cons tst tests)))
|
||||
(define/public (get-info)
|
||||
(unless test-info (send this setup-info 'check-require))
|
||||
test-info)
|
||||
(define/public (reset-info)
|
||||
(set! tests null)
|
||||
#;(send this setup-info 'check-require))
|
||||
|
||||
(define/augment (run)
|
||||
(inner (void) run)
|
||||
(for ([t (reverse tests)]) (run-test t)))
|
||||
|
||||
(define/augment (run-test test)
|
||||
(test)
|
||||
(inner (void) run-test test))))
|
||||
|
||||
(provide scheme-test-data test-format test-execute test-silence error-handler)
|
||||
#lang racket/base
|
||||
(require "racket-tests.rkt")
|
||||
(provide (all-from-out "racket-tests.rkt"))
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
#lang scribble/doc
|
||||
@(require scribble/manual
|
||||
(for-label scheme/base
|
||||
test-engine/scheme-tests
|
||||
(prefix-in gui: test-engine/scheme-gui)))
|
||||
(for-label racket/base
|
||||
test-engine/racket-tests
|
||||
(prefix-in gui: test-engine/racket-gui)))
|
||||
|
||||
@title{Test Support}
|
||||
|
||||
|
|
@ -14,7 +14,7 @@
|
|||
|
||||
@section{Using Check Forms}
|
||||
|
||||
@defmodule[test-engine/scheme-tests]
|
||||
@defmodule[test-engine/racket-tests]
|
||||
|
||||
This module provides test forms for use in Racket programs, as well
|
||||
as parameters to configure the behavior of test reports.
|
||||
|
|
@ -22,7 +22,7 @@ as parameters to configure the behavior of test reports.
|
|||
Each check form may only occur at the top-level; results are collected
|
||||
and reported by the test function. Note that the check forms only
|
||||
register checks to be performed. The checks are actually run by the
|
||||
@scheme[test] function.
|
||||
@racket[test] function.
|
||||
|
||||
@defproc[(check-expect (test any/c) (expected any/c)) void?]{
|
||||
|
||||
|
|
@ -34,7 +34,7 @@ It is an error to produce a function value or an inexact number.}
|
|||
|
||||
@defproc[(check-within (test any/c) (expected any/c) (delta number?)) void?]{
|
||||
|
||||
Like @scheme[check-expect], but with an extra expression that produces
|
||||
Like @racket[check-expect], but with an extra expression that produces
|
||||
a number delta. Every number in the first expression must be within
|
||||
delta of the cooresponding number in the second expression.
|
||||
|
||||
|
|
@ -85,14 +85,14 @@ suppress evaluation of test expressions.
|
|||
|
||||
@section{GUI Interface}
|
||||
|
||||
@defmodule[test-engine/scheme-gui]
|
||||
@defmodule[test-engine/racket-gui]
|
||||
|
||||
@; FIXME: need to actually list the bindings here, so they're found in
|
||||
@; the index
|
||||
|
||||
This module requires GRacket and produces an independent window when
|
||||
displaying test results. It provides the same bindings as
|
||||
@scheme[test-engine/scheme-tests].
|
||||
@racket[test-engine/racket-tests].
|
||||
|
||||
@section{Integrating languages with Test Engine}
|
||||
|
||||
|
|
|
|||
5
collects/typed/test-engine/racket-tests.rkt
Normal file
5
collects/typed/test-engine/racket-tests.rkt
Normal file
|
|
@ -0,0 +1,5 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require test-engine/racket-tests
|
||||
"type-env-ext.ss")
|
||||
(provide (all-from-out test-engine/racket-tests))
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require typed-scheme/utils/utils
|
||||
(prefix-in ce: test-engine/scheme-tests)
|
||||
(prefix-in ce: test-engine/racket-tests)
|
||||
(for-syntax
|
||||
scheme/base syntax/parse
|
||||
(utils tc-utils)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user