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

167
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 ,(contract-name ctc))
(lambda (x) (and (predicate? x) (testmap content-pred? x)))))
(let ([proj (contract-projection ctc)])
(make-contract
#:name (build-compound-type-name 'name ctc) #:name (build-compound-type-name 'name ctc)
#:first-order fo-check
#:projection #:projection
(λ (blame) (λ (blame)
(let ([p-app (proj blame)]) (let ([p-app (proj blame)])
(λ (val) (λ (val)
(unless (predicate? val) (unless (predicate? val)
(raise-blame-error (raise-blame-error blame val
blame
val
"expected <~a>, given: ~e" "expected <~a>, given: ~e"
'type-name 'type-name val))
val)) (for-each-name p-app val)
(fill-name p-app val)))) val))))
#:first-order predicate?)))))))])) (make-contract
#:name (build-compound-type-name 'name ctc)
#:first-order fo-check
#:projection
(λ (blame)
(let ([p-app (proj blame)])
(λ (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 ,(contract-name ctc-x) ...)
(lambda (x)
(and (predicate?-name x)
(p-apps (selector-names x))
...))))
(let ([procs (contract-projection ctc-x)] ...)
(make-contract
#:name (build-compound-type-name 'name ctc-x ...) #:name (build-compound-type-name 'name ctc-x ...)
#:first-order fo-check
#:projection #:projection
(λ (blame) (λ (blame)
(let ([p-apps (procs blame)] ...) (let ([p-apps (procs blame)] ...)
(λ (v) (λ (v)
(if #,(if test-immutable? (unless (pred? v)
#'(and (predicate?-name v) (raise-blame-error blame v
(immutable? v)) pred-fail-text
#'(predicate?-name v)) 'type-name v))
(constructor-name (p-apps (selector-names v)) ...) (void (p-apps (selector-names v)) ...)
(raise-blame-error v))))
blame (make-contract
v #:name (build-compound-type-name 'name ctc-x ...)
#,(if test-immutable? #:first-order fo-check
"expected immutable <~a>, given: ~e" #:projection
"expected <~a>, given: ~e") (λ (blame)
'type-name (let ([p-apps (procs blame)] ...)
v)))))))))))))] (λ (v)
(unless (pred? v)
(raise-blame-error blame v
pred-fail-text
'type-name v))
(constructor-name (p-apps (selector-names 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)
(predicate?-name v)
(correct-size count v)))]
[ctcs (map (λ (param) (coerce-contract 'name param)) params)]
[procs (map contract-projection ctcs)]
[fo-check
(λ (v)
(and (pred? v)
(for/and ([c (in-list ctcs)]
[i (in-naturals)])
(contract-first-order-passes? c (selector-name v i)))))])
(if (andmap flat-contract? ctcs)
(make-flat-contract
#:name (apply build-compound-type-name 'name ctcs) #:name (apply build-compound-type-name 'name ctcs)
#:first-order fo-check
#:projection #:projection
(λ (blame) (λ (blame)
(let ([p-apps (map (λ (proc) (proc blame)) procs)] (let ([p-apps (map (λ (proc) (proc blame)) procs)])
[count (length params)])
(λ (v) (λ (v)
(if (and (immutable? v) (unless (pred? v)
(predicate?-name v) (raise-blame-error blame v
(correct-size count v))
(apply constructor-name
(let loop ([p-apps p-apps]
[i 0])
(cond
[(null? p-apps) null]
[else (let ([p-app (car p-apps)])
(cons (p-app (selector-name v i))
(loop (cdr p-apps) (+ i 1))))])))
(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))