diff --git a/collects/plot/common/contract.rkt b/collects/plot/common/contract.rkt index 0f60bb6370..425f521781 100644 --- a/collects/plot/common/contract.rkt +++ b/collects/plot/common/contract.rkt @@ -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 diff --git a/collects/plot/plot3d/contour.rkt b/collects/plot/plot3d/contour.rkt index 940a337d65..aed91db4a9 100644 --- a/collects/plot/plot3d/contour.rkt +++ b/collects/plot/plot3d/contour.rkt @@ -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)] diff --git a/collects/syntax/id-table.rkt b/collects/syntax/id-table.rkt index 5ec4262982..02ca90f425 100644 --- a/collects/syntax/id-table.rkt +++ b/collects/syntax/id-table.rkt @@ -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) diff --git a/collects/syntax/private/id-table.rkt b/collects/syntax/private/id-table.rkt index 8a03a1f8ce..59731f0f8b 100644 --- a/collects/syntax/private/id-table.rkt +++ b/collects/syntax/private/id-table.rkt @@ -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) diff --git a/collects/tests/unstable/contract.rkt b/collects/tests/unstable/contract.rkt index c50df5afa1..4175c673bc 100644 --- a/collects/tests/unstable/contract.rkt +++ b/collects/tests/unstable/contract.rkt @@ -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,26 +36,7 @@ (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))))) + (void))))) (test-suite "Data structure contracts" (test-suite "option/c" (test-true "flat" (flat-contract? (option/c number?))) diff --git a/collects/unstable/contract.rkt b/collects/unstable/contract.rkt index 3d8df77dfb..eaf48da48e 100644 --- a/collects/unstable/contract.rkt +++ b/collects/unstable/contract.rkt @@ -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?)]) + ) diff --git a/collects/unstable/scribblings/contract.scrbl b/collects/unstable/scribblings/contract.scrbl index 0f1bb3cdcd..1fc75a6a61 100644 --- a/collects/unstable/scribblings/contract.scrbl +++ b/collects/unstable/scribblings/contract.scrbl @@ -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)