clean up a bunch of contract names

2017-05-06 22:10:41 -05:00 · 2017-05-06 22:10:41 -05:00 · 79cef0a96e
commit 79cef0a96e
parent 2db8523eb5
5 changed files with 45 additions and 45 deletions
--- a/pkgs/racket-test/tests/racket/contract/name.rkt
+++ b/pkgs/racket-test/tests/racket/contract/name.rkt
@ -241,10 +241,13 @@
  (test-name '(and/c real? (not/c positive?)) (and/c real? (not/c positive?)))
  (test-name '(and/c real? negative?) (and/c real? negative?))
  (test-name '(and/c real? (not/c negative?)) (and/c real? (not/c negative?)))
-  (test-name '(and/c real? positive?) (>/c 0))
-  (test-name '(and/c real? (not/c positive?)) (<=/c 0))
-  (test-name '(and/c real? negative?) (</c 0))
-  (test-name '(and/c real? (not/c negative?)) (>=/c 0))
+  (test-name '(>/c 0) (>/c 0))
+  (test-name '(<=/c 0) (<=/c 0))
+  (test-name '(</c 0) (</c 0))
+  (test-name '(>=/c 0) (>=/c 0))
+  (test-name '(between/c 0 +inf.0) (between/c 0 +inf.0))
+  (test-name '(between/c -inf.0 0) (between/c -inf.0 0))
+  (test-name '(between/c 1 1) (between/c 1 1))

  (test-name '(not/c integer?) (not/c integer?))
  (test-name '(=/c 5) (=/c 5))
@ -253,8 +256,8 @@
  (test-name '(</c 5) (</c 5))
  (test-name '(>/c 5) (>/c 5))
  (test-name '(between/c 5 6) (between/c 5 6))
-  (test-name 'real? (between/c -inf.0 +inf.0))
-  (test-name '5 (between/c 5 5))
+  (test-name '(between/c -inf.0 +inf.0) (between/c -inf.0 +inf.0))
+  (test-name '(between/c 5 5) (between/c 5 5))
  (test-name '(integer-in 0 10) (integer-in 0 10))
  (test-name '(integer-in 10 #f) (integer-in 10 #f))
  (test-name '(integer-in #f 10) (integer-in #f 10))
--- a/racket/collects/racket/contract/private/and.rkt
+++ b/racket/collects/racket/contract/private/and.rkt
@ -193,16 +193,16 @@
             (define second-pred (cadr preds))
             (cond
               [(chaperone-of? second-pred negative?)
-                (</c 0)]
+                (renamed-<-ctc 0 `(and/c real? negative?))]
               [(chaperone-of? second-pred positive?)
-                (>/c 0)]
+                (renamed->-ctc 0 `(and/c real? positive?))]
               [else
                (define second-contract (cadr contracts))
                (cond
                  [(equal? (contract-name second-contract) '(not/c positive?))
-                   (<=/c 0)]
+                   (renamed-between/c -inf.0 0 `(and/c real? (not/c positive?)))]
                  [(equal? (contract-name second-contract) '(not/c negative?))
-                   (>=/c 0)]
+                   (renamed-between/c 0 +inf.0 `(and/c real? (not/c negative?)))]
                  [else
                   (make-first-order-and/c contracts preds)])])]
            [(or (chaperone-of? (car preds) exact-nonnegative-integer?)
--- a/racket/collects/racket/contract/private/guts.rkt
+++ b/racket/collects/racket/contract/private/guts.rkt
@ -318,13 +318,13 @@
  (set! listof-any l)
  (set! consc-anyany p)
  (set! list/c-empty mt))
-(define between/c-inf+inf #f)
+(define between/c-inf+inf-as-real? #f)
 (define renamed-between/c #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 r-b b/c-s? b/c-s-l b/c-s-h)
-  (set! between/c-inf+inf b)
+  (set! between/c-inf+inf-as-real? b)
  (set! renamed-between/c r-b)
  (set! between/c-s? b/c-s?)
  (set! between/c-s-low b/c-s-l)
@ -368,10 +368,10 @@
          (error 'coerce-contract/f::consc-anyany "too soon!"))
        consc-anyany]
       [(chaperone-of? x real?)
-        (unless between/c-inf+inf
+        (unless between/c-inf+inf-as-real?
          (error 'coerce-contract/f::between/c-inf+inf "too soon!"))
        (if (name-default? name)
-            between/c-inf+inf
+            between/c-inf+inf-as-real?
            (renamed-between/c -inf.0 +inf.0 name))]
       [(chaperone-of? x exact-positive-integer?)
        (if (name-default? name) integer-in-1f (renamed-integer-in 1 #f name))]
--- a/racket/collects/racket/contract/private/misc.rkt
+++ b/racket/collects/racket/contract/private/misc.rkt
@ -14,6 +14,7 @@
 (provide flat-murec-contract
         not/c
         =/c >=/c <=/c </c >/c between/c
+         renamed->-ctc renamed-<-ctc
         char-in
         real-in
         natural-number/c
@ -28,7 +29,7 @@
         parameter/c
         procedure-arity-includes/c
         
-         any/c  any/c?
+         any/c any/c?
         any
         none/c
         make-none/c
@ -55,7 +56,8 @@

         flat-contract-with-explanation

-         (struct-out between/c-s))
+         (struct-out between/c-s)
+         renamed-between/c)

 (define-syntax (flat-murec-contract stx)
  (syntax-case stx  ()
@ -178,18 +180,18 @@
  (build-flat-contract-property
   #:name
   (λ (ctc)
-     (define n (between/c-s-low ctc))
-     (define m (between/c-s-high ctc))
-     (define name (if (renamed-between/c? ctc) (renamed-between/c-name ctc) 'between/c))
     (cond
-       [(and (= n -inf.0) (= m +inf.0))
-        (if (renamed-between/c? ctc)
-            (renamed-between/c-name ctc)
-            'real?)]
-       [(= n -inf.0) (if (= m 0) `(and/c real? (not/c positive?)) `(<=/c ,m))]
-       [(= m +inf.0) (if (= n 0) `(and/c real? (not/c negative?)) `(>=/c ,n))]
-       [(= n m) `(=/c ,n)]
-       [else `(,name ,n ,m)]))
+       [(renamed-between/c? ctc) (renamed-between/c-name ctc)]
+       [else
+        `(between/c ,(between/c-s-low ctc) ,(between/c-s-high ctc))
+        #;
+        (cond
+          [(and (= n -inf.0) (= m +inf.0))
+           'real?]
+          [(= n -inf.0) (if (= m 0) `(and/c real? (not/c positive?)) `(<=/c ,m))]
+          [(= m +inf.0) (if (= n 0) `(and/c real? (not/c negative?)) `(>=/c ,n))]
+          [(= n m) `(=/c ,n)]
+          [else ])]))
   #:stronger between/c-stronger
   #:first-order between/c-first-order
   #:generate between/c-generate))
@ -203,29 +205,28 @@

 (define/final-prop (=/c x) 
  (check-unary-between/c '=/c x)
-  (make-between/c-s x x))
+  (make-renamed-between/c x x `(=/c ,x)))
 (define/final-prop (<=/c x) 
  (check-unary-between/c '<=/c x)
-  (make-between/c-s -inf.0 x))
+  (make-renamed-between/c -inf.0 x `(<=/c ,x)))
 (define/final-prop (>=/c x)
  (check-unary-between/c '>=/c x)
-  (make-between/c-s x +inf.0))
+  (make-renamed-between/c x +inf.0 `(>=/c ,x)))
 (define (check-between/c x y)
  (check-two-args 'between/c x y real? real?))
 (define/final-prop (between/c x y)
  (check-between/c x y)
  (if (= x y)
-      (coerce-contract 'between/c x)
+      (make-renamed-between/c x x `(between/c ,x ,y))
      (make-between/c-s x y)))

 (define (make-</c->/c-contract-property name </> -/+ less/greater)
  (build-flat-contract-property
   #:name (λ (c)
            (cond
-              [(= (</>-ctc-x c) 0)
-               `(and/c real? ,(if (equal? name '>/c) 'positive? 'negative?))]
-              [else
-               `(,name ,(</>-ctc-x c))]))
+              [(renamed-<-ctc? c) (renamed-<-ctc-name c)]
+              [(renamed->-ctc? c) (renamed->-ctc-name c)]
+              [else `(,name ,(</>-ctc-x c))]))
   #:first-order (λ (ctc) (define x (</>-ctc-x ctc)) (λ (y) (and (real? y) (</> y x))))
   #:late-neg-projection
   (λ (ctc)
@ -278,11 +279,13 @@
  #:property prop:flat-contract
  (make-</c->/c-contract-property '</c < - "less")
  #:property prop:custom-write custom-write-property-proc)
+(struct renamed-<-ctc <-ctc (name))
 (define (</c x) (<-ctc x))
 (struct >-ctc </>-ctc ()
  #:property prop:flat-contract
  (make-</c->/c-contract-property '>/c > + "greater")
  #:property prop:custom-write custom-write-property-proc)
+(struct renamed->-ctc >-ctc (name))
 (define (>/c x) (>-ctc x))

 (define (check-two-args name arg1 arg2 pred1? pred2?)
@ -297,7 +300,7 @@
                          1
                          arg1 arg2)))

-(set-some-basic-misc-contracts! (between/c -inf.0 +inf.0)
+(set-some-basic-misc-contracts! (renamed-between/c -inf.0 +inf.0 'real?)
                                renamed-between/c
                                between/c-s?
                                between/c-s-low
@ -309,7 +312,7 @@

 (define/final-prop (real-in start end)
  (check-two-args 'real-in start end real? real?)
-  (make-renamed-between/c start end 'real-in))
+  (make-renamed-between/c start end `(real-in ,start ,end)))

 (define/final-prop (not/c f)
  (let* ([ctc (coerce-flat-contract 'not/c f)]
--- a/racket/collects/racket/contract/private/opters.rkt
+++ b/racket/collects/racket/contract/private/opters.rkt
@ -204,11 +204,7 @@
              #: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 (between/c-opt-name n m) `(between/c ,n ,m))

 (define (raise-opt-between/c-error blame val lo hi)
  (raise-blame-error
@ -248,9 +244,7 @@
                                    [that that])
                        (syntax (comparison this that))))))
             #:chaperone #t
-             #:name #`(if (= m 0)
-                          '#,special-name
-                          '(#,name m)))))))))
+             #:name #`'(#,name m))))))))

 (define (raise-opt-single-comparison-opter-error blame val comparison m predicate?)
  (raise-blame-error