From 66b199307ca1aa80b7457d8cd73645a35959d3a4 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 29 Dec 2016 09:03:59 -0600 Subject: [PATCH] Adjust and/c so that it cooperates with between/c Specifically, when it sees these contracts: (and/c real? negative?) (and/c real? positive?) (and/c real? (not/c positive?)) (and/c real? (not/c negative?)) it generates the corresponding use of >=/c, <=/c, /c, but those contracts have also been adjusted to report their names as (and/c real? ...). This mostly is an improvement for contract-stronger, but also make it so that (between/c -inf.0 +inf.0) just uses the real? predicate directly, instead of a more complex function --- .../tests/racket/contract/flat-contracts.rkt | 5 ++++ .../tests/racket/contract/name.rkt | 13 ++++++++-- .../tests/racket/contract/stronger.rkt | 10 ++++++++ .../collects/racket/contract/private/and.rkt | 24 +++++++++++++++++-- .../collects/racket/contract/private/misc.rkt | 19 ++++++++++----- .../racket/contract/private/opters.rkt | 22 +++++++++++------ 6 files changed, 76 insertions(+), 17 deletions(-) diff --git a/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt b/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt index 1cd5869f35..b711c42992 100644 --- a/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt +++ b/pkgs/racket-test/tests/racket/contract/flat-contracts.rkt @@ -53,6 +53,11 @@ (test-flat-contract 'natural-number/c 0 -1) (test-flat-contract 'false/c #f #t) (test-flat-contract 'contract? #f (λ (x y) 'whatever)) + + (test-flat-contract '(and/c real? negative?) -1 0) + (test-flat-contract '(and/c real? positive?) 1 0) + (test-flat-contract '(and/c real? (not/c positive?)) 0 1) + (test-flat-contract '(and/c real? (not/c negative?)) 0 -1) (test-flat-contract #t #t "x") (test-flat-contract #f #f "x") diff --git a/pkgs/racket-test/tests/racket/contract/name.rkt b/pkgs/racket-test/tests/racket/contract/name.rkt index 53e4a6808d..cd80deca1c 100644 --- a/pkgs/racket-test/tests/racket/contract/name.rkt +++ b/pkgs/racket-test/tests/racket/contract/name.rkt @@ -229,6 +229,15 @@ (test-name '(and/c (-> boolean? boolean?) (-> integer? integer?)) (and/c (-> boolean? boolean?) (-> integer? integer?))) + (test-name '(and/c real? positive?) (and/c real? positive?)) + (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 '(not/c integer?) (not/c integer?)) (test-name '(=/c 5) (=/c 5)) (test-name '(>=/c 5) (>=/c 5)) @@ -434,13 +443,13 @@ (test-name '(class/c (absent a b c (field d e f))) (class/c (absent a b c (field d e f)))) (test-name '(class/c (absent a b c)) (class/c (absent a b c))) (test-name '(class/c (inherit [f integer?]) - (super [m (->m (<=/c 0) integer?)]) + (super [m (->m (<=/c -1) integer?)]) (inner [n (->m (<=/c 1) integer?)]) (override [o (->m (<=/c 2) integer?)]) (augment [p (->m (<=/c 3) integer?)]) (augride [q (->m (<=/c 4) integer?)])) (class/c (inherit [f integer?]) - (super [m (->m (<=/c 0) integer?)]) + (super [m (->m (<=/c -1) integer?)]) (inner [n (->m (<=/c 1) integer?)]) (override [o (->m (<=/c 2) integer?)]) (augment [p (->m (<=/c 3) integer?)]) diff --git a/pkgs/racket-test/tests/racket/contract/stronger.rkt b/pkgs/racket-test/tests/racket/contract/stronger.rkt index 5bd1ae9e9a..0a5905d8fc 100644 --- a/pkgs/racket-test/tests/racket/contract/stronger.rkt +++ b/pkgs/racket-test/tests/racket/contract/stronger.rkt @@ -42,6 +42,16 @@ (ctest #f contract-stronger? (<=/c 2) (>/c 2)) (ctest #f contract-stronger? (>=/c 2) (>/c 2)) (ctest #t contract-stronger? (>=/c 3) (>/c 2)) + + (ctest #t contract-stronger? (>/c 0) (and/c real? positive?)) + (ctest #t contract-stronger? (and/c real? positive?) (>/c 0)) + (ctest #t contract-stronger? (=/c 0) (and/c real? (not/c negative?))) + (ctest #t contract-stronger? (and/c real? (not/c negative?)) (>=/c 0)) + (ctest #t contract-stronger? (recursive-contract (<=/c 2)) (recursive-contract (<=/c 3))) (ctest #f contract-stronger? (recursive-contract (<=/c 3)) (recursive-contract (<=/c 2))) (let ([f (contract-eval '(λ (x) (recursive-contract (<=/c x))))]) diff --git a/racket/collects/racket/contract/private/and.rkt b/racket/collects/racket/contract/private/and.rkt index 70e2431cdc..c7a5eea6a4 100644 --- a/racket/collects/racket/contract/private/and.rkt +++ b/racket/collects/racket/contract/private/and.rkt @@ -183,8 +183,28 @@ (cond [(null? contracts) any/c] [(andmap flat-contract? contracts) - (let ([preds (map flat-contract-predicate contracts)]) - (make-first-order-and/c contracts preds))] + (define preds (map flat-contract-predicate contracts)) + (cond + [(and (chaperone-of? (car preds) real?) + (pair? (cdr preds)) + (null? (cddr preds))) + (define second-pred (cadr preds)) + (cond + [(chaperone-of? second-pred negative?) + (/c 0)] + [else + (define second-contract (cadr contracts)) + (cond + [(equal? (contract-name second-contract) '(not/c positive?)) + (<=/c 0)] + [(equal? (contract-name second-contract) '(not/c negative?)) + (>=/c 0)] + [else + (make-first-order-and/c contracts preds)])])] + [else + (make-first-order-and/c contracts preds)])] [(andmap chaperone-contract? contracts) (make-chaperone-and/c contracts)] [else (make-impersonator-and/c contracts)]))) diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index c40f9c5a38..82ca98f8f9 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -118,9 +118,11 @@ (define (between/c-first-order ctc) (define n (between/c-s-low ctc)) (define m (between/c-s-high ctc)) - (λ (x) - (and (real? x) - (<= n x m)))) + (cond + [(and (= n -inf.0) (= m +inf.0)) + real?] + [else + (λ (x) (and (real? x) (<= n x m)))])) (define ((between/c-generate ctc) fuel) (define n (between/c-s-low ctc)) @@ -180,8 +182,8 @@ (cond [(and (= n -inf.0) (= m +inf.0)) 'real?] - [(= n -inf.0) `(<=/c ,m)] - [(= m +inf.0) `(>=/c ,n)] + [(= 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)])) #:stronger between/c-stronger @@ -214,7 +216,12 @@ (define (make-/c-contract-property name -/+ less/greater) (build-flat-contract-property - #:name (λ (c) `(,name ,(-ctc-x c))) + #:name (λ (c) + (cond + [(= (-ctc-x c) 0) + `(and/c real? ,(if (equal? name '>/c) 'positive? 'negative?))] + [else + `(,name ,(-ctc-x c))])) #:first-order (λ (ctc) (define x (-ctc-x ctc)) (λ (y) (and (real? y) ( y x)))) #:late-neg-projection (λ (ctc) diff --git a/racket/collects/racket/contract/private/opters.rkt b/racket/collects/racket/contract/private/opters.rkt index 51e7706796..886c0d9831 100644 --- a/racket/collects/racket/contract/private/opters.rkt +++ b/racket/collects/racket/contract/private/opters.rkt @@ -217,7 +217,8 @@ '(expected: "a number between ~a and ~a" given: "~e") lo hi val)) -(define-for-syntax (single-comparison-opter opt/info stx check-arg comparison arg name predicate?) +(define-for-syntax (single-comparison-opter opt/info stx check-arg comparison arg name predicate? + special-name) (with-syntax ([comparison comparison] [predicate? predicate?]) (let*-values ([(lift-low lifts2) (lift/binding arg 'single-comparison-val empty-lifts)]) @@ -247,7 +248,9 @@ [that that]) (syntax (comparison this that)))))) #:chaperone #t - #:name #`'(#,name m)))))))) + #:name #`(if (= m 0) + '#,special-name + '(#,name m))))))))) (define (raise-opt-single-comparison-opter-error blame val comparison m predicate?) (raise-blame-error @@ -271,7 +274,8 @@ #'= #'x '=/c - #'number?)])) + #'number? + '(= 0))])) (define/opter (>=/c opt/i opt/info stx) (syntax-case stx (>=/c) @@ -284,7 +288,8 @@ #'>= #'low '>=/c - #'real?)])) + #'real? + '(and/c real? (not/c negative?)))])) (define/opter (<=/c opt/i opt/info stx) (syntax-case stx (<=/c) @@ -297,7 +302,8 @@ #'<= #'high '<=/c - #'real?)])) + #'real? + '(and/c real? (not/c positive?)))])) (define/opter (>/c opt/i opt/info stx) (syntax-case stx (>/c) @@ -310,7 +316,8 @@ #'> #'low '>/c - #'real?)])) + #'real? + '(and/c real? positive?))])) (define/opter (