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

Fix flat immutable container ctcs so that errors pinpoint specific elements.

Browse Source 
* Fixes immutable container contract combinators so that, if given flat
   contracts, they report blame errors in terms of the specific element
   that failed, instead of reporting the entire container as failing.

   This fixes issues seen with contracts such as (listof string?), where
   the contract is applied to a list with far too many elements to print
   all at once and the failing element is never printed.

 * Fixes vector-immutable/c so that if all the element contracts are flat,
   we create a flat contract, like the other immutable container contract
   combinators.

 * Also have more appropriate first-order checks for each combinator
   than just "Is it the right type of container?".

These changes affect:
 listof
 non-empty-listof
 vector-immutableof
 cons/c
 box-immutable/c
 vector-immutable/c
This commit is contained in:
Stevie Strickland 2010-06-09 13:22:42 -04:00
parent d6ddbe15d5
commit 99bb46d225
2 changed files with 122 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -714,45 +714,57 @@
(define-syntax (*-immutableof stx) (define-syntax (*-immutableof stx)
(syntax-case stx () (syntax-case stx ()
[(_ predicate? fill testmap type-name name) [(_ predicate? app fill testmap type-name name)
(identifier? (syntax predicate?)) (identifier? (syntax predicate?))
(syntax (syntax
(let ([fill-name fill]) (let ([fill-name fill]
[for-each-name app])
(λ (input) (λ (input)
(let ([ctc (coerce-contract 'name input)]) (let* ([ctc (coerce-contract 'name input)]
[fo-check
(λ (x)
(and (predicate? x)
(testmap (λ (v) (contract-first-order-passes? ctc v)) x)))]
[proj (contract-projection ctc)])
(if (flat-contract? ctc) (if (flat-contract? ctc)
(let ([content-pred? (flat-contract-predicate ctc)]) (make-flat-contract
(build-flat-contract #:name (build-compound-type-name 'name ctc)
`(name ,(contract-name ctc)) #:first-order fo-check
(lambda (x) (and (predicate? x) (testmap content-pred? x))))) #:projection
(let ([proj (contract-projection ctc)]) (λ (blame)
(make-contract (let ([p-app (proj blame)])
#:name (build-compound-type-name 'name ctc) (λ (val)
#:projection (unless (predicate? val)
(λ (blame) (raise-blame-error blame val
(let ([p-app (proj blame)]) "expected <~a>, given: ~e"
(λ (val) 'type-name val))
(unless (predicate? val) (for-each-name p-app val)
(raise-blame-error val))))
blame (make-contract
val #:name (build-compound-type-name 'name ctc)
"expected <~a>, given: ~e" #:first-order fo-check
'type-name #:projection
val)) (λ (blame)
(fill-name p-app val)))) (let ([p-app (proj blame)])
#:first-order predicate?)))))))])) (λ (val)
(unless (predicate? val)
(raise-blame-error blame val
"expected <~a>, given: ~e"
'type-name val))
(fill-name p-app val))))))))))]))
(define listof (define listof
(*-immutableof list? map andmap list listof)) (*-immutableof list? for-each map andmap list listof))
(define (non-empty-list? x) (and (pair? x) (list? (cdr x)))) (define (non-empty-list? x) (and (pair? x) (list? (cdr x))))
(define non-empty-listof (define non-empty-listof
(*-immutableof non-empty-list? map andmap non-empty-list non-empty-listof)) (*-immutableof non-empty-list? for-each map andmap non-empty-list non-empty-listof))
(define (immutable-vector? val) (and (immutable? val) (vector? val))) (define (immutable-vector? val) (and (immutable? val) (vector? val)))
(define vector-immutableof (define vector-immutableof
(*-immutableof immutable-vector? (*-immutableof immutable-vector?
(λ (f v) (for-each f (vector->list v)))
(λ (f v) (apply vector-immutable (map f (vector->list v)))) (λ (f v) (apply vector-immutable (map f (vector->list v))))
(λ (f v) (andmap f (vector->list v))) (λ (f v) (andmap f (vector->list v)))
immutable-vector immutable-vector
@ -865,7 +877,15 @@
(and (eq? #f (syntax->datum (syntax arb?))) (and (eq? #f (syntax->datum (syntax arb?)))
(boolean? (syntax->datum #'test-immutable?))) (boolean? (syntax->datum #'test-immutable?)))
(let ([test-immutable? (syntax->datum #'test-immutable?)]) (let ([test-immutable? (syntax->datum #'test-immutable?)])
(with-syntax ([(params ...) (generate-temporaries (syntax (selectors ...)))] (with-syntax ([pred?
(if test-immutable?
#'(λ (v) (and (predicate?-name v) (immutable? v)))
#'predicate?-name)]
[pred-fail-text
(if test-immutable?
"expected immutable <~a>, given: ~e"
"expected <~a>, given: ~e")]
[(params ...) (generate-temporaries (syntax (selectors ...)))]
[(p-apps ...) (generate-temporaries (syntax (selectors ...)))] [(p-apps ...) (generate-temporaries (syntax (selectors ...)))]
[(ctc-x ...) (generate-temporaries (syntax (selectors ...)))] [(ctc-x ...) (generate-temporaries (syntax (selectors ...)))]
[(procs ...) (generate-temporaries (syntax (selectors ...)))] [(procs ...) (generate-temporaries (syntax (selectors ...)))]
@ -874,35 +894,38 @@
[constructor-name constructor] [constructor-name constructor]
[selector-names selectors] ...) [selector-names selectors] ...)
(λ (params ...) (λ (params ...)
(let ([ctc-x (coerce-contract 'name params)] ...) (let* ([ctc-x (coerce-contract 'name params)] ...
[procs (contract-projection ctc-x)] ...
[fo-check
(λ (v)
(and (pred? v)
(contract-first-order-passes? ctc-x (selector-names v)) ...))])
(if (and (flat-contract? ctc-x) ...) (if (and (flat-contract? ctc-x) ...)
(let ([p-apps (flat-contract-predicate ctc-x)] ...) (make-flat-contract
(build-flat-contract #:name (build-compound-type-name 'name ctc-x ...)
`(name ,(contract-name ctc-x) ...) #:first-order fo-check
(lambda (x) #:projection
(and (predicate?-name x) (λ (blame)
(p-apps (selector-names x)) (let ([p-apps (procs blame)] ...)
...)))) (λ (v)
(let ([procs (contract-projection ctc-x)] ...) (unless (pred? v)
(make-contract (raise-blame-error blame v
#:name (build-compound-type-name 'name ctc-x ...) pred-fail-text
#:projection 'type-name v))
(λ (blame) (void (p-apps (selector-names v)) ...)
(let ([p-apps (procs blame)] ...) v))))
(λ (v) (make-contract
(if #,(if test-immutable? #:name (build-compound-type-name 'name ctc-x ...)
#'(and (predicate?-name v) #:first-order fo-check
(immutable? v)) #:projection
#'(predicate?-name v)) (λ (blame)
(constructor-name (p-apps (selector-names v)) ...) (let ([p-apps (procs blame)] ...)
(raise-blame-error (λ (v)
blame (unless (pred? v)
v (raise-blame-error blame v
#,(if test-immutable? pred-fail-text
"expected immutable <~a>, given: ~e" 'type-name v))
"expected <~a>, given: ~e") (constructor-name (p-apps (selector-names v)) ...)))))))))))]
'type-name
v)))))))))))))]
[(_ predicate? constructor (arb? selector) correct-size type-name name) [(_ predicate? constructor (arb? selector) correct-size type-name name)
(eq? #t (syntax->datum (syntax arb?))) (eq? #t (syntax->datum (syntax arb?)))
(syntax (syntax
@ -910,32 +933,50 @@
[constructor-name constructor] [constructor-name constructor]
[selector-name selector]) [selector-name selector])
(λ params (λ params
(let ([ctcs (map (λ (param) (coerce-contract 'name param)) params)]) (let* ([count (length params)]
(let ([procs (map contract-projection ctcs)]) [pred? (λ (v)
(make-contract (and (immutable? v)
#:name (apply build-compound-type-name 'name ctcs) (predicate?-name v)
#:projection (correct-size count v)))]
(λ (blame) [ctcs (map (λ (param) (coerce-contract 'name param)) params)]
(let ([p-apps (map (λ (proc) (proc blame)) procs)] [procs (map contract-projection ctcs)]
[count (length params)]) [fo-check
(λ (v) (λ (v)
(if (and (immutable? v) (and (pred? v)
(predicate?-name v) (for/and ([c (in-list ctcs)]
(correct-size count v)) [i (in-naturals)])
(apply constructor-name (contract-first-order-passes? c (selector-name v i)))))])
(let loop ([p-apps p-apps] (if (andmap flat-contract? ctcs)
[i 0]) (make-flat-contract
(cond #:name (apply build-compound-type-name 'name ctcs)
[(null? p-apps) null] #:first-order fo-check
[else (let ([p-app (car p-apps)]) #:projection
(cons (p-app (selector-name v i)) (λ (blame)
(loop (cdr p-apps) (+ i 1))))]))) (let ([p-apps (map (λ (proc) (proc blame)) procs)])
(raise-blame-error (λ (v)
blame (unless (pred? v)
v (raise-blame-error blame v
"expected <~a>, given: ~e" "expected <~a>, given: ~e"
'type-name 'type-name v))
v)))))))))))])) (for ([p (in-list p-apps)]
[i (in-naturals)])
(p (selector-name v i)))
v))))
(make-contract
#:name (apply build-compound-type-name 'name ctcs)
#:first-order fo-check
#:projection
(λ (blame)
(let ([p-apps (map (λ (proc) (proc blame)) procs)])
(λ (v)
(unless (pred? v)
(raise-blame-error blame v
"expected <~a>, given: ~e"
'type-name v))
(apply constructor-name
(for/list ([p (in-list p-apps)]
[i (in-naturals)])
(p (selector-name v i)))))))))))))]))
(define cons/c (*-immutable/c pair? cons (#f car cdr) cons cons/c #f)) (define cons/c (*-immutable/c pair? cons (#f car cdr) cons cons/c #f))
(define box-immutable/c (*-immutable/c box? box-immutable (#f unbox) immutable-box box-immutable/c)) (define box-immutable/c (*-immutable/c box? box-immutable (#f unbox) immutable-box box-immutable/c))

2
collects/tests/racket/contract-test.rktl
View File

@ -7632,7 +7632,7 @@ so that propagation occurs.
(ctest #t contract-first-order-passes? (ctest #t contract-first-order-passes?
(cons/c boolean? (-> integer? integer?)) (cons/c boolean? (-> integer? integer?))
(list* #t (λ (x) x))) (list* #t (λ (x) x)))
(ctest #t contract-first-order-passes? (ctest #f contract-first-order-passes?
(cons/c boolean? (-> integer? integer?)) (cons/c boolean? (-> integer? integer?))
(list* 1 2)) (list* 1 2))