check-satisfied: the basic functionality, the display in repl and test suite gui, plus the communication among these modules; missing: language constant
This commit is contained in:
Matthias Felleisen
parent
08f32b1a6e
commit
eb8fb04baa
|
|
@ -5,8 +5,10 @@
|
|||
lang/private/rewrite-error-message)
|
||||
racket/class
|
||||
racket/match
|
||||
racket/function
|
||||
lang/private/continuation-mark-key
|
||||
lang/private/rewrite-error-message
|
||||
; (for-template lang/private/firstorder)
|
||||
"test-engine.rkt"
|
||||
"test-info.scm")
|
||||
|
||||
|
|
@ -19,6 +21,7 @@
|
|||
check-member-of ;; syntax : (check-member-of <expression> <expression>)
|
||||
check-range ;; syntax : (check-range <expression> <expression> <expression>)
|
||||
check-error ;; syntax : (check-error <expression> [<expression>])
|
||||
check-satisfied ;; syntax : (check-satisfied <expression> <expression>)
|
||||
)
|
||||
|
||||
; for other modules implementing check-expect-like forms
|
||||
|
|
@ -31,22 +34,24 @@
|
|||
"check-expect cannot compare inexact numbers. Try (check-within test ~a range).")
|
||||
(define FUNCTION-FMT
|
||||
"check-expect cannot compare functions.")
|
||||
(define SATISFIED-FMT
|
||||
"check-satisfied: expects function of one argument in second position. Given ~a")
|
||||
(define CHECK-ERROR-STR-FMT
|
||||
"check-error expects a string (the expected error message) for the second argument. Given ~s")
|
||||
"check-error: expects a string (the expected error message) for the second argument. Given ~s")
|
||||
(define CHECK-WITHIN-INEXACT-FMT
|
||||
"check-within expects an inexact number for the range. ~a is not inexact.")
|
||||
"check-within: expects 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 expects a list for the second argument (the possible outcomes). Given ~s")
|
||||
"check-member-of: expects a list for the second argument (the possible outcomes). Given ~s")
|
||||
(define CHECK-MEMBER-OF-FUNCTION-FMT
|
||||
"check-member-of cannot compare functions.")
|
||||
"check-member-of: cannot compare functions.")
|
||||
(define RANGE-MIN-FMT
|
||||
"check-range expects a number for the minimum value. Given ~a")
|
||||
"check-range: expects a number for the minimum value. Given ~a")
|
||||
(define RANGE-MAX-FMT
|
||||
"check-range expects a number for the maximum value. Given ~a")
|
||||
"check-range: expects a number for the maximum value. Given ~a")
|
||||
(define CHECK-RANGE-FUNCTION-FMT
|
||||
"check-range cannot compare functions.")
|
||||
"check-range: cannot compare functions.")
|
||||
|
||||
|
||||
(define-for-syntax CHECK-EXPECT-DEFN-STR
|
||||
|
|
@ -57,7 +62,15 @@
|
|||
CHECK-EXPECT-DEFN-STR)
|
||||
|
||||
;; check-expect-maker : syntax? syntax? (listof syntax?) symbol? -> syntax?
|
||||
;; the common part of all three test forms.
|
||||
;; the common part of all three test forms
|
||||
;; examples
|
||||
#;
|
||||
(_ stx #'check-values-expected #`test (list #`actual) 'comes-from-check-expect)
|
||||
#;
|
||||
(_ stx #'check-values-within #`test (list #`actual #`within) 'comes-from-check-within)
|
||||
#;
|
||||
(_ stx #'check-values-error #`test (list #`error) 'comes-from-check-error)
|
||||
|
||||
(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))
|
||||
|
|
@ -165,8 +178,35 @@
|
|||
#`(lambda (rng k)
|
||||
(parameterize ((current-pseudo-random-generator rng)) (random-seed k)
|
||||
e2)))])
|
||||
;; ---------------------------------------------------------------------------------------------------
|
||||
(check-expect-maker stx #'check-random-values test actuals 'comes-from-check-expect))]))
|
||||
(check-expect-maker stx #'check-random-values test actuals 'comes-from-check-expect))]
|
||||
[_ (raise-syntax-error 'check-random (argcount-error-message/stx 2 stx) stx)]))
|
||||
|
||||
(define-syntax (check-satisfied stx)
|
||||
(syntax-case stx ()
|
||||
[(_ actual:exp expected-property:exp)
|
||||
(symbol? (syntax-e #'expected-property:exp))
|
||||
(check-expect-maker stx
|
||||
#'check-values-property
|
||||
#'(lambda (x) (expected-property:exp x))
|
||||
(list #'actual:exp (symbol->string (syntax-e #'expected-property:exp)))
|
||||
'comes-from-check-satisfied)]
|
||||
[(_ actual:exp expected-property:exp)
|
||||
(raise-syntax-error 'check-satisfied "expects named function in second position." stx)]
|
||||
[_ (raise-syntax-error 'check-satisfied (argcount-error-message/stx 2 stx) stx)]))
|
||||
|
||||
(define (check-values-property test actual property? src test-engine)
|
||||
;; it is okay if actual is a procedure because property testing may use
|
||||
;; it, but it is possibly weird for students
|
||||
(send (send test-engine get-info) add-check)
|
||||
(run-and-check
|
||||
(lambda (v p? _what-is-this?) (p? v))
|
||||
(lambda (src format v1 v2 _) (make-satisfied-failed src format v2 property?))
|
||||
test
|
||||
actual
|
||||
#f
|
||||
src
|
||||
test-engine
|
||||
(list 'check-satisfied property?)))
|
||||
|
||||
;; check-values-expected: (-> scheme-val) (-> nat scheme-val) src test-engine -> void
|
||||
(define (check-random-values test actual-maker src test-engine)
|
||||
|
|
@ -179,7 +219,12 @@
|
|||
(send (send test-engine get-info) add-check)
|
||||
(run-and-check (lambda (v1 v2 _) (teach-equal? v1 v2))
|
||||
(lambda (src format v1 v2 _) (make-unequal src format v1 v2))
|
||||
(lambda () ((test) rng k)) actual #f src test-engine 'check-expect))
|
||||
(lambda () ((test) rng k))
|
||||
actual
|
||||
#f
|
||||
src
|
||||
test-engine
|
||||
'check-expect))
|
||||
|
||||
;; check-values-expected: (-> scheme-val) scheme-val src test-engine -> void
|
||||
(define (check-values-expected test actual src test-engine)
|
||||
|
|
@ -259,12 +304,11 @@
|
|||
#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)))))
|
||||
(define msg (if fmt-act? (format fmt actual) fmt))
|
||||
(raise (make-exn:fail:contract msg (current-continuation-marks)))))
|
||||
|
||||
;;check-member-of
|
||||
(define-syntax (check-member-of stx)
|
||||
|
|
@ -308,19 +352,23 @@
|
|||
(lambda (src format v1 v2 v3) (make-not-range src format v1 v2 v3))
|
||||
test min max src test-engine '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 test-engine symbol? -> void
|
||||
;; ( -> scheme-val) scheme-val scheme-val test-engine symbol? -> boolean
|
||||
(define (run-and-check check maker test expect range src test-engine kind)
|
||||
(match-let
|
||||
([(list result result-val exn)
|
||||
(match-let ([(list result result-val exn)
|
||||
(with-handlers ([exn:fail:wish?
|
||||
(lambda (e)
|
||||
(define display (error-display-handler))
|
||||
(define name (exn:fail:wish-name e))
|
||||
(define args (exn:fail:wish-args e))
|
||||
(list (unimplemented-wish src (test-format) name args) 'error #f))]
|
||||
[(lambda (x)
|
||||
(and (exn:fail:contract:arity? x)
|
||||
(pair? kind)
|
||||
(eq? 'check-satisfied (car kind))))
|
||||
(lambda (_)
|
||||
(error-check (lambda (v) #f) (cadr kind) SATISFIED-FMT #t))]
|
||||
[exn:fail?
|
||||
(lambda (e)
|
||||
(define display (error-display-handler))
|
||||
|
|
|
|||
|
|
@ -278,6 +278,14 @@
|
|||
(print (string-constant test-engine-actual-value-differs-error)
|
||||
(formatter (unequal-test fail))
|
||||
(formatter (unequal-actual fail)))]
|
||||
[(satisfied-failed? fail)
|
||||
(print "Actual value ~F does not satisfy ~a."
|
||||
(formatter (satisfied-failed-actual fail))
|
||||
(satisfied-failed-name fail))
|
||||
#;
|
||||
(print (string-constant test-engine-actual-value-differs-error)
|
||||
(formatter (unequal-test fail))
|
||||
(formatter (unequal-actual fail)))]
|
||||
[(outofrange? fail)
|
||||
(print (string-constant test-engine-actual-value-not-within-error)
|
||||
(formatter (outofrange-test fail))
|
||||
|
|
|
|||
|
|
@ -211,7 +211,8 @@
|
|||
(lambda () (send rep display-test-results test-display))))]
|
||||
[event-space
|
||||
(parameterize ([(dynamic-require 'mred/mred 'current-eventspace) event-space])
|
||||
((dynamic-require 'mred/mred 'queue-callback) (lambda () (send test-display display-results))))]
|
||||
((dynamic-require 'mred/mred 'queue-callback)
|
||||
(lambda () (send test-display display-results))))]
|
||||
[else (send test-display display-results)]))
|
||||
|
||||
(define/public (display-untested port)
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/class
|
||||
deinprogramm/quickcheck/quickcheck
|
||||
"print.ss")
|
||||
deinprogramm/quickcheck/quickcheck
|
||||
"print.ss")
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
||||
|
|
@ -27,6 +27,8 @@
|
|||
(define-struct (not-mem check-fail) (test set))
|
||||
;; (make-not-range src format scheme-val scheme-val scheme-val)
|
||||
(define-struct (not-range check-fail) (test min max))
|
||||
;; (make-satisfied-failed src format scheme-val symbol)
|
||||
(define-struct (satisfied-failed check-fail) (actual name))
|
||||
|
||||
;;Wishes
|
||||
(define-struct (unimplemented-wish check-fail) (name args))
|
||||
|
|
@ -45,30 +47,30 @@
|
|||
(define test-info-base%
|
||||
(class* object% ()
|
||||
(super-instantiate ())
|
||||
|
||||
|
||||
(init-field (style 'check-base))
|
||||
(field [analyses null])
|
||||
|
||||
|
||||
(define total-tsts 0)
|
||||
(define failed-tsts 0)
|
||||
(define total-cks 0)
|
||||
(define failed-cks 0)
|
||||
(define total-called-wishes 0)
|
||||
|
||||
|
||||
(define failures null)
|
||||
(define wishes null)
|
||||
|
||||
|
||||
(define unreported-failures #f)
|
||||
|
||||
|
||||
(define/public (clear-unreported-failures)
|
||||
(set! unreported-failures #f))
|
||||
|
||||
|
||||
(define/public (report-failure)
|
||||
(set! unreported-failures #t))
|
||||
|
||||
|
||||
(define/public (has-unreported-failures)
|
||||
unreported-failures)
|
||||
|
||||
|
||||
(define/public (test-style) style)
|
||||
(define/public (tests-run) total-tsts)
|
||||
(define/public (tests-failed) failed-tsts)
|
||||
|
|
@ -79,7 +81,7 @@
|
|||
[(and (zero? failed-cks) (zero? failed-tsts)) 'all-passed]
|
||||
[else 'mixed-results]))
|
||||
(define/public (called-wishes) total-called-wishes)
|
||||
|
||||
|
||||
(define/public (failed-checks) failures)
|
||||
(define/public (unimplemented-wishes) wishes)
|
||||
|
||||
|
|
@ -87,15 +89,15 @@
|
|||
(set! total-called-wishes (add1 total-called-wishes))
|
||||
(unless (memq name wishes) (set! wishes (cons name wishes)))
|
||||
(inner (void) add-wish-call name))
|
||||
|
||||
|
||||
(define/pubment (add-check)
|
||||
(set! total-cks (add1 total-cks))
|
||||
(inner (void) add-check))
|
||||
|
||||
|
||||
(define/pubment (add-test)
|
||||
(set! total-tsts (add1 total-tsts))
|
||||
(inner (void) add-test))
|
||||
|
||||
|
||||
(define/pubment (add-check-failure fail exn?)
|
||||
(set! failed-cks (add1 failed-cks))
|
||||
(set! failures (cons (make-failed-check fail exn?) failures))
|
||||
|
|
@ -105,27 +107,27 @@
|
|||
(unless (memq name wishes)
|
||||
(set! wishes (cons name wishes)))
|
||||
(inner (void) add-wish name))
|
||||
|
||||
|
||||
;; check-failed: (U check-fail (list (U string snip%))) src (U exn false) -> void
|
||||
(define/pubment (check-failed msg src exn?)
|
||||
(let ((fail
|
||||
;; We'd like every caller to make a check-fail object,
|
||||
;; but some (such as ProfessorJ's run time) cannot because
|
||||
;; of phase problems. Therefore, do the coercion here.
|
||||
(if (check-fail? msg)
|
||||
msg
|
||||
(make-message-error src #f msg))))
|
||||
(add-check-failure fail exn?)
|
||||
(report-failure)
|
||||
(inner (void) check-failed fail src exn?)))
|
||||
|
||||
;; We'd like every caller to make a check-fail object,
|
||||
;; but some (such as ProfessorJ's run time) cannot because
|
||||
;; of phase problems. Therefore, do the coercion here.
|
||||
(if (check-fail? msg)
|
||||
msg
|
||||
(make-message-error src #f msg))))
|
||||
(add-check-failure fail exn?)
|
||||
(report-failure)
|
||||
(inner (void) check-failed fail src exn?)))
|
||||
|
||||
(define/pubment (test-failed failed-info)
|
||||
(set! failed-tsts (add1 failed-tsts))
|
||||
(report-failure)
|
||||
(inner (void) test-failed failed-info))
|
||||
|
||||
|
||||
(define/public (add-analysis a) (set! analyses (cons a analyses)))
|
||||
|
||||
|
||||
(define/public (analyze-position src . vals)
|
||||
(for ([a analyses]) (send a analyze src vals)))
|
||||
(define/public (extract-info pred?)
|
||||
|
|
@ -134,56 +136,62 @@
|
|||
; helper for printing error messages
|
||||
(define (print-reason print-string print-formatted fail)
|
||||
(let ((print
|
||||
(lambda (fstring . vals)
|
||||
(apply print-with-values fstring print-string print-formatted vals)))
|
||||
(formatter (check-fail-format fail)))
|
||||
(lambda (fstring . vals)
|
||||
(apply print-with-values fstring print-string print-formatted vals)))
|
||||
(formatter (check-fail-format fail)))
|
||||
(cond
|
||||
[(unexpected-error? fail)
|
||||
(print "check-expect encountered the following error instead of the expected value, ~F. \n :: ~a"
|
||||
(formatter (unexpected-error-expected fail))
|
||||
(unexpected-error-message fail))]
|
||||
[(unequal? fail)
|
||||
(print "Actual value ~F differs from ~F, the expected value."
|
||||
(formatter (unequal-test fail))
|
||||
(formatter (unequal-actual fail)))]
|
||||
[(outofrange? fail)
|
||||
(print "Actual value ~F is not within ~a of expected value ~F."
|
||||
(formatter (outofrange-test fail))
|
||||
(formatter (outofrange-range fail))
|
||||
(formatter (outofrange-actual fail)))]
|
||||
[(incorrect-error? fail)
|
||||
(print "check-error encountered the following error instead of the expected ~a\n :: ~a"
|
||||
(incorrect-error-expected fail)
|
||||
(incorrect-error-message fail))]
|
||||
[(expected-error? fail)
|
||||
(print "check-error expected the following error, but instead received the value ~F.\n ~a"
|
||||
(formatter (expected-error-value fail))
|
||||
(expected-error-message fail))]
|
||||
[(message-error? fail)
|
||||
(for-each print-formatted (message-error-strings fail))]
|
||||
[(not-mem? fail)
|
||||
(print "Actual value ~F differs from all given members in ~F."
|
||||
(formatter (not-mem-test fail))
|
||||
(formatter (not-mem-set fail)))]
|
||||
[(not-range? fail)
|
||||
(print "Actual value ~F is not between ~F and ~F, inclusive."
|
||||
(formatter (not-range-test fail))
|
||||
(formatter (not-range-min fail))
|
||||
(formatter (not-range-max fail)))]
|
||||
[(unimplemented-wish? fail)
|
||||
(print "Test relies on a call to wished for function ~F that has not been implemented, with arguments ~F."
|
||||
(unimplemented-wish-name fail)
|
||||
(formatter (unimplemented-wish-args fail)))]
|
||||
[(property-fail? fail)
|
||||
(print-string "Property falsifiable with")
|
||||
(for-each (lambda (arguments)
|
||||
(for-each (lambda (p)
|
||||
(if (car p)
|
||||
(print " ~a = ~F" (car p) (formatter (cdr p)))
|
||||
(print "~F" (formatter (cdr p)))))
|
||||
arguments))
|
||||
(result-arguments-list (property-fail-result fail)))]
|
||||
[(property-error? fail)
|
||||
(print "check-property encountered the following error\n:: ~a"
|
||||
(property-error-message fail))])
|
||||
[(unexpected-error? fail)
|
||||
(print
|
||||
"check-expect encountered the following error instead of the expected value, ~F. \n :: ~a"
|
||||
(formatter (unexpected-error-expected fail))
|
||||
(unexpected-error-message fail))]
|
||||
[(satisfied-failed? fail)
|
||||
(print "Actual value ~F does not satisfy ~F.\n"
|
||||
(formatter (satisfied-failed-actual fail))
|
||||
(formatter (satisfied-failed-name fail)))]
|
||||
[(unequal? fail)
|
||||
(print "Actual value ~F differs from ~F, the expected value."
|
||||
(formatter (unequal-test fail))
|
||||
(formatter (unequal-actual fail)))]
|
||||
[(outofrange? fail)
|
||||
(print "Actual value ~F is not within ~a of expected value ~F."
|
||||
(formatter (outofrange-test fail))
|
||||
(formatter (outofrange-range fail))
|
||||
(formatter (outofrange-actual fail)))]
|
||||
[(incorrect-error? fail)
|
||||
(print "check-error encountered the following error instead of the expected ~a\n :: ~a"
|
||||
(incorrect-error-expected fail)
|
||||
(incorrect-error-message fail))]
|
||||
[(expected-error? fail)
|
||||
(print "check-error expected the following error, but instead received the value ~F.\n ~a"
|
||||
(formatter (expected-error-value fail))
|
||||
(expected-error-message fail))]
|
||||
[(message-error? fail)
|
||||
(for-each print-formatted (message-error-strings fail))]
|
||||
[(not-mem? fail)
|
||||
(print "Actual value ~F differs from all given members in ~F."
|
||||
(formatter (not-mem-test fail))
|
||||
(formatter (not-mem-set fail)))]
|
||||
[(not-range? fail)
|
||||
(print "Actual value ~F is not between ~F and ~F, inclusive."
|
||||
(formatter (not-range-test fail))
|
||||
(formatter (not-range-min fail))
|
||||
(formatter (not-range-max fail)))]
|
||||
[(unimplemented-wish? fail)
|
||||
(print (string-append "Test relies on a call to wished-for function ~F "
|
||||
" that has not been implemented, with arguments ~F.")
|
||||
(unimplemented-wish-name fail)
|
||||
(formatter (unimplemented-wish-args fail)))]
|
||||
[(property-fail? fail)
|
||||
(print-string "Property falsifiable with")
|
||||
(for-each (lambda (arguments)
|
||||
(for-each (lambda (p)
|
||||
(if (car p)
|
||||
(print " ~a = ~F" (car p) (formatter (cdr p)))
|
||||
(print "~F" (formatter (cdr p)))))
|
||||
arguments))
|
||||
(result-arguments-list (property-fail-result fail)))]
|
||||
[(property-error? fail)
|
||||
(print "check-property encountered the following error\n:: ~a"
|
||||
(property-error-message fail))])
|
||||
(print-string "\n")))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user