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

Adding check-member-of and check-range

Browse Source 
svn: r16045
This commit is contained in:
Kathy Gray 2009-09-17 15:50:57 +00:00
parent c94c63ebe1
commit fcbe2cd7d3
3 changed files with 88 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

66
collects/test-engine/scheme-tests.ss
View File

@ -3,7 +3,7 @@
(require lang/private/teachprims
scheme/class
scheme/match
(only scheme/base for)
(only scheme/base for memf)
"test-engine.scm"
"test-info.scm"
)
@ -13,6 +13,8 @@
(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>)
)
@ -30,6 +32,17 @@
"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).")
@ -37,6 +50,10 @@
"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 two expressions. Try (check-member-of test 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")
@ -136,7 +153,7 @@
'comes-from-check-expect)]
[_ (raise-syntax-error 'check-expect CHECK-EXPECT-STR stx)]))
;; check-values-expected: (-> scheme-val) scheme-val src -> void
;; 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)
@ -146,7 +163,7 @@
(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))
@ -156,6 +173,7 @@
'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)
@ -164,7 +182,7 @@
test-info
'check-within))
;; check-error
(define-syntax (check-error stx)
(unless (check-context?)
(raise-syntax-error 'check-error CHECK-ERROR-DEFN-STR stx))
@ -174,6 +192,7 @@
'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)
@ -193,14 +212,53 @@
#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 actuals)
(check-expect-maker stx #'check-member-of-values-expected #`test (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 actuals src test-info)
(error-check (lambda (v) (list? v)) actuals LIST-FMT #t)
(error-check (lambda (v) (not (procedure? v))) actuals 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 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

12
collects/test-engine/test-display.scm
View File

@ -256,7 +256,17 @@
(formatter (expected-error-value fail))
(expected-error-message fail))]
[(message-error? fail)
(for-each print-formatted (message-error-strings 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)))]
)
(print-string "\n")))
;; make-error-link: text% check-fail exn src editor -> void

16
collects/test-engine/test-info.scm
View File

@ -20,6 +20,10 @@
(define-struct (incorrect-error check-fail) (expected message exn))
;; (make-expected-error src format string scheme-val)
(define-struct (expected-error check-fail) (message value))
;; (make-not-mem src format scheme-val scheme-val)
(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-message-error src format (listof string))
(define-struct (message-error check-fail) (strings))
@ -115,6 +119,16 @@
(formatter (expected-error-value fail))
(expected-error-message fail))]
[(message-error? fail)
(for-each print-formatted (message-error-strings 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)))]
)
(print-string "\n")))