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

added the racket/contract/combinator library,

Browse Source 
and documented and adjusted these libraries:
     racket/contract/base
     racket/contract/exists
     racket/contract/parametric (renamed from exists)
     racket/contract/region
This commit is contained in:
Robby Findler 2011-04-20 16:49:39 -05:00
parent 6b7e844254
commit 21cbd9ad81
47 changed files with 524 additions and 1049 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/mzlib/contract.rkt
View File

@ -51,7 +51,8 @@
racket/contract/private/blame racket/contract/private/blame
racket/contract/private/ds racket/contract/private/ds
racket/contract/private/opt racket/contract/private/opt
racket/contract/private/basic-opters) racket/contract/private/basic-opters
racket/contract/combinator)
(provide (provide
opt/c define-opt/c ;(all-from "private/contract-opt.rkt") opt/c define-opt/c ;(all-from "private/contract-opt.rkt")
@ -70,5 +71,6 @@
check-flat-contract check-flat-contract
check-flat-named-contract) check-flat-named-contract)
(all-from-out racket/contract/private/prop (all-from-out racket/contract/private/prop
racket/contract/private/blame)) racket/contract/private/blame
racket/contract/combinator))

2
collects/mzlib/integer-set.rkt
View File

@ -428,7 +428,7 @@
(provide well-formed-set?) (provide well-formed-set?)
(provide/contract (struct integer-set ((contents (flat-named-contract "integer-set-list" well-formed-set?)))) (provide/contract (struct integer-set ((contents well-formed-set?)))
(make-range (make-range
(->i () ((i exact-integer?) (j (i) (and/c exact-integer? (>=/c i)))) [res integer-set?])) (->i () ((i exact-integer?) (j (i) (and/c exact-integer? (>=/c i)))) [res integer-set?]))
(rename merge union (integer-set? integer-set? . -> . integer-set?)) (rename merge union (integer-set? integer-set? . -> . integer-set?))

3
collects/mzlib/private/contract-arr-checks.rkt
View File

@ -2,7 +2,8 @@
(provide (all-defined-out)) (provide (all-defined-out))
(require racket/contract/private/guts (require racket/contract/private/guts
racket/contract/private/blame) racket/contract/private/blame
racket/contract/private/misc)
(define empty-case-lambda/c (define empty-case-lambda/c
(flat-named-contract '(case->) (flat-named-contract '(case->)

1
collects/mzlib/private/contract-arr-obj-helpers.rkt
View File

@ -5,6 +5,7 @@
(require (for-syntax scheme/base)) (require (for-syntax scheme/base))
(require (for-template scheme/base) (require (for-template scheme/base)
(for-template racket/contract/private/guts (for-template racket/contract/private/guts
racket/contract/private/misc
racket/contract/private/prop racket/contract/private/prop
racket/contract/private/blame) racket/contract/private/blame)
(for-template "contract-arr-checks.rkt")) (for-template "contract-arr-checks.rkt"))

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

@ -4,6 +4,7 @@
racket/contract/private/blame racket/contract/private/blame
racket/contract/private/prop racket/contract/private/prop
racket/contract/private/opt racket/contract/private/opt
racket/contract/private/misc
"contract-arr-checks.rkt") "contract-arr-checks.rkt")
(require (for-syntax racket/base) (require (for-syntax racket/base)
(for-syntax racket/contract/private/opt-guts) (for-syntax racket/contract/private/opt-guts)

3
collects/mzlib/private/contract-mutable.rkt
View File

@ -5,7 +5,8 @@
vector-immutableof vector-immutable/c) vector-immutableof vector-immutable/c)
racket/contract/private/blame racket/contract/private/blame
racket/contract/private/guts racket/contract/private/guts
racket/contract/private/prop) racket/contract/private/prop
racket/contract/private/misc)
(provide box/c box-immutable/c (provide box/c box-immutable/c
vector/c vectorof vector-immutableof vector-immutable/c) vector/c vectorof vector-immutableof vector-immutable/c)

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

@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(require "contract-arrow.rkt" (require "contract-arrow.rkt"
racket/contract/private/guts racket/contract/private/guts
racket/contract/private/misc
racket/contract/private/prop racket/contract/private/prop
racket/private/class-internal racket/private/class-internal
"contract-arr-checks.rkt") "contract-arr-checks.rkt")

3
collects/mzlib/private/contract-struct.rkt
View File

@ -3,7 +3,8 @@
(require (for-syntax racket/base (require (for-syntax racket/base
racket/contract/private/helpers racket/contract/private/helpers
racket/struct-info) racket/struct-info)
racket/contract/private/guts) racket/contract/private/guts
racket/contract/private/misc)
(provide struct/c) (provide struct/c)

1
collects/mzlib/private/unit-contract.rkt
View File

@ -9,6 +9,7 @@
"unit-syntax.rkt") "unit-syntax.rkt")
(for-meta 2 racket/base) (for-meta 2 racket/base)
racket/contract/base racket/contract/base
racket/contract/combinator
"unit-utils.rkt" "unit-utils.rkt"
"unit-runtime.rkt") "unit-runtime.rkt")

2
collects/mzlib/unit.rkt
View File

@ -17,6 +17,8 @@
(require mzlib/etc (require mzlib/etc
racket/contract/base racket/contract/base
racket/contract/region
racket/contract/combinator
scheme/stxparam scheme/stxparam
syntax/location syntax/location
"private/unit-contract.rkt" "private/unit-contract.rkt"

27
collects/racket/contract.rkt
View File

@ -1,19 +1,14 @@
#lang racket/base #lang racket/base
(require "contract/base.rkt"
(require racket/contract/exists "contract/combinator.rkt"
racket/contract/regions "contract/parametric.rkt"
"contract/region.rkt"
"contract/private/basic-opters.rkt" "contract/private/basic-opters.rkt"
"contract/base.rkt"
"contract/private/legacy.rkt" "contract/private/legacy.rkt"
"contract/private/ds.rkt" "contract/private/ds.rkt")
"contract/private/parametric.rkt" (provide (all-from-out "contract/base.rkt"
"private/define-struct.rkt") "contract/combinator.rkt"
"contract/parametric.rkt"
(provide (all-from-out "contract/base.rkt") "contract/region.rkt"
(all-from-out "contract/private/parametric.rkt") "contract/private/legacy.rkt"
(except-out (all-from-out racket/contract/exists) ∀∃?) "contract/private/ds.rkt"))
(all-from-out racket/contract/regions)
(all-from-out "contract/private/legacy.rkt")
(all-from-out "contract/private/ds.rkt"))

38
collects/racket/contract/base.rkt
View File

@ -1,8 +1,5 @@
#lang racket/base #lang racket/base
;; A version of racket/contract without contract regions
;; for use in the macro stepper
(require "private/arrow.rkt" (require "private/arrow.rkt"
"private/arr-i.rkt" "private/arr-i.rkt"
"private/base.rkt" "private/base.rkt"
@ -13,7 +10,6 @@
"private/misc.rkt" "private/misc.rkt"
"private/provide.rkt" "private/provide.rkt"
"private/guts.rkt" "private/guts.rkt"
"private/blame.rkt"
"private/prop.rkt" "private/prop.rkt"
"private/opters.rkt" ;; required for effect to install the opters "private/opters.rkt" ;; required for effect to install the opters
"private/opt.rkt") "private/opt.rkt")
@ -30,30 +26,22 @@
contracted-function-proc contracted-function-proc
contracted-function-ctc contracted-function-ctc
make-contracted-function) make-contracted-function)
(all-from-out "private/arr-i.rkt") (all-from-out "private/arr-i.rkt"
(all-from-out "private/box.rkt") "private/box.rkt"
(all-from-out "private/hash.rkt") "private/hash.rkt"
(all-from-out "private/vector.rkt") "private/vector.rkt"
(all-from-out "private/struct.rkt") "private/struct.rkt")
(except-out (all-from-out "private/base.rkt")
current-contract-region)
(except-out (all-from-out "private/misc.rkt") (except-out (all-from-out "private/misc.rkt")
check-between/c check-between/c
check-unary-between/c) check-unary-between/c)
(all-from-out "private/provide.rkt") (all-from-out "private/provide.rkt")
(all-from-out "private/base.rkt")
(except-out (all-from-out "private/guts.rkt")
check-flat-contract
check-flat-named-contract)
(except-out (all-from-out "private/blame.rkt") make-blame)
(except-out (all-from-out "private/prop.rkt")
contract-struct-name
contract-struct-first-order
contract-struct-projection
contract-struct-stronger?
contract-struct?
chaperone-contract-struct?
flat-contract-struct?)
;; from private/opt.rkt: ;; from private/opt.rkt:
opt/c define-opt/c) opt/c define-opt/c
;; from private/guts.rkt
has-contract?
value-contract
)

23
collects/racket/contract/combinator.rkt Normal file
View File

@ -0,0 +1,23 @@
#lang racket/base
(require "private/prop.rkt"
"private/guts.rkt"
"private/blame.rkt")
(provide
(except-out (all-from-out "private/prop.rkt")
contract-struct-name
contract-struct-first-order
contract-struct-projection
contract-struct-stronger?
contract-struct?
chaperone-contract-struct?
flat-contract-struct?)
(except-out (all-from-out "private/guts.rkt")
check-flat-contract
check-flat-named-contract
make-predicate-contract
has-contract?
value-contract)
(except-out (all-from-out "private/blame.rkt") make-blame))

6
collects/racket/contract/parametric.rkt Normal file
View File

@ -0,0 +1,6 @@
#lang racket/base
(require "private/exists.rkt"
"private/parametric.rkt")
(provide (all-from-out "private/parametric.rkt")
(except-out (all-from-out "private/exists.rkt")
∀∃?))

