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

add missing require, fix opt/c test suite

Browse Source
This commit is contained in:
Robby Findler 2011-03-29 08:50:16 -05:00
parent 68f7e9f33b
commit 5b879d0680
2 changed files with 283 additions and 283 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/racket/contract/private/basic-opters.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(require "guts.rkt" (require "guts.rkt"
"blame.rkt"
"opt.rkt" "opt.rkt"
"base.rkt") "base.rkt")
(require (for-syntax racket/base (require (for-syntax racket/base

455
collects/tests/racket/contract-opt-tests.rkt
View File

@ -1,284 +1,283 @@
(module contract-opt-tests mzscheme #lang racket/base
(require mzlib/contract (require racket/contract
rackunit rackunit
rackunit/text-ui) rackunit/text-ui)
(define (exn:fail:contract-violation? exn) (define (exn:fail:contract-violation? exn)
(if (regexp-match #rx"broke" (exn-message exn)) #t #f)) (if (regexp-match #rx"contract violation" (exn-message exn)) #t #f))
(define ((blame-to whom) exn) (define ((blame-to whom) exn)
(and (exn:fail:contract-violation? exn) (and (exn:fail:contract-violation? exn)
(regexp-match (format "~a broke" whom) (regexp-match (regexp-quote (format "blaming ~a" whom))
(exn-message exn)))) (exn-message exn))))
(define ((match-msg msg) exn) (define ((match-msg msg) exn)
(regexp-match (regexp msg) (exn-message exn))) (regexp-match (regexp msg) (exn-message exn)))
(define-simple-check (check-pred2 func thunk) (define-simple-check (check-pred2 func thunk)
(let-values ([(a b) (thunk)]) (let-values ([(a b) (thunk)])
(func a b))) (func a b)))
(define-simple-check (check-name expected ctc) (define-simple-check (check-name expected ctc)
(let ((got (contract-name ctc))) (let ((got (contract-name ctc)))
(equal? expected got))) (equal? expected got)))
(define opt-tests (define opt-tests
(test-suite (test-suite
"Tests for opt/c" "Tests for opt/c"
(test-case (test-case
"or 1" "or 1"
(check-pred (λ (x) (= x 1)) (check-pred (λ (x) (= x 1))
(contract (opt/c (or/c number? boolean?)) 1 'pos 'neg))) (contract (opt/c (or/c number? boolean?)) 1 'pos 'neg)))
(test-case (test-case
"or 2" "or 2"
(check-pred (λ (x) (eq? x #t)) (check-pred (λ (x) (eq? x #t))
(contract (opt/c (or/c number? boolean?)) #t 'pos 'neg))) (contract (opt/c (or/c number? boolean?)) #t 'pos 'neg)))
(test-exn (test-exn
"or 3" "or 3"
(blame-to 'pos) (blame-to 'pos)
(λ () (λ ()
(contract (opt/c (or/c number? boolean?)) "string" 'pos 'neg))) (contract (opt/c (or/c number? boolean?)) "string" 'pos 'neg)))
(test-case (test-case
"or 4" "or 4"
(check-pred (λ (x) (= x 1)) (check-pred (λ (x) (= x 1))
((contract (opt/c (or/c number? (-> boolean? number?))) ((contract (opt/c (or/c number? (-> boolean? number?)))
(λ (x) 1) 'pos 'neg) #t))) (λ (x) 1) 'pos 'neg) #t)))
(test-case (test-case
"or 5" "or 5"
(check-pred (λ (x) (= x 1)) (check-pred (λ (x) (= x 1))
((contract (opt/c (or/c (-> boolean? boolean? number?) (-> boolean? number?))) ((contract (opt/c (or/c (-> boolean? boolean? number?) (-> boolean? number?)))
(λ (x y) 1) 'pos 'neg) #t #f))) (λ (x y) 1) 'pos 'neg) #t #f)))
(test-case (test-case
"lifting 1" "lifting 1"
(check-pred (λ (x) (= x 1)) (check-pred (λ (x) (= x 1))
(let ((volatile 0)) (let ((volatile 0))
(contract (opt/c (between/c (begin (set! volatile 1) 3) 5)) 4 'pos 'neg) (contract (opt/c (between/c (begin (set! volatile 1) 3) 5)) 4 'pos 'neg)
volatile))) volatile)))
(test-case (test-case
"arrow 1" "arrow 1"
(check-pred (λ (x) (= x 1)) (check-pred (λ (x) (= x 1))
((contract (opt/c (-> boolean? number?)) (λ (x) 1) 'pos 'neg) #t))) ((contract (opt/c (-> boolean? number?)) (λ (x) 1) 'pos 'neg) #t)))
(test-case (test-case
"arrow 2" "arrow 2"
(check-pred2 (λ (x y) (and (= x 1) (= y 2))) (check-pred2 (λ (x y) (and (= x 1) (= y 2)))
(λ () (λ ()
((contract (opt/c (-> boolean? (values number? number?))) ((contract (opt/c (-> boolean? (values number? number?)))
(λ (x) (values 1 2)) 'pos 'neg) #t)))) (λ (x) (values 1 2)) 'pos 'neg) #t))))
(test-case (test-case
"arrow 3" "arrow 3"
(check-pred2 (λ (x y) (and (= x 1) (= y 2))) (check-pred2 (λ (x y) (and (= x 1) (= y 2)))
(λ () (λ ()
((contract (opt/c (-> boolean? any)) (λ (x) (values 1 2)) 'pos 'neg) #t)))) ((contract (opt/c (-> boolean? any)) (λ (x) (values 1 2)) 'pos 'neg) #t))))
(test-case (test-case
"arrow 4" "arrow 4"
(check-pred (λ (x) (= x 1)) (check-pred (λ (x) (= x 1))
((contract (opt/c (-> boolean? any)) (λ (x) 1) 'pos 'neg) #t))) ((contract (opt/c (-> boolean? any)) (λ (x) 1) 'pos 'neg) #t)))
(test-exn (test-exn
"arrow 5" "arrow 5"
(blame-to 'neg) (blame-to 'neg)
(λ () (λ ()
((contract (opt/c (-> boolean? number?)) (λ (x) #t) 'pos 'neg) 1))) ((contract (opt/c (-> boolean? number?)) (λ (x) #t) 'pos 'neg) 1)))
(test-exn (test-exn
"arrow 6" "arrow 6"
(blame-to 'pos) (blame-to 'pos)
(λ () (λ ()
((contract (opt/c (-> boolean? number?)) (λ (x) #t) 'pos 'neg) #t))) ((contract (opt/c (-> boolean? number?)) (λ (x) #t) 'pos 'neg) #t)))
(test-case (test-case
"flat-contract 1" "flat-contract 1"
(check-pred (λ (x) (= x 1)) (check-pred (λ (x) (= x 1))
(contract (opt/c (flat-contract (λ (x) (= x 1)))) 1 'pos 'neg))) (contract (opt/c (flat-contract (λ (x) (= x 1)))) 1 'pos 'neg)))
(test-exn (test-exn
"flat-contract 2" "flat-contract 2"
(match-msg "expected a flat") (match-msg "expected a flat")
(λ () (λ ()
(contract (opt/c (flat-contract (λ (x y) #f))) 1 'pos 'neg))) (contract (opt/c (flat-contract (λ (x y) #f))) 1 'pos 'neg)))
(test-case (test-case
"cons/c 1" "cons/c 1"
(check-pred (λ (x) (and (= (car x) 1) (= (cdr x) 2))) (check-pred (λ (x) (and (= (car x) 1) (= (cdr x) 2)))
(contract (opt/c (cons/c number? (flat-contract (λ (x) (= x 2))))) (contract (opt/c (cons/c number? (flat-contract (λ (x) (= x 2)))))
(cons 1 2) 'pos 'neg))) (cons 1 2) 'pos 'neg)))
(test-case (test-case
"cons/c 1" "cons/c 1"
(check-pred (λ (x) (and (= (car x) 1) (= (cdr x) 2))) (check-pred (λ (x) (and (= (car x) 1) (= (cdr x) 2)))
(contract (opt/c (cons/c number? (flat-contract (λ (x) (= x 2))))) (contract (opt/c (cons/c number? (flat-contract (λ (x) (= x 2)))))
(cons 1 2) 'pos 'neg))) (cons 1 2) 'pos 'neg)))
(test-case (test-case
"cons/c 2" "cons/c 2"
(check-pred (λ (x) (and (= (car x) 1) (= ((cdr x) 1) 2))) (check-pred (λ (x) (and (= (car x) 1) (= ((cdr x) 1) 2)))
(contract (opt/c (cons/c number? (-> number? any))) (contract (opt/c (cons/c number? (-> number? any)))
(cons 1 (λ (x) 2)) 'pos 'neg))) (cons 1 (λ (x) 2)) 'pos 'neg)))
(test-case (test-case
"between/c 1" "between/c 1"
(check-pred (λ (x) (= x 1)) (check-pred (λ (x) (= x 1))
(contract (opt/c (between/c 1 2)) 1 'pos 'neg))) (contract (opt/c (between/c 1 2)) 1 'pos 'neg)))
(test-case (test-case
"between/c 2" "between/c 2"
(blame-to 'pos) (blame-to 'pos)
(λ () (λ ()
(contract (opt/c (between/c 1 2)) 3 'pos 'neg))) (contract (opt/c (between/c 1 2)) 3 'pos 'neg)))
(test-exn (test-exn
"between/c 2" "between/c 2"
(match-msg "expected a number as first") (match-msg "expected a real number as first")
(λ () (λ ()
(contract (opt/c (between/c 'x 'b)) 1 'pos 'neg))) (contract (opt/c (between/c 'x 'b)) 1 'pos 'neg)))
(test-exn (test-exn
"between/c 3" "between/c 3"
(match-msg "expected a number as second") (match-msg "expected a real number as second")
(λ () (λ ()
(contract (opt/c (between/c 1 'b)) 1 'pos 'neg))) (contract (opt/c (between/c 1 'b)) 1 'pos 'neg)))
;; ;;
;; name tests ;; name tests
;; ;;
(test-case (test-case
"integer? name" "integer? name"
(check-name 'integer? (opt/c (flat-contract integer?)))) (check-name 'integer? (opt/c (flat-contract integer?))))
(test-case (test-case
"boolean? name" "boolean? name"
(check-name 'boolean? (opt/c (flat-contract boolean?)))) (check-name 'boolean? (opt/c (flat-contract boolean?))))
(test-case (test-case
"char? name" "char? name"
(check-name 'char? (opt/c (flat-contract char?)))) (check-name 'char? (opt/c (flat-contract char?))))
(test-case (test-case
"any/c name" "any/c name"
(check-name 'any/c (opt/c any/c))) (check-name 'any/c (opt/c any/c)))
(test-case (test-case
"-> name 1" "-> name 1"
(check-name '(-> integer? integer?) (opt/c (-> integer? integer?)))) (check-name '(-> integer? integer?) (opt/c (-> integer? integer?))))
(test-case (test-case
"-> name 2" "-> name 2"
(check-name '(-> integer? any) (opt/c (-> integer? any)))) (check-name '(-> integer? any) (opt/c (-> integer? any))))
(test-case (test-case
"-> name 3" "-> name 3"
(check-name '(-> integer? (values boolean? char?)) (opt/c (-> integer? (values boolean? char?))))) (check-name '(-> integer? (values boolean? char?)) (opt/c (-> integer? (values boolean? char?)))))
(test-case (test-case
"or/c name 1" "or/c name 1"
(check-name '(or/c) (opt/c (or/c)))) (check-name '(or/c) (opt/c (or/c))))
(test-case (test-case
"or/c name 2" "or/c name 2"
(check-name '(or/c integer? gt0?) (opt/c (or/c integer? (let ([gt0? (lambda (x) (> x 0))]) gt0?))))) (check-name '(or/c integer? gt0?) (opt/c (or/c integer? (let ([gt0? (lambda (x) (> x 0))]) gt0?)))))
(test-case (test-case
"or/c name 3" "or/c name 3"
(check-name '(or/c integer? boolean?) (check-name '(or/c integer? boolean?)
(opt/c (or/c (flat-contract integer?) (opt/c (or/c (flat-contract integer?)
(flat-contract boolean?))))) (flat-contract boolean?)))))
(test-case (test-case
"or/c name 4" "or/c name 4"
(check-name '(or/c integer? boolean?) (check-name '(or/c integer? boolean?)
(opt/c (or/c integer? boolean?)))) (opt/c (or/c integer? boolean?))))
(test-case (test-case
"or/c name 5" "or/c name 5"
(check-name '(or/c (-> (>=/c 5) (>=/c 5)) boolean?) (check-name '(or/c (-> (>=/c 5) (>=/c 5)) boolean?)
(opt/c (or/c (-> (>=/c 5) (>=/c 5)) boolean?)))) (opt/c (or/c (-> (>=/c 5) (>=/c 5)) boolean?))))
(test-case (test-case
"or/c name 6" "or/c name 6"
(check-name '(or/c (-> (>=/c 5) (>=/c 5)) boolean?) (check-name '(or/c (-> (>=/c 5) (>=/c 5)) boolean?)
(opt/c (or/c boolean? (-> (>=/c 5) (>=/c 5)))))) (opt/c (or/c boolean? (-> (>=/c 5) (>=/c 5))))))
(test-case (test-case
"or/c name 7" "or/c name 7"
(check-name '(or/c (-> (>=/c 5) (>=/c 5)) (check-name '(or/c (-> (>=/c 5) (>=/c 5))
(-> (<=/c 5) (<=/c 5) (<=/c 5))) (-> (<=/c 5) (<=/c 5) (<=/c 5)))
(opt/c (or/c (-> (>=/c 5) (>=/c 5)) (opt/c (or/c (-> (>=/c 5) (>=/c 5))
(-> (<=/c 5) (<=/c 5) (<=/c 5)))))) (-> (<=/c 5) (<=/c 5) (<=/c 5))))))
(test-case (test-case
"or/c name 8" "or/c name 8"
(check-name '(or/c boolean? (check-name '(or/c boolean?
(-> (>=/c 5) (>=/c 5)) (-> (>=/c 5) (>=/c 5))
(-> (<=/c 5) (<=/c 5) (<=/c 5))) (-> (<=/c 5) (<=/c 5) (<=/c 5)))
(opt/c (or/c boolean? (opt/c (or/c boolean?
(-> (>=/c 5) (>=/c 5)) (-> (>=/c 5) (>=/c 5))
(-> (<=/c 5) (<=/c 5) (<=/c 5)))))) (-> (<=/c 5) (<=/c 5) (<=/c 5))))))
(test-case (test-case
"=/c name 1" "=/c name 1"
(check-name '(=/c 5) (opt/c (=/c 5)))) (check-name '(=/c 5) (opt/c (=/c 5))))
(test-case (test-case
">=/c name 1" ">=/c name 1"
(check-name '(>=/c 5) (opt/c (>=/c 5)))) (check-name '(>=/c 5) (opt/c (>=/c 5))))
(test-case (test-case
"<=/c name 1" "<=/c name 1"
(check-name '(<=/c 5) (opt/c (<=/c 5)))) (check-name '(<=/c 5) (opt/c (<=/c 5))))
(test-case (test-case
"</c name 1" "</c name 1"
(check-name '(</c 5) (opt/c (</c 5)))) (check-name '(</c 5) (opt/c (</c 5))))
(test-case (test-case
">/c name 1" ">/c name 1"
(check-name '(>/c 5) (opt/c (>/c 5)))) (check-name '(>/c 5) (opt/c (>/c 5))))
(test-case (test-case
"between/c name 1" "between/c name 1"
(check-name '(between/c 5 6) (opt/c (between/c 5 6)))) (check-name '(between/c 5 6) (opt/c (between/c 5 6))))
(test-case (test-case
"cons/c name 1" "cons/c name 1"
(check-name '(cons/c boolean? integer?) (check-name '(cons/c boolean? integer?)
(opt/c (cons/c boolean? (flat-contract integer?))))) (opt/c (cons/c boolean? (flat-contract integer?)))))
(test-case (test-case
"cons/c name 2" "cons/c name 2"
(check-name '(cons/c boolean? integer?) (check-name '(cons/c boolean? integer?)
(opt/c (cons/c boolean? (flat-contract integer?))))) (opt/c (cons/c boolean? (flat-contract integer?)))))
(test-case (test-case
"cons/c name 1" "cons/c name 1"
(check-name '(cons/c boolean? integer?) (check-name '(cons/c boolean? integer?)
(opt/c (cons/c boolean? (flat-contract integer?))))) (opt/c (cons/c boolean? (flat-contract integer?)))))
(test-case (test-case
"cons/c name 2" "cons/c name 2"
(check-name '(cons/c boolean? integer?) (check-name '(cons/c boolean? integer?)
(opt/c (cons/c boolean? (flat-contract integer?))))) (opt/c (cons/c boolean? (flat-contract integer?)))))
(test-case (test-case
"cons/c name 3" "cons/c name 3"
(check-name '(cons/c boolean? integer?) (check-name '(cons/c boolean? integer?)
(opt/c (cons/c boolean? (flat-contract integer?))))) (opt/c (cons/c boolean? (flat-contract integer?)))))
(test-case (test-case
"cons/c name 4" "cons/c name 4"
(check-name '(cons/c (-> boolean? boolean?) integer?) (check-name '(cons/c (-> boolean? boolean?) integer?)
(opt/c (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"))
(run-tests opt-tests))