Permalink
Browse files

add keywords as values that coerce into contracts

adjust 'one-of/c' and 'symbols' so they just use or/c (when possible)

improve or/c's stronger check so that, in the case that or/c is
getting eq or equal contracts, or/c's stronger check is as good as
'symbols'/'one-of/c's stronger check is.
  • Loading branch information...
1 parent bbc8067 commit 483dde9ea8cb06b7f2430ce0802abd28ee08a6b8 @rfindler rfindler committed Apr 6, 2012
@@ -37,7 +37,12 @@
define/final-prop
define/subexpression-pos-prop
- make-predicate-contract)
+ make-predicate-contract
+
+ eq-contract?
+ eq-contract-val
+ equal-contract?
+ equal-contract-val)
(define (has-contract? v)
(or (has-prop:contracted? v)
@@ -154,7 +159,7 @@
[(contract-struct? x) x]
[(and (procedure? x) (procedure-arity-includes? x 1))
(make-predicate-contract (or (object-name x) '???) x (make-generate-ctc-fail))]
- [(or (symbol? x) (boolean? x) (char? x) (null? x)) (make-eq-contract x)]
+ [(or (symbol? x) (boolean? x) (char? x) (null? x) (keyword? x)) (make-eq-contract x)]
[(or (bytes? x) (string? x)) (make-equal-contract x)]
[(number? x) (make-=-contract x)]
[(or (regexp? x) (byte-regexp? x)) (make-regexp/c x)]
@@ -291,10 +291,29 @@
(and (flat-or/c? that)
(let ([this-ctcs (flat-or/c-flat-ctcs this)]
[that-ctcs (flat-or/c-flat-ctcs that)])
- (and (= (length this-ctcs) (length that-ctcs))
- (andmap contract-stronger?
- this-ctcs
- that-ctcs)))))
+ (cond
+ [(and (<= (length this-ctcs) (length that-ctcs))
+ (for/and ([this-ctc (in-list this-ctcs)]
+ [that-ctc (in-list that-ctcs)])
+ (contract-stronger? this-ctc that-ctc)))
+ #t]
+ [(and (andmap (λ (x) (or (eq-contract? x) (equal-contract? x))) this-ctcs)
+ (andmap (λ (x) (or (eq-contract? x) (equal-contract? x))) that-ctcs))
+ (define ht (make-hash))
+ (for ([x (in-list that-ctcs)])
+ (hash-set! ht
+ (if (equal-contract? x)
+ (equal-contract-val x)
+ (eq-contract-val x))
+ #t))
+ (for/and ([x (in-list this-ctcs)])
+ (hash-ref ht
+ (if (equal-contract? x)
+ (equal-contract-val x)
+ (eq-contract-val x))
+ #f))]
+ [else #f]))))
+
#:first-order
(λ (ctc) (flat-or/c-pred ctc))
@@ -400,7 +419,7 @@
(unless (andmap symbol? ss)
(error 'symbols "expected symbols as arguments, given: ~a"
(apply string-append (map (λ (x) (format "~e " x)) ss))))
- (make-one-of/c ss))
+ (apply or/c ss))
(define atomic-value?
(let ([undefined (letrec ([x x]) x)])
@@ -413,7 +432,10 @@
(unless (andmap atomic-value? elems)
(error 'one-of/c "expected chars, symbols, booleans, null, keywords, numbers, void, or undefined, got ~e"
elems))
- (make-one-of/c elems))
+ (if (or (member (void) elems)
+ (member (letrec ([x x]) x) elems))
+ (make-one-of/c elems)
+ (apply or/c elems)))
(define (one-of-pc x)
(cond
@@ -440,12 +462,7 @@
#:name
(λ (ctc)
(let ([elems (one-of/c-elems ctc)])
- `(,(cond
- [(andmap symbol? elems)
- 'symbols]
- [else
- 'one-of/c])
- ,@(map one-of-pc elems))))
+ `(one-of/c ,@(map one-of-pc elems))))
#:stronger
(λ (this that)
@@ -47,7 +47,7 @@ constraints.
various operations listed in this section of the manual, and various
ordinary Racket values that double as contracts, including
@itemize[
-@item{@tech{symbols}, @tech{booleans}, @tech{characters}, and
+@item{@tech{symbols}, @tech{booleans}, @tech{characters}, @tech{keywords}, and
@racket[null], which are treated as contracts that recognize
themselves, using @racket[eq?], }
@@ -243,13 +243,22 @@ recognizes those values, using @racket[eqv?] as the comparison
predicate. For the purposes of @racket[one-of/c], atomic values are
defined to be: @tech{characters}, @tech{symbols}, @tech{booleans},
@racket[null], @tech{keywords}, @tech{numbers},
-@|void-const|, and @|undefined-const|.}
+@|void-const|, and @|undefined-const|.
+
+This is a backwards compatibility contract constructor. If
+neither @|void-const| nor @|undefined-const| are arguments,
+it simply passes its arguments to @racket[or/c].
+}
@defproc[(symbols [sym symbol?] ...+) flat-contract?]{
Accepts any number of symbols and returns a flat contract that
-recognizes those symbols.}
+recognizes those symbols.
+
+This is a backwards compatibility constructor; it merely
+passes its arguments to @racket[or/c].
+}
@defproc[(vectorof [c contract?]
[#:immutable immutable (or/c #t #f 'dont-care) 'dont-care]
@@ -10126,17 +10126,17 @@ so that propagation occurs.
(test-name #\a #\a)
(test-name "x" "x")
(test-name ''x 'x)
- ;(test-name #rx"x" #rx"x") ;; commented out because regexps don't compare via equal?
- ;(test-name #rx#"x" #rx#"x") ;; commented out because regexps don't compare via equal?
+ (test-name #rx"x" #rx"x")
+ (test-name #rx#"x" #rx#"x")
(test-name 'printable/c printable/c)
- (test-name '(symbols 'a 'b 'c) (symbols 'a 'b 'c))
- (test-name '(one-of/c 1 2 3) (one-of/c 1 2 3))
+ (test-name '(or/c 'a 'b 'c) (symbols 'a 'b 'c))
+ (test-name '(or/c 1 2 3) (one-of/c 1 2 3))
(test-name '(one-of/c '() 'x 1 #f #\a (void) (letrec ([x x]) x))
(one-of/c '() 'x 1 #f #\a (void) (letrec ([x x]) x)))
(test-name '(or/c #f #t #\a "x") (or/c #f #t #\a "x"))
- ;(test-name '(or/c #f #t #\a "x" #rx"x" #rx#"x") (or/c #f #t #\a "x" #rx"x" #rx#"x")) ;; commented out because regexps don't compare via equal?
-
+ (test-name '(or/c #f #t #\a "x" #rx"x" #rx#"x") (or/c #f #t #\a "x" #rx"x" #rx#"x"))
+
(test-name '(subclass?/c class:c%)
(let ([c% (class object% (super-new))]) (subclass?/c c%)))

0 comments on commit 483dde9

Please sign in to comment.