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

Removing now-unneeded abstractions for *-immutable/c.

Browse Source 
Also converting cons/c to create chaperone contracts when appropriate.
This commit is contained in:
Stevie Strickland 2010-06-09 14:45:01 -04:00
parent 2677cbf1a4
commit 6446d267ea
1 changed files with 34 additions and 109 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -828,116 +828,41 @@
(procedure-arity-includes? pred 1)))) (procedure-arity-includes? pred 1))))
(define-syntax (*-immutable/c stx) (define cons/c-main-function
(syntax-case stx () (λ (car-c cdr-c)
[(_ predicate? constructor (arb? selectors ...) type-name name) (let* ([ctc-car (coerce-contract 'cons/c car-c)]
#'(*-immutable/c predicate? constructor (arb? selectors ...) type-name name #t)] [ctc-cdr (coerce-contract 'cons/c cdr-c)]
[(_ predicate? constructor (arb? selectors ...) type-name name test-immutable?) [ctc-name (build-compound-type-name 'cons/c ctc-car ctc-cdr)]
(and (eq? #f (syntax->datum (syntax arb?))) [car-proj (contract-projection ctc-car)]
(boolean? (syntax->datum #'test-immutable?))) [cdr-proj (contract-projection ctc-cdr)])
(let ([test-immutable? (syntax->datum #'test-immutable?)]) (define (fo-check v)
(with-syntax ([pred? (and (pair? v)
(if test-immutable? (contract-first-order-passes? ctc-car (car v))
#'(λ (v) (and (predicate?-name v) (immutable? v))) (contract-first-order-passes? ctc-cdr (cdr v))))
#'predicate?-name)] (define ((ho-check combine) blame)
[pred-fail-text (let ([car-p (car-proj blame)]
(if test-immutable? [cdr-p (cdr-proj blame)])
"expected immutable <~a>, given: ~e" (λ (v)
"expected <~a>, given: ~e")] (unless (pair? v)
[(params ...) (generate-temporaries (syntax (selectors ...)))] (raise-blame-error blame v "expected <~a>, given: ~e" 'cons v))
[(p-apps ...) (generate-temporaries (syntax (selectors ...)))] (combine v (car-p (car v)) (cdr-p (cdr v))))))
[(ctc-x ...) (generate-temporaries (syntax (selectors ...)))] (cond
[(procs ...) (generate-temporaries (syntax (selectors ...)))] [(and (flat-contract? ctc-car) (flat-contract? ctc-cdr))
[(selector-names ...) (generate-temporaries (syntax (selectors ...)))]) (make-flat-contract
#`(let ([predicate?-name predicate?] #:name ctc-name
[constructor-name constructor] #:first-order fo-check
[selector-names selectors] ...) #:projection (ho-check (λ (v a d) v)))]
(λ (params ...) [(and (chaperone-contract? ctc-car) (chaperone-contract? ctc-cdr))
(let* ([ctc-x (coerce-contract 'name params)] ... (make-chaperone-contract
[procs (contract-projection ctc-x)] ... #:name ctc-name
[fo-check #:first-order fo-check
(λ (v) #:projection (ho-check (λ (v a d) (cons a d))))]
(and (pred? v) [else
(contract-first-order-passes? ctc-x (selector-names v)) ...))]) (make-contract
(if (and (flat-contract? ctc-x) ...) #:name ctc-name
(make-flat-contract #:first-order fo-check
#:name (build-compound-type-name 'name ctc-x ...) #:projection (ho-check (λ (v a d) (cons a d))))]))))
#: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))
(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
(let ([predicate?-name predicate?]
[constructor-name constructor]
[selector-name selector])
(λ params
(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)])
(λ (v)
(unless (pred? v)
(raise-blame-error blame v
"expected <~a>, given: ~e"
'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-main-function (*-immutable/c pair? cons (#f car cdr) cons cons/c #f))
(define/subexpression-pos-prop (cons/c a b) (cons/c-main-function a b)) (define/subexpression-pos-prop (cons/c a b) (cons/c-main-function a b))
;; ;;