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

improve flat-contract test suite so that it checks

Browse Source 
the predicate-ness of the contracts
This commit is contained in:
Robby Findler 2017-05-12 10:51:59 -05:00
parent 7908be8ce9
commit 8f34b702ab
2 changed files with 64 additions and 53 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
pkgs/racket-test/tests/racket/contract/flat-contracts.rkt
View File

@ -10,15 +10,15 @@
(define-syntax (test-flat-contract stx) (define-syntax (test-flat-contract stx)
(syntax-case stx () (syntax-case stx ()
[(_ contract pass fail) [(_ contract pass fail more ...)
#`(test-flat-contract/proc contract pass fail #,(syntax-line stx))])) #`(test-flat-contract/proc contract pass fail #,(syntax-line stx)
more ...)]))
(define (test-flat-contract/proc contract pass fail line) (define (test-flat-contract/proc contract pass fail line
#:skip-predicate-checks? [skip-predicate-checks? #f])
(contract-eval `(,test #t flat-contract? ,contract)) (contract-eval `(,test #t flat-contract? ,contract))
(define (run-two-tests maybe-rewrite) (define (run-two-tests maybe-rewrite)
(let ([name (if (pair? contract) (define name (if (pair? contract) (car contract) contract))
(car contract)
contract)])
(let/ec k (let/ec k
(test/spec-failed (format "~a fail, line ~a" name line) (test/spec-failed (format "~a fail, line ~a" name line)
(maybe-rewrite `(contract ,contract ',fail 'pos 'neg) k) (maybe-rewrite `(contract ,contract ',fail 'pos 'neg) k)
@ -27,7 +27,17 @@
(test/spec-passed/result (test/spec-passed/result
(format "~a pass, line ~a" name line) (format "~a pass, line ~a" name line)
(maybe-rewrite `(contract ,contract ',pass 'pos 'neg) k) (maybe-rewrite `(contract ,contract ',pass 'pos 'neg) k)
pass)))) pass))
(unless skip-predicate-checks?
(let/ec k
(test/spec-passed/result (format "~a predicate returns #f, line ~a" name line)
(maybe-rewrite `(,contract ',fail) k)
#f))
(let/ec k
(test/spec-passed/result
(format "~a predicate returns #t, line ~a" name line)
(maybe-rewrite `(,contract ',pass) k)
#t))))
(run-two-tests (λ (x k) x)) (run-two-tests (λ (x k) x))
(run-two-tests rewrite-to-add-opt/c)) (run-two-tests rewrite-to-add-opt/c))
@ -68,7 +78,7 @@
(test-flat-contract 'natural-number/c 5 -1) (test-flat-contract 'natural-number/c 5 -1)
(test-flat-contract 'natural-number/c #e3 #i3.0) (test-flat-contract 'natural-number/c #e3 #i3.0)
(test-flat-contract 'natural-number/c 0 -1) (test-flat-contract 'natural-number/c 0 -1)
(test-flat-contract 'false/c #f #t) (test-flat-contract 'false/c #f #t #:skip-predicate-checks? #t)
(test-flat-contract 'contract? #f (λ (x y) 'whatever)) (test-flat-contract 'contract? #f (λ (x y) 'whatever))
(test-flat-contract '(and/c real? negative?) -1 0) (test-flat-contract '(and/c real? negative?) -1 0)
@ -81,25 +91,25 @@
(test-flat-contract '(and/c (flat-named-contract 'Real real?) (not/c positive?)) 0 1) (test-flat-contract '(and/c (flat-named-contract 'Real real?) (not/c positive?)) 0 1)
(test-flat-contract '(and/c (flat-named-contract 'Real real?) (not/c negative?)) 0 -1) (test-flat-contract '(and/c (flat-named-contract 'Real real?) (not/c negative?)) 0 -1)
(test-flat-contract #t #t "x") (test-flat-contract #t #t "x" #:skip-predicate-checks? #t)
(test-flat-contract #f #f "x") (test-flat-contract #f #f "x" #:skip-predicate-checks? #t)
(test-flat-contract #\a #\a #\b) (test-flat-contract #\a #\a #\b #:skip-predicate-checks? #t)
(test-flat-contract #\a #\a 'a) (test-flat-contract #\a #\a 'a #:skip-predicate-checks? #t)
(test-flat-contract ''a 'a 'b) (test-flat-contract ''a 'a 'b #:skip-predicate-checks? #t)
(let ([a #\⊢]) (let ([a #\⊢])
(test-flat-contract a (integer->char (char->integer a)) #\a)) (test-flat-contract a (integer->char (char->integer a)) #\a #:skip-predicate-checks? #t))
(test-flat-contract ''a 'a #\a) (test-flat-contract ''a 'a #\a #:skip-predicate-checks? #t)
(test-flat-contract "x" "x" "y") (test-flat-contract "x" "x" "y" #:skip-predicate-checks? #t)
(test-flat-contract "x" "x" 'x) (test-flat-contract "x" "x" 'x #:skip-predicate-checks? #t)
(test-flat-contract 1 1 2) (test-flat-contract 1 1 2 #:skip-predicate-checks? #t)
(test-flat-contract #e1 #i1.0 'x) (test-flat-contract #e1 #i1.0 'x #:skip-predicate-checks? #t)
(test-flat-contract +nan.0 +nan.0 +nan.f) (test-flat-contract +nan.0 +nan.0 +nan.f #:skip-predicate-checks? #t)
(test-flat-contract +nan.f +nan.f +nan.0) (test-flat-contract +nan.f +nan.f +nan.0 #:skip-predicate-checks? #t)
(test-flat-contract #rx".x." "axq" "x") (test-flat-contract #rx".x." "axq" "x" #:skip-predicate-checks? #t)
(test-flat-contract #rx#".x." #"axq" #"x") (test-flat-contract #rx#".x." #"axq" #"x" #:skip-predicate-checks? #t)
(test-flat-contract #rx".x." #"axq" #"x") (test-flat-contract #rx".x." #"axq" #"x" #:skip-predicate-checks? #t)
(test-flat-contract #rx#".x." "axq" "x") (test-flat-contract #rx#".x." "axq" "x" #:skip-predicate-checks? #t)
(test-flat-contract ''() '() #f) (test-flat-contract ''() '() #f #:skip-predicate-checks? #t)
(test-flat-contract '(if/c integer? even? list?) 2 3) (test-flat-contract '(if/c integer? even? list?) 2 3)
(test-flat-contract '(if/c integer? even? list?) '() #f) (test-flat-contract '(if/c integer? even? list?) '() #f)

5
racket/collects/racket/contract/private/misc.rkt
View File

@ -916,7 +916,7 @@
(flat-named-contract (flat-named-contract
'printable/c 'printable/c
(λ (x) (λ (x)
(let printable? ([x x]) (and (let printable? ([x x])
(or (symbol? x) (or (symbol? x)
(string? x) (string? x)
(bytes? x) (bytes? x)
@ -937,7 +937,8 @@
(immutable? x) (immutable? x)
(for/and ([(k v) (in-hash x)]) (for/and ([(k v) (in-hash x)])
(and (printable? k) (and (printable? k)
(printable? v))))))))) (printable? v))))))
#t))))
(define natural-number/c (define natural-number/c