From 286319d7239a93e2268228434f16f1a0b603d83d Mon Sep 17 00:00:00 2001
From: Carl Eastlund <cce@racket-lang.org>
Date: Sat, 29 May 2010 12:52:44 -0400
Subject: [PATCH] Added unstable/cce/contract contents to unstable/contract.

---
 collects/tests/unstable/contract.rkt          |  80 ++++++
 collects/unstable/cce/contract.ss             | 268 ------------------
 collects/unstable/cce/dict.ss                 |   2 +-
 .../unstable/cce/reference/contract.scrbl     | 131 ---------
 collects/unstable/cce/reference/dict.scrbl    |   2 +-
 collects/unstable/cce/reference/manual.scrbl  |   2 -
 .../unstable/cce/reference/slideshow.scrbl    |   2 +-
 collects/unstable/cce/syntax.ss               |   4 +-
 collects/unstable/cce/test/test-contract.ss   |  83 ------
 collects/unstable/cce/test/test-main.ss       |   2 -
 collects/unstable/contract.rkt                | 266 ++++++++++++++++-
 collects/unstable/scribblings/contract.scrbl  | 130 ++++++++-
 12 files changed, 472 insertions(+), 500 deletions(-)
 create mode 100644 collects/tests/unstable/contract.rkt
 delete mode 100644 collects/unstable/cce/contract.ss
 delete mode 100644 collects/unstable/cce/reference/contract.scrbl
 delete mode 100644 collects/unstable/cce/test/test-contract.ss

