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

add another special case to and/c to detect a situation that's really just integer-in

Browse Source
This commit is contained in:
Robby Findler 2018-09-03 20:29:31 -05:00
parent 416447e842
commit 988e0d441b
4 changed files with 42 additions and 0 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

@ -266,6 +266,8 @@
(test-name 'exact-positive-integer? (integer-in 1 #f))
(test-name '(char-in #\a #\z) (char-in #\a #\z))
(test-name '(and/c 0 exact?) (integer-in 0 0))
;; this next one is convenient, using the and/c name would also be okay
(test-name '(integer-in 0 9) (and/c (</c 10) exact-integer? (>=/c 0)))
(test-name '(real-in 1 10) (real-in 1 10))
(test-name '(between/c 1 10) (between/c 1 10))
(test-name '(string-len/c 3) (string-len/c 3))

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

@ -23,6 +23,13 @@
(ctest #t contract-stronger? (integer-in #f 0) (integer-in #f #f))
(ctest #t contract-stronger? (integer-in 0 0) (and/c 0 exact?))
(ctest #t contract-stronger? (and/c 0 exact?) (integer-in 0 0))
(ctest #t contract-stronger? (and/c exact-integer? (>=/c 1) (<=/c 10)) (integer-in 1 10))
(ctest #t contract-stronger? (integer-in 1 10) (and/c exact-integer? (>=/c 1) (<=/c 10)))
(ctest #t contract-stronger? (and/c exact-integer? (<=/c 10) (>/c 1)) (integer-in 2 10))
(ctest #t contract-stronger? (integer-in 2 10) (and/c exact-integer? (<=/c 10) (>/c 1)))
(ctest #t contract-stronger? (and/c exact-integer? (</c 10) (>/c 1)) (integer-in 2 9))
(ctest #t contract-stronger? (integer-in 2 9) (and/c exact-integer? (</c 10) (>/c 1)))
(ctest #t contract-stronger? (integer-in 2 9) (and/c exact-integer? (</c 10.0) (>/c 1.0)))
(ctest #t contract-stronger? exact-integer? (integer-in #f #f))
(ctest #t contract-stronger? (integer-in #f #f) exact-integer?)
(ctest #t contract-stronger? (integer-in 0 #f) exact-nonnegative-integer?)

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

@ -247,6 +247,36 @@
[else (make-first-order-and/c contracts preds)])]
[else
(make-first-order-and/c contracts preds)])]
[(and (pair? (cdr preds))
(pair? (cddr preds))
(null? (cdddr preds)))
(cond
[(or (chaperone-of? (car preds) exact-integer?)
(chaperone-of? (cadr preds) exact-integer?)
(chaperone-of? (caddr preds) exact-integer?))
(define lb #f)
(define ub #f)
(for ([ctc (in-list contracts)])
(cond
[(between/c-s? ctc)
(define lo (between/c-s-low ctc))
(define hi (between/c-s-high ctc))
(cond
[(and (= lo -inf.0) (integer? hi))
(set! ub (inexact->exact hi))]
[(and (= hi +inf.0) (integer? lo))
(set! lb (inexact->exact lo))])]
[(</>-ctc? ctc)
(define x (</>-ctc-x ctc))
(when (integer? x)
(cond
[(<-ctc? ctc) (set! ub (- (inexact->exact x) 1))]
[(>-ctc? ctc) (set! lb (+ (inexact->exact x) 1))]))]))
(cond
[(and lb ub)
(integer-in lb ub)]
[else (make-first-order-and/c contracts preds)])]
[else (make-first-order-and/c contracts preds)])]
[else
(make-first-order-and/c contracts preds)])]
[(andmap chaperone-contract? contracts)

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

@ -58,6 +58,9 @@
flat-contract-with-explanation
(struct-out between/c-s)
(struct-out </>-ctc)
(struct-out <-ctc)
(struct-out >-ctc)
renamed-between/c)
(define-syntax (flat-murec-contract stx)