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

make real? and (between/c -inf.0 +inf.0) be the same contract

Browse Source 
mostly this just makes contract-stronger? work (slightly) better
This commit is contained in:
Robby Findler 2016-12-28 18:56:30 -06:00
parent f039a4c571
commit 9019e8b318
7 changed files with 41 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
pkgs/racket-test/tests/racket/contract/name.rkt
View File

@ -236,7 +236,7 @@
(test-name '(</c 5) (</c 5))
(test-name '(>/c 5) (>/c 5))
(test-name '(between/c 5 6) (between/c 5 6))
(test-name '(between/c -inf.0 +inf.0) (between/c -inf.0 +inf.0))
(test-name 'real? (between/c -inf.0 +inf.0))
(test-name '5 (between/c 5 5))
(test-name '(integer-in 0 10) (integer-in 0 10))
(test-name '(char-in #\a #\z) (char-in #\a #\z))

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

@ -20,6 +20,8 @@
(ctest #f contract-stronger? (char-in #\a #\z) (char-in #\f #\q))
(ctest #t contract-stronger? (between/c 1 3) (between/c 0 4))
(ctest #f contract-stronger? (between/c 0 4) (between/c 1 3))
(ctest #t contract-stronger? (between/c -inf.0 +inf.0) real?)
(ctest #t contract-stronger? real? (between/c -inf.0 +inf.0))
(ctest #t contract-stronger? (>=/c 3) (>=/c 2))
(ctest #f contract-stronger? (>=/c 2) (>=/c 3))
(ctest #f contract-stronger? (<=/c 3) (<=/c 2))
@ -280,6 +282,7 @@
(ctest #f contract-stronger? string? "x")
(ctest #t contract-stronger? 1 real?)
(ctest #t contract-stronger? 1 (between/c -10 10))
(ctest #f contract-stronger? real? 1)
(ctest #t contract-stronger? 'x symbol?)

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

@ -82,8 +82,6 @@
contract-custom-write-property-proc
(rename-out [contract-custom-write-property-proc custom-write-property-proc])
set-some-basic-contracts!
blame?
blame-source
blame-positive

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

@ -70,7 +70,8 @@
contract-name
maybe-warn-about-val-first
set-some-basic-contracts!
set-some-basic-list-contracts!
set-some-basic-misc-contracts!
contract-first-order-okay-to-give-up?
contract-first-order-try-less-hard
@ -294,18 +295,30 @@
(struct name-default ())
(values (name-default) name-default?)))
;; these two definitions work around a cyclic
;; these definitions work around a cyclic
;; dependency. When we coerce a value to a contract,
;; we want to use (listof any/c) for list?, but
;; the files are not set up for that, so we just
;; bang it in here and use it only after it's been banged in.
;; ditto for: (cons/c any/c any/c), (list/c), and (between/c -inf.0 +inf.0)
;; the selectors and predicate for `between/c-s` are used
;; to get contract-stronger right for numeric constants
(define listof-any #f)
(define consc-anyany #f)
(define list/c-empty #f)
(define (set-some-basic-contracts! l p mt)
(define (set-some-basic-list-contracts! l p mt)
(set! listof-any l)
(set! consc-anyany p)
(set! list/c-empty mt))
(define between/c-inf+inf #f)
(define between/c-s? #f)
(define between/c-s-low #f)
(define between/c-s-high #f)
(define (set-some-basic-misc-contracts! b b/c-s? b/c-s-l b/c-s-h)
(set! between/c-inf+inf b)
(set! between/c-s? b/c-s?)
(set! between/c-s-low b/c-s-l)
(set! between/c-s-high b/c-s-h))
(define (coerce-contract/f x [name name-default])
(define (coerce-simple-value x)
@ -323,6 +336,10 @@
(unless consc-anyany
(error 'coerce-contract/f::consc-anyany "too soon!"))
consc-anyany]
[(chaperone-of? x real?)
(unless between/c-inf+inf
(error 'coerce-contract/f::between/c-inf+inf "too soon!"))
between/c-inf+inf]
[else
(make-predicate-contract (if (name-default? name)
(or (object-name x) '???)
@ -544,6 +561,8 @@
(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)))
(and (predicate-contract? that)
(predicate-contract-sane? that)
((predicate-contract-pred that) this-val))))

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

@ -987,8 +987,8 @@
(impersonator-*list/c (car ctcs) (cdr ctcs))]))
;; this is a hack to work around cyclic linking issues;
;; see definition of set-some-basic-contracts!
(set-some-basic-contracts!
;; see definition of set-some-basic-list-contracts!
(set-some-basic-list-contracts!
(listof any/c)
(cons/c any/c any/c)
(list/c))

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

@ -179,7 +179,7 @@
(define name (if (real-in-s? ctc) 'real-in 'between/c))
(cond
[(and (= n -inf.0) (= m +inf.0))
`(,name ,n ,m)]
'real?]
[(= n -inf.0) `(<=/c ,m)]
[(= m +inf.0) `(>=/c ,n)]
[(= n m) `(=/c ,n)]
@ -286,6 +286,11 @@
1
arg1 arg2)))
(set-some-basic-misc-contracts! (between/c -inf.0 +inf.0)
between/c-s?
between/c-s-low
between/c-s-high)
(define (char-in a b)
(check-two-args 'char-in a b char? char?)
(char-in/c a b))

10
racket/collects/racket/contract/private/opters.rkt
View File

@ -201,11 +201,15 @@
[that that])
(syntax (<= this that))))))
#:chaperone #t
#:name #'(if (= n m)
n
'(between/c n m)))))))]
#:name #'(between/c-opt-name n m))))))]
[_ (opt/unknown opt/i opt/info stx)]))
(define (between/c-opt-name n m)
(cond
[(= n m) n]
[(and (= n -inf.0) (= m +inf.0)) 'real?]
[else `(between/c ,n ,m)]))
(define (raise-opt-between/c-error blame val lo hi)
(raise-blame-error
blame