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

make #f always coerce into the same (eq?) contract and make

Browse Source 
(or/c #f #t) (or (or/c #t #f)) coerce into the same thing
that boolean? coerces into (and make that also always be eq?)
This commit is contained in:
Robby Findler 2016-04-22 15:43:19 -05:00
parent bbac97129e
commit 68b8bf760a
4 changed files with 28 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -32,6 +32,9 @@
(or/c (-> (>=/c 5) (>=/c 5)) boolean?))
(test-name '(or/c boolean? (-> (>=/c 5) (>=/c 5)))
(or/c boolean? (-> (>=/c 5) (>=/c 5))))
(test-name 'boolean? (or/c #f #t))
(test-name 'boolean? (or/c #t #f))
(test-name '(or/c #t #f 'x) (or/c #t #f 'x))
(test-name '(if/c integer? odd? (-> integer? integer?))
(if/c integer? odd? (-> integer? integer?)))

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

@ -78,7 +78,10 @@
raise-predicate-blame-error-failure
n->th)
n->th
false/c-contract
true/c-contract)
(define (contract-custom-write-property-proc stct port mode)
(define (write-prefix)
@ -304,6 +307,7 @@
(unless listof-any
(error 'coerce-contract/f::listof-any "too soon!"))
listof-any]
[(chaperone-of? x boolean?) boolean?/c]
[(chaperone-of? x pair?)
(unless consc-anyany
(error 'coerce-contract/f::consc-anyany "too soon!"))
@ -320,6 +324,7 @@
(error 'coerce-contract/f::list/c-empty "too soon!"))
list/c-empty]
[(not x) false/c-contract]
[(equal? x #t) true/c-contract]
[(or (symbol? x) (boolean? x) (keyword? x))
(make-eq-contract x
(if (name-default? name)
@ -496,6 +501,7 @@
#:list-contract? (λ (c) (null? (eq-contract-val c)))))
(define false/c-contract (make-eq-contract #f #f))
(define true/c-contract (make-eq-contract #t #t))
(define-struct equal-contract (val name)
#:property prop:custom-write contract-custom-write-property-proc
@ -664,7 +670,7 @@
(define (build-flat-contract name pred [generate #f])
(make-predicate-contract name pred generate #f))
(define boolean?/c (make-predicate-contract 'boolean? boolean? #f #t))
(define (contract-name ctc)
(contract-struct-name

6
racket/collects/racket/contract/private/opters.rkt
View File

@ -147,7 +147,11 @@
#:name (or name-from-hos
(if (= (length names) 1)
(car names)
#`(list 'or/c #,@names))))))
#`(let ([names (list #,@names)])
(if (or (equal? names '(#f #t))
(equal? names '(#t #f)))
'boolean?
(cons 'or/c names))))))))
(syntax-case stx (or/c)
[(or/c p ...)

12
racket/collects/racket/contract/private/orc.rkt
View File

@ -34,7 +34,17 @@
(define pred (make-flat-predicate flat-contracts))
(cond
[(null? ho-contracts)
(make-flat-or/c pred flat-contracts)]
(cond
[(and (pair? flat-contracts)
(pair? (cdr flat-contracts))
(null? (cddr flat-contracts))
(or (and (equal? false/c-contract (car flat-contracts))
(equal? true/c-contract (cadr flat-contracts)))
(and (equal? false/c-contract (cadr flat-contracts))
(equal? true/c-contract (car flat-contracts)))))
(coerce-contract 'or/c boolean?)]
[else
(make-flat-or/c pred flat-contracts)])]
[(null? (cdr ho-contracts))
(define name (apply build-compound-type-name 'or/c args))
(if (chaperone-contract? (car ho-contracts))