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

pruned unstable/contract

Browse Source 
Removed unused code. Removed nat/c, pos/c as they correspond to
standard predicates.
This commit is contained in:
Ryan Culpepper 2011-12-17 21:15:04 -07:00
parent b12d284055
commit f99d79ef10
7 changed files with 9 additions and 451 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/plot/common/contract.rkt
View File

@ -13,7 +13,8 @@
maybe-function/c maybe-apply
plot-colors/c pen-widths/c plot-pen-styles/c plot-brush-styles/c alphas/c
labels/c)
nat/c pos/c truth/c)
(rename-out [natural-number/c nat/c])
truth/c)
;; ===================================================================================================
;; Convenience

4
collects/plot/plot3d/contour.rkt
View File

@ -94,7 +94,7 @@
[y-min (or/c rational? #f) #f] [y-max (or/c rational? #f) #f]
[#:z-min z-min (or/c rational? #f) #f] [#:z-max z-max (or/c rational? #f) #f]
[#:samples samples (and/c exact-integer? (>=/c 2)) (plot3d-samples)]
[#:levels levels (or/c 'auto pos/c (listof real?)) (contour-levels)]
[#:levels levels (or/c 'auto exact-positive-integer? (listof real?)) (contour-levels)]
[#:colors colors (plot-colors/c (listof real?)) (contour-colors)]
[#:widths widths (pen-widths/c (listof real?)) (contour-widths)]
[#:styles styles (plot-pen-styles/c (listof real?)) (contour-styles)]
@ -181,7 +181,7 @@
[y-min (or/c rational? #f) #f] [y-max (or/c rational? #f) #f]
[#:z-min z-min (or/c rational? #f) #f] [#:z-max z-max (or/c rational? #f) #f]
[#:samples samples (and/c exact-integer? (>=/c 2)) (plot3d-samples)]
[#:levels levels (or/c 'auto pos/c (listof real?)) (contour-levels)]
[#:levels levels (or/c 'auto exact-positive-integer? (listof real?)) (contour-levels)]
[#:colors colors (plot-colors/c (listof ivl?)) (contour-interval-colors)]
[#:styles styles (plot-brush-styles/c (listof ivl?)) (contour-interval-styles)]
[#:line-colors line-colors (plot-colors/c (listof ivl?)) (contour-interval-line-colors)]

1
collects/syntax/id-table.rkt
View File

@ -76,7 +76,6 @@
(define (make-idtbl [init-dict null]
#:phase [phase (syntax-local-phase-level)])
;; init-dict is good candidate for object/c-like dict/c
(let ([t (mutable-idtbl (make-hasheq) phase)])
(for ([(k v) (in-dict init-dict)])
(unless (identifier? k)

1
collects/syntax/private/id-table.rkt
View File

@ -92,7 +92,6 @@
(define (make-idtbl [init-dict null]
#:phase [phase (syntax-local-phase-level)])
;; init-dict is good candidate for object/c like dict/c
(let ([t (mutable-idtbl (make-hasheq) phase)])
(for ([(k v) (in-dict init-dict)])
(unless (identifier? k)

82
collects/tests/unstable/contract.rkt
View File

@ -5,76 +5,15 @@
(run-tests
(test-suite "contract.rkt"
(test-suite "Flat Contracts"
(test-suite "nat/c"
(test-ok (with/c nat/c 1))
(test-ok (with/c nat/c 0))
(test-bad (with/c nat/c -1))
(test-bad (with/c nat/c 'non-numeric)))
(test-suite "pos/c"
(test-ok (with/c pos/c 1))
(test-bad (with/c pos/c 0))
(test-bad (with/c pos/c -1))
(test-bad (with/c pos/c 'non-numeric)))
(test-suite "truth/c"
(test-ok (with/c truth/c #t))
(test-ok (with/c truth/c #f))
(test-ok (with/c truth/c '(x)))))
(test-suite "Syntax Object Contracts"
(test-suite "syntax-datum/c"
(test-ok (with/c (syntax-datum/c (listof (listof natural-number/c)))
#'((0 1 2) () (3 4) (5))))
(test-bad (with/c (syntax-datum/c (listof (listof natural-number/c)))
#'((x y z))))
(test-bad (with/c (syntax-datum/c string?) "xyz")))
(test-suite "syntax-listof/c"
(test-ok (with/c (syntax-listof/c identifier?) #'(a b c)))
(test-bad (with/c (syntax-listof/c identifier?) #'(1 2 3)))
(test-bad (with/c (syntax-listof/c identifier?) #'(a b . c)))
(test-bad (with/c (syntax-listof/c identifier?) (list #'a #'b #'c))))
(test-suite "syntax-list/c"
(test-ok (with/c (syntax-list/c identifier? (syntax/c string?))
#'(a "b")))
(test-bad (with/c (syntax-list/c identifier? (syntax/c string?))
#'(a "b" #:c)))
(test-bad (with/c (syntax-list/c identifier? (syntax/c string?))
#'(a b)))
(test-bad (with/c (syntax-list/c identifier? (syntax/c string?))
#'(a "b" . c)))
(test-bad (with/c (syntax-list/c identifier? (syntax/c string?))
'(#'a #'"b")))))
(test-suite "Higher Order Contracts"
(test-suite "thunk/c"
(test-ok ([with/c thunk/c gensym]))
(test-bad ([with/c thunk/c gensym] 'x))
(test-bad ([with/c thunk/c cons])))
(test-suite "unary/c"
(test-ok ([with/c unary/c list] 'x))
(test-bad ([with/c unary/c list] 'x 'y))
(test-bad ([with/c unary/c cons] 1)))
(test-suite "binary/c"
(test-ok ([with/c binary/c +] 1 2))
(test-bad ([with/c binary/c +] 1 2 3))
(test-bad ([with/c binary/c symbol->string] 'x 'y)))
(test-suite "predicate/c"
(test-ok ([with/c predicate/c integer?] 1))
(test-ok ([with/c predicate/c integer?] 1/2))
(test-bad ([with/c predicate/c values] 'x)))
(test-suite "predicate-like/c"
(test-ok ([with/c predicate-like/c integer?] 1))
(test-ok ([with/c predicate-like/c integer?] 1/2))
(test-ok ([with/c predicate-like/c values] 'x)))
(test-suite "comparison/c"
(test-ok ([with/c comparison/c equal?] 1 1))
(test-ok ([with/c comparison/c equal?] 1 2))
(test-bad ([with/c comparison/c list] 1 2)))
(test-suite "comparison-like/c"
(test-ok ([with/c comparison-like/c equal?] 1 1))
(test-ok ([with/c comparison-like/c equal?] 1 2))
(test-ok ([with/c comparison-like/c list] 1 2))))
(test-bad ([with/c predicate/c values] 'x))))
(test-suite "Collection Contracts"
(test-suite "sequence/c"
(test-ok
@ -97,25 +36,6 @@
(test-bad
(for ([(x y) (with/c (sequence/c integer?)
(in-dict (list (cons 1 'one) (cons 2 'two))))])
(void))))
(test-suite "dict/c"
(test-ok
(for ([(x y)
(in-dict
(with/c (dict/c integer? symbol?)
#hash([1 . a] [2 . b])))])
(void)))
(test-bad
(for ([(x y)
(in-dict
(with/c (dict/c integer? symbol?)
#hash([1 . a] [three . b])))])
(void)))
(test-bad
(for ([(x y)
(in-dict
(with/c (dict/c integer? symbol?)
#hash([1 . a] [2 . "b"])))])
(void)))))
(test-suite "Data structure contracts"
(test-suite "option/c"

245
collects/unstable/contract.rkt
View File

@ -9,14 +9,6 @@
(define (non-empty-string? x)
(and (string? x) (not (zero? (string-length x)))))
(define (non-empty-bytes? x)
(and (bytes? x) (not (zero? (bytes-length x)))))
(define (non-empty-vector? x)
(and (vector? x) (not (zero? (vector-length x)))))
(define (non-empty-list? x)
(and (list? x) (pair? x)))
(define (singleton-list? x)
(and (pair? x) (null? (cdr x))))
;; ryanc added:
@ -132,58 +124,9 @@
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define nat/c
(flat-named-contract '|natural number| exact-nonnegative-integer?))
(define pos/c
(flat-named-contract '|positive integer| exact-positive-integer?))
(define truth/c
(flat-named-contract '|truth value| (lambda (x) #t)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Syntax Contracts
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (syntax-datum/c datum)
(let* ([datum/c (coerce-contract datum datum)])
(flat-named-contract (build-compound-type-name 'syntax-datum/c datum/c)
(lambda (v)
(and (syntax? v)
((flat-contract-predicate datum/c)
(syntax->datum v)))))))
(define (syntax-listof/c elem)
(let* ([elem/c (coerce-contract elem elem)])
(flat-named-contract (build-compound-type-name 'syntax-listof/c elem/c)
(lambda (v)
(and (syntax? v)
((flat-contract-predicate (listof elem/c))
(syntax->list v)))))))
(define (syntax-list/c . elems)
(let* ([elem/cs (map (lambda (elem) (coerce-contract elem elem)) elems)])
(flat-named-contract (apply build-compound-type-name 'syntax-list/c elem/cs)
(lambda (v)
(and (syntax? v)
((flat-contract-predicate (apply list/c elem/cs))
(syntax->list v)))))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Function Contracts
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define thunk/c (-> any/c))
(define unary/c (-> any/c any/c))
(define binary/c (-> any/c any/c any/c))
(define comparison/c (-> any/c any/c boolean?))
(define predicate-like/c (-> any/c truth/c))
(define comparison-like/c (-> any/c any/c truth/c))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Contracted Sequences
@ -228,174 +171,6 @@
(lambda (idx . elems) #t)))))))
sequence?)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Contracted Dictionaries
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; A CDict is (make-contracted-dictionary (Listof (Cons Proj Proj)) Dict)
;; A Proj is (make-projection Contract Symbol Symbol Any Any)
(define-struct contracted-dictionary [projections bindings])
(define-struct projection [contract out in source name blame])
(define (dict/c key/c value/c)
(let* ([key/c (coerce-contract 'dict/c key/c)]
[value/c (coerce-contract 'dict/c value/c)])
(make-proj-contract
(build-compound-type-name 'dict/c key/c value/c)
(lambda (pos neg src name blame)
(lambda (dict)
(unless (dict? dict)
(raise-contract-error dict src pos name
"expected a dictionary, got: ~e"
dict))
(wrap
(cons (cons (make-projection key/c pos neg src name blame)
(make-projection value/c pos neg src name blame))
(dict->projections dict))
(dict->bindings dict))))
dict?)))
(define-match-expander cdict
(syntax-rules () [(_ p b) (struct contracted-dictionary [p b])]))
(define-match-expander proj
(syntax-rules () [(_ c o i s n b) (struct projection [c o i s n b])]))
(define -ref
(case-lambda
[(dict key)
(match dict
[(cdict projs binds)
(let* ([key (key-in projs key)])
(value-out projs (dict-ref binds key)))])]
[(dict key failure)
(match dict
[(cdict projs binds)
(let* ([key (key-in projs key)])
(let/ec return
(define (fail)
(return (if (procedure? failure) (failure) failure)))
(value-out projs (dict-ref binds key fail))))])]))
(define (-set! dict key value)
(match dict
[(cdict projs binds)
(dict-set! binds (key-in projs key) (value-in projs value))]))
(define (-set dict key value)
(match dict
[(cdict projs binds)
(wrap projs (dict-set binds (key-in projs key) (value-in projs value)))]))
(define (-rem! dict key)
(match dict
[(cdict projs binds)
(dict-remove! binds (key-in projs key))]))
(define (-rem dict key)
(match dict
[(cdict projs binds)
(wrap projs (dict-remove binds (key-in projs key)))]))
(define (-size dict)
(match dict
[(cdict projs binds)
(dict-count binds)]))
(define (-fst dict)
(match dict
[(cdict projs binds)
(dict-iterate-first binds)]))
(define (-nxt dict iter)
(match dict
[(cdict projs binds)
(dict-iterate-next binds iter)]))
(define (-key dict iter)
(match dict
[(cdict projs binds)
(key-out projs (dict-iterate-key binds iter))]))
(define (-val dict iter)
(match dict
[(cdict projs binds)
(value-out projs (dict-iterate-value binds iter))]))
(define (key-in projs key)
(if (null? projs)
key
(key-in (cdr projs) (project-in (caar projs) key))))
(define (value-in projs value)
(if (null? projs)
value
(value-in (cdr projs) (project-in (cdar projs) value))))
(define (key-out projs key)
(if (null? projs)
key
(project-out (caar projs) (key-out (cdr projs) key))))
(define (value-out projs value)
(if (null? projs)
value
(project-out (cdar projs) (value-out (cdr projs) value))))
(define (project-in p x)
(match p
[(proj c o i s n b)
(((contract-proc c) i o s n (not b)) x)]))
(define (project-out p x)
(match p
[(proj c o i s n b)
(((contract-proc c) o i s n b) x)]))
(define (dict->bindings dict)
(match dict
[(cdict projs binds) binds]
[_ dict]))
(define (dict->projections dict)
(match dict
[(cdict projs binds) projs]
[_ null]))
(define (wrap projs binds)
((dict->wrapper binds) projs binds))
(define (dict->wrapper dict)
(if (dict-mutable? dict)
(if (dict-can-functional-set? dict)
(if (dict-can-remove-keys? dict) make-:!+- make-:!+_)
(if (dict-can-remove-keys? dict) make-:!_- make-:!__))
(if (dict-can-functional-set? dict)
(if (dict-can-remove-keys? dict) make-:_+- make-:_+_)
(if (dict-can-remove-keys? dict) make-:__- make-:___))))
;; The __- case (removal without functional or mutable update) is nonsensical.
(define prop:!+- (vector -ref -set! -set -rem! -rem -size -fst -nxt -key -val))
(define prop:!+_ (vector -ref -set! -set #f #f -size -fst -nxt -key -val))
(define prop:!_- (vector -ref -set! #f -rem! #f -size -fst -nxt -key -val))
(define prop:!__ (vector -ref -set! #f #f #f -size -fst -nxt -key -val))
(define prop:_+- (vector -ref #f -set #f -rem -size -fst -nxt -key -val))
(define prop:_+_ (vector -ref #f -set #f -rem -size -fst -nxt -key -val))
(define prop:__- (vector -ref #f #f #f #f -size -fst -nxt -key -val))
(define prop:___ (vector -ref #f #f #f #f -size -fst -nxt -key -val))
;; The __- case (removal without functional or mutable update) is nonsensical.
(define-struct (:!+- contracted-dictionary) [] #:property prop:dict prop:!+-)
(define-struct (:!+_ contracted-dictionary) [] #:property prop:dict prop:!+_)
(define-struct (:!_- contracted-dictionary) [] #:property prop:dict prop:!_-)
(define-struct (:!__ contracted-dictionary) [] #:property prop:dict prop:!__)
(define-struct (:_+- contracted-dictionary) [] #:property prop:dict prop:_+-)
(define-struct (:_+_ contracted-dictionary) [] #:property prop:dict prop:_+_)
(define-struct (:__- contracted-dictionary) [] #:property prop:dict prop:__-)
(define-struct (:___ contracted-dictionary) [] #:property prop:dict prop:___)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Exports
@ -408,31 +183,13 @@
[tcp-listen-port? contract?]
[non-empty-string? predicate/c]
[non-empty-bytes? predicate/c]
[non-empty-vector? predicate/c]
[non-empty-list? predicate/c]
[singleton-list? predicate/c]
[if/c (-> procedure? contract? contract? contract?)]
[failure-result/c contract?]
[rename-contract (-> contract? any/c contract?)]
[option/c (-> contract? contract?)]
[nat/c flat-contract?]
[pos/c flat-contract?]
[truth/c flat-contract?]
[thunk/c contract?]
[unary/c contract?]
[binary/c contract?]
[comparison/c contract?]
[predicate-like/c contract?]
[comparison-like/c contract?]
[syntax-datum/c (-> flat-contract? flat-contract?)]
[syntax-listof/c (-> flat-contract? flat-contract?)]
[syntax-list/c
(->* [] [] #:rest (listof flat-contract?) flat-contract?)]
[sequence/c (->* [] [] #:rest (listof contract?) contract?)]
[dict/c (-> contract? contract? contract?)])
)

122
collects/unstable/scribblings/contract.scrbl
View File

@ -10,23 +10,12 @@
@unstable-header[]
@deftogether[[
@defproc[(non-empty-string? [x any/c]) boolean?]
@defproc[(non-empty-list? [x any/c]) boolean?]
@defproc[(non-empty-bytes? [x any/c]) boolean?]
@defproc[(non-empty-vector? [x any/c]) boolean?]]]{
@defproc[(non-empty-string? [x any/c]) boolean?]{
Returns @racket[#t] if @racket[x] is of the appropriate data type
(string, list, bytes, or vector, respectively) and is not empty;
Returns @racket[#t] if @racket[x] is a string and is not empty;
returns @racket[#f] otherwise.
}
@defproc[(singleton-list? [x any/c]) boolean?]{
Returns @racket[#t] if @racket[x] is a list of one element; returns
@racket[#f] otherwise.
}
@defthing[port-number? contract?]{
Equivalent to @racket[(between/c 1 65535)].
}
@ -93,22 +82,6 @@ or default value may be used.
@addition[@author+email["Carl Eastlund" "cce@racket-lang.org"]]
@section{Flat Contracts}
@defthing[nat/c flat-contract?]{
This contract recognizes natural numbers that satisfy
@racket[exact-nonnegative-integer?].
}
@defthing[pos/c flat-contract?]{
This contract recognizes positive integers that satisfy
@racket[exact-positive-integer?].
}
@defthing[truth/c flat-contract?]{
This contract recognizes Scheme truth values, i.e., any value, but with a more
@ -117,70 +90,6 @@ that accept arbitrary truth values that may not be booleans.
}
@section{Syntax Object Contracts}
@defproc[(syntax-datum/c [datum/c any/c]) flat-contract?]{
Recognizes syntax objects @racket[stx] such that @racket[(syntax->datum stx)]
satisfies @racket[datum/c].
}
@defproc[(syntax-listof/c [elem/c any/c]) flat-contract?]{
Recognizes syntax objects @racket[stx] such that @racket[(syntax->list stx)]
satisfies @racket[(listof elem/c)].
}
@defproc[(syntax-list/c [elem/c any/c] ...) flat-contract?]{
Recognizes syntax objects @racket[stx] such that @racket[(syntax->list stx)]
satisfies @racket[(list/c elem/c ...)].
}
@section{Higher-Order Contracts}
@deftogether[(
@defthing[thunk/c contract?]
@defthing[unary/c contract?]
@defthing[binary/c contract?]
)]{
These contracts recognize functions that accept 0, 1, or 2 arguments,
respectively, and produce a single result.
}
@deftogether[(
@defthing[predicate-like/c contract?]
)]{
This contract recognizes unary functions whose results satisfy @racket[truth/c]. Use
@racket[predicate-like/c] in negative position for predicates passed as
arguments that may return arbitrary values as truth values.
}
@deftogether[(
@defthing[comparison/c contract?]
@defthing[comparison-like/c contract?]
)]{
These contracts recognize comparisons: functions of two arguments that
produce a boolean result.
The first constrains its output to satisfy @racket[boolean?]. Use
@racket[comparison/c] in positive position for comparisons that guarantee a
result of @racket[#t] or @racket[#f].
The second constrains its output to satisfy @racket[truth/c]. Use
@racket[comparison-like/c] in negative position for comparisons passed as
arguments that may return arbitrary values as truth values.
}
@defproc[(sequence/c [elem/c contract?] ...) contract?]{
Wraps a @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{sequence},
@ -208,31 +117,4 @@ for instance, a wrapped list is not guaranteed to satisfy @racket[list?].
}
@defproc[(dict/c [key/c contract?] [value/c contract?]) contract?]{
Wraps a @tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{dictionary},
obligating its keys to satisfy @racket[key/c] and their corresponding values to
satisfy @racket[value/c]. The result is not guaranteed to be the same kind of
dictionary as the original value; for instance, a wrapped hash table is not
guaranteed to satisfy @racket[hash?].
@defexamples[
#:eval the-eval
(define/contract table
(dict/c symbol? string?)
(make-immutable-hash (list (cons 'A "A") (cons 'B 2) (cons 3 "C"))))
(dict-ref table 'A)
(dict-ref table 'B)
(dict-ref table 3)
]
@emph{Warning:} Bear in mind that key and value contracts are re-wrapped on
every dictionary operation, and dictionaries wrapped in @racket[dict/c] multiple
times will perform the checks as many times for each operation. Especially for
immutable dictionaries (which may be passed through a constructor that involves
@racket[dict/c] on each update), contract-wrapped dictionaries may be much less
efficient than the original dictionaries.
}
@(close-eval the-eval)