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

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?))))

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))

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))

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

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)]
+  (char-in/c a b))
-         [y (char->integer b)]
-         [ctc (integer-in x y)])
-    (flat-named-contract
-     `(char-in ,a ,b)
-     (λ (c) (and (char? c)
-                 (ctc (char->integer c)))))))
 
 (define/final-prop (real-in start end)
   (check-two-args 'real-in start end real? real?)