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

Added option/c for possibly #f values in unstable.

Browse Source
This commit is contained in:
Asumu Takikawa 2011-05-25 02:40:53 -04:00
parent 7f143f03ed
commit f4aab53efa
3 changed files with 91 additions and 1 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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])))))))))

52
collects/unstable/contract.rkt
View File

@ -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?]

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

@ -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}