improve stronger for flat-named-contract
by making the equal, eq, and regexp contracts all have an extra field to hold the name. This mostly has the advantage that flat-named-contract has to turn a flat contract into it's predicate a bit less often
This commit is contained in:
Robby Findler
parent
0f78892a0b
commit
05185dcdde
|
|
@ -116,21 +116,18 @@ implement contracts~@cite{Strickland12}.
|
|||
@section[#:tag "data-structure-contracts"]{Data-structure Contracts}
|
||||
@declare-exporting-ctc[racket/contract/base]
|
||||
|
||||
@defproc[(flat-named-contract [type-name any/c]
|
||||
[predicate flat-contract?]
|
||||
@defproc[(flat-named-contract [name any/c]
|
||||
[flat-contract flat-contract?]
|
||||
[generator (or/c #f (-> contract (-> int? any))) #f])
|
||||
flat-contract?]{
|
||||
Produces a contract like @racket[flat-contract], but with the name @racket[name].
|
||||
|
||||
On predicates, behaves like @racket[flat-contract], but the first argument must be the
|
||||
(quoted) name of a contract used for error reporting.
|
||||
For example,
|
||||
@racketblock[(flat-named-contract
|
||||
'odd-integer
|
||||
(lambda (x) (and (integer? x) (odd? x))))]
|
||||
turns the predicate into a contract with the name @tt{odd-integer}.
|
||||
|
||||
On flat contracts, the new flat contract is the same as the old except for
|
||||
the name.
|
||||
@racketblock[(define/contract i
|
||||
(flat-named-contract
|
||||
'odd-integer
|
||||
(lambda (x) (and (integer? x) (odd? x))))
|
||||
2)]
|
||||
|
||||
The generator argument adds a generator for the flat-named-contract. See
|
||||
@racket[contract-generate] for more information.
|
||||
|
|
|
|||
|
|
@ -150,6 +150,18 @@
|
|||
(ctest #t contract-stronger? 'x symbol?)
|
||||
(ctest #f contract-stronger? symbol? 'x)
|
||||
|
||||
(ctest #t contract-stronger?
|
||||
(flat-named-contract 'name1 #f)
|
||||
(flat-named-contract 'name2 #f))
|
||||
(ctest #t contract-stronger?
|
||||
(flat-named-contract 'name1 (flat-named-contract 'name2 #f))
|
||||
(flat-named-contract 'name3 (flat-named-contract 'name4 #f)))
|
||||
(ctest #t contract-stronger? (flat-named-contract 'name1 1) (flat-named-contract 'name2 1))
|
||||
(ctest #t contract-stronger? (flat-named-contract 'name1 "x") (flat-named-contract 'name2 "x"))
|
||||
(ctest #t contract-stronger?
|
||||
(flat-named-contract 'name2 (regexp "x"))
|
||||
(flat-named-contract 'name2 (regexp "x")))
|
||||
|
||||
(contract-eval
|
||||
`(let ([c (class/c (m (-> any/c integer?)))])
|
||||
(,test #t contract-stronger? (instanceof/c c) (instanceof/c c))))
|
||||
|
|
|
|||
|
|
@ -205,19 +205,44 @@
|
|||
|
||||
;; coerce-contract/f : any -> (or/c #f contract?)
|
||||
;; returns #f if the argument could not be coerced to a contract
|
||||
(define (coerce-contract/f x)
|
||||
(define-values (name-default name-default?)
|
||||
(let ()
|
||||
(struct name-default ())
|
||||
(values (name-default) name-default?)))
|
||||
(define (coerce-contract/f x [name name-default])
|
||||
(define (coerce-simple-value 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))
|
||||
(make-predicate-contract (if (name-default? name)
|
||||
(or (object-name x) '???)
|
||||
name)
|
||||
x
|
||||
#f
|
||||
(memq x the-known-good-contracts))]
|
||||
[(or (symbol? x) (boolean? x) (char? x) (null? x) (keyword? x))
|
||||
(make-eq-contract x
|
||||
(if (name-default? name)
|
||||
(if (or (null? x)
|
||||
(symbol? x))
|
||||
`',x
|
||||
x)
|
||||
name))]
|
||||
[(or (bytes? x) (string? x))
|
||||
(make-equal-contract x (if (name-default? name) x name))]
|
||||
[(number? x)
|
||||
(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
|
||||
[(contract-struct? x) x]
|
||||
[(and (procedure? x) (procedure-arity-includes? x 1))
|
||||
(make-predicate-contract (or (object-name x) '???)
|
||||
x
|
||||
#f
|
||||
(memq x the-known-good-contracts))]
|
||||
[(null? x) (make-eq-contract x)]
|
||||
[(or (symbol? x) (boolean? x) (char? x) (null? x) (keyword? x)) (make-eq-contract x)]
|
||||
[(or (bytes? x) (string? x)) (make-equal-contract x)]
|
||||
[(number? x) (make-=-contract x)]
|
||||
[(or (regexp? x) (byte-regexp? x)) (make-regexp/c x)]
|
||||
[(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
|
||||
|
|
@ -341,17 +366,12 @@
|
|||
;
|
||||
;
|
||||
|
||||
(define-struct eq-contract (val)
|
||||
(define-struct eq-contract (val name)
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
#:first-order (λ (ctc) (λ (x) (eq? (eq-contract-val ctc) x)))
|
||||
#:name
|
||||
(λ (ctc)
|
||||
(if (or (null? (eq-contract-val ctc))
|
||||
(symbol? (eq-contract-val ctc)))
|
||||
`',(eq-contract-val ctc)
|
||||
(eq-contract-val ctc)))
|
||||
#:name (λ (ctc) (eq-contract-name ctc))
|
||||
#:generate
|
||||
(λ (ctc)
|
||||
(define v (eq-contract-val ctc))
|
||||
|
|
@ -366,12 +386,12 @@
|
|||
((predicate-contract-pred that) this-val))))
|
||||
#:list-contract? (λ (c) (null? (eq-contract-val c)))))
|
||||
|
||||
(define-struct equal-contract (val)
|
||||
(define-struct equal-contract (val name)
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
#:first-order (λ (ctc) (λ (x) (equal? (equal-contract-val ctc) x)))
|
||||
#:name (λ (ctc) (equal-contract-val ctc))
|
||||
#:name (λ (ctc) (equal-contract-name ctc))
|
||||
#:stronger
|
||||
(λ (this that)
|
||||
(define this-val (equal-contract-val this))
|
||||
|
|
@ -385,12 +405,12 @@
|
|||
(define v (equal-contract-val ctc))
|
||||
(λ (fuel) (λ () v)))))
|
||||
|
||||
(define-struct =-contract (val)
|
||||
(define-struct =-contract (val name)
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
#:first-order (λ (ctc) (λ (x) (and (number? x) (= (=-contract-val ctc) x))))
|
||||
#:name (λ (ctc) (=-contract-val ctc))
|
||||
#:name (λ (ctc) (=-contract-name ctc))
|
||||
#:stronger
|
||||
(λ (this that)
|
||||
(define this-val (=-contract-val this))
|
||||
|
|
@ -404,7 +424,7 @@
|
|||
(define v (=-contract-val ctc))
|
||||
(λ (fuel) (λ () v)))))
|
||||
|
||||
(define-struct regexp/c (reg)
|
||||
(define-struct regexp/c (reg name)
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
|
|
@ -417,7 +437,7 @@
|
|||
#:name (λ (ctc) (regexp/c-reg ctc))
|
||||
#:stronger
|
||||
(λ (this that)
|
||||
(and (regexp/c? that) (eq? (regexp/c-reg this) (regexp/c-reg that))))))
|
||||
(and (regexp/c? that) (equal? (regexp/c-reg this) (regexp/c-reg that))))))
|
||||
|
||||
|
||||
;; sane? : boolean -- indicates if we know that the predicate is well behaved
|
||||
|
|
|
|||
|
|
@ -1514,19 +1514,18 @@
|
|||
|
||||
|
||||
(define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
|
||||
(define (flat-named-contract name predicate [generate #f])
|
||||
(define (flat-named-contract name pre-contract [generate #f])
|
||||
(cond
|
||||
[(and (procedure? predicate)
|
||||
(procedure-arity-includes? predicate 1))
|
||||
(make-predicate-contract name predicate generate #f)]
|
||||
[(flat-contract? predicate)
|
||||
(make-predicate-contract name (flat-contract-predicate predicate) generate #f)]
|
||||
[(and (not generate)
|
||||
(coerce-contract/f pre-contract name))
|
||||
=>
|
||||
values]
|
||||
[(flat-contract? pre-contract)
|
||||
(make-predicate-contract name (flat-contract-predicate pre-contract) generate #f)]
|
||||
[else
|
||||
(raise-argument-error 'flat-named-contract
|
||||
(format "~s" `(or/c flat-contract?
|
||||
(and/c procedure?
|
||||
(λ (x) (procedure-arity-include? x 1)))))
|
||||
predicate)]))
|
||||
"flat-contract?"
|
||||
pre-contract)]))
|
||||
|
||||
(define printable/c
|
||||
(flat-named-contract
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user