diff --git a/collects/test-engine/scheme-tests.ss b/collects/test-engine/scheme-tests.ss index 0da7d2e858..165137d70a 100644 --- a/collects/test-engine/scheme-tests.ss +++ b/collects/test-engine/scheme-tests.ss @@ -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 ) check-within ;; syntax : (check-within ) + check-member-of ;; syntax : (check-member-of ) + check-range ;; syntax : (check-range ) check-error ;; syntax : (check-error ) ) @@ -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 diff --git a/collects/test-engine/test-display.scm b/collects/test-engine/test-display.scm index aeaea75adb..e77d5b84ad 100644 --- a/collects/test-engine/test-display.scm +++ b/collects/test-engine/test-display.scm @@ -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 diff --git a/collects/test-engine/test-info.scm b/collects/test-engine/test-info.scm index b600e2551c..ab48376833 100644 --- a/collects/test-engine/test-info.scm +++ b/collects/test-engine/test-info.scm @@ -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")))