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

fix interaction between real? and flat-named-contract

Browse Source 
and fix opters, which were just broken for flat-named-contract and names

closes #1559
This commit is contained in:
Robby Findler 2017-01-03 17:02:50 -06:00
parent 83d4cf4485
commit cff1c1dd4e
5 changed files with 29 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
pkgs/racket-test/tests/racket/contract/flat-contracts.rkt
View File

@ -58,6 +58,11 @@
(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 '(and/c (flat-named-contract 'Real real?) negative?) -1 0)
(test-flat-contract '(and/c (flat-named-contract 'Real real?) positive?) 1 0)
(test-flat-contract '(and/c (flat-named-contract 'Real real?) (not/c positive?)) 0 1)
(test-flat-contract '(and/c (flat-named-contract 'Real real?) (not/c negative?)) 0 -1)
(test-flat-contract #t #t "x")
(test-flat-contract #f #f "x")

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

@ -56,6 +56,7 @@
(flat-named-contract 'mumble
(and/c frotz/c
(not/c bazzle/c)))))
(test-name 'Real (flat-named-contract 'Real real?))
(test-name '(-> integer? integer?) (-> integer? integer?))

17
racket/collects/racket/contract/private/basic-opters.rkt
View File

@ -34,11 +34,11 @@
;;
;; flat-contract helper
;;
(define-for-syntax (opt/flat-ctc opt/info pred checker)
(define-for-syntax (opt/flat-ctc opt/info pred checker name)
(syntax-case pred (null? number? integer? boolean? string? pair? not)
;; Better way of doing this?
[pred
(let* ((lift-vars (generate-temporaries (syntax (pred error-check))))
(let* ((lift-vars (generate-temporaries (syntax (pred error-check the-name))))
(lift-pred (car lift-vars)))
(with-syntax ((val (opt/info-val opt/info))
(ctc (opt/info-contract opt/info))
@ -56,22 +56,25 @@
#:lifts
(interleave-lifts
lift-vars
(list #'pred (cond [(eq? checker 'check-flat-contract) #'(check-flat-contract lift-pred)]
[(eq? checker 'check-flat-named-contract) #'(check-flat-named-contract lift-pred)])))
(list #'pred
(cond [(eq? checker 'check-flat-contract) #'(check-flat-contract lift-pred)]
[(eq? checker 'check-flat-named-contract) #'(check-flat-named-contract lift-pred)])
(or name #'(object-name lift-pred))))
#:superlifts null
#:partials null
#:flat (syntax (lift-pred val))
#:opt #f
#:stronger-ribs null
#:chaperone #t
#:name #'(object-name lift-pred))))]))
#:name (list-ref lift-vars 2))))]))
;;
;; flat-contract and flat-named-contract
;;
(define/opter (flat-contract opt/i opt/info stx)
(syntax-case stx (flat-contract)
[(flat-contract pred) (opt/flat-ctc opt/info #'pred 'check-flat-contract)]))
[(flat-contract pred) (opt/flat-ctc opt/info #'pred 'check-flat-contract #f)]))
(define/opter (flat-named-contract opt/i opt/info stx)
(syntax-case stx (flat-named-contract)
[(flat-named-contract name pred) (opt/flat-ctc opt/info #'pred 'check-flat-named-contract)]))
[(flat-named-contract name pred)
(opt/flat-ctc opt/info #'pred 'check-flat-named-contract #'name)]))

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

@ -311,11 +311,13 @@
(set! consc-anyany p)
(set! list/c-empty mt))
(define between/c-inf+inf #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 b/c-s? b/c-s-l b/c-s-h)
(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! renamed-between/c r-b)
(set! between/c-s? b/c-s?)
(set! between/c-s-low b/c-s-l)
(set! between/c-s-high b/c-s-h))
@ -339,7 +341,9 @@
[(chaperone-of? x real?)
(unless between/c-inf+inf
(error 'coerce-contract/f::between/c-inf+inf "too soon!"))
between/c-inf+inf]
(if (name-default? name)
between/c-inf+inf
(renamed-between/c -inf.0 +inf.0 name))]
[else
(make-predicate-contract (if (name-default? name)
(or (object-name x) '???)

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

@ -178,10 +178,12 @@
(λ (ctc)
(define n (between/c-s-low ctc))
(define m (between/c-s-high ctc))
(define name (if (real-in-s? ctc) 'real-in 'between/c))
(define name (if (renamed-between/c? ctc) (renamed-between/c-name ctc) 'between/c))
(cond
[(and (= n -inf.0) (= m +inf.0))
'real?]
(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)]
@ -189,7 +191,7 @@
#:stronger between/c-stronger
#:first-order between/c-first-order
#:generate between/c-generate))
(define-struct (real-in-s between/c-s) ())
(define-struct (renamed-between/c between/c-s) (name))
(define (maybe-neg n) (rand-choice [1/2 n] [else (- n)]))
@ -294,6 +296,7 @@
arg1 arg2)))
(set-some-basic-misc-contracts! (between/c -inf.0 +inf.0)
renamed-between/c
between/c-s?
between/c-s-low
between/c-s-high)
@ -304,7 +307,7 @@
(define/final-prop (real-in start end)
(check-two-args 'real-in start end real? real?)
(make-real-in-s start end))
(make-renamed-between/c start end 'real-in))
(define/final-prop (not/c f)
(let* ([ctc (coerce-flat-contract 'not/c f)]