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

add contract-equivalent?

Browse Source 
and use it to get rid of the change in 4de050552,
avoiding the exponential blowup in a way that
doesn't compromise on contract-stronger?'s result
This commit is contained in:
Robby Findler 2018-05-09 21:31:12 -05:00
parent c927a004d2
commit 8ec3edaa95
22 changed files with 1544 additions and 118 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
pkgs/racket-doc/scribblings/reference/contracts.scrbl
View File

@ -2125,6 +2125,9 @@ where the violation was detected.
[#:stronger stronger
(or/c #f (-> contract? contract? boolean?))
#f]
[#:equivalent equivalent
(or/c #f (-> contract? contract? boolean?))
#f]
[#:list-contract? is-list-contract? boolean? #f])
contract?]
@defproc[(make-chaperone-contract
@ -2150,6 +2153,9 @@ where the violation was detected.
[#:stronger stronger
(or/c #f (-> contract? contract? boolean?))
#f]
[#:equivalent equivalent
(or/c #f (-> contract? contract? boolean?))
#f]
[#:list-contract? is-list-contract? boolean? #f])
chaperone-contract?]
@defproc[(make-flat-contract
@ -2175,6 +2181,9 @@ where the violation was detected.
[#:stronger stronger
(or/c #f (-> contract? contract? boolean?))
#f]
[#:equivalent equivalent
(or/c #f (-> contract? contract? boolean?))
#f]
[#:list-contract? is-list-contract? boolean? #f])
flat-contract?]
)]{
@ -2250,6 +2259,9 @@ with @racket[equal?] is used for @tech{flat contracts} and @tech{chaperone contr
For @tech{impersonator contracts} constructed with @racket[make-contract] that do not
supply the @racket[stronger] argument, @racket[contract-stronger?] returns @racket[#f].
Similarly, the @racket[equivalent] argument is used to implement @racket[contract-equivalent?].
If it isn't supplied or @racket[#false] is supplied, then @racket[equal?] is used
for chaperone and flat contracts, and @racket[(λ (x y) #f)] is used otherwise.
The @racket[is-list-contract?] argument is used by the @racket[list-contract?] predicate
to determine if this is a contract that accepts only @racket[list?] values.
@ -2717,6 +2729,9 @@ returns @racket[#f] but @racket[value-blame] returns @racket[#f].
stronger
(or/c (-> contract? contract? boolean?) #f)
#f]
[#:equivalent equivalent
(or/c #f (-> contract? contract? boolean?))
#f]
[#:generate
generate
(->i ([c contract?])
@ -2760,6 +2775,9 @@ returns @racket[#f] but @racket[value-blame] returns @racket[#f].
stronger
(or/c (-> contract? contract? boolean?) #f)
#f]
[#:equivalent equivalent
(or/c #f (-> contract? contract? boolean?))
#f]
[#:generate
generate
(->i ([c contract?])
@ -2813,6 +2831,9 @@ returns @racket[#f] but @racket[value-blame] returns @racket[#f].
stronger
(or/c (-> contract? contract? boolean?) #f)
#f]
[#:equivalent equivalent
(or/c #f (-> contract? contract? boolean?))
#f]
[#:generate
generate
(->i ([c contract?])
@ -2853,6 +2874,11 @@ a contract. It is specified in terms of seven properties:
contract (passed in the first argument) is stronger than some other
contract (passed in the second argument) and whose default always
returns @racket[#f];}
@item{@racket[equivalent], a predicate that determines whether this
contract (passed in the first argument) is equivalent to some other
contract (passed in the second argument); the default for flat
and chaperone contracts is @racket[equal?] and for impersonator contracts
returns @racket[#f];}
@item{@racket[generate], which returns a thunk that generates random values
matching the contract (using @racket[contract-random-generate-fail])
to indicate failure) or @racket[#f] to indicate that random
@ -3010,7 +3036,7 @@ are below):
@defproc[(contract-stronger? [c1 contract?] [c2 contract?]) boolean?]{
Returns @racket[#t] if the contract @racket[c1] accepts either fewer
or the same number of values as @racket[c2] does.
or the same set of values that @racket[c2] does.
@tech{Chaperone contracts} and @tech{flat contracts} that are the same
(i.e., where @racket[c1] is @racket[equal?] to @racket[c2]) are
@ -3029,6 +3055,28 @@ are below):
(λ (x) (and (real? x) (<= x 100))))]
}
@defproc[(contract-equivalent? [c1 contract?] [c2 contract?]) boolean?]{
Returns @racket[#t] if the contract @racket[c1] accepts the same
set of values that @racket[c2] does.
@tech{Chaperone contracts} and @tech{flat contracts} that are the same
(i.e., where @racket[c1] is @racket[equal?] to @racket[c2]) are
considered to always be equivalent to each other.
This function is conservative, so it may return @racket[#f] when
@racket[c1] does, in fact, accept the same set of values that @racket[c2] does.
@examples[#:eval (contract-eval) #:once
(contract-equivalent? integer? integer?)
(contract-equivalent? (non-empty-listof integer?)
(cons/c integer? (listof integer?)))
(contract-equivalent? (λ (x) (and (real? x) (and (number? x) (>= (sqr x) 0))))
(λ (x) (and (real? x) (real? x))))]
}
@defproc[(contract-first-order-passes? [contract contract?]

830
pkgs/racket-test/tests/racket/contract/equivalent.rkt Normal file
View File

@ -0,0 +1,830 @@
#lang racket/base
(require "test-util.rkt")
(parameterize ([current-contract-namespace
(make-basic-contract-namespace 'racket/contract
'racket/list
'racket/class
'racket/math)])
(contract-eval '(define-contract-struct couple (hd tl)))
(contract-eval '(define-contract-struct triple (a b c)))
(ctest #t contract-equivalent? any/c any/c)
(ctest #f contract-equivalent? integer? any/c)
(ctest #t contract-equivalent? (integer-in 0 4) (integer-in 0 4))
(ctest #f contract-equivalent? (integer-in 1 3) (integer-in 0 4))
(ctest #f contract-equivalent? (integer-in 0 4) (integer-in 1 3))
(ctest #f contract-equivalent? (integer-in 0 4) (integer-in 1 #f))
(ctest #f contract-equivalent? (integer-in 0 4) (integer-in #f 3))
(ctest #f contract-equivalent? (integer-in 0 4) (integer-in #f 4))
(ctest #f contract-equivalent? (integer-in 0 #f) (integer-in #f #f))
(ctest #f contract-equivalent? (integer-in #f 0) (integer-in #f #f))
(ctest #t contract-equivalent? (integer-in #f #f) (integer-in #f #f))
(ctest #t contract-equivalent? (integer-in 0 0) (and/c 0 exact?))
(ctest #t contract-equivalent? (and/c 0 exact?) (integer-in 0 0))
(ctest #t contract-equivalent? exact-integer? (integer-in #f #f))
(ctest #t contract-equivalent? (integer-in #f #f) exact-integer?)
(ctest #t contract-equivalent? (integer-in 0 #f) exact-nonnegative-integer?)
(ctest #t contract-equivalent? (integer-in 0 #f) natural?)
(ctest #t contract-equivalent? natural? (integer-in 0 #f))
(ctest #t contract-equivalent? (integer-in 1 #f) exact-positive-integer?)
(ctest #t contract-equivalent? exact-positive-integer? (integer-in 1 #f))
(ctest #f contract-equivalent? natural? exact-integer?) ;; this actually is `integer-in`
(ctest #t contract-equivalent? (integer-in 0 5) (and/c natural? (<=/c 5)))
(ctest #t contract-equivalent? (and/c natural? (<=/c 5)) (integer-in 0 5))
(ctest #t contract-equivalent? (integer-in 0 5) (and/c exact-nonnegative-integer? (<=/c 5)))
(ctest #t contract-equivalent? (and/c exact-nonnegative-integer? (<=/c 5)) (integer-in 0 5))
(ctest #t contract-equivalent? (integer-in 5 #f) (and/c natural? (>=/c 5)))
(ctest #t contract-equivalent? (and/c natural? (>=/c 5)) (integer-in 5 #f))
(ctest #t contract-equivalent? (integer-in 0 #f) (and/c exact-nonnegative-integer? (>=/c -4)))
(ctest #t contract-equivalent? (and/c exact-nonnegative-integer? (>=/c -4)) (integer-in 0 #f))
(ctest #t contract-equivalent? #\a #\a)
(ctest #t contract-equivalent? #\a (char-in #\a #\a))
(ctest #t contract-equivalent? (char-in #\a #\a) (char-in #\a #\a))
(ctest #f contract-equivalent? #\a (char-in #\a #\c))
(ctest #f contract-equivalent? #\a (char-in #\b #\c))
(ctest #f contract-equivalent? (char-in #\f #\q) (char-in #\a #\z))
(ctest #f contract-equivalent? (char-in #\a #\z) (char-in #\f #\q))
(ctest #f contract-equivalent? (between/c 1 3) (between/c 0 4))
(ctest #f contract-equivalent? (between/c 0 4) (between/c 1 3))
(ctest #t contract-equivalent? (between/c 0 4) (between/c 0 4))
(ctest #t contract-equivalent? (between/c -inf.0 +inf.0) real?)
(ctest #t contract-equivalent? real? (between/c -inf.0 +inf.0))
(ctest #f contract-equivalent? (>=/c 3) (>=/c 2))
(ctest #f contract-equivalent? (>=/c 2) (>=/c 3))
(ctest #t contract-equivalent? (>=/c 2) (>=/c 2))
(ctest #f contract-equivalent? (<=/c 3) (<=/c 2))
(ctest #f contract-equivalent? (<=/c 2) (<=/c 3))
(ctest #t contract-equivalent? (<=/c 2) (<=/c 2))
(ctest #f contract-equivalent? (>/c 3) (>/c 2))
(ctest #f contract-equivalent? (>/c 2) (>/c 3))
(ctest #t contract-equivalent? (>/c 2) (>/c 2))
(ctest #f contract-equivalent? (</c 3) (</c 2))
(ctest #f contract-equivalent? (</c 2) (</c 3))
(ctest #t contract-equivalent? (</c 2) (</c 2))
(ctest #f contract-equivalent? (</c 2) (>/c 2))
(ctest #f contract-equivalent? (</c 2) (<=/c 2))
(ctest #f contract-equivalent? (</c 2) (>=/c 2))
(ctest #f contract-equivalent? (>/c 2) (<=/c 2))
(ctest #f contract-equivalent? (>/c 2) (>=/c 2))
(ctest #f contract-equivalent? (</c 2) (<=/c 200))
(ctest #f contract-equivalent? (<=/c 2) (</c 2))
(ctest #f contract-equivalent? (<=/c 1) (</c 2))
(ctest #f contract-equivalent? (>=/c 2) (</c 2))
(ctest #f contract-equivalent? (<=/c 2) (>/c 2))
(ctest #f contract-equivalent? (>=/c 2) (>/c 2))
(ctest #f contract-equivalent? (>=/c 3) (>/c 2))
(ctest #t contract-equivalent? (>/c 0) (and/c real? positive?))
(ctest #t contract-equivalent? (and/c real? positive?) (>/c 0))
(ctest #t contract-equivalent? (</c 0) (and/c real? negative?))
(ctest #t contract-equivalent? (and/c real? negative?) (</c 0))
(ctest #t contract-equivalent? (<=/c 0) (and/c real? (not/c positive?)))
(ctest #t contract-equivalent? (and/c real? (not/c positive?)) (<=/c 0))
(ctest #t contract-equivalent? (>=/c 0) (and/c real? (not/c negative?)))
(ctest #t contract-equivalent? (and/c real? (not/c negative?)) (>=/c 0))
(ctest #t contract-equivalent? (recursive-contract (<=/c 2)) (recursive-contract (<=/c 2)))
(ctest #f contract-equivalent? (recursive-contract (<=/c 2)) (recursive-contract (<=/c 3)))
(ctest #f contract-equivalent? (recursive-contract (<=/c 3)) (recursive-contract (<=/c 2)))
(let ([f (contract-eval '(λ (x) (recursive-contract (<=/c x))))])
(ctest #t contract-equivalent? (,f 1) (,f 1)))
(ctest #f contract-equivalent?
(letrec ([c (recursive-contract (-> (<=/c 5) c))]) c)
(letrec ([c (recursive-contract (-> (<=/c 3) c))]) c))
(ctest #t contract-equivalent?
(letrec ([c (recursive-contract (-> (<=/c 3) c))]) c)
(letrec ([c (recursive-contract (-> (<=/c 3) c))]) c))
(ctest #f contract-equivalent?
(letrec ([c (recursive-contract (-> (<=/c 3) c))]) c)
(letrec ([c (recursive-contract (-> (<=/c 1) c))]) c))
(ctest #t contract-equivalent?
(letrec ([c (recursive-contract (-> (<=/c 1) c))]) c)
(letrec ([c (recursive-contract (-> (<=/c 1) (-> (<=/c 1) c)))]) c))
(ctest #t contract-equivalent?
(letrec ([c (recursive-contract (-> (<=/c 1) (-> (<=/c 1) c)))]) c)
(letrec ([c (recursive-contract (-> (<=/c 1) (-> (<=/c 1) (-> (<=/c 1) c))))]) c))
(ctest #t contract-equivalent? (-> integer? integer?) (-> integer? integer?))
(ctest #f contract-equivalent? (-> boolean? boolean?) (-> integer? integer?))
(ctest #f contract-equivalent? (-> (>=/c 3) (>=/c 3)) (-> (>=/c 4) (>=/c 3)))
(ctest #f contract-equivalent? (-> (>=/c 4) (>=/c 3)) (-> (>=/c 3) (>=/c 3)))
(ctest #f contract-equivalent? (-> (>=/c 3) (>=/c 3)) (-> (>=/c 3) (>=/c 2)))
(ctest #f contract-equivalent? (-> (>=/c 3) (>=/c 2)) (-> (>=/c 3) (>=/c 3)))
(ctest #f contract-equivalent? (-> (>=/c 2)) (-> (>=/c 3) (>=/c 3)))
(ctest #f contract-equivalent?
(-> integer? #:x integer? integer?)
(-> integer? #:y integer? integer?))
(ctest #f contract-equivalent?
(-> integer? #:y integer? integer?)
(-> integer? #:x integer? integer?))
(ctest #t contract-equivalent?
(-> integer? #:x integer? integer?)
(-> integer? #:x integer? integer?))
(ctest #t contract-equivalent? (-> #:x (>=/c 3) (>=/c 3)) (-> #:x (>=/c 3) (>=/c 3)))
(ctest #f contract-equivalent? (-> #:x (>=/c 3) (>=/c 3)) (-> #:x (>=/c 3) (>=/c 2)))
(ctest #t contract-equivalent? (-> any/c any/c any) (-> any/c any/c any))
(ctest #f contract-equivalent? (-> any/c any/c any/c any) (-> any/c any/c any))
(ctest #f contract-equivalent? (-> (-> any/c) integer?) (-> (-> any/c) any/c))
(ctest #t contract-equivalent? (-> (-> any/c) integer?) (-> (-> any/c) integer?))
(ctest #f contract-equivalent? (-> (-> any/c) any/c) (-> (-> any/c) integer?))
(let ([c (contract-eval '(->* () () any))])
(ctest #t contract-equivalent? ,c ,c))
(let ([c (contract-eval '(->d () () any))])
(ctest #t contract-equivalent? ,c ,c))
(let ([c (contract-eval '(->i () () any))])
(ctest #t contract-equivalent? ,c ,c))
(ctest #f contract-equivalent?
(->* () #:pre (zero? (random 10)) any)
(->* () #:pre (zero? (random 10)) any))
(ctest #f contract-equivalent?
(->* () integer? #:post (zero? (random 10)))
(->* () integer? #:post (zero? (random 10))))
(ctest #t contract-equivalent? (or/c null? #f) (or/c null? #f))
(ctest #f contract-equivalent? (or/c null? #f) (or/c boolean? #f))
(ctest #t contract-equivalent? (or/c null? boolean?) (or/c null? boolean?))
(ctest #t contract-equivalent? (or/c null? boolean?) (or/c boolean? null?))
(ctest #t contract-equivalent?
(or/c null? (-> integer? integer?))
(or/c null? (-> integer? integer?)))
(ctest #f contract-equivalent?
(or/c null? (-> boolean? boolean?))
(or/c null? (-> integer? integer?)))
(ctest #f contract-equivalent? (or/c number? #f) number?)
(ctest #f contract-equivalent? number? (or/c number? #f))
(ctest #f contract-equivalent? (or/c (-> number? number?) #f) (-> number? number?))
(ctest #f contract-equivalent? (-> number? number?) (or/c (-> number? number?) #f))
(ctest #f contract-equivalent? (or/c (-> number? number?) (-> number? number? number?) #f) #f)
(ctest #f contract-equivalent? #f (or/c (-> number? number?) (-> number? number? number?) #f))
(ctest #f contract-equivalent? (or/c real?) (or/c integer? real?))
(ctest #f contract-equivalent? (-> number?) (-> (or/c #f number?)))
(ctest #f contract-equivalent? (-> (or/c #f number?) any/c) (-> number? any/c))
(ctest #f contract-equivalent? (-> (or/c #f number?)) (-> number?))
(ctest #f contract-equivalent? (-> number? any/c) (-> (or/c #f number?) any/c))
(ctest #t contract-equivalent? (first-or/c null? #f) (first-or/c null? #f))
(ctest #f contract-equivalent? (first-or/c null? #f) (first-or/c boolean? #f))
(ctest #t contract-equivalent? (first-or/c null? boolean?) (first-or/c null? boolean?))
(ctest #t contract-equivalent? (first-or/c null? boolean?) (first-or/c boolean? null?))
(ctest #t contract-equivalent?
(first-or/c null? (-> integer? integer?))
(first-or/c null? (-> integer? integer?)))
(ctest #f contract-equivalent?
(first-or/c null? (-> boolean? boolean?))
(first-or/c null? (-> integer? integer?)))
(ctest #f contract-equivalent? (first-or/c number? #f) number?)
(ctest #f contract-equivalent? number? (first-or/c number? #f))
(ctest #f contract-equivalent? (first-or/c (-> number? number?) #f) (-> number? number?))
(ctest #f contract-equivalent? (-> number? number?) (first-or/c (-> number? number?) #f))
(ctest #f contract-equivalent? (first-or/c (-> number? number?) (-> number? number? number?) #f) #f)
(ctest #f contract-equivalent? #f (first-or/c (-> number? number?) (-> number? number? number?) #f))
(ctest #f contract-equivalent? (first-or/c real?) (first-or/c integer? real?))
(ctest #f contract-equivalent? (-> number?) (-> (first-or/c #f number?)))
(ctest #f contract-equivalent? (-> (first-or/c #f number?) any/c) (-> number? any/c))
(ctest #f contract-equivalent? (-> (first-or/c #f number?)) (-> number?))
(ctest #f contract-equivalent? (-> number? any/c) (-> (first-or/c #f number?) any/c))
(ctest #t contract-equivalent? (first-or/c null? #f) (or/c null? #f))
(ctest #f contract-equivalent? (first-or/c null? #f) (or/c boolean? #f))
(ctest #t contract-equivalent? (first-or/c null? boolean?) (or/c null? boolean?))
(ctest #t contract-equivalent? (first-or/c null? boolean?) (or/c boolean? null?))
(ctest #t contract-equivalent? (or/c null? #f) (first-or/c null? #f))
(ctest #f contract-equivalent? (or/c null? #f) (first-or/c boolean? #f))
(ctest #t contract-equivalent? (or/c null? boolean?) (first-or/c null? boolean?))
(ctest #t contract-equivalent? (or/c null? boolean?) (first-or/c boolean? null?))
(ctest #t contract-equivalent? number? number?)
(ctest #f contract-equivalent? boolean? number?)
(ctest #t contract-equivalent? (parameter/c (between/c 0 5)) (parameter/c (between/c 0 5)))
(ctest #f contract-equivalent? (parameter/c (between/c 0 5)) (parameter/c (between/c 1 4)))
(ctest #f contract-equivalent? (parameter/c (between/c 1 4)) (parameter/c (between/c 0 5)))
(ctest #f contract-equivalent?
(parameter/c (between/c 1 4) (between/c 0 5))
(parameter/c (between/c 0 5)))
(ctest #f contract-equivalent?
(parameter/c (between/c 0 5) (between/c 1 4))
(parameter/c (between/c 1 4)))
(ctest #f contract-equivalent?
(parameter/c (between/c 0 5))
(parameter/c (between/c 1 4) (between/c 0 5)))
(ctest #f contract-equivalent?
(parameter/c (between/c 1 4))
(parameter/c (between/c 0 5) (between/c 0 5)))
(ctest #f contract-equivalent?
(parameter/c (between/c 0 5) (between/c 1 4))
(parameter/c (between/c 1 4) (between/c 0 5)))
(ctest #f contract-equivalent?
(parameter/c (between/c 1 4) (between/c 0 5))
(parameter/c (between/c 0 5) (between/c 1 4)))
(ctest #f contract-equivalent? (symbols 'x 'y) (symbols 'x 'y 'z))
(ctest #f contract-equivalent? (symbols 'x 'y 'z) (symbols 'x 'y))
(ctest #f contract-equivalent? (symbols 'x 'y) (symbols 'z 'x 'y))
(ctest #f contract-equivalent? (symbols 'z 'x 'y) (symbols 'x 'y))
(ctest #t contract-equivalent? (symbols 'z 'x 'y) (symbols 'z 'x 'y))
(ctest #t contract-equivalent? (symbols 'z 'x 'y) (symbols 'y 'z 'x))
(ctest #f contract-equivalent? (one-of/c (expt 2 100)) (one-of/c (expt 2 100) 12))
(ctest #f contract-equivalent?
(or/c (-> (>=/c 3) (>=/c 3)) (-> string?))
(or/c (-> (>=/c 4) (>=/c 3)) (-> string?)))
(ctest #t contract-equivalent?
(or/c (-> (>=/c 4) (>=/c 3)) (-> string?))
(or/c (-> (>=/c 4) (>=/c 3)) (-> string?)))
(ctest #f contract-equivalent?
(or/c (-> string?) (-> integer? integer?))
(or/c (-> string?) (-> any/c integer?)))
(ctest #f contract-equivalent?
(or/c (-> string?) (-> #f integer?))
(or/c (-> string?) (-> integer? integer?)))
(ctest #t contract-equivalent?
(or/c (-> string?) (-> integer? integer?) integer? boolean?)
(or/c (-> string?) (-> integer? integer?) integer? boolean?))
(ctest #f contract-equivalent?
(or/c (-> string?) (-> integer? integer?) integer? char?)
(or/c (-> string?) (-> integer? integer?) integer? boolean?))
(ctest #f contract-equivalent?
(or/c (-> string?) (-> integer? integer?) integer?)
(or/c (-> string?) (-> integer? integer?) integer? boolean?))
(ctest #f contract-equivalent?
(or/c (-> string?) (-> integer? integer?) integer?)
(or/c (-> integer? integer?) integer?))
(ctest #t contract-equivalent? (list/c) '())
(ctest #t contract-equivalent? '() (list/c))
(ctest #t contract-equivalent? (cons/c boolean? integer?) (cons/c boolean? integer?))
(ctest #f contract-equivalent? (cons/c boolean? integer?) (cons/c integer? boolean?))
(ctest #t contract-equivalent? (cons/c number? (listof number?)) (non-empty-listof number?))
(ctest #t contract-equivalent? (and/c pair? (listof number?)) (non-empty-listof number?))
(ctest #t contract-equivalent? (non-empty-listof number?) (and/c (listof number?) pair?))
(ctest #t contract-equivalent? (non-empty-listof number?) (cons/c number? (listof number?)))
(ctest #f contract-equivalent? (cons/c number? (list/c number? number?)) (non-empty-listof number?))
(ctest #f contract-equivalent? (cons/c number? (cons/c number? (listof number?))) (listof number?))
(ctest #f contract-equivalent?
(cons/c (<=/c 1) (cons/c (<=/c 2) (listof (<=/c 3))))
(listof (<=/c 4)))
(ctest #f contract-equivalent? (listof number?) (cons/c number? (cons/c number? (listof any/c))))
(ctest #f contract-equivalent? (list*of (<=/c 2)) (list*of (<=/c 3)))
(ctest #f contract-equivalent? (list*of (<=/c 3)) (list*of (<=/c 2)))
(ctest #t contract-equivalent? (list*of (<=/c 3)) (list*of (<=/c 3)))
(ctest #f contract-equivalent? (list*of (<=/c 2) char?) (list*of (<=/c 3) char?))
(ctest #t contract-equivalent? (list*of (<=/c 3) char?) (list*of (<=/c 3) char?))
(ctest #f contract-equivalent? (list*of (<=/c 3) char?) (list*of (<=/c 2) char?))
(ctest #f contract-equivalent? (list*of char? (<=/c 2)) (list*of char? (<=/c 3)))
(ctest #t contract-equivalent? (list*of char? (<=/c 2)) (list*of char? (<=/c 2)))
(ctest #f contract-equivalent? (list*of char? (<=/c 3)) (list*of char? (<=/c 2)))
(ctest #t contract-equivalent? (list*of char? null?) (listof char?))
(ctest #t contract-equivalent? (listof char?) (list*of char? null?))
(ctest #f contract-equivalent? (list*of char? any/c) (listof char?))
(ctest #f contract-equivalent? (vectorof (<=/c 3)) (vectorof (<=/c 4)))
(ctest #f contract-equivalent? (vectorof (<=/c 3)) (vectorof (<=/c 4)))
(ctest #t contract-equivalent? (vectorof (<=/c 3)) (vectorof (<=/c 3)))
(ctest #f contract-equivalent? (vectorof (<=/c 3) #:immutable #t) (vectorof (<=/c 4) #:immutable #t))
(ctest #f contract-equivalent? (vectorof (<=/c 3) #:immutable #t) (vectorof (<=/c 3)))
(ctest #f contract-equivalent? (vectorof (<=/c 3)) (vectorof (<=/c 3) #:immutable #t))
(ctest #f contract-equivalent? (vectorof (<=/c 3)) (vectorof (<=/c 3) #:immutable #f))
(ctest #f contract-equivalent? (vectorof (<=/c 3) #:immutable #f) (vectorof (<=/c 3)))
(ctest #t contract-equivalent? (vectorof (<=/c 3) #:immutable #f) (vectorof (<=/c 3) #:immutable #f))
(ctest #t contract-equivalent? (vectorof (<=/c 3)) (vectorof (<=/c 3)))
(ctest #f contract-equivalent? (vector/c (<=/c 3) (<=/c 3) (<=/c 3)) (vectorof (<=/c 3)))
(ctest #f contract-equivalent? (vector/c (<=/c 3) (<=/c 3) (<=/c 3)) (vectorof (<=/c 4)))
(ctest #f contract-equivalent? (vector/c (<=/c 3) (<=/c 3) (<=/c 3)) (vectorof (<=/c 2)))
(ctest #t contract-equivalent? (vector/c (<=/c 3) (<=/c 2)) (vector/c (<=/c 3) (<=/c 2)))
(ctest #f contract-equivalent? (vector/c (<=/c 3) (<=/c 3)) (vector/c (<=/c 3) (<=/c 2)))
(ctest #f contract-equivalent? (vector/c (<=/c 3) (<=/c 2)) (vector/c (<=/c 3) (<=/c 3)))
(ctest #f contract-equivalent? (vector/c (<=/c 3) #:immutable #t) (vector/c (<=/c 3)))
(ctest #f contract-equivalent? (vector/c (<=/c 3) #:immutable #f) (vector/c (<=/c 3)))
(ctest #t contract-equivalent? (vector/c (<=/c 3) #:immutable #f) (vector/c (<=/c 3) #:immutable #f))
(ctest #f contract-equivalent? (vector/c (<=/c 3)) (vector/c (<=/c 3) #:immutable #t))
(ctest #f contract-equivalent? (vector/c (<=/c 3)) (vector/c (<=/c 3) #:immutable #f))
(ctest #f contract-equivalent? (vector/c (<=/c 2) #:immutable #t) (vector/c (<=/c 3) #:immutable #t))
(ctest #f contract-equivalent? (vector/c (<=/c 3) #:immutable #t) (vector/c (<=/c 2) #:immutable #t))
(ctest #t contract-equivalent? (box/c (<=/c 3)) (box/c (<=/c 3)))
(ctest #f contract-equivalent? (box/c (<=/c 3)) (box/c (<=/c 2)))
(ctest #f contract-equivalent? (box/c (<=/c 2)) (box/c (<=/c 3)))
(ctest #t contract-equivalent? (box/c (<=/c 3) #:immutable #t) (box/c (<=/c 3) #:immutable #t))
(ctest #f contract-equivalent? (box/c (<=/c 2) #:immutable #t) (box/c (<=/c 3) #:immutable #t))
(ctest #f contract-equivalent? (box/c (<=/c 3) #:immutable #t) (box/c (<=/c 2) #:immutable #t))
(ctest #f contract-equivalent? (box/c (<=/c 3) #:immutable #t) (box/c (<=/c 3)))
(ctest #f contract-equivalent? (box/c (<=/c 3) #:immutable #f) (box/c (<=/c 3)))
(ctest #f contract-equivalent? (box/c (<=/c 3)) (box/c (<=/c 3) #:immutable #t))
(ctest #f contract-equivalent? (box/c (<=/c 3)) (box/c (<=/c 3) #:immutable #f))
(ctest #t contract-equivalent? (hash/c integer? symbol?) (hash/c integer? symbol?))
(ctest #f contract-equivalent? (hash/c integer? symbol?) (hash/c symbol? integer?))
(ctest #f contract-equivalent? (hash/c (<=/c 2) symbol?) (hash/c (<=/c 3) symbol?))
(ctest #f contract-equivalent?
(hash/c (<=/c 2) symbol? #:immutable #t)
(hash/c (<=/c 3) symbol? #:immutable #t))
(ctest #t contract-equivalent?
(hash/c (<=/c 2) symbol? #:immutable #t)
(hash/c (<=/c 2) symbol? #:immutable #t))
(ctest #f contract-equivalent?
(hash/c (<=/c 3) symbol? #:immutable #t)
(hash/c (<=/c 2) symbol? #:immutable #t))
(ctest #t contract-equivalent?
(hash/c (<=/c 2) symbol? #:immutable #f)
(hash/c (<=/c 2) symbol? #:immutable #f))
(ctest #f contract-equivalent?
(hash/c (<=/c 2) symbol? #:immutable #f)
(hash/c (<=/c 2) symbol?))
(ctest #f contract-equivalent?
(hash/c (<=/c 2) symbol?)
(hash/c (<=/c 2) symbol? #:immutable #f))
(contract-eval
`(let ()
(define x (flat-rec-contract x (or/c (cons/c x '()) '())))
(,test #:test-case-name 'flat-rec.1 #t contract-equivalent? x (or/c (cons/c x '()) '()))))
(contract-eval
`(let ()
(define x (flat-rec-contract x (first-or/c (cons/c x '()) '())))
(,test #:test-case-name 'flat-rec.2 #t contract-equivalent? x (first-or/c (cons/c x '()) '()))))
(ctest #f contract-equivalent? "x" string?)
(ctest #f contract-equivalent? string? "x")
(ctest #f contract-equivalent? 1 real?)
(ctest #f contract-equivalent? 1 (between/c -10 10))
(ctest #f contract-equivalent? real? 1)
(ctest #t contract-equivalent? real? real?)
(ctest #t contract-equivalent? 1 1)
(ctest #f contract-equivalent? 'x symbol?)
(ctest #f contract-equivalent? symbol? 'x)
(ctest #t contract-equivalent?
(flat-named-contract 'name1 #f)
(flat-named-contract 'name2 #f))
(ctest #t contract-equivalent?
(flat-named-contract 'name1 (flat-named-contract 'name2 #f))
(flat-named-contract 'name3 (flat-named-contract 'name4 #f)))
(ctest #t contract-equivalent? (flat-named-contract 'name1 1) (flat-named-contract 'name2 1))
(ctest #t contract-equivalent? (flat-named-contract 'name1 "x") (flat-named-contract 'name2 "x"))
(ctest #t contract-equivalent?
(flat-named-contract 'name2 (regexp "x"))
(flat-named-contract 'name2 (regexp "x")))
(ctest #f contract-equivalent? (listof (<=/c 3)) (listof (<=/c 5)))
(ctest #t contract-equivalent? (listof (<=/c 5)) (listof (<=/c 5)))
(ctest #t contract-equivalent? (list/c (<=/c 3) (<=/c 3)) (list/c (<=/c 3) (<=/c 3)))
(ctest #f contract-equivalent? (list/c (<=/c 3) (<=/c 3)) (list/c (<=/c 3) (<=/c 3) (<=/c 3)))
(ctest #f contract-equivalent? (list/c (<=/c 3) (<=/c 3) (<=/c 3)) (list/c (<=/c 3) (<=/c 3)))
(ctest #f contract-equivalent? (list/c (<=/c 3) (<=/c 3)) (listof (<=/c 5)))
(ctest #f contract-equivalent? (list/c (<=/c 3) (<=/c 3)) (non-empty-listof (<=/c 5)))
(ctest #f contract-equivalent? (list/c (<=/c 3)) (non-empty-listof (<=/c 5)))
(ctest #f contract-equivalent? (list/c) (non-empty-listof (<=/c 5)))
(ctest #f contract-equivalent? (list/c) (listof (<=/c 5)))
(ctest #t contract-equivalent? (list/c) (list/c))
(ctest #t contract-equivalent? (listof (<=/c 5)) (listof (<=/c 5)))
(ctest #t contract-equivalent? (*list/c integer? boolean? char?) (*list/c integer? boolean? char?))
(ctest #f contract-equivalent? (list/c integer? boolean? char?) (listof (or/c integer? boolean? char?)))
(ctest #t contract-equivalent? (list/c integer? boolean? char?) (list/c integer? boolean? char?))
(ctest #t contract-equivalent? (listof (or/c integer? boolean? char?)) (listof (or/c integer? boolean? char?)))
(ctest #f contract-equivalent? (promise/c (<=/c 2)) (promise/c (<=/c 3)))
(ctest #f contract-equivalent? (promise/c (<=/c 3)) (promise/c (<=/c 2)))
(ctest #t contract-equivalent? (promise/c (<=/c 2)) (promise/c (<=/c 2)))
(ctest #f contract-equivalent? (syntax/c (<=/c 3)) (syntax/c (<=/c 4)))
(ctest #f contract-equivalent? (syntax/c (<=/c 4)) (syntax/c (<=/c 3)))
(ctest #t contract-equivalent? (syntax/c (<=/c 4)) (syntax/c (<=/c 4)))
(ctest #t contract-equivalent? (parametric->/c (x) (-> x x)) (parametric->/c (x) (-> x x)))
(ctest #f contract-equivalent? (parametric->/c (x) (-> x x)) (parametric->/c (x) (-> x (or/c x #f))))
(ctest #f contract-equivalent? (parametric->/c (x) (-> x x)) (parametric->/c (x) (-> x (first-or/c x #f))))
(ctest #f contract-equivalent? (parametric->/c (x y) (-> x y)) (parametric->/c (x y) (-> x x y)))
(contract-eval `(define α (new-∀/c)))
(ctest #f contract-equivalent? (-> α α) (-> α (or/c #f α)))
(ctest #t contract-equivalent? (-> α α) (-> α α))
(ctest #f contract-equivalent? (-> α (or/c #f α)) (-> α α))
(ctest #f contract-equivalent? (-> α α) (-> α (first-or/c #f α)))
(ctest #f contract-equivalent? (-> α (first-or/c #f α)) (-> α α))
(ctest #t contract-equivalent?
(class/c (m (-> any/c (<=/c 3))))
(class/c (m (-> any/c (<=/c 3)))))
(ctest #f contract-equivalent?
(class/c (m (-> any/c (<=/c 3))))
(class/c (m (-> any/c (<=/c 4)))))
(ctest #f contract-equivalent?
(class/c (m (-> any/c (<=/c 4))))
(class/c (m (-> any/c (<=/c 3)))))
(ctest #t contract-equivalent?
(class/c (field [f integer?]))
(class/c (field [f integer?])))
(ctest #f contract-equivalent?
(class/c (field [f (<=/c 3)]))
(class/c (field [f (<=/c 4)])))
(ctest #f contract-equivalent?
(class/c (field [f (<=/c 4)]))
(class/c (field [f (<=/c 3)])))
(ctest #t contract-equivalent?
(class/c (init [f (<=/c 3)]))
(class/c (init [f (<=/c 3)])))
(ctest #f contract-equivalent?
(class/c (init [f (<=/c 3)]))
(class/c (init [f (<=/c 4)])))
(ctest #f contract-equivalent?
(class/c (init [f (<=/c 4)]))
(class/c (init [f (<=/c 3)])))
(ctest #t contract-equivalent?
(class/c (inherit [m (-> any/c (<=/c 3))]))
(class/c (inherit [m (-> any/c (<=/c 3))])))
(ctest #f contract-equivalent?
(class/c (inherit [m (-> any/c (<=/c 3))]))
(class/c (inherit [m (-> any/c (<=/c 4))])))
(ctest #f contract-equivalent?
(class/c (inherit [m (-> any/c (<=/c 4))]))
(class/c (inherit [m (-> any/c (<=/c 3))])))
(ctest #t contract-equivalent?
(class/c (super [m (-> any/c (<=/c 3))]))
(class/c (super [m (-> any/c (<=/c 3))])))
(ctest #f contract-equivalent?
(class/c (super [m (-> any/c (<=/c 3))]))
(class/c (super [m (-> any/c (<=/c 4))])))
(ctest #f contract-equivalent?
(class/c (super [m (-> any/c (<=/c 4))]))
(class/c (super [m (-> any/c (<=/c 3))])))
(ctest #t contract-equivalent?
(class/c (inner [m (-> any/c (<=/c 3))]))
(class/c (inner [m (-> any/c (<=/c 3))])))
(ctest #f contract-equivalent?
(class/c (inner [m (-> any/c (<=/c 3))]))
(class/c (inner [m (-> any/c (<=/c 4))])))
(ctest #f contract-equivalent?
(class/c (inner [m (-> any/c (<=/c 4))]))
(class/c (inner [m (-> any/c (<=/c 3))])))
(ctest #t contract-equivalent?
(class/c (override [m (-> any/c (<=/c 3))]))
(class/c (override [m (-> any/c (<=/c 3))])))
(ctest #f contract-equivalent?
(class/c (override [m (-> any/c (<=/c 3))]))
(class/c (override [m (-> any/c (<=/c 4))])))
(ctest #f contract-equivalent?
(class/c (override [m (-> any/c (<=/c 4))]))
(class/c (override [m (-> any/c (<=/c 3))])))
(ctest #t contract-equivalent?
(class/c (augment [m (-> any/c (<=/c 3))]))
(class/c (augment [m (-> any/c (<=/c 3))])))
(ctest #f contract-equivalent?
(class/c (augment [m (-> any/c (<=/c 3))]))
(class/c (augment [m (-> any/c (<=/c 4))])))
(ctest #f contract-equivalent?
(class/c (augment [m (-> any/c (<=/c 4))]))
(class/c (augment [m (-> any/c (<=/c 3))])))
(ctest #t contract-equivalent?
(class/c (augride [m (-> any/c (<=/c 3))]))
(class/c (augride [m (-> any/c (<=/c 3))])))
(ctest #f contract-equivalent?
(class/c (augride [m (-> any/c (<=/c 3))]))
(class/c (augride [m (-> any/c (<=/c 4))])))
(ctest #f contract-equivalent?
(class/c (augride [m (-> any/c (<=/c 4))]))
(class/c (augride [m (-> any/c (<=/c 3))])))
(ctest #t contract-equivalent?
(class/c (absent m))
(class/c (absent m)))
(ctest #f contract-equivalent?
(class/c (absent m n))
(class/c (absent m)))
(ctest #f contract-equivalent?
(class/c (absent m))
(class/c (absent m n)))
(ctest #t contract-equivalent?
(class/c (absent (field f)))
(class/c (absent (field f))))
(ctest #f contract-equivalent?
(class/c (absent (field f g)))
(class/c (absent (field f))))
(ctest #f contract-equivalent?
(class/c (absent (field f)))
(class/c (absent (field f g))))
(ctest #f contract-equivalent?
(class/c (absent (field x)))
(class/c (absent x)))
(ctest #f contract-equivalent?
(class/c (absent x))
(class/c (absent (field x))))
(ctest #t contract-equivalent?
(instanceof/c (class/c (m (-> any/c (<=/c 3)))))
(instanceof/c (class/c (m (-> any/c (<=/c 3))))))
(ctest #f contract-equivalent?
(instanceof/c (class/c (m (-> any/c (<=/c 3)))))
(instanceof/c (class/c (m (-> any/c (<=/c 4))))))
(ctest #f contract-equivalent?
(instanceof/c (class/c (m (-> any/c (<=/c 4)))))
(instanceof/c (class/c (m (-> any/c (<=/c 3))))))
(ctest #t contract-equivalent?
(object/c (m (-> any/c (<=/c 3))))
(object/c (m (-> any/c (<=/c 3)))))
(ctest #f contract-equivalent?
(object/c (m (-> any/c (<=/c 3))))
(object/c (m (-> any/c (<=/c 4)))))
(ctest #t contract-equivalent?
(object/c (field (f (<=/c 4))))
(object/c (field (f (<=/c 4)))))
(ctest #f contract-equivalent?
(object/c (m (-> any/c (<=/c 3)))
(n (-> any/c any/c)))
(object/c (m (-> any/c (<=/c 4)))))
(ctest #f contract-equivalent?
(object/c (m (-> any/c (<=/c 4))))
(object/c (m (-> any/c (<=/c 3)))))
(ctest #f contract-equivalent?
(object/c (field (f (<=/c 4))))
(object/c (field (f (<=/c 3)))))
(ctest #f contract-equivalent?
(object/c (m (-> any/c (<=/c 3))))
(object/c (n (-> any/c (<=/c 4)))))
(ctest #f contract-equivalent?
(object/c (field (x any/c)))
(object/c (field (y any/c))))
(ctest #f contract-equivalent?
(object/c (m (-> any/c (<=/c 4))))
(object/c (m (-> any/c (<=/c 3)))
(n (-> any/c any/c))))
(ctest #t contract-equivalent? (is-a?/c object%) (is-a?/c object%))
(ctest #f contract-equivalent? (is-a?/c (class object% (super-new))) (is-a?/c object%))
(ctest #f contract-equivalent? (is-a?/c object%) (is-a?/c (class object% (super-new))))
(contract-eval `(define one-interface<%> (interface ())))
(contract-eval `(define another-interface<%> (interface (one-interface<%>))))
(ctest #t contract-equivalent? (is-a?/c one-interface<%>) (is-a?/c one-interface<%>))
(ctest #f contract-equivalent? (is-a?/c another-interface<%>) (is-a?/c one-interface<%>))
(ctest #f contract-equivalent? (is-a?/c one-interface<%>) (is-a?/c another-interface<%>))
(ctest #f contract-equivalent?
(is-a?/c (class* object% (one-interface<%>) (super-new)))
(is-a?/c one-interface<%>))
(ctest #f contract-equivalent?
(is-a?/c one-interface<%>)
(is-a?/c (class* object% (one-interface<%>) (super-new))))
(ctest #t contract-equivalent? (subclass?/c object%) (subclass?/c object%))
(ctest #f contract-equivalent? (subclass?/c (class object% (super-new))) (subclass?/c object%))
(ctest #f contract-equivalent? (subclass?/c object%) (subclass?/c (class object% (super-new))))
(ctest #t contract-equivalent?
(implementation?/c one-interface<%>)
(implementation?/c one-interface<%>))
(ctest #f contract-equivalent?
(implementation?/c another-interface<%>)
(implementation?/c one-interface<%>))
(ctest #f contract-equivalent?
(implementation?/c one-interface<%>)
(implementation?/c another-interface<%>))
(ctest #t contract-equivalent? (evt/c integer?) (evt/c integer?))
(ctest #f contract-equivalent? (evt/c integer?) (evt/c boolean?))
;; chances are, this predicate will accept "x", but
;; we don't want to consider it stronger, since it
;; will not always accept "x".
(ctest #f contract-equivalent? "x" (λ (x) (not (zero? (random 10000)))))
(contract-eval
`(let ()
(define (non-zero? x) (not (zero? x)))
(define list-of-numbers
(or/c null?
(couple/c number?
(recursive-contract list-of-numbers))))
(define (short-list/less-than n)
(or/c null?
(couple/c (<=/c n)
(or/c null?
(couple/c (<=/c n)
any/c)))))
(define (short-sorted-list/less-than n)
(or/c null?
(couple/dc
[hd (<=/c n)]
[tl (hd) (or/c null?
(couple/c (<=/c hd)
any/c))])))
(define (sorted-list/less-than n)
(or/c null?
(couple/dc
[hd (<=/c n)]
[tl (hd) (sorted-list/less-than hd)])))
;; for some reason, the `n' makes it harder to optimize.
;; without it, this test isn't as good a test
(define (closure-comparison-test n)
(couple/dc
[hd any/c]
[tl (hd) (if (< (random n) -1) none/c any/c)]))
(,test #:test-case-name 'dsc.1 #t contract-equivalent? (couple/c any/c any/c) (couple/c any/c any/c))
(,test #:test-case-name 'dsc.2 #f contract-equivalent? (couple/c (>=/c 2) (>=/c 3)) (couple/c (>=/c 4) (>=/c 5)))
(,test #:test-case-name 'dsc.3 #f contract-equivalent? (couple/c (>=/c 4) (>=/c 5)) (couple/c (>=/c 2) (>=/c 3)))
(,test #:test-case-name 'dsc.4 #f contract-equivalent? (couple/c (>=/c 1) (>=/c 5)) (couple/c (>=/c 5) (>=/c 1)))
(let ([ctc (couple/dc [hd any/c] [tl (hd) any/c])])
(,test #:test-case-name 'dsc.5 #t contract-equivalent? ctc ctc))
(let ([ctc (couple/dc [hd any/c] [tl (hd) (<=/c hd)])])
(,test #:test-case-name 'dsc.6 #t contract-equivalent? ctc ctc))
(,test #:test-case-name 'dsc.7 #t contract-equivalent? list-of-numbers list-of-numbers)
(,test #:test-case-name 'dsc.8 #t contract-equivalent? (short-list/less-than 4) (short-list/less-than 4))
(,test #:test-case-name 'dsc.9 #f contract-equivalent? (short-list/less-than 4) (short-list/less-than 5))
(,test #:test-case-name 'dsc.10 #f contract-equivalent? (short-list/less-than 5) (short-list/less-than 4))
(,test #:test-case-name 'dsc.11 #t contract-equivalent? (short-sorted-list/less-than 4) (short-sorted-list/less-than 4))
(,test #:test-case-name 'dsc.12 #f contract-equivalent? (short-sorted-list/less-than 4) (short-sorted-list/less-than 5))
(,test #:test-case-name 'dsc.13 #f contract-equivalent? (short-sorted-list/less-than 5) (short-sorted-list/less-than 4))
(,test #:test-case-name 'dsc.14 #t contract-equivalent? (sorted-list/less-than 4) (sorted-list/less-than 4))
(,test #:test-case-name 'dsc.15 #f contract-equivalent? (sorted-list/less-than 4) (sorted-list/less-than 5))
(,test #:test-case-name 'dsc.16 #f contract-equivalent? (sorted-list/less-than 5) (sorted-list/less-than 4))
(,test #:test-case-name 'dsc.17 #t contract-equivalent? (closure-comparison-test 4) (closure-comparison-test 4))
(,test #:test-case-name 'dsc.18 #f contract-equivalent? (closure-comparison-test 4) (closure-comparison-test 5))
(letrec ([mk-c
(λ (x)
(triple/dc [a (<=/c x)]
[b any/c]
[c (a b) (or/c #f (mk-c a))]))])
(,test #:test-case-name 'dsc.19 #t contract-equivalent? (mk-c 1) (mk-c 1)))
(letrec ([mk-c
(λ (x)
(triple/dc [a (<=/c x)]
[b any/c]
[c (a b) (or/c #f (mk-c a))]))])
(,test #:test-case-name 'dsc.20 #f contract-equivalent? (mk-c 1) (mk-c 2)))))
(contract-eval
`(let ()
(define (non-zero? x) (not (zero? x)))
(define list-of-numbers
(first-or/c null?
(couple/c number?
(recursive-contract list-of-numbers))))
(define (short-list/less-than n)
(first-or/c null?
(couple/c (<=/c n)
(first-or/c null?
(couple/c (<=/c n)
any/c)))))
(define (short-sorted-list/less-than n)
(first-or/c null?
(couple/dc
[hd (<=/c n)]
[tl (hd) (first-or/c null?
(couple/c (<=/c hd)
any/c))])))
(define (sorted-list/less-than n)
(first-or/c null?
(couple/dc
[hd (<=/c n)]
[tl (hd) (sorted-list/less-than hd)])))
(define (closure-comparison-test n)
(couple/dc
[hd any/c]
[tl (hd) (if (< (random 10) (- n)) none/c any/c)]))
(,test #:test-case-name 'couple.1
#t contract-equivalent? (couple/c any/c any/c) (couple/c any/c any/c))
(,test #:test-case-name 'couple.2
#f contract-equivalent? (couple/c (>=/c 2) (>=/c 3)) (couple/c (>=/c 4) (>=/c 5)))
(,test #:test-case-name 'couple.3
#f contract-equivalent? (couple/c (>=/c 4) (>=/c 5)) (couple/c (>=/c 2) (>=/c 3)))
(,test #:test-case-name 'couple.4
#f contract-equivalent? (couple/c (>=/c 1) (>=/c 5)) (couple/c (>=/c 5) (>=/c 1)))
(let ([ctc (couple/dc [hd any/c] [tl (hd) any/c])])
(,test #:test-case-name 'couple.5 #t contract-equivalent? ctc ctc))
(let ([ctc (couple/dc [hd any/c] [tl (hd) (<=/c hd)])])
(,test #:test-case-name 'couple.6 #t contract-equivalent? ctc ctc))
(,test #:test-case-name 'couple.7 #t contract-equivalent? list-of-numbers list-of-numbers)
(,test #:test-case-name 'couple.8 #f contract-equivalent? (short-list/less-than 4) (short-list/less-than 5))
(,test #:test-case-name 'couple.9 #f contract-equivalent? (short-list/less-than 5) (short-list/less-than 4))
(,test #:test-case-name 'couple.10 #t contract-equivalent? (short-sorted-list/less-than 4) (short-sorted-list/less-than 4))
(,test #:test-case-name 'couple.11 #f contract-equivalent? (short-sorted-list/less-than 4) (short-sorted-list/less-than 5))
(,test #:test-case-name 'couple.12 #f contract-equivalent? (short-sorted-list/less-than 5) (short-sorted-list/less-than 4))
(,test #:test-case-name 'couple.13 #t contract-equivalent? (sorted-list/less-than 4) (sorted-list/less-than 4))
(,test #:test-case-name 'couple.14 #f contract-equivalent? (sorted-list/less-than 4) (sorted-list/less-than 5))
(,test #:test-case-name 'couple.15 #f contract-equivalent? (sorted-list/less-than 5) (sorted-list/less-than 4))
(,test #:test-case-name 'couple.16 #t contract-equivalent? (closure-comparison-test 4) (closure-comparison-test 4))
(,test #:test-case-name 'couple.17 #f contract-equivalent? (closure-comparison-test 4) (closure-comparison-test 5))
(letrec ([mk-c
(λ (x)
(triple/dc [a (<=/c x)]
[b any/c]
[c (a b) (or/c #f (mk-c a))]))])
(,test #:test-case-name 'couple.18 #t contract-equivalent? (mk-c 1) (mk-c 1)))
(letrec ([mk-c
(λ (x)
(triple/dc [a (<=/c x)]
[b any/c]
[c (a b) (or/c #f (mk-c a))]))])
(,test #:test-case-name 'couple.19 #f contract-equivalent? (mk-c 1) (mk-c 2)))))
(contract-eval
`(let ()
(struct s (a b))
(struct t (a b))
(,test #:test-case-name 'struct/dc.1 #f contract-equivalent?
(struct/dc s
[a (>=/c 1)]
[b (>=/c 2)])
(struct/dc s
[a (>=/c 2)]
[b (>=/c 3)]))
(,test #:test-case-name 'struct/dc.2 #t contract-equivalent?
(struct/dc s
[a (>=/c 2)]
[b (>=/c 3)])
(struct/dc s
[a (>=/c 2)]
[b (>=/c 3)]))
(,test #:test-case-name 'struct/dc.3 #f contract-equivalent?
(struct/dc s
[a (>=/c 2)]
[b (>=/c 3)])
(struct/dc s
[a (>=/c 1)]
[b (>=/c 2)]))
(,test #:test-case-name 'struct/dc.4 #f contract-equivalent?
(struct/dc s
[a number?]
[b number?])
(struct/dc t
[a number?]
[b number?]))
(,test #:test-case-name 'struct/dc.5 #f contract-equivalent?
(struct/dc t
[a number?]
[b number?])
(struct/dc s
[a number?]
[b number?]))
(,test #:test-case-name 'struct/dc.6 #f
contract-equivalent?
(struct/dc s
[a integer?]
[b integer?])
(struct/dc s
[a integer?]
[b integer?]
#:inv (a b) #f))
(,test #:test-case-name 'struct/dc.7 #f
contract-equivalent?
(struct/dc s
[a integer?]
[b integer?]
#:inv (a b) #f)
(struct/dc s
[a integer?]
[b integer?]))
(define (mk c)
(struct/dc s
[a (>=/c c)]
[b (a) (>=/c a)]))
(define one (mk 1))
(define two (mk 2))
(,test #:test-case-name 'struct/dc.8 #t contract-equivalent? one one)
(,test #:test-case-name 'struct/dc.9 #f contract-equivalent? one two)
(,test #:test-case-name 'struct/dc.10 #f contract-equivalent? two one)))
(contract-eval
`(define imp-ctc
(make-contract
#:late-neg-projection (λ (blame) (λ (val neg) (add1 val))))))
(contract-eval
`(define imp-struct-ctc
(let ()
(struct imp-ctc-struct ()
#:property prop:contract
(build-contract-property
#:late-neg-projection
(λ (ctc)
(λ (blame)
(λ (val neg)
(add1 val))))))
(imp-ctc-struct))))
(ctest #f contract-equivalent? imp-ctc imp-ctc)
(ctest #f contract-equivalent? imp-struct-ctc imp-struct-ctc))

1
racket/collects/racket/contract/combinator.rkt
View File

@ -51,6 +51,7 @@
build-compound-type-name
contract-stronger?
contract-equivalent?
list-contract?
contract-first-order

24
racket/collects/racket/contract/private/and.rkt
View File

@ -62,6 +62,11 @@
(pairwise-stronger-contracts? (base-and/c-ctcs this)
(base-and/c-ctcs that))))
(define (and-equivalent? this that)
(and (base-and/c? that)
(pairwise-equivalent-contracts? (base-and/c-ctcs this)
(base-and/c-ctcs that))))
(define (and/c-generate? ctc)
(cond
[(and/c-check-nonneg ctc real?) => values]
@ -147,6 +152,7 @@
#:name and-name
#:first-order and-first-order
#:stronger and-stronger?
#:equivalent and-equivalent?
#:generate and/c-generate?))
(define-struct (chaperone-and/c base-and/c) ()
#:property prop:custom-write custom-write-property-proc
@ -156,6 +162,7 @@
#:name and-name
#:first-order and-first-order
#:stronger and-stronger?
#:equivalent and-equivalent?
#:generate and/c-generate?))
(define-struct (impersonator-and/c base-and/c) ()
#:property prop:custom-write custom-write-property-proc
@ -165,6 +172,7 @@
#:name and-name
#:first-order and-first-order
#:stronger and-stronger?
#:equivalent and-equivalent?
#:generate and/c-generate?))
(define-syntax (and/c stx)
@ -274,15 +282,25 @@
[else exact-integer?]))
(define (integer-in-stronger this that)
(define this-start (or (integer-in-ctc-start this) -inf.0))
(define this-end (or (integer-in-ctc-end this) +inf.0))
(cond
[(integer-in-ctc? that)
(define this-start (or (integer-in-ctc-start this) -inf.0))
(define this-end (or (integer-in-ctc-end this) +inf.0))
(define that-start (or (integer-in-ctc-start that) -inf.0))
(define that-end (or (integer-in-ctc-end that) +inf.0))
(<= that-start this-start this-end that-end)]
[else #f]))
(define (integer-in-equivalent this that)
(cond
[(integer-in-ctc? that)
(define this-start (or (integer-in-ctc-start this) -inf.0))
(define this-end (or (integer-in-ctc-end this) +inf.0))
(define that-start (or (integer-in-ctc-start that) -inf.0))
(define that-end (or (integer-in-ctc-end that) +inf.0))
(and (= that-start this-start) (= this-end that-end))]
[else #f]))
(define (integer-in-generate ctc)
(define start (integer-in-ctc-start ctc))
(define end (integer-in-ctc-end ctc))
@ -311,6 +329,7 @@
#:name integer-in-name
#:first-order integer-in-first-order
#:stronger integer-in-stronger
#:equivalent integer-in-equivalent
#:generate integer-in-generate))
(struct renamed-integer-in integer-in-ctc (name)
@ -319,6 +338,7 @@
#:name (λ (ctc) (renamed-integer-in-name ctc))
#:first-order integer-in-first-order
#:stronger integer-in-stronger
#:equivalent integer-in-equivalent
#:generate integer-in-generate))
(define (geo-dist p)

5
racket/collects/racket/contract/private/arr-d.rkt
View File

@ -545,7 +545,7 @@
(if (base-->d-rest-ctc ctc)
(check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds #f #f)
(check-procedure val mtd? dom-length optionals mandatory-kwds optional-kwds #f #f)))))
(define (->d-stronger? this that) (eq? this that))
(define (->d-equivalent? this that) (eq? this that))
;; in the struct type descriptions "d???" refers to the arguments (domain) of the function that
;; is under the contract, and "dr???" refers to the arguments & the results of the function that
@ -580,4 +580,5 @@
#:late-neg-projection (late-neg-->d-proj impersonate-procedure)
#:name (->d-name #|print-as-method-if-method?|# #t)
#:first-order ->d-first-order
#:stronger ->d-stronger?))
#:equivalent ->d-equivalent?
#:stronger ->d-equivalent?))

1
racket/collects/racket/contract/private/arr-i.rkt
View File

@ -317,6 +317,7 @@
(check-procedure/more val mtd? mand-args mand-kwds opt-kwds #f #f)
(check-procedure val mtd? mand-args opt-args mand-kwds opt-kwds #f #f)))))
#:exercise exercise->i
#:equivalent (λ (this that) (eq? this that))
#:stronger (λ (this that) (eq? this that)))) ;; WRONG
(struct chaperone->i ->i () #:property prop:chaperone-contract (mk-prop #t))

24
racket/collects/racket/contract/private/arrow-val-first.rkt
View File

@ -1558,6 +1558,7 @@
(λ (val)
((cblame val) #f))))
#:stronger ->-stronger
#:equivalent ->-equivalent
#:generate ->-generate
#:exercise ->-exercise
#:val-first-projection val-first-proj
@ -1586,6 +1587,29 @@
(not (base->-post? this))
(not (base->-post? that))))
(define (->-equivalent this that)
(and (base->? that)
(= (length (base->-doms that))
(length (base->-doms this)))
(= (base->-min-arity this) (base->-min-arity that))
(andmap contract-struct-equivalent? (base->-doms that) (base->-doms this))
(= (length (base->-kwd-infos this))
(length (base->-kwd-infos that)))
(for/and ([this-kwd-info (base->-kwd-infos this)]
[that-kwd-info (base->-kwd-infos that)])
(and (equal? (kwd-info-kwd this-kwd-info)
(kwd-info-kwd that-kwd-info))
(contract-struct-equivalent? (kwd-info-ctc that-kwd-info)
(kwd-info-ctc this-kwd-info))))
(if (base->-rngs this)
(and (base->-rngs that)
(andmap contract-struct-equivalent? (base->-rngs this) (base->-rngs that)))
(not (base->-rngs that)))
(not (base->-pre? this))
(not (base->-pre? that))
(not (base->-post? this))
(not (base->-post? that))))
(define-struct (-> base->) ()
#:property prop:chaperone-contract (make-property #f))

11
racket/collects/racket/contract/private/base.rkt
View File

@ -259,7 +259,7 @@
((f blame-known) val neg-party)))])]
[else (recursive-contract-late-neg-projection ctc)]))
(define (recursive-contract-stronger this that) (equal? this that))
(define (recursive-contract-equivalent this that) (equal? this that))
(define ((recursive-contract-first-order ctc) val)
(cond
@ -288,7 +288,8 @@
#:name recursive-contract-name
#:first-order recursive-contract-first-order
#:late-neg-projection flat-recursive-contract-late-neg-projection
#:stronger recursive-contract-stronger
#:stronger recursive-contract-equivalent
#:equivalent recursive-contract-equivalent
#:generate recursive-contract-generate
#:list-contract? recursive-contract-list-contract?))
(struct chaperone-recursive-contract recursive-contract ()
@ -298,7 +299,8 @@
#:name recursive-contract-name
#:first-order recursive-contract-first-order
#:late-neg-projection recursive-contract-late-neg-projection
#:stronger recursive-contract-stronger
#:stronger recursive-contract-equivalent
#:equivalent recursive-contract-equivalent
#:generate recursive-contract-generate
#:list-contract? recursive-contract-list-contract?))
(struct impersonator-recursive-contract recursive-contract ()
@ -308,6 +310,7 @@
#:name recursive-contract-name
#:first-order recursive-contract-first-order
#:late-neg-projection recursive-contract-late-neg-projection
#:stronger recursive-contract-stronger
#:stronger recursive-contract-equivalent
#:equivalent recursive-contract-equivalent
#:generate recursive-contract-generate
#:list-contract? recursive-contract-list-contract?))

29
racket/collects/racket/contract/private/box.rkt
View File

@ -101,11 +101,35 @@
(contract-struct-stronger? this-content-r that-content-r)]
[(or (equal? that-immutable 'dont-care)
(equal? this-immutable that-immutable))
(if (and (eq? this-content-r this-content-w)
(eq? that-content-r that-content-w))
;; if the original box/c didn't specify a separate read and write
;; contract, we end up in this case
(contract-struct-equivalent? this-content-r that-content-r)
(and (contract-struct-stronger? this-content-r that-content-r)
(contract-struct-stronger? that-content-w this-content-w))]
(contract-struct-stronger? that-content-w this-content-w)))]
[else #f])]
[else #f]))
(define (box/c-equivalent this that)
(cond
[(base-box/c? that)
(define this-content-w (base-box/c-content-w this))
(define this-content-r (base-box/c-content-r this))
(define this-immutable (base-box/c-immutable this))
(define that-content-w (base-box/c-content-w that))
(define that-content-r (base-box/c-content-r that))
(define that-immutable (base-box/c-immutable that))
(and (equal? this-immutable that-immutable)
(cond
[(or (equal? this-immutable 'immutable)
(and (eq? this-content-r this-content-w)
(eq? that-content-r that-content-w)))
(contract-struct-equivalent? this-content-r that-content-r)]
[else
(and (contract-struct-equivalent? this-content-r that-content-r)
(contract-struct-equivalent? that-content-w this-content-w))]))]
[else #f]))
(define-struct (flat-box/c base-box/c) ()
#:property prop:custom-write custom-write-property-proc
@ -114,6 +138,7 @@
#:name box/c-name
#:first-order box/c-first-order
#:stronger box/c-stronger
#:equivalent box/c-equivalent
#:late-neg-projection
(λ (ctc)
(define content-ctc (get/build-late-neg-projection (base-box/c-content-w ctc)))
@ -184,6 +209,7 @@
#:name box/c-name
#:first-order box/c-first-order
#:stronger box/c-stronger
#:equivalent box/c-equivalent
#:late-neg-projection (ho-late-neg-projection chaperone-box)))
(define-struct (impersonator-box/c base-box/c) ()
@ -193,6 +219,7 @@
#:name box/c-name
#:first-order box/c-first-order
#:stronger box/c-stronger
#:equivalent box/c-equivalent
#:late-neg-projection (ho-late-neg-projection impersonate-box)))
(define-syntax (box/c stx)

14
racket/collects/racket/contract/private/ds.rkt
View File

@ -229,13 +229,15 @@ it around flattened out.
ctc-field-val)] ...)
(values f-x ...)))
(define (stronger-lazy-contract? a b)
(define (stronger/equivalent-lazy-contract?
a b
contract-struct-stronger/equivalent?)
(and (contract-predicate b)
(let ([a-sel (contract-get a selector-indices)]
[b-sel (contract-get b selector-indices)])
(if (contract-struct? a-sel)
(if (contract-struct? b-sel)
(contract-struct-stronger? a-sel b-sel)
(contract-struct-stronger/equivalent? a-sel b-sel)
#f)
(if (contract-struct? b-sel)
#f
@ -321,7 +323,13 @@ it around flattened out.
#:projection lazy-contract-proj
#:name lazy-contract-name
#:first-order (lambda (ctc) predicate)
#:stronger stronger-lazy-contract?))
#:equivalent (λ (this that)
(stronger/equivalent-lazy-contract?
this that
contract-struct-equivalent?))
#:stronger (λ (this that) (stronger/equivalent-lazy-contract?
this that
contract-struct-stronger?))))
(define-values (contract-type contract-maker contract-predicate contract-get contract-set)
(make-struct-type 'the-contract

1
racket/collects/racket/contract/private/exists.rkt
View File

@ -36,6 +36,7 @@
#:first-order (λ (ctc) (λ (x) #t)) ;; ???
#:late-neg-projection ∀∃-late-neg-proj
#:stronger (λ (this that) (equal? this that))
#:equivalent (λ (this that) (equal? this that))
#:generate (λ (ctc)
(cond
[(∀∃/c-neg? ctc)

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

@ -22,6 +22,7 @@
build-compound-type-name
contract-stronger?
contract-equivalent?
list-contract?
contract-first-order
@ -229,6 +230,10 @@
(contract-struct-stronger? (coerce-contract 'contract-stronger? a)
(coerce-contract 'contract-stronger? b)))
(define (contract-equivalent? a b)
(contract-struct-equivalent? (coerce-contract 'contract-equivalent? a)
(coerce-contract 'contract-equivalent? b)))
;; coerce-flat-contract : symbol any/c -> contract
(define (coerce-flat-contract name x)
(define ctc (coerce-contract/f x))
@ -557,6 +562,11 @@
(and (predicate-contract? that)
(predicate-contract-sane? that)
((predicate-contract-pred that) this-val))))
#:equivalent
(λ (this that)
(define this-val (eq-contract-val this))
(and (eq-contract? that)
(eq? this-val (eq-contract-val that))))
#:list-contract? (λ (c) (null? (eq-contract-val c)))))
(define false/c-contract (make-eq-contract #f #f))
@ -576,6 +586,11 @@
(and (predicate-contract? that)
(predicate-contract-sane? that)
((predicate-contract-pred that) this-val))))
#:equivalent
(λ (this that)
(define this-val (equal-contract-val this))
(and (equal-contract? that)
(equal? this-val (equal-contract-val that))))
#:generate
(λ (ctc)
(define v (equal-contract-val ctc))
@ -597,6 +612,13 @@
(and (predicate-contract? that)
(predicate-contract-sane? that)
((predicate-contract-pred that) this-val))))
#:equivalent
(λ (this that)
(define this-val (=-contract-val this))
(or (and (=-contract? that)
(= this-val (=-contract-val that)))
(and (between/c-s? that)
(= (between/c-s-low that) this-val (between/c-s-high that)))))
#:generate
(λ (ctc)
(define v (=-contract-val ctc))
@ -659,6 +681,17 @@
(and (char<=? that-low this-low)
(char<=? this-high that-high))]
[else #f]))
#:equivalent
(λ (this that)
(cond
[(char-in/c? that)
(define this-low (char-in/c-low this))
(define this-high (char-in/c-high this))
(define that-low (char-in/c-low that))
(define that-high (char-in/c-high that))
(and (char=? that-low this-low)
(char=? this-high that-high))]
[else #f]))
#:generate
(λ (ctc)
(define low (char->integer (char-in/c-low ctc)))
@ -668,6 +701,10 @@
(λ ()
(integer->char (+ low (random delta))))))))
(define (regexp/c-equivalent this that)
(and (regexp/c? that)
(equal? (regexp/c-reg this) (regexp/c-reg that))))
(define-struct regexp/c (reg name)
#:property prop:custom-write contract-custom-write-property-proc
#:property prop:flat-contract
@ -679,9 +716,13 @@
(and (or (string? x) (bytes? x))
(regexp-match? reg x))))
#:name (λ (ctc) (regexp/c-reg ctc))
#:stronger
(λ (this that)
(and (regexp/c? that) (equal? (regexp/c-reg this) (regexp/c-reg that))))))
#:stronger regexp/c-equivalent
#:equivalent regexp/c-equivalent))
(define (predicate-contract-equivalent this that)
(and (predicate-contract? that)
(procedure-closure-contents-eq? (predicate-contract-pred this)
(predicate-contract-pred that))))
;; sane? : boolean -- indicates if we know that the predicate is well behaved
;; (for now, basically amounts to trusting primitive procedures)
@ -689,11 +730,8 @@
#:property prop:custom-write contract-custom-write-property-proc
#:property prop:flat-contract
(build-flat-contract-property
#:stronger
(λ (this that)
(and (predicate-contract? that)
(procedure-closure-contents-eq? (predicate-contract-pred this)
(predicate-contract-pred that))))
#:stronger predicate-contract-equivalent
#:equivalent predicate-contract-equivalent
#:name (λ (ctc) (predicate-contract-name ctc))
#:first-order (λ (ctc) (predicate-contract-pred ctc))
#:late-neg-projection

27
racket/collects/racket/contract/private/hash.rkt
View File

@ -169,13 +169,25 @@
(contract-struct-stronger? this-rng that-rng))]
[(or (equal? that-immutable 'dont-care)
(equal? this-immutable that-immutable))
(and (contract-struct-stronger? this-dom that-dom)
(contract-struct-stronger? that-dom this-dom)
(contract-struct-stronger? this-rng that-rng)
(contract-struct-stronger? that-rng this-rng))]
(and (contract-struct-equivalent? this-dom that-dom)
(contract-struct-equivalent? this-rng that-rng))]
[else #f])]
[else #f]))
(define (hash/c-equivalent this that)
(cond
[(base-hash/c? that)
(define this-dom (base-hash/c-dom this))
(define this-rng (base-hash/c-rng this))
(define this-immutable (base-hash/c-immutable this))
(define that-dom (base-hash/c-dom that))
(define that-rng (base-hash/c-rng that))
(define that-immutable (base-hash/c-immutable that))
(and (equal? this-immutable that-immutable)
(contract-struct-equivalent? this-dom that-dom)
(contract-struct-equivalent? this-rng that-rng))]
[else #f]))
(define-struct (flat-hash/c base-hash/c) ()
#:omit-define-syntaxes
#:property prop:custom-write custom-write-property-proc
@ -184,6 +196,7 @@
#:name hash/c-name
#:first-order hash/c-first-order
#:stronger hash/c-stronger
#:equivalent hash/c-equivalent
#:late-neg-projection
(λ (ctc)
(define dom-ctc (base-hash/c-dom ctc))
@ -299,6 +312,7 @@
#:name hash/c-name
#:first-order hash/c-first-order
#:stronger hash/c-stronger
#:equivalent hash/c-equivalent
#:late-neg-projection (ho-projection chaperone-hash)))
(define-struct (impersonator-hash/c base-hash/c) ()
@ -309,6 +323,7 @@
#:name hash/c-name
#:first-order hash/c-first-order
#:stronger hash/c-stronger
#:equivalent hash/c-equivalent
#:late-neg-projection (ho-projection impersonate-hash)))
@ -337,6 +352,7 @@
(contract-first-order-passes? (rng-f k) v))))))
(define (hash/dc-stronger this that) #f)
(define (hash/dc-equivalent this that) #f)
(define ((hash/dc-late-neg-projection chaperone-or-impersonate-hash) ctc)
(define dom-ctc (base-hash/dc-dom ctc))
@ -371,6 +387,7 @@
(build-flat-contract-property
#:name hash/dc-name
#:first-order hash/dc-first-order
#:equivalent hash/dc-equivalent
#:stronger hash/dc-stronger))
(struct chaperone-hash/dc base-hash/dc ()
@ -380,6 +397,7 @@
#:name hash/dc-name
#:first-order hash/dc-first-order
#:stronger hash/dc-stronger
#:equivalent hash/dc-equivalent
#:late-neg-projection (hash/dc-late-neg-projection chaperone-hash)))
(struct impersonator-hash/dc base-hash/dc ()
#:property prop:custom-write custom-write-property-proc
@ -388,6 +406,7 @@
#:name hash/dc-name
#:first-order hash/dc-first-order
#:stronger hash/dc-stronger
#:equivalent hash/dc-equivalent
#:late-neg-projection (hash/dc-late-neg-projection impersonate-hash)))
(define (build-hash/dc dom dep-rng here name-info immutable kind)

73
racket/collects/racket/contract/private/list.rkt
View File

@ -108,6 +108,28 @@
(contract-struct-stronger? (ne->pe-ctc this) tl-ctc))]
[else #f]))
(define (listof-equivalent this that)
(define this-elem (listof-ctc-elem-c this))
(cond
[(listof-ctc? that)
(define that-elem (listof-ctc-elem-c that))
(cond
[(pe-listof-ctc? this) (and (pe-listof-ctc? that)
(contract-struct-equivalent? this-elem that-elem))]
[(im-listof-ctc? this)
(and (im-listof-ctc? that)
(contract-struct-equivalent? this-elem that-elem)
(contract-struct-equivalent? (im-listof-ctc-last-c this)
(im-listof-ctc-last-c that)))]
[else (contract-struct-equivalent? this-elem that-elem)])]
[(the-cons/c? that)
(define hd-ctc (the-cons/c-hd-ctc that))
(define tl-ctc (the-cons/c-tl-ctc that))
(and (ne-listof-ctc? this)
(contract-struct-equivalent? this-elem hd-ctc)
(contract-struct-equivalent? (ne->pe-ctc this) tl-ctc))]
[else #f]))
(define (raise-listof-blame-error blame val empty-ok? neg-party)
(raise-blame-error blame #:missing-party neg-party val
'(expected: "~s" given: "~e")
@ -219,6 +241,7 @@
#:generate listof-generate
#:exercise listof-exercise
#:stronger listof-stronger
#:equivalent listof-equivalent
#:list-contract? (λ (c) (not (im-listof-ctc? c)))))
(define chap-prop
(build-chaperone-contract-property
@ -228,6 +251,7 @@
#:generate listof-generate
#:exercise listof-exercise
#:stronger listof-stronger
#:equivalent listof-equivalent
#:list-contract? (λ (c) (not (im-listof-ctc? c)))))
(define full-prop
(build-contract-property
@ -237,6 +261,7 @@
#:generate listof-generate
#:exercise listof-exercise
#:stronger listof-stronger
#:equivalent listof-equivalent
#:list-contract? (λ (c) (not (im-listof-ctc? c)))))
(struct listof-ctc (elem-c))
@ -382,6 +407,20 @@
(contract-struct-stronger? this-tl that))]
[else #f]))
(define (cons/c-equivalent? this that)
(define this-hd (the-cons/c-hd-ctc this))
(define this-tl (the-cons/c-tl-ctc this))
(cond
[(the-cons/c? that)
(define that-hd (the-cons/c-hd-ctc that))
(define that-tl (the-cons/c-tl-ctc that))
(and (contract-struct-equivalent? this-hd that-hd)
(contract-struct-equivalent? this-tl that-tl))]
[(ne-listof-ctc? that)
(define elem-ctc (listof-ctc-elem-c that))
(and (contract-struct-equivalent? this-hd elem-ctc)
(contract-struct-equivalent? this-tl (ne->pe-ctc that)))]
[else #f]))
(define (cons/c-generate ctc)
(define ctc-car (the-cons/c-hd-ctc ctc))
@ -405,6 +444,7 @@
#:name cons/c-name
#:first-order cons/c-first-order
#:stronger cons/c-stronger?
#:equivalent cons/c-equivalent?
#:generate cons/c-generate
#:list-contract? cons/c-list-contract?))
(define-struct (chaperone-cons/c the-cons/c) ()
@ -415,6 +455,7 @@
#:name cons/c-name
#:first-order cons/c-first-order
#:stronger cons/c-stronger?
#:equivalent cons/c-equivalent?
#:generate cons/c-generate
#:list-contract? cons/c-list-contract?))
(define-struct (impersonator-cons/c the-cons/c) ()
@ -425,6 +466,7 @@
#:name cons/c-name
#:first-order cons/c-first-order
#:stronger cons/c-stronger?
#:equivalent cons/c-equivalent?
#:generate cons/c-generate
#:list-contract? cons/c-list-contract?))
@ -496,6 +538,7 @@
dep-val))))))
(define (cons/dc-stronger? this that) #f)
(define (cons/dc-equivalent? this that) #f)
(define (cons/dc-generate ctc)
(define undep-ctc (the-cons/dc-undep ctc))
@ -526,6 +569,7 @@
#:name cons/dc-name
#:first-order cons/dc-first-order
#:stronger cons/dc-stronger?
#:equivalent cons/dc-equivalent?
#:generate cons/dc-generate))
(struct chaperone-cons/dc the-cons/dc ()
@ -536,6 +580,7 @@
#:name cons/dc-name
#:first-order cons/dc-first-order
#:stronger cons/dc-stronger?
#:equivalent cons/dc-equivalent?
#:generate cons/dc-generate))
(struct impersonator-cons/dc the-cons/dc ()
@ -546,6 +591,7 @@
#:name cons/dc-name
#:first-order cons/dc-first-order
#:stronger cons/dc-stronger?
#:equivalent cons/dc-equivalent?
#:generate cons/dc-generate))
(define-syntax (cons/dc stx)
@ -669,6 +715,13 @@
(contract-struct-stronger? this-s that-elem-ctc)))]
[else #f]))
(define (list/c-equivalent this that)
(cond
[(generic-list/c? that)
(pairwise-equivalent-contracts? (generic-list/c-args this)
(generic-list/c-args that))]
[else #f]))
(struct generic-list/c (args))
(struct flat-list/c generic-list/c ()
@ -680,6 +733,7 @@
#:generate list/c-generate
#:exercise list/c-exercise
#:stronger list/c-stronger
#:equivalent list/c-equivalent
#:late-neg-projection
(λ (c)
(λ (blame)
@ -774,6 +828,7 @@
#:generate list/c-generate
#:exercise list/c-exercise
#:stronger list/c-stronger
#:equivalent list/c-equivalent
#:late-neg-projection list/c-chaperone/other-late-neg-projection
#:list-contract? (λ (c) #t)))
@ -786,6 +841,7 @@
#:generate list/c-generate
#:exercise list/c-exercise
#:stronger list/c-stronger
#:equivalent list/c-equivalent
#:late-neg-projection list/c-chaperone/other-late-neg-projection
#:list-contract? (λ (c) #t)))
@ -882,6 +938,17 @@
(contract-struct-stronger? suf that-elem)))]
[else #f]))
(define (*list/c-equivalent this that)
(define this-prefix (*list-ctc-prefix this))
(define this-suffix (*list-ctc-suffix this))
(cond
[(*list-ctc? that)
(define that-prefix (*list-ctc-prefix that))
(define that-suffix (*list-ctc-suffix that))
(and (contract-struct-equivalent? this-prefix that-prefix)
(pairwise-equivalent-contracts? this-suffix that-suffix))]
[else #f]))
(define (*list/c-late-neg-projection ctc start-index flat?)
(define prefix-lnp (contract-late-neg-projection (*list-ctc-prefix ctc)))
(define suffix-lnps (map contract-late-neg-projection (*list-ctc-suffix ctc)))
@ -959,6 +1026,7 @@
#:generate *list/c-generate
#:exercise *list/c-exercise
#:stronger *list/c-stronger
#:equivalent *list/c-equivalent
#:late-neg-projection (λ (ctc) (*list/c-late-neg-projection ctc #f #t))
#:list-contract? (λ (c) #t)))
(struct chaperone-*list/c *list-ctc ()
@ -969,6 +1037,7 @@
#:generate *list/c-generate
#:exercise *list/c-exercise
#:stronger *list/c-stronger
#:equivalent *list/c-equivalent
#:late-neg-projection (λ (ctc) (*list/c-late-neg-projection ctc #f #f))
#:list-contract? (λ (c) #t)))
(struct impersonator-*list/c *list-ctc ()
@ -979,6 +1048,7 @@
#:generate *list/c-generate
#:exercise *list/c-exercise
#:stronger *list/c-stronger
#:equivalent *list/c-equivalent
#:late-neg-projection (λ (ctc) (*list/c-late-neg-projection ctc #f #f))
#:list-contract? (λ (c) #t)))
@ -1022,6 +1092,7 @@
#:generate *list/c-generate
#:exercise *list/c-exercise
#:stronger *list/c-stronger
#:equivalent *list/c-equivalent
#:late-neg-projection
(λ (ctc) (*list/c-late-neg-projection ctc (ellipsis-rest-arg-ctc-start-index ctc) #t))
#:list-contract? (λ (c) #t)))
@ -1033,6 +1104,7 @@
#:generate *list/c-generate
#:exercise *list/c-exercise
#:stronger *list/c-stronger
#:equivalent *list/c-equivalent
#:late-neg-projection
(λ (ctc) (*list/c-late-neg-projection ctc (ellipsis-rest-arg-ctc-start-index ctc) #f))
#:list-contract? (λ (c) #t)))
@ -1044,6 +1116,7 @@
#:generate *list/c-generate
#:exercise *list/c-exercise
#:stronger *list/c-stronger
#:equivalent *list/c-equivalent
#:late-neg-projection
(λ (ctc) (*list/c-late-neg-projection ctc (ellipsis-rest-arg-ctc-start-index ctc) #f))
#:list-contract? (λ (c) #t)))

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

@ -50,6 +50,7 @@
if/c
pairwise-stronger-contracts?
pairwise-equivalent-contracts?
check-two-args
suggest/c
@ -119,6 +120,15 @@
(< that-x this-low))])]
[else #f]))
(define (between/c-equivalent this that)
(define this-low (between/c-s-low this))
(define this-high (between/c-s-high this))
(cond
[(between/c-s? that)
(and (= (between/c-s-low that) this-low)
(= this-high (between/c-s-high that)))]
[else #f]))
(define (between/c-first-order ctc)
(define n (between/c-s-low ctc))
(define m (between/c-s-high ctc))
@ -193,6 +203,7 @@
[(= n m) `(=/c ,n)]
[else ])]))
#:stronger between/c-stronger
#:equivalent between/c-equivalent
#:first-order between/c-first-order
#:generate between/c-generate))
(define-struct (renamed-between/c between/c-s) (name))
@ -253,7 +264,8 @@
[1/10 (-/+ x 0.01)]
[4/10 (-/+ x (random))]
[else (-/+ x (random 4294967087))]))))
#:stronger </>-ctc-stronger))
#:stronger </>-ctc-stronger
#:equivalent </>-ctc-equivalent))
(define (</>-ctc-stronger this that)
(define this-x (</>-ctc-x this))
@ -274,6 +286,17 @@
(and (= (between/c-s-high that) +inf.0)
(<= (between/c-s-low that) this-x))])]))
(define (</>-ctc-equivalent this that)
(define this-x (</>-ctc-x this))
(cond
[(</>-ctc? that)
(cond
[(and (<-ctc? this) (<-ctc? that))
(= this-x (</>-ctc-x that))]
[(and (>-ctc? this) (>-ctc? that))
(= this-x (</>-ctc-x that))]
[else #f])]
[else #f]))
(struct </>-ctc (x))
(struct <-ctc </>-ctc ()
@ -331,6 +354,10 @@
(and (syntax-ctc? that)
(contract-struct-stronger? (syntax-ctc-ctc this)
(syntax-ctc-ctc that))))
#:equivalent (λ (this that)
(and (syntax-ctc? that)
(contract-struct-equivalent? (syntax-ctc-ctc this)
(syntax-ctc-ctc that))))
#:first-order (λ (ctc)
(define ? (flat-contract-predicate (syntax-ctc-ctc ctc)))
(λ (v)
@ -406,6 +433,11 @@
(contract-struct-stronger? (promise-base-ctc-ctc this)
(promise-base-ctc-ctc that))))
(define (promise-ctc-equivalent? this that)
(and (promise-base-ctc? that)
(contract-struct-equivalent? (promise-base-ctc-ctc this)
(promise-base-ctc-ctc that))))
(struct promise-base-ctc (ctc))
(struct chaperone-promise-ctc promise-base-ctc ()
#:property prop:custom-write custom-write-property-proc
@ -414,6 +446,7 @@
#:name promise-contract-name
#:late-neg-projection promise-contract-late-neg-proj
#:stronger promise-ctc-stronger?
#:equivalent promise-ctc-equivalent?
#:first-order (λ (ctc) promise?)))
(struct promise-ctc promise-base-ctc ()
#:property prop:custom-write custom-write-property-proc
@ -422,6 +455,7 @@
#:name promise-contract-name
#:late-neg-projection promise-contract-late-neg-proj
#:stronger promise-ctc-stronger?
#:equivalent promise-ctc-equivalent?
#:first-order (λ (ctc) promise?)))
;; (parameter/c in/out-ctc)
@ -488,16 +522,26 @@
(and (contract-struct-stronger? (parameter/c-out this)
(parameter/c-out that))
(contract-struct-stronger? (parameter/c-in that)
(parameter/c-in this)))))
#:equivalent
(λ (this that)
(and (parameter/c? that)
(and (contract-struct-equivalent? (parameter/c-out this)
(parameter/c-out that))
(contract-struct-equivalent? (parameter/c-in that)
(parameter/c-in this)))))))
(define (procedure-arity-includes-equivalent? this that)
(and (procedure-arity-includes/c? that)
(= (procedure-arity-includes/c-n this)
(procedure-arity-includes/c-n that))))
(define-struct procedure-arity-includes/c (n)
#:property prop:custom-write custom-write-property-proc
#:omit-define-syntaxes
#:property prop:flat-contract
(build-flat-contract-property
#:stronger (λ (this that) (and (procedure-arity-includes/c? that)
(= (procedure-arity-includes/c-n this)
(procedure-arity-includes/c-n that))))
#:stronger procedure-arity-includes-equivalent?
#:equivalent procedure-arity-includes-equivalent?
#:name (λ (ctc) `(procedure-arity-includes/c ,(procedure-arity-includes/c-n ctc)))
#:first-order (λ (ctc)
(define n (procedure-arity-includes/c-n ctc))
@ -557,6 +601,7 @@
(build-flat-contract-property
#:late-neg-projection (λ (ctc) any/c-blame->neg-party-fn)
#:stronger (λ (this that) (any/c? that))
#:equivalent (λ (this that) (any/c? that))
#:name (λ (ctc) 'any/c)
#:generate (λ (ctc)
(λ (fuel)
@ -584,6 +629,7 @@
(build-flat-contract-property
#:late-neg-projection none-curried-late-neg-proj
#:stronger (λ (this that) #t)
#:equivalent (λ (this that) (none/c? that))
#:name (λ (ctc) (none/c-name ctc))
#:first-order (λ (ctc) (λ (val) #f))))
@ -666,10 +712,19 @@
(define (prompt-tag/c-stronger? this that)
(and (base-prompt-tag/c? that)
(andmap (λ (this that) (contract-struct-stronger? this that))
(pairwise-stronger-contracts?
(base-prompt-tag/c-ctcs this)
(base-prompt-tag/c-ctcs that))
(andmap (λ (this that) (contract-struct-stronger? this that))
(pairwise-stronger-contracts?
(base-prompt-tag/c-call/ccs this)
(base-prompt-tag/c-call/ccs that))))
(define (prompt-tag/c-equivalent? this that)
(and (base-prompt-tag/c? that)
(pairwise-equivalent-contracts?
(base-prompt-tag/c-ctcs this)
(base-prompt-tag/c-ctcs that))
(pairwise-equivalent-contracts?
(base-prompt-tag/c-call/ccs this)
(base-prompt-tag/c-call/ccs that))))
@ -683,6 +738,7 @@
#:late-neg-projection (prompt-tag/c-late-neg-proj #t)
#:first-order (λ (ctc) continuation-prompt-tag?)
#:stronger prompt-tag/c-stronger?
#:equivalent prompt-tag/c-equivalent?
#:name prompt-tag/c-name))
(define-struct (impersonator-prompt-tag/c base-prompt-tag/c) ()
@ -692,6 +748,7 @@
#:late-neg-projection (prompt-tag/c-late-neg-proj #f)
#:first-order (λ (ctc) continuation-prompt-tag?)
#:stronger prompt-tag/c-stronger?
#:equivalent prompt-tag/c-equivalent?
#:name prompt-tag/c-name))
@ -743,6 +800,12 @@
(base-continuation-mark-key/c-ctc this)
(base-continuation-mark-key/c-ctc that))))
(define (continuation-mark-key/c-equivalent? this that)
(and (base-continuation-mark-key/c? that)
(contract-struct-equivalent?
(base-continuation-mark-key/c-ctc this)
(base-continuation-mark-key/c-ctc that))))
(define-struct base-continuation-mark-key/c (ctc))
(define-struct (chaperone-continuation-mark-key/c
@ -754,6 +817,7 @@
#:late-neg-projection (continuation-mark-key/c-late-neg-proj chaperone-continuation-mark-key)
#:first-order (λ (ctc) continuation-mark-key?)
#:stronger continuation-mark-key/c-stronger?
#:equivalent continuation-mark-key/c-equivalent?
#:name continuation-mark-key/c-name))
(define-struct (impersonator-continuation-mark-key/c
@ -765,6 +829,7 @@
#:late-neg-projection (continuation-mark-key/c-late-neg-proj impersonate-continuation-mark-key)
#:first-order (λ (ctc) continuation-mark-key?)
#:stronger continuation-mark-key/c-stronger?
#:equivalent continuation-mark-key/c-equivalent?
#:name continuation-mark-key/c-name))
;; evt/c : Contract * -> Contract
@ -823,9 +888,20 @@
;; evt/c-stronger? : Contract Contract -> Boolean
(define (evt/c-stronger? this that)
(cond
[(chaperone-evt/c? that)
(define this-ctcs (chaperone-evt/c-ctcs this))
(define that-ctcs (chaperone-evt/c-ctcs that))
(pairwise-stronger-contracts? this-ctcs that-ctcs))
(pairwise-stronger-contracts? this-ctcs that-ctcs)]
[else #f]))
(define (evt/c-equivalent? this that)
(cond
[(chaperone-evt/c? that)
(define this-ctcs (chaperone-evt/c-ctcs this))
(define that-ctcs (chaperone-evt/c-ctcs that))
(pairwise-equivalent-contracts? this-ctcs that-ctcs)]
[else #f]))
;; ctcs - Listof<Contract>
(define-struct chaperone-evt/c (ctcs)
@ -834,6 +910,7 @@
#:late-neg-projection evt/c-proj
#:first-order evt/c-first-order
#:stronger evt/c-stronger?
#:equivalent evt/c-equivalent?
#:name evt/c-name))
;; channel/c
@ -891,6 +968,12 @@
(base-channel/c-ctc this)
(base-channel/c-ctc that))))
(define (channel/c-equivalent? this that)
(and (base-channel/c? that)
(contract-struct-equivalent?
(base-channel/c-ctc this)
(base-channel/c-ctc that))))
(define-struct base-channel/c (ctc))
(define-struct (chaperone-channel/c base-channel/c)
@ -901,6 +984,7 @@
#:late-neg-projection (channel/c-late-neg-proj chaperone-channel)
#:first-order channel/c-first-order
#:stronger channel/c-stronger?
#:equivalent channel/c-equivalent?
#:name channel/c-name))
(define-struct (impersonator-channel/c base-channel/c)
@ -911,6 +995,7 @@
#:late-neg-projection (channel/c-late-neg-proj impersonate-channel)
#:first-order channel/c-first-order
#:stronger channel/c-stronger?
#:equivalent channel/c-equivalent?
#:name channel/c-name))
@ -980,12 +1065,15 @@
(if (flat-contract? ctc)
(flat-named-contract name (flat-contract-predicate ctc))
(let* ([make-contract (if (chaperone-contract? ctc) make-chaperone-contract make-contract)])
(define (stronger? this other)
(define (rename-contract-stronger? this other)
(contract-struct-stronger? ctc other))
(define (rename-contract-equivalent? this other)
(contract-struct-equivalent? ctc other))
(make-contract #:name name
#:late-neg-projection (get/build-late-neg-projection ctc)
#:first-order (contract-first-order ctc)
#:stronger stronger?
#:stronger rename-contract-stronger?
#:equivalent rename-contract-equivalent?
#:list-contract? (list-contract? ctc))))))
(define (if/c predicate then/c else/c)
@ -1063,6 +1151,16 @@
(loop (cdr c1s) (cdr c2s)))]
[else #f])))
(define (pairwise-equivalent-contracts? c1s c2s)
(let loop ([c1s c1s]
[c2s c2s])
(cond
[(and (null? c1s) (null? c2s)) #t]
[(and (pair? c1s) (pair? c2s))
(and (contract-struct-equivalent? (car c1s) (car c2s))
(loop (cdr c1s) (cdr c2s)))]
[else #f])))
(define (suggest/c _ctc field message)
(define ctc (coerce-contract 'suggest/c _ctc))
(unless (string? field)
@ -1083,7 +1181,8 @@
#:name (contract-name ctc)
#:first-order (contract-first-order ctc)
#:late-neg-projection (λ (b) (ctc-lnp (blame-add-extra-field b field message)))
#:stronger (λ (this that) (contract-stronger? ctc that))
#:stronger (λ (this that) (contract-struct-stronger? ctc that))
#:equivalent (λ (this that) (contract-struct-equivalent? ctc that))
#:list-contract? (list-contract? ctc)))
(define (flat-contract-with-explanation ? #:name [name (object-name ?)])

11
racket/collects/racket/contract/private/object.rkt
View File

@ -128,6 +128,9 @@
[(subclass/c? that)
(subclass? (subclass/c-% this) (subclass/c-% that))]
[else #f]))
#:equivalent (λ (this that)
(and (subclass/c? that)
(equal? (subclass/c-% this) (subclass/c-% that))))
#:name (λ (ctc) `(subclass?/c ,(or (object-name (subclass/c-% ctc)) 'unknown%)))))
(define (subclass?/c %)
(unless (class? %)
@ -145,6 +148,10 @@
(interface-extension? (implementation/c-<%> this)
(implementation/c-<%> that))]
[else #f]))
#:equivalent (λ (this that)
(and (implementation/c? that)
(equal? (implementation/c-<%> this)
(implementation/c-<%> that))))
#:name (λ (ctc) `(implementation?/c ,(or (object-name (implementation/c-<%> ctc)) 'unknown<%>)))))
(define (implementation?/c <%>)
@ -185,6 +192,10 @@
(interface-extension? this-<%> that-<%>)]
[else #f])]
[else #f]))
#:equivalent
(λ (this that)
(and (is-a?-ctc? that)
(equal? (is-a?-ctc-<%> this) (is-a?-ctc-<%> that))))
#:name
(λ (ctc)
(define <%> (is-a?-ctc-<%> ctc))

42
racket/collects/racket/contract/private/orc.rkt
View File

@ -110,6 +110,14 @@
(single-or/c-flat-ctcs that)))
(generic-or/c-stronger? this that)))
(define (single-or/c-equivalent? this that)
(or (and (single-or/c? that)
(contract-struct-equivalent? (single-or/c-ho-ctc this)
(single-or/c-ho-ctc that))
(pairwise-equivalent-contracts? (single-or/c-flat-ctcs this)
(single-or/c-flat-ctcs that)))
(generic-or/c-equivalent? this that)))
(define (generic-or/c-stronger? this that)
(define this-sub-ctcs (or/c-sub-contracts this))
(define that-sub-ctcs (or/c-sub-contracts that))
@ -119,6 +127,15 @@
(for/or ([that-sub-ctc (in-list that-sub-ctcs)])
(contract-struct-stronger? this-sub-ctc that-sub-ctc)))))
(define (generic-or/c-equivalent? this that)
(define this-sub-ctcs (or/c-sub-contracts this))
(define that-sub-ctcs (or/c-sub-contracts that))
(and this-sub-ctcs
that-sub-ctcs
(pairwise-equivalent-contracts?
(sort this-sub-ctcs < #:key (λ (x) (equal-hash-code (contract-name x))))
(sort that-sub-ctcs < #:key (λ (x) (equal-hash-code (contract-name x)))))))
(define (or/c-sub-contracts ctc)
(cond
[(single-or/c? ctc)
@ -215,6 +232,7 @@
#:name single-or/c-name
#:first-order single-or/c-first-order
#:stronger single-or/c-stronger?
#:equivalent single-or/c-equivalent?
#:generate (λ (ctc) (or/c-generate ctc
(cons (single-or/c-ho-ctc ctc)
(single-or/c-flat-ctcs ctc))))
@ -229,6 +247,7 @@
#:name single-or/c-name
#:first-order single-or/c-first-order
#:stronger single-or/c-stronger?
#:equivalent single-or/c-equivalent?
#:generate (λ (ctc) (or/c-generate ctc
(cons (single-or/c-ho-ctc ctc)
(single-or/c-flat-ctcs ctc))))
@ -316,6 +335,14 @@
(multi-or/c-flat-ctcs that)))
(generic-or/c-stronger? this that)))
(define (multi-or/c-equivalent? this that)
(or (and (multi-or/c? that)
(pairwise-equivalent-contracts? (multi-or/c-ho-ctcs this)
(multi-or/c-ho-ctcs that))
(pairwise-equivalent-contracts? (multi-or/c-flat-ctcs this)
(multi-or/c-flat-ctcs that)))
(generic-or/c-equivalent? this that)))
(define (mult-or/c-list-contract? c)
(and (for/and ([c (in-list (multi-or/c-flat-ctcs c))])
(list-contract? c))
@ -335,6 +362,7 @@
#:name multi-or/c-name
#:first-order multi-or/c-first-order
#:stronger multi-or/c-stronger?
#:equivalent multi-or/c-equivalent?
#:generate (λ (ctc) (or/c-generate ctc
(append (multi-or/c-ho-ctcs ctc)
(multi-or/c-flat-ctcs ctc))))
@ -349,6 +377,7 @@
#:name multi-or/c-name
#:first-order multi-or/c-first-order
#:stronger multi-or/c-stronger?
#:equivalent multi-or/c-equivalent?
#:generate (λ (ctc) (or/c-generate ctc
(append (multi-or/c-ho-ctcs ctc)
(multi-or/c-flat-ctcs ctc))))
@ -394,7 +423,7 @@
#f))]
[else #f])))
(generic-or/c-stronger? this that)))
#:equivalent generic-or/c-equivalent?
#:first-order
(λ (ctc) (flat-or/c-pred ctc))
@ -470,6 +499,7 @@
#:name first-or/c-name
#:first-order first-or/c-first-order
#:stronger multi-or/c-stronger?
#:equivalent multi-or/c-equivalent?
#:generate (λ (ctc) (or/c-generate ctc (base-first-or/c-ctcs ctc)))
#:exercise (λ (ctc) (or/c-exercise (base-first-or/c-ctcs ctc)))
#:list-contract? first-or/c-list-contract?))
@ -480,6 +510,7 @@
#:name first-or/c-name
#:first-order first-or/c-first-order
#:stronger generic-or/c-stronger?
#:equivalent generic-or/c-equivalent?
#:generate (λ (ctc) (or/c-generate ctc (base-first-or/c-ctcs ctc)))
#:exercise (λ (ctc) (or/c-exercise (base-first-or/c-ctcs ctc)))
#:list-contract? first-or/c-list-contract?))
@ -526,6 +557,15 @@
(parameterize ([recur? #f])
(contract-struct-stronger? (get-flat-rec-me this) that))]
[else #f])))
#:equivalent
(let ([recur? (make-parameter #t)])
(λ (this that)
(cond
[(equal? this that) #t]
[(recur?)
(parameterize ([recur? #f])
(contract-struct-equivalent? (get-flat-rec-me this) that))]
[else #f])))
#:first-order
(λ (ctc)
(λ (v)

19
racket/collects/racket/contract/private/parametric.rkt
View File

@ -53,6 +53,24 @@
(apply (polymorphic-contract-body that) instances))]
[else #f])]
[else #f]))
#:equivalent
(λ (this that)
(cond
[(polymorphic-contract? that)
(define this-vars (polymorphic-contract-vars this))
(define that-vars (polymorphic-contract-vars that))
(define this-barrier/c (polymorphic-contract-barrier this))
(define that-barrier/c (polymorphic-contract-barrier that))
(cond
[(and (eq? this-barrier/c that-barrier/c)
(= (length this-vars) (length that-vars)))
(define instances
(for/list ([var (in-list this-vars)])
(this-barrier/c #t var)))
(contract-struct-equivalent? (apply (polymorphic-contract-body this) instances)
(apply (polymorphic-contract-body that) instances))]
[else #f])]
[else #f]))
#:late-neg-projection
(lambda (c)
(lambda (orig-blame)
@ -104,6 +122,7 @@
#:name (lambda (c) (barrier-contract-name c))
#:first-order (λ (c) (barrier-contract-pred c))
#:stronger (λ (this that) (eq? this that))
#:equivalent (λ (this that) (eq? this that))
#:late-neg-projection
(lambda (c)
(define mk (barrier-contract-make c))

72
racket/collects/racket/contract/private/prop.rkt
View File

@ -12,6 +12,7 @@
contract-struct-val-first-projection
contract-struct-late-neg-projection
contract-struct-stronger?
contract-struct-equivalent?
contract-struct-generate
contract-struct-exercise
contract-struct-list-contract?
@ -62,6 +63,7 @@
first-order
projection
stronger
equivalent
generate
exercise
val-first-projection
@ -111,8 +113,12 @@
(and get-projection
(get-projection c)))
(define trail (make-parameter #f))
(define (contract-struct-stronger? a b)
(define (contract-struct-stronger/equivalent?
a b
trail
contract-property-stronger/equivalent
special-or/c-any/c-handling?)
(let loop ([a a][b b])
(cond
[(and (or (flat-contract-struct? a)
(chaperone-contract-struct? a))
@ -120,12 +126,16 @@
#t]
[else
(define prop (contract-struct-property a))
(define stronger? (contract-property-stronger prop))
(define stronger/equivalent? (contract-property-stronger/equivalent prop))
(cond
[(stronger? a b)
[(stronger/equivalent? a b)
;; optimistically try skip some of the more complex work below
#t]
[(and (flat-contract-struct? a) (prop:any/c? b)) #t] ;; is the flat-check needed here?
[(and special-or/c-any/c-handling?
(flat-contract-struct? a)
(prop:any/c? b))
;; is the flat-check needed here?
#t]
[(let ([th (trail)])
(and th
(for/or ([(a2 bs-h) (in-hash th)])
@ -144,27 +154,45 @@
(define a-h (make-hasheq))
(hash-set! trail-h a a-h)
(hash-set! a-h b #t)]))
(contract-struct-stronger? (if (prop:recursive-contract? a)
(loop (if (prop:recursive-contract? a)
((prop:recursive-contract-unroll a) a)
a)
(if (prop:recursive-contract? b)
((prop:recursive-contract-unroll b) b)
b)))]
[else
[special-or/c-any/c-handling?
;; the 'later?' flag avoids checking
;; (stronger? a b) in the first iteration,
;; since it was checked in the "optimistically"
;; branch above
(let loop ([b b] [later? #f])
(cond
[(and later? (stronger? a b))
[(and later? (stronger/equivalent? a b))
#t]
[(prop:orc-contract? b)
(define sub-contracts ((prop:orc-contract-get-subcontracts b) b))
(for/or ([sub-contract (in-list sub-contracts)])
(loop sub-contract #t))]
[else
#f]))])]))
#f]))]
[else #f])])))
(define stronger-trail (make-parameter #f))
(define (contract-struct-stronger? a b)
(contract-struct-stronger/equivalent?
a b
stronger-trail
contract-property-stronger
#t))
(define equivalent-trail (make-parameter #f))
(define (contract-struct-equivalent? a b)
(contract-struct-stronger/equivalent?
a b
equivalent-trail
contract-property-equivalent
#f))
(define (contract-struct-generate c)
(define prop (contract-struct-property c))
@ -262,13 +290,14 @@
(define-logger racket/contract)
(define ((build-property mk default-name proc-name first-order?)
(define ((build-property mk default-name proc-name first-order? equivalent-equal?)
#:name [get-name #f]
#:first-order [get-first-order #f]
#:projection [get-projection #f]
#:val-first-projection [get-val-first-projection #f]
#:late-neg-projection [get-late-neg-projection #f]
#:stronger [stronger #f]
#:equivalent [equivalent #f]
#:generate [generate (λ (ctc) (λ (fuel) #f))]
#:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))]
#:list-contract? [list-contract? (λ (c) #f)])
@ -304,6 +333,7 @@
(or get-first-order get-any?)
get-projection
(or stronger weakest)
(or equivalent (if equivalent-equal? equal? weakest))
generate exercise
get-val-first-projection
(cond
@ -325,13 +355,13 @@
(define build-contract-property
(procedure-rename
(build-property make-contract-property 'anonymous-contract 'build-contract-property #f)
(build-property make-contract-property 'anonymous-contract 'build-contract-property #f #f)
'build-contract-property))
(define build-flat-contract-property
(procedure-rename
(build-property (compose make-flat-contract-property make-contract-property)
'anonymous-flat-contract 'build-flat-contract-property #t)
'anonymous-flat-contract 'build-flat-contract-property #t #t)
'build-flat-contract-property))
(define (blame-context-projection-wrapper proj)
@ -343,7 +373,7 @@
(define build-chaperone-contract-property
(procedure-rename
(build-property (compose make-chaperone-contract-property make-contract-property)
'anonymous-chaperone-contract 'build-chaperone-contract-property #f)
'anonymous-chaperone-contract 'build-chaperone-contract-property #f #t)
'build-chaperone-contract-property))
(define (get-any? c) any?)
@ -383,7 +413,7 @@
(define-struct make-contract [ name first-order projection
val-first-projection late-neg-projection
stronger generate exercise list-contract? ]
stronger equivalent generate exercise list-contract? ]
#:omit-define-syntaxes
#:property prop:custom-write
(λ (stct port display?)
@ -404,7 +434,7 @@
(define-struct make-chaperone-contract [ name first-order projection
val-first-projection late-neg-projection
stronger generate exercise list-contract? ]
stronger equivalent generate exercise list-contract? ]
#:omit-define-syntaxes
#:property prop:custom-write
(λ (stct port display?)
@ -425,7 +455,7 @@
(define-struct make-flat-contract [ name first-order projection
val-first-projection late-neg-projection
stronger generate exercise list-contract? ]
stronger equivalent generate exercise list-contract? ]
#:omit-define-syntaxes
#:property prop:custom-write
(λ (stct port display?)
@ -444,13 +474,14 @@
#:exercise (lambda (c) (make-flat-contract-exercise c))
#:list-contract? (λ (c) (make-flat-contract-list-contract? c))))
(define ((build-contract mk default-name proc-name first-order?)
(define ((build-contract mk default-name proc-name first-order? equivalent-equal?)
#:name [name #f]
#:first-order [first-order #f]
#:projection [projection #f]
#:val-first-projection [val-first-projection #f]
#:late-neg-projection [late-neg-projection #f]
#:stronger [stronger #f]
#:equivalent [equivalent #f]
#:generate [generate (λ (ctc) (λ (fuel) #f))]
#:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))]
#:list-contract? [list-contract? #f])
@ -485,6 +516,7 @@
[else #f])]
[else late-neg-projection])
(or stronger weakest)
(or equivalent (if equivalent-equal? equal? weakest))
generate exercise
(and list-contract? #t)))
@ -502,7 +534,7 @@
(define make-contract
(procedure-rename
(build-contract make-make-contract 'anonymous-contract 'make-contract #f)
(build-contract make-make-contract 'anonymous-contract 'make-contract #f #f)
'make-contract))
(define make-chaperone-contract
@ -510,7 +542,7 @@
(build-contract make-make-chaperone-contract
'anonymous-chaperone-contract
'make-chaperone-contract
#f)
#f #t)
'make-chaperone-contract))
(define make-flat-contract
@ -518,7 +550,7 @@
(build-contract make-make-flat-contract
'anonymous-flat-contract
'make-flat-contract
#t)
#t #t)
'make-flat-contract))
;; property should be bound to a function that accepts the contract and

42
racket/collects/racket/contract/private/struct-dc.rkt
View File

@ -673,7 +673,44 @@
(procedure-closure-contents-eq?
(dep-dep-proc this-subcontract)
(dep-dep-proc that-subcontract)))]
[else #t]))))
[else #f]))))
(define (struct/dc-equivalent? this that)
(and (base-struct/dc? that)
(eq? (base-struct/dc-pred this) (base-struct/dc-pred that))
(let ([this-inv (get-invariant this)]
[that-inv (get-invariant that)])
(cond
[(and (not this-inv) (not that-inv)) #t]
[(and this-inv that-inv)
(procedure-closure-contents-eq? (invariant-dep-proc this-inv)
(invariant-dep-proc that-inv))]
[else #f]))
(for/and ([this-subcontract (in-list (base-struct/dc-subcontracts this))]
[that-subcontract (in-list (base-struct/dc-subcontracts that))])
(cond
[(and (indep? this-subcontract)
(indep? that-subcontract))
(and (or (and (mutable? this-subcontract)
(mutable? that-subcontract))
(and (immutable? this-subcontract)
(immutable? that-subcontract))
(and (lazy-immutable? this-subcontract)
(lazy-immutable? that-subcontract)))
(contract-struct-equivalent? (indep-ctc this-subcontract)
(indep-ctc that-subcontract)))]
[(and (dep? this-subcontract)
(dep? that-subcontract))
(and (or (and (dep-mutable? this-subcontract)
(dep-mutable? that-subcontract))
(and (dep-immutable? this-subcontract)
(dep-immutable? that-subcontract))
(and (dep-lazy-immutable? this-subcontract)
(dep-lazy-immutable? that-subcontract)))
(procedure-closure-contents-eq?
(dep-dep-proc this-subcontract)
(dep-dep-proc that-subcontract)))]
[else #f]))))
(define (get-invariant sc)
(for/or ([sub (base-struct/dc-subcontracts sc)]
@ -700,6 +737,7 @@
#:first-order struct/dc-first-order
#:late-neg-projection struct/dc-late-neg-proj
#:stronger struct/dc-stronger?
#:equivalent struct/dc-equivalent?
#:generate struct/dc-generate
#:exercise struct/dc-exercise))
@ -710,6 +748,7 @@
#:first-order struct/dc-flat-first-order
#:late-neg-projection struct/dc-late-neg-proj
#:stronger struct/dc-stronger?
#:equivalent struct/dc-equivalent?
#:generate struct/dc-generate
#:exercise struct/dc-exercise))
@ -720,6 +759,7 @@
#:first-order struct/dc-first-order
#:late-neg-projection struct/dc-late-neg-proj
#:stronger struct/dc-stronger?
#:equivalent struct/dc-equivalent?
#:generate struct/dc-generate
#:exercise struct/dc-exercise))

25
racket/collects/racket/contract/private/vector.rkt
View File

@ -126,6 +126,15 @@
(contract-struct-stronger? that-elem this-elem))])]
[else #f]))
(define (vectorof-equivalent this that)
(cond
[(base-vectorof? that)
(and (equal? (base-vectorof-immutable this)
(base-vectorof-immutable that))
(contract-struct-equivalent? (base-vectorof-elem this)
(base-vectorof-elem that)))]
[else #f]))
(define-struct (flat-vectorof base-vectorof) ()
#:property prop:custom-write custom-write-property-proc
#:property prop:flat-contract
@ -143,6 +152,7 @@
(for ([x (in-vector val)])
(vfp+blame x neg-party))
val)))
#:equivalent vectorof-equivalent
#:stronger vectorof-stronger))
(define (blame-add-element-of-context blame #:swap? [swap? #f])
@ -258,6 +268,7 @@
(build-chaperone-contract-property
#:name vectorof-name
#:first-order vectorof-first-order
#:equivalent vectorof-equivalent
#:stronger vectorof-stronger
#:late-neg-projection (vectorof-late-neg-ho-projection chaperone-vector)))
@ -267,6 +278,7 @@
(build-contract-property
#:name vectorof-name
#:first-order vectorof-first-order
#:equivalent vectorof-equivalent
#:stronger vectorof-stronger
#:late-neg-projection (vectorof-late-neg-ho-projection impersonate-vector)))
@ -375,7 +387,6 @@
(contract-first-order-passes? c e)))))
(define (vector/c-stronger this that)
;(define-struct base-vector/c (elems immutable))
(define this-elems (base-vector/c-elems this))
(define this-immutable (base-vector/c-immutable this))
(cond
@ -413,6 +424,15 @@
[else #f])]
[else #f]))
(define (vector/c-equivalent this that)
(cond
[(base-vector/c? that)
(and (equal? (base-vector/c-immutable this)
(base-vector/c-immutable that))
(pairwise-equivalent-contracts? (base-vector/c-elems this)
(base-vector/c-elems that)))]
[else #f]))
(define-struct (flat-vector/c base-vector/c) ()
#:property prop:custom-write custom-write-property-proc
#:property prop:flat-contract
@ -420,6 +440,7 @@
#:name vector/c-name
#:first-order vector/c-first-order
#:stronger vector/c-stronger
#:equivalent vector/c-equivalent
#:late-neg-projection
(λ (ctc)
(λ (blame)
@ -512,6 +533,7 @@
#:name vector/c-name
#:first-order vector/c-first-order
#:stronger vector/c-stronger
#:equivalent vector/c-equivalent
#:late-neg-projection (vector/c-ho-late-neg-projection chaperone-vector)))
(define-struct (impersonator-vector/c base-vector/c) ()
@ -521,6 +543,7 @@
#:name vector/c-name
#:first-order vector/c-first-order
#:stronger vector/c-stronger
#:equivalent vector/c-equivalent
#:late-neg-projection (vector/c-ho-late-neg-projection impersonate-vector)))
(define-syntax (wrap-vector/c stx)

84
racket/collects/racket/private/class-c-old.rkt
View File

@ -940,10 +940,7 @@
(check-one-stronger class/c-inits class/c-init-contracts this that)
;; check both ways for fields (since mutable)
(limit-depth
(and (check-one-stronger class/c-fields class/c-field-contracts this that)
(check-one-stronger class/c-fields class/c-field-contracts that this)))
(check-one-equivalent class/c-fields class/c-field-contracts this that)
;; inherits
(check-one-stronger internal-class/c-inherits internal-class/c-inherit-contracts
@ -974,6 +971,36 @@
(all-included? (class/c-absents that) (class/c-absents this)))]
[else #f]))
(define (class/c-equivalent this that)
(define this-internal (class/c-internal this))
(cond
[(class/c? that)
(define that-internal (class/c-internal that))
(and
(check-one-equivalent class/c-methods class/c-method-contracts this that)
(check-one-equivalent class/c-inits class/c-init-contracts this that)
(check-one-equivalent class/c-fields class/c-field-contracts this that)
(check-one-equivalent internal-class/c-inherits internal-class/c-inherit-contracts
this-internal that-internal)
(check-one-equivalent internal-class/c-inherit-fields internal-class/c-inherit-field-contracts
this-internal that-internal)
(check-one-equivalent internal-class/c-inherit-fields internal-class/c-inherit-field-contracts
that-internal this-internal)
(check-one-equivalent internal-class/c-supers internal-class/c-super-contracts
this-internal that-internal)
(check-one-equivalent internal-class/c-inners internal-class/c-inner-contracts
this-internal that-internal)
(check-one-equivalent internal-class/c-overrides internal-class/c-override-contracts
this-internal that-internal)
(check-one-equivalent internal-class/c-augments internal-class/c-augment-contracts
this-internal that-internal)
(check-one-equivalent internal-class/c-augrides internal-class/c-augride-contracts
this-internal that-internal)
(equal? (class/c-opaque? this) (class/c-opaque? that))
(equal? (class/c-absent-fields that) (class/c-absent-fields this))
(equal? (class/c-absents that) (class/c-absents this)))]
[else #f]))
(define (all-included? this-items that-items)
(for/and ([this-item (in-list this-items)])
(for/or ([that-item (in-list that-items)])
@ -1039,6 +1066,14 @@
(and (equal? this-name that-name)
(contract-stronger? this-ctc that-ctc)))))
(define (check-one-equivalent names-sel ctcs-sel this that)
(for/and ([this-name (in-list (names-sel this))]
[this-ctc (in-list (ctcs-sel this))])
(for/or ([that-name (in-list (names-sel that))]
[that-ctc (in-list (ctcs-sel that))])
(and (equal? this-name that-name)
(contract-equivalent? this-ctc that-ctc)))))
(define-struct class/c
(methods method-contracts fields field-contracts inits init-contracts
absents absent-fields
@ -1050,6 +1085,7 @@
#:late-neg-projection class/c-late-neg-proj
#:name build-class/c-name
#:stronger class/c-stronger
#:equivalent class/c-equivalent
#:first-order
(λ (ctc)
(λ (cls)
@ -1468,6 +1504,11 @@
(contract-stronger? (base-instanceof/c-class-ctc this)
(base-instanceof/c-class-ctc that))))
(define (instanceof/c-equivalent this that)
(and (base-instanceof/c? that)
(contract-equivalent? (base-instanceof/c-class-ctc this)
(base-instanceof/c-class-ctc that))))
(define-struct base-instanceof/c (class-ctc)
#:property prop:custom-write custom-write-property-proc
#:property prop:contract
@ -1477,6 +1518,7 @@
(λ (ctc)
(build-compound-type-name 'instanceof/c (base-instanceof/c-class-ctc ctc)))
#:first-order instanceof/c-first-order
#:equivalent instanceof/c-equivalent
#:stronger instanceof/c-stronger))
(define/subexpression-pos-prop (instanceof/c cctc)
@ -1550,15 +1592,24 @@
(object/c-width-subtype? this that))]
[else #f]))
(define (object/c-equivalent this that)
(cond
[(base-object/c? that)
(and
(check-one-object/equivalent base-object/c-methods base-object/c-method-contracts this that)
(check-one-object/equivalent base-object/c-fields base-object/c-field-contracts this that)
(equal? (base-object/c-methods that)
(base-object/c-methods this))
(equal? (base-object/c-fields that)
(base-object/c-fields this)))]
[else #f]))
(define (object/c-common-methods-stronger? this that)
(check-one-object base-object/c-methods base-object/c-method-contracts this that))
(define (object/c-common-fields-stronger? this that)
;; check both ways for fields (since mutable)
(limit-depth
(and
(check-one-object base-object/c-fields base-object/c-field-contracts this that)
(check-one-object base-object/c-fields base-object/c-field-contracts that this))))
(check-one-object/equivalent base-object/c-fields base-object/c-field-contracts this that))
;; True if `this` has at least as many field / method names as `that`
(define (object/c-width-subtype? this that)
@ -1585,6 +1636,22 @@
any/c
that-ctc)))))))
(define (check-one-object/equivalent names-sel ctcs-sel this that)
(and (equal? (names-sel this)
(names-sel this))
(for/and ([this-name (in-list (names-sel this))]
[this-ctc (in-list (ctcs-sel this))])
(for/or ([that-name (in-list (names-sel that))]
[that-ctc (in-list (ctcs-sel that))])
(and (equal? this-name that-name)
(contract-equivalent?
(if (just-check-existence? this-ctc)
any/c
this-ctc)
(if (just-check-existence? that-ctc)
any/c
that-ctc)))))))
(define-struct base-object/c (methods method-contracts fields field-contracts)
#:property prop:custom-write custom-write-property-proc
#:property prop:contract
@ -1598,6 +1665,7 @@
(base-object/c-fields ctc)
(base-object/c-field-contracts ctc)))
#:first-order object/c-first-order
#:equivalent object/c-equivalent
#:stronger object/c-stronger))
(define (build-object/c-type-name name method-names method-ctcs field-names field-ctcs)