From f4aab53efa01ae54ee5f46074f7c7231c8d7d2da Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Wed, 25 May 2011 02:40:53 -0400
Subject: [PATCH] Added option/c for possibly #f values in unstable.

---
 collects/tests/unstable/contract.rkt         | 31 +++++++++++-
 collects/unstable/contract.rkt               | 52 ++++++++++++++++++++
 collects/unstable/scribblings/contract.scrbl |  9 ++++
 3 files changed, 91 insertions(+), 1 deletion(-)

diff --git a/collects/tests/unstable/contract.rkt b/collects/tests/unstable/contract.rkt
index 6f89eae80c..32254042af 100644
--- a/collects/tests/unstable/contract.rkt
+++ b/collects/tests/unstable/contract.rkt
@@ -104,4 +104,33 @@
                (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?)))
+       (test-true "chaperone" (chaperone-contract? (option/c (box/c number?))))
+       (test-true "impersonator" (impersonator-contract? (option/c (object/c))))
+       (test-ok (with/c (option/c number?) 0))
+       (test-ok (with/c (option/c number?) #f))
+       (test-ok (with/c (option/c (-> number? number?)) #f))
+       (test-ok (with/c (option/c (-> number? number?)) +))
+       (test-ok (with/c (option/c (class/c (field [x number?])))
+                        (class object% (super-new) (field [x 0]))))
+       (test-ok (with/c (option/c (class/c (field [x number?]))) #f))
+       (test-ok (with/c (class/c (field [c (option/c string?)]))
+                        (class object% (super-new) (field [c #f]))))
+       (test-bad (with/c (option/c number?) "string"))
+       (test-bad (with/c (option/c (-> number? number?))
+                         (lambda (x y) x)))
+       (test-bad
+         ([with/c (option/c (-> number? number?))
+                  (lambda (x) (void))]
+          0))
+       (test-bad (with/c (option/c (class/c (field [x number?])))
+                        (class object% (super-new))))
+       (test-bad (with/c (option/c (class/c (field [x number?]))) 5))
+       (test-bad
+         (get-field c (with/c (class/c (field [c (option/c string?)]))
+                              (class object%
+                                (super-new)
+                                (field [c 70])))))))))
diff --git a/collects/unstable/contract.rkt b/collects/unstable/contract.rkt
index fa7855a5e4..41db1e1419 100644
--- a/collects/unstable/contract.rkt
+++ b/collects/unstable/contract.rkt
@@ -77,6 +77,57 @@
                            #:projection proj
                            #:first-order ctc-fo)))))
 
+;; Added by asumu
+;; option/c : contract -> contract
+(define (option/c ctc-arg)
+  (define ctc (coerce-contract 'option/c ctc-arg))
+  (cond [(flat-contract? ctc) (flat-option/c ctc)]
+        [(chaperone-contract? ctc) (chaperone-option/c ctc)]
+        [else (impersonator-option/c ctc)]))
+
+(define (option/c-name ctc)
+  (build-compound-type-name 'option/c (base-option/c-ctc ctc)))
+
+(define (option/c-projection ctc)
+  (define ho-proj (contract-projection (base-option/c-ctc ctc)))
+  (λ (blame)
+    (define partial (ho-proj blame))
+    (λ (val)
+      (if (not val) val (partial val)))))
+
+(define ((option/c-first-order ctc) v)
+  (or (not v) (contract-first-order-passes? (base-option/c-ctc ctc) v)))
+
+(define (option/c-stronger? this that)
+  (and (base-option/c? that)
+       (contract-stronger? (base-option/c-ctc this)
+                           (base-option/c-ctc that))))
+
+(struct base-option/c (ctc))
+
+(struct flat-option/c base-option/c ()
+        #:property prop:flat-contract
+        (build-flat-contract-property
+          #:name option/c-name
+          #:first-order option/c-first-order
+          #:stronger option/c-stronger?))
+
+(struct chaperone-option/c base-option/c ()
+        #:property prop:chaperone-contract
+        (build-chaperone-contract-property
+          #:name option/c-name
+          #:first-order option/c-first-order
+          #:projection option/c-projection
+          #:stronger option/c-stronger?))
+
+(struct impersonator-option/c base-option/c ()
+        #:property prop:contract
+        (build-contract-property
+          #:name option/c-name
+          #:first-order option/c-first-order
+          #:projection option/c-projection
+          #:stronger option/c-stronger?))
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;
 ;;  Flat Contracts
@@ -368,6 +419,7 @@
  [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?]
diff --git a/collects/unstable/scribblings/contract.scrbl b/collects/unstable/scribblings/contract.scrbl
index a033360731..ae95e887fc 100644
--- a/collects/unstable/scribblings/contract.scrbl
+++ b/collects/unstable/scribblings/contract.scrbl
@@ -79,6 +79,15 @@ The resulting contract is a flat contract if @racket[contract] is a
 flat contract.
 }
 
+@addition{Asumu Takikawa}
+
+@defproc[(option/c [contract contract?]) contract?]{
+
+Creates a contract that acts like @racket[contract] but will also
+accept @racket[#f]. Intended to describe situations where a failure
+or default value may be used.
+}
+
 @addition[@author+email["Carl Eastlund" "cce@racket-lang.org"]]
 
 @section{Flat Contracts}