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)
(syntax-case stx ()
[(_ predicate? fill testmap type-name name)
[(_ predicate? app fill testmap type-name name)
(identifier? (syntax predicate?))
(syntax
(let ([fill-name fill])
(let ([fill-name fill]
[for-each-name app])
(λ (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)
(let ([content-pred? (flat-contract-predicate ctc)])
(build-flat-contract
`(name ,(contract-name ctc))
(lambda (x) (and (predicate? x) (testmap content-pred? x)))))
(let ([proj (contract-projection ctc)])
(make-contract
(make-flat-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
(raise-blame-error blame val
"expected <~a>, given: ~e"
'type-name
val))
(fill-name p-app val))))
#:first-order predicate?)))))))]))
'type-name val))
(for-each-name p-app val)
val))))
(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
(*-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-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 vector-immutableof
(*-immutableof immutable-vector?
(λ (f v) (for-each f (vector->list v)))
(λ (f v) (apply vector-immutable (map f (vector->list v))))
(λ (f v) (andmap f (vector->list v)))
immutable-vector
@ -865,7 +877,15 @@
(and (eq? #f (syntax->datum (syntax arb?)))
(boolean? (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 ...)))]
[(ctc-x ...) (generate-temporaries (syntax (selectors ...)))]
[(procs ...) (generate-temporaries (syntax (selectors ...)))]
@ -874,35 +894,38 @@
[constructor-name constructor]
[selector-names selectors] ...)
(λ (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) ...)
(let ([p-apps (flat-contract-predicate ctc-x)] ...)
(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
(make-flat-contract
#:name (build-compound-type-name 'name ctc-x ...)
#:first-order fo-check
#:projection
(λ (blame)
(let ([p-apps (procs blame)] ...)
(λ (v)
(if #,(if test-immutable?
#'(and (predicate?-name v)
(immutable? v))
#'(predicate?-name v))
(constructor-name (p-apps (selector-names v)) ...)
(raise-blame-error
blame
v
#,(if test-immutable?
"expected immutable <~a>, given: ~e"
"expected <~a>, given: ~e")
'type-name
v)))))))))))))]
(unless (pred? v)
(raise-blame-error blame v
pred-fail-text
'type-name v))
(void (p-apps (selector-names v)) ...)
v))))
(make-contract
#:name (build-compound-type-name 'name ctc-x ...)
#:first-order fo-check
#:projection
(λ (blame)
(let ([p-apps (procs blame)] ...)
(λ (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)
(eq? #t (syntax->datum (syntax arb?)))
(syntax
@ -910,32 +933,50 @@
[constructor-name constructor]
[selector-name selector])
(λ params
(let ([ctcs (map (λ (param) (coerce-contract 'name param)) params)])
(let ([procs (map contract-projection ctcs)])
(make-contract
(let* ([count (length params)]
[pred? (λ (v)
(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)
#:first-order fo-check
#:projection
(λ (blame)
(let ([p-apps (map (λ (proc) (proc blame)) procs)]
[count (length params)])
(let ([p-apps (map (λ (proc) (proc blame)) procs)])
(λ (v)
(if (and (immutable? v)
(predicate?-name 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
(unless (pred? v)
(raise-blame-error blame v
"expected <~a>, given: ~e"
'type-name
v)))))))))))]))
'type-name 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 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?
(cons/c boolean? (-> integer? integer?))
(list* #t (λ (x) x)))
(ctest #t contract-first-order-passes?
(ctest #f contract-first-order-passes?
(cons/c boolean? (-> integer? integer?))
(list* 1 2))