600
collects/racket/contract/private/arr-i-old.rkt
View File

@ -1,600 +0,0 @@
#lang racket/base
(require "guts.rkt"
"arrow.rkt"
"opt.rkt"
"blame.rkt"
"prop.rkt"
racket/stxparam
(for-syntax racket/base
syntax/stx
syntax/name
"arr-i-parse.rkt"
"opt-guts.rkt"
"helpers.rkt"
"arr-util.rkt"))
(provide ->i)
(define-for-syntax (make-this-parameters id)
(if (syntax-parameter-value #'making-a-method)
(list id)
null))
;; parses everything after the mandatory and optional doms in a ->d contract
(define-for-syntax (parse-leftover stx leftover)
(let*-values ([(raw-optional-doms leftover)
(syntax-case leftover ()
[(kwd . leftover2)
(keyword? (syntax-e #'kwd))
(values '() leftover)]
[(dep-range)
(values '() leftover)]
[(dep-range #:post . more)
(values '() leftover)]
[((opts ...) . rest)
(values #'(opts ...) #'rest)]
[_ (values '() leftover)])]
[(id/rest-id leftover)
(syntax-case leftover ()
[(#:rest [id rest-expr] . leftover)
(and (identifier? #'id)
(not (keyword? (syntax-e #'rest-expr))))
(values #'(id rest-expr) #'leftover)]
[(#:rest [id (id2 ...) rest-expr] . leftover)
(and (identifier? #'id)
(andmap identifier? (syntax->list #'(id2 ...)))
(not (keyword? (syntax-e #'rest-expr))))
(values #'(id rest-expr) #'leftover)]
[(#:rest something . leftover)
(raise-syntax-error #f "expected id+ctc" stx #'something)]
[_ (values #f leftover)])]
[(pre-cond leftover)
(syntax-case leftover ()
[(#:pre (id ...) pre-cond . leftover)
(values #'pre-cond #'leftover)]
[_ (values #f leftover)])]
[(range leftover)
(syntax-case leftover ()
[(range . leftover) (values #'range #'leftover)]
[_
(raise-syntax-error #f "expected a range expression, but found nothing" stx)])]
[(post-cond leftover)
(syntax-case leftover ()
[(#:post (id ...) post-cond . leftover)
(begin
(syntax-case range (any)
[any (raise-syntax-error #f "cannot have a #:post with any as the range" stx #'post-cond)]
[_ (void)])
(values #'post-cond #'leftover))]
[_ (values #f leftover)])])
(syntax-case leftover ()
[()
(values raw-optional-doms id/rest-id pre-cond range post-cond)]
[_
(raise-syntax-error #f "bad syntax" stx)])))
;; verify-->i-structure : syntax syntax -> syntax
;; returns the second argument when it has the proper shape for the first two arguments to ->i
;; otherwise, raises a syntax error.
;; also: drops the extra identifiers in the ->i.
(define-for-syntax (verify-->i-structure stx doms)
(syntax-case doms ()
[((regular ...) (kwd ...))
(let ([check-pair-shape
(λ (reg)
(syntax-case reg ()
[(id dom)
(identifier? #'id)
reg]
[(a b)
(raise-syntax-error #f "expected an identifier" stx #'a)]
[(id (id2 ...) dom)
(and (identifier? #'id)
(andmap identifier? (syntax->list #'(id2 ...))))
#'(id dom)]
[(id ids dom)
(unless (identifier? #'id)
(raise-syntax-error #f "expected an identifier" stx #'id))
(raise-syntax-error #f "expected an sequence of identifiers" stx #'ids)]
[_
(raise-syntax-error #f "expected an identifier and a contract-expr" stx reg)]))])
(list (map check-pair-shape (syntax->list #'(regular ...)))
(map
(λ (kwd)
(syntax-case kwd ()
[(kwd ps)
#`(kwd #,(check-pair-shape #'ps))]))
(syntax->list #'(kwd ...)))))]))
(define-for-syntax (make-this-transformer this-arg)
(with-syntax ([this-arg this-arg])
(make-set!-transformer
(λ (sstx)
(syntax-case sstx (set!)
[(set! id arg)
(raise-syntax-error #f
"can't mutate this"
sstx)]
[id
(identifier? #'id)
(syntax/loc sstx this-arg)]
[(id . args)
(datum->syntax sstx (cons #'this-arg #'args) sstx)])))))
(define-for-syntax (find-pre/post-keywords stx)
(let ([pre #f]
[post #f])
(let loop ([stx (syntax->list stx)])
(cond
[(syntax? stx)
(loop (syntax-e stx))]
[(pair? stx)
(when (and (syntax? (car stx))
(eq? (syntax-e (car stx))
'#:pre))
(set! pre (car stx)))
(when (and (syntax? (car stx))
(eq? (syntax-e (car stx))
'#:post))
(set! post (car stx)))
(loop (cdr stx))]
[else (void)]))
(values pre post)))
(define-syntax (->i stx)
(parse-->i stx)
(printf "finished ->i parsing\n")
(syntax-case stx ()
[(_ (raw-mandatory-doms ...)
.
leftover)
(let-values ([(raw-optional-doms id/rest pre-cond range post-cond) (parse-leftover stx #'leftover)]
[(this->i) (gensym '->i)])
(define (add-indy-prop stx)
(syntax-property stx 'racket/contract:internal-contract (gensym '->i-boundary)))
(with-syntax ([(([mandatory-regular-id mandatory-dom/no-prop] ... )
([mandatory-kwd (mandatory-kwd-id mandatory-kwd-dom/no-prop)] ...))
(verify-->i-structure stx (split-doms stx '->i #'(raw-mandatory-doms ...)))]
[(([optional-regular-id optional-dom/no-prop] ...)
([optional-kwd (optional-kwd-id optional-kwd-dom/no-prop)] ...))
(verify-->i-structure stx (split-doms stx '->i raw-optional-doms))])
(with-syntax ([(mandatory-dom ...) (map (λ (x) (add-indy-prop (syntax-property x 'racket/contract:negative-position this->i)))
(syntax->list #'(mandatory-dom/no-prop ...)))]
[(mandatory-kwd-dom ...) (map (λ (x) (add-indy-prop (syntax-property x 'racket/contract:negative-position this->i)))
(syntax->list #'(mandatory-kwd-dom/no-prop ...)))]
[(optional-dom ...) (map (λ (x) (add-indy-prop (syntax-property x 'racket/contract:negative-position this->i)))
(syntax->list #'(optional-dom/no-prop ...)))]
[(optional-kwd-dom ...) (map (λ (x) (syntax-property x 'racket/contract:negative-position this->i))
(syntax->list #'(optional-kwd-dom/no-prop ...)))])
(with-syntax ([((kwd kwd-id) ...)
(sort-keywords
stx
(syntax->list
#'((optional-kwd optional-kwd-id) ...
(mandatory-kwd mandatory-kwd-id) ...)))]
[(this-parameter ...)
(make-this-parameters (if (syntax? (syntax-parameter-value #'making-a-method))
(car (generate-temporaries '(this)))
(datum->syntax stx 'this #f)))])
(with-syntax ([(dom-params ...)
#`(this-parameter ...
mandatory-regular-id ...
optional-regular-id ...
#,@(if id/rest
(with-syntax ([(id rst-ctc) id/rest])
#'(id))
#'())
kwd-id ...)])
(with-syntax ([((rng-params ...) rng-ctcs)
(syntax-case range (any values)
[(values ctc-pr ...)
(with-syntax ([((id ctc/no-prop) ...)
(map (lambda (x) (syntax-case x ()
[[id ctc/no-prop] #'[id ctc/no-prop]]
[[id (id2 ...) ctc/no-prop] #'[id ctc/no-prop]]
[x (raise-syntax-error #f "expected binding pair" stx #'x)]))
(syntax->list #'(ctc-pr ...)))])
(with-syntax ([(ctc ...) (map (λ (x) (add-indy-prop (syntax-property x 'racket/contract:positive-position this->i)))
(syntax->list #'(ctc/no-prop ...)))])
#'((id ...) (ctc ...))))]
[any #'(() #f)]
[[id ctc]
#`((id) (#,(add-indy-prop (syntax-property #'ctc 'racket/contract:positive-position this->i))))]
[[id (id2 ...) ctc]
#`((id) (#,(add-indy-prop (syntax-property #'ctc 'racket/contract:positive-position this->i))))]
[x (raise-syntax-error #f "expected binding pair or any" stx #'x)])]
[mtd? (and (syntax-parameter-value #'making-a-method) #t)])
(let ([rng-underscores?
(let ([is-underscore?
(λ (x)
(syntax-case x (_)
[_ #t]
[else #f]))])
(cond
[(andmap is-underscore? (syntax->list #'(rng-params ...)))
#t]
[(ormap (λ (x) (and (is-underscore? x) x))
(syntax->list #'(rng-params ...)))
=>
(λ (id)
(raise-syntax-error '->i
"expected all of the identifiers to be underscores, or none of them to be"
stx
id))]
[else #f]))])
(let ([dup (check-duplicate-identifier
(append (if rng-underscores?
'()
(syntax->list #'(rng-params ...)))
(syntax->list #'(dom-params ...))))])
(when dup
(raise-syntax-error #f "duplicate identifier" stx dup)))
#`(let-syntax ([parameterize-this
(let ([old-param (syntax-parameter-value #'making-a-method)])
(λ (stx)
(syntax-case stx ()
[(_ body) #'body]
[(_ id body)
(if (syntax? old-param)
(with-syntax ([param old-param])
(syntax/loc stx
(syntax-parameterize
([param (make-this-transformer #'id)])
body)))
#'body)])))])
(syntax-parameterize
((making-a-method #f))
#,(syntax-property
#`(build-->d mtd?
(list (λ (dom-params ...)
(parameterize-this this-parameter ... mandatory-dom)) ...)
(list (λ (dom-params ...)
(parameterize-this this-parameter ... optional-dom)) ...)
(list (λ (dom-params ...)
(parameterize-this this-parameter ... mandatory-kwd-dom)) ...)
(list (λ (dom-params ...)
(parameterize-this this-parameter ... optional-kwd-dom)) ...)
#,(if id/rest
(with-syntax ([(id rst-ctc) id/rest])
#`(λ (dom-params ...)
(parameterize-this this-parameter ... rst-ctc)))
#f)
#,(if pre-cond
#`(λ (dom-params ...)
(parameterize-this this-parameter ... #,pre-cond))
#f)
#,(syntax-case #'rng-ctcs ()
[#f #f]
[(ctc ...)
(if rng-underscores?
#'(box (list (λ (dom-params ...)
(parameterize-this this-parameter ... ctc)) ...))
#'(list (λ (rng-params ... dom-params ...)
(parameterize-this this-parameter ... ctc)) ...))])
#,(if post-cond
#`(λ (rng-params ... dom-params ...)
(parameterize-this this-parameter ... #,post-cond))
#f)
'(mandatory-kwd ...)
'(optional-kwd ...)
(λ (f)
#,(add-name-prop
(syntax-local-infer-name stx)
#`(λ args (apply f args)))))
'racket/contract:contract
(let-values ([(pre-kwd post-kwd) (find-pre/post-keywords #'leftover)])
(vector this->i
;; the -> in the original input to this guy
(let ([kwd (list (car (syntax-e stx)))])
(if post-kwd
(cons post-kwd kwd)
kwd))
(if pre-kwd
(list pre-kwd)
'())))))))))))))]))
(define ->d-tail-key (gensym '->d-tail-key))
(define (->d-proj ->d-stct)
(let* ([opt-count (length (->d-optional-dom-ctcs ->d-stct))]
[mandatory-count (+ (length (->d-mandatory-dom-ctcs ->d-stct))
(if (->d-mtd? ->d-stct) 1 0))]
[non-kwd-ctc-count (+ mandatory-count opt-count)]
[arity
(cond
[(->d-rest-ctc ->d-stct)
(make-arity-at-least mandatory-count)]
[else
(let loop ([i 0])
(cond
[(= i opt-count)
(list (+ mandatory-count i))]
[else
(cons (+ mandatory-count i) (loop (+ i 1)))]))])])
(λ (blame)
(let ([this->d-id (gensym '->d-tail-key)])
(λ (val)
(check-procedure val
(->d-mtd? ->d-stct)
(length (->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
(length (->d-optional-dom-ctcs ->d-stct)) ; optionals-length
(->d-mandatory-keywords ->d-stct)
(->d-optional-keywords ->d-stct)
blame)
(let ([kwd-proc
(λ (kwd-args kwd-arg-vals . raw-orig-args)
(let* ([orig-args (if (->d-mtd? ->d-stct)
(cdr raw-orig-args)
raw-orig-args)]
[this (and (->d-mtd? ->d-stct) (car raw-orig-args))]
[dep-pre-args
(build-dep-ctc-args non-kwd-ctc-count raw-orig-args (->d-rest-ctc ->d-stct)
(->d-keywords ->d-stct) kwd-args kwd-arg-vals)]
[thunk
(λ ()
(keyword-apply
val
kwd-args
;; contracted keyword arguments
(let loop ([all-kwds (->d-keywords ->d-stct)]
[kwd-ctcs (->d-keyword-ctcs ->d-stct)]
[building-kwd-args kwd-args]
[building-kwd-arg-vals kwd-arg-vals])
(cond
[(or (null? building-kwd-args) (null? all-kwds)) '()]
[else (if (eq? (car all-kwds)
(car building-kwd-args))
(cons (invoke-dep-ctc (car kwd-ctcs) dep-pre-args (car building-kwd-arg-vals) (blame-swap blame))
(loop (cdr all-kwds) (cdr kwd-ctcs) (cdr building-kwd-args) (cdr building-kwd-arg-vals)))
(loop (cdr all-kwds) (cdr kwd-ctcs) building-kwd-args building-kwd-arg-vals))]))
(append
;; this parameter (if necc.)
(if (->d-mtd? ->d-stct)
(list (car raw-orig-args))
'())
;; contracted ordinary arguments
(let loop ([args orig-args]
[non-kwd-ctcs (append (->d-mandatory-dom-ctcs ->d-stct)
(->d-optional-dom-ctcs ->d-stct))])
(cond
[(null? args)
(if (->d-rest-ctc ->d-stct)
(invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args '() (blame-swap blame))
'())]
[(null? non-kwd-ctcs)
(if (->d-rest-ctc ->d-stct)
(invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args args (blame-swap blame))
;; ran out of arguments, but don't have a rest parameter.
;; procedure-reduce-arity (or whatever the new thing is
;; going to be called) should ensure this doesn't happen.
(error 'shouldnt\ happen))]
[else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) (blame-swap blame))
(loop (cdr args)
(cdr non-kwd-ctcs)))])))))]
[rng (let ([rng (->d-range ->d-stct)])
(cond
[(not rng) #f]
[(box? rng)
(map (λ (val) (apply val dep-pre-args))
(unbox rng))]
[else rng]))]
[rng-underscore? (box? (->d-range ->d-stct))])
(when (->d-pre-cond ->d-stct)
(unless (apply (->d-pre-cond ->d-stct) dep-pre-args)
(raise-blame-error (blame-swap blame)
val
"#:pre violation~a"
(build-values-string ", argument" dep-pre-args))))
(call-with-immediate-continuation-mark
->d-tail-key
(λ (first-mark)
(cond
[(and rng
(not (and first-mark
(eq? this->d-id (car first-mark))
(andmap eq? raw-orig-args (cdr first-mark)))))
(call-with-values
(λ ()
(with-continuation-mark ->d-tail-key (cons this->d-id raw-orig-args)
(thunk)))
(λ orig-results
(let* ([range-count (length rng)]
[post-args (append orig-results raw-orig-args)]
[post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)]
[dep-post-args (build-dep-ctc-args post-non-kwd-arg-count
post-args (->d-rest-ctc ->d-stct)
(->d-keywords ->d-stct) kwd-args kwd-arg-vals)])
(when (->d-post-cond ->d-stct)
(unless (apply (->d-post-cond ->d-stct) dep-post-args)
(raise-blame-error blame
val
"#:post violation~a~a"
(build-values-string ", argument" dep-pre-args)
(build-values-string (if (null? dep-pre-args)
", result"
"\n result")
orig-results))))
(unless (= range-count (length orig-results))
(raise-blame-error blame
val
"expected ~a results, got ~a"
range-count
(length orig-results)))
(apply
values
(let loop ([results orig-results]
[result-contracts rng])
(cond
[(null? result-contracts) '()]
[else
(cons
(invoke-dep-ctc (car result-contracts)
(if rng-underscore? #f dep-post-args)
(car results)
blame)
(loop (cdr results) (cdr result-contracts)))]))))))]
[else
(thunk)])))))])
(make-contracted-function
(procedure-reduce-keyword-arity
(make-keyword-procedure kwd-proc
((->d-name-wrapper ->d-stct)
(λ args
(apply kwd-proc '() '() args))))
arity
(->d-mandatory-keywords ->d-stct)
(->d-keywords ->d-stct))
->d-stct)))))))
(define (build-values-string desc dep-pre-args)
(cond
[(null? dep-pre-args) ""]
[(null? (cdr dep-pre-args)) (format "~a was: ~e" desc (car dep-pre-args))]
[else
(apply
string-append
(format "~as were:" desc)
(let loop ([lst dep-pre-args])
(cond
[(null? lst) '()]
[else (cons (format "\n ~e" (car lst))
(loop (cdr lst)))])))]))
;; invoke-dep-ctc : (...? -> ctc) (or/c #f (listof tst)) val pos-blame neg-blame src-info orig-src -> tst
(define (invoke-dep-ctc dep-ctc dep-args val blame)
(let ([ctc (coerce-contract '->d (if dep-args
(apply dep-ctc dep-args)
dep-ctc))])
(((contract-projection ctc) blame) val)))
;; build-dep-ctc-args : number (listof any) boolean (listof keyword) (listof keyword) (listof any)
(define (build-dep-ctc-args non-kwd-ctc-count args rest-arg? all-kwds supplied-kwds supplied-args)
(append
;; ordinary args (possibly including `this' as the first element)
(let loop ([count non-kwd-ctc-count]
[args args])
(cond
[(zero? count)
(if rest-arg?
(list args)
'())]
[(null? args) (cons the-unsupplied-arg (loop (- count 1) null))]
[else (cons (car args) (loop (- count 1) (cdr args)))]))
;; kwd args
(let loop ([all-kwds all-kwds]
[kwds supplied-kwds]
[args supplied-args])
(cond
[(null? all-kwds) null]
[else (let* ([kwd (car all-kwds)]
[kwd-matches? (and (not (null? kwds)) (eq? (car kwds) kwd))])
(if kwd-matches?
(cons (car args) (loop (cdr all-kwds) (cdr kwds) (cdr args)))
(cons the-unsupplied-arg (loop (cdr all-kwds) kwds args))))]))))
(define (build-->d mtd?
mandatory-dom-ctcs optional-dom-ctcs
mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs
rest-ctc pre-cond range post-cond
mandatory-kwds optional-kwds
name-wrapper)
(let ([kwd/ctc-pairs (sort
(map cons
(append mandatory-kwds optional-kwds)
(append mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs))
(λ (x y) (keyword<? (car x) (car y))))])
(make-->d mtd?
mandatory-dom-ctcs optional-dom-ctcs
(map cdr kwd/ctc-pairs)
rest-ctc pre-cond range post-cond
(map car kwd/ctc-pairs)
mandatory-kwds
optional-kwds
name-wrapper)))
;; in the struct type descriptions "d???" refers to the arguments (domain) of the function that
;; is under the contract, and "dr???" refers to the arguments & the results of the function that
;; is under the contract.
;; the `box' in the range only serves to differentiate between range contracts that depend on
;; both the domain and the range from those that depend only on the domain (and thus, those
;; that can be applied early)
(define-struct ->d (mtd? ;; boolean; indicates if this is a contract on a method, for error reporing purposes.
mandatory-dom-ctcs ;; (listof (-> d??? ctc))
optional-dom-ctcs ;; (listof (-> d??? ctc))
keyword-ctcs ;; (listof (-> d??? ctc))
rest-ctc ;; (or/c false/c (-> d??? ctc))
pre-cond ;; (-> d??? boolean)
range ;; (or/c false/c (listof (-> dr??? ctc)) (box (listof (-> r??? ctc))))
post-cond ;; (-> dr??? boolean)
keywords ;; (listof keywords) -- sorted by keyword<
mandatory-keywords ;; (listof keywords) -- sorted by keyword<
optional-keywords ;; (listof keywords) -- sorted by keyword<
name-wrapper) ;; (-> proc proc)
#:omit-define-syntaxes
#:property prop:contract
(build-contract-property
#:projection ->d-proj
#:name
(λ (ctc)
(let* ([counting-id 'x]
[ids '(x y z w)]
[next-id
(λ ()
(cond
[(pair? ids)
(begin0 (car ids)
(set! ids (cdr ids)))]
[(null? ids)
(begin0
(string->symbol (format "~a0" counting-id))
(set! ids 1))]
[else
(begin0
(string->symbol (format "~a~a" counting-id ids))
(set! ids (+ ids 1)))]))])
`(->i (,@(map (λ (x) `(,(next-id) ...)) (->d-mandatory-dom-ctcs ctc))
,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-mandatory-keywords ctc))))
(,@(map (λ (x) `(,(next-id) ...)) (->d-optional-dom-ctcs ctc))
,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-optional-keywords ctc))))
,@(if (->d-rest-ctc ctc)
(list '#:rest (next-id) '...)
'())
,@(if (->d-pre-cond ctc)
(list '#:pre '...)
(list))
,(let ([range (->d-range ctc)])
(cond
[(not range) 'any]
[(box? range)
(let ([range (unbox range)])
(cond
[(and (not (null? range))
(null? (cdr range)))
`[_ ...]]
[else
`(values ,@(map (λ (x) `(_ ...)) range))]))]
[(and (not (null? range))
(null? (cdr range)))
`[,(next-id) ...]]
[else
`(values ,@(map (λ (x) `(,(next-id) ...)) range))]))
,@(if (->d-post-cond ctc)
(list '#:post '...)
(list)))))
#:first-order (λ (ctc) (λ (x) #f))
#:stronger (λ (this that) (eq? this that))))

2
collects/racket/contract/private/arr-i-parse.rkt
View File

@ -7,6 +7,8 @@
[module-identifier-mapping-get free-identifier-mapping-get] [module-identifier-mapping-get free-identifier-mapping-get]
[module-identifier-mapping-put! free-identifier-mapping-put!]) [module-identifier-mapping-put! free-identifier-mapping-put!])
(for-template racket/base (for-template racket/base
"misc.rkt"
"prop.rkt"
"guts.rkt")) "guts.rkt"))
#| #|

1
collects/racket/contract/private/arr-i.rkt
View File

@ -4,6 +4,7 @@
"prop.rkt" "prop.rkt"
"guts.rkt" "guts.rkt"
"opt.rkt" "opt.rkt"
"misc.rkt"
"blame.rkt" "blame.rkt"
syntax/location syntax/location
(for-syntax racket/base (for-syntax racket/base

1
collects/racket/contract/private/arrow.rkt
View File

@ -21,6 +21,7 @@ v4 todo:
(require "guts.rkt" (require "guts.rkt"
"blame.rkt" "blame.rkt"
"prop.rkt" "prop.rkt"
"misc.rkt"
racket/stxparam) racket/stxparam)
(require (for-syntax racket/base) (require (for-syntax racket/base)
(for-syntax "helpers.rkt") (for-syntax "helpers.rkt")

3
collects/racket/contract/private/base.rkt
View File

@ -20,7 +20,8 @@ improve method arity mismatch contract violation error messages?
"guts.rkt" "guts.rkt"
"blame.rkt" "blame.rkt"
"prop.rkt" "prop.rkt"
"arrow.rkt") "arrow.rkt"
"misc.rkt")
(define-syntax-parameter current-contract-region (define-syntax-parameter current-contract-region
(λ (stx) #'(quote-module-path))) (λ (stx) #'(quote-module-path)))

3
collects/racket/contract/private/basic-opters.rkt
View File

@ -3,7 +3,8 @@
(require "guts.rkt" (require "guts.rkt"
"blame.rkt" "blame.rkt"
"opt.rkt" "opt.rkt"
"base.rkt") "base.rkt"
"misc.rkt")
(require (for-syntax racket/base (require (for-syntax racket/base
"opt-guts.rkt")) "opt-guts.rkt"))

3
collects/racket/contract/private/box.rkt
View File

@ -3,7 +3,8 @@
(require (for-syntax racket/base) (require (for-syntax racket/base)
"prop.rkt" "prop.rkt"
"blame.rkt" "blame.rkt"
"guts.rkt") "guts.rkt"
"misc.rkt")
(provide box-immutable/c (provide box-immutable/c
(rename-out [wrap-box/c box/c])) (rename-out [wrap-box/c box/c]))

3
collects/racket/contract/private/ds.rkt
View File

@ -20,7 +20,8 @@ it around flattened out.
(require "guts.rkt" (require "guts.rkt"
"prop.rkt" "prop.rkt"
"blame.rkt" "blame.rkt"
"opt.rkt") "opt.rkt"
"misc.rkt")
(require (for-syntax scheme/base) (require (for-syntax scheme/base)
(for-syntax "ds-helpers.rkt") (for-syntax "ds-helpers.rkt")
(for-syntax "helpers.rkt") (for-syntax "helpers.rkt")

6
collects/racket/contract/exists.rkt → collects/racket/contract/private/exists.rkt
View File

@ -1,8 +1,8 @@
#lang racket/base #lang racket/base
(require "private/guts.rkt" (require "guts.rkt"
"private/prop.rkt" "prop.rkt"
"private/blame.rkt") "blame.rkt")
(provide new-∃/c (provide new-∃/c
new-∀/c new-∀/c

200
collects/racket/contract/private/guts.rkt
View File

@ -16,24 +16,8 @@
coerce-chaperone-contracts coerce-chaperone-contracts
coerce-contract/f coerce-contract/f
chaperone-contract?
flat-contract?
flat-contract
flat-contract-predicate
flat-named-contract
build-compound-type-name build-compound-type-name
and/c
any/c
none/c
make-none/c
contract?
contract-name
contract-projection
contract-stronger? contract-stronger?
contract-first-order contract-first-order
@ -47,11 +31,12 @@
;; for opters ;; for opters
check-flat-contract check-flat-contract
check-flat-named-contract check-flat-named-contract
any
;; helpers for adding properties that check syntax uses ;; helpers for adding properties that check syntax uses
define/final-prop define/final-prop
define/subexpression-pos-prop) define/subexpression-pos-prop
make-predicate-contract)
(define (has-contract? v) (define (has-contract? v)
(or (has-prop:contracted? v) (or (has-prop:contracted? v)
@ -79,9 +64,6 @@
(define-values (impersonator-prop:contracted has-impersonator-prop:contracted? get-impersonator-prop:contracted) (define-values (impersonator-prop:contracted has-impersonator-prop:contracted? get-impersonator-prop:contracted)
(make-impersonator-property 'impersonator-prop:contracted)) (make-impersonator-property 'impersonator-prop:contracted))
(define-syntax (any stx)
(raise-syntax-error 'any "use of 'any' outside the range of an arrow contract" stx))
(define (contract-first-order c) (define (contract-first-order c)
(contract-struct-first-order (contract-struct-first-order
(coerce-contract 'contract-first-order c))) (coerce-contract 'contract-first-order c)))
@ -176,7 +158,7 @@
[(number? x) (make-=-contract x)] [(number? x) (make-=-contract x)]
[(or (regexp? x) (byte-regexp? x)) (make-regexp/c x)] [(or (regexp? x) (byte-regexp? x)) (make-regexp/c x)]
[else #f])) [else #f]))
(define-syntax (define/final-prop stx) (define-syntax (define/final-prop stx)
(syntax-case stx () (syntax-case stx ()
[(_ header bodies ...) [(_ header bodies ...)
@ -253,181 +235,12 @@
(list (car (syntax-e stx))) (list (car (syntax-e stx)))
'()))))])))))])) '()))))])))))]))
;
;
;
;
;
; ; ;
; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;;
; ; ; ; ; ;; ; ; ;; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ;;;; ; ;
; ; ; ; ; ; ; ; ; ; ; ;
; ; ; ; ; ; ; ; ; ; ; ; ; ;
; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;;
;
;
;
(define (flat-contract-predicate x)
(contract-struct-first-order
(coerce-flat-contract 'flat-contract-predicate x)))
(define (flat-contract? x)
(let ([c (coerce-contract/f x)])
(and c
(flat-contract-struct? c))))
(define (chaperone-contract? x)
(let ([c (coerce-contract/f x)])
(and c
(chaperone-contract-struct? c))))
(define (contract-name ctc)
(contract-struct-name
(coerce-contract 'contract-name ctc)))
(define (contract? x) (and (coerce-contract/f x) #t))
(define (contract-projection ctc)
(contract-struct-projection
(coerce-contract 'contract-projection ctc)))
(define (check-flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
(define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
(define (check-flat-named-contract predicate) (coerce-flat-contract 'flat-named-contract predicate))
(define (flat-named-contract name predicate)
(cond
[(and (procedure? predicate)
(procedure-arity-includes? predicate 1))
(make-predicate-contract name predicate)]
[(flat-contract? predicate)
(make-predicate-contract name (flat-contract-predicate predicate))]
[else
(error 'flat-named-contract
"expected a flat contract or procedure of arity 1 as second argument, got ~e"
predicate)]))
;; build-compound-type-name : (union contract symbol) ... -> (-> sexp) ;; build-compound-type-name : (union contract symbol) ... -> (-> sexp)
(define (build-compound-type-name . fs) (define (build-compound-type-name . fs)
(for/list ([sub (in-list fs)]) (for/list ([sub (in-list fs)])
(if (contract-struct? sub) (contract-name sub) sub))) (if (contract-struct? sub) (contract-struct-name sub) sub)))
(define (and-name ctc)
(apply build-compound-type-name 'and/c (base-and/c-ctcs ctc)))
(define (and-first-order ctc)
(let ([tests (map contract-first-order (base-and/c-ctcs ctc))])
(λ (x) (for/and ([test (in-list tests)]) (test x)))))
(define (and-proj ctc)
(let ([mk-pos-projs (map contract-projection (base-and/c-ctcs ctc))])
(lambda (blame)
(let ([projs (map (λ (c) (c blame)) mk-pos-projs)])
(for/fold ([proj (car projs)])
([p (in-list (cdr projs))])
(λ (v) (p (proj v))))))))
(define (first-order-and-proj ctc)
(λ (blame)
(λ (val)
(let loop ([predicates (first-order-and/c-predicates ctc)]
[ctcs (base-and/c-ctcs ctc)])
(cond
[(null? predicates) val]
[else
(if ((car predicates) val)
(loop (cdr predicates) (cdr ctcs))
(raise-blame-error
blame
val
"expected <~s>, given ~a, which isn't ~s"
(contract-name ctc)
val
(contract-name (car ctcs))))])))))
(define (and-stronger? this that)
(and (base-and/c? that)
(let ([this-ctcs (base-and/c-ctcs this)]
[that-ctcs (base-and/c-ctcs that)])
(and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger?
this-ctcs
that-ctcs)))))
(define-struct base-and/c (ctcs))
(define-struct (first-order-and/c base-and/c) (predicates)
#:property prop:flat-contract
(build-flat-contract-property
#:projection first-order-and-proj
#:name and-name
#:first-order and-first-order
#:stronger and-stronger?))
(define-struct (chaperone-and/c base-and/c) ()
#:property prop:chaperone-contract
(build-chaperone-contract-property
#:projection and-proj
#:name and-name
#:first-order and-first-order
#:stronger and-stronger?))
(define-struct (impersonator-and/c base-and/c) ()
#:property prop:contract
(build-contract-property
#:projection and-proj
#:name and-name
#:first-order and-first-order
#:stronger and-stronger?))
(define/subexpression-pos-prop (and/c . raw-fs)
(let ([contracts (coerce-contracts 'and/c raw-fs)])
(cond
[(null? contracts) any/c]
[(andmap flat-contract? contracts)
(let ([preds (map flat-contract-predicate contracts)])
(make-first-order-and/c contracts preds))]
[(andmap chaperone-contract? contracts)
(make-chaperone-and/c contracts)]
[else (make-impersonator-and/c contracts)])))
(define (get-any-projection c) any-projection)
(define (any-projection b) any-function)
(define (any-function x) x)
(define (get-any? c) any?)
(define (any? x) #t)
(define-struct any/c ()
#:omit-define-syntaxes
#:property prop:flat-contract
(build-flat-contract-property
#:projection get-any-projection
#:stronger (λ (this that) (any/c? that))
#:name (λ (ctc) 'any/c)
#:first-order get-any?))
(define/final-prop any/c (make-any/c))
(define (none-curried-proj ctc)
(λ (blame)
(λ (val)
(raise-blame-error
blame
val
"~s accepts no values, given: ~e"
(none/c-name ctc)
val))))
(define-struct none/c (name)
#:omit-define-syntaxes
#:property prop:flat-contract
(build-flat-contract-property
#:projection none-curried-proj
#:stronger (λ (this that) #t)
#:name (λ (ctc) (none/c-name ctc))
#:first-order (λ (ctc) (λ (val) #f))))
(define/final-prop none/c (make-none/c 'none/c))
@ -509,3 +322,6 @@
(predicate-contract-pred that)))) (predicate-contract-pred that))))
#:name (λ (ctc) (predicate-contract-name ctc)) #:name (λ (ctc) (predicate-contract-name ctc))
#:first-order (λ (ctc) (predicate-contract-pred ctc)))) #:first-order (λ (ctc) (predicate-contract-pred ctc))))
(define (check-flat-named-contract predicate) (coerce-flat-contract 'flat-named-contract predicate))
(define (check-flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))

3
collects/racket/contract/private/hash.rkt
View File

@ -3,7 +3,8 @@
(require (for-syntax racket/base) (require (for-syntax racket/base)
"guts.rkt" "guts.rkt"
"blame.rkt" "blame.rkt"
"prop.rkt") "prop.rkt"
"misc.rkt")
(provide (rename-out [wrap-hash/c hash/c])) (provide (rename-out [wrap-hash/c hash/c]))

2
collects/racket/contract/private/legacy.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require "guts.rkt" "blame.rkt" "prop.rkt" syntax/srcloc) (require "guts.rkt" "blame.rkt" "prop.rkt" "misc.rkt" syntax/srcloc)
(provide make-proj-contract (provide make-proj-contract
raise-contract-error raise-contract-error

244
collects/racket/contract/private/misc.rkt
View File

@ -10,6 +10,7 @@
(provide flat-rec-contract (provide flat-rec-contract
flat-murec-contract flat-murec-contract
or/c or/c
and/c
not/c not/c
=/c >=/c <=/c </c >/c between/c =/c >=/c <=/c </c >/c between/c
integer-in integer-in
@ -25,7 +26,23 @@
check-between/c check-between/c
check-unary-between/c check-unary-between/c
parameter/c) parameter/c
any/c
any
none/c
make-none/c
chaperone-contract?
flat-contract?
contract?
flat-contract
flat-contract-predicate
flat-named-contract
contract-projection
contract-name)
(define-syntax (flat-rec-contract stx) (define-syntax (flat-rec-contract stx)
(syntax-case stx () (syntax-case stx ()
@ -280,6 +297,85 @@
#:first-order #:first-order
(λ (ctc) (flat-or/c-pred ctc)))) (λ (ctc) (flat-or/c-pred ctc))))
(define (and-name ctc)
(apply build-compound-type-name 'and/c (base-and/c-ctcs ctc)))
(define (and-first-order ctc)
(let ([tests (map contract-first-order (base-and/c-ctcs ctc))])
(λ (x) (for/and ([test (in-list tests)]) (test x)))))
(define (and-proj ctc)
(let ([mk-pos-projs (map contract-projection (base-and/c-ctcs ctc))])
(lambda (blame)
(let ([projs (map (λ (c) (c blame)) mk-pos-projs)])
(for/fold ([proj (car projs)])
([p (in-list (cdr projs))])
(λ (v) (p (proj v))))))))
(define (first-order-and-proj ctc)
(λ (blame)
(λ (val)
(let loop ([predicates (first-order-and/c-predicates ctc)]
[ctcs (base-and/c-ctcs ctc)])
(cond
[(null? predicates) val]
[else
(if ((car predicates) val)
(loop (cdr predicates) (cdr ctcs))
(raise-blame-error
blame
val
"expected <~s>, given ~a, which isn't ~s"
(contract-name ctc)
val
(contract-name (car ctcs))))])))))
(define (and-stronger? this that)
(and (base-and/c? that)
(let ([this-ctcs (base-and/c-ctcs this)]
[that-ctcs (base-and/c-ctcs that)])
(and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger?
this-ctcs
that-ctcs)))))
(define-struct base-and/c (ctcs))
(define-struct (first-order-and/c base-and/c) (predicates)
#:property prop:flat-contract
(build-flat-contract-property
#:projection first-order-and-proj
#:name and-name
#:first-order and-first-order
#:stronger and-stronger?))
(define-struct (chaperone-and/c base-and/c) ()
#:property prop:chaperone-contract
(build-chaperone-contract-property
#:projection and-proj
#:name and-name
#:first-order and-first-order
#:stronger and-stronger?))
(define-struct (impersonator-and/c base-and/c) ()
#:property prop:contract
(build-contract-property
#:projection and-proj
#:name and-name
#:first-order and-first-order
#:stronger and-stronger?))
(define/subexpression-pos-prop (and/c . raw-fs)
(let ([contracts (coerce-contracts 'and/c raw-fs)])
(cond
[(null? contracts) any/c]
[(andmap flat-contract? contracts)
(let ([preds (map flat-contract-predicate contracts)])
(make-first-order-and/c contracts preds))]
[(andmap chaperone-contract? contracts)
(make-chaperone-and/c contracts)]
[else (make-impersonator-and/c contracts)])))
(define false/c #f) (define false/c #f)
(define/final-prop (string-len/c n) (define/final-prop (string-len/c n)
@ -358,28 +454,6 @@
(let ([elems (one-of/c-elems ctc)]) (let ([elems (one-of/c-elems ctc)])
(λ (x) (memv x elems)))))) (λ (x) (memv x elems))))))
(define printable/c
(flat-named-contract
'printable/c
(λ (x)
(let printable? ([x x])
(or (symbol? x)
(string? x)
(bytes? x)
(boolean? x)
(char? x)
(null? x)
(number? x)
(regexp? x)
(prefab-struct-key x) ;; this cannot be last, since it doesn't return just #t
(and (pair? x)
(printable? (car x))
(printable? (cdr x)))
(and (vector? x)
(andmap printable? (vector->list x)))
(and (box? x)
(printable? (unbox x))))))))
(define-struct between/c (low high) (define-struct between/c (low high)
#:omit-define-syntaxes #:omit-define-syntaxes
#:property prop:flat-contract #:property prop:flat-contract
@ -446,15 +520,6 @@
`(>/c ,x) `(>/c ,x)
(λ (y) (and (real? y) (> y x))))) (λ (y) (and (real? y) (> y x)))))
(define natural-number/c
(flat-named-contract
'natural-number/c
(λ (x)
(and (number? x)
(integer? x)
(exact? x)
(x . >= . 0)))))
(define/final-prop (integer-in start end) (define/final-prop (integer-in start end)
(unless (and (integer? start) (unless (and (integer? start)
(exact? start) (exact? start)
@ -703,3 +768,118 @@
(parameter/c-ctc that)) (parameter/c-ctc that))
(contract-stronger? (parameter/c-ctc that) (contract-stronger? (parameter/c-ctc that)
(parameter/c-ctc this)))))) (parameter/c-ctc this))))))
(define (get-any-projection c) any-projection)
(define (any-projection b) any-function)
(define (any-function x) x)
(define (get-any? c) any?)
(define (any? x) #t)
(define-struct any/c ()
#:omit-define-syntaxes
#:property prop:flat-contract
(build-flat-contract-property
#:projection get-any-projection
#:stronger (λ (this that) (any/c? that))
#:name (λ (ctc) 'any/c)
#:first-order get-any?))
(define/final-prop any/c (make-any/c))
(define-syntax (any stx)
(raise-syntax-error 'any "use of 'any' outside the range of an arrow contract" stx))
(define (none-curried-proj ctc)
(λ (blame)
(λ (val)
(raise-blame-error
blame
val
"~s accepts no values, given: ~e"
(none/c-name ctc)
val))))
(define-struct none/c (name)
#:omit-define-syntaxes
#:property prop:flat-contract
(build-flat-contract-property
#:projection none-curried-proj
#:stronger (λ (this that) #t)
#:name (λ (ctc) (none/c-name ctc))
#:first-order (λ (ctc) (λ (val) #f))))
(define/final-prop none/c (make-none/c 'none/c))
(define (flat-contract-predicate x)
(contract-struct-first-order
(coerce-flat-contract 'flat-contract-predicate x)))
(define (flat-contract? x)
(let ([c (coerce-contract/f x)])
(and c
(flat-contract-struct? c))))
(define (chaperone-contract? x)
(let ([c (coerce-contract/f x)])
(and c
(chaperone-contract-struct? c))))
(define (contract-name ctc)
(contract-struct-name
(coerce-contract 'contract-name ctc)))
(define (contract? x) (and (coerce-contract/f x) #t))
(define (contract-projection ctc)
(contract-struct-projection
(coerce-contract 'contract-projection ctc)))
(define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
(define (flat-named-contract name predicate)
(cond
[(and (procedure? predicate)
(procedure-arity-includes? predicate 1))
(make-predicate-contract name predicate)]
[(flat-contract? predicate)
(make-predicate-contract name (flat-contract-predicate predicate))]
[else
(error 'flat-named-contract
"expected a flat contract or procedure of arity 1 as second argument, got ~e"
predicate)]))
(define printable/c
(flat-named-contract
'printable/c
(λ (x)
(let printable? ([x x])
(or (symbol? x)
(string? x)
(bytes? x)
(boolean? x)
(char? x)
(null? x)
(number? x)
(regexp? x)
(prefab-struct-key x) ;; this cannot be last, since it doesn't return just #t
(and (pair? x)
(printable? (car x))
(printable? (cdr x)))
(and (vector? x)
(andmap printable? (vector->list x)))
(and (box? x)
(printable? (unbox x))))))))
(define natural-number/c
(flat-named-contract
'natural-number/c
(λ (x)
(and (number? x)
(integer? x)
(exact? x)
(x . >= . 0)))))

3
collects/racket/contract/private/object.rkt
View File

@ -1,7 +1,8 @@
#lang scheme/base #lang racket/base
(require "arrow.rkt" (require "arrow.rkt"
"guts.rkt" "guts.rkt"
"prop.rkt" "prop.rkt"
"misc.rkt"
racket/private/class-internal racket/private/class-internal
scheme/stxparam) scheme/stxparam)

3
collects/racket/contract/private/opt-guts.rkt
View File

@ -2,7 +2,8 @@
(require syntax/private/boundmap ;; needs to be the private one, since the public one has contracts (require syntax/private/boundmap ;; needs to be the private one, since the public one has contracts
(for-template racket/base) (for-template racket/base)
(for-template "guts.rkt" (for-template "guts.rkt"
"blame.rkt") "blame.rkt"
"misc.rkt")
(for-syntax racket/base)) (for-syntax racket/base))
(provide get-opter reg-opter! opter (provide get-opter reg-opter! opter

1
collects/racket/contract/private/opt.rkt
View File

@ -2,6 +2,7 @@
(require "guts.rkt" (require "guts.rkt"
"prop.rkt" "prop.rkt"
"blame.rkt" "blame.rkt"
"misc.rkt"
racket/stxparam) racket/stxparam)
(require (for-syntax racket/base) (require (for-syntax racket/base)
(for-syntax "opt-guts.rkt") (for-syntax "opt-guts.rkt")

1
collects/racket/contract/private/opters.rkt
View File

@ -4,6 +4,7 @@
"guts.rkt" "guts.rkt"
"arrow.rkt" "arrow.rkt"
"blame.rkt" "blame.rkt"
"misc.rkt"
(for-syntax racket/base (for-syntax racket/base
syntax/stx syntax/stx
"opt-guts.rkt")) "opt-guts.rkt"))

1
collects/racket/contract/private/parametric.rkt
View File

@ -2,6 +2,7 @@
(require "guts.rkt" (require "guts.rkt"
"prop.rkt" "prop.rkt"
"blame.rkt" "blame.rkt"
"misc.rkt"
(for-syntax racket/base)) (for-syntax racket/base))
(provide parametric->/c) (provide parametric->/c)

3
collects/racket/contract/private/provide.rkt
View File

@ -9,8 +9,9 @@
(prefix-in a: "helpers.rkt")) (prefix-in a: "helpers.rkt"))
"arrow.rkt" "arrow.rkt"
"base.rkt" "base.rkt"
racket/contract/exists
"guts.rkt" "guts.rkt"
"misc.rkt"
"exists.rkt"
(for-syntax unstable/dirs) (for-syntax unstable/dirs)
syntax/location syntax/location
syntax/srcloc) syntax/srcloc)

3
collects/racket/contract/private/struct.rkt
View File

@ -6,7 +6,8 @@
racket/list racket/list
"guts.rkt" "guts.rkt"
"blame.rkt" "blame.rkt"
"prop.rkt") "prop.rkt"
"misc.rkt")
(provide struct/c) (provide struct/c)

3
collects/racket/contract/private/vector.rkt
View File

@ -3,7 +3,8 @@
(require (for-syntax racket/base) (require (for-syntax racket/base)
"guts.ss" "guts.ss"
"prop.rkt" "prop.rkt"
"blame.rkt") "blame.rkt"
"misc.rkt")
(provide (rename-out [wrap-vectorof vectorof] (provide (rename-out [wrap-vectorof vectorof]
[wrap-vector/c vector/c]) [wrap-vector/c vector/c])

6
collects/racket/contract/regions.rkt → collects/racket/contract/region.rkt
View File

@ -2,7 +2,8 @@
(provide define-struct/contract (provide define-struct/contract
define/contract define/contract
with-contract) with-contract
current-contract-region)
(require (for-syntax racket/base (require (for-syntax racket/base
racket/list racket/list
@ -17,7 +18,8 @@
syntax/location syntax/location
"private/arrow.rkt" "private/arrow.rkt"
"private/base.rkt" "private/base.rkt"
"private/guts.rkt") "private/guts.rkt"
"private/misc.rkt")
;; These are useful for all below. ;; These are useful for all below.

8
collects/racket/dict.rkt
View File

@ -121,9 +121,7 @@
(or/c #f (-> dict? contract?)) (or/c #f (-> dict? contract?))
(or/c #f (-> dict? contract?)))) (or/c #f (-> dict? contract?))))
(define even-length-list/c (define (even-length-list? l) (even? (length l)))
(flat-named-contract 'even-length-list/c
(lambda (l) (even? (length l)))))
;; ---------------------------------------- ;; ----------------------------------------
@ -163,7 +161,7 @@
(recursive-contract (recursive-contract
(or/c null (or/c null
(cons/c key/c (cons/c val/c args/c))))]) (cons/c key/c (cons/c val/c args/c))))])
(and/c even-length-list/c (and/c even-length-list?
args/c)))] args/c)))]
[_r void?])] [_r void?])]
[dict-set* [dict-set*
@ -174,7 +172,7 @@
(recursive-contract (recursive-contract
(or/c null (or/c null
(cons/c key/c (cons/c val/c args/c))))]) (cons/c key/c (cons/c val/c args/c))))])
(and/c even-length-list/c (and/c even-length-list?
args/c)))] args/c)))]
[_r dict?])] [_r dict?])]
[dict-update! [dict-update!

1
collects/racket/private/class-internal.rkt
View File

@ -3,6 +3,7 @@
(require (for-syntax racket/base) (require (for-syntax racket/base)
mzlib/etc mzlib/etc
racket/contract/base racket/contract/base
racket/contract/combinator
(only-in racket/contract/private/arrow making-a-method) (only-in racket/contract/private/arrow making-a-method)
racket/list racket/list
racket/stxparam racket/stxparam

2
collects/scheme/exists/lang.rkt
View File

@ -1,6 +1,6 @@
#lang scheme #lang scheme
(require racket/contract/exists) (require racket/contract/private/exists)
;; this code builds the list of predicates (in case it changes, this may need to be re-run) ;; this code builds the list of predicates (in case it changes, this may need to be re-run)
#; #;

331
collects/scribblings/reference/contracts.scrbl
View File

@ -17,15 +17,30 @@ another. Programmers specify the behavior of a module's exports via
@racket[provide/contract], and the contract system enforces those @racket[provide/contract], and the contract system enforces those
constraints. constraints.
@note-lib[racket/contract #:use-sources (racket/contract/private/ds @(define-syntax-rule
racket/contract/private/base (add-use-sources (x y ...))
racket/contract/private/guts (x y ...
racket/contract/private/box #:use-sources
racket/contract/private/hash (racket/contract/private/base
racket/contract/private/vector racket/contract/private/misc
racket/contract/private/struct racket/contract/private/provide
racket/contract/private/misc racket/contract/private/guts
racket/contract/private/provide)] racket/contract/private/prop
racket/contract/private/blame
racket/contract/private/ds
racket/contract/private/opt
racket/contract/private/basic-opters
racket/contract/private/box
racket/contract/private/hash
racket/contract/private/vector
racket/contract/private/struct)))
@(define-syntax-rule
(declare-exporting-ctc mod)
(add-use-sources (declare-exporting mod racket/contract racket)))
@(add-use-sources @note-lib[racket/contract])
@deftech{Contracts} come in two forms: those constructed by the @deftech{Contracts} come in two forms: those constructed by the
various operations listed in this section of the manual, and various various operations listed in this section of the manual, and various
@ -55,6 +70,7 @@ failed, and anything else to indicate it passed.}
@; ---------------------------------------- @; ----------------------------------------
@section{Data-structure Contracts} @section{Data-structure Contracts}
@declare-exporting-ctc[racket/contract/base]
A @deftech{flat contract} can be fully checked immediately for A @deftech{flat contract} can be fully checked immediately for
a given value. a given value.
@ -428,60 +444,12 @@ Constructs a contract on a promise. The contract does not force the
promise, but when the promise is forced, the contract checks that the promise, but when the promise is forced, the contract checks that the
result value meets the contract produced by @racket[expr].} result value meets the contract produced by @racket[expr].}
@defproc[(new-∀/c [name symbol?]) contract?]{
Constructs a new universal contract.
Universal contracts accept all values when in negative positions (e.g., function
inputs) and wrap them in an opaque struct, hiding the precise value.
In positive positions (e.g. function returns),
a universal contract accepts only values that were previously accepted in negative positions (by checking
for the wrappers).
The name is used to identify the contract in error messages.
For example, this contract:
@racketblock[(let ([a (new-∃/c 'a)])
(-> a a))]
describes the identity function (or a non-terminating function)
That is, the first use of the @racket[a] appears in a
negative position and thus inputs to that function are wrapped with an opaque struct.
Then, when the function returns, it is checked to determine whether the result is wrapped, since
the second @racket[a] appears in a positive position.
The @racket[new-∀/c] construct constructor is dual to @racket[new-∃/c].
}
@defproc[(new-∃/c [name symbol?]) contract?]{
Constructs a new existential contract.
Existential contracts accept all values when in positive positions (e.g., function
returns) and wrap them in an opaque struct, hiding the precise value.
In negative positions (e.g. function inputs),
they accepts only values that were previously accepted in positive positions (by checking
for the wrappers).
The name is used to identify the contract in error messages.
For example, this contract:
@racketblock[(let ([a (new-∃/c 'a)])
(-> (-> a a)
any/c))]
describes a function that accepts the identity function (or a non-terminating function)
and returns an arbitrary value. That is, the first use of the @racket[a] appears in a
positive position and thus inputs to that function are wrapped with an opaque struct.
Then, when the function returns, it is checked to see if the result is wrapped, since
the second @racket[a] appears in a negative position.
The @racket[new-∃/c] construct constructor is dual to @racket[new-∀/c].
}
@; ------------------------------------------------------------------------ @; ------------------------------------------------------------------------
@section{Function Contracts} @section{Function Contracts}
@declare-exporting-ctc[racket/contract/base]
A @deftech{function contract} wraps a procedure to delay A @deftech{function contract} wraps a procedure to delay
checks for its arguments and results. There are three checks for its arguments and results. There are three
primary function contract combinators that have increasing primary function contract combinators that have increasing
@ -786,7 +754,15 @@ be blamed using the above contract:
} }
@subsection[#:tag "parametric-contracts"]{Parametric Contracts} @section[#:tag "parametric-contracts"]{Parametric Contracts}
@defmodule*/no-declare[(racket/contract/parametric)]
@declare-exporting-ctc[racket/contract/parametric]
The most convenient way to use parametric contract is to use
@racket[provide/contract]'s @racket[#:exists] keyword.
The @racketmodname[racket/contract/parametric] provides a few more,
general-purpose parametric contracts.
@defform[(parametric->/c (x ...) c)]{ @defform[(parametric->/c (x ...) c)]{
@ -815,6 +791,56 @@ if they do not, a contract violation is signaled.
] ]
} }
@defproc[(new-∀/c [name symbol?]) contract?]{
Constructs a new universal contract.
Universal contracts accept all values when in negative positions (e.g., function
inputs) and wrap them in an opaque struct, hiding the precise value.
In positive positions (e.g. function returns),
a universal contract accepts only values that were previously accepted in negative positions (by checking
for the wrappers).
The name is used to identify the contract in error messages.
For example, this contract:
@racketblock[(let ([a (new-∀/c 'a)])
(-> a a))]
describes the identity function (or a non-terminating function)
That is, the first use of the @racket[a] appears in a
negative position and thus inputs to that function are wrapped with an opaque struct.
Then, when the function returns, it is checked to determine whether the result is wrapped, since
the second @racket[a] appears in a positive position.
The @racket[new-∀/c] construct constructor is dual to @racket[new-∃/c].
}
@defproc[(new-∃/c [name symbol?]) contract?]{
Constructs a new existential contract.
Existential contracts accept all values when in positive positions (e.g., function
returns) and wrap them in an opaque struct, hiding the precise value.
In negative positions (e.g. function inputs),
they accepts only values that were previously accepted in positive positions (by checking
for the wrappers).
The name is used to identify the contract in error messages.
For example, this contract:
@racketblock[(let ([a (new-∃/c 'a)])
(-> (-> a a)
any/c))]
describes a function that accepts the identity function (or a non-terminating function)
and returns an arbitrary value. That is, the first use of the @racket[a] appears in a
positive position and thus inputs to that function are wrapped with an opaque struct.
Then, when the function returns, it is checked to see if the result is wrapped, since
the second @racket[a] appears in a negative position.
The @racket[new-∃/c] construct constructor is dual to @racket[new-∀/c].
}
@; ------------------------------------------------------------------------ @; ------------------------------------------------------------------------
@ -909,6 +935,7 @@ lazy contract.
@; ------------------------------------------------------------------------ @; ------------------------------------------------------------------------
@section{Attaching Contracts to Values} @section{Attaching Contracts to Values}
@declare-exporting-ctc[racket/contract/base]
@defform/subs[ @defform/subs[
#:literals (struct rename) #:literals (struct rename)
@ -969,6 +996,10 @@ is bound to vectors of two elements, the exported identifier and a
syntax object for the expression that produces the contract controlling syntax object for the expression that produces the contract controlling
the export. the export.
} }
@subsection{Nested Contract Boundaries}
@defmodule*/no-declare[(racket/contract/region)]
@declare-exporting-ctc[racket/contract/region]
@defform*/subs[ @defform*/subs[
[(with-contract blame-id (wc-export ...) free-var-list ... body ...+) [(with-contract blame-id (wc-export ...) free-var-list ... body ...+)
@ -1050,6 +1081,9 @@ The @racket[define-struct/contract] form only allows a subset of the
(make-salmon #f 'pacific) (make-salmon #f 'pacific)
]} ]}
@subsection{Low-level Contract Boundaries}
@declare-exporting-ctc[racket/contract/base]
@defform*[[(contract contract-expr to-protect-expr @defform*[[(contract contract-expr to-protect-expr
positive-blame-expr negative-blame-expr) positive-blame-expr negative-blame-expr)
(contract contract-expr to-protect-expr (contract contract-expr to-protect-expr
@ -1088,8 +1122,8 @@ accepted by the third argument to @racket[datum->syntax].
@section{Building New Contract Combinators} @section{Building New Contract Combinators}
@emph{@bold{Note:} @defmodule*/no-declare[(racket/contract/combinator)]
The interface in this section is unstable and subject to change.} @declare-exporting-ctc[racket/contract/combinator]
Contracts are represented internally as functions that Contracts are represented internally as functions that
accept information about the contract (who is to blame, accept information about the contract (who is to blame,
@ -1460,6 +1494,44 @@ specific to the precise violation.
field extracts the @racket[blame?] object associated with a contract violation. field extracts the @racket[blame?] object associated with a contract violation.
} }
@defparam[current-blame-format
proc
(-> blame? any/c string? string?)]{
A parameter that is used when constructing a
contract violation error. Its value is procedure that
accepts three arguments:
@itemize[
@item{the blame object for the violation,}
@item{the value that the contract applies to, and}
@item{a message indicating the kind of violation.}]
The procedure then
returns a string that is put into the contract error
message. Note that the value is often already included in
the message that indicates the violation.
@defexamples[#:eval (contract-eval)
(define (show-blame-error blame value message)
(string-append
"Contract Violation!\n"
(format "Guilty Party: ~a\n" (blame-positive blame))
(format "Innocent Party: ~a\n" (blame-negative blame))
(format "Contracted Value Name: ~a\n" (blame-value blame))
(format "Contract Location: ~s\n" (blame-source blame))
(format "Contract Name: ~a\n" (blame-contract blame))
(format "Offending Value: ~s\n" value)
(format "Offense: ~a\n" message)))
(current-blame-format show-blame-error)
(define/contract (f x)
(-> integer? integer?)
(/ x 2))
(f 2)
(f 1)
(f 1/2)
]
}
@subsection{Contracts as structs} @subsection{Contracts as structs}
@para{ @para{
@ -1727,46 +1799,8 @@ are below):
@; ------------------------------------------------------------------------ @; ------------------------------------------------------------------------
@section{Contract Utilities} @subsection{Utilities for Building New Combinators}
@defproc[(contract? [v any/c]) boolean?]{
Returns @racket[#t] if its argument is a contract (i.e., constructed
with one of the combinators described in this section or a value that
can be used as a contract) and @racket[#f] otherwise.}
@defproc[(chaperone-contract? [v any/c]) boolean?]{
Returns @racket[#t] if its argument is a contract that guarantees that
it returns a value which passes @racket[chaperone-of?] when compared to
the original, uncontracted value.}
@defproc[(flat-contract? [v any/c]) boolean?]{
Returns @racket[#t] when its argument is a contract that can be
checked immediately (unlike, say, a function contract).
For example,
@racket[flat-contract] constructs flat contracts from predicates, and
symbols, booleans, numbers, and other ordinary Racket values
(that are defined as @tech{contracts}) are also
flat contracts.}
@defproc[(flat-contract-predicate [v flat-contract?])
(any/c . -> . any/c)]{
Extracts the predicate from a flat contract.}
@defproc[(value-contract [v has-contract?]) contract?]{
Returns the contract attached to @racket[v], if recorded.
Otherwise it returns @racket[#f].
}
@defproc[(has-contract? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] is a value that
has a recorded contract attached to it.
}
@defproc[(contract-stronger? [x contract?] [y contract?]) boolean?]{ @defproc[(contract-stronger? [x contract?] [y contract?]) boolean?]{
Returns @racket[#t] if the contract @racket[x] accepts either fewer Returns @racket[#t] if the contract @racket[x] accepts either fewer
or the same number of values as @racket[y] does. or the same number of values as @racket[y] does.
@ -1799,14 +1833,57 @@ may or may not hold. If the contract is a first-order
contract, a result of @racket[#t] guarantees that the contract, a result of @racket[#t] guarantees that the
contract holds.} contract holds.}
@defproc[(contract-name [c contract?]) any/c]{
Produces the name used to describe the contract in error messages.
}
@defproc[(contract-first-order [c contract?]) (-> any/c boolean?)]{ @defproc[(contract-first-order [c contract?]) (-> any/c boolean?)]{
Produces the first-order test used by @racket[or/c] to match values to Produces the first-order test used by @racket[or/c] to match values to
higher-order contracts. higher-order contracts.
} }
@section{Contract Utilities}
@declare-exporting-ctc[racket/contract/base]
@defproc[(contract? [v any/c]) boolean?]{
Returns @racket[#t] if its argument is a contract (i.e., constructed
with one of the combinators described in this section or a value that
can be used as a contract) and @racket[#f] otherwise.}
@defproc[(chaperone-contract? [v any/c]) boolean?]{
Returns @racket[#t] if its argument is a contract that guarantees that
it returns a value which passes @racket[chaperone-of?] when compared to
the original, uncontracted value.}
@defproc[(flat-contract? [v any/c]) boolean?]{
Returns @racket[#t] when its argument is a contract that can be
checked immediately (unlike, say, a function contract).
For example,
@racket[flat-contract] constructs flat contracts from predicates, and
symbols, booleans, numbers, and other ordinary Racket values
(that are defined as @tech{contracts}) are also
flat contracts.}
@defproc[(flat-contract-predicate [v flat-contract?])
(any/c . -> . any/c)]{
Extracts the predicate from a flat contract.}
@defproc[(contract-name [c contract?]) any/c]{
Produces the name used to describe the contract in error messages.
}
@defproc[(value-contract [v has-contract?]) contract?]{
Returns the contract attached to @racket[v], if recorded.
Otherwise it returns @racket[#f].
}
@defproc[(has-contract? [v any/c]) boolean?]{
Returns @racket[#t] if @racket[v] is a value that
has a recorded contract attached to it.
}
@defproc[(contract-projection [c contract?]) (-> blame? (-> any/c any/c))]{ @defproc[(contract-projection [c contract?]) (-> blame? (-> any/c any/c))]{
Produces the projection defining a contract's behavior on protected values. Produces the projection defining a contract's behavior on protected values.
@ -1817,46 +1894,6 @@ Produces the projection defining a contract's behavior on protected values.
Makes a contract that accepts no values, and reports the Makes a contract that accepts no values, and reports the
name @racket[sexp-name] when signaling a contract violation.} name @racket[sexp-name] when signaling a contract violation.}
@defparam[current-blame-format
proc
(-> blame? any/c string? string?)]{
A parameter that is used when constructing a
contract violation error. Its value is procedure that
accepts three arguments:
@itemize[
@item{the blame object for the violation,}
@item{the value that the contract applies to, and}
@item{a message indicating the kind of violation.}]
The procedure then
returns a string that is put into the contract error
message. Note that the value is often already included in
the message that indicates the violation.
@defexamples[#:eval (contract-eval)
(define (show-blame-error blame value message)
(string-append
"Contract Violation!\n"
(format "Guilty Party: ~a\n" (blame-positive blame))
(format "Innocent Party: ~a\n" (blame-negative blame))
(format "Contracted Value Name: ~a\n" (blame-value blame))
(format "Contract Location: ~s\n" (blame-source blame))
(format "Contract Name: ~a\n" (blame-contract blame))
(format "Offending Value: ~s\n" value)
(format "Offense: ~a\n" message)))
(current-blame-format show-blame-error)
(define/contract (f x)
(-> integer? integer?)
(/ x 2))
(f 2)
(f 1)
(f 1/2)
]
}
@defform*[[(recursive-contract contract-expr) @defform*[[(recursive-contract contract-expr)
(recursive-contract contract-expr type)]]{ (recursive-contract contract-expr type)]]{
@ -1963,4 +2000,4 @@ makes a binary search tree contract, but one that is
struct and returns a projection function that checks the contract. struct and returns a projection function that checks the contract.
} }

1
collects/syntax/parse/experimental/provide.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base #lang racket/base
(require racket/contract/base (require racket/contract/base
racket/contract/combinator
syntax/location syntax/location
(for-syntax racket/base (for-syntax racket/base
racket/syntax racket/syntax

1
collects/syntax/parse/experimental/reflect.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base #lang racket/base
(require racket/contract/base (require racket/contract/base
racket/contract/combinator
"../private/minimatch.rkt" "../private/minimatch.rkt"
"../private/keywords.rkt" "../private/keywords.rkt"
"../private/runtime-reflect.rkt" "../private/runtime-reflect.rkt"

8
collects/syntax/parse/private/rep-data.rkt
View File

@ -195,12 +195,10 @@ Arguments is defined in rep-patterns.rkt
;; Contracts ;; Contracts
(define DeclEnv/c (define DeclEnv/c declenv?)
(flat-named-contract 'DeclEnv declenv?))
(define DeclEntry/c (define DeclEntry/c
(flat-named-contract 'DeclEntry (or/c den:lit? den:class? den:parser? den:delayed?))
(or/c den:lit? den:class? den:parser? den:delayed?)))
(define SideClause/c (define SideClause/c
(or/c clause:fail? clause:with? clause:attr? clause:do?)) (or/c clause:fail? clause:with? clause:attr? clause:do?))

2
collects/typed-scheme/private/with-types.rkt
View File

@ -4,7 +4,7 @@
(for-template (for-template
(except-in racket/base for for*) (except-in racket/base for for*)
"prims.rkt" "prims.rkt"
(prefix-in c: (combine-in racket/contract/regions racket/contract/base))) (prefix-in c: (combine-in racket/contract/region racket/contract/base)))
"extra-procs.rkt" "prims.rkt" "extra-procs.rkt" "prims.rkt"
syntax/parse racket/block racket/match syntax/parse racket/block racket/match
unstable/sequence "base-types-extra.rkt" unstable/sequence "base-types-extra.rkt"

3
collects/unstable/prop-contract.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base #lang racket/base
(require racket/contract/base) (require racket/contract/base
racket/contract/combinator)
(define (get-stpc-proj stpc) (define (get-stpc-proj stpc)
(let ([get-val-proj (let ([get-val-proj

1
collects/web-server/stuffers/stuffer.rkt
View File

@ -1,5 +1,4 @@
#lang racket #lang racket
(define-struct stuffer (in out)) (define-struct stuffer (in out))
(define (stuffer/c dom rng) (define (stuffer/c dom rng)
(define in (dom . -> . rng)) (define in (dom . -> . rng))

3
collects/xml/private/structures.rkt
View File

@ -1,4 +1,5 @@
#lang racket #lang racket/base
(require racket/contract)
; Location = (make-location Nat Nat Nat) | Symbol ; Location = (make-location Nat Nat Nat) | Symbol
(define-struct location (line char offset) #:transparent) (define-struct location (line char offset) #:transparent)