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

made sure that all of the mzlib/contract exports are documented

Browse Source 
(some by using racket/contract exports and some by adding
   more docs)

original commit: 1fdfd8406df526cacf803e037c1f69b29d916828
This commit is contained in:
Robby Findler 2011-04-25 11:33:38 -05:00
parent 0604c1fe24
commit 2fd831d01e
3 changed files with 36 additions and 96 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

42
collects/mzlib/contract.rkt
View File

@ -2,11 +2,13 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; provide arrow contracts from our local copy
;; provide arrow contracts from our local copy (mostly)
;;
(require "private/contract-arrow.rkt")
(provide (all-from-out "private/contract-arrow.rkt"))
(require (only-in racket/contract unconstrained-domain->))
(provide unconstrained-domain->)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
@ -15,6 +17,18 @@
(require "private/contract-object.rkt")
(provide (all-from-out "private/contract-object.rkt"))
(require (only-in racket/class
is-a?/c
implementation?/c
subclass?/c
mixin-contract
make-mixin-contract))
(provide is-a?/c
implementation?/c
subclass?/c
mixin-contract
make-mixin-contract)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; old-style define/contract
@ -54,13 +68,16 @@
racket/contract/private/basic-opters
racket/contract/combinator)
(define (build-flat-contract name pred) (make-predicate-contract name pred))
(provide
opt/c define-opt/c ;(all-from "private/contract-opt.rkt")
(except-out (all-from-out racket/contract/private/ds)
contract-struct)
(all-from-out racket/contract/private/base)
(all-from-out racket/contract/private/provide)
(all-from-out racket/contract/private/base
racket/contract/private/provide)
(except-out (all-from-out racket/contract/private/misc)
check-between/c
string-len/c
@ -69,8 +86,17 @@
(rename-out [string-len/c string/len])
(except-out (all-from-out racket/contract/private/guts)
check-flat-contract
check-flat-named-contract)
(all-from-out racket/contract/private/prop
racket/contract/private/blame
racket/contract/combinator))
check-flat-named-contract
make-predicate-contract)
(except-out (all-from-out racket/contract/private/blame)
make-blame)
(except-out (all-from-out racket/contract/private/prop)
chaperone-contract-struct?
contract-struct-first-order
contract-struct-name
contract-struct-projection
contract-struct-stronger?
contract-struct?
flat-contract-struct?)
(all-from-out racket/contract/combinator)
build-flat-contract)

41
collects/mzlib/private/contract-arrow.rkt
View File

@ -22,51 +22,12 @@
->pp-rest
case->
opt->
opt->*
unconstrained-domain->)
opt->*)
(define-struct contracted-function (proc ctc)
#:property prop:procedure 0
#:property prop:contracted 1)
(define-syntax (unconstrained-domain-> stx)
(syntax-case stx ()
[(_ rngs ...)
(with-syntax ([(rngs-x ...) (generate-temporaries #'(rngs ...))]
[(proj-x ...) (generate-temporaries #'(rngs ...))]
[(p-app-x ...) (generate-temporaries #'(rngs ...))]
[(res-x ...) (generate-temporaries #'(rngs ...))])
#'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
(let ([proj-x (contract-projection rngs-x)] ...)
(define name
(build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...))
(define (proj wrapper)
(λ (blame)
(let* ([p-app-x (proj-x blame)] ...
[res-checker (λ (res-x ...) (values (p-app-x res-x) ...))])
(λ (val)
(if (procedure? val)
(wrapper
val
(make-keyword-procedure
(λ (kwds kwd-vals . args)
(apply values res-checker kwd-vals args))
(λ args
(apply values res-checker args)))
impersonator-prop:contracted ctc)
(raise-blame-error blame val "expected a procedure"))))))
(define ctc
(if (and (chaperone-contract? rngs-x) ...)
(make-chaperone-contract
#:name name
#:projection (proj chaperone-procedure)
#:first-order procedure?)
(make-contract
#:name name
#:projection (proj impersonate-procedure)
#:first-order procedure?)))
ctc)))]))
(define (build--> name doms doms-rest rngs kwds quoted-kwds rng-any? func)
(let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)]
[rngs/c (map (λ (rng) (coerce-contract name rng)) rngs)]

49
collects/mzlib/private/contract-object.rkt
View File

@ -10,12 +10,7 @@
racket/contract/private/helpers
"contract-arr-obj-helpers.rkt"))
(provide mixin-contract
make-mixin-contract
is-a?/c
subclass?/c
implementation?/c
object-contract)
(provide object-contract)
(define-syntax object-contract
(let ()
@ -303,46 +298,4 @@
ctc))))]))))
(define (make-mixin-contract . %/<%>s)
((and/c (flat-contract class?)
(apply and/c (map sub/impl?/c %/<%>s)))
. ->d .
subclass?/c))
(define (subclass?/c %)
(unless (class? %)
(error 'subclass?/c "expected <class>, given: ~e" %))
(let ([name (object-name %)])
(flat-named-contract
`(subclass?/c ,(or name 'unknown%))
(lambda (x) (subclass? x %)))))
(define (implementation?/c <%>)
(unless (interface? <%>)
(error 'implementation?/c "expected <interface>, given: ~e" <%>))
(let ([name (object-name <%>)])
(flat-named-contract
`(implementation?/c ,(or name 'unknown<%>))
(lambda (x) (implementation? x <%>)))))
(define (sub/impl?/c %/<%>)
(cond
[(interface? %/<%>) (implementation?/c %/<%>)]
[(class? %/<%>) (subclass?/c %/<%>)]
[else (error 'make-mixin-contract "unknown input ~e" %/<%>)]))
(define (is-a?/c <%>)
(unless (or (interface? <%>)
(class? <%>))
(error 'is-a?/c "expected <interface> or <class>, given: ~e" <%>))
(let ([name (object-name <%>)])
(flat-named-contract
(cond
[name
`(is-a?/c ,name)]
[(class? <%>)
`(is-a?/c unknown%)]
[else `(is-a?/c unknown<%>)])
(lambda (x) (is-a? x <%>)))))
(define mixin-contract (class? . ->d . subclass?/c))