From 8f34b702ab276bf0027c4c1cca7fd2a135ac0ab0 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 12 May 2017 10:51:59 -0500 Subject: [PATCH] improve flat-contract test suite so that it checks the predicate-ness of the contracts --- .../tests/racket/contract/flat-contracts.rkt | 72 +++++++++++-------- .../collects/racket/contract/private/misc.rkt | 45 ++++++------ 2 files changed, 64 insertions(+), 53 deletions(-) diff --git a/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt b/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt index 73ce62b6b6..24ecae3be6 100644 --- a/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt +++ b/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt @@ -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) diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index a299ea1cb4..358f74d783 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -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