move contract tests into contract subdirectory
and fix up the code that orders the tests when running them all
This commit is contained in:
Robby Findler
parent
c7726e23ec
commit
31a9414983
|
|
@ -1,282 +0,0 @@
|
|||
#lang racket/base
|
||||
(require racket/contract
|
||||
rackunit
|
||||
rackunit/text-ui)
|
||||
|
||||
(define ((blame-to whom) exn)
|
||||
(and (exn:fail:contract:blame? exn)
|
||||
(regexp-match? (regexp-quote (format "blaming: ~a" whom))
|
||||
(exn-message exn))))
|
||||
|
||||
(define ((match-msg . msgs) exn)
|
||||
(and (exn:fail? exn)
|
||||
(for/and ([msg (in-list msgs)])
|
||||
(regexp-match (regexp-quote msg) (exn-message exn)))))
|
||||
|
||||
(define-simple-check (check-pred2 func thunk)
|
||||
(let-values ([(a b) (thunk)])
|
||||
(func a b)))
|
||||
|
||||
(define-simple-check (check-name expected ctc)
|
||||
(let ((got (contract-name ctc)))
|
||||
(equal? expected got)))
|
||||
|
||||
(define opt-tests
|
||||
(test-suite
|
||||
"Tests for opt/c"
|
||||
|
||||
(test-case
|
||||
"or 1"
|
||||
(check-pred (λ (x) (= x 1))
|
||||
(contract (opt/c (or/c number? boolean?)) 1 'pos 'neg)))
|
||||
|
||||
(test-case
|
||||
"or 2"
|
||||
(check-pred (λ (x) (eq? x #t))
|
||||
(contract (opt/c (or/c number? boolean?)) #t 'pos 'neg)))
|
||||
|
||||
(test-exn
|
||||
"or 3"
|
||||
(blame-to 'pos)
|
||||
(λ ()
|
||||
(contract (opt/c (or/c number? boolean?)) "string" 'pos 'neg)))
|
||||
|
||||
(test-case
|
||||
"or 4"
|
||||
(check-pred (λ (x) (= x 1))
|
||||
((contract (opt/c (or/c number? (-> boolean? number?)))
|
||||
(λ (x) 1) 'pos 'neg) #t)))
|
||||
|
||||
(test-case
|
||||
"or 5"
|
||||
(check-pred (λ (x) (= x 1))
|
||||
((contract (opt/c (or/c (-> boolean? boolean? number?) (-> boolean? number?)))
|
||||
(λ (x y) 1) 'pos 'neg) #t #f)))
|
||||
|
||||
(test-case
|
||||
"lifting 1"
|
||||
(check-pred (λ (x) (= x 1))
|
||||
(let ((volatile 0))
|
||||
(contract (opt/c (between/c (begin (set! volatile 1) 3) 5)) 4 'pos 'neg)
|
||||
volatile)))
|
||||
|
||||
(test-case
|
||||
"arrow 1"
|
||||
(check-pred (λ (x) (= x 1))
|
||||
((contract (opt/c (-> boolean? number?)) (λ (x) 1) 'pos 'neg) #t)))
|
||||
|
||||
(test-case
|
||||
"arrow 2"
|
||||
(check-pred2 (λ (x y) (and (= x 1) (= y 2)))
|
||||
(λ ()
|
||||
((contract (opt/c (-> boolean? (values number? number?)))
|
||||
(λ (x) (values 1 2)) 'pos 'neg) #t))))
|
||||
|
||||
(test-case
|
||||
"arrow 3"
|
||||
(check-pred2 (λ (x y) (and (= x 1) (= y 2)))
|
||||
(λ ()
|
||||
((contract (opt/c (-> boolean? any)) (λ (x) (values 1 2)) 'pos 'neg) #t))))
|
||||
|
||||
(test-case
|
||||
"arrow 4"
|
||||
(check-pred (λ (x) (= x 1))
|
||||
((contract (opt/c (-> boolean? any)) (λ (x) 1) 'pos 'neg) #t)))
|
||||
|
||||
(test-exn
|
||||
"arrow 5"
|
||||
(blame-to 'neg)
|
||||
(λ ()
|
||||
((contract (opt/c (-> boolean? number?)) (λ (x) #t) 'pos 'neg) 1)))
|
||||
|
||||
(test-exn
|
||||
"arrow 6"
|
||||
(blame-to 'pos)
|
||||
(λ ()
|
||||
((contract (opt/c (-> boolean? number?)) (λ (x) #t) 'pos 'neg) #t)))
|
||||
|
||||
(test-case
|
||||
"flat-contract 1"
|
||||
(check-pred (λ (x) (= x 1))
|
||||
(contract (opt/c (flat-contract (λ (x) (= x 1)))) 1 'pos 'neg)))
|
||||
|
||||
(test-exn
|
||||
"flat-contract 2"
|
||||
(match-msg "expected: flat-contract?")
|
||||
(λ ()
|
||||
(contract (opt/c (flat-contract (λ (x y) #f))) 1 'pos 'neg)))
|
||||
|
||||
(test-case
|
||||
"cons/c 1"
|
||||
(check-pred (λ (x) (and (= (car x) 1) (= (cdr x) 2)))
|
||||
(contract (opt/c (cons/c number? (flat-contract (λ (x) (= x 2)))))
|
||||
(cons 1 2) 'pos 'neg)))
|
||||
|
||||
(test-case
|
||||
"cons/c 1"
|
||||
(check-pred (λ (x) (and (= (car x) 1) (= (cdr x) 2)))
|
||||
(contract (opt/c (cons/c number? (flat-contract (λ (x) (= x 2)))))
|
||||
(cons 1 2) 'pos 'neg)))
|
||||
|
||||
(test-case
|
||||
"cons/c 2"
|
||||
(check-pred (λ (x) (and (= (car x) 1) (= ((cdr x) 1) 2)))
|
||||
(contract (opt/c (cons/c number? (-> number? any)))
|
||||
(cons 1 (λ (x) 2)) 'pos 'neg)))
|
||||
|
||||
(test-case
|
||||
"between/c 1"
|
||||
(check-pred (λ (x) (= x 1))
|
||||
(contract (opt/c (between/c 1 2)) 1 'pos 'neg)))
|
||||
|
||||
(test-case
|
||||
"between/c 2"
|
||||
(blame-to 'pos)
|
||||
(λ ()
|
||||
(contract (opt/c (between/c 1 2)) 3 'pos 'neg)))
|
||||
|
||||
(test-exn
|
||||
"between/c 2"
|
||||
(match-msg "expected: real?" "argument position: 1st")
|
||||
(λ ()
|
||||
(contract (opt/c (between/c 'x 'b)) 1 'pos 'neg)))
|
||||
|
||||
(test-exn
|
||||
"between/c 3"
|
||||
(match-msg "expected: real?" "argument position: 2nd")
|
||||
(λ ()
|
||||
(contract (opt/c (between/c 1 'b)) 1 'pos 'neg)))
|
||||
|
||||
;;
|
||||
;; name tests
|
||||
;;
|
||||
|
||||
(test-case
|
||||
"integer? name"
|
||||
(check-name 'integer? (opt/c (flat-contract integer?))))
|
||||
|
||||
(test-case
|
||||
"boolean? name"
|
||||
(check-name 'boolean? (opt/c (flat-contract boolean?))))
|
||||
|
||||
(test-case
|
||||
"char? name"
|
||||
(check-name 'char? (opt/c (flat-contract char?))))
|
||||
|
||||
(test-case
|
||||
"any/c name"
|
||||
(check-name 'any/c (opt/c any/c)))
|
||||
|
||||
(test-case
|
||||
"-> name 1"
|
||||
(check-name '(-> integer? integer?) (opt/c (-> integer? integer?))))
|
||||
|
||||
(test-case
|
||||
"-> name 2"
|
||||
(check-name '(-> integer? any) (opt/c (-> integer? any))))
|
||||
|
||||
(test-case
|
||||
"-> name 3"
|
||||
(check-name '(-> integer? (values boolean? char?)) (opt/c (-> integer? (values boolean? char?)))))
|
||||
|
||||
(test-case
|
||||
"or/c name 1"
|
||||
(check-name '(or/c) (opt/c (or/c))))
|
||||
|
||||
(test-case
|
||||
"or/c name 2"
|
||||
(check-name '(or/c integer? gt0?) (opt/c (or/c integer? (let ([gt0? (lambda (x) (> x 0))]) gt0?)))))
|
||||
|
||||
(test-case
|
||||
"or/c name 3"
|
||||
(check-name '(or/c integer? boolean?)
|
||||
(opt/c (or/c (flat-contract integer?)
|
||||
(flat-contract boolean?)))))
|
||||
|
||||
(test-case
|
||||
"or/c name 4"
|
||||
(check-name '(or/c integer? boolean?)
|
||||
(opt/c (or/c integer? boolean?))))
|
||||
|
||||
(test-case
|
||||
"or/c name 5"
|
||||
(check-name '(or/c (-> (>=/c 5) (>=/c 5)) boolean?)
|
||||
(opt/c (or/c (-> (>=/c 5) (>=/c 5)) boolean?))))
|
||||
|
||||
(test-case
|
||||
"or/c name 6"
|
||||
(check-name '(or/c boolean? (-> (>=/c 5) (>=/c 5)))
|
||||
(opt/c (or/c boolean? (-> (>=/c 5) (>=/c 5))))))
|
||||
|
||||
(test-case
|
||||
"or/c name 7"
|
||||
(check-name '(or/c (-> (>=/c 5) (>=/c 5))
|
||||
(-> (<=/c 5) (<=/c 5) (<=/c 5)))
|
||||
(opt/c (or/c (-> (>=/c 5) (>=/c 5))
|
||||
(-> (<=/c 5) (<=/c 5) (<=/c 5))))))
|
||||
|
||||
(test-case
|
||||
"or/c name 8"
|
||||
(check-name '(or/c boolean?
|
||||
(-> (>=/c 5) (>=/c 5))
|
||||
(-> (<=/c 5) (<=/c 5) (<=/c 5)))
|
||||
(opt/c (or/c boolean?
|
||||
(-> (>=/c 5) (>=/c 5))
|
||||
(-> (<=/c 5) (<=/c 5) (<=/c 5))))))
|
||||
|
||||
(test-case
|
||||
"=/c name 1"
|
||||
(check-name '(=/c 5) (opt/c (=/c 5))))
|
||||
|
||||
(test-case
|
||||
">=/c name 1"
|
||||
(check-name '(>=/c 5) (opt/c (>=/c 5))))
|
||||
|
||||
(test-case
|
||||
"<=/c name 1"
|
||||
(check-name '(<=/c 5) (opt/c (<=/c 5))))
|
||||
|
||||
(test-case
|
||||
"</c name 1"
|
||||
(check-name '(</c 5) (opt/c (</c 5))))
|
||||
|
||||
(test-case
|
||||
">/c name 1"
|
||||
(check-name '(>/c 5) (opt/c (>/c 5))))
|
||||
|
||||
(test-case
|
||||
"between/c name 1"
|
||||
(check-name '(between/c 5 6) (opt/c (between/c 5 6))))
|
||||
|
||||
(test-case
|
||||
"cons/c name 1"
|
||||
(check-name '(cons/c boolean? integer?)
|
||||
(opt/c (cons/c boolean? (flat-contract integer?)))))
|
||||
|
||||
(test-case
|
||||
"cons/c name 2"
|
||||
(check-name '(cons/c boolean? integer?)
|
||||
(opt/c (cons/c boolean? (flat-contract integer?)))))
|
||||
|
||||
(test-case
|
||||
"cons/c name 1"
|
||||
(check-name '(cons/c boolean? integer?)
|
||||
(opt/c (cons/c boolean? (flat-contract integer?)))))
|
||||
|
||||
(test-case
|
||||
"cons/c name 2"
|
||||
(check-name '(cons/c boolean? integer?)
|
||||
(opt/c (cons/c boolean? (flat-contract integer?)))))
|
||||
|
||||
(test-case
|
||||
"cons/c name 3"
|
||||
(check-name '(cons/c boolean? integer?)
|
||||
(opt/c (cons/c boolean? (flat-contract integer?)))))
|
||||
|
||||
(test-case
|
||||
"cons/c name 4"
|
||||
(check-name '(cons/c (-> boolean? boolean?) integer?)
|
||||
(opt/c (cons/c (-> boolean? boolean?) integer?))))))
|
||||
|
||||
(unless (zero? (run-tests opt-tests))
|
||||
(error 'contract-opt-tests.rkt "tests failed"))
|
||||
|
|
@ -98,7 +98,7 @@
|
|||
#:when
|
||||
(and (regexp-match #rx"[.]rkt$" (path->string file))
|
||||
(not (member (path->string file)
|
||||
'("test-util.rkt" "all.rkt")))))
|
||||
'("info.rkt" "test-util.rkt" "all.rkt")))))
|
||||
file))
|
||||
|
||||
(define (find-deps file)
|
||||
|
|
@ -117,26 +117,34 @@
|
|||
(cond
|
||||
[(and (list? exp)
|
||||
(pair? exp)
|
||||
(eq? (car exp) 'make-basic-contract-namespace))
|
||||
(when deps
|
||||
(or (equal? (car exp) 'make-basic-contract-namespace)
|
||||
(equal? (car exp) 'make-full-contract-namespace)))
|
||||
(when deps
|
||||
(error 'find-deps
|
||||
"found two calls to make-basic-contract-namespace in ~a"
|
||||
file))
|
||||
(set! deps (map remove-quote (cdr exp)))]
|
||||
(set! deps (append (if (equal? (car exp) 'make-full-contract-namespace)
|
||||
full-contract-namespace-initial-set
|
||||
'())
|
||||
(map remove-quote (cdr exp))))]
|
||||
[(list? exp)
|
||||
(for-each loop exp)]
|
||||
[else (void)]))
|
||||
(unless deps (printf "no deps ~a\n" file))
|
||||
deps)
|
||||
|
||||
(define (dep<? a b)
|
||||
(set! a (or a '()))
|
||||
(set! b (or b '()))
|
||||
(define (subset? a b)
|
||||
(for/and ([x (in-list a)])
|
||||
(member x b)))
|
||||
(or (and (subset? a b)
|
||||
(not (subset? b a)))
|
||||
(< (length a) (length b))))
|
||||
(cond
|
||||
[(and (not a) (not b)) #t]
|
||||
[(not a) #f]
|
||||
[(not b) #t]
|
||||
[else
|
||||
(define (subset? a b)
|
||||
(for/and ([x (in-list a)])
|
||||
(member x b)))
|
||||
(or (and (subset? a b)
|
||||
(not (subset? b a)))
|
||||
(< (length a) (length b)))]))
|
||||
|
||||
(define files-to-run
|
||||
(sort
|
||||
|
|
|
|||
|
|
@ -172,10 +172,137 @@ so that propagation occurs.
|
|||
|
||||
|#
|
||||
|
||||
(test/spec-passed/result
|
||||
"or 1"
|
||||
'(contract (opt/c (or/c number? boolean?)) 1 'pos 'neg)
|
||||
1)
|
||||
|
||||
(test/spec-passed/result
|
||||
"or 2"
|
||||
'(contract (opt/c (or/c number? boolean?)) #t 'pos 'neg)
|
||||
#t)
|
||||
|
||||
(test/pos-blame
|
||||
"or 3"
|
||||
'(contract (opt/c (or/c number? boolean?)) "string" 'pos 'neg))
|
||||
|
||||
(test/spec-passed/result
|
||||
"or 4"
|
||||
'((contract (opt/c (or/c number? (-> boolean? number?)))
|
||||
(λ (x) 1) 'pos 'neg) #t)
|
||||
1)
|
||||
|
||||
(test/spec-passed/result
|
||||
"or 5"
|
||||
'((contract (opt/c (or/c (-> boolean? boolean? number?) (-> boolean? number?)))
|
||||
(λ (x y) 1) 'pos 'neg) #t #f)
|
||||
1)
|
||||
|
||||
(test/spec-passed/result
|
||||
"lifting 1"
|
||||
'(let ((volatile 0))
|
||||
(contract (opt/c (between/c (begin (set! volatile 1) 3) 5)) 4 'pos 'neg)
|
||||
volatile)
|
||||
1)
|
||||
|
||||
(test/spec-passed/result
|
||||
"arrow 1"
|
||||
'((contract (opt/c (-> boolean? number?)) (λ (x) 1) 'pos 'neg) #t)
|
||||
1)
|
||||
|
||||
(test/spec-passed/result
|
||||
"arrow 2"
|
||||
'(call-with-values
|
||||
(λ () ((contract (opt/c (-> boolean? (values number? number?)))
|
||||
(λ (x) (values 1 2)) 'pos 'neg) #t))
|
||||
list)
|
||||
'(1 2))
|
||||
|
||||
(test/spec-passed/result
|
||||
"arrow 3"
|
||||
'(call-with-values
|
||||
(λ () ((contract (opt/c (-> boolean? any)) (λ (x) (values 1 2)) 'pos 'neg) #t))
|
||||
list)
|
||||
'(1 2))
|
||||
|
||||
(test/spec-passed/result
|
||||
"arrow 4"
|
||||
'((contract (opt/c (-> boolean? any)) (λ (x) 1) 'pos 'neg) #t)
|
||||
1)
|
||||
|
||||
(test/neg-blame
|
||||
"arrow 5"
|
||||
'((contract (opt/c (-> boolean? number?)) (λ (x) #t) 'pos 'neg) 1))
|
||||
|
||||
(test/pos-blame
|
||||
"arrow 6"
|
||||
'((contract (opt/c (-> boolean? number?)) (λ (x) #t) 'pos 'neg) #t))
|
||||
|
||||
(test/spec-passed/result
|
||||
"flat-contract 1"
|
||||
'(contract (opt/c (flat-contract (λ (x) (= x 1)))) 1 'pos 'neg)
|
||||
1)
|
||||
|
||||
(test/spec-passed/result
|
||||
"flat-contract 2"
|
||||
'(with-handlers ([exn:fail? (λ (x) (regexp-match? #rx"expected: flat-contract[?]"
|
||||
(exn-message x)))])
|
||||
(contract (opt/c (flat-contract (λ (x y) #f))) 1 'pos 'neg)
|
||||
'no-exn)
|
||||
#t)
|
||||
|
||||
(test/spec-passed/result
|
||||
"cons/c 1"
|
||||
'(contract (opt/c (cons/c number? (flat-contract (λ (x) (= x 2)))))
|
||||
(cons 1 2) 'pos 'neg)
|
||||
'(1 . 2))
|
||||
|
||||
(test/spec-passed/result
|
||||
"cons/c 1b"
|
||||
'(contract (opt/c (cons/c number? (flat-contract (λ (x) (= x 2)))))
|
||||
(cons 1 2) 'pos 'neg)
|
||||
'(1 . 2))
|
||||
|
||||
(test/spec-passed/result
|
||||
"cons/c 2"
|
||||
'(let ([x (contract (opt/c (cons/c number? (-> number? any)))
|
||||
(cons 1 (λ (x) 2)) 'pos 'neg)])
|
||||
(and (= (car x) 1) (= ((cdr x) 1) 2)))
|
||||
#t)
|
||||
|
||||
(test/spec-passed/result
|
||||
"between/c 1"
|
||||
'(contract (opt/c (between/c 1 2)) 1 'pos 'neg)
|
||||
1)
|
||||
|
||||
(test/pos-blame
|
||||
"between/c 2"
|
||||
'(contract (opt/c (between/c 1 2)) 3 'pos 'neg))
|
||||
|
||||
(test/spec-passed/result
|
||||
"between/c 2"
|
||||
'(with-handlers ([exn:fail? (λ (x)
|
||||
(regexp-match?
|
||||
#rx"expected: real[?].*argument position: 1st"
|
||||
(exn-message x)))])
|
||||
(contract (opt/c (between/c 'x 'b)) 1 'pos 'neg)
|
||||
'no-exn)
|
||||
#t)
|
||||
|
||||
(test/spec-passed/result
|
||||
"between/c 3"
|
||||
'(with-handlers ([exn:fail? (λ (x)
|
||||
(regexp-match?
|
||||
#rx"expected: real[?].*argument position: 2nd"
|
||||
(exn-message x)))])
|
||||
(contract (opt/c (between/c 1 'b)) 1 'pos 'neg))
|
||||
#t)
|
||||
|
||||
|
||||
|
||||
;; test the predicate
|
||||
(ctest #t couple? (contract (couple/c any/c any/c) (make-couple 1 2) 'pos 'neg))
|
||||
(ctest #t couple? (make-couple 1 2))
|
||||
(ctest #t couple? (contract (couple/dc [hd any/c] [tl (hd) any/c]) (make-couple 1 2) 'pos 'neg))
|
||||
(ctest #f couple? 1)
|
||||
(ctest #f couple? #f))
|
||||
(ctest #f couple? #f))
|
||||
|
|
|
|||
|
|
@ -13,6 +13,7 @@
|
|||
current-contract-namespace
|
||||
make-basic-contract-namespace
|
||||
make-full-contract-namespace
|
||||
full-contract-namespace-initial-set
|
||||
|
||||
contract-syntax-error-test
|
||||
contract-error-test
|
||||
|
|
@ -104,10 +105,10 @@
|
|||
|
||||
(define (make-full-contract-namespace . addons)
|
||||
(apply make-basic-contract-namespace
|
||||
'racket/contract
|
||||
'racket/class
|
||||
'racket/set
|
||||
addons))
|
||||
(append full-contract-namespace-initial-set addons)))
|
||||
(define full-contract-namespace-initial-set
|
||||
'(racket/contract racket/class racket/set))
|
||||
|
||||
|
||||
(define (contract-eval x #:test-case-name [test-case #f])
|
||||
(with-handlers ((exn:fail? (λ (x)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user