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

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

@ -10,24 +10,34 @@
(define-syntax (test-flat-contract stx)
(syntax-case stx ()
[(_ contract pass fail)
#`(test-flat-contract/proc contract pass fail #,(syntax-line stx))]))
[(_ contract pass fail more ...)
#`(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))
(define (run-two-tests maybe-rewrite)
(let ([name (if (pair? contract)
(car contract)
contract)])
(define name (if (pair? contract) (car contract) contract))
(let/ec k
(test/spec-failed (format "~a fail, line ~a" name line)
(maybe-rewrite `(contract ,contract ',fail 'pos 'neg) k)
'pos))
(let/ec k
(test/spec-passed/result
(format "~a pass, line ~a" name line)
(maybe-rewrite `(contract ,contract ',pass 'pos 'neg) k)
pass))
(unless skip-predicate-checks?
(let/ec k
(test/spec-failed (format "~a fail, line ~a" name line)
(maybe-rewrite `(contract ,contract ',fail 'pos 'neg) k)
'pos))
(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 pass, line ~a" name line)
(maybe-rewrite `(contract ,contract ',pass 'pos 'neg) k)
pass))))
(format "~a predicate returns #t, line ~a" name line)
(maybe-rewrite `(,contract ',pass) k)
#t))))
(run-two-tests (λ (x k) x))
(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 #e3 #i3.0)
(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 '(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 negative?)) 0 -1)
(test-flat-contract #t #t "x")
(test-flat-contract #f #f "x")
(test-flat-contract #\a #\a #\b)
(test-flat-contract #\a #\a 'a)
(test-flat-contract ''a 'a 'b)
(test-flat-contract #t #t "x" #:skip-predicate-checks? #t)
(test-flat-contract #f #f "x" #:skip-predicate-checks? #t)
(test-flat-contract #\a #\a #\b #:skip-predicate-checks? #t)
(test-flat-contract #\a #\a 'a #:skip-predicate-checks? #t)
(test-flat-contract ''a 'a 'b #:skip-predicate-checks? #t)
(let ([a #\⊢])
(test-flat-contract a (integer->char (char->integer a)) #\a))
(test-flat-contract ''a 'a #\a)
(test-flat-contract "x" "x" "y")
(test-flat-contract "x" "x" 'x)
(test-flat-contract 1 1 2)
(test-flat-contract #e1 #i1.0 'x)
(test-flat-contract +nan.0 +nan.0 +nan.f)
(test-flat-contract +nan.f +nan.f +nan.0)
(test-flat-contract #rx".x." "axq" "x")
(test-flat-contract #rx#".x." #"axq" #"x")
(test-flat-contract #rx".x." #"axq" #"x")
(test-flat-contract #rx#".x." "axq" "x")
(test-flat-contract ''() '() #f)
(test-flat-contract a (integer->char (char->integer a)) #\a #:skip-predicate-checks? #t))
(test-flat-contract ''a 'a #\a #:skip-predicate-checks? #t)
(test-flat-contract "x" "x" "y" #:skip-predicate-checks? #t)
(test-flat-contract "x" "x" 'x #:skip-predicate-checks? #t)
(test-flat-contract 1 1 2 #:skip-predicate-checks? #t)
(test-flat-contract #e1 #i1.0 'x #:skip-predicate-checks? #t)
(test-flat-contract +nan.0 +nan.0 +nan.f #:skip-predicate-checks? #t)
(test-flat-contract +nan.f +nan.f +nan.0 #:skip-predicate-checks? #t)
(test-flat-contract #rx".x." "axq" "x" #:skip-predicate-checks? #t)
(test-flat-contract #rx#".x." #"axq" #"x" #:skip-predicate-checks? #t)
(test-flat-contract #rx".x." #"axq" #"x" #:skip-predicate-checks? #t)
(test-flat-contract #rx#".x." "axq" "x" #:skip-predicate-checks? #t)
(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?) '() #f)

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

@ -916,28 +916,29 @@
(flat-named-contract
'printable/c
(λ (x)
(let printable? ([x x])
(or (symbol? x)
(string? x)
(bytes? x)
(boolean? x)
(char? x)
(null? x)
(number? x)
(regexp? x)
(prefab-struct-key x) ;; this cannot be last, since it doesn't return just #t
(and (pair? x)
(printable? (car x))
(printable? (cdr x)))
(and (vector? x)
(andmap printable? (vector->list x)))
(and (box? x)
(printable? (unbox x)))
(and (hash? x)
(immutable? x)
(for/and ([(k v) (in-hash x)])
(and (printable? k)
(printable? v)))))))))
(and (let printable? ([x x])
(or (symbol? x)
(string? x)
(bytes? x)
(boolean? x)
(char? x)
(null? x)
(number? x)
(regexp? x)
(prefab-struct-key x) ;; this cannot be last, since it doesn't return just #t
(and (pair? x)
(printable? (car x))
(printable? (cdr x)))
(and (vector? x)
(andmap printable? (vector->list x)))
(and (box? x)
(printable? (unbox x)))
(and (hash? x)
(immutable? x)
(for/and ([(k v) (in-hash x)])
(and (printable? k)
(printable? v))))))
#t))))
(define natural-number/c