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

add support for random generation and contract stronger to char-in

Browse Source
This commit is contained in:
Robby Findler 2015-05-08 16:55:27 -05:00
parent aa4c57bf9a
commit bd5723c51c
5 changed files with 48 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -42,6 +42,8 @@
(check-not-exn (λ () (test-contract-generation (integer-in 0 100))))
(check-not-exn (λ () (test-contract-generation (integer-in 0 (expt 2 1000)))))
(check-not-exn (λ () (test-contract-generation (char-in #\a #\z))))
(check-not-exn (λ () (test-contract-generation #\a)))
(check-not-exn (λ () (test-contract-generation (between/c 1 100))))
(check-not-exn (λ () (test-contract-generation (between/c 1.0 100.0))))
(check-not-exn (λ () (test-contract-generation (listof integer?))))

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

@ -185,6 +185,7 @@
(test-name '(between/c -inf.0 +inf.0) (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))
(test-name '(and/c 0 exact?) (integer-in 0 0))
(test-name '(real-in 1 10) (real-in 1 10))
(test-name '(between/c 1 10) (between/c 1 10))

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

@ -13,6 +13,10 @@
(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))
(ctest #t contract-stronger? #\a (char-in #\a #\c))
(ctest #f contract-stronger? #\a (char-in #\b #\c))
(ctest #t contract-stronger? (char-in #\f #\q) (char-in #\a #\z))
(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? (>=/c 3) (>=/c 2))

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

@ -45,6 +45,7 @@
eq-contract-val
equal-contract?
equal-contract-val
char-in/c
contract-continuation-mark-key
@ -243,7 +244,7 @@
#f
(memq x the-known-good-contracts))])]
[(null? x) list/c-empty]
[(or (symbol? x) (boolean? x) (char? x) (keyword? x))
[(or (symbol? x) (boolean? x) (keyword? x))
(make-eq-contract x
(if (name-default? name)
(if (or (null? x)
@ -251,6 +252,7 @@
`',x
x)
name))]
[(char? x) (make-char-in/c x x)]
[(or (bytes? x) (string? x) (equal? +nan.0 x) (equal? +nan.f x))
(make-equal-contract x (if (name-default? name) x name))]
[(number? x)
@ -476,6 +478,43 @@
;; otherwise, just stick with the original number (80% of the time)
v]))])))))
(define-struct char-in/c (low high)
#:property prop:custom-write contract-custom-write-property-proc
#:property prop:flat-contract
(build-flat-contract-property
#:first-order
(λ (ctc)
(define low (char-in/c-low ctc))
(define high (char-in/c-high ctc))
(λ (x)
(and (char? x)
(char<=? low x high))))
#:name (λ (ctc)
(define low (char-in/c-low ctc))
(define high (char-in/c-high ctc))
(if (equal? low high)
low
`(char-in ,low ,high)))
#:stronger
(λ (this that)
(cond
[(char-in/c? that)
(define this-low (char-in/c-low this))
(define this-high (char-in/c-high this))
(define that-low (char-in/c-low that))
(define that-high (char-in/c-high that))
(and (char<=? that-low this-low)
(char<=? this-high that-high))]
[else #f]))
#:generate
(λ (ctc)
(define low (char->integer (char-in/c-low ctc)))
(define high (char->integer (char-in/c-high ctc)))
(define delta (+ (- high low) 1))
(λ (fuel)
(λ ()
(integer->char (+ low (random delta))))))))
(define-struct regexp/c (reg name)
#:property prop:custom-write contract-custom-write-property-proc
#:property prop:flat-contract

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

@ -553,13 +553,7 @@
(define (char-in a b)
(check-two-args 'char-in a b char? char?)
(let* ([x (char->integer a)]
[y (char->integer b)]
[ctc (integer-in x y)])
(flat-named-contract
`(char-in ,a ,b)
(λ (c) (and (char? c)
(ctc (char->integer c)))))))
(char-in/c a b))
(define/final-prop (real-in start end)
(check-two-args 'real-in start end real? real?)