diff --git a/pkgs/racket-test/tests/racket/contract-rand-test.rkt b/pkgs/racket-test/tests/racket/contract-rand-test.rkt index d7cf7ff6c9..099decc9a0 100644 --- a/pkgs/racket-test/tests/racket/contract-rand-test.rkt +++ b/pkgs/racket-test/tests/racket/contract-rand-test.rkt @@ -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?)))) diff --git a/pkgs/racket-test/tests/racket/contract/name.rkt b/pkgs/racket-test/tests/racket/contract/name.rkt index f314e3947a..a077488eb7 100644 --- a/pkgs/racket-test/tests/racket/contract/name.rkt +++ b/pkgs/racket-test/tests/racket/contract/name.rkt @@ -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)) diff --git a/pkgs/racket-test/tests/racket/contract/stronger.rkt b/pkgs/racket-test/tests/racket/contract/stronger.rkt index 0edeab8368..1a159ab71a 100644 --- a/pkgs/racket-test/tests/racket/contract/stronger.rkt +++ b/pkgs/racket-test/tests/racket/contract/stronger.rkt @@ -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)) diff --git a/racket/collects/racket/contract/private/guts.rkt b/racket/collects/racket/contract/private/guts.rkt index 90fbd54b85..a804c13436 100644 --- a/racket/collects/racket/contract/private/guts.rkt +++ b/racket/collects/racket/contract/private/guts.rkt @@ -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 diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index 11a357e9a2..907f1141a5 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -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?)