diff --git a/collects/tests/unstable/contract.rkt b/collects/tests/unstable/contract.rkt
new file mode 100644
index 0000000000..5f0a03b456
--- /dev/null
+++ b/collects/tests/unstable/contract.rkt
@@ -0,0 +1,80 @@
+#lang racket
+
+(require rackunit rackunit/text-ui unstable/contract "helpers.rkt")
+
+(run-tests
+ (test-suite "contract.ss"
+   (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 "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-suite "Collection Contracts"
+     (test-suite "sequence/c"
+       (test-ok
+        (for ([x (with/c (sequence/c integer?) (list 1 2 3 4))])
+          (void)))
+       (test-bad
+        (for ([x (with/c (sequence/c integer?) (list 1 2 'c 4))])
+          (void)))
+       (test-bad
+        (for ([x (with/c (sequence/c integer? symbol?) (list 1 2 3 4))])
+          (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)))))))
diff --git a/collects/unstable/cce/contract.ss b/collects/unstable/cce/contract.ss
deleted file mode 100644
index ad1277ec85..0000000000
--- a/collects/unstable/cce/contract.ss
+++ /dev/null
@@ -1,268 +0,0 @@
-#lang scheme
-
-(require (for-syntax syntax/parse))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;;  Flat Contracts
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(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)))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;
-;;  Function Contracts
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define thunk/c (-> any/c))
-(define unary/c (-> any/c any/c))
-(define binary/c (-> any/c any/c any/c))
-(define predicate/c (-> any/c boolean?))
-(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
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(define (sequence/c . elem/cs)
-  (let* ([elem/cs (for/list ([elem/c (in-list elem/cs)])
-                    (coerce-contract 'sequence/c elem/c))]
-         [n-cs (length elem/cs)])
-    (make-proj-contract
-     (apply build-compound-type-name 'sequence/c elem/cs)
-     (lambda (pos neg src name blame)
-       (lambda (seq)
-         (unless (sequence? seq)
-           (raise-contract-error
-            seq src pos name
-            "expected a sequence, got: ~e"
-            seq))
-           (make-do-sequence
-            (lambda ()
-              (let*-values ([(more? next) (sequence-generate seq)])
-                (values
-                 (lambda (idx)
-                   (call-with-values next
-                     (lambda elems
-                       (define n-elems (length elems))
-                       (unless (= n-elems n-cs)
-                         (raise-contract-error
-                          seq src pos name
-                          "expected a sequence of ~a values, got ~a values: ~s"
-                          n-cs n-elems elems))
-                       (apply
-                        values
-                        (for/list ([elem (in-list elems)]
-                                   [elem/c (in-list elem/cs)])
-                          ((((proj-get elem/c) elem/c) pos neg src name blame) elem))))))
-                 (lambda (idx) idx)
-                 #f
-                 (lambda (idx) (more?))
-                 (lambda (elem) #t)
-                 (lambda (idx elem) #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)
-     ((((proj-get c) c) i o s n (not b)) x)]))
-
-(define (project-out p x)
-  (match p
-    [(proj c o i s n b)
-     ((((proj-get c) 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
-;;
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(provide/contract
-
- [nat/c flat-contract?]
- [pos/c flat-contract?]
- [truth/c flat-contract?]
-
- [thunk/c contract?]
- [unary/c contract?]
- [binary/c contract?]
- [predicate/c contract?]
- [comparison/c contract?]
- [predicate-like/c contract?]
- [comparison-like/c contract?]
-
- [sequence/c (->* [] [] #:rest (listof contract?) contract?)]
- [dict/c (-> contract? contract? contract?)]
- )
diff --git a/collects/unstable/cce/dict.ss b/collects/unstable/cce/dict.ss
index 44e02bf667..1890bee194 100644
--- a/collects/unstable/cce/dict.ss
+++ b/collects/unstable/cce/dict.ss
@@ -1,6 +1,6 @@
 #lang scheme
 
-(require "define.ss" "contract.ss")
+(require unstable/contract "define.ss")
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
diff --git a/collects/unstable/cce/reference/contract.scrbl b/collects/unstable/cce/reference/contract.scrbl
deleted file mode 100644
index 773d87f846..0000000000
--- a/collects/unstable/cce/reference/contract.scrbl
+++ /dev/null
@@ -1,131 +0,0 @@
-#lang scribble/doc
-@(require scribble/manual
-          scribble/eval
-          "../scribble.ss"
-          "eval.ss")
-@(require (for-label scheme unstable/cce/contract))
-
-@title[#:style 'quiet #:tag "cce-contract"]{Contracts}
-
-@defmodule[unstable/cce/contract]
-
-This module provides useful contracts and contract constructors.
-
-@section{Flat Contracts}
-
-@defthing[nat/c flat-contract?]{
-
-This contract recognizes natural numbers that satisfy
-@scheme[exact-nonnegative-integer?].
-
-}
-
-@defthing[pos/c flat-contract?]{
-
-This contract recognizes positive integers that satisfy
-@scheme[exact-positive-integer?].
-
-}
-
-@defthing[truth/c flat-contract?]{
-
-This contract recognizes Scheme truth values, i.e., any value, but with a more
-informative name and description.  Use it in negative positions for arguments
-that accept arbitrary truth values that may not be booleans.
-
-}
-
-@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/c contract?]
-@defthing[predicate-like/c contract?]
-)]{
-
-These contracts recognize predicates: functions of a single argument that
-produce a boolean result.
-
-The first constrains its output to satisfy @scheme[boolean?].  Use
-@scheme[predicate/c] in positive position for predicates that guarantee a result
-of @scheme[#t] or @scheme[#f].
-
-The second constrains its output to satisfy @scheme[truth/c].  Use
-@scheme[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 @scheme[boolean?].  Use
-@scheme[comparison/c] in positive position for comparisons that guarantee a
-result of @scheme[#t] or @scheme[#f].
-
-The second constrains its output to satisfy @scheme[truth/c].  Use
-@scheme[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},
-obligating it to produce as many values as there are @scheme[elem/c] contracts,
-and obligating each value to satisfy the corresponding @scheme[elem/c].  The
-result is not guaranteed to be the same kind of sequence as the original value;
-for instance, a wrapped list is not guaranteed to satisfy @scheme[list?].
-
-@defexamples[
-#:eval (evaluator 'unstable/cce/contract)
-(define/contract predicates
-  (sequence/c (-> any/c boolean?))
-  (list integer? string->symbol))
-(for ([P predicates])
-  (printf "~s\n" (P "cat")))
-]
-
-}
-
-@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 @scheme[key/c] and their corresponding values to
-satisfy @scheme[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 @scheme[hash?].
-
-@defexamples[
-#:eval (evaluator 'unstable/cce/contract)
-(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 @scheme[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
-@scheme[dict/c] on each update), contract-wrapped dictionaries may be much less
-efficient than the original dictionaries.
-
-}
diff --git a/collects/unstable/cce/reference/dict.scrbl b/collects/unstable/cce/reference/dict.scrbl
index e29378d20b..f09dfea7de 100644
--- a/collects/unstable/cce/reference/dict.scrbl
+++ b/collects/unstable/cce/reference/dict.scrbl
@@ -297,4 +297,4 @@ wrapped dictionary during functional update using @scheme[wrap].
 @section{Contracted Dictionaries}
 
 This library re-provides @scheme[dict/c] from
-@schememodname[unstable/cce/contract].
+@schememodname[unstable/contract].
diff --git a/collects/unstable/cce/reference/manual.scrbl b/collects/unstable/cce/reference/manual.scrbl
index 2b814d12ae..152e84fb7b 100644
--- a/collects/unstable/cce/reference/manual.scrbl
+++ b/collects/unstable/cce/reference/manual.scrbl
@@ -21,8 +21,6 @@
 
 @include-section["class.scrbl"]
 
-@include-section["contract.scrbl"]
-
 @include-section["require-provide.scrbl"]
 @include-section["planet.scrbl"]
 
diff --git a/collects/unstable/cce/reference/slideshow.scrbl b/collects/unstable/cce/reference/slideshow.scrbl
index 9d7d22334b..ad5755f598 100644
--- a/collects/unstable/cce/reference/slideshow.scrbl
+++ b/collects/unstable/cce/reference/slideshow.scrbl
@@ -2,7 +2,7 @@
 @(require scribble/manual
           "../scribble.ss"
           (for-label slideshow
-                     unstable/cce/contract
+                     unstable/contract
                      unstable/cce/slideshow))
 
 @title[#:style 'quiet #:tag "cce-slideshow"]{Slideshow Presentations}
diff --git a/collects/unstable/cce/syntax.ss b/collects/unstable/cce/syntax.ss
index 5c9b80123a..a9374f2279 100644
--- a/collects/unstable/cce/syntax.ss
+++ b/collects/unstable/cce/syntax.ss
@@ -8,14 +8,14 @@
          syntax/kerncase
          setup/main-collects
          planet/planet-archives
+         unstable/contract
          unstable/text
          (for-template scheme/base)
          (for-syntax scheme/base)
          (for-label scheme)
          "private/syntax-core.ss"
          "private/define-core.ss"
-         (for-template "private/define-core.ss")
-         "contract.ss")
+         (for-template "private/define-core.ss"))
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
diff --git a/collects/unstable/cce/test/test-contract.ss b/collects/unstable/cce/test/test-contract.ss
deleted file mode 100644
index 1929381c71..0000000000
--- a/collects/unstable/cce/test/test-contract.ss
+++ /dev/null
@@ -1,83 +0,0 @@
-#lang scheme
-
-(require "checks.ss"
-         "../contract.ss")
-
-(provide contract-suite)
-
-(define contract-suite
-  (test-suite "contract.ss"
-    (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 "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-suite "Collection Contracts"
-      (test-suite "sequence/c"
-        (test-ok
-         (for ([x (with/c (sequence/c integer?) (list 1 2 3 4))])
-           (void)))
-        (test-bad
-         (for ([x (with/c (sequence/c integer?) (list 1 2 'c 4))])
-           (void)))
-        (test-bad
-         (for ([x (with/c (sequence/c integer? symbol?) (list 1 2 3 4))])
-           (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)))))))
diff --git a/collects/unstable/cce/test/test-main.ss b/collects/unstable/cce/test/test-main.ss
index b84e009373..52592cdfe1 100644
--- a/collects/unstable/cce/test/test-main.ss
+++ b/collects/unstable/cce/test/test-main.ss
@@ -2,7 +2,6 @@
 
 (require "checks.ss"
          "test-class.ss"
-         "test-contract.ss"
          "test-debug.ss"
          "test-define.ss"
          "test-dict.ss"
@@ -20,7 +19,6 @@
 (run-tests
  (test-suite "scheme.plt"
    class-suite
-   contract-suite
    debug-suite
    define-suite
    dict-suite
diff --git a/collects/unstable/contract.rkt b/collects/unstable/contract.rkt
index 58812d3d57..c7d528f5f4 100644
--- a/collects/unstable/contract.rkt
+++ b/collects/unstable/contract.rkt
@@ -1,5 +1,5 @@
 #lang racket/base
-(require racket/contract)
+(require racket/contract racket/dict racket/match)
 
 (define path-element?
   (or/c path-string? (symbols 'up 'same)))
@@ -62,9 +62,271 @@
                            #:projection proj
                            #:first-order ctc-fo)))))
 
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Flat Contracts
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(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)))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;;  Function Contracts
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define thunk/c (-> any/c))
+(define unary/c (-> any/c any/c))
+(define binary/c (-> any/c any/c any/c))
+(define predicate/c (-> any/c boolean?))
+(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
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(define (sequence/c . elem/cs)
+  (let* ([elem/cs (for/list ([elem/c (in-list elem/cs)])
+                    (coerce-contract 'sequence/c elem/c))]
+         [n-cs (length elem/cs)])
+    (make-proj-contract
+     (apply build-compound-type-name 'sequence/c elem/cs)
+     (lambda (pos neg src name blame)
+       (lambda (seq)
+         (unless (sequence? seq)
+           (raise-contract-error
+            seq src pos name
+            "expected a sequence, got: ~e"
+            seq))
+           (make-do-sequence
+            (lambda ()
+              (let*-values ([(more? next) (sequence-generate seq)])
+                (values
+                 (lambda (idx)
+                   (call-with-values next
+                     (lambda elems
+                       (define n-elems (length elems))
+                       (unless (= n-elems n-cs)
+                         (raise-contract-error
+                          seq src pos name
+                          "expected a sequence of ~a values, got ~a values: ~s"
+                          n-cs n-elems elems))
+                       (apply
+                        values
+                        (for/list ([elem (in-list elems)]
+                                   [elem/c (in-list elem/cs)])
+                          ((((proj-get elem/c) elem/c) pos neg src name blame) elem))))))
+                 (lambda (idx) idx)
+                 #f
+                 (lambda (idx) (more?))
+                 (lambda (elem) #t)
+                 (lambda (idx elem) #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)
+     ((((proj-get c) c) i o s n (not b)) x)]))
+
+(define (project-out p x)
+  (match p
+    [(proj c o i s n b)
+     ((((proj-get c) 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
+;;
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
 (provide/contract
  [non-empty-string/c contract?]
  [path-element? contract?]
  [port-number? contract?]
  [if/c (-> procedure? contract? contract? contract?)]
- [rename-contract (-> contract? any/c contract?)])
+ [rename-contract (-> contract? any/c contract?)]
+
+ [nat/c flat-contract?]
+ [pos/c flat-contract?]
+ [truth/c flat-contract?]
+
+ [thunk/c contract?]
+ [unary/c contract?]
+ [binary/c contract?]
+ [predicate/c contract?]
+ [comparison/c contract?]
+ [predicate-like/c contract?]
+ [comparison-like/c 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 dc7ec4fc5f..90631d44d6 100644
--- a/collects/unstable/scribblings/contract.scrbl
+++ b/collects/unstable/scribblings/contract.scrbl
@@ -1,10 +1,5 @@
-#lang scribble/doc
-@(require scribble/base
-          scribble/manual
-          "utils.rkt"
-          (for-label unstable/contract
-                     racket/contract
-                     racket/base))
+#lang scribble/manual
+@(require scribble/eval "utils.rkt" (for-label racket unstable/contract))
 
 @title[#:tag "contract"]{Contracts}
 
@@ -58,3 +53,124 @@ Produces a contract that acts like @racket[contract] but with the name
 The resulting contract is a flat contract if @racket[contract] is a
 flat contract.
 }
+
+@addition[@author+email["Carl Eastlund" "cce@racket-lang.org"]]
+
+@section{Flat Contracts}
+
+@defthing[nat/c flat-contract?]{
+
+This contract recognizes natural numbers that satisfy
+@scheme[exact-nonnegative-integer?].
+
+}
+
+@defthing[pos/c flat-contract?]{
+
+This contract recognizes positive integers that satisfy
+@scheme[exact-positive-integer?].
+
+}
+
+@defthing[truth/c flat-contract?]{
+
+This contract recognizes Scheme truth values, i.e., any value, but with a more
+informative name and description.  Use it in negative positions for arguments
+that accept arbitrary truth values that may not be booleans.
+
+}
+
+@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/c contract?]
+@defthing[predicate-like/c contract?]
+)]{
+
+These contracts recognize predicates: functions of a single argument that
+produce a boolean result.
+
+The first constrains its output to satisfy @scheme[boolean?].  Use
+@scheme[predicate/c] in positive position for predicates that guarantee a result
+of @scheme[#t] or @scheme[#f].
+
+The second constrains its output to satisfy @scheme[truth/c].  Use
+@scheme[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 @scheme[boolean?].  Use
+@scheme[comparison/c] in positive position for comparisons that guarantee a
+result of @scheme[#t] or @scheme[#f].
+
+The second constrains its output to satisfy @scheme[truth/c].  Use
+@scheme[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},
+obligating it to produce as many values as there are @scheme[elem/c] contracts,
+and obligating each value to satisfy the corresponding @scheme[elem/c].  The
+result is not guaranteed to be the same kind of sequence as the original value;
+for instance, a wrapped list is not guaranteed to satisfy @scheme[list?].
+
+@defexamples[
+#:eval (eval/require 'racket/contract 'unstable/contract)
+(define/contract predicates
+  (sequence/c (-> any/c boolean?))
+  (list integer? string->symbol))
+(for ([P predicates])
+  (printf "~s\n" (P "cat")))
+]
+
+}
+
+@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 @scheme[key/c] and their corresponding values to
+satisfy @scheme[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 @scheme[hash?].
+
+@defexamples[
+#:eval (eval/require 'racket/contract 'racket/dict 'unstable/contract)
+(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 @scheme[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
+@scheme[dict/c] on each update), contract-wrapped dictionaries may be much less
+efficient than the original dictionaries.
+
+}