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

add the same fast path to contract? and chaperone-contract? that is already in flat-contract?

Browse Source
This commit is contained in:
Robby Findler 2017-03-07 09:24:23 -06:00
parent 36368628af
commit 7c3412957a
1 changed files with 70 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
racket/collects/racket/contract/private/guts.rkt
View File

@ -107,9 +107,25 @@
(print (contract-struct-name stct) port 1)
(write-suffix)])]))
(define (contract? x) (and (coerce-contract/f x) #t))
(define (contract? x)
(or (simple-flat-contract? x)
(and (coerce-contract/f x) #t)))
(define (flat-contract? x)
(or (simple-flat-contract? x)
(let ([c (coerce-contract/f x)])
(and c
(flat-contract-struct? c)))))
(define (chaperone-contract? x)
(or (simple-flat-contract? x)
(let ([c (coerce-contract/f x)])
(and c
(or (chaperone-contract-struct? c)
(and (prop:opt-chaperone-contract? c)
((prop:opt-chaperone-contract-get-test c) c)))))))
(define (simple-flat-contract? x)
(or (and (procedure? x) (procedure-arity-includes? x 1))
(null? x)
(boolean? x)
@ -120,17 +136,7 @@
(string? x)
(number? x)
(regexp? x)
(byte-regexp? x)
(let ([c (coerce-contract/f x)])
(and c
(flat-contract-struct? c)))))
(define (chaperone-contract? x)
(let ([c (coerce-contract/f x)])
(and c
(or (chaperone-contract-struct? c)
(and (prop:opt-chaperone-contract? c)
((prop:opt-chaperone-contract-get-test c) c))))))
(byte-regexp? x)))
(define (impersonator-contract? x)
(let ([c (coerce-contract/f x)])
@ -323,7 +329,19 @@
(set! between/c-s-high b/c-s-h))
(define (coerce-contract/f x [name name-default])
(define (coerce-simple-value x)
(cond
[(coerce-simple-value name x) => values]
[(name-default? name) (and (contract-struct? x) x)]
[(predicate-contract? x)
(struct-copy predicate-contract x [name name])]
[(eq-contract? x) (make-eq-contract (eq-contract-val x) name)]
[(equal-contract? x) (make-eq-contract (equal-contract-val x) name)]
[(=-contract? x) (make-=-contract (=-contract-val x) name)]
[(regexp/c? x) (make-regexp/c (regexp/c-reg x) name)]
[else #f]))
(define (coerce-simple-value name x)
(cond
[(contract-struct? x) #f] ;; this has to come first, since some of these are procedure?.
[(and (procedure? x) (procedure-arity-includes? x 1))
@ -372,16 +390,6 @@
(make-=-contract x (if (name-default? name) x name))]
[(or (regexp? x) (byte-regexp? x)) (make-regexp/c x (if (name-default? name) x name))]
[else #f]))
(cond
[(coerce-simple-value x) => values]
[(name-default? name) (and (contract-struct? x) x)]
[(predicate-contract? x)
(struct-copy predicate-contract x [name name])]
[(eq-contract? x) (make-eq-contract (eq-contract-val x) name)]
[(equal-contract? x) (make-eq-contract (equal-contract-val x) name)]
[(=-contract? x) (make-=-contract (=-contract-val x) name)]
[(regexp/c? x) (make-regexp/c (regexp/c-reg x) name)]
[else #f]))
(define the-known-good-contracts
(let-syntax ([m (λ (x) #`(list #,@(known-good-contracts)))])