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

make stronger recognize any/c on the right as stronger than any flat contracts

Browse Source
This commit is contained in:
Robby Findler 2016-01-01 19:46:45 -06:00
parent b24882fd18
commit 2529e63b74
3 changed files with 21 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
pkgs/racket-test/tests/racket/contract/stronger.rkt
View File

@ -10,6 +10,7 @@
(contract-eval '(define-contract-struct triple (a b c)))
(ctest #t contract-stronger? any/c any/c)
(ctest #t contract-stronger? integer? any/c)
(ctest #t contract-stronger? (integer-in 0 4) (integer-in 0 4))
(ctest #t contract-stronger? (integer-in 1 3) (integer-in 0 4))
(ctest #f contract-stronger? (integer-in 0 4) (integer-in 1 3))
@ -74,6 +75,8 @@
(ctest #t contract-stronger? (-> #:x (>=/c 3) (>=/c 3)) (-> #:x (>=/c 3) (>=/c 2)))
(ctest #t contract-stronger? (-> any/c any/c any) (-> any/c any/c any))
(ctest #f contract-stronger? (-> any/c any/c any/c any) (-> any/c any/c any))
(ctest #t contract-stronger? (-> (-> any/c) integer?) (-> (-> any/c) any/c))
(ctest #f contract-stronger? (-> (-> any/c) any/c) (-> (-> any/c) integer?))
(let ([c (contract-eval '(->* () () any))])
(test #t (contract-eval 'contract-stronger?) c c))
@ -89,8 +92,8 @@
(->* () integer? #:post (zero? (random 10)))
(->* () integer? #:post (zero? (random 10))))
(ctest #t contract-stronger? (or/c null? any/c) (or/c null? any/c))
(ctest #f contract-stronger? (or/c null? any/c) (or/c boolean? any/c))
(ctest #t contract-stronger? (or/c null? #f) (or/c null? #f))
(ctest #f contract-stronger? (or/c null? #f) (or/c boolean? #f))
(ctest #t contract-stronger? (or/c null? boolean?) (or/c null? boolean?))
(ctest #t contract-stronger? (or/c null? boolean?) (or/c boolean? null?))
(ctest #t contract-stronger?
@ -111,8 +114,8 @@
(ctest #f contract-stronger? (-> (or/c #f number?)) (-> number?))
(ctest #f contract-stronger? (-> number? any/c) (-> (or/c #f number?) any/c))
(ctest #t contract-stronger? (first-or/c null? any/c) (first-or/c null? any/c))
(ctest #f contract-stronger? (first-or/c null? any/c) (first-or/c boolean? any/c))
(ctest #t contract-stronger? (first-or/c null? #f) (first-or/c null? #f))
(ctest #f contract-stronger? (first-or/c null? #f) (first-or/c boolean? #f))
(ctest #t contract-stronger? (first-or/c null? boolean?) (first-or/c null? boolean?))
(ctest #t contract-stronger? (first-or/c null? boolean?) (first-or/c boolean? null?))
(ctest #t contract-stronger?
@ -133,13 +136,13 @@
(ctest #f contract-stronger? (-> (first-or/c #f number?)) (-> number?))
(ctest #f contract-stronger? (-> number? any/c) (-> (first-or/c #f number?) any/c))
(ctest #t contract-stronger? (first-or/c null? any/c) (or/c null? any/c))
(ctest #f contract-stronger? (first-or/c null? any/c) (or/c boolean? any/c))
(ctest #t contract-stronger? (first-or/c null? #f) (or/c null? #f))
(ctest #f contract-stronger? (first-or/c null? #f) (or/c boolean? #f))
(ctest #t contract-stronger? (first-or/c null? boolean?) (or/c null? boolean?))
(ctest #t contract-stronger? (first-or/c null? boolean?) (or/c boolean? null?))
(ctest #t contract-stronger? (or/c null? any/c) (first-or/c null? any/c))
(ctest #f contract-stronger? (or/c null? any/c) (first-or/c boolean? any/c))
(ctest #t contract-stronger? (or/c null? #f) (first-or/c null? #f))
(ctest #f contract-stronger? (or/c null? #f) (first-or/c boolean? #f))
(ctest #t contract-stronger? (or/c null? boolean?) (first-or/c null? boolean?))
(ctest #t contract-stronger? (or/c null? boolean?) (first-or/c boolean? null?))
@ -176,7 +179,7 @@
(or/c (-> string?) (-> integer? integer?))
(or/c (-> string?) (-> any/c integer?)))
(ctest #f contract-stronger?
(or/c (-> string?) (-> any/c integer?))
(or/c (-> string?) (-> #f integer?))
(or/c (-> string?) (-> integer? integer?)))
(ctest #t contract-stronger?
(or/c (-> string?) (-> integer? integer?) integer? boolean?)

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

@ -1447,6 +1447,7 @@
(define-struct any/c ()
#:property prop:custom-write custom-write-property-proc
#:omit-define-syntaxes
#:property prop:any/c #f
#:property prop:flat-contract
(build-flat-contract-property
#:late-neg-projection (λ (ctc) any/c-blame->neg-party-fn)

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

@ -52,6 +52,8 @@
prop:arrow-contract-get-info
(struct-out arrow-contract-info)
prop:any/c prop:any/c?
build-context)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -124,6 +126,7 @@
[(stronger? a b)
;; optimistically try skip some of the more complex work below
#t]
[(and (flat-contract-struct? a) (prop:any/c? b)) #t] ;; is the flat-check needed here?
[(let ([th (trail)])
(and th
(for/or ([(a2 bs-h) (in-hash th)])
@ -531,6 +534,11 @@
prop:recursive-contract-unroll)
(make-struct-type-property 'prop:recursive-contract))
;; this property's value isn't looked at; it is just a signal
;; that the contract accepts any value
(define-values (prop:any/c prop:any/c? prop:get-any/c)
(make-struct-type-property 'prop:any/c))
;; get-info : (-> ctc arrow-contract-info?)
(define-values (prop:arrow-contract prop:arrow-contract? prop:arrow-contract-get-info)
(make-struct-type-property 'prop:arrow-contract))