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 [#:stronger stronger
(or/c #f (-> contract? contract? boolean?)) (or/c #f (-> contract? contract? boolean?))
#f] #f]
[#:equivalent equivalent
(or/c #f (-> contract? contract? boolean?))
#f]
[#:list-contract? is-list-contract? boolean? #f]) [#:list-contract? is-list-contract? boolean? #f])
contract?] contract?]
@defproc[(make-chaperone-contract @defproc[(make-chaperone-contract
@ -2150,6 +2153,9 @@ where the violation was detected.
[#:stronger stronger [#:stronger stronger
(or/c #f (-> contract? contract? boolean?)) (or/c #f (-> contract? contract? boolean?))
#f] #f]
[#:equivalent equivalent
(or/c #f (-> contract? contract? boolean?))
#f]
[#:list-contract? is-list-contract? boolean? #f]) [#:list-contract? is-list-contract? boolean? #f])
chaperone-contract?] chaperone-contract?]
@defproc[(make-flat-contract @defproc[(make-flat-contract
@ -2175,6 +2181,9 @@ where the violation was detected.
[#:stronger stronger [#:stronger stronger
(or/c #f (-> contract? contract? boolean?)) (or/c #f (-> contract? contract? boolean?))
#f] #f]
[#:equivalent equivalent
(or/c #f (-> contract? contract? boolean?))
#f]
[#:list-contract? is-list-contract? boolean? #f]) [#:list-contract? is-list-contract? boolean? #f])
flat-contract?] 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 For @tech{impersonator contracts} constructed with @racket[make-contract] that do not
supply the @racket[stronger] argument, @racket[contract-stronger?] returns @racket[#f]. 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 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. 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 stronger
(or/c (-> contract? contract? boolean?) #f) (or/c (-> contract? contract? boolean?) #f)
#f] #f]
[#:equivalent equivalent
(or/c #f (-> contract? contract? boolean?))
#f]
[#:generate [#:generate
generate generate
(->i ([c contract?]) (->i ([c contract?])
@ -2760,6 +2775,9 @@ returns @racket[#f] but @racket[value-blame] returns @racket[#f].
stronger stronger
(or/c (-> contract? contract? boolean?) #f) (or/c (-> contract? contract? boolean?) #f)
#f] #f]
[#:equivalent equivalent
(or/c #f (-> contract? contract? boolean?))
#f]
[#:generate [#:generate
generate generate
(->i ([c contract?]) (->i ([c contract?])
@ -2813,6 +2831,9 @@ returns @racket[#f] but @racket[value-blame] returns @racket[#f].
stronger stronger
(or/c (-> contract? contract? boolean?) #f) (or/c (-> contract? contract? boolean?) #f)
#f] #f]
[#:equivalent equivalent
(or/c #f (-> contract? contract? boolean?))
#f]
[#:generate [#:generate
generate generate
(->i ([c contract?]) (->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 first argument) is stronger than some other
contract (passed in the second argument) and whose default always contract (passed in the second argument) and whose default always
returns @racket[#f];} 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 @item{@racket[generate], which returns a thunk that generates random values
matching the contract (using @racket[contract-random-generate-fail]) matching the contract (using @racket[contract-random-generate-fail])
to indicate failure) or @racket[#f] to indicate that random to indicate failure) or @racket[#f] to indicate that random
@ -3010,7 +3036,7 @@ are below):
@defproc[(contract-stronger? [c1 contract?] [c2 contract?]) boolean?]{ @defproc[(contract-stronger? [c1 contract?] [c2 contract?]) boolean?]{
Returns @racket[#t] if the contract @racket[c1] accepts either fewer 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 @tech{Chaperone contracts} and @tech{flat contracts} that are the same
(i.e., where @racket[c1] is @racket[equal?] to @racket[c2]) are (i.e., where @racket[c1] is @racket[equal?] to @racket[c2]) are
@ -3029,6 +3055,28 @@ are below):
(λ (x) (and (real? x) (<= x 100))))] (λ (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?] @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 build-compound-type-name
contract-stronger? contract-stronger?
contract-equivalent?
list-contract? list-contract?
contract-first-order 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) (pairwise-stronger-contracts? (base-and/c-ctcs this)
(base-and/c-ctcs that)))) (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) (define (and/c-generate? ctc)
(cond (cond
[(and/c-check-nonneg ctc real?) => values] [(and/c-check-nonneg ctc real?) => values]
@ -147,6 +152,7 @@
#:name and-name #:name and-name
#:first-order and-first-order #:first-order and-first-order
#:stronger and-stronger? #:stronger and-stronger?
#:equivalent and-equivalent?
#:generate and/c-generate?)) #:generate and/c-generate?))
(define-struct (chaperone-and/c base-and/c) () (define-struct (chaperone-and/c base-and/c) ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
@ -156,6 +162,7 @@
#:name and-name #:name and-name
#:first-order and-first-order #:first-order and-first-order
#:stronger and-stronger? #:stronger and-stronger?
#:equivalent and-equivalent?
#:generate and/c-generate?)) #:generate and/c-generate?))
(define-struct (impersonator-and/c base-and/c) () (define-struct (impersonator-and/c base-and/c) ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
@ -165,6 +172,7 @@
#:name and-name #:name and-name
#:first-order and-first-order #:first-order and-first-order
#:stronger and-stronger? #:stronger and-stronger?
#:equivalent and-equivalent?
#:generate and/c-generate?)) #:generate and/c-generate?))
(define-syntax (and/c stx) (define-syntax (and/c stx)
@ -274,15 +282,25 @@
[else exact-integer?])) [else exact-integer?]))
(define (integer-in-stronger this that) (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 (cond
[(integer-in-ctc? that) [(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-start (or (integer-in-ctc-start that) -inf.0))
(define that-end (or (integer-in-ctc-end that) +inf.0)) (define that-end (or (integer-in-ctc-end that) +inf.0))
(<= that-start this-start this-end that-end)] (<= that-start this-start this-end that-end)]
[else #f])) [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 (integer-in-generate ctc)
(define start (integer-in-ctc-start ctc)) (define start (integer-in-ctc-start ctc))
(define end (integer-in-ctc-end ctc)) (define end (integer-in-ctc-end ctc))
@ -311,6 +329,7 @@
#:name integer-in-name #:name integer-in-name
#:first-order integer-in-first-order #:first-order integer-in-first-order
#:stronger integer-in-stronger #:stronger integer-in-stronger
#:equivalent integer-in-equivalent
#:generate integer-in-generate)) #:generate integer-in-generate))
(struct renamed-integer-in integer-in-ctc (name) (struct renamed-integer-in integer-in-ctc (name)
@ -319,6 +338,7 @@
#:name (λ (ctc) (renamed-integer-in-name ctc)) #:name (λ (ctc) (renamed-integer-in-name ctc))
#:first-order integer-in-first-order #:first-order integer-in-first-order
#:stronger integer-in-stronger #:stronger integer-in-stronger
#:equivalent integer-in-equivalent
#:generate integer-in-generate)) #:generate integer-in-generate))
(define (geo-dist p) (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) (if (base-->d-rest-ctc ctc)
(check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds #f #f) (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))))) (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 ;; 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 ;; 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) #:late-neg-projection (late-neg-->d-proj impersonate-procedure)
#:name (->d-name #|print-as-method-if-method?|# #t) #:name (->d-name #|print-as-method-if-method?|# #t)
#:first-order ->d-first-order #: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/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))))) (check-procedure val mtd? mand-args opt-args mand-kwds opt-kwds #f #f)))))
#:exercise exercise->i #:exercise exercise->i
#:equivalent (λ (this that) (eq? this that))
#:stronger (λ (this that) (eq? this that)))) ;; WRONG #:stronger (λ (this that) (eq? this that)))) ;; WRONG
(struct chaperone->i ->i () #:property prop:chaperone-contract (mk-prop #t)) (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) (λ (val)
((cblame val) #f)))) ((cblame val) #f))))
#:stronger ->-stronger #:stronger ->-stronger
#:equivalent ->-equivalent
#:generate ->-generate #:generate ->-generate
#:exercise ->-exercise #:exercise ->-exercise
#:val-first-projection val-first-proj #:val-first-projection val-first-proj
@ -1586,6 +1587,29 @@
(not (base->-post? this)) (not (base->-post? this))
(not (base->-post? that)))) (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->) () (define-struct (-> base->) ()
#:property prop:chaperone-contract (make-property #f)) #: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)))])] ((f blame-known) val neg-party)))])]
[else (recursive-contract-late-neg-projection ctc)])) [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) (define ((recursive-contract-first-order ctc) val)
(cond (cond
@ -288,7 +288,8 @@
#:name recursive-contract-name #:name recursive-contract-name
#:first-order recursive-contract-first-order #:first-order recursive-contract-first-order
#:late-neg-projection flat-recursive-contract-late-neg-projection #: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 #:generate recursive-contract-generate
#:list-contract? recursive-contract-list-contract?)) #:list-contract? recursive-contract-list-contract?))
(struct chaperone-recursive-contract recursive-contract () (struct chaperone-recursive-contract recursive-contract ()
@ -298,7 +299,8 @@
#:name recursive-contract-name #:name recursive-contract-name
#:first-order recursive-contract-first-order #:first-order recursive-contract-first-order
#:late-neg-projection recursive-contract-late-neg-projection #:late-neg-projection recursive-contract-late-neg-projection
#:stronger recursive-contract-stronger #:stronger recursive-contract-equivalent
#:equivalent recursive-contract-equivalent
#:generate recursive-contract-generate #:generate recursive-contract-generate
#:list-contract? recursive-contract-list-contract?)) #:list-contract? recursive-contract-list-contract?))
(struct impersonator-recursive-contract recursive-contract () (struct impersonator-recursive-contract recursive-contract ()
@ -308,6 +310,7 @@
#:name recursive-contract-name #:name recursive-contract-name
#:first-order recursive-contract-first-order #:first-order recursive-contract-first-order
#:late-neg-projection recursive-contract-late-neg-projection #:late-neg-projection recursive-contract-late-neg-projection
#:stronger recursive-contract-stronger #:stronger recursive-contract-equivalent
#:equivalent recursive-contract-equivalent
#:generate recursive-contract-generate #:generate recursive-contract-generate
#:list-contract? recursive-contract-list-contract?)) #:list-contract? recursive-contract-list-contract?))

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

@ -101,11 +101,35 @@
(contract-struct-stronger? this-content-r that-content-r)] (contract-struct-stronger? this-content-r that-content-r)]
[(or (equal? that-immutable 'dont-care) [(or (equal? that-immutable 'dont-care)
(equal? this-immutable that-immutable)) (equal? this-immutable that-immutable))
(and (contract-struct-stronger? this-content-r that-content-r) (if (and (eq? this-content-r this-content-w)
(contract-struct-stronger? that-content-w 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)))]
[else #f])] [else #f])]
[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) () (define-struct (flat-box/c base-box/c) ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
@ -114,6 +138,7 @@
#:name box/c-name #:name box/c-name
#:first-order box/c-first-order #:first-order box/c-first-order
#:stronger box/c-stronger #:stronger box/c-stronger
#:equivalent box/c-equivalent
#:late-neg-projection #:late-neg-projection
(λ (ctc) (λ (ctc)
(define content-ctc (get/build-late-neg-projection (base-box/c-content-w ctc))) (define content-ctc (get/build-late-neg-projection (base-box/c-content-w ctc)))
@ -184,6 +209,7 @@
#:name box/c-name #:name box/c-name
#:first-order box/c-first-order #:first-order box/c-first-order
#:stronger box/c-stronger #:stronger box/c-stronger
#:equivalent box/c-equivalent
#:late-neg-projection (ho-late-neg-projection chaperone-box))) #:late-neg-projection (ho-late-neg-projection chaperone-box)))
(define-struct (impersonator-box/c base-box/c) () (define-struct (impersonator-box/c base-box/c) ()
@ -193,6 +219,7 @@
#:name box/c-name #:name box/c-name
#:first-order box/c-first-order #:first-order box/c-first-order
#:stronger box/c-stronger #:stronger box/c-stronger
#:equivalent box/c-equivalent
#:late-neg-projection (ho-late-neg-projection impersonate-box))) #:late-neg-projection (ho-late-neg-projection impersonate-box)))
(define-syntax (box/c stx) (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)] ...) ctc-field-val)] ...)
(values f-x ...))) (values f-x ...)))
(define (stronger-lazy-contract? a b) (define (stronger/equivalent-lazy-contract?
a b
contract-struct-stronger/equivalent?)
(and (contract-predicate b) (and (contract-predicate b)
(let ([a-sel (contract-get a selector-indices)] (let ([a-sel (contract-get a selector-indices)]
[b-sel (contract-get b selector-indices)]) [b-sel (contract-get b selector-indices)])
(if (contract-struct? a-sel) (if (contract-struct? a-sel)
(if (contract-struct? b-sel) (if (contract-struct? b-sel)
(contract-struct-stronger? a-sel b-sel) (contract-struct-stronger/equivalent? a-sel b-sel)
#f) #f)
(if (contract-struct? b-sel) (if (contract-struct? b-sel)
#f #f
@ -321,7 +323,13 @@ it around flattened out.
#:projection lazy-contract-proj #:projection lazy-contract-proj
#:name lazy-contract-name #:name lazy-contract-name
#:first-order (lambda (ctc) predicate) #: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) (define-values (contract-type contract-maker contract-predicate contract-get contract-set)
(make-struct-type 'the-contract (make-struct-type 'the-contract

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

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

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

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

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

@ -169,13 +169,25 @@
(contract-struct-stronger? this-rng that-rng))] (contract-struct-stronger? this-rng that-rng))]
[(or (equal? that-immutable 'dont-care) [(or (equal? that-immutable 'dont-care)
(equal? this-immutable that-immutable)) (equal? this-immutable that-immutable))
(and (contract-struct-stronger? this-dom that-dom) (and (contract-struct-equivalent? this-dom that-dom)
(contract-struct-stronger? that-dom this-dom) (contract-struct-equivalent? this-rng that-rng))]
(contract-struct-stronger? this-rng that-rng)
(contract-struct-stronger? that-rng this-rng))]
[else #f])] [else #f])]
[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) () (define-struct (flat-hash/c base-hash/c) ()
#:omit-define-syntaxes #:omit-define-syntaxes
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
@ -184,6 +196,7 @@
#:name hash/c-name #:name hash/c-name
#:first-order hash/c-first-order #:first-order hash/c-first-order
#:stronger hash/c-stronger #:stronger hash/c-stronger
#:equivalent hash/c-equivalent
#:late-neg-projection #:late-neg-projection
(λ (ctc) (λ (ctc)
(define dom-ctc (base-hash/c-dom ctc)) (define dom-ctc (base-hash/c-dom ctc))
@ -299,6 +312,7 @@
#:name hash/c-name #:name hash/c-name
#:first-order hash/c-first-order #:first-order hash/c-first-order
#:stronger hash/c-stronger #:stronger hash/c-stronger
#:equivalent hash/c-equivalent
#:late-neg-projection (ho-projection chaperone-hash))) #:late-neg-projection (ho-projection chaperone-hash)))
(define-struct (impersonator-hash/c base-hash/c) () (define-struct (impersonator-hash/c base-hash/c) ()
@ -309,6 +323,7 @@
#:name hash/c-name #:name hash/c-name
#:first-order hash/c-first-order #:first-order hash/c-first-order
#:stronger hash/c-stronger #:stronger hash/c-stronger
#:equivalent hash/c-equivalent
#:late-neg-projection (ho-projection impersonate-hash))) #:late-neg-projection (ho-projection impersonate-hash)))
@ -337,6 +352,7 @@
(contract-first-order-passes? (rng-f k) v)))))) (contract-first-order-passes? (rng-f k) v))))))
(define (hash/dc-stronger this that) #f) (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 ((hash/dc-late-neg-projection chaperone-or-impersonate-hash) ctc)
(define dom-ctc (base-hash/dc-dom ctc)) (define dom-ctc (base-hash/dc-dom ctc))
@ -371,6 +387,7 @@
(build-flat-contract-property (build-flat-contract-property
#:name hash/dc-name #:name hash/dc-name
#:first-order hash/dc-first-order #:first-order hash/dc-first-order
#:equivalent hash/dc-equivalent
#:stronger hash/dc-stronger)) #:stronger hash/dc-stronger))
(struct chaperone-hash/dc base-hash/dc () (struct chaperone-hash/dc base-hash/dc ()
@ -380,6 +397,7 @@
#:name hash/dc-name #:name hash/dc-name
#:first-order hash/dc-first-order #:first-order hash/dc-first-order
#:stronger hash/dc-stronger #:stronger hash/dc-stronger
#:equivalent hash/dc-equivalent
#:late-neg-projection (hash/dc-late-neg-projection chaperone-hash))) #:late-neg-projection (hash/dc-late-neg-projection chaperone-hash)))
(struct impersonator-hash/dc base-hash/dc () (struct impersonator-hash/dc base-hash/dc ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
@ -388,6 +406,7 @@
#:name hash/dc-name #:name hash/dc-name
#:first-order hash/dc-first-order #:first-order hash/dc-first-order
#:stronger hash/dc-stronger #:stronger hash/dc-stronger
#:equivalent hash/dc-equivalent
#:late-neg-projection (hash/dc-late-neg-projection impersonate-hash))) #:late-neg-projection (hash/dc-late-neg-projection impersonate-hash)))
(define (build-hash/dc dom dep-rng here name-info immutable kind) (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))] (contract-struct-stronger? (ne->pe-ctc this) tl-ctc))]
[else #f])) [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) (define (raise-listof-blame-error blame val empty-ok? neg-party)
(raise-blame-error blame #:missing-party neg-party val (raise-blame-error blame #:missing-party neg-party val
'(expected: "~s" given: "~e") '(expected: "~s" given: "~e")
@ -219,6 +241,7 @@
#:generate listof-generate #:generate listof-generate
#:exercise listof-exercise #:exercise listof-exercise
#:stronger listof-stronger #:stronger listof-stronger
#:equivalent listof-equivalent
#:list-contract? (λ (c) (not (im-listof-ctc? c))))) #:list-contract? (λ (c) (not (im-listof-ctc? c)))))
(define chap-prop (define chap-prop
(build-chaperone-contract-property (build-chaperone-contract-property
@ -228,6 +251,7 @@
#:generate listof-generate #:generate listof-generate
#:exercise listof-exercise #:exercise listof-exercise
#:stronger listof-stronger #:stronger listof-stronger
#:equivalent listof-equivalent
#:list-contract? (λ (c) (not (im-listof-ctc? c))))) #:list-contract? (λ (c) (not (im-listof-ctc? c)))))
(define full-prop (define full-prop
(build-contract-property (build-contract-property
@ -237,6 +261,7 @@
#:generate listof-generate #:generate listof-generate
#:exercise listof-exercise #:exercise listof-exercise
#:stronger listof-stronger #:stronger listof-stronger
#:equivalent listof-equivalent
#:list-contract? (λ (c) (not (im-listof-ctc? c))))) #:list-contract? (λ (c) (not (im-listof-ctc? c)))))
(struct listof-ctc (elem-c)) (struct listof-ctc (elem-c))
@ -382,6 +407,20 @@
(contract-struct-stronger? this-tl that))] (contract-struct-stronger? this-tl that))]
[else #f])) [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 (cons/c-generate ctc)
(define ctc-car (the-cons/c-hd-ctc ctc)) (define ctc-car (the-cons/c-hd-ctc ctc))
@ -405,6 +444,7 @@
#:name cons/c-name #:name cons/c-name
#:first-order cons/c-first-order #:first-order cons/c-first-order
#:stronger cons/c-stronger? #:stronger cons/c-stronger?
#:equivalent cons/c-equivalent?
#:generate cons/c-generate #:generate cons/c-generate
#:list-contract? cons/c-list-contract?)) #:list-contract? cons/c-list-contract?))
(define-struct (chaperone-cons/c the-cons/c) () (define-struct (chaperone-cons/c the-cons/c) ()
@ -415,6 +455,7 @@
#:name cons/c-name #:name cons/c-name
#:first-order cons/c-first-order #:first-order cons/c-first-order
#:stronger cons/c-stronger? #:stronger cons/c-stronger?
#:equivalent cons/c-equivalent?
#:generate cons/c-generate #:generate cons/c-generate
#:list-contract? cons/c-list-contract?)) #:list-contract? cons/c-list-contract?))
(define-struct (impersonator-cons/c the-cons/c) () (define-struct (impersonator-cons/c the-cons/c) ()
@ -425,6 +466,7 @@
#:name cons/c-name #:name cons/c-name
#:first-order cons/c-first-order #:first-order cons/c-first-order
#:stronger cons/c-stronger? #:stronger cons/c-stronger?
#:equivalent cons/c-equivalent?
#:generate cons/c-generate #:generate cons/c-generate
#:list-contract? cons/c-list-contract?)) #:list-contract? cons/c-list-contract?))
@ -496,6 +538,7 @@
dep-val)))))) dep-val))))))
(define (cons/dc-stronger? this that) #f) (define (cons/dc-stronger? this that) #f)
(define (cons/dc-equivalent? this that) #f)
(define (cons/dc-generate ctc) (define (cons/dc-generate ctc)
(define undep-ctc (the-cons/dc-undep ctc)) (define undep-ctc (the-cons/dc-undep ctc))
@ -526,6 +569,7 @@
#:name cons/dc-name #:name cons/dc-name
#:first-order cons/dc-first-order #:first-order cons/dc-first-order
#:stronger cons/dc-stronger? #:stronger cons/dc-stronger?
#:equivalent cons/dc-equivalent?
#:generate cons/dc-generate)) #:generate cons/dc-generate))
(struct chaperone-cons/dc the-cons/dc () (struct chaperone-cons/dc the-cons/dc ()
@ -536,6 +580,7 @@
#:name cons/dc-name #:name cons/dc-name
#:first-order cons/dc-first-order #:first-order cons/dc-first-order
#:stronger cons/dc-stronger? #:stronger cons/dc-stronger?
#:equivalent cons/dc-equivalent?
#:generate cons/dc-generate)) #:generate cons/dc-generate))
(struct impersonator-cons/dc the-cons/dc () (struct impersonator-cons/dc the-cons/dc ()
@ -546,6 +591,7 @@
#:name cons/dc-name #:name cons/dc-name
#:first-order cons/dc-first-order #:first-order cons/dc-first-order
#:stronger cons/dc-stronger? #:stronger cons/dc-stronger?
#:equivalent cons/dc-equivalent?
#:generate cons/dc-generate)) #:generate cons/dc-generate))
(define-syntax (cons/dc stx) (define-syntax (cons/dc stx)
@ -669,6 +715,13 @@
(contract-struct-stronger? this-s that-elem-ctc)))] (contract-struct-stronger? this-s that-elem-ctc)))]
[else #f])) [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 generic-list/c (args))
(struct flat-list/c generic-list/c () (struct flat-list/c generic-list/c ()
@ -680,6 +733,7 @@
#:generate list/c-generate #:generate list/c-generate
#:exercise list/c-exercise #:exercise list/c-exercise
#:stronger list/c-stronger #:stronger list/c-stronger
#:equivalent list/c-equivalent
#:late-neg-projection #:late-neg-projection
(λ (c) (λ (c)
(λ (blame) (λ (blame)
@ -774,6 +828,7 @@
#:generate list/c-generate #:generate list/c-generate
#:exercise list/c-exercise #:exercise list/c-exercise
#:stronger list/c-stronger #:stronger list/c-stronger
#:equivalent list/c-equivalent
#:late-neg-projection list/c-chaperone/other-late-neg-projection #:late-neg-projection list/c-chaperone/other-late-neg-projection
#:list-contract? (λ (c) #t))) #:list-contract? (λ (c) #t)))
@ -786,6 +841,7 @@
#:generate list/c-generate #:generate list/c-generate
#:exercise list/c-exercise #:exercise list/c-exercise
#:stronger list/c-stronger #:stronger list/c-stronger
#:equivalent list/c-equivalent
#:late-neg-projection list/c-chaperone/other-late-neg-projection #:late-neg-projection list/c-chaperone/other-late-neg-projection
#:list-contract? (λ (c) #t))) #:list-contract? (λ (c) #t)))
@ -882,6 +938,17 @@
(contract-struct-stronger? suf that-elem)))] (contract-struct-stronger? suf that-elem)))]
[else #f])) [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 (*list/c-late-neg-projection ctc start-index flat?)
(define prefix-lnp (contract-late-neg-projection (*list-ctc-prefix ctc))) (define prefix-lnp (contract-late-neg-projection (*list-ctc-prefix ctc)))
(define suffix-lnps (map contract-late-neg-projection (*list-ctc-suffix ctc))) (define suffix-lnps (map contract-late-neg-projection (*list-ctc-suffix ctc)))
@ -959,6 +1026,7 @@
#:generate *list/c-generate #:generate *list/c-generate
#:exercise *list/c-exercise #:exercise *list/c-exercise
#:stronger *list/c-stronger #:stronger *list/c-stronger
#:equivalent *list/c-equivalent
#:late-neg-projection (λ (ctc) (*list/c-late-neg-projection ctc #f #t)) #:late-neg-projection (λ (ctc) (*list/c-late-neg-projection ctc #f #t))
#:list-contract? (λ (c) #t))) #:list-contract? (λ (c) #t)))
(struct chaperone-*list/c *list-ctc () (struct chaperone-*list/c *list-ctc ()
@ -969,6 +1037,7 @@
#:generate *list/c-generate #:generate *list/c-generate
#:exercise *list/c-exercise #:exercise *list/c-exercise
#:stronger *list/c-stronger #:stronger *list/c-stronger
#:equivalent *list/c-equivalent
#:late-neg-projection (λ (ctc) (*list/c-late-neg-projection ctc #f #f)) #:late-neg-projection (λ (ctc) (*list/c-late-neg-projection ctc #f #f))
#:list-contract? (λ (c) #t))) #:list-contract? (λ (c) #t)))
(struct impersonator-*list/c *list-ctc () (struct impersonator-*list/c *list-ctc ()
@ -979,6 +1048,7 @@
#:generate *list/c-generate #:generate *list/c-generate
#:exercise *list/c-exercise #:exercise *list/c-exercise
#:stronger *list/c-stronger #:stronger *list/c-stronger
#:equivalent *list/c-equivalent
#:late-neg-projection (λ (ctc) (*list/c-late-neg-projection ctc #f #f)) #:late-neg-projection (λ (ctc) (*list/c-late-neg-projection ctc #f #f))
#:list-contract? (λ (c) #t))) #:list-contract? (λ (c) #t)))
@ -1022,6 +1092,7 @@
#:generate *list/c-generate #:generate *list/c-generate
#:exercise *list/c-exercise #:exercise *list/c-exercise
#:stronger *list/c-stronger #:stronger *list/c-stronger
#:equivalent *list/c-equivalent
#:late-neg-projection #:late-neg-projection
(λ (ctc) (*list/c-late-neg-projection ctc (ellipsis-rest-arg-ctc-start-index ctc) #t)) (λ (ctc) (*list/c-late-neg-projection ctc (ellipsis-rest-arg-ctc-start-index ctc) #t))
#:list-contract? (λ (c) #t))) #:list-contract? (λ (c) #t)))
@ -1033,6 +1104,7 @@
#:generate *list/c-generate #:generate *list/c-generate
#:exercise *list/c-exercise #:exercise *list/c-exercise
#:stronger *list/c-stronger #:stronger *list/c-stronger
#:equivalent *list/c-equivalent
#:late-neg-projection #:late-neg-projection
(λ (ctc) (*list/c-late-neg-projection ctc (ellipsis-rest-arg-ctc-start-index ctc) #f)) (λ (ctc) (*list/c-late-neg-projection ctc (ellipsis-rest-arg-ctc-start-index ctc) #f))
#:list-contract? (λ (c) #t))) #:list-contract? (λ (c) #t)))
@ -1044,6 +1116,7 @@
#:generate *list/c-generate #:generate *list/c-generate
#:exercise *list/c-exercise #:exercise *list/c-exercise
#:stronger *list/c-stronger #:stronger *list/c-stronger
#:equivalent *list/c-equivalent
#:late-neg-projection #:late-neg-projection
(λ (ctc) (*list/c-late-neg-projection ctc (ellipsis-rest-arg-ctc-start-index ctc) #f)) (λ (ctc) (*list/c-late-neg-projection ctc (ellipsis-rest-arg-ctc-start-index ctc) #f))
#:list-contract? (λ (c) #t))) #:list-contract? (λ (c) #t)))

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

@ -50,6 +50,7 @@
if/c if/c
pairwise-stronger-contracts? pairwise-stronger-contracts?
pairwise-equivalent-contracts?
check-two-args check-two-args
suggest/c suggest/c
@ -119,6 +120,15 @@
(< that-x this-low))])] (< that-x this-low))])]
[else #f])) [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 (between/c-first-order ctc)
(define n (between/c-s-low ctc)) (define n (between/c-s-low ctc))
(define m (between/c-s-high ctc)) (define m (between/c-s-high ctc))
@ -193,6 +203,7 @@
[(= n m) `(=/c ,n)] [(= n m) `(=/c ,n)]
[else ])])) [else ])]))
#:stronger between/c-stronger #:stronger between/c-stronger
#:equivalent between/c-equivalent
#:first-order between/c-first-order #:first-order between/c-first-order
#:generate between/c-generate)) #:generate between/c-generate))
(define-struct (renamed-between/c between/c-s) (name)) (define-struct (renamed-between/c between/c-s) (name))
@ -253,7 +264,8 @@
[1/10 (-/+ x 0.01)] [1/10 (-/+ x 0.01)]
[4/10 (-/+ x (random))] [4/10 (-/+ x (random))]
[else (-/+ x (random 4294967087))])))) [else (-/+ x (random 4294967087))]))))
#:stronger </>-ctc-stronger)) #:stronger </>-ctc-stronger
#:equivalent </>-ctc-equivalent))
(define (</>-ctc-stronger this that) (define (</>-ctc-stronger this that)
(define this-x (</>-ctc-x this)) (define this-x (</>-ctc-x this))
@ -274,6 +286,17 @@
(and (= (between/c-s-high that) +inf.0) (and (= (between/c-s-high that) +inf.0)
(<= (between/c-s-low that) this-x))])])) (<= (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 (x))
(struct <-ctc </>-ctc () (struct <-ctc </>-ctc ()
@ -331,6 +354,10 @@
(and (syntax-ctc? that) (and (syntax-ctc? that)
(contract-struct-stronger? (syntax-ctc-ctc this) (contract-struct-stronger? (syntax-ctc-ctc this)
(syntax-ctc-ctc that)))) (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) #:first-order (λ (ctc)
(define ? (flat-contract-predicate (syntax-ctc-ctc ctc))) (define ? (flat-contract-predicate (syntax-ctc-ctc ctc)))
(λ (v) (λ (v)
@ -406,6 +433,11 @@
(contract-struct-stronger? (promise-base-ctc-ctc this) (contract-struct-stronger? (promise-base-ctc-ctc this)
(promise-base-ctc-ctc that)))) (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 promise-base-ctc (ctc))
(struct chaperone-promise-ctc promise-base-ctc () (struct chaperone-promise-ctc promise-base-ctc ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
@ -414,6 +446,7 @@
#:name promise-contract-name #:name promise-contract-name
#:late-neg-projection promise-contract-late-neg-proj #:late-neg-projection promise-contract-late-neg-proj
#:stronger promise-ctc-stronger? #:stronger promise-ctc-stronger?
#:equivalent promise-ctc-equivalent?
#:first-order (λ (ctc) promise?))) #:first-order (λ (ctc) promise?)))
(struct promise-ctc promise-base-ctc () (struct promise-ctc promise-base-ctc ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
@ -422,6 +455,7 @@
#:name promise-contract-name #:name promise-contract-name
#:late-neg-projection promise-contract-late-neg-proj #:late-neg-projection promise-contract-late-neg-proj
#:stronger promise-ctc-stronger? #:stronger promise-ctc-stronger?
#:equivalent promise-ctc-equivalent?
#:first-order (λ (ctc) promise?))) #:first-order (λ (ctc) promise?)))
;; (parameter/c in/out-ctc) ;; (parameter/c in/out-ctc)
@ -488,16 +522,26 @@
(and (contract-struct-stronger? (parameter/c-out this) (and (contract-struct-stronger? (parameter/c-out this)
(parameter/c-out that)) (parameter/c-out that))
(contract-struct-stronger? (parameter/c-in that) (contract-struct-stronger? (parameter/c-in that)
(parameter/c-in this))))))) (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) (define-struct procedure-arity-includes/c (n)
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:omit-define-syntaxes #:omit-define-syntaxes
#:property prop:flat-contract #:property prop:flat-contract
(build-flat-contract-property (build-flat-contract-property
#:stronger (λ (this that) (and (procedure-arity-includes/c? that) #:stronger procedure-arity-includes-equivalent?
(= (procedure-arity-includes/c-n this) #:equivalent procedure-arity-includes-equivalent?
(procedure-arity-includes/c-n that))))
#:name (λ (ctc) `(procedure-arity-includes/c ,(procedure-arity-includes/c-n ctc))) #:name (λ (ctc) `(procedure-arity-includes/c ,(procedure-arity-includes/c-n ctc)))
#:first-order (λ (ctc) #:first-order (λ (ctc)
(define n (procedure-arity-includes/c-n ctc)) (define n (procedure-arity-includes/c-n ctc))
@ -557,6 +601,7 @@
(build-flat-contract-property (build-flat-contract-property
#:late-neg-projection (λ (ctc) any/c-blame->neg-party-fn) #:late-neg-projection (λ (ctc) any/c-blame->neg-party-fn)
#:stronger (λ (this that) (any/c? that)) #:stronger (λ (this that) (any/c? that))
#:equivalent (λ (this that) (any/c? that))
#:name (λ (ctc) 'any/c) #:name (λ (ctc) 'any/c)
#:generate (λ (ctc) #:generate (λ (ctc)
(λ (fuel) (λ (fuel)
@ -584,6 +629,7 @@
(build-flat-contract-property (build-flat-contract-property
#:late-neg-projection none-curried-late-neg-proj #:late-neg-projection none-curried-late-neg-proj
#:stronger (λ (this that) #t) #:stronger (λ (this that) #t)
#:equivalent (λ (this that) (none/c? that))
#:name (λ (ctc) (none/c-name ctc)) #:name (λ (ctc) (none/c-name ctc))
#:first-order (λ (ctc) (λ (val) #f)))) #:first-order (λ (ctc) (λ (val) #f))))
@ -666,12 +712,21 @@
(define (prompt-tag/c-stronger? this that) (define (prompt-tag/c-stronger? this that)
(and (base-prompt-tag/c? 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 this)
(base-prompt-tag/c-ctcs that)) (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 this)
(base-prompt-tag/c-call/ccs that)))) (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))))
;; (listof contract) (listof contract) ;; (listof contract) (listof contract)
(define-struct base-prompt-tag/c (ctcs call/ccs)) (define-struct base-prompt-tag/c (ctcs call/ccs))
@ -683,6 +738,7 @@
#:late-neg-projection (prompt-tag/c-late-neg-proj #t) #:late-neg-projection (prompt-tag/c-late-neg-proj #t)
#:first-order (λ (ctc) continuation-prompt-tag?) #:first-order (λ (ctc) continuation-prompt-tag?)
#:stronger prompt-tag/c-stronger? #:stronger prompt-tag/c-stronger?
#:equivalent prompt-tag/c-equivalent?
#:name prompt-tag/c-name)) #:name prompt-tag/c-name))
(define-struct (impersonator-prompt-tag/c base-prompt-tag/c) () (define-struct (impersonator-prompt-tag/c base-prompt-tag/c) ()
@ -692,6 +748,7 @@
#:late-neg-projection (prompt-tag/c-late-neg-proj #f) #:late-neg-projection (prompt-tag/c-late-neg-proj #f)
#:first-order (λ (ctc) continuation-prompt-tag?) #:first-order (λ (ctc) continuation-prompt-tag?)
#:stronger prompt-tag/c-stronger? #:stronger prompt-tag/c-stronger?
#:equivalent prompt-tag/c-equivalent?
#:name prompt-tag/c-name)) #:name prompt-tag/c-name))
@ -743,6 +800,12 @@
(base-continuation-mark-key/c-ctc this) (base-continuation-mark-key/c-ctc this)
(base-continuation-mark-key/c-ctc that)))) (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 base-continuation-mark-key/c (ctc))
(define-struct (chaperone-continuation-mark-key/c (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) #:late-neg-projection (continuation-mark-key/c-late-neg-proj chaperone-continuation-mark-key)
#:first-order (λ (ctc) continuation-mark-key?) #:first-order (λ (ctc) continuation-mark-key?)
#:stronger continuation-mark-key/c-stronger? #:stronger continuation-mark-key/c-stronger?
#:equivalent continuation-mark-key/c-equivalent?
#:name continuation-mark-key/c-name)) #:name continuation-mark-key/c-name))
(define-struct (impersonator-continuation-mark-key/c (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) #:late-neg-projection (continuation-mark-key/c-late-neg-proj impersonate-continuation-mark-key)
#:first-order (λ (ctc) continuation-mark-key?) #:first-order (λ (ctc) continuation-mark-key?)
#:stronger continuation-mark-key/c-stronger? #:stronger continuation-mark-key/c-stronger?
#:equivalent continuation-mark-key/c-equivalent?
#:name continuation-mark-key/c-name)) #:name continuation-mark-key/c-name))
;; evt/c : Contract * -> Contract ;; evt/c : Contract * -> Contract
@ -823,9 +888,20 @@
;; evt/c-stronger? : Contract Contract -> Boolean ;; evt/c-stronger? : Contract Contract -> Boolean
(define (evt/c-stronger? this that) (define (evt/c-stronger? this that)
(define this-ctcs (chaperone-evt/c-ctcs this)) (cond
(define that-ctcs (chaperone-evt/c-ctcs that)) [(chaperone-evt/c? that)
(pairwise-stronger-contracts? this-ctcs that-ctcs)) (define this-ctcs (chaperone-evt/c-ctcs this))
(define that-ctcs (chaperone-evt/c-ctcs that))
(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> ;; ctcs - Listof<Contract>
(define-struct chaperone-evt/c (ctcs) (define-struct chaperone-evt/c (ctcs)
@ -834,6 +910,7 @@
#:late-neg-projection evt/c-proj #:late-neg-projection evt/c-proj
#:first-order evt/c-first-order #:first-order evt/c-first-order
#:stronger evt/c-stronger? #:stronger evt/c-stronger?
#:equivalent evt/c-equivalent?
#:name evt/c-name)) #:name evt/c-name))
;; channel/c ;; channel/c
@ -891,6 +968,12 @@
(base-channel/c-ctc this) (base-channel/c-ctc this)
(base-channel/c-ctc that)))) (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 base-channel/c (ctc))
(define-struct (chaperone-channel/c base-channel/c) (define-struct (chaperone-channel/c base-channel/c)
@ -901,6 +984,7 @@
#:late-neg-projection (channel/c-late-neg-proj chaperone-channel) #:late-neg-projection (channel/c-late-neg-proj chaperone-channel)
#:first-order channel/c-first-order #:first-order channel/c-first-order
#:stronger channel/c-stronger? #:stronger channel/c-stronger?
#:equivalent channel/c-equivalent?
#:name channel/c-name)) #:name channel/c-name))
(define-struct (impersonator-channel/c base-channel/c) (define-struct (impersonator-channel/c base-channel/c)
@ -911,6 +995,7 @@
#:late-neg-projection (channel/c-late-neg-proj impersonate-channel) #:late-neg-projection (channel/c-late-neg-proj impersonate-channel)
#:first-order channel/c-first-order #:first-order channel/c-first-order
#:stronger channel/c-stronger? #:stronger channel/c-stronger?
#:equivalent channel/c-equivalent?
#:name channel/c-name)) #:name channel/c-name))
@ -980,12 +1065,15 @@
(if (flat-contract? ctc) (if (flat-contract? ctc)
(flat-named-contract name (flat-contract-predicate ctc)) (flat-named-contract name (flat-contract-predicate ctc))
(let* ([make-contract (if (chaperone-contract? ctc) make-chaperone-contract make-contract)]) (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)) (contract-struct-stronger? ctc other))
(define (rename-contract-equivalent? this other)
(contract-struct-equivalent? ctc other))
(make-contract #:name name (make-contract #:name name
#:late-neg-projection (get/build-late-neg-projection ctc) #:late-neg-projection (get/build-late-neg-projection ctc)
#:first-order (contract-first-order ctc) #:first-order (contract-first-order ctc)
#:stronger stronger? #:stronger rename-contract-stronger?
#:equivalent rename-contract-equivalent?
#:list-contract? (list-contract? ctc)))))) #:list-contract? (list-contract? ctc))))))
(define (if/c predicate then/c else/c) (define (if/c predicate then/c else/c)
@ -1063,6 +1151,16 @@
(loop (cdr c1s) (cdr c2s)))] (loop (cdr c1s) (cdr c2s)))]
[else #f]))) [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 (suggest/c _ctc field message)
(define ctc (coerce-contract 'suggest/c _ctc)) (define ctc (coerce-contract 'suggest/c _ctc))
(unless (string? field) (unless (string? field)
@ -1083,7 +1181,8 @@
#:name (contract-name ctc) #:name (contract-name ctc)
#:first-order (contract-first-order ctc) #:first-order (contract-first-order ctc)
#:late-neg-projection (λ (b) (ctc-lnp (blame-add-extra-field b field message))) #: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))) #:list-contract? (list-contract? ctc)))
(define (flat-contract-with-explanation ? #:name [name (object-name ?)]) (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/c? that)
(subclass? (subclass/c-% this) (subclass/c-% that))] (subclass? (subclass/c-% this) (subclass/c-% that))]
[else #f])) [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%))))) #:name (λ (ctc) `(subclass?/c ,(or (object-name (subclass/c-% ctc)) 'unknown%)))))
(define (subclass?/c %) (define (subclass?/c %)
(unless (class? %) (unless (class? %)
@ -145,6 +148,10 @@
(interface-extension? (implementation/c-<%> this) (interface-extension? (implementation/c-<%> this)
(implementation/c-<%> that))] (implementation/c-<%> that))]
[else #f])) [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<%>))))) #:name (λ (ctc) `(implementation?/c ,(or (object-name (implementation/c-<%> ctc)) 'unknown<%>)))))
(define (implementation?/c <%>) (define (implementation?/c <%>)
@ -185,6 +192,10 @@
(interface-extension? this-<%> that-<%>)] (interface-extension? this-<%> that-<%>)]
[else #f])] [else #f])]
[else #f])) [else #f]))
#:equivalent
(λ (this that)
(and (is-a?-ctc? that)
(equal? (is-a?-ctc-<%> this) (is-a?-ctc-<%> that))))
#:name #:name
(λ (ctc) (λ (ctc)
(define <%> (is-a?-ctc-<%> 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))) (single-or/c-flat-ctcs that)))
(generic-or/c-stronger? this 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 (generic-or/c-stronger? this that)
(define this-sub-ctcs (or/c-sub-contracts this)) (define this-sub-ctcs (or/c-sub-contracts this))
(define that-sub-ctcs (or/c-sub-contracts that)) (define that-sub-ctcs (or/c-sub-contracts that))
@ -119,6 +127,15 @@
(for/or ([that-sub-ctc (in-list that-sub-ctcs)]) (for/or ([that-sub-ctc (in-list that-sub-ctcs)])
(contract-struct-stronger? this-sub-ctc that-sub-ctc))))) (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) (define (or/c-sub-contracts ctc)
(cond (cond
[(single-or/c? ctc) [(single-or/c? ctc)
@ -215,6 +232,7 @@
#:name single-or/c-name #:name single-or/c-name
#:first-order single-or/c-first-order #:first-order single-or/c-first-order
#:stronger single-or/c-stronger? #:stronger single-or/c-stronger?
#:equivalent single-or/c-equivalent?
#:generate (λ (ctc) (or/c-generate ctc #:generate (λ (ctc) (or/c-generate ctc
(cons (single-or/c-ho-ctc ctc) (cons (single-or/c-ho-ctc ctc)
(single-or/c-flat-ctcs ctc)))) (single-or/c-flat-ctcs ctc))))
@ -229,6 +247,7 @@
#:name single-or/c-name #:name single-or/c-name
#:first-order single-or/c-first-order #:first-order single-or/c-first-order
#:stronger single-or/c-stronger? #:stronger single-or/c-stronger?
#:equivalent single-or/c-equivalent?
#:generate (λ (ctc) (or/c-generate ctc #:generate (λ (ctc) (or/c-generate ctc
(cons (single-or/c-ho-ctc ctc) (cons (single-or/c-ho-ctc ctc)
(single-or/c-flat-ctcs ctc)))) (single-or/c-flat-ctcs ctc))))
@ -316,6 +335,14 @@
(multi-or/c-flat-ctcs that))) (multi-or/c-flat-ctcs that)))
(generic-or/c-stronger? this 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) (define (mult-or/c-list-contract? c)
(and (for/and ([c (in-list (multi-or/c-flat-ctcs c))]) (and (for/and ([c (in-list (multi-or/c-flat-ctcs c))])
(list-contract? c)) (list-contract? c))
@ -335,6 +362,7 @@
#:name multi-or/c-name #:name multi-or/c-name
#:first-order multi-or/c-first-order #:first-order multi-or/c-first-order
#:stronger multi-or/c-stronger? #:stronger multi-or/c-stronger?
#:equivalent multi-or/c-equivalent?
#:generate (λ (ctc) (or/c-generate ctc #:generate (λ (ctc) (or/c-generate ctc
(append (multi-or/c-ho-ctcs ctc) (append (multi-or/c-ho-ctcs ctc)
(multi-or/c-flat-ctcs ctc)))) (multi-or/c-flat-ctcs ctc))))
@ -349,6 +377,7 @@
#:name multi-or/c-name #:name multi-or/c-name
#:first-order multi-or/c-first-order #:first-order multi-or/c-first-order
#:stronger multi-or/c-stronger? #:stronger multi-or/c-stronger?
#:equivalent multi-or/c-equivalent?
#:generate (λ (ctc) (or/c-generate ctc #:generate (λ (ctc) (or/c-generate ctc
(append (multi-or/c-ho-ctcs ctc) (append (multi-or/c-ho-ctcs ctc)
(multi-or/c-flat-ctcs ctc)))) (multi-or/c-flat-ctcs ctc))))
@ -394,7 +423,7 @@
#f))] #f))]
[else #f]))) [else #f])))
(generic-or/c-stronger? this that))) (generic-or/c-stronger? this that)))
#:equivalent generic-or/c-equivalent?
#:first-order #:first-order
(λ (ctc) (flat-or/c-pred ctc)) (λ (ctc) (flat-or/c-pred ctc))
@ -470,6 +499,7 @@
#:name first-or/c-name #:name first-or/c-name
#:first-order first-or/c-first-order #:first-order first-or/c-first-order
#:stronger multi-or/c-stronger? #:stronger multi-or/c-stronger?
#:equivalent multi-or/c-equivalent?
#:generate (λ (ctc) (or/c-generate ctc (base-first-or/c-ctcs ctc))) #:generate (λ (ctc) (or/c-generate ctc (base-first-or/c-ctcs ctc)))
#:exercise (λ (ctc) (or/c-exercise (base-first-or/c-ctcs ctc))) #:exercise (λ (ctc) (or/c-exercise (base-first-or/c-ctcs ctc)))
#:list-contract? first-or/c-list-contract?)) #:list-contract? first-or/c-list-contract?))
@ -480,6 +510,7 @@
#:name first-or/c-name #:name first-or/c-name
#:first-order first-or/c-first-order #:first-order first-or/c-first-order
#:stronger generic-or/c-stronger? #:stronger generic-or/c-stronger?
#:equivalent generic-or/c-equivalent?
#:generate (λ (ctc) (or/c-generate ctc (base-first-or/c-ctcs ctc))) #:generate (λ (ctc) (or/c-generate ctc (base-first-or/c-ctcs ctc)))
#:exercise (λ (ctc) (or/c-exercise (base-first-or/c-ctcs ctc))) #:exercise (λ (ctc) (or/c-exercise (base-first-or/c-ctcs ctc)))
#:list-contract? first-or/c-list-contract?)) #:list-contract? first-or/c-list-contract?))
@ -526,6 +557,15 @@
(parameterize ([recur? #f]) (parameterize ([recur? #f])
(contract-struct-stronger? (get-flat-rec-me this) that))] (contract-struct-stronger? (get-flat-rec-me this) that))]
[else #f]))) [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 #:first-order
(λ (ctc) (λ (ctc)
(λ (v) (λ (v)

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

@ -53,6 +53,24 @@
(apply (polymorphic-contract-body that) instances))] (apply (polymorphic-contract-body that) instances))]
[else #f])] [else #f])]
[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 #:late-neg-projection
(lambda (c) (lambda (c)
(lambda (orig-blame) (lambda (orig-blame)
@ -104,6 +122,7 @@
#:name (lambda (c) (barrier-contract-name c)) #:name (lambda (c) (barrier-contract-name c))
#:first-order (λ (c) (barrier-contract-pred c)) #:first-order (λ (c) (barrier-contract-pred c))
#:stronger (λ (this that) (eq? this that)) #:stronger (λ (this that) (eq? this that))
#:equivalent (λ (this that) (eq? this that))
#:late-neg-projection #:late-neg-projection
(lambda (c) (lambda (c)
(define mk (barrier-contract-make c)) (define mk (barrier-contract-make c))

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

@ -12,6 +12,7 @@
contract-struct-val-first-projection contract-struct-val-first-projection
contract-struct-late-neg-projection contract-struct-late-neg-projection
contract-struct-stronger? contract-struct-stronger?
contract-struct-equivalent?
contract-struct-generate contract-struct-generate
contract-struct-exercise contract-struct-exercise
contract-struct-list-contract? contract-struct-list-contract?
@ -62,6 +63,7 @@
first-order first-order
projection projection
stronger stronger
equivalent
generate generate
exercise exercise
val-first-projection val-first-projection
@ -111,60 +113,86 @@
(and get-projection (and get-projection
(get-projection c))) (get-projection c)))
(define trail (make-parameter #f)) (define (contract-struct-stronger/equivalent?
(define (contract-struct-stronger? a b) a b
(cond trail
[(and (or (flat-contract-struct? a) contract-property-stronger/equivalent
(chaperone-contract-struct? a)) special-or/c-any/c-handling?)
(equal? a b)) (let loop ([a a][b b])
#t] (cond
[else [(and (or (flat-contract-struct? a)
(define prop (contract-struct-property a)) (chaperone-contract-struct? a))
(define stronger? (contract-property-stronger prop)) (equal? a b))
(cond #t]
[(stronger? a b) [else
;; optimistically try skip some of the more complex work below (define prop (contract-struct-property a))
#t] (define stronger/equivalent? (contract-property-stronger/equivalent prop))
[(and (flat-contract-struct? a) (prop:any/c? b)) #t] ;; is the flat-check needed here? (cond
[(let ([th (trail)]) [(stronger/equivalent? a b)
(and th ;; optimistically try skip some of the more complex work below
(for/or ([(a2 bs-h) (in-hash th)]) #t]
(and (eq? a a2) [(and special-or/c-any/c-handling?
(for/or ([(b2 _) (in-hash bs-h)]) (flat-contract-struct? a)
(eq? b b2)))))) (prop:any/c? b))
#t] ;; is the flat-check needed here?
[(or (prop:recursive-contract? a) (prop:recursive-contract? b)) #t]
(parameterize ([trail (or (trail) (make-hasheq))]) [(let ([th (trail)])
(define trail-h (trail)) (and th
(let ([a-h (hash-ref trail-h a #f)]) (for/or ([(a2 bs-h) (in-hash th)])
(and (eq? a a2)
(for/or ([(b2 _) (in-hash bs-h)])
(eq? b b2))))))
#t]
[(or (prop:recursive-contract? a) (prop:recursive-contract? b))
(parameterize ([trail (or (trail) (make-hasheq))])
(define trail-h (trail))
(let ([a-h (hash-ref trail-h a #f)])
(cond
[a-h
(hash-set! a-h b #t)]
[else
(define a-h (make-hasheq))
(hash-set! trail-h a a-h)
(hash-set! a-h b #t)]))
(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)))]
[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 (cond
[a-h [(and later? (stronger/equivalent? a b))
(hash-set! a-h b #t)] #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 [else
(define a-h (make-hasheq)) #f]))]
(hash-set! trail-h a a-h) [else #f])])))
(hash-set! a-h b #t)]))
(contract-struct-stronger? (if (prop:recursive-contract? a) (define stronger-trail (make-parameter #f))
((prop:recursive-contract-unroll a) a) (define (contract-struct-stronger? a b)
a) (contract-struct-stronger/equivalent?
(if (prop:recursive-contract? b) a b
((prop:recursive-contract-unroll b) b) stronger-trail
b)))] contract-property-stronger
[else #t))
;; the 'later?' flag avoids checking
;; (stronger? a b) in the first iteration, (define equivalent-trail (make-parameter #f))
;; since it was checked in the "optimistically" (define (contract-struct-equivalent? a b)
;; branch above (contract-struct-stronger/equivalent?
(let loop ([b b] [later? #f]) a b
(cond equivalent-trail
[(and later? (stronger? a b)) contract-property-equivalent
#t] #f))
[(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]))])]))
(define (contract-struct-generate c) (define (contract-struct-generate c)
(define prop (contract-struct-property c)) (define prop (contract-struct-property c))
@ -262,13 +290,14 @@
(define-logger racket/contract) (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] #:name [get-name #f]
#:first-order [get-first-order #f] #:first-order [get-first-order #f]
#:projection [get-projection #f] #:projection [get-projection #f]
#:val-first-projection [get-val-first-projection #f] #:val-first-projection [get-val-first-projection #f]
#:late-neg-projection [get-late-neg-projection #f] #:late-neg-projection [get-late-neg-projection #f]
#:stronger [stronger #f] #:stronger [stronger #f]
#:equivalent [equivalent #f]
#:generate [generate (λ (ctc) (λ (fuel) #f))] #:generate [generate (λ (ctc) (λ (fuel) #f))]
#:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))] #:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))]
#:list-contract? [list-contract? (λ (c) #f)]) #:list-contract? [list-contract? (λ (c) #f)])
@ -304,6 +333,7 @@
(or get-first-order get-any?) (or get-first-order get-any?)
get-projection get-projection
(or stronger weakest) (or stronger weakest)
(or equivalent (if equivalent-equal? equal? weakest))
generate exercise generate exercise
get-val-first-projection get-val-first-projection
(cond (cond
@ -325,13 +355,13 @@
(define build-contract-property (define build-contract-property
(procedure-rename (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)) 'build-contract-property))
(define build-flat-contract-property (define build-flat-contract-property
(procedure-rename (procedure-rename
(build-property (compose make-flat-contract-property make-contract-property) (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)) 'build-flat-contract-property))
(define (blame-context-projection-wrapper proj) (define (blame-context-projection-wrapper proj)
@ -343,7 +373,7 @@
(define build-chaperone-contract-property (define build-chaperone-contract-property
(procedure-rename (procedure-rename
(build-property (compose make-chaperone-contract-property make-contract-property) (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)) 'build-chaperone-contract-property))
(define (get-any? c) any?) (define (get-any? c) any?)
@ -383,7 +413,7 @@
(define-struct make-contract [ name first-order projection (define-struct make-contract [ name first-order projection
val-first-projection late-neg-projection val-first-projection late-neg-projection
stronger generate exercise list-contract? ] stronger equivalent generate exercise list-contract? ]
#:omit-define-syntaxes #:omit-define-syntaxes
#:property prop:custom-write #:property prop:custom-write
(λ (stct port display?) (λ (stct port display?)
@ -404,7 +434,7 @@
(define-struct make-chaperone-contract [ name first-order projection (define-struct make-chaperone-contract [ name first-order projection
val-first-projection late-neg-projection val-first-projection late-neg-projection
stronger generate exercise list-contract? ] stronger equivalent generate exercise list-contract? ]
#:omit-define-syntaxes #:omit-define-syntaxes
#:property prop:custom-write #:property prop:custom-write
(λ (stct port display?) (λ (stct port display?)
@ -425,7 +455,7 @@
(define-struct make-flat-contract [ name first-order projection (define-struct make-flat-contract [ name first-order projection
val-first-projection late-neg-projection val-first-projection late-neg-projection
stronger generate exercise list-contract? ] stronger equivalent generate exercise list-contract? ]
#:omit-define-syntaxes #:omit-define-syntaxes
#:property prop:custom-write #:property prop:custom-write
(λ (stct port display?) (λ (stct port display?)
@ -444,13 +474,14 @@
#:exercise (lambda (c) (make-flat-contract-exercise c)) #:exercise (lambda (c) (make-flat-contract-exercise c))
#:list-contract? (λ (c) (make-flat-contract-list-contract? 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] #:name [name #f]
#:first-order [first-order #f] #:first-order [first-order #f]
#:projection [projection #f] #:projection [projection #f]
#:val-first-projection [val-first-projection #f] #:val-first-projection [val-first-projection #f]
#:late-neg-projection [late-neg-projection #f] #:late-neg-projection [late-neg-projection #f]
#:stronger [stronger #f] #:stronger [stronger #f]
#:equivalent [equivalent #f]
#:generate [generate (λ (ctc) (λ (fuel) #f))] #:generate [generate (λ (ctc) (λ (fuel) #f))]
#:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))] #:exercise [exercise (λ (ctc) (λ (fuel) (values void '())))]
#:list-contract? [list-contract? #f]) #:list-contract? [list-contract? #f])
@ -485,6 +516,7 @@
[else #f])] [else #f])]
[else late-neg-projection]) [else late-neg-projection])
(or stronger weakest) (or stronger weakest)
(or equivalent (if equivalent-equal? equal? weakest))
generate exercise generate exercise
(and list-contract? #t))) (and list-contract? #t)))
@ -502,7 +534,7 @@
(define make-contract (define make-contract
(procedure-rename (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)) 'make-contract))
(define make-chaperone-contract (define make-chaperone-contract
@ -510,7 +542,7 @@
(build-contract make-make-chaperone-contract (build-contract make-make-chaperone-contract
'anonymous-chaperone-contract 'anonymous-chaperone-contract
'make-chaperone-contract 'make-chaperone-contract
#f) #f #t)
'make-chaperone-contract)) 'make-chaperone-contract))
(define make-flat-contract (define make-flat-contract
@ -518,7 +550,7 @@
(build-contract make-make-flat-contract (build-contract make-make-flat-contract
'anonymous-flat-contract 'anonymous-flat-contract
'make-flat-contract 'make-flat-contract
#t) #t #t)
'make-flat-contract)) 'make-flat-contract))
;; property should be bound to a function that accepts the contract and ;; 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? (procedure-closure-contents-eq?
(dep-dep-proc this-subcontract) (dep-dep-proc this-subcontract)
(dep-dep-proc that-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) (define (get-invariant sc)
(for/or ([sub (base-struct/dc-subcontracts sc)] (for/or ([sub (base-struct/dc-subcontracts sc)]
@ -700,6 +737,7 @@
#:first-order struct/dc-first-order #:first-order struct/dc-first-order
#:late-neg-projection struct/dc-late-neg-proj #:late-neg-projection struct/dc-late-neg-proj
#:stronger struct/dc-stronger? #:stronger struct/dc-stronger?
#:equivalent struct/dc-equivalent?
#:generate struct/dc-generate #:generate struct/dc-generate
#:exercise struct/dc-exercise)) #:exercise struct/dc-exercise))
@ -710,6 +748,7 @@
#:first-order struct/dc-flat-first-order #:first-order struct/dc-flat-first-order
#:late-neg-projection struct/dc-late-neg-proj #:late-neg-projection struct/dc-late-neg-proj
#:stronger struct/dc-stronger? #:stronger struct/dc-stronger?
#:equivalent struct/dc-equivalent?
#:generate struct/dc-generate #:generate struct/dc-generate
#:exercise struct/dc-exercise)) #:exercise struct/dc-exercise))
@ -720,6 +759,7 @@
#:first-order struct/dc-first-order #:first-order struct/dc-first-order
#:late-neg-projection struct/dc-late-neg-proj #:late-neg-projection struct/dc-late-neg-proj
#:stronger struct/dc-stronger? #:stronger struct/dc-stronger?
#:equivalent struct/dc-equivalent?
#:generate struct/dc-generate #:generate struct/dc-generate
#:exercise struct/dc-exercise)) #: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))])] (contract-struct-stronger? that-elem this-elem))])]
[else #f])) [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) () (define-struct (flat-vectorof base-vectorof) ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:flat-contract #:property prop:flat-contract
@ -143,6 +152,7 @@
(for ([x (in-vector val)]) (for ([x (in-vector val)])
(vfp+blame x neg-party)) (vfp+blame x neg-party))
val))) val)))
#:equivalent vectorof-equivalent
#:stronger vectorof-stronger)) #:stronger vectorof-stronger))
(define (blame-add-element-of-context blame #:swap? [swap? #f]) (define (blame-add-element-of-context blame #:swap? [swap? #f])
@ -258,6 +268,7 @@
(build-chaperone-contract-property (build-chaperone-contract-property
#:name vectorof-name #:name vectorof-name
#:first-order vectorof-first-order #:first-order vectorof-first-order
#:equivalent vectorof-equivalent
#:stronger vectorof-stronger #:stronger vectorof-stronger
#:late-neg-projection (vectorof-late-neg-ho-projection chaperone-vector))) #:late-neg-projection (vectorof-late-neg-ho-projection chaperone-vector)))
@ -267,6 +278,7 @@
(build-contract-property (build-contract-property
#:name vectorof-name #:name vectorof-name
#:first-order vectorof-first-order #:first-order vectorof-first-order
#:equivalent vectorof-equivalent
#:stronger vectorof-stronger #:stronger vectorof-stronger
#:late-neg-projection (vectorof-late-neg-ho-projection impersonate-vector))) #:late-neg-projection (vectorof-late-neg-ho-projection impersonate-vector)))
@ -375,7 +387,6 @@
(contract-first-order-passes? c e))))) (contract-first-order-passes? c e)))))
(define (vector/c-stronger this that) (define (vector/c-stronger this that)
;(define-struct base-vector/c (elems immutable))
(define this-elems (base-vector/c-elems this)) (define this-elems (base-vector/c-elems this))
(define this-immutable (base-vector/c-immutable this)) (define this-immutable (base-vector/c-immutable this))
(cond (cond
@ -413,6 +424,15 @@
[else #f])] [else #f])]
[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) () (define-struct (flat-vector/c base-vector/c) ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:flat-contract #:property prop:flat-contract
@ -420,6 +440,7 @@
#:name vector/c-name #:name vector/c-name
#:first-order vector/c-first-order #:first-order vector/c-first-order
#:stronger vector/c-stronger #:stronger vector/c-stronger
#:equivalent vector/c-equivalent
#:late-neg-projection #:late-neg-projection
(λ (ctc) (λ (ctc)
(λ (blame) (λ (blame)
@ -512,6 +533,7 @@
#:name vector/c-name #:name vector/c-name
#:first-order vector/c-first-order #:first-order vector/c-first-order
#:stronger vector/c-stronger #:stronger vector/c-stronger
#:equivalent vector/c-equivalent
#:late-neg-projection (vector/c-ho-late-neg-projection chaperone-vector))) #:late-neg-projection (vector/c-ho-late-neg-projection chaperone-vector)))
(define-struct (impersonator-vector/c base-vector/c) () (define-struct (impersonator-vector/c base-vector/c) ()
@ -521,6 +543,7 @@
#:name vector/c-name #:name vector/c-name
#:first-order vector/c-first-order #:first-order vector/c-first-order
#:stronger vector/c-stronger #:stronger vector/c-stronger
#:equivalent vector/c-equivalent
#:late-neg-projection (vector/c-ho-late-neg-projection impersonate-vector))) #:late-neg-projection (vector/c-ho-late-neg-projection impersonate-vector)))
(define-syntax (wrap-vector/c stx) (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-one-stronger class/c-inits class/c-init-contracts this that)
;; check both ways for fields (since mutable) ;; check both ways for fields (since mutable)
(limit-depth (check-one-equivalent class/c-fields class/c-field-contracts this that)
(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)))
;; inherits ;; inherits
(check-one-stronger internal-class/c-inherits internal-class/c-inherit-contracts (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)))] (all-included? (class/c-absents that) (class/c-absents this)))]
[else #f])) [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) (define (all-included? this-items that-items)
(for/and ([this-item (in-list this-items)]) (for/and ([this-item (in-list this-items)])
(for/or ([that-item (in-list that-items)]) (for/or ([that-item (in-list that-items)])
@ -1039,6 +1066,14 @@
(and (equal? this-name that-name) (and (equal? this-name that-name)
(contract-stronger? this-ctc that-ctc))))) (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 (define-struct class/c
(methods method-contracts fields field-contracts inits init-contracts (methods method-contracts fields field-contracts inits init-contracts
absents absent-fields absents absent-fields
@ -1050,6 +1085,7 @@
#:late-neg-projection class/c-late-neg-proj #:late-neg-projection class/c-late-neg-proj
#:name build-class/c-name #:name build-class/c-name
#:stronger class/c-stronger #:stronger class/c-stronger
#:equivalent class/c-equivalent
#:first-order #:first-order
(λ (ctc) (λ (ctc)
(λ (cls) (λ (cls)
@ -1468,6 +1504,11 @@
(contract-stronger? (base-instanceof/c-class-ctc this) (contract-stronger? (base-instanceof/c-class-ctc this)
(base-instanceof/c-class-ctc that)))) (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) (define-struct base-instanceof/c (class-ctc)
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:contract #:property prop:contract
@ -1477,6 +1518,7 @@
(λ (ctc) (λ (ctc)
(build-compound-type-name 'instanceof/c (base-instanceof/c-class-ctc ctc))) (build-compound-type-name 'instanceof/c (base-instanceof/c-class-ctc ctc)))
#:first-order instanceof/c-first-order #:first-order instanceof/c-first-order
#:equivalent instanceof/c-equivalent
#:stronger instanceof/c-stronger)) #:stronger instanceof/c-stronger))
(define/subexpression-pos-prop (instanceof/c cctc) (define/subexpression-pos-prop (instanceof/c cctc)
@ -1550,15 +1592,24 @@
(object/c-width-subtype? this that))] (object/c-width-subtype? this that))]
[else #f])) [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) (define (object/c-common-methods-stronger? this that)
(check-one-object base-object/c-methods base-object/c-method-contracts this that)) (check-one-object base-object/c-methods base-object/c-method-contracts this that))
(define (object/c-common-fields-stronger? this that) (define (object/c-common-fields-stronger? this that)
;; check both ways for fields (since mutable) ;; check both ways for fields (since mutable)
(limit-depth (check-one-object/equivalent base-object/c-fields base-object/c-field-contracts this that))
(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))))
;; True if `this` has at least as many field / method names as `that` ;; True if `this` has at least as many field / method names as `that`
(define (object/c-width-subtype? this that) (define (object/c-width-subtype? this that)
@ -1585,6 +1636,22 @@
any/c any/c
that-ctc))))))) 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) (define-struct base-object/c (methods method-contracts fields field-contracts)
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:contract #:property prop:contract
@ -1598,6 +1665,7 @@
(base-object/c-fields ctc) (base-object/c-fields ctc)
(base-object/c-field-contracts ctc))) (base-object/c-field-contracts ctc)))
#:first-order object/c-first-order #:first-order object/c-first-order
#:equivalent object/c-equivalent
#:stronger object/c-stronger)) #:stronger object/c-stronger))
(define (build-object/c-type-name name method-names method-ctcs field-names field-ctcs) (define (build-object/c-type-name name method-names method-ctcs field-names field-ctcs)