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

Merged from branch: ^/branches/cce/plt+contract-props+r17680

Browse Source 
Added new implementation of contract structure properties.  Contracts are now
based on prop:contract, and flat contracts are based on prop:flat-contract.  The
flat contract property inherits prop:contract (flat contracts are contracts) and
prop:procedure (flat contracts are predicates).

A value is now a contract if it has prop:contract, or if it is a flat contract.
A value is now a flat contract if it has prop:flat-contract, or if it is a
procedure of one argument (assumed to be a predicate), or if it is one of the
constants allowed as a flat contract (e.g. booleans, numbers, strings, symbols,
regular expressions).

The old custom contract systems (proj-prop and friends, make-proj-contract and
friends) have been supplanted by the new properties, constructors for the
properties' associated values, and "simple-contract" and "simple-flat-contract"
constructors for one-off contracts.  These forms are all documented in the
reference.  Documentation of the legacy bindings has been removed, though as
many of them as possible are still exported to give legacy code time to migrate.

This commit includes all the changes to the contract system, plus replacement of
all uses of the legacy bindings (proj-prop, proj-get, make-proj-contract,
several others) in other collections.

svn: r18009
This commit is contained in:
Carl Eastlund 2010-02-06 20:40:03 +00:00
commit 5069f3b37e
47 changed files with 2368 additions and 2261 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/drscheme/private/debug.ss
View File

@ -335,8 +335,10 @@ profile todo:
;; =User=
(define (print-planet-icon-to-stderr exn)
(when (exn:fail:contract2? exn)
(let ([table (parse-gp exn (guilty-party exn))])
(when (exn:fail:contract:blame? exn)
(let ([table (parse-gp exn
(blame-positive
(exn:fail:contract:blame-object exn)))])
(when table
(let ([gp-url (bug-info->ticket-url table)])
(when planet-note%

1
collects/drscheme/private/tools.ss
View File

@ -326,6 +326,7 @@
name
'drscheme
tool-name
(quote name)
(quote-syntax name))]))
name
ctc)

47
collects/mzlib/contract.ss
View File

@ -48,48 +48,11 @@
check-between/c
string-len/c
check-unary-between/c)
(rename-out [string-len/c string/len]))
;; from contract-guts.ss
(provide any
and/c
any/c
none/c
make-none/c
guilty-party
contract-violation->string
contract?
contract-name
contract-proc
flat-contract?
flat-contract
flat-contract-predicate
flat-named-contract
contract-first-order-passes?
;; below need docs
make-proj-contract
contract-stronger?
coerce-contract
flat-contract/predicate?
build-compound-type-name
raise-contract-error
proj-prop proj-pred? proj-get
name-prop name-pred? name-get
stronger-prop stronger-pred? stronger-get
flat-prop flat-pred? flat-get
first-order-prop first-order-get
(rename-out [or/c union]))
(rename-out [or/c union])
(rename-out [string-len/c string/len])
(except-out (all-from-out scheme/contract/private/guts)
check-flat-contract
check-flat-named-contract))
;; copied here because not provided by scheme/contract anymore

82
collects/mzlib/private/contract-arr-checks.ss
View File

@ -77,31 +77,21 @@
f)))
(define (check-pre-expr->pp/h val pre-expr src-info blame orig-str)
(define (check-pre-expr->pp/h val pre-expr blame)
(unless pre-expr
(raise-contract-error val
src-info
blame
orig-str
"pre-condition expression failure")))
(raise-blame-error blame val "pre-condition expression failure")))
(define (check-post-expr->pp/h val post-expr src-info blame orig-str)
(define (check-post-expr->pp/h val post-expr blame)
(unless post-expr
(raise-contract-error val
src-info
blame
orig-str
"post-condition expression failure")))
(raise-blame-error blame val "post-condition expression failure")))
(define (check-procedure val dom-length optionals mandatory-kwds optional-keywords src-info blame orig-str)
(define (check-procedure val dom-length optionals mandatory-kwds optional-keywords blame)
(unless (and (procedure? val)
(procedure-arity-includes?/optionals val dom-length optionals)
(keywords-match mandatory-kwds optional-keywords val))
(raise-contract-error
val
src-info
(raise-blame-error
blame
orig-str
val
"expected a procedure that accepts ~a arguments~a, given: ~e"
dom-length
(keyword-error-text mandatory-kwds)
@ -140,53 +130,37 @@
(and (procedure? val)
(procedure-accepts-and-more? val arity)))
(define (check-procedure/kind val arity kind-of-thing src-info blame orig-str)
(define (check-procedure/kind val arity kind-of-thing blame)
(unless (procedure? val)
(raise-contract-error val
src-info
blame
orig-str
"expected a procedure, got ~e"
val))
(raise-blame-error blame val "expected a procedure, got ~e" val))
(unless (procedure-arity-includes? val arity)
(raise-contract-error val
src-info
blame
orig-str
"expected a ~a of arity ~a (not arity ~a), got ~e"
kind-of-thing
arity
(procedure-arity val)
val)))
(raise-blame-error blame
val
"expected a ~a of arity ~a (not arity ~a), got ~e"
kind-of-thing
arity
(procedure-arity val)
val)))
(define (check-procedure/more/kind val arity kind-of-thing src-info blame orig-str)
(define (check-procedure/more/kind val arity kind-of-thing blame)
(unless (procedure? val)
(raise-contract-error val
src-info
blame
orig-str
"expected a procedure, got ~e"
val))
(raise-blame-error blame val "expected a procedure, got ~e" val))
(unless (procedure-accepts-and-more? val arity)
(raise-contract-error val
src-info
blame
orig-str
"expected a ~a that accepts ~a arguments and aribtrarily more (not arity ~a), got ~e"
kind-of-thing
arity
(procedure-arity val)
val)))
(raise-blame-error blame
val
"expected a ~a that accepts ~a arguments and aribtrarily more (not arity ~a), got ~e"
kind-of-thing
arity
(procedure-arity val)
val)))
(define (check-procedure/more val dom-length mandatory-kwds optional-kwds src-info blame orig-str)
(define (check-procedure/more val dom-length mandatory-kwds optional-kwds blame)
(unless (and (procedure? val)
(procedure-accepts-and-more? val dom-length)
(keywords-match mandatory-kwds optional-kwds val))
(raise-contract-error
val
src-info
(raise-blame-error
blame
orig-str
val
"expected a procedure that accepts ~a arguments and and arbitrarily more~a, given: ~e"
dom-length
(keyword-error-text mandatory-kwds)

293
collects/mzlib/private/contract-arr-obj-helpers.ss
View File

@ -19,9 +19,9 @@
(define (make-/proc method-proc? /h stx)
(let-values ([(arguments-check build-proj check-val first-order-check wrapper)
(/h method-proc? stx)])
(let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id positive-position?))])
(let ([outer-args (syntax (val blame name-id))])
(with-syntax ([inner-check (check-val outer-args)]
[(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
[(val blame name-id) outer-args]
[(val-args body) (wrapper outer-args)])
(with-syntax ([inner-lambda
(set-inferred-name-from
@ -37,11 +37,10 @@
(arguments-check
outer-args
(syntax/loc stx
(make-proj-contract
name-id
(lambda (pos-blame neg-blame src-info orig-str positive-position?)
proj-code)
first-order-check))))))))))
(simple-contract
#:name name-id
#:projection (lambda (blame) proj-code)
#:first-order first-order-check))))))))))
(define (make-case->/proc method-proc? stx inferred-name-stx select/h)
(syntax-case stx ()
@ -55,9 +54,9 @@
[(_ cases ...)
(let-values ([(arguments-check build-projs check-val first-order-check wrapper)
(case->/h method-proc? stx (syntax->list (syntax (cases ...))) select/h)])
(let ([outer-args (syntax (val pos-blame neg-blame src-info orig-str name-id positive-position?))])
(let ([outer-args (syntax (val blame name-id))])
(with-syntax ([(inner-check ...) (check-val outer-args)]
[(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
[(val blame name-id) outer-args]
[(body ...) (wrapper outer-args)])
(with-syntax ([inner-lambda
(set-inferred-name-from
@ -73,11 +72,10 @@
(arguments-check
outer-args
(syntax/loc stx
(make-proj-contract
(apply build-compound-type-name 'case-> name-id)
(lambda (pos-blame neg-blame src-info orig-str positive-position?)
proj-code)
first-order-check)))))))))]))
(simple-contract
#:name (apply build-compound-type-name 'case-> name-id)
#:projection (lambda (blame) proj-code)
#:first-order first-order-check)))))))))]))
(define (make-opt->/proc method-proc? stx select/h case-arr-stx arr-stx)
(syntax-case stx (any)
@ -230,7 +228,7 @@
[(null? cases)
(values
(lambda (outer-args body)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
(with-syntax ([(val blame name-id) outer-args]
[body body]
[(name-ids ...) (reverse name-ids)])
(syntax
@ -249,10 +247,10 @@
(/h method-proc? (car cases))])
(values
(lambda (outer-args x)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
(with-syntax ([(val blame name-id) outer-args]
[new-id new-id])
(arguments-check
(syntax (val pos-blame neg-blame src-info orig-str new-id positive-position?))
(syntax (val blame new-id))
(arguments-checks
outer-args
x))))
@ -364,28 +362,28 @@
(values
(lambda (outer-args body)
(with-syntax ([body body]
[(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
[(val blame name-id) outer-args])
(syntax
(let ([dom-contract-x (coerce-contract '-> dom)] ...)
(let ([dom-x (contract-proc dom-contract-x)] ...)
(let ([dom-x (contract-projection dom-contract-x)] ...)
(let ([name-id (build-compound-type-name '-> name-dom-contract-x ... 'any)])
body))))))
;; proj
(lambda (outer-args inner-lambda)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
(with-syntax ([(val blame name-id) outer-args]
[inner-lambda inner-lambda])
(syntax
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))] ...)
(let ([dom-projection-x (dom-x (blame-swap blame))] ...)
inner-lambda))))
(lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
(with-syntax ([(val blame name-id) outer-args])
(syntax
(check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str))))
(check-procedure val dom-length 0 '() '() #|keywords|# blame))))
(syntax (check-procedure? dom-length))
(lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
(with-syntax ([(val blame name-id) outer-args])
(syntax
((arg-x ...)
(val (dom-projection-x arg-x) ...))))))]
@ -399,14 +397,14 @@
(values
(lambda (outer-args body)
(with-syntax ([body body]
[(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
[(val blame name-id) outer-args])
(syntax
(let ([dom-contract-x (coerce-contract '-> dom)]
...
[rng-contract-x (coerce-contract '-> rng)] ...)
(let ([dom-x (contract-proc dom-contract-x)]
(let ([dom-x (contract-projection dom-contract-x)]
...
[rng-x (contract-proc rng-contract-x)]
[rng-x (contract-projection rng-contract-x)]
...)
(let ([name-id
(build-compound-type-name
@ -417,22 +415,22 @@
;; proj
(lambda (outer-args inner-lambda)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
(with-syntax ([(val blame name-id) outer-args]
[inner-lambda inner-lambda])
(syntax
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))]
(let ([dom-projection-x (dom-x (blame-swap blame))]
...
[rng-projection-x (rng-x pos-blame neg-blame src-info orig-str positive-position?)] ...)
[rng-projection-x (rng-x blame)] ...)
inner-lambda))))
(lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
(with-syntax ([(val blame name-id) outer-args])
(syntax
(check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str))))
(check-procedure val dom-length 0 '() '() #|keywords|# blame))))
(syntax (check-procedure? dom-length))
(lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
(with-syntax ([(val blame name-id) outer-args])
(syntax
((arg-x ...)
(let-values ([(res-x ...) (val (dom-projection-x arg-x) ...)])
@ -448,34 +446,34 @@
(values
(lambda (outer-args body)
(with-syntax ([body body]
[(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
[(val blame name-id) outer-args])
(syntax
(let ([dom-contract-x (coerce-contract '-> dom)]
...
[rng-contract-x (coerce-contract '-> rng)])
(let ([dom-x (contract-proc dom-contract-x)]
(let ([dom-x (contract-projection dom-contract-x)]
...
[rng-x (contract-proc rng-contract-x)])
[rng-x (contract-projection rng-contract-x)])
(let ([name-id (build-compound-type-name '-> name-dom-contract-x ... rng-contract-x)])
body))))))
;; proj
(lambda (outer-args inner-lambda)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
(with-syntax ([(val blame name-id) outer-args]
[inner-lambda inner-lambda])
(syntax
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))]
(let ([dom-projection-x (dom-x (blame-swap blame))]
...
[rng-projection-x (rng-x pos-blame neg-blame src-info orig-str positive-position?)])
[rng-projection-x (rng-x blame)])
inner-lambda))))
(lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
(with-syntax ([(val blame name-id) outer-args])
(syntax
(check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str))))
(check-procedure val dom-length 0 '() '() #|keywords|# blame))))
(syntax (check-procedure? dom-length))
(lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
(with-syntax ([(val blame name-id) outer-args])
(syntax
((arg-x ...)
(let ([res-x (val (dom-projection-x arg-x) ...)])
@ -509,7 +507,7 @@
[arity (length (syntax->list (syntax (dom ...))))])
(values
(lambda (outer-args body)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
(with-syntax ([(val blame name-id) outer-args]
[body body]
[(name-dom-contract-x ...)
(if method-proc?
@ -522,10 +520,10 @@
...
[dom-rest-contract-x (coerce-contract '->* rest)]
[rng-contract-x (coerce-contract '->* rng)] ...)
(let ([dom-x (contract-proc dom-contract-x)]
(let ([dom-x (contract-projection dom-contract-x)]
...
[dom-rest-x (contract-proc dom-rest-contract-x)]
[rng-x (contract-proc rng-contract-x)]
[dom-rest-x (contract-projection dom-rest-contract-x)]
[rng-x (contract-projection rng-contract-x)]
...)
(let ([name-id
(build-compound-type-name
@ -536,22 +534,22 @@
body))))))
;; proj
(lambda (outer-args inner-lambda)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
(with-syntax ([(val blame name-id) outer-args]
[inner-lambda inner-lambda])
(syntax
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))]
(let ([dom-projection-x (dom-x (blame-swap blame))]
...
[dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info orig-str (not positive-position?))]
[rng-projection-x (rng-x pos-blame neg-blame src-info orig-str positive-position?)] ...)
[dom-rest-projection-x (dom-rest-x (blame-swap blame))]
[rng-projection-x (rng-x blame)] ...)
inner-lambda))))
(lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
(with-syntax ([(val blame name-id) outer-args])
(syntax
(check-procedure/more val dom-length '() '() #|keywords|# src-info pos-blame orig-str))))
(check-procedure/more val dom-length '() '() #|keywords|# blame))))
(syntax (check-procedure/more? dom-length))
(lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
(with-syntax ([(val blame name-id) outer-args])
(syntax
((arg-x ... . arg-rest-x)
(let-values ([(res-x ...)
@ -577,7 +575,7 @@
(values
(lambda (outer-args body)
(with-syntax ([body body]
[(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
[(val blame name-id) outer-args]
[(name-dom-contract-x ...)
(if method-proc?
(cdr
@ -588,9 +586,9 @@
(let ([dom-contract-x (coerce-contract '->* dom)]
...
[dom-rest-contract-x (coerce-contract '->* rest)])
(let ([dom-x (contract-proc dom-contract-x)]
(let ([dom-x (contract-projection dom-contract-x)]
...
[dom-rest-x (contract-proc dom-rest-contract-x)])
[dom-rest-x (contract-projection dom-rest-contract-x)])
(let ([name-id (build-compound-type-name
'->*
(build-compound-type-name name-dom-contract-x ...)
@ -599,21 +597,21 @@
body))))))
;; proj
(lambda (outer-args inner-lambda)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
(with-syntax ([(val blame name-id) outer-args]
[inner-lambda inner-lambda])
(syntax
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))]
(let ([dom-projection-x (dom-x (blame-swap blame))]
...
[dom-projection-rest-x (dom-rest-x neg-blame pos-blame src-info orig-str (not positive-position?))])
[dom-projection-rest-x (dom-rest-x (blame-swap blame))])
inner-lambda))))
(lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
(with-syntax ([(val blame name-id) outer-args])
(syntax
(check-procedure/more val dom-length '() '() #|keywords|# src-info pos-blame orig-str))))
(check-procedure/more val dom-length '() '() #|keywords|# blame))))
(syntax (check-procedure/more? dom-length))
(lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
(with-syntax ([(val blame name-id) outer-args])
(syntax
((arg-x ... . arg-rest-x)
(apply
@ -636,7 +634,7 @@
(values
(lambda (outer-args body)
(with-syntax ([body body]
[(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
[(val blame name-id) outer-args]
[(name-dom-contract-x ...)
(if method-proc?
(cdr
@ -645,7 +643,7 @@
(syntax (dom-contract-x ...)))])
(syntax
(let ([dom-contract-x (coerce-contract '->d dom)] ...)
(let ([dom-x (contract-proc dom-contract-x)]
(let ([dom-x (contract-projection dom-contract-x)]
...
[rng-x rng])
(check-rng-procedure '->d rng-x arity)
@ -654,31 +652,27 @@
;; proj
(lambda (outer-args inner-lambda)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
(with-syntax ([(val blame name-id) outer-args]
[inner-lambda inner-lambda])
(syntax
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))] ...)
(let ([dom-projection-x (dom-x (blame-swap blame))] ...)
inner-lambda))))
(lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
(with-syntax ([(val blame name-id) outer-args])
(syntax
(check-procedure val arity 0 '() '() #|keywords|# src-info pos-blame orig-str))))
(check-procedure val arity 0 '() '() #|keywords|# blame))))
(syntax (check-procedure? arity))
(lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
(with-syntax ([(val blame name-id) outer-args])
(syntax
((arg-x ...)
(let ([arg-x (dom-projection-x arg-x)] ...)
(let ([rng-contract (rng-x arg-x ...)])
(((contract-proc (coerce-contract '->d rng-contract))
pos-blame
neg-blame
src-info
orig-str
positive-position?)
(((contract-projection (coerce-contract '->d rng-contract))
blame)
(val arg-x ...))))))))))]))
;; ->d*/h : boolean stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
@ -694,7 +688,7 @@
(values
(lambda (outer-args body)
(with-syntax ([body body]
[(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
[(val blame name-id) outer-args]
[(name-dom-contract-x ...)
(if method-proc?
(cdr
@ -703,7 +697,7 @@
(syntax (dom-contract-x ...)))])
(syntax
(let ([dom-contract-x (coerce-contract '->d* dom)] ...)
(let ([dom-x (contract-proc dom-contract-x)]
(let ([dom-x (contract-projection dom-contract-x)]
...
[rng-mk-x rng-mk])
(check-rng-procedure '->d* rng-mk-x dom-length)
@ -715,20 +709,20 @@
;; proj
(lambda (outer-args inner-lambda)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
(with-syntax ([(val blame name-id) outer-args]
[inner-lambda inner-lambda])
(syntax
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))] ...)
(let ([dom-projection-x (dom-x (blame-swap blame))] ...)
inner-lambda))))
(lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
(with-syntax ([(val blame name-id) outer-args])
(syntax
(check-procedure val dom-length 0 '() '() #|keywords|# src-info pos-blame orig-str))))
(check-procedure val dom-length 0 '() '() #|keywords|# blame))))
(syntax (check-procedure? dom-length))
(lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
(with-syntax ([(val blame name-id) outer-args])
(syntax
((arg-x ...)
(call-with-values
@ -742,12 +736,8 @@
(apply
values
(map (lambda (rng-contract result)
(((contract-proc (coerce-contract '->d* rng-contract))
pos-blame
neg-blame
src-info
orig-str
positive-position?)
(((contract-projection (coerce-contract '->d* rng-contract))
blame)
result))
rng-contracts
results))))))))))))]
@ -763,7 +753,7 @@
(values
(lambda (outer-args body)
(with-syntax ([body body]
[(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
[(val blame name-id) outer-args]
[(name-dom-contract-x ...)
(if method-proc?
(cdr
@ -774,9 +764,9 @@
(let ([dom-contract-x (coerce-contract '->d* dom)]
...
[dom-rest-contract-x (coerce-contract '->d* rest)])
(let ([dom-x (contract-proc dom-contract-x)]
(let ([dom-x (contract-projection dom-contract-x)]
...
[dom-rest-x (contract-proc dom-rest-contract-x)]
[dom-rest-x (contract-projection dom-rest-contract-x)]
[rng-mk-x rng-mk])
(check-rng-procedure/more rng-mk-x arity)
(let ([name-id (build-compound-type-name
@ -788,22 +778,22 @@
;; proj
(lambda (outer-args inner-lambda)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
(with-syntax ([(val blame name-id) outer-args]
[inner-lambda inner-lambda])
(syntax
(let ([dom-projection-x (dom-x neg-blame pos-blame src-info orig-str (not positive-position?))]
(let ([dom-projection-x (dom-x (blame-swap blame))]
...
[dom-rest-projection-x (dom-rest-x neg-blame pos-blame src-info orig-str (not positive-position?))])
[dom-rest-projection-x (dom-rest-x (blame-swap blame))])
inner-lambda))))
(lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
(with-syntax ([(val blame name-id) outer-args])
(syntax
(check-procedure/more val arity '() '() #|keywords|# src-info pos-blame orig-str))))
(check-procedure/more val arity '() '() #|keywords|# blame))))
(syntax (check-procedure/more? arity))
(lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
(with-syntax ([(val blame name-id) outer-args])
(syntax
((arg-x ... . rest-arg-x)
(call-with-values
@ -822,12 +812,8 @@
(apply
values
(map (lambda (rng-contract result)
(((contract-proc (coerce-contract '->d* rng-contract))
pos-blame
neg-blame
src-info
orig-str
positive-position?)
(((contract-projection (coerce-contract '->d* rng-contract))
blame)
result))
rng-contracts
results))))))))))))]))
@ -880,32 +866,31 @@
(values
(lambda (outer-args body)
(with-syntax ([body body]
[(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
[(val blame name-id) outer-args])
(syntax
(let ([name-id name-stx])
body))))
(lambda (outer-args inner-lambda) inner-lambda)
(lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
(with-syntax ([(val blame name-id) outer-args]
[kind-of-thing (if method-proc? 'method 'procedure)])
(syntax
(begin
(check-procedure/kind val arity 'kind-of-thing src-info pos-blame orig-str)))))
(check-procedure/kind val arity 'kind-of-thing blame)))))
(syntax (check-procedure? arity))
(lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
(with-syntax ([(val blame name-id) outer-args])
(syntax-case* (syntax result-stuff) (any values) module-or-top-identifier=?
[(any)
(syntax
((x ...)
(begin
(check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str)
(let ([dom-id ((contract-proc (coerce-contract 'stx-name dom))
neg-blame pos-blame src-info orig-str
(not positive-position?))]
(check-pre-expr->pp/h val pre-expr (blame-swap blame))
(let ([dom-id ((contract-projection (coerce-contract 'stx-name dom))
(blame-swap blame))]
...)
(val (dom-id x) ...)))))]
[((values (rng-ids rng-ctc) ...) post-expr)
@ -915,16 +900,14 @@
(syntax
((x ...)
(begin
(check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str)
(let ([dom-id ((contract-proc (coerce-contract 'stx-name dom))
neg-blame pos-blame src-info orig-str
(not positive-position?))]
(check-pre-expr->pp/h val pre-expr (blame-swap blame))
(let ([dom-id ((contract-projection (coerce-contract 'stx-name dom))
(blame-swap blame))]
...)
(let-values ([(rng-ids ...) (val (dom-id x) ...)])
(check-post-expr->pp/h val post-expr src-info pos-blame orig-str)
(let ([rng-ids-x ((contract-proc (coerce-contract 'stx-name rng-ctc))
pos-blame neg-blame src-info orig-str
positive-position?)] ...)
(check-post-expr->pp/h val post-expr blame)
(let ([rng-ids-x ((contract-projection (coerce-contract 'stx-name rng-ctc))
blame)] ...)
(values (rng-ids-x rng-ids) ...))))))))]
[((values (rng-ids rng-ctc) ...) post-expr)
(andmap identifier? (syntax->list (syntax (rng-ids ...))))
@ -941,16 +924,14 @@
(syntax
((x ...)
(begin
(check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str)
(let ([dom-id ((contract-proc (coerce-contract 'stx-name dom))
neg-blame pos-blame src-info orig-str
(not positive-position?))]
(check-pre-expr->pp/h val pre-expr (blame-swap blame))
(let ([dom-id ((contract-projection (coerce-contract 'stx-name dom))
(blame-swap blame))]
...
[rng-id ((contract-proc (coerce-contract 'stx-name rng))
pos-blame neg-blame src-info orig-str
positive-position?)])
[rng-id ((contract-projection (coerce-contract 'stx-name rng))
blame)])
(let ([res-id (rng-id (val (dom-id x) ...))])
(check-post-expr->pp/h val post-expr src-info pos-blame orig-str)
(check-post-expr->pp/h val post-expr blame)
res-id)))))]
[_
(raise-syntax-error name "unknown result specification" stx (syntax result-stuff))]))))))]
@ -1000,35 +981,33 @@
(values
(lambda (outer-args body)
(with-syntax ([body body]
[(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
[(val blame name-id) outer-args])
(syntax
(let ([name-id name-stx])
body))))
(lambda (outer-args inner-lambda) inner-lambda)
(lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args]
(with-syntax ([(val blame name-id) outer-args]
[kind-of-thing (if method-proc? 'method 'procedure)])
(syntax
(begin
(check-procedure/more/kind val arity 'kind-of-thing src-info pos-blame orig-str)))))
(check-procedure/more/kind val arity 'kind-of-thing blame)))))
(syntax (check-procedure/more? arity))
(lambda (outer-args)
(with-syntax ([(val pos-blame neg-blame src-info orig-str name-id positive-position?) outer-args])
(with-syntax ([(val blame name-id) outer-args])
(syntax-case* (syntax result-stuff) (values any) module-or-top-identifier=?
[(any)
(syntax
((x ... . rest-x)
(begin
(check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str)
(let ([dom-id ((contract-proc (coerce-contract 'stx-name dom))
neg-blame pos-blame src-info orig-str
(not positive-position?))]
(check-pre-expr->pp/h val pre-expr (blame-swap blame))
(let ([dom-id ((contract-projection (coerce-contract 'stx-name dom))
(blame-swap blame))]
...
[rest-id ((contract-proc (coerce-contract 'stx-name rest-dom))
neg-blame pos-blame src-info orig-str
(not positive-position?))])
[rest-id ((contract-projection (coerce-contract 'stx-name rest-dom))
(blame-swap blame))])
(apply val (dom-id x) ... (rest-id rest-x))))))]
[(any . x)
(raise-syntax-error name "cannot have anything after any" stx (syntax result-stuff))]
@ -1039,19 +1018,16 @@
(syntax
((x ... . rest-x)
(begin
(check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str)
(let ([dom-id ((contract-proc (coerce-contract 'stx-name dom))
neg-blame pos-blame src-info orig-str
(not positive-position?))]
(check-pre-expr->pp/h val pre-expr (blame-swap blame))
(let ([dom-id ((contract-projection (coerce-contract 'stx-name dom))
(blame-swap blame))]
...
[rest-id ((contract-proc (coerce-contract 'stx-name rest-dom))
neg-blame pos-blame src-info orig-str
(not positive-position?))])
[rest-id ((contract-projection (coerce-contract 'stx-name rest-dom))
(blame-swap blame))])
(let-values ([(rng-ids ...) (apply val (dom-id x) ... (rest-id rest-x))])
(check-post-expr->pp/h val post-expr src-info pos-blame orig-str)
(let ([rng-ids-x ((contract-proc (coerce-contract 'stx-name rng-ctc))
pos-blame neg-blame src-info orig-str
positive-position?)] ...)
(check-post-expr->pp/h val post-expr blame)
(let ([rng-ids-x ((contract-projection (coerce-contract 'stx-name rng-ctc))
blame)] ...)
(values (rng-ids-x rng-ids) ...))))))))]
[((values (rng-ids rng-ctc) ...) . whatever)
(and (andmap identifier? (syntax->list (syntax (rng-ids ...))))
@ -1073,19 +1049,16 @@
(syntax
((x ... . rest-x)
(begin
(check-pre-expr->pp/h val pre-expr src-info neg-blame orig-str)
(let ([dom-id ((contract-proc (coerce-contract 'stx-name dom))
neg-blame pos-blame src-info orig-str
(not positive-position?))]
(check-pre-expr->pp/h val pre-expr (blame-swap blame))
(let ([dom-id ((contract-projection (coerce-contract 'stx-name dom))
(blame-swap blame))]
...
[rest-id ((contract-proc (coerce-contract 'stx-name rest-dom))
neg-blame pos-blame src-info orig-str
(not positive-position?))]
[rng-id ((contract-proc (coerce-contract 'stx-name rng))
pos-blame neg-blame src-info orig-str
positive-position?)])
[rest-id ((contract-projection (coerce-contract 'stx-name rest-dom))
(blame-swap blame))]
[rng-id ((contract-projection (coerce-contract 'stx-name rng))
blame)])
(let ([res-id (rng-id (apply val (dom-id x) ... (rest-id rest-x)))])
(check-post-expr->pp/h val post-expr src-info pos-blame orig-str)
(check-post-expr->pp/h val post-expr blame)
res-id)))))]
[(rng res-id post-expr)
(not (identifier? (syntax res-id)))

142
collects/mzlib/private/contract-arrow.ss
View File

@ -30,22 +30,20 @@
[(p-app-x ...) (generate-temporaries #'(rngs ...))]
[(res-x ...) (generate-temporaries #'(rngs ...))])
#'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
(let ([proj-x ((proj-get rngs-x) rngs-x)] ...)
(make-proj-contract
(build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...)
(λ (pos-blame neg-blame src-info orig-str positive-position?)
(let ([p-app-x (proj-x pos-blame neg-blame src-info orig-str positive-position?)] ...)
(let ([proj-x (contract-projection rngs-x)] ...)
(simple-contract
#:name
(build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...)
#:projection
(λ (blame)
(let ([p-app-x (proj-x blame)] ...)
(λ (val)
(if (procedure? val)
(λ args
(let-values ([(res-x ...) (apply val args)])
(values (p-app-x res-x) ...)))
(raise-contract-error val
src-info
pos-blame
orig-str
"expected a procedure")))))
procedure?))))]))
(raise-blame-error blame val "expected a procedure")))))
#:first-order procedure?))))]))
(define (build--> name doms doms-rest rngs kwds quoted-kwds rng-any? func)
(let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)]
@ -64,64 +62,66 @@
;; and it produces a wrapper-making function.
(define-struct -> (rng-any? doms dom-rest rngs kwds quoted-kwds func)
#:omit-define-syntaxes
#:property proj-prop
(λ (ctc)
(let* ([doms/c (map (λ (x) ((proj-get x) x))
(if (->-dom-rest ctc)
#:property prop:contract
(build-contract-property
#:projection
(λ (ctc)
(let* ([doms/c (map contract-projection
(if (->-dom-rest ctc)
(append (->-doms ctc) (list (->-dom-rest ctc)))
(->-doms ctc)))]
[rngs/c (map (λ (x) ((proj-get x) x)) (->-rngs ctc))]
[kwds/c (map (λ (x) ((proj-get x) x)) (->-kwds ctc))]
[mandatory-keywords (->-quoted-kwds ctc)]
[func (->-func ctc)]
[dom-length (length (->-doms ctc))]
[has-rest? (and (->-dom-rest ctc) #t)])
(lambda (pos-blame neg-blame src-info orig-str positive-position?)
(let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str (not positive-position?)))
doms/c)]
[partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str positive-position?))
rngs/c)]
[partial-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str (not positive-position?)))
kwds/c)])
(apply func
(λ (val)
(if has-rest?
(check-procedure/more val dom-length '() mandatory-keywords src-info pos-blame orig-str)
(check-procedure val dom-length 0 '() mandatory-keywords src-info pos-blame orig-str)))
(append partial-doms partial-ranges partial-kwds))))))
#:property name-prop
(λ (ctc) (single-arrow-name-maker
(->-doms ctc)
(->-dom-rest ctc)
(->-kwds ctc)
(->-quoted-kwds ctc)
(->-rng-any? ctc)
(->-rngs ctc)))
#:property first-order-prop
(λ (ctc)
(let ([l (length (->-doms ctc))])
(if (->-dom-rest ctc)
[rngs/c (map contract-projection (->-rngs ctc))]
[kwds/c (map contract-projection (->-kwds ctc))]
[mandatory-keywords (->-quoted-kwds ctc)]
[func (->-func ctc)]
[dom-length (length (->-doms ctc))]
[has-rest? (and (->-dom-rest ctc) #t)])
(lambda (blame)
(let ([partial-doms (map (λ (dom) (dom (blame-swap blame)))
doms/c)]
[partial-ranges (map (λ (rng) (rng blame))
rngs/c)]
[partial-kwds (map (λ (kwd) (kwd (blame-swap blame)))
kwds/c)])
(apply func
(λ (val)
(if has-rest?
(check-procedure/more val dom-length '() mandatory-keywords blame)
(check-procedure val dom-length 0 '() mandatory-keywords blame)))
(append partial-doms partial-ranges partial-kwds))))))
#:name
(λ (ctc) (single-arrow-name-maker
(->-doms ctc)
(->-dom-rest ctc)
(->-kwds ctc)
(->-quoted-kwds ctc)
(->-rng-any? ctc)
(->-rngs ctc)))
#:first-order
(λ (ctc)
(let ([l (length (->-doms ctc))])
(if (->-dom-rest ctc)
(λ (x)
(and (procedure? x)
(procedure-accepts-and-more? x l)))
(and (procedure? x)
(procedure-accepts-and-more? x l)))
(λ (x)
(and (procedure? x)
(procedure-arity-includes? x l)
(no-mandatory-keywords? x))))))
#:property stronger-prop
(λ (this that)
(and (->? that)
(= (length (->-doms that))
(length (->-doms this)))
(andmap contract-stronger?
(->-doms that)
(->-doms this))
(= (length (->-rngs that))
(length (->-rngs this)))
(andmap contract-stronger?
(->-rngs this)
(->-rngs that)))))
(and (procedure? x)
(procedure-arity-includes? x l)
(no-mandatory-keywords? x))))))
#:stronger
(λ (this that)
(and (->? that)
(= (length (->-doms that))
(length (->-doms this)))
(andmap contract-stronger?
(->-doms that)
(->-doms this))
(= (length (->-rngs that))
(length (->-rngs this)))
(andmap contract-stronger?
(->-rngs this)
(->-rngs that))))))
(define (single-arrow-name-maker doms/c doms-rest kwds/c kwds rng-any? rngs)
(cond
@ -455,16 +455,14 @@
(append partials-rngs partial)
(append this-stronger-ribs stronger-ribs)))]))])
(values
(with-syntax ((pos (opt/info-pos opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
(with-syntax ((blame (opt/info-blame opt/info))
((dom-arg ...) dom-vars)
((rng-arg ...) rng-vars)
((next-dom ...) next-doms)
(dom-len (length dom-vars))
((next-rng ...) next-rngs))
(syntax (begin
(check-procedure val dom-len 0 '() '() #| keywords |# src-info pos orig-str)
(check-procedure val dom-len 0 '() '() #| keywords |# blame)
(λ (dom-arg ...)
(let-values ([(rng-arg ...) (val next-dom ...)])
(values next-rng ...))))))
@ -505,14 +503,12 @@
(append partials-doms partial)
(append this-stronger-ribs stronger-ribs)))]))])
(values
(with-syntax ((pos (opt/info-pos opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
(with-syntax ((blame (opt/info-blame opt/info))
((dom-arg ...) dom-vars)
((next-dom ...) next-doms)
(dom-len (length dom-vars)))
(syntax (begin
(check-procedure val dom-len 0 '() '() #|keywords|# src-info pos orig-str)
(check-procedure val dom-len 0 '() '() #|keywords|# blame)
(λ (dom-arg ...)
(val next-dom ...)))))
lifts-doms

11
collects/mzlib/private/contract-define.ss
View File

@ -2,9 +2,10 @@
(provide define/contract)
(require (for-syntax scheme/base)
(only-in scheme/contract contract)
(for-syntax (prefix-in a: scheme/contract/private/helpers)))
(require (for-syntax scheme/base
unstable/srcloc
(prefix-in a: scheme/contract/private/helpers))
(only-in scheme/contract contract))
;; First, we have the old define/contract implementation, which
;; is still used in mzlib/contract.
@ -12,7 +13,7 @@
(define-for-syntax (make-define/contract-transformer contract-id id)
(make-set!-transformer
(λ (stx)
(with-syntax ([neg-blame-str (a:build-src-loc-string stx)]
(with-syntax ([neg-blame-str (source-location->string stx "<<unknown>>")]
[contract-id contract-id]
[id id])
(syntax-case stx (set!)
@ -27,6 +28,7 @@
id
(syntax->datum (quote-syntax f))
neg-blame-str
(quote f)
(quote-syntax f))
arg
...))]
@ -37,6 +39,7 @@
id
(syntax->datum (quote-syntax ident))
neg-blame-str
(quote ident)
(quote-syntax ident)))])))))
;; (define/contract id contract expr)

50
collects/mzlib/private/contract-object.ss
View File

@ -331,37 +331,39 @@
...
[field-ctc-var (coerce-contract 'object-contract field-ctc-stx)]
...)
(let ([method-var (contract-proc method-ctc-var)]
(let ([method-var (contract-projection method-ctc-var)]
...
[field-var (contract-proc field-ctc-var)]
[field-var (contract-projection field-ctc-var)]
...)
(let ([cls (make-wrapper-class 'wrapper-class
'(method-name ...)
(list methods ...)
'(field-name ...)
#t)])
(make-proj-contract
(simple-contract
#:name
`(object-contract
,(build-compound-type-name 'method-name method-ctc-var) ...
,(build-compound-type-name 'field 'field-name field-ctc-var) ...)
(lambda (pos-blame neg-blame src-info orig-str positive-position?)
(let ([method/app-var (method-var pos-blame neg-blame src-info orig-str positive-position?)]
#:projection
(lambda (blame)
(let ([method/app-var (method-var blame)]
...
[field/app-var (field-var pos-blame neg-blame src-info orig-str positive-position?)]
[field/app-var (field-var blame)]
...)
(let ([field-names-list '(field-name ...)])
(lambda (val)
(check-object val src-info pos-blame orig-str)
(check-object val blame)
(let ([val-mtd-names
(interface->method-names
(object-interface
val))])
(void)
(check-method val 'method-name val-mtd-names src-info pos-blame orig-str)
(check-method val 'method-name val-mtd-names blame)
...)
(unless (field-bound? field-name val)
(field-error val 'field-name src-info pos-blame orig-str)) ...
(field-error val 'field-name blame)) ...
(let ([vtable (extract-vtable val)]
[method-ht (extract-method-ht val)])
@ -369,35 +371,19 @@
val
(method/app-var (vector-ref vtable (hash-ref method-ht 'method-name))) ...
(field/app-var (get-field field-name val)) ...
))))))
#f)))))))]))))
)))))))))))))]))))
(define (check-object val src-info blame orig-str)
(define (check-object val blame)
(unless (object? val)
(raise-contract-error val
src-info
blame
orig-str
"expected an object, got ~e"
val)))
(raise-blame-error blame val "expected an object, got ~e" val)))
(define (check-method val method-name val-mtd-names src-info blame orig-str)
(define (check-method val method-name val-mtd-names blame)
(unless (memq method-name val-mtd-names)
(raise-contract-error val
src-info
blame
orig-str
"expected an object with method ~s"
method-name)))
(raise-blame-error blame val "expected an object with method ~s" method-name)))
(define (field-error val field-name src-info blame orig-str)
(raise-contract-error val
src-info
blame
orig-str
"expected an object with field ~s"
field-name))
(define (field-error val field-name blame)
(raise-blame-error blame val "expected an object with field ~s" field-name))
(define (make-mixin-contract . %/<%>s)
((and/c (flat-contract class?)

54
collects/mzlib/private/unit-contract.ss
View File

@ -15,7 +15,7 @@
(provide (for-syntax unit/c/core) unit/c)
(define-for-syntax (contract-imports/exports import?)
(λ (table-stx import-tagged-infos import-sigs ctc-table pos neg src-info name positive-position?)
(λ (table-stx import-tagged-infos import-sigs ctc-table blame-id)
(define def-table (make-bound-identifier-mapping))
(define (convert-reference var vref ctc sig-ctc rename-bindings)
@ -25,12 +25,8 @@
;; store the result in a local box, then just check the box to
;; see if we need to coerce.
#`(let ([ctc (coerce-contract 'unit/c (letrec-syntax #,rename-bindings #,ctc))])
((((proj-get ctc) ctc)
#,(if import? neg pos)
#,(if import? pos neg)
#,src-info
#,name
#,(if import? (not positive-position?) positive-position?))
(((contract-projection ctc)
#,(if import? #`(blame-swap #,blame-id) blame-id))
#,stx)))])
(if ctc
#`(λ ()
@ -43,9 +39,9 @@
var)])
#`(let ([old-v/c (#,vref)])
(contract sig-ctc-stx (car old-v/c)
(cdr old-v/c) #,pos
#,(id->contract-src-info var)))))
#,neg)
(cdr old-v/c) (blame-positive #,blame-id)
(quote #,var) (quote-syntax #,var)))))
(blame-negative #,blame-id))
(wrap-with-proj ctc #`(#,vref))))
vref)))
(for ([tagged-info (in-list import-tagged-infos)]
@ -57,7 +53,7 @@
#`(vector-ref #,v #,index)))))
(with-syntax ((((eloc ...) ...)
(for/list ([target-sig import-sigs])
(let ([rename-bindings (get-member-bindings def-table target-sig pos)])
(let ([rename-bindings (get-member-bindings def-table target-sig #`(blame-positive #,blame-id))])
(for/list ([target-int/ext-name (in-list (car target-sig))]
[sig-ctc (in-list (cadddr target-sig))])
(let* ([var (car target-int/ext-name)]
@ -136,7 +132,8 @@
export-tagged-infos)])
(quasisyntax/loc stx
(begin
(make-proj-contract
(simple-contract
#:name
(list 'unit/c
(cons 'import
(list (cons 'isig
@ -148,11 +145,11 @@
(map list (list 'e.x ...)
(build-compound-type-name 'e.c ...)))
...)))
(λ (pos neg src-info name positive-position?)
#:projection
(λ (blame)
(λ (unit-tmp)
(unless (unit? unit-tmp)
(raise-contract-error unit-tmp src-info pos name
"value is not a unit"))
(raise-blame-error blame unit-tmp "value is not a unit"))
(contract-check-sigs
unit-tmp
(vector-immutable
@ -161,7 +158,7 @@
(vector-immutable
(cons 'export-name
(vector-immutable export-key ...)) ...)
src-info pos name)
blame)
(make-unit
'#,name
(vector-immutable (cons 'import-name
@ -177,21 +174,14 @@
import-tagged-infos
import-sigs
contract-table
#'pos
#'neg
#'src-info
#'name
#'positive-position?)))
#'blame)))
#,(contract-exports
#'export-table
export-tagged-infos
export-sigs
contract-table
#'pos
#'neg
#'src-info
#'name
#'positive-position?)))))))
#'blame)))))))
#:first-order
(λ (v)
(and (unit? v)
(with-handlers ([exn:fail:contract? (λ () #f)])
@ -212,7 +202,7 @@
(let ([name (syntax-local-infer-name stx)])
(unit/c/core name #'sstx))]))
(define (contract-check-helper sub-sig super-sig import? val src-info blame ctc)
(define (contract-check-helper sub-sig super-sig import? val blame)
(define t (make-hash))
(let loop ([i (sub1 (vector-length sub-sig))])
(when (>= i 0)
@ -232,8 +222,8 @@
[r (hash-ref t v0 #f)])
(when (not r)
(let ([sub-name (car (vector-ref super-sig i))])
(raise-contract-error
val src-info blame ctc
(raise-blame-error
blame val
(cond
[import?
(format "contract does not list import ~a" sub-name)]
@ -241,6 +231,6 @@
(format "unit must export signature ~a" sub-name)])))))
(loop (sub1 i)))))
(define (contract-check-sigs unit expected-imports expected-exports src-info blame ctc)
(contract-check-helper expected-imports (unit-import-sigs unit) #t unit src-info blame ctc)
(contract-check-helper (unit-export-sigs unit) expected-exports #f unit src-info blame ctc))
(define (contract-check-sigs unit expected-imports expected-exports blame)
(contract-check-helper expected-imports (unit-import-sigs unit) #t unit blame)
(contract-check-helper (unit-export-sigs unit) expected-exports #f unit blame))

17
collects/mzlib/private/unit-utils.ss
View File

@ -13,7 +13,6 @@
process-unit-import
process-unit-export
tagged-info->keys
id->contract-src-info
get-member-bindings))
(provide equal-hash-table
@ -26,20 +25,10 @@
((= n 0) acc)
(else (loop (sub1 n) (cons (sub1 n) acc))))))
;; id->contract-src-info : identifier -> syntax
;; constructs the last argument to the contract, given an identifier
(define-for-syntax (id->contract-src-info id)
#`(list (make-srcloc (quote-syntax #,id)
#,(syntax-line id)
#,(syntax-column id)
#,(syntax-position id)
#,(syntax-span id))
#,(format "~s" (syntax->datum id))))
(define-syntax-rule (equal-hash-table [k v] ...)
(make-immutable-hash (list (cons k v) ...)))
(define-for-syntax (get-member-bindings member-table sig blame)
(define-for-syntax (get-member-bindings member-table sig pos)
(for/list ([i (in-list (map car (car sig)))]
[c (in-list (cadddr sig))])
(let ([add-ctc
@ -47,8 +36,8 @@
(if c
(with-syntax ([c-stx (syntax-property c 'inferred-name v)])
#`(let ([v/c (#,stx)])
(contract c-stx (car v/c) (cdr v/c) #,blame
#,(id->contract-src-info v))))
(contract c-stx (car v/c) (cdr v/c) #,pos
(quote #,v) (quote-syntax #,v))))
#`(#,stx)))])
#`[#,i
(make-set!-transformer

19
collects/mzlib/unit.ss
View File

@ -16,6 +16,7 @@
(require mzlib/etc
scheme/contract/base
scheme/stxparam
unstable/location
"private/unit-contract.ss"
"private/unit-keywords.ss"
"private/unit-runtime.ss"
@ -482,7 +483,7 @@
(if (pair? v/c)
(contract (let-syntax #,renamings ctc-stx) (car v/c) (cdr v/c)
(current-contract-region)
#,(id->contract-src-info var))
(quote #,var) (quote-syntax #,var))
(error 'unit "contracted import ~a used before definition"
(quote #,(syntax->datum var))))))))
(quasisyntax/loc (error-syntax)
@ -747,7 +748,8 @@
(contract #,ctc #,tmp
(current-contract-region)
'cant-happen
#,(id->contract-src-info id))
(quote #,id)
(quote-syntax #,id))
(set-box! #,export-loc
(cons #,tmp (current-contract-region)))))
(quasisyntax/loc defn-or-expr
@ -824,7 +826,7 @@
#`(let ([old-v/c (#,vref)])
(contract ctc-stx (car old-v/c)
(cdr old-v/c) (current-contract-region)
#,(id->contract-src-info var)))
(quote #,var) (quote-syntax #,var)))
#`(#,vref))
(current-contract-region)))
(if ctc
@ -832,7 +834,7 @@
(let ([old-v/c (#,vref)])
(contract ctc-stx (car old-v/c)
(cdr old-v/c) (current-contract-region)
#,(id->contract-src-info var))))
(quote #,var) (quote-syntax #,var))))
vref)))))
(car target-sig)
(cadddr target-sig)))
@ -1293,7 +1295,7 @@
(((wrap-code ...) ...)
(map (λ (os ov tbs)
(define rename-bindings
(get-member-bindings def-table os #'(#%variable-reference)))
(get-member-bindings def-table os #'(quote-module-path)))
(map (λ (tb i v c)
(if c
(with-syntax ([ctc-stx
@ -1303,7 +1305,7 @@
#`(let ([v/c (#,tb)])
(contract ctc-stx (car v/c) (cdr v/c)
(current-contract-region)
#,(id->contract-src-info v))))
(quote #,v) (quote-syntax #,v))))
#`(#,tb)))
tbs
(iota (length (car os)))
@ -1503,11 +1505,10 @@
#'name
(syntax/loc stx
((import (import-tagged-sig-id [i.x i.c] ...) ...)
(export (export-tagged-sig-id [e.x e.c] ...) ...))))]
[src-info (id->contract-src-info #'name)])
(export (export-tagged-sig-id [e.x e.c] ...) ...))))])
(values
(syntax/loc stx
(contract unit-contract new-unit '(unit name) (current-contract-region) src-info))
(contract unit-contract new-unit '(unit name) (current-contract-region) (quote name) (quote-syntax name)))
isigs esigs deps))))]
[(ic:import-clause/contract ec:export-clause/contract . body)
(build-unit/contract

76
collects/scheme/contract.ss
View File

@ -9,80 +9,14 @@ differences from v3:
|#
(require "contract/private/arrow.ss"
"contract/private/base.ss"
scheme/contract/exists
"contract/private/misc.ss"
"contract/private/provide.ss"
(require scheme/contract/exists
scheme/contract/regions
"contract/private/guts.ss"
"contract/private/ds.ss"
"contract/private/opt.ss"
"contract/private/basic-opters.ss")
"contract/private/basic-opters.ss"
"contract/base.ss")
(provide
opt/c define-opt/c ;(all-from-out "contract/private/opt.ss")
(except-out (all-from-out "contract/private/ds.ss")
lazy-depth-to-look)
(except-out (all-from-out "contract/private/arrow.ss")
making-a-method
procedure-accepts-and-more?
check-procedure
check-procedure/more)
(provide (all-from-out "contract/base.ss")
(except-out (all-from-out scheme/contract/exists) ∃?)
(except-out (all-from-out "contract/private/misc.ss")
check-between/c
check-unary-between/c)
(all-from-out scheme/contract/regions)
(all-from-out "contract/private/provide.ss")
(all-from-out "contract/private/base.ss"))
;; from contract-guts.ss
(provide any
and/c
any/c
none/c
make-none/c
guilty-party
exn:fail:contract2?
exn:fail:contract2-srclocs
contract-violation->string
contract?
contract-name
contract-proc
flat-contract?
flat-contract
flat-contract-predicate
flat-named-contract
contract-first-order-passes?
;; below need docs
make-proj-contract
contract-stronger?
coerce-contract/f
coerce-contract
coerce-contracts
coerce-flat-contract
coerce-flat-contracts
build-compound-type-name
raise-contract-error
proj-prop proj-pred? proj-get
name-prop name-pred? name-get
stronger-prop stronger-pred? stronger-get
flat-prop flat-pred? flat-get
first-order-prop first-order-get)
(all-from-out scheme/contract/regions))
;; ======================================================================
;; The alternate implementation disables contracts. Its useful mainly to

52
collects/scheme/contract/base.ss
View File

@ -8,6 +8,7 @@
"private/misc.ss"
"private/provide.ss"
"private/guts.ss"
"private/legacy.ss"
"private/ds.ss"
"private/opt.ss")
@ -25,50 +26,9 @@
check-between/c
check-unary-between/c)
(all-from-out "private/provide.ss")
(all-from-out "private/base.ss"))
(all-from-out "private/base.ss")
(all-from-out "private/legacy.ss")
(except-out (all-from-out "private/guts.ss")
check-flat-contract
check-flat-named-contract))
;; from private/guts.ss
(provide any
and/c
any/c
none/c
make-none/c
guilty-party
exn:fail:contract2?
exn:fail:contract2-srclocs
contract-violation->string
contract?
contract-name
contract-proc
flat-contract?
flat-contract
flat-contract-predicate
flat-named-contract
contract-first-order-passes?
;; below need docs
make-proj-contract
contract-stronger?
coerce-contract/f
coerce-contract
coerce-contracts
coerce-flat-contract
coerce-flat-contracts
build-compound-type-name
raise-contract-error
proj-prop proj-pred? proj-get
name-prop name-pred? name-get
stronger-prop stronger-pred? stronger-get
flat-prop flat-pred? flat-get
first-order-prop first-order-get)

25
collects/scheme/contract/exists.ss
View File

@ -9,25 +9,24 @@
(let ([in (∃/c-in ctc)]
[out (∃/c-out ctc)]
[pred? (∃/c-pred? ctc)])
(λ (pos-blame neg-blame src-info orig-str positive-position?)
(if positive-position?
in
(λ (blame)
(if (blame-swapped? blame)
(λ (val)
(if (pred? val)
(out val)
(raise-contract-error val src-info pos-blame orig-str
"non-polymorphic value: ~e"
val)))))))
(raise-blame-error blame
val
"non-polymorphic value: ~e"
val)))
in))))
(define-struct ∃/c (in out pred? name)
#:omit-define-syntaxes
#:property proj-prop ∃-proj
#:property name-prop (λ (ctc) (∃/c-name ctc))
#:property first-order-prop
(λ (ctc) (λ (x) #t)) ;; ???
#:property stronger-prop
(λ (this that) #f))
#:property prop:contract
(build-contract-property
#:name (λ (ctc) (∃/c-name ctc))
#:first-order (λ (ctc) (λ (x) #t)) ;; ???
#:projection ∃-proj))
(define-struct ∃ ())

447
collects/scheme/contract/private/arrow.ss
View File

@ -48,11 +48,13 @@ v4 todo:
[(p-app-x ...) (generate-temporaries #'(rngs ...))]
[(res-x ...) (generate-temporaries #'(rngs ...))])
#'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
(let ([proj-x ((proj-get rngs-x) rngs-x)] ...)
(make-proj-contract
(build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...)
(λ (pos-blame neg-blame src-info orig-str positive-position?)
(let ([p-app-x (proj-x pos-blame neg-blame src-info orig-str positive-position?)] ...)
(let ([proj-x (contract-projection rngs-x)] ...)
(simple-contract
#:name
(build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...)
#:projection
(λ (blame)
(let ([p-app-x (proj-x blame)] ...)
(λ (val)
(if (procedure? val)
(make-keyword-procedure
@ -62,11 +64,10 @@ v4 todo:
(λ args
(let-values ([(res-x ...) (apply val args)])
(values (p-app-x res-x) ...))))
(raise-contract-error val
src-info
pos-blame
orig-str
"expected a procedure")))))
(raise-blame-error blame
val
"expected a procedure")))))
#:first-order
procedure?))))]))
@ -100,81 +101,83 @@ v4 todo:
;; and it produces a wrapper-making function.
(define-struct -> (doms/c optional-doms/c dom-rest/c mandatory-kwds/c mandatory-kwds optional-kwds/c optional-kwds rngs/c rng-any? func)
#:omit-define-syntaxes
#:property proj-prop
(λ (ctc)
(let* ([doms-proj (map (λ (x) ((proj-get x) x))
(if (->-dom-rest/c ctc)
#:property prop:contract
(build-contract-property
#:projection
(λ (ctc)
(let* ([doms-proj (map contract-projection
(if (->-dom-rest/c ctc)
(append (->-doms/c ctc) (list (->-dom-rest/c ctc)))
(->-doms/c ctc)))]
[doms-optional-proj (map (λ (x) ((proj-get x) x)) (->-optional-doms/c ctc))]
[rngs-proj (map (λ (x) ((proj-get x) x)) (->-rngs/c ctc))]
[mandatory-kwds-proj (map (λ (x) ((proj-get x) x)) (->-mandatory-kwds/c ctc))]
[optional-kwds-proj (map (λ (x) ((proj-get x) x)) (->-optional-kwds/c ctc))]
[mandatory-keywords (->-mandatory-kwds ctc)]
[optional-keywords (->-optional-kwds ctc)]
[func (->-func ctc)]
[dom-length (length (->-doms/c ctc))]
[optionals-length (length (->-optional-doms/c ctc))]
[has-rest? (and (->-dom-rest/c ctc) #t)])
(λ (pos-blame neg-blame src-info orig-str positive-position?)
(let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str (not positive-position?)))
doms-proj)]
[partial-optional-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str (not positive-position?)))
doms-optional-proj)]
[partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str positive-position?))
rngs-proj)]
[partial-mandatory-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str (not positive-position?)))
mandatory-kwds-proj)]
[partial-optional-kwds (map (λ (kwd) (kwd neg-blame pos-blame src-info orig-str (not positive-position?)))
optional-kwds-proj)])
(apply func
(λ (val mtd?)
(if has-rest?
(check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords src-info pos-blame orig-str)
(check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords src-info pos-blame orig-str)))
(append partial-doms partial-optional-doms
partial-mandatory-kwds partial-optional-kwds
partial-ranges))))))
#:property name-prop
(λ (ctc) (single-arrow-name-maker
(->-doms/c ctc)
(->-optional-doms/c ctc)
(->-dom-rest/c ctc)
(->-mandatory-kwds/c ctc)
(->-mandatory-kwds ctc)
(->-optional-kwds/c ctc)
(->-optional-kwds ctc)
(->-rng-any? ctc)
(->-rngs/c ctc)))
#:property first-order-prop
(λ (ctc)
(λ (x)
(let ([l (length (->-doms/c ctc))])
(and (procedure? x)
(if (->-dom-rest/c ctc)
(procedure-accepts-and-more? x l)
(procedure-arity-includes? x l))
(let-values ([(x-mandatory-keywords x-all-keywords) (procedure-keywords x)])
(and (equal? x-mandatory-keywords (->-mandatory-kwds ctc))
(andmap (λ (optional-keyword) (member optional-keyword x-all-keywords))
(->-mandatory-kwds ctc))))
#t))))
#:property stronger-prop
(λ (this that)
(and (->? that)
(= (length (->-doms/c that)) (length (->-doms/c this)))
(andmap contract-stronger? (->-doms/c that) (->-doms/c this))
(equal? (->-mandatory-kwds this) (->-mandatory-kwds that))
(andmap contract-stronger? (->-mandatory-kwds/c that) (->-mandatory-kwds/c this))
(equal? (->-optional-kwds this) (->-optional-kwds that))
(andmap contract-stronger? (->-optional-kwds/c that) (->-optional-kwds/c this))
(= (length (->-rngs/c that)) (length (->-rngs/c this)))
(andmap contract-stronger? (->-rngs/c this) (->-rngs/c that)))))
[doms-optional-proj (map contract-projection (->-optional-doms/c ctc))]
[rngs-proj (map contract-projection (->-rngs/c ctc))]
[mandatory-kwds-proj (map contract-projection (->-mandatory-kwds/c ctc))]
[optional-kwds-proj (map contract-projection (->-optional-kwds/c ctc))]
[mandatory-keywords (->-mandatory-kwds ctc)]
[optional-keywords (->-optional-kwds ctc)]
[func (->-func ctc)]
[dom-length (length (->-doms/c ctc))]
[optionals-length (length (->-optional-doms/c ctc))]
[has-rest? (and (->-dom-rest/c ctc) #t)])
(λ (blame)
(let ([partial-doms (map (λ (dom) (dom (blame-swap blame)))
doms-proj)]
[partial-optional-doms (map (λ (dom) (dom (blame-swap blame)))
doms-optional-proj)]
[partial-ranges (map (λ (rng) (rng blame))
rngs-proj)]
[partial-mandatory-kwds (map (λ (kwd) (kwd (blame-swap blame)))
mandatory-kwds-proj)]
[partial-optional-kwds (map (λ (kwd) (kwd (blame-swap blame)))
optional-kwds-proj)])
(apply func
(λ (val mtd?)
(if has-rest?
(check-procedure/more val mtd? dom-length mandatory-keywords optional-keywords blame)
(check-procedure val mtd? dom-length optionals-length mandatory-keywords optional-keywords blame)))
(append partial-doms partial-optional-doms
partial-mandatory-kwds partial-optional-kwds
partial-ranges))))))
#:name
(λ (ctc) (single-arrow-name-maker
(->-doms/c ctc)
(->-optional-doms/c ctc)
(->-dom-rest/c ctc)
(->-mandatory-kwds/c ctc)
(->-mandatory-kwds ctc)
(->-optional-kwds/c ctc)
(->-optional-kwds ctc)
(->-rng-any? ctc)
(->-rngs/c ctc)))
#:first-order
(λ (ctc)
(λ (x)
(let ([l (length (->-doms/c ctc))])
(and (procedure? x)
(if (->-dom-rest/c ctc)
(procedure-accepts-and-more? x l)
(procedure-arity-includes? x l))
(let-values ([(x-mandatory-keywords x-all-keywords) (procedure-keywords x)])
(and (equal? x-mandatory-keywords (->-mandatory-kwds ctc))
(andmap (λ (optional-keyword) (member optional-keyword x-all-keywords))
(->-mandatory-kwds ctc))))
#t))))
#:stronger
(λ (this that)
(and (->? that)
(= (length (->-doms/c that)) (length (->-doms/c this)))
(andmap contract-stronger? (->-doms/c that) (->-doms/c this))
(equal? (->-mandatory-kwds this) (->-mandatory-kwds that))
(andmap contract-stronger? (->-mandatory-kwds/c that) (->-mandatory-kwds/c this))
(equal? (->-optional-kwds this) (->-optional-kwds that))
(andmap contract-stronger? (->-optional-kwds/c that) (->-optional-kwds/c this))
(= (length (->-rngs/c that)) (length (->-rngs/c this)))
(andmap contract-stronger? (->-rngs/c this) (->-rngs/c that))))))
(define (build--> name
doms/c-or-p optional-doms/c-or-p doms-rest/c-or-p-or-f
@ -435,16 +438,14 @@ v4 todo:
(append partials-rngs partial)
(append this-stronger-ribs stronger-ribs)))]))])
(values
(with-syntax ((pos (opt/info-pos opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
(with-syntax ((blame (opt/info-blame opt/info))
((dom-arg ...) dom-vars)
((rng-arg ...) rng-vars)
((next-dom ...) next-doms)
(dom-len (length dom-vars))
((next-rng ...) next-rngs))
(syntax (begin
(check-procedure val #f dom-len 0 '() '() #| keywords |# src-info pos orig-str)
(check-procedure val #f dom-len 0 '() '() #| keywords |# blame)
(λ (dom-arg ...)
(let-values ([(rng-arg ...) (val next-dom ...)])
(values next-rng ...))))))
@ -485,14 +486,12 @@ v4 todo:
(append partials-doms partial)
(append this-stronger-ribs stronger-ribs)))]))])
(values
(with-syntax ((pos (opt/info-pos opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
(with-syntax ((blame (opt/info-blame opt/info))
((dom-arg ...) dom-vars)
((next-dom ...) next-doms)
(dom-len (length dom-vars)))
(syntax (begin
(check-procedure val #f dom-len 0 '() '() #|keywords|# src-info pos orig-str)
(check-procedure val #f dom-len 0 '() '() #|keywords|# blame)
(λ (dom-arg ...)
(val next-dom ...)))))
lifts-doms
@ -855,7 +854,7 @@ v4 todo:
(list (+ mandatory-count i))]
[else
(cons (+ mandatory-count i) (loop (+ i 1)))]))])])
(λ (pos-blame neg-blame src-info orig-str positive-position?)
(λ (blame)
(let ([this->d-id (gensym '->d-tail-key)])
(λ (val)
(check-procedure val
@ -864,7 +863,7 @@ v4 todo:
(length (->d-optional-dom-ctcs ->d-stct)) ; optionals-length
(->d-mandatory-keywords ->d-stct)
(->d-optional-keywords ->d-stct)
src-info pos-blame orig-str)
blame)
(let ([kwd-proc
(λ (kwd-args kwd-arg-vals . raw-orig-args)
(let* ([orig-args (if (->d-mtd? ->d-stct)
@ -889,7 +888,7 @@ v4 todo:
[(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) neg-blame pos-blame src-info orig-str (not positive-position?))
(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))]))
@ -906,17 +905,17 @@ v4 todo:
(cond
[(null? args)
(if (->d-rest-ctc ->d-stct)
(invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args '() neg-blame pos-blame src-info orig-str (not positive-position?))
(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 neg-blame pos-blame src-info orig-str (not positive-position?))
(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) neg-blame pos-blame src-info orig-str (not positive-position?))
[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)])
@ -929,12 +928,10 @@ v4 todo:
[rng-underscore? (box? (->d-range ->d-stct))])
(when (->d-pre-cond ->d-stct)
(unless (apply (->d-pre-cond ->d-stct) dep-pre-args)
(raise-contract-error val
src-info
neg-blame
orig-str
"#:pre-cond violation~a"
(build-values-string ", argument" dep-pre-args))))
(raise-blame-error (blame-swap blame)
val
"#:pre-cond violation~a"
(build-values-string ", argument" dep-pre-args))))
(call-with-immediate-continuation-mark
->d-tail-key
(λ (first-mark)
@ -956,25 +953,21 @@ v4 todo:
(->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-contract-error val
src-info
pos-blame
orig-str
"#:post-cond violation~a~a"
(build-values-string ", argument" dep-pre-args)
(build-values-string (if (null? dep-pre-args)
", result"
"\n result")
orig-results))))
(raise-blame-error blame
val
"#:post-cond 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-contract-error val
src-info
pos-blame
orig-str
"expected ~a results, got ~a"
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]
@ -985,7 +978,8 @@ v4 todo:
(cons
(invoke-dep-ctc (car result-contracts)
(if rng-underscore? #f dep-post-args)
(car results) pos-blame neg-blame src-info orig-str positive-position?)
(car results)
blame)
(loop (cdr results) (cdr result-contracts)))]))))))]
[else
(thunk)])))))])
@ -1014,11 +1008,11 @@ v4 todo:
(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 pos-blame neg-blame src-info orig-str positive-position?)
(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))])
((((proj-get ctc) ctc) pos-blame neg-blame src-info orig-str positive-position?) val)))
(((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)
@ -1090,58 +1084,60 @@ v4 todo:
name-wrapper) ;; (-> proc proc)
#:omit-define-syntaxes
#:property proj-prop ->d-proj
#:property name-prop
(λ (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)))]))])
`(->d (,@(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)
#: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)))]))])
`(->d (,@(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)
,@(if (->d-pre-cond ctc)
(list '#:pre-cond '...)
(list))
,(let ([range (->d-range ctc)])
(cond
[(not range) 'any]
[(box? range)
(let ([range (unbox range)])
(cond
,(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)
[(and (not (null? range))
(null? (cdr range)))
`[,(next-id) ...]]
[else
`(values ,@(map (λ (x) `(,(next-id) ...)) range))]))
,@(if (->d-post-cond ctc)
(list '#:post-cond '...)
(list)))))
#:property first-order-prop (λ (ctc) (λ (x) #f))
#:property stronger-prop (λ (this that) (eq? this that)))
#:first-order (λ (ctc) (λ (x) #f))
#:stronger (λ (this that) (eq? this that))))
;
@ -1249,60 +1245,59 @@ v4 todo:
;; wrapper : (->* () () (listof contract?) (-> procedure? procedure?)) -- generates a wrapper from projections
(define-struct case-> (dom-ctcs rst-ctcs rng-ctcs specs wrapper)
#:omit-define-syntaxes
#:property proj-prop
(λ (ctc)
(let* ([to-proj (λ (c) ((proj-get c) c))]
[dom-ctcs (map to-proj (get-case->-dom-ctcs ctc))]
[rng-ctcs (let ([rngs (get-case->-rng-ctcs ctc)])
(and rngs (map to-proj (get-case->-rng-ctcs ctc))))]
[rst-ctcs (case->-rst-ctcs ctc)]
[specs (case->-specs ctc)])
(λ (pos-blame neg-blame src-info orig-str positive-position?)
(let ([projs (append (map (λ (f) (f neg-blame pos-blame src-info orig-str (not positive-position?))) dom-ctcs)
(map (λ (f) (f pos-blame neg-blame src-info orig-str positive-position?)) rng-ctcs))]
[chk
(λ (val mtd?)
(cond
[(null? specs)
(unless (procedure? val)
(raise-contract-error val
src-info
pos-blame
orig-str
"expected a procedure"))]
[else
(for-each
(λ (dom-length has-rest?)
(if has-rest?
(check-procedure/more val mtd? dom-length '() '() src-info pos-blame orig-str)
(check-procedure val mtd? dom-length 0 '() '() src-info pos-blame orig-str)))
specs rst-ctcs)]))])
(apply (case->-wrapper ctc)
chk
projs)))))
#:property name-prop
(λ (ctc) (apply
build-compound-type-name
'case->
(map (λ (dom rst range)
(apply
build-compound-type-name
'->
(append dom
(if rst
(list '#:rest rst)
'())
(list
(cond
[(not range) 'any]
[(and (pair? range) (null? (cdr range)))
(car range)]
[else (apply build-compound-type-name 'values range)])))))
(case->-dom-ctcs ctc)
(case->-rst-ctcs ctc)
(case->-rng-ctcs ctc))))
#:property first-order-prop (λ (ctc) (λ (val) #f))
#:property stronger-prop (λ (this that) #f))
#:property prop:contract
(build-contract-property
#:projection
(λ (ctc)
(let* ([dom-ctcs (map contract-projection (get-case->-dom-ctcs ctc))]
[rng-ctcs (let ([rngs (get-case->-rng-ctcs ctc)])
(and rngs (map contract-projection (get-case->-rng-ctcs ctc))))]
[rst-ctcs (case->-rst-ctcs ctc)]
[specs (case->-specs ctc)])
(λ (blame)
(let ([projs (append (map (λ (f) (f (blame-swap blame))) dom-ctcs)
(map (λ (f) (f blame)) rng-ctcs))]
[chk
(λ (val mtd?)
(cond
[(null? specs)
(unless (procedure? val)
(raise-blame-error blame val "expected a procedure"))]
[else
(for-each
(λ (dom-length has-rest?)
(if has-rest?
(check-procedure/more val mtd? dom-length '() '() blame)
(check-procedure val mtd? dom-length 0 '() '() blame)))
specs rst-ctcs)]))])
(apply (case->-wrapper ctc)
chk
projs)))))
#:name
(λ (ctc)
(apply
build-compound-type-name
'case->
(map (λ (dom rst range)
(apply
build-compound-type-name
'->
(append dom
(if rst
(list '#:rest rst)
'())
(list
(cond
[(not range) 'any]
[(and (pair? range) (null? (cdr range)))
(car range)]
[else (apply build-compound-type-name 'values range)])))))
(case->-dom-ctcs ctc)
(case->-rst-ctcs ctc)
(case->-rng-ctcs ctc))))
#:first-order (λ (ctc) (λ (val) #f))
#:stronger (λ (this that) #f)))
(define (build-case-> dom-ctcs rst-ctcs rng-ctcs specs wrapper)
(make-case-> (map (λ (l) (map (λ (x) (coerce-contract 'case-> x)) l)) dom-ctcs)
@ -1459,15 +1454,13 @@ v4 todo:
(let-values ([(mandatory optional) (procedure-keywords f)])
(null? mandatory)))
(define (check-procedure val mtd? dom-length optionals mandatory-kwds optional-keywords src-info blame orig-str)
(define (check-procedure val mtd? dom-length optionals mandatory-kwds optional-keywords blame)
(unless (and (procedure? val)
(procedure-arity-includes?/optionals val (if mtd? (+ dom-length 1) dom-length) optionals)
(keywords-match mandatory-kwds optional-keywords val))
(raise-contract-error
val
src-info
(raise-blame-error
blame
orig-str
val
"expected a ~a that accepts ~a~a~a argument~a~a~a, given: ~e"
(if mtd? "method" "procedure")
(if (zero? dom-length) "no" dom-length)
@ -1522,15 +1515,13 @@ v4 todo:
", and "
(format-keywords-error 'optional optional-keywords))]))
(define (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds src-info blame orig-str)
(define (check-procedure/more val mtd? dom-length mandatory-kwds optional-kwds blame)
(unless (and (procedure? val)
(procedure-accepts-and-more? val (if mtd? (+ dom-length 1) dom-length))
(keywords-match mandatory-kwds optional-kwds val))
(raise-contract-error
val
src-info
(raise-blame-error
blame
orig-str
val
"expected a ~a that accepts ~a argument~a and arbitrarily more~a, given: ~e"
(if mtd? "method" "procedure")
(cond

74
collects/scheme/contract/private/base.ss
View File

@ -9,60 +9,50 @@ improve method arity mismatch contract violation error messages?
(provide (rename-out [-contract contract])
(provide contract
recursive-contract
current-contract-region)
(require (for-syntax scheme/base)
scheme/stxparam
unstable/srcloc
unstable/location
"guts.ss"
"helpers.ss")
"blame.ss")
(define-syntax-parameter current-contract-region (λ (stx) #'(#%variable-reference)))
(define-syntax-parameter current-contract-region
(λ (stx) #'(quote-module-path)))
(define-syntax (-contract stx)
(define-syntax (contract stx)
(syntax-case stx ()
[(_ a-contract to-check pos-blame-e neg-blame-e)
(let ([s (syntax/loc stx here)])
(quasisyntax/loc stx
(contract/proc a-contract to-check pos-blame-e neg-blame-e
(list (make-srcloc (quote-syntax #,s)
#,(syntax-line s)
#,(syntax-column s)
#,(syntax-position s)
#,(syntax-span s))
#f))))]
[(_ a-contract-e to-check pos-blame-e neg-blame-e src-info-e)
[(_ c v pos neg name loc)
(syntax/loc stx
(begin
(contract/proc a-contract-e to-check pos-blame-e neg-blame-e src-info-e)))]))
(apply-contract c v pos neg name loc))]
[(_ c v pos neg)
(syntax/loc stx
(apply-contract c v pos neg #f (build-source-location #f)))]
[(_ c v pos neg src)
(raise-syntax-error 'contract
(string-append
"please update contract application to new protocol "
"(either 4 or 6 arguments)"))]))
(define (contract/proc a-contract-raw name pos-blame neg-blame src-info)
(let ([a-contract (coerce-contract 'contract a-contract-raw)])
(unless (or (and (list? src-info)
(= 2 (length src-info))
(srcloc? (list-ref src-info 0))
(or (string? (list-ref src-info 1))
(not (list-ref src-info 1))))
(syntax? src-info))
(error 'contract "expected syntax or a list of two elements (srcloc and string or #f) as last argument, given: ~e, other args ~e ~e ~e ~e"
src-info
(unpack-blame neg-blame)
(unpack-blame pos-blame)
a-contract-raw
name))
(((contract-proc a-contract) pos-blame neg-blame src-info (contract-name a-contract) #t)
name)))
(define (apply-contract c v pos neg name loc)
(let* ([c (coerce-contract 'contract c)])
(check-source-location! 'contract loc)
(((contract-projection c)
(make-blame loc name (contract-name c) pos neg #t))
v)))
(define-syntax (recursive-contract stx)
(syntax-case stx ()
[(_ arg)
(syntax (make-proj-contract
'(recursive-contract arg)
(λ (pos-blame neg-blame src str positive-position?)
(let ([ctc (coerce-contract 'recursive-contract arg)])
(let ([proc (contract-proc ctc)])
(λ (val)
((proc pos-blame neg-blame src str positive-position?) val)))))
#f))]))
(syntax
(simple-contract
#:name '(recursive-contract arg)
#:projection
(λ (blame)
(let ([ctc (coerce-contract 'recursive-contract arg)])
(let ([f (contract-projection ctc)])
(λ (val)
((f blame) val)))))))]))

24
collects/scheme/contract/private/basic-opters.ss
View File

@ -14,18 +14,14 @@
(values
(with-syntax ((val (opt/info-val opt/info))
(ctc (opt/info-contract opt/info))
(pos (opt/info-pos opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info)))
(blame (opt/info-blame opt/info)))
(syntax (if (pred val)
val
(raise-contract-error
(raise-blame-error
blame
val
src-info
pos
orig-str
"expected <~a>, given: ~e"
((name-get ctc) ctc)
(contract-name ctc)
val))))
null
null
@ -96,20 +92,16 @@
(lift-pred (car lift-vars)))
(with-syntax ((val (opt/info-val opt/info))
(ctc (opt/info-contract opt/info))
(pos (opt/info-pos opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
(blame (opt/info-blame opt/info))
(lift-pred lift-pred))
(values
(syntax (if (lift-pred val)
val
(raise-contract-error
(raise-blame-error
blame
val
src-info
pos
orig-str
"expected <~a>, given: ~e"
((name-get ctc) ctc)
(contract-name ctc)
val)))
(interleave-lifts
lift-vars

100
collects/scheme/contract/private/blame.ss Normal file
View File

@ -0,0 +1,100 @@
#lang scheme/base
(require unstable/srcloc scheme/pretty)
(provide blame?
make-blame
blame-source
blame-positive
blame-negative
blame-contract
blame-value
blame-original?
blame-swapped?
blame-swap
raise-blame-error
current-blame-format
(struct-out exn:fail:contract:blame))
(define (blame=? a b equal?/recur)
(and (equal?/recur (blame-positive a) (blame-positive b))
(equal?/recur (blame-negative a) (blame-negative b))
(equal?/recur (blame-contract a) (blame-contract b))
(equal?/recur (blame-value a) (blame-value b))
(equal?/recur (blame-source a) (blame-source b))
(equal?/recur (blame-original? a) (blame-original? b))))
(define (blame-hash b hash/recur)
(bitwise-xor (hash/recur (blame-positive b))
(hash/recur (blame-negative b))
(hash/recur (blame-contract b))
(hash/recur (blame-value b))
(hash/recur (blame-source b))
(hash/recur (blame-original? b))))
(define-struct blame
[source value contract positive negative original?]
#:property prop:equal+hash
(list blame=? blame-hash blame-hash))
(define (blame-swap b)
(struct-copy
blame b
[original? (not (blame-original? b))]
[positive (blame-negative b)]
[negative (blame-positive b)]))
(define (blame-swapped? b)
(not (blame-original? b)))
(define-struct (exn:fail:contract:blame exn:fail:contract) [object]
#:transparent)
(define (raise-blame-error b x fmt . args)
(raise
(make-exn:fail:contract:blame
((current-blame-format) b x (apply format fmt args))
(current-continuation-marks)
b)))
(define (default-blame-format b x custom-message)
(let* ([source-message (source-location->prefix (blame-source b))]
[positive-message (show/display (blame-positive b))]
[contract-message (show/write (blame-contract b))]
[value-message (if (blame-value b)
(format " on ~a" (show/display (blame-value b)))
"")])
(format "~a~a broke the contract ~a~a; ~a"
source-message
positive-message
contract-message
value-message
custom-message)))
(define ((show f) v)
(let* ([line
(parameterize ([pretty-print-columns 'infinity])
(f v))])
(if (< (string-length line) 30)
line
(parameterize ([pretty-print-print-line show-line-break]
[pretty-print-columns 50])
(f v)))))
(define (pretty-format/display v [columns (pretty-print-columns)])
(let ([port (open-output-string)])
(pretty-display v port)
(get-output-string port)))
(define show/display (show pretty-format/display))
(define show/write (show pretty-format))
(define (show-line-break line port len cols)
(newline port)
(if line
(begin (display " " port) 2)
0))
(define current-blame-format
(make-parameter default-blame-format))

411
collects/scheme/contract/private/ds.ss
View File

@ -75,7 +75,7 @@ it around flattened out.
[struct:-name struct:-name/val]
[struct-maker struct-maker/val]
[predicate predicate/val]
[contract-name (add-suffix "-contract")]
[the-contract (add-suffix "-contract")]
[(selector-indices ...) (nums-up-to field-count/val)]
[(selector-indices+1 ...) (map add1 (nums-up-to field-count/val))]
[(ctc-x ...) (generate-temporaries (syntax (fields ...)))]
@ -214,16 +214,13 @@ it around flattened out.
(define (rewrite-fields parent contract/info ctc-x ...)
(let* ([f-x (let* ([ctc-field (contract-get (contract/info-contract contract/info)
selector-indices)]
[ctc (if (procedure? ctc-field)
(ctc-field f-xs ...)
ctc-field)]
[ctc (if (contract-struct? ctc-field)
ctc-field
(ctc-field f-xs ...))]
[ctc-field-val
((((proj-get ctc) ctc) (contract/info-pos contract/info)
(contract/info-neg contract/info)
(contract/info-src-info contract/info)
(contract/info-orig-str contract/info)
(contract/info-positive-position? contract/info))
(((contract-projection ctc)
(contract/info-blame contract/info))
ctc-x)])
(update-parent-links parent ctc-field-val)
ctc-field-val)] ...)
@ -231,22 +228,20 @@ it around flattened out.
(define (stronger-lazy-contract? a b)
(and (contract-predicate b)
(check-sub-contract?
(contract-stronger?
(contract-get a selector-indices)
(contract-get b selector-indices)) ...))
(define (lazy-contract-proj ctc)
(λ (pos-blame neg-blame src-info orig-str positive-position?)
(let ([contract/info (make-contract/info ctc pos-blame neg-blame src-info orig-str positive-position?)])
(λ (blame)
(let ([contract/info (make-contract/info ctc blame)])
(λ (val)
(unless (or (wrap-predicate val)
(opt-wrap-predicate val)
(raw-predicate val))
(raise-contract-error
(raise-blame-error
blame
val
src-info
pos-blame
orig-str
"expected <~a>, got ~e" 'name val))
(cond
[(already-there? contract/info val lazy-depth-to-look)
@ -268,10 +263,8 @@ it around flattened out.
[(wrap-predicate val)
(and (wrap-get val 0)
(let ([old-contract/info (wrap-get val 1)])
(if (and (eq? (contract/info-pos new-contract/info)
(contract/info-pos old-contract/info))
(eq? (contract/info-neg new-contract/info)
(contract/info-neg old-contract/info))
(if (and (equal? (contract/info-blame new-contract/info)
(contract/info-blame old-contract/info))
(contract-stronger? (contract/info-contract old-contract/info)
(contract/info-contract new-contract/info)))
#t
@ -286,194 +279,194 @@ it around flattened out.
(contract-maker ctc-x ... #f)))
(define (selectors x)
(burrow-in x 'selectors selector-indices)) ...
(define (burrow-in struct selector-name i)
(cond
[(raw-predicate struct)
(get struct i)]
[(opt-wrap-predicate struct)
(if (opt-wrap-get struct 0)
(do-selection struct (+ i 1))
(opt-wrap-get struct (+ i 1)))]
[(wrap-predicate struct)
(if (wrap-get struct 0)
(do-selection struct (+ i 1))
(wrap-get struct (+ i 1)))]
[else
(error selector-name "expected <~a>, got ~e" 'name struct)]))
(define (lazy-contract-name ctc)
(do-contract-name 'struct/c
'struct/dc
(list (contract-get ctc selector-indices) ...)
'(fields ...)
(contract-get ctc field-count)))
(define-values (contract-type contract-maker contract-predicate contract-get contract-set)
(make-struct-type 'contract-name
#f
(+ field-count 1) ;; extra field is for synthesized attribute ctcs
;; it is a list whose first element is
;; a procedure (called once the attrs are known) that
;; indicates if the test passes. the rest of the elements are
;; procedures that build the attrs
;; this field is #f when there is no synthesized attrs
0 ;; auto-field-k
'() ;; auto-field-v
(list (cons proj-prop lazy-contract-proj)
(cons name-prop lazy-contract-name)
(cons first-order-prop (λ (ctc) predicate))
(cons stronger-prop stronger-lazy-contract?))))
(define-for-syntax (build-enforcer opt/i opt/info name stx clauses
helper-id-var helper-info helper-freev
enforcer-id-var)
(define (make-free-vars free-vars freev)
(let loop ([i 0]
[stx null]
[free-vars free-vars])
(cond
[(null? free-vars) (reverse stx)]
[else (loop (+ i 1)
(cons (with-syntax ((var (car free-vars))
(freev freev)
(j (+ i 2)))
(syntax (var (opt-wrap-get stct j)))) stx)
(cdr free-vars))])))
(let*-values ([(inner-val) #'val]
[(clauses lifts superlifts stronger-ribs)
(build-enforcer-clauses opt/i
(opt/info-change-val inner-val opt/info)
name
stx
clauses
(list (syntax f-x) ...)
(list (list (syntax f-xs) ...) ...)
helper-id-var
helper-info
helper-freev)])
(with-syntax ([(clause (... ...)) clauses]
[enforcer-id enforcer-id-var]
[helper-id helper-id-var]
[((free-var free-var-val) (... ...))
(make-free-vars (append (opt/info-free-vars opt/info)) #'freev)]
[(saved-lifts (... ...)) (lifts-to-save lifts)])
(values
#`(λ (stct f-x ...)
(let ((free-var free-var-val) (... ...))
#,(bind-lifts
lifts
#'(let* (clause (... ...))
(values f-x ...)))))
lifts
superlifts
stronger-ribs))))
;;
;; struct/dc opter
;;
(define/opter (struct/dc opt/i opt/info stx)
(syntax-case stx ()
[(_ clause (... ...))
(let ((enforcer-id-var (car (generate-temporaries (syntax (enforcer)))))
(helper-id-var (car (generate-temporaries (syntax (helper)))))
(contract/info-var (car (generate-temporaries (syntax (contract/info)))))
(id-var (car (generate-temporaries (syntax (id))))))
(let-values ([(enforcer lifts superlifts stronger-ribs)
(build-enforcer opt/i
opt/info
'struct/dc
stx
(syntax (clause (... ...)))
helper-id-var
#'info
#'freev
enforcer-id-var)])
(let ([to-save (append (opt/info-free-vars opt/info)
(lifts-to-save lifts))])
(with-syntax ((val (opt/info-val opt/info))
(pos (opt/info-pos opt/info))
(neg (opt/info-neg opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
(ctc (opt/info-contract opt/info))
(enforcer-id enforcer-id-var)
(helper-id helper-id-var)
(contract/info contract/info-var)
(id id-var)
((j (... ...)) (let loop ([i 2]
[lst to-save])
(cond
[(null? lst) null]
[else (cons i (loop (+ i 1) (cdr lst)))])))
((free-var (... ...)) to-save))
(with-syntax ([(stronger-this-var (... ...)) (map stronger-rib-this-var stronger-ribs)]
[(stronger-that-var (... ...)) (map stronger-rib-that-var stronger-ribs)]
[(stronger-exps (... ...)) (map stronger-rib-stronger-exp stronger-ribs)]
[(stronger-indexes (... ...)) (build-list (length stronger-ribs)
(λ (x) (+ x 2)))]
[(stronger-var (... ...)) (map stronger-rib-save-id stronger-ribs)])
(let ([partials
(list (cons id-var #'(begin-lifted (box 'identity)))
(cons enforcer-id-var enforcer)
(cons contract/info-var
(syntax
(make-opt-contract/info ctc enforcer-id id))))])
(values
(syntax
(cond
[(opt-wrap-predicate val)
(if (and (opt-wrap-get val 0)
(let ([stronger-this-var stronger-var]
(... ...)
;; this computation is bogus
;; it only works if the stronger vars and the things
;; saved in the wrapper are the same
[stronger-that-var (opt-wrap-get val stronger-indexes)]
(... ...))
(and
;; make sure this is the same contract -- if not,
;; the rest of this test is bogus and may fail at runtime
(eq? id (opt-contract/info-id (opt-wrap-get val 1)))
stronger-exps (... ...))))
val
(let ([w (opt-wrap-maker val contract/info)])
(opt-wrap-set w j free-var) (... ...)
w))]
[(or (raw-predicate val)
(wrap-predicate val))
(let ([w (opt-wrap-maker val contract/info)])
(opt-wrap-set w j free-var) (... ...)
w)]
[else
(raise-contract-error
val
src-info
pos
orig-str
"expected <~a>, got ~e"
((name-get ctc) ctc)
val)]))
lifts
superlifts
partials
#f
#f
stronger-ribs)))))))]))
)))]))
(burrow-in x 'selectors selector-indices))
...
(define (burrow-in struct selector-name i)
(cond
[(raw-predicate struct)
(get struct i)]
[(opt-wrap-predicate struct)
(if (opt-wrap-get struct 0)
(do-selection struct (+ i 1))
(opt-wrap-get struct (+ i 1)))]
[(wrap-predicate struct)
(if (wrap-get struct 0)
(do-selection struct (+ i 1))
(wrap-get struct (+ i 1)))]
[else
(error selector-name "expected <~a>, got ~e" 'name struct)]))
(define (lazy-contract-name ctc)
(do-contract-name 'struct/c
'struct/dc
(list (contract-get ctc selector-indices) ...)
'(fields ...)
(contract-get ctc field-count)))
(define lazy-contract-property
(build-contract-property
#:projection lazy-contract-proj
#:name lazy-contract-name
#:first-order (lambda (ctc) predicate)
#:stronger stronger-lazy-contract?))
(define-values (contract-type contract-maker contract-predicate contract-get contract-set)
(make-struct-type 'the-contract
#f
(+ field-count 1) ;; extra field is for synthesized attribute ctcs
;; it is a list whose first element is
;; a procedure (called once the attrs are known) that
;; indicates if the test passes. the rest of the elements are
;; procedures that build the attrs
;; this field is #f when there is no synthesized attrs
0 ;; auto-field-k
'() ;; auto-field-v
(list (cons prop:contract lazy-contract-property))))
(define-for-syntax (build-enforcer opt/i opt/info name stx clauses
helper-id-var helper-info helper-freev
enforcer-id-var)
(define (make-free-vars free-vars freev)
(let loop ([i 0]
[stx null]
[free-vars free-vars])
(cond
[(null? free-vars) (reverse stx)]
[else (loop (+ i 1)
(cons (with-syntax ((var (car free-vars))
(freev freev)
(j (+ i 2)))
(syntax (var (opt-wrap-get stct j)))) stx)
(cdr free-vars))])))
(let*-values ([(inner-val) #'val]
[(clauses lifts superlifts stronger-ribs)
(build-enforcer-clauses opt/i
(opt/info-change-val inner-val opt/info)
name
stx
clauses
(list (syntax f-x) ...)
(list (list (syntax f-xs) ...) ...)
helper-id-var
helper-info
helper-freev)])
(with-syntax ([(clause (... ...)) clauses]
[enforcer-id enforcer-id-var]
[helper-id helper-id-var]
[((free-var free-var-val) (... ...))
(make-free-vars (append (opt/info-free-vars opt/info)) #'freev)]
[(saved-lifts (... ...)) (lifts-to-save lifts)])
(values
#`(λ (stct f-x ...)
(let ((free-var free-var-val) (... ...))
#,(bind-lifts
lifts
#'(let* (clause (... ...))
(values f-x ...)))))
lifts
superlifts
stronger-ribs))))
;;
;; struct/dc opter
;;
(define/opter (struct/dc opt/i opt/info stx)
(syntax-case stx ()
[(_ clause (... ...))
(let ((enforcer-id-var (car (generate-temporaries (syntax (enforcer)))))
(helper-id-var (car (generate-temporaries (syntax (helper)))))
(contract/info-var (car (generate-temporaries (syntax (contract/info)))))
(id-var (car (generate-temporaries (syntax (id))))))
(let-values ([(enforcer lifts superlifts stronger-ribs)
(build-enforcer opt/i
opt/info
'struct/dc
stx
(syntax (clause (... ...)))
helper-id-var
#'info
#'freev
enforcer-id-var)])
(let ([to-save (append (opt/info-free-vars opt/info)
(lifts-to-save lifts))])
(with-syntax ((val (opt/info-val opt/info))
(blame (opt/info-blame opt/info))
(ctc (opt/info-contract opt/info))
(enforcer-id enforcer-id-var)
(helper-id helper-id-var)
(contract/info contract/info-var)
(id id-var)
((j (... ...)) (let loop ([i 2]
[lst to-save])
(cond
[(null? lst) null]
[else (cons i (loop (+ i 1) (cdr lst)))])))
((free-var (... ...)) to-save))
(with-syntax ([(stronger-this-var (... ...)) (map stronger-rib-this-var stronger-ribs)]
[(stronger-that-var (... ...)) (map stronger-rib-that-var stronger-ribs)]
[(stronger-exps (... ...)) (map stronger-rib-stronger-exp stronger-ribs)]
[(stronger-indexes (... ...)) (build-list (length stronger-ribs)
(λ (x) (+ x 2)))]
[(stronger-var (... ...)) (map stronger-rib-save-id stronger-ribs)])
(let ([partials
(list (cons id-var #'(begin-lifted (box 'identity)))
(cons enforcer-id-var enforcer)
(cons contract/info-var
(syntax
(make-opt-contract/info ctc enforcer-id id))))])
(values
(syntax
(cond
[(opt-wrap-predicate val)
(if (and (opt-wrap-get val 0)
(let ([stronger-this-var stronger-var]
(... ...)
;; this computation is bogus
;; it only works if the stronger vars and the things
;; saved in the wrapper are the same
[stronger-that-var (opt-wrap-get val stronger-indexes)]
(... ...))
(and
;; make sure this is the same contract -- if not,
;; the rest of this test is bogus and may fail at runtime
(eq? id (opt-contract/info-id (opt-wrap-get val 1)))
stronger-exps (... ...))))
val
(let ([w (opt-wrap-maker val contract/info)])
(opt-wrap-set w j free-var) (... ...)
w))]
[(or (raw-predicate val)
(wrap-predicate val))
(let ([w (opt-wrap-maker val contract/info)])
(opt-wrap-set w j free-var) (... ...)
w)]
[else
(raise-blame-error
blame
val
"expected <~a>, got ~e"
(contract-name ctc)
val)]))
lifts
superlifts
partials
#f
#f
stronger-ribs)))))))]))
)))]))
(define (do-contract-name name/c name/dc list-of-subcontracts fields attrs)
(cond
[(and (andmap name-pred? list-of-subcontracts) (not attrs))
[(and (andmap contract-struct? list-of-subcontracts) (not attrs))
(apply build-compound-type-name name/c list-of-subcontracts)]
[else
(let ([fields
(map (λ (field ctc)
(if (name-pred? ctc)
(if (contract-struct? ctc)
(build-compound-type-name field ctc)
(build-compound-type-name field '...)))
fields
@ -489,7 +482,7 @@ it around flattened out.
(list 'and '...)))]
[else (apply build-compound-type-name name/dc fields)]))]))
(define-struct contract/info (contract pos neg src-info orig-str positive-position?))
(define-struct contract/info (contract blame))
(define-struct opt-contract/info (contract enforcer id))
;; parents : (listof wrap-parent)
@ -512,11 +505,9 @@ it around flattened out.
(define (check-synth-info-test stct synth-info contract/info)
(unless ((synth-info-test synth-info) (synth-info-vals synth-info))
(raise-contract-error
(raise-blame-error
(contract/info-blame contract/info)
stct
(contract/info-src-info contract/info)
(contract/info-pos contract/info)
(contract/info-orig-str contract/info)
"failed `and' clause, got ~e" stct)))
(define-values (evaluate-attr-prop evaluate-attr-prop-predicate evaluate-attr-prop-accessor)
@ -543,14 +534,6 @@ it around flattened out.
(define max-cache-size 5)
(define lazy-depth-to-look 5)
(define (check-sub-contract? x y)
(cond
[(and (stronger-pred? x) (stronger-pred? y))
(contract-stronger? x y)]
[(and (procedure? x) (procedure? y))
(procedure-closure-contents-eq? x y)]
[else #f]))
#|
test case:
(define-contract-struct s (a b))

415
collects/scheme/contract/private/guts.ss
View File

@ -1,17 +1,15 @@
#lang scheme/base
(require "helpers.ss"
"blame.ss"
"prop.ss"
scheme/pretty)
(require (for-syntax scheme/base
"helpers.ss"))
(provide raise-contract-error
guilty-party
exn:fail:contract2?
exn:fail:contract2-srclocs
contract-violation->string
(provide (except-out (all-from-out "blame.ss") make-blame)
(all-from-out "prop.ss")
coerce-contract
coerce-contracts
@ -34,21 +32,13 @@
contract?
contract-name
contract-proc
make-proj-contract
contract-projection
contract-stronger?
contract-first-order
contract-first-order-passes?
proj-prop proj-pred? proj-get
name-prop name-pred? name-get
stronger-prop stronger-pred? stronger-get
flat-prop flat-pred? flat-get
flat-proj
first-order-prop
first-order-get
;; for opters
check-flat-contract
check-flat-named-contract
@ -57,48 +47,26 @@
(define-syntax (any stx)
(raise-syntax-error 'any "use of 'any' outside of an arrow contract" stx))
(define-values (proj-prop proj-pred? raw-proj-get)
(make-struct-type-property 'contract-projection))
(define-values (name-prop name-pred? name-get)
(make-struct-type-property 'contract-name))
(define-values (stronger-prop stronger-pred? stronger-get)
(make-struct-type-property 'contract-stronger-than))
(define-values (flat-prop flat-pred? flat-get)
(make-struct-type-property 'contract-flat))
(define-values (first-order-prop first-order-pred? raw-first-order-get)
(make-struct-type-property 'contract-first-order))
(define (first-order-get stct)
(cond
[(flat-pred? stct) (flat-get stct)]
[else (raw-first-order-get stct)]))
(define (contract-first-order c)
(contract-struct-first-order
(coerce-contract 'contract-first-order-passes? c)))
(define (contract-first-order-passes? c v)
(let ([ctc (coerce-contract 'contract-first-order-passes? c)])
(cond
[(first-order-pred? ctc) (((first-order-get ctc) ctc) v)]
[(flat-pred? c) (((flat-get c) c) v)]
[else #t])))
(define (proj-get ctc)
(cond
[(proj-pred? ctc)
(raw-proj-get ctc)]
[else (error 'proj-get "unknown ~e" ctc)]))
((contract-struct-first-order
(coerce-contract 'contract-first-order-passes? c))
v))
;; contract-stronger? : contract contract -> boolean
;; indicates if one contract is stronger (ie, likes fewer values) than another
;; this is not a total order.
(define (contract-stronger? a b)
(let ([a-ctc (coerce-contract 'contract-stronger? a)]
[b-ctc (coerce-contract 'contract-stronger? b)])
((stronger-get a-ctc) a-ctc b-ctc)))
(contract-struct-stronger? (coerce-contract 'contract-stronger? a)
(coerce-contract 'contract-stronger? b)))
;; coerce-flat-contract : symbol any/c -> contract
(define (coerce-flat-contract name x)
(let ([ctc (coerce-contract/f x)])
(unless (flat-pred? ctc)
(unless (flat-contract-struct? ctc)
(error name
"expected a flat contract or a value that can be coerced into one, got ~e"
x))
@ -113,7 +81,7 @@
[(null? xs) '()]
[else
(let ([fst (coerce-contract/f (car xs))])
(unless (flat-pred? fst)
(unless (flat-contract-struct? fst)
(error name
"expected all of the arguments to be flat contracts, but argument ~a was not, got ~e"
i
@ -147,7 +115,7 @@
;; returns #f if the argument could not be coerced to a contract
(define (coerce-contract/f x)
(cond
[(proj-pred? x) x]
[(contract-struct? x) x]
[(and (procedure? x) (procedure-arity-includes? x 1))
(make-predicate-contract (or (object-name x) '???) x)]
[(or (symbol? x) (boolean? x) (char? x) (null? x)) (make-eq-contract x)]
@ -155,114 +123,6 @@
[(number? x) (make-=-contract x)]
[(or (regexp? x) (byte-regexp? x)) (make-regexp/c x)]
[else #f]))
(define-values (make-exn:fail:contract2
exn:fail:contract2?
exn:fail:contract2-srclocs
guilty-party)
(let-values ([(exn:fail:contract2
make-exn:fail:contract2
exn:fail:contract2?
get
set)
(parameterize ([current-inspector (make-inspector)])
(make-struct-type 'exn:fail:contract2
struct:exn:fail:contract
2
0
#f
(list (cons prop:exn:srclocs
(lambda (x)
(exn:fail:contract2-srclocs x))))))])
(values
make-exn:fail:contract2
exn:fail:contract2?
(lambda (x) (get x 0))
(lambda (x) (get x 1)))))
(define (default-contract-violation->string val src-info to-blame contract-sexp msg)
(let ([blame-src (src-info-as-string src-info)]
[formatted-contract-sexp
(let ([one-line
(let ([sp (open-output-string)])
(parameterize ([pretty-print-columns 'infinity])
(pretty-print contract-sexp sp)
(get-output-string sp)))])
(if (< (string-length one-line) 30)
one-line
(let ([sp (open-output-string)])
(newline sp)
(parameterize ([pretty-print-print-line print-contract-liner]
[pretty-print-columns 50])
(pretty-print contract-sexp sp))
(get-output-string sp))))]
[specific-blame
(cond
[(syntax? src-info)
(let ([datum (syntax->datum src-info)])
(if (symbol? datum)
(format " on ~a" datum)
""))]
[(pair? src-info)
(format " on ~a" (list-ref src-info 1))]
[else ""])])
(string-append (format "~a~a broke the contract ~a~a; "
blame-src
(cond
[(not to-blame) "<<unknown>>"]
[(and (pair? to-blame)
(pair? (cdr to-blame))
(null? (cddr to-blame))
(equal? 'quote (car to-blame)))
(format "'~s" (cadr to-blame))]
[else (format "~s" to-blame)])
formatted-contract-sexp
specific-blame)
msg)))
(define contract-violation->string (make-parameter default-contract-violation->string))
(define (raise-contract-error val src-info blame contract-sexp fmt . args)
(let ([blame (unpack-blame blame)])
(raise
(make-exn:fail:contract2
(string->immutable-string
((contract-violation->string) val
src-info
blame
contract-sexp
(apply format fmt args)))
(current-continuation-marks)
(cond
[(syntax? src-info)
(list (make-srcloc
(syntax-source src-info)
(syntax-line src-info)
(syntax-column src-info)
(syntax-position src-info)
(syntax-span src-info)))]
[(srcloc? src-info) (list src-info)]
[else '()])
(unpack-blame blame)))))
(define print-contract-liner
(let ([default (pretty-print-print-line)])
(λ (line port ol cols)
(+ (default line port ol cols)
(if line
(begin (display " " port)
2)
0)))))
;; src-info-as-string : (union srcloc syntax #f) -> string
(define (src-info-as-string src-info)
(if (or (syntax? src-info)
(srcloc? src-info))
(let ([src-loc-str (build-src-loc-string src-info)])
(if src-loc-str
(string-append src-loc-str ": ")
""))
""))
;
;
@ -281,86 +141,23 @@
;
;
;; contract = (make-contract sexp
;; (sym
;; sym
;; (union syntax #f)
;; string
;; ->
;; (alpha -> alpha)))
;; the first arg to make-contract builds the name of the contract. The
;; path records how the violation occurs
;;
;; generic contract container;
;; the first arg to proc is a symbol representing the name of the positive blame
;; the second arg to proc is the symbol representing the name of the negative blame
;; the third argument to proc is the src-info.
;; the fourth argumet is a textual representation of the original contract
;;
;; the argument to the result function is the value to test.
;; (the result function is the projection)
;;
(define (flat-proj ctc)
(let ([pred? ((flat-get ctc) ctc)])
(λ (pos neg src-info orig-str positive-position?)
(λ (val)
(if (pred? val)
val
(raise-contract-error
val
src-info
pos
orig-str
"expected <~a>, given: ~e"
((name-get ctc) ctc)
val))))))
(define (double-any-curried-proj ctc) double-any-curred-proj2)
(define (double-any-curred-proj2 pos-blame neg-blame src-info orig-str positive-position?) values)
(define-values (make-proj-contract)
(let ()
(define-struct proj-contract (the-name proj first-order-proc)
#:property proj-prop
(λ (ctc)
(let ([raw-proj (proj-contract-proj ctc)])
(if (procedure-arity-includes? raw-proj 5)
raw-proj
(λ (pos neg src-info name positive-position?)
(raw-proj pos neg src-info name)))))
#:property name-prop
(λ (ctc) (proj-contract-the-name ctc))
#:property first-order-prop
(λ (ctc) (or (proj-contract-first-order-proc ctc)
(λ (x) #t)))
#:property stronger-prop
(λ (this that)
(and (proj-contract? that)
(procedure-closure-contents-eq?
(proj-contract-proj this)
(proj-contract-proj that)))))
(values make-proj-contract)))
(define (flat-contract-predicate x)
(let ([ctc (coerce-flat-contract 'flat-contract-predicate x)])
((flat-get ctc) ctc)))
(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-pred? c))))
(flat-contract-struct? c))))
(define (contract-name ctc)
(let ([ctc (coerce-contract 'contract-name ctc)])
((name-get ctc) ctc)))
(contract-struct-name
(coerce-contract 'contract-name ctc)))
(define (contract? x) (and (coerce-contract/f x) #t))
(define (contract-proc ctc) ((proj-get ctc) ctc))
(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))
@ -385,15 +182,15 @@
'()]
[else (let ([sub (car subs)])
(cond
[(name-pred? sub)
[(contract-struct? sub)
(let ([mk-sub-name (contract-name sub)])
`(,mk-sub-name ,@(loop (cdr subs))))]
[else `(,sub ,@(loop (cdr subs)))]))])))
(define (and-proj ctc)
(let ([mk-pos-projs (map (λ (x) ((proj-get x) x)) (and/c-ctcs ctc))])
(lambda (pos neg src-info orig-str positive-position?)
(let ([projs (map (λ (c) (c pos neg src-info orig-str positive-position?)) mk-pos-projs)])
(let ([mk-pos-projs (map contract-projection (and/c-ctcs ctc))])
(lambda (blame)
(let ([projs (map (λ (c) (c blame)) mk-pos-projs)])
(let loop ([projs (cdr projs)]
[proj (car projs)])
(cond
@ -405,23 +202,24 @@
(define-struct and/c (ctcs)
#:omit-define-syntaxes
#:property proj-prop and-proj
#:property name-prop (λ (ctc) (apply build-compound-type-name 'and/c (and/c-ctcs ctc)))
#:property first-order-prop
(λ (ctc)
(let ([tests (map (λ (x) ((first-order-get x) x))
(and/c-ctcs ctc))])
(λ (x)
(andmap (λ (f) (f x)) tests))))
#:property stronger-prop
(λ (this that)
(and (and/c? that)
(let ([this-ctcs (and/c-ctcs this)]
[that-ctcs (and/c-ctcs that)])
(and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger?
this-ctcs
that-ctcs))))))
#:property prop:contract
(build-contract-property
#:projection and-proj
#:name (λ (ctc) (apply build-compound-type-name 'and/c (and/c-ctcs ctc)))
#:first-order
(λ (ctc)
(let ([tests (map contract-first-order (and/c-ctcs ctc))])
(λ (x)
(andmap (λ (f) (f x)) tests))))
#:stronger
(λ (this that)
(and (and/c? that)
(let ([this-ctcs (and/c-ctcs this)]
[that-ctcs (and/c-ctcs that)])
(and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger?
this-ctcs
that-ctcs)))))))
(define (and/c . raw-fs)
(let ([contracts (coerce-contracts 'and/c raw-fs)])
@ -441,35 +239,42 @@
(flat-named-contract (apply build-compound-type-name 'and/c contracts) pred))]
[else (make-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 proj-prop double-any-curried-proj
#:property stronger-prop (λ (this that) (any/c? that))
#:property name-prop (λ (ctc) 'any/c)
#:property first-order-prop (λ (ctc) (λ (val) #t))
#:property flat-prop (λ (ctc) (λ (x) #t)))
#: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 any/c (make-any/c))
(define (none-curried-proj ctc)
(λ (pos-blame neg-blame src-info orig-str positive-position?)
(λ (blame)
(λ (val)
(raise-contract-error
(raise-blame-error
blame
val
src-info
pos-blame
orig-str
"~s accepts no values, given: ~e"
(none/c-name ctc)
val))))
(define-struct none/c (name)
#:omit-define-syntaxes
#:property proj-prop none-curried-proj
#:property stronger-prop (λ (this that) #t)
#:property name-prop (λ (ctc) (none/c-name ctc))
#:property first-order-prop (λ (ctc) (λ (val) #f))
#:property flat-prop (λ (ctc) (λ (x) #f)))
#: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 none/c (make-none/c 'none/c))
@ -495,43 +300,63 @@
;
(define-struct eq-contract (val)
#:property proj-prop flat-proj
#:property flat-prop (λ (ctc) (λ (x) (eq? (eq-contract-val ctc) x)))
#:property name-prop (λ (ctc)
(if (symbol? (eq-contract-val ctc))
`',(eq-contract-val ctc)
(eq-contract-val ctc)))
#:property stronger-prop (λ (this that) (and (eq-contract? that) (eq? (eq-contract-val this) (eq-contract-val that)))))
#:property prop:flat-contract
(build-flat-contract-property
#:first-order (λ (ctc) (λ (x) (eq? (eq-contract-val ctc) x)))
#:name
(λ (ctc)
(if (symbol? (eq-contract-val ctc))
`',(eq-contract-val ctc)
(eq-contract-val ctc)))
#:stronger
(λ (this that)
(and (eq-contract? that)
(eq? (eq-contract-val this) (eq-contract-val that))))))
(define-struct equal-contract (val)
#:property proj-prop flat-proj
#:property flat-prop (λ (ctc) (λ (x) (equal? (equal-contract-val ctc) x)))
#:property name-prop (λ (ctc) (equal-contract-val ctc))
#:property stronger-prop (λ (this that) (and (equal-contract? that) (equal? (equal-contract-val this) (equal-contract-val that)))))
#:property prop:flat-contract
(build-flat-contract-property
#:first-order (λ (ctc) (λ (x) (equal? (equal-contract-val ctc) x)))
#:name (λ (ctc) (equal-contract-val ctc))
#:stronger
(λ (this that)
(and (equal-contract? that)
(equal? (equal-contract-val this) (equal-contract-val that))))))
(define-struct =-contract (val)
#:property proj-prop flat-proj
#:property flat-prop (λ (ctc) (λ (x) (and (number? x) (= (=-contract-val ctc) x))))
#:property name-prop (λ (ctc) (=-contract-val ctc))
#:property stronger-prop (λ (this that) (and (=-contract? that) (= (=-contract-val this) (=-contract-val that)))))
#:property prop:flat-contract
(build-flat-contract-property
#:first-order (λ (ctc) (λ (x) (and (number? x) (= (=-contract-val ctc) x))))
#:name (λ (ctc) (=-contract-val ctc))
#:stronger
(λ (this that)
(and (=-contract? that)
(= (=-contract-val this) (=-contract-val that))))))
(define-struct regexp/c (reg)
#:property proj-prop flat-proj
#:property flat-prop (λ (ctc) (λ (x) (and (or (string? x) (bytes? x))
(regexp-match (regexp/c-reg ctc) x)
#t)))
#:property name-prop (λ (ctc) (regexp/c-reg ctc))
#:property stronger-prop (λ (this that) (and (regexp/c? that) (eq? (regexp/c-reg this) (regexp/c-reg that)))))
#:property prop:flat-contract
(build-flat-contract-property
#:first-order
(λ (ctc)
(λ (x)
(and (or (string? x) (bytes? x))
(regexp-match (regexp/c-reg ctc) x)
#t)))
#:name (λ (ctc) (regexp/c-reg ctc))
#:stronger
(λ (this that)
(and (regexp/c? that) (eq? (regexp/c-reg this) (regexp/c-reg that))))))
(define-struct predicate-contract (name pred)
#:property proj-prop flat-proj
#:property stronger-prop
(λ (this that)
(and (predicate-contract? that)
(procedure-closure-contents-eq? (predicate-contract-pred this)
(predicate-contract-pred that))))
#:property name-prop (λ (ctc) (predicate-contract-name ctc))
#:property flat-prop (λ (ctc) (predicate-contract-pred ctc)))
#:property prop:flat-contract
(build-flat-contract-property
#:stronger
(λ (this that)
(and (predicate-contract? that)
(procedure-closure-contents-eq? (predicate-contract-pred this)
(predicate-contract-pred that))))
#:name (λ (ctc) (predicate-contract-name ctc))
#:first-order (λ (ctc) (predicate-contract-pred ctc))))
(define (build-flat-contract name pred) (make-predicate-contract name pred))

40
collects/scheme/contract/private/helpers.ss
View File

@ -1,7 +1,6 @@
#lang scheme/base
(provide unpack-blame build-src-loc-string
mangle-id mangle-id-for-maker
(provide mangle-id mangle-id-for-maker
build-struct-names
lookup-struct-info
nums-up-to
@ -109,14 +108,18 @@
(syntax-line stx)
(syntax-column stx)
(syntax-position stx))
(values (source->name
(resolved-module-path-name
(module-path-index-resolve
(syntax-source-module
(srcloc-source stx)))))
(srcloc-line stx)
(srcloc-column stx)
(srcloc-position stx)))])
(if (syntax? (srcloc-source stx))
(values (source->name
(resolved-module-path-name
(module-path-index-resolve
(syntax-source-module
(srcloc-source stx)))))
(srcloc-line stx)
(srcloc-column stx)
(srcloc-position stx))
(error 'contract
"malformed srcloc has non-syntax source: ~e"
stx)))])
(let ([location (cond [(and line col) (format "~a:~a" line col)]
[pos (format "~a" pos)]
[else #f])])
@ -124,23 +127,6 @@
(string-append source ":" location)
(or location source)))))
;; unpack-blame : any/c -> any/c
;; Constructs an S-expression for use in the blame error messages.
;; A variable reference represents a module or top-level context.
;; Other representations of blame are returned as-is.
(define (unpack-blame blame)
(if (variable-reference? blame)
(let ([rp (variable-reference->resolved-module-path blame)])
(cond
[(not rp)
'top-level]
[else
(let ([resolved (resolved-module-path-name rp)])
(cond
[(symbol? resolved) `(quote ,resolved)]
[else `(file ,(path->string resolved))]))]))
blame))
(define build-struct-names
(lambda (name-stx fields omit-sel? omit-set? srcloc-stx)
(let ([name (symbol->string (syntax-e name-stx))]

136
collects/scheme/contract/private/legacy.ss Normal file
View File

@ -0,0 +1,136 @@
#lang scheme/base
(require "guts.ss" "blame.ss" unstable/srcloc)
(provide make-proj-contract
raise-contract-error
contract-proc
proj-prop proj-get proj-pred?
name-prop name-get name-pred?
stronger-prop stronger-get stronger-pred?
first-order-prop first-order-get first-order-pred?
flat-prop flat-get flat-pred?
)
(define (raise-contract-error x src pos name fmt . args)
(apply raise-blame-error
(make-blame (unpack-source src)
(unpack-name src)
name
(unpack-blame pos)
"<<unknown party>>"
#t)
x
fmt
args))
(define (make-proj-contract name proj test)
(simple-contract
#:name name
#:first-order test
#:projection
(cond
[(procedure-arity-includes? proj 5)
(lambda (blame)
(proj (blame-positive blame)
(blame-negative blame)
(list (blame-source blame) (blame-value blame))
(blame-contract blame)
(not (blame-swapped? blame))))]
[(procedure-arity-includes? proj 4)
(lambda (blame)
(proj (blame-positive blame)
(blame-negative blame)
(list (blame-source blame) (blame-value blame))
(blame-contract blame)))]
[else
(error 'make-proj-contract
"expected a projection that accepts 4 or 5 arguments; got: ~e"
proj)])))
(define (contract-proc c)
(let* ([proj (contract-projection c)])
(lambda (pos neg src name [original? #t])
(proj (make-blame (unpack-source src)
(unpack-name src)
name
(unpack-blame (if original? pos neg))
(unpack-blame (if original? neg pos))
original?)))))
(define (legacy-property name)
(define-values [ prop pred get ]
(make-struct-type-property
name
(lambda (impl info)
(error
name
(string-append
"this property is a legacy implementation; "
"use prop:contract or prop:flat-contract instead.")))))
prop)
(define proj-prop (legacy-property 'proj-prop))
(define name-prop (legacy-property 'name-prop))
(define stronger-prop (legacy-property 'stronger-prop))
(define first-order-prop (legacy-property 'first-order-prop))
(define flat-prop (legacy-property 'flat-prop))
(define proj-pred? contract-struct?)
(define name-pred? contract-struct?)
(define stronger-pred? contract-struct?)
(define first-order-pred? contract-struct?)
(define flat-pred? contract-struct?)
(define (proj-get c) contract-proc)
(define (name-get c) contract-name)
(define (stronger-get c) contract-stronger?)
(define (first-order-get c) contract-first-order)
(define (flat-get c) flat-contract-predicate)
;; unpack-blame : any/c -> any/c
;; Constructs an S-expression for use in the blame error messages.
;; A variable reference represents a module or top-level context.
;; Other representations of blame are returned as-is.
(define (unpack-blame blame)
(if (variable-reference? blame)
(let ([rp (variable-reference->resolved-module-path blame)])
(cond
[(not rp)
'top-level]
[else
(let ([resolved (resolved-module-path-name rp)])
(cond
[(symbol? resolved) `(quote ,resolved)]
[else `(file ,(path->string resolved))]))]))
blame))
(define (unpack-source info)
(cond
[(syntax? info) (build-source-location info)]
[(list? info)
(let ([loc (list-ref info 0)])
(if (syntax? (srcloc-source loc))
(struct-copy
srcloc loc
[source
(resolved-module-path-name
(module-path-index-resolve
(syntax-source-module
(srcloc-source loc))))])
loc))]
[else
(error 'contract
"expected a syntax object or list of two elements, got: ~e"
info)]))
(define (unpack-name info)
(cond
[(syntax? info) (and (identifier? info) (syntax-e info))]
[(list? info) (list-ref info 1)]
[else
(error 'contract
"expected a syntax object or list of two elements, got: ~e"
info)]))

644
collects/scheme/contract/private/misc.ss
View File

@ -126,51 +126,53 @@
(define-struct or/c (pred flat-ctcs ho-ctc)
#:omit-define-syntaxes
#:property proj-prop
(λ (ctc)
(let ([c-proc ((proj-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))]
[pred (or/c-pred ctc)])
(λ (pos-blame neg-blame src-info orig-str positive-position?)
(let ([partial-contract (c-proc pos-blame neg-blame src-info orig-str positive-position?)])
(λ (val)
(cond
[(pred val) val]
[else
(partial-contract val)]))))))
#:property name-prop
(λ (ctc)
(apply build-compound-type-name
'or/c
(or/c-ho-ctc ctc)
(or/c-flat-ctcs ctc)))
#:property first-order-prop
(λ (ctc)
(let ([pred (or/c-pred ctc)]
[ho ((first-order-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))])
(λ (x)
(or (ho x)
(pred x)))))
#:property stronger-prop
(λ (this that)
(and (or/c? that)
(contract-stronger? (or/c-ho-ctc this) (or/c-ho-ctc that))
(let ([this-ctcs (or/c-flat-ctcs this)]
[that-ctcs (or/c-flat-ctcs that)])
(and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger?
this-ctcs
that-ctcs))))))
#:property prop:contract
(build-contract-property
#:projection
(λ (ctc)
(let ([c-proc (contract-projection (or/c-ho-ctc ctc))]
[pred (or/c-pred ctc)])
(λ (blame)
(let ([partial-contract (c-proc blame)])
(λ (val)
(cond
[(pred val) val]
[else
(partial-contract val)]))))))
#:name
(λ (ctc)
(apply build-compound-type-name
'or/c
(or/c-ho-ctc ctc)
(or/c-flat-ctcs ctc)))
#:first-order
(λ (ctc)
(let ([pred (or/c-pred ctc)]
[ho (contract-first-order (or/c-ho-ctc ctc))])
(λ (x)
(or (ho x)
(pred x)))))
#:stronger
(λ (this that)
(and (or/c? that)
(contract-stronger? (or/c-ho-ctc this) (or/c-ho-ctc that))
(let ([this-ctcs (or/c-flat-ctcs this)]
[that-ctcs (or/c-flat-ctcs that)])
(and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger?
this-ctcs
that-ctcs)))))))
(define (multi-or/c-proj ctc)
(let* ([ho-contracts (multi-or/c-ho-ctcs ctc)]
[c-procs (map (λ (x) ((proj-get x) x)) ho-contracts)]
[first-order-checks (map (λ (x) ((first-order-get x) x)) ho-contracts)]
[c-procs (map (λ (x) (contract-projection x)) ho-contracts)]
[first-order-checks (map (λ (x) (contract-first-order x)) ho-contracts)]
[predicates (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))])
(λ (pos-blame neg-blame src-info orig-str positive-position?)
(let ([partial-contracts (map (λ (c-proc) (c-proc pos-blame neg-blame src-info orig-str positive-position?)) c-procs)])
(λ (blame)
(let ([partial-contracts (map (λ (c-proc) (c-proc blame)) c-procs)])
(λ (val)
(cond
[(ormap (λ (pred) (pred val)) predicates)
@ -185,16 +187,16 @@
[(null? checks)
(if candidate-proc
(candidate-proc val)
(raise-contract-error val src-info pos-blame orig-str
"none of the branches of the or/c matched, given ~e"
val))]
(raise-blame-error blame val
"none of the branches of the or/c matched, given ~e"
val))]
[((car checks) val)
(if candidate-proc
(raise-contract-error val src-info pos-blame orig-str
"two of the clauses in the or/c might both match: ~s and ~s, given ~e"
(contract-name candidate-contract)
(contract-name (car contracts))
val)
(raise-blame-error blame val
"two of the clauses in the or/c might both match: ~s and ~s, given ~e"
(contract-name candidate-contract)
(contract-name (car contracts))
val)
(loop (cdr checks)
(cdr procs)
(cdr contracts)
@ -208,58 +210,61 @@
candidate-contract)]))]))))))
(define-struct multi-or/c (flat-ctcs ho-ctcs)
#:property proj-prop multi-or/c-proj
#:property name-prop
(λ (ctc)
(apply build-compound-type-name
'or/c
(append
(multi-or/c-flat-ctcs ctc)
(reverse (multi-or/c-ho-ctcs ctc)))))
#:property first-order-prop
(λ (ctc)
(let ([flats (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))]
[hos (map (λ (x) ((first-order-get x) x)) (multi-or/c-ho-ctcs ctc))])
(λ (x)
(or (ormap (λ (f) (f x)) hos)
(ormap (λ (f) (f x)) flats)))))
#:property stronger-prop
(λ (this that)
(and (multi-or/c? that)
(let ([this-ctcs (multi-or/c-ho-ctcs this)]
[that-ctcs (multi-or/c-ho-ctcs that)])
(and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger?
this-ctcs
that-ctcs)))
(let ([this-ctcs (multi-or/c-flat-ctcs this)]
[that-ctcs (multi-or/c-flat-ctcs that)])
(and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger?
this-ctcs
that-ctcs))))))
#:property prop:contract
(build-contract-property
#:projection multi-or/c-proj
#:name
(λ (ctc)
(apply build-compound-type-name
'or/c
(append
(multi-or/c-flat-ctcs ctc)
(reverse (multi-or/c-ho-ctcs ctc)))))
#:first-order
(λ (ctc)
(let ([flats (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))]
[hos (map (λ (x) (contract-first-order x)) (multi-or/c-ho-ctcs ctc))])
(λ (x)
(or (ormap (λ (f) (f x)) hos)
(ormap (λ (f) (f x)) flats)))))
#:stronger
(λ (this that)
(and (multi-or/c? that)
(let ([this-ctcs (multi-or/c-ho-ctcs this)]
[that-ctcs (multi-or/c-ho-ctcs that)])
(and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger?
this-ctcs
that-ctcs)))
(let ([this-ctcs (multi-or/c-flat-ctcs this)]
[that-ctcs (multi-or/c-flat-ctcs that)])
(and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger?
this-ctcs
that-ctcs)))))))
(define-struct flat-or/c (pred flat-ctcs)
#:property proj-prop flat-proj
#:property name-prop
(λ (ctc)
(apply build-compound-type-name
'or/c
(flat-or/c-flat-ctcs ctc)))
#:property stronger-prop
(λ (this that)
(and (flat-or/c? that)
(let ([this-ctcs (flat-or/c-flat-ctcs this)]
[that-ctcs (flat-or/c-flat-ctcs that)])
(and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger?
this-ctcs
that-ctcs)))))
#:property prop:flat-contract
(build-flat-contract-property
#:name
(λ (ctc)
(apply build-compound-type-name
'or/c
(flat-or/c-flat-ctcs ctc)))
#:stronger
(λ (this that)
(and (flat-or/c? that)
(let ([this-ctcs (flat-or/c-flat-ctcs this)]
[that-ctcs (flat-or/c-flat-ctcs that)])
(and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger?
this-ctcs
that-ctcs)))))
#:property flat-prop
(λ (ctc) (flat-or/c-pred ctc)))
#:first-order
(λ (ctc) (flat-or/c-pred ctc))))
;;
;; or/c opter
@ -283,12 +288,8 @@
(list (cons
partial-var
(with-syntax ((lift-var lift-var)
(pos (opt/info-pos opt/info))
(neg (opt/info-neg opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
(positive-position? (opt/info-orig-str opt/info)))
(syntax (((proj-get lift-var) lift-var) pos neg src-info orig-str positive-position?)))))
(blame (opt/info-blame opt/info)))
(syntax ((contract-projection lift-var) blame)))))
#f
lift-var
(list #f)
@ -351,14 +352,13 @@
(cond
[(null? hos)
(with-syntax ([val (opt/info-val opt/info)]
[pos (opt/info-pos opt/info)]
[src-info (opt/info-src-info opt/info)]
[orig-str (opt/info-orig-str opt/info)])
[blame (opt/info-blame opt/info)])
(syntax
(if next-ps
val
(raise-contract-error val src-info pos orig-str
"none of the branches of the or/c matched"))))]
(raise-blame-error blame
val
"none of the branches of the or/c matched"))))]
[(= (length hos) 1) (with-syntax ((ho-ctc ho-ctc))
(syntax
(if next-ps val ho-ctc)))]
@ -435,30 +435,31 @@
(define-struct one-of/c (elems)
#:omit-define-syntaxes
#:property proj-prop flat-proj
#:property name-prop
(λ (ctc)
(let ([elems (one-of/c-elems ctc)])
`(,(cond
[(andmap symbol? elems)
'symbols]
[else
'one-of/c])
,@(map one-of-pc elems))))
#:property stronger-prop
(λ (this that)
(and (one-of/c? that)
(let ([this-elems (one-of/c-elems this)]
[that-elems (one-of/c-elems that)])
(and
(andmap (λ (this-elem) (memv this-elem that-elems))
this-elems)
#t))))
#:property flat-prop
(λ (ctc)
(let ([elems (one-of/c-elems ctc)])
(λ (x) (memv x elems)))))
#:property prop:flat-contract
(build-flat-contract-property
#:name
(λ (ctc)
(let ([elems (one-of/c-elems ctc)])
`(,(cond
[(andmap symbol? elems)
'symbols]
[else
'one-of/c])
,@(map one-of-pc elems))))
#:stronger
(λ (this that)
(and (one-of/c? that)
(let ([this-elems (one-of/c-elems this)]
[that-elems (one-of/c-elems that)])
(and
(andmap (λ (this-elem) (memv this-elem that-elems))
this-elems)
#t))))
#:first-order
(λ (ctc)
(let ([elems (one-of/c-elems ctc)])
(λ (x) (memv x elems))))))
(define printable/c
(flat-named-contract
@ -484,30 +485,31 @@
(define-struct between/c (low high)
#:omit-define-syntaxes
#:property proj-prop flat-proj
#:property name-prop
(λ (ctc)
(let ([n (between/c-low ctc)]
[m (between/c-high ctc)])
(cond
[(= n -inf.0) `(<=/c ,m)]
[(= m +inf.0) `(>=/c ,n)]
[(= n m) `(=/c ,n)]
[else `(between/c ,n ,m)])))
#:property prop:flat-contract
(build-flat-contract-property
#:name
(λ (ctc)
(let ([n (between/c-low ctc)]
[m (between/c-high ctc)])
(cond
[(= n -inf.0) `(<=/c ,m)]
[(= m +inf.0) `(>=/c ,n)]
[(= n m) `(=/c ,n)]
[else `(between/c ,n ,m)])))
#:property stronger-prop
(λ (this that)
(and (between/c? that)
(<= (between/c-low that) (between/c-low this))
(<= (between/c-high this) (between/c-high that))))
#:property flat-prop
(λ (ctc)
(let ([n (between/c-low ctc)]
[m (between/c-high ctc)])
(λ (x)
(and (real? x)
(<= n x m))))))
#:stronger
(λ (this that)
(and (between/c? that)
(<= (between/c-low that) (between/c-low this))
(<= (between/c-high this) (between/c-high that))))
#:first-order
(λ (ctc)
(let ([n (between/c-low ctc)]
[m (between/c-high ctc)])
(λ (x)
(and (real? x)
(<= n x m)))))))
(define-syntax (check-unary-between/c stx)
(syntax-case stx ()
@ -556,21 +558,17 @@
(let ([lifts3 (lift/effect #'(check-between/c n m) lifts2)])
(with-syntax ((val (opt/info-val opt/info))
(ctc (opt/info-contract opt/info))
(pos (opt/info-pos opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
(blame (opt/info-blame opt/info))
(this (opt/info-this opt/info))
(that (opt/info-that opt/info)))
(values
(syntax (if (and (number? val) (<= n val m))
val
(raise-contract-error
(raise-blame-error
blame
val
src-info
pos
orig-str
"expected <~a>, given: ~e"
((name-get ctc) ctc)
(contract-name ctc)
val)))
lifts3
null
@ -597,22 +595,18 @@
(let ([lifts3 (lift/effect (check-arg #'m) lifts2)])
(with-syntax ((val (opt/info-val opt/info))
(ctc (opt/info-contract opt/info))
(pos (opt/info-pos opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
(blame (opt/info-blame opt/info))
(this (opt/info-this opt/info))
(that (opt/info-that opt/info)))
(values
(syntax
(if (and (real? val) (comparison val m))
val
(raise-contract-error
(raise-blame-error
blame
val
src-info
pos
orig-str
"expected <~a>, given: ~e"
((name-get ctc) ctc)
(contract-name ctc)
val)))
lifts3
null
@ -731,23 +725,22 @@
(build-flat-contract
`(name ,(contract-name ctc))
(lambda (x) (and (predicate? x) (testmap content-pred? x)))))
(let ([proj (contract-proc ctc)])
(make-proj-contract
(build-compound-type-name 'name ctc)
(λ (pos-blame neg-blame src-info orig-str positive-position?)
(let ([p-app (proj pos-blame neg-blame src-info orig-str positive-position?)])
(let ([proj (contract-projection ctc)])
(simple-contract
#:name (build-compound-type-name 'name ctc)
#:projection
(λ (blame)
(let ([p-app (proj blame)])
(λ (val)
(unless (predicate? val)
(raise-contract-error
(raise-blame-error
blame
val
src-info
pos-blame
orig-str
"expected <~a>, given: ~e"
'type-name
val))
(fill-name p-app val))))
predicate?)))))))]))
#:first-order predicate?)))))))]))
(define listof
(*-immutableof list? map andmap list listof))
@ -816,18 +809,14 @@
(values
(with-syntax ((val (opt/info-val opt/info))
(ctc (opt/info-contract opt/info))
(pos (opt/info-pos opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info)))
(blame (opt/info-blame opt/info)))
(syntax (if next
val
(raise-contract-error
(raise-blame-error
blame
val
src-info
pos
orig-str
"expected <~a>, given: ~e"
((name-get ctc) ctc)
(contract-name ctc)
val))))
(append
lifts-hdp lifts-tlp
@ -894,28 +883,26 @@
(and (predicate?-name x)
(p-apps (selector-names x))
...))))
(let ([procs (contract-proc ctc-x)] ...)
(make-proj-contract
(build-compound-type-name 'name ctc-x ...)
(λ (pos-blame neg-blame src-info orig-str positive-position?)
(let ([p-apps (procs pos-blame neg-blame src-info orig-str positive-position?)] ...)
(let ([procs (contract-projection ctc-x)] ...)
(simple-contract
#:name (build-compound-type-name 'name ctc-x ...)
#:projection
(λ (blame)
(let ([p-apps (procs blame)] ...)
(λ (v)
(if #,(if test-immutable?
#'(and (predicate?-name v)
(immutable? v))
#'(predicate?-name v))
(constructor-name (p-apps (selector-names v)) ...)
(raise-contract-error
(raise-blame-error
blame
v
src-info
pos-blame
orig-str
#,(if test-immutable?
"expected immutable <~a>, given: ~e"
"expected <~a>, given: ~e")
'type-name
v)))))
#f))))))))]
v)))))))))))))]
[(_ predicate? constructor (arb? selector) correct-size type-name name)
(eq? #t (syntax->datum (syntax arb?)))
(syntax
@ -924,11 +911,12 @@
[selector-name selector])
(λ params
(let ([ctcs (map (λ (param) (coerce-contract 'name param)) params)])
(let ([procs (map contract-proc ctcs)])
(make-proj-contract
(apply build-compound-type-name 'name ctcs)
(λ (pos-blame neg-blame src-info orig-str positive-position?)
(let ([p-apps (map (λ (proc) (proc pos-blame neg-blame src-info orig-str positive-position?)) procs)]
(let ([procs (map contract-projection ctcs)])
(simple-contract
#:name (apply build-compound-type-name 'name ctcs)
#:projection
(λ (blame)
(let ([p-apps (map (λ (proc) (proc blame)) procs)]
[count (length params)])
(λ (v)
(if (and (immutable? v)
@ -942,15 +930,12 @@
[else (let ([p-app (car p-apps)])
(cons (p-app (selector-name v i))
(loop (cdr p-apps) (+ i 1))))])))
(raise-contract-error
(raise-blame-error
blame
v
src-info
pos-blame
orig-str
"expected <~a>, given: ~e"
'type-name
v)))))
#f))))))]))
v)))))))))))]))
(define cons/c (*-immutable/c pair? cons (#f car cdr) cons cons/c #f))
(define box-immutable/c (*-immutable/c box? box-immutable (#f unbox) immutable-box box-immutable/c))
@ -975,21 +960,17 @@
(values
(with-syntax ((val (opt/info-val opt/info))
(ctc (opt/info-contract opt/info))
(pos (opt/info-pos opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
(blame (opt/info-blame opt/info))
(next-hdp next-hdp)
(next-tlp next-tlp))
(syntax (if check
(cons (let ((val (car val))) next-hdp)
(let ((val (cdr val))) next-tlp))
(raise-contract-error
(raise-blame-error
blame
val
src-info
pos
orig-str
"expected <~a>, given: ~e"
((name-get ctc) ctc)
(contract-name ctc)
val))))
(append lifts-hdp lifts-tlp)
(append superlifts-hdp superlifts-tlp)
@ -1026,23 +1007,21 @@
(define promise/c
(λ (ctc-in)
(let* ([ctc (coerce-contract 'promise/c ctc-in)]
[ctc-proc (contract-proc ctc)])
(make-proj-contract
(build-compound-type-name 'promise/c ctc)
(λ (pos-blame neg-blame src-info orig-str positive-position?)
(let ([p-app (ctc-proc pos-blame neg-blame src-info orig-str positive-position?)])
[ctc-proc (contract-projection ctc)])
(simple-contract
#:name (build-compound-type-name 'promise/c ctc)
#:projection
(λ (blame)
(let ([p-app (ctc-proc blame)])
(λ (val)
(unless (promise? val)
(raise-contract-error
(raise-blame-error
blame
val
src-info
pos-blame
'ignored
orig-str
"expected <promise>, given: ~e"
val))
(delay (p-app (force val))))))
promise?))))
#:first-order promise?))))
#|
as with copy-struct in struct.ss, this first begin0
@ -1117,40 +1096,42 @@
(define-struct parameter/c (ctc)
#:omit-define-syntaxes
#:property proj-prop
(λ (ctc)
(let ([c-proc ((proj-get (parameter/c-ctc ctc)) (parameter/c-ctc ctc))])
(λ (pos-blame neg-blame src-info orig-str positive-position?)
(let ([partial-neg-contract (c-proc neg-blame pos-blame src-info orig-str (not positive-position?))]
[partial-pos-contract (c-proc pos-blame neg-blame src-info orig-str positive-position?)])
(λ (val)
(cond
[(parameter? val)
(make-derived-parameter
val
partial-neg-contract
partial-pos-contract)]
[else
(raise-contract-error val src-info pos-blame orig-str
"expected a parameter")]))))))
#:property name-prop (λ (ctc) (build-compound-type-name 'parameter/c (parameter/c-ctc ctc)))
#:property first-order-prop
(λ (ctc)
(let ([tst ((first-order-get (parameter/c-ctc ctc)) (parameter/c-ctc ctc))])
(λ (x)
(and (parameter? x)
(tst (x))))))
#:property stronger-prop
(λ (this that)
;; must be invariant (because the library doesn't currently split out pos/neg contracts
;; which could be tested individually ....)
(and (parameter/c? that)
(contract-stronger? (parameter/c-ctc this)
(parameter/c-ctc that))
(contract-stronger? (parameter/c-ctc that)
(parameter/c-ctc this)))))
#:property prop:contract
(build-contract-property
#:projection
(λ (ctc)
(let ([c-proc (contract-projection (parameter/c-ctc ctc))])
(λ (blame)
(let ([partial-neg-contract (c-proc (blame-swap blame))]
[partial-pos-contract (c-proc blame)])
(λ (val)
(cond
[(parameter? val)
(make-derived-parameter
val
partial-neg-contract
partial-pos-contract)]
[else
(raise-blame-error blame val "expected a parameter")]))))))
#:name
(λ (ctc) (build-compound-type-name 'parameter/c (parameter/c-ctc ctc)))
#:first-order
(λ (ctc)
(let ([tst (contract-first-order (parameter/c-ctc ctc))])
(λ (x)
(and (parameter? x)
(tst (x))))))
#:stronger
(λ (this that)
;; must be invariant (because the library doesn't currently split out pos/neg contracts
;; which could be tested individually ....)
(and (parameter/c? that)
(contract-stronger? (parameter/c-ctc this)
(parameter/c-ctc that))
(contract-stronger? (parameter/c-ctc that)
(parameter/c-ctc this))))))
(define (hash/c dom rng #:immutable [immutable 'dont-care])
(unless (memq immutable '(#t #f dont-care))
@ -1166,8 +1147,8 @@
;; hash-test : hash/c -> any -> bool
(define (hash-test ctc)
(let ([dom-proc ((flat-get (hash/c-dom ctc)) (hash/c-dom ctc))]
[rng-proc ((flat-get (hash/c-rng ctc)) (hash/c-rng ctc))]
(let ([dom-proc (flat-contract-predicate (hash/c-dom ctc))]
[rng-proc (flat-contract-predicate (hash/c-rng ctc))]
[immutable (hash/c-immutable ctc)])
(λ (val)
(and (hash? val)
@ -1186,72 +1167,71 @@
(define-struct hash/c (dom rng immutable)
#:omit-define-syntaxes
#:property flat-prop hash-test
#:property proj-prop
(λ (ctc)
(let ([dom-proc ((proj-get (hash/c-dom ctc)) (hash/c-dom ctc))]
[rng-proc ((proj-get (hash/c-rng ctc)) (hash/c-rng ctc))]
[immutable (hash/c-immutable ctc)])
(λ (pos-blame neg-blame src-info orig-str positive-position?)
(let ([partial-dom-contract (dom-proc pos-blame neg-blame src-info orig-str positive-position?)]
[partial-rng-contract (rng-proc pos-blame neg-blame src-info orig-str positive-position?)])
(λ (val)
(unless (hash? val)
(raise-contract-error val src-info pos-blame orig-str
"expected a hash, got ~a" val))
(case immutable
[(#t) (unless (immutable? val)
(raise-contract-error val src-info pos-blame orig-str
"expected an immutable hash, got ~a" val))]
[(#f) (when (immutable? val)
(raise-contract-error val src-info pos-blame orig-str
"expected a mutable hash, got ~a" val))]
[(dont-care) (void)])
(hash-for-each
val
(λ (key val)
(partial-dom-contract key)
(partial-rng-contract val)))
val)))))
#:property name-prop (λ (ctc) (apply
build-compound-type-name
'hash/c (hash/c-dom ctc) (hash/c-rng ctc)
(if (eq? 'dont-care (hash/c-immutable ctc))
'()
(list '#:immutable (hash/c-immutable ctc)))))
#:property stronger-prop
(λ (this that)
#f))
#:property prop:flat-contract
(build-flat-contract-property
#:first-order hash-test
#:projection
(λ (ctc)
(let ([dom-proc (contract-projection (hash/c-dom ctc))]
[rng-proc (contract-projection (hash/c-rng ctc))]
[immutable (hash/c-immutable ctc)])
(λ (blame)
(let ([partial-dom-contract (dom-proc blame)]
[partial-rng-contract (rng-proc blame)])
(λ (val)
(unless (hash? val)
(raise-blame-error blame val "expected a hash, got ~a" val))
(case immutable
[(#t) (unless (immutable? val)
(raise-blame-error blame val
"expected an immutable hash, got ~a" val))]
[(#f) (when (immutable? val)
(raise-blame-error blame val
"expected a mutable hash, got ~a" val))]
[(dont-care) (void)])
(hash-for-each
val
(λ (key val)
(partial-dom-contract key)
(partial-rng-contract val)))
val)))))
#:name
(λ (ctc) (apply
build-compound-type-name
'hash/c (hash/c-dom ctc) (hash/c-rng ctc)
(if (eq? 'dont-care (hash/c-immutable ctc))
'()
(list '#:immutable (hash/c-immutable ctc)))))))
(define-struct immutable-hash/c (dom rng)
#:omit-define-syntaxes
#:property first-order-prop (λ (ctc) (λ (val) (and (hash? val) (immutable? val))))
#:property proj-prop
(λ (ctc)
(let ([dom-proc ((proj-get (immutable-hash/c-dom ctc)) (immutable-hash/c-dom ctc))]
[rng-proc ((proj-get (immutable-hash/c-rng ctc)) (immutable-hash/c-rng ctc))])
(λ (pos-blame neg-blame src-info orig-str positive-position?)
(let ([partial-dom-contract (dom-proc pos-blame neg-blame src-info orig-str positive-position?)]
[partial-rng-contract (rng-proc pos-blame neg-blame src-info orig-str positive-position?)])
(λ (val)
(unless (and (hash? val)
(immutable? val))
(raise-contract-error val src-info pos-blame orig-str
"expected an immutable hash"))
(make-immutable-hash
(hash-map
val
(λ (k v)
(cons (partial-dom-contract k)
(partial-rng-contract v))))))))))
#:property name-prop (λ (ctc) (build-compound-type-name
'hash/c (immutable-hash/c-dom ctc) (immutable-hash/c-rng ctc)
'#:immutable #t))
#:property stronger-prop
(λ (this that)
#f))
#:property prop:contract
(build-contract-property
#:first-order (λ (ctc) (λ (val) (and (hash? val) (immutable? val))))
#:projection
(λ (ctc)
(let ([dom-proc (contract-projection (immutable-hash/c-dom ctc))]
[rng-proc (contract-projection (immutable-hash/c-rng ctc))])
(λ (blame)
(let ([partial-dom-contract (dom-proc blame)]
[partial-rng-contract (rng-proc blame)])
(λ (val)
(unless (and (hash? val)
(immutable? val))
(raise-blame-error blame val
"expected an immutable hash"))
(make-immutable-hash
(hash-map
val
(λ (k v)
(cons (partial-dom-contract k)
(partial-rng-contract v))))))))))
#:name
(λ (ctc) (build-compound-type-name
'hash/c (immutable-hash/c-dom ctc) (immutable-hash/c-rng ctc)
'#:immutable #t))))

114
collects/scheme/contract/private/object.ss
View File

@ -17,8 +17,10 @@
#;
(let* ([cm (syntax-parameterize ((making-a-method #t)) (-> any/c integer? integer?))]
[cf (-> integer? integer?)]
[m-proj (((proj-get cm) cm) 'pos 'neg #'here "whatever" some-boolean)]
[f-proj (((proj-get cf) cf) 'pos 'neg #'here "whatever" some-boolean)]
[m-proj ((contract-projection cm)
(make-blame #'here #f "whatever" 'pos 'neg #t))]
[f-proj ((contract-projection cf)
(make-blame #'here #f "whatever" 'pos 'neg #t))]
[cls (make-wrapper-class 'wrapper-class
'(m)
(list
@ -52,63 +54,57 @@
(define-struct object-contract (methods method-ctcs method-wrappers fields field-ctcs)
#:omit-define-syntaxes
#:property proj-prop
(λ (ctc)
(let ([meth-names (object-contract-methods ctc)]
[meth-param-projs (map (λ (x) ((proj-get x) x)) (object-contract-method-ctcs ctc))]
[ctc-field-names (object-contract-fields ctc)]
[field-param-projs (map (λ (x) ((proj-get x) x)) (object-contract-field-ctcs ctc))])
(λ (pos-blame neg-blame src-info orig-str positive-position?)
(let* ([meth-projs (map (λ (x) (x pos-blame neg-blame src-info orig-str positive-position?))
meth-param-projs)]
[meths (map (λ (p x) (p x)) meth-projs (object-contract-method-wrappers ctc))]
[cls (make-wrapper-class 'wrapper-class meth-names meths ctc-field-names #f)]
[field-projs (map (λ (x) (x pos-blame neg-blame src-info orig-str positive-position?)) field-param-projs)])
(λ (val)
(unless (object? val)
(raise-contract-error val src-info pos-blame orig-str
"expected an object, got ~e"
val))
(let ([objs-mtds (interface->method-names (object-interface val))]
[vtable (extract-vtable val)]
[method-ht (extract-method-ht val)])
(for-each (λ (m proj)
(let ([index (hash-ref method-ht m #f)])
(unless index
(raise-contract-error val src-info pos-blame orig-str
"expected an object with method ~s"
m))
;; verify the first-order properties by apply the projection and
;; throwing the result away. Without this, the contract wrappers
;; just check the first-order properties of the wrappers, which is
;; the wrong thing.
(proj (vector-ref vtable index))))
meth-names
meth-projs))
(let ([fields (field-names val)])
(for-each (λ (f)
(unless (memq f fields)
(raise-contract-error val src-info pos-blame orig-str
"expected an object with field ~s"
f)))
ctc-field-names))
(apply make-object cls val
(map (λ (field proj) (proj (get-field/proc field val)))
ctc-field-names field-projs)))))))
#:property name-prop
(λ (ctc) `(object-contract ,@(map (λ (fld ctc) (build-compound-type-name 'field fld ctc))
(object-contract-fields ctc)
(object-contract-field-ctcs ctc))
,@(map (λ (mtd ctc) (build-compound-type-name mtd ctc))
(object-contract-methods ctc)
(object-contract-method-ctcs ctc))))
#:property first-order-prop (λ (ctc) (λ (val) #f))
#:property stronger-prop (λ (this that) #f))
#:property prop:contract
(build-contract-property
#:projection
(λ (ctc)
(let ([meth-names (object-contract-methods ctc)]
[meth-param-projs (map contract-projection (object-contract-method-ctcs ctc))]
[ctc-field-names (object-contract-fields ctc)]
[field-param-projs (map contract-projection (object-contract-field-ctcs ctc))])
(λ (blame)
(let* ([meth-projs (map (λ (x) (x blame)) meth-param-projs)]
[meths (map (λ (p x) (p x)) meth-projs (object-contract-method-wrappers ctc))]
[cls (make-wrapper-class 'wrapper-class meth-names meths ctc-field-names #f)]
[field-projs (map (λ (x) (x blame)) field-param-projs)])
(λ (val)
(unless (object? val)
(raise-blame-error blame val "expected an object, got ~e" val))
(let ([objs-mtds (interface->method-names (object-interface val))]
[vtable (extract-vtable val)]
[method-ht (extract-method-ht val)])
(for-each (λ (m proj)
(let ([index (hash-ref method-ht m #f)])
(unless index
(raise-blame-error blame val "expected an object with method ~s" m))
;; verify the first-order properties by apply the projection and
;; throwing the result away. Without this, the contract wrappers
;; just check the first-order properties of the wrappers, which is
;; the wrong thing.
(proj (vector-ref vtable index))))
meth-names
meth-projs))
(let ([fields (field-names val)])
(for-each (λ (f)
(unless (memq f fields)
(raise-blame-error blame val "expected an object with field ~s" f)))
ctc-field-names))
(apply make-object cls val
(map (λ (field proj) (proj (get-field/proc field val)))
ctc-field-names field-projs)))))))
#:name
(λ (ctc) `(object-contract ,@(map (λ (fld ctc) (build-compound-type-name 'field fld ctc))
(object-contract-fields ctc)
(object-contract-field-ctcs ctc))
,@(map (λ (mtd ctc) (build-compound-type-name mtd ctc))
(object-contract-methods ctc)
(object-contract-method-ctcs ctc))))
#:first-order (λ (ctc) (λ (val) #f))))
(define-syntax (object-contract stx)
(syntax-case stx ()

62
collects/scheme/contract/private/opt-guts.ss
View File

@ -10,11 +10,7 @@
make-opt/info
opt/info-contract
opt/info-val
opt/info-pos
opt/info-neg
opt/info-src-info
opt/info-orig-str
opt/info-positive-position?
opt/info-blame
opt/info-free-vars
opt/info-recf
opt/info-base-pred
@ -57,52 +53,22 @@
;; struct for color-keeping across opters
(define-struct opt/info
(contract val pos neg src-info orig-str position-var position-swap?
free-vars recf base-pred this that))
(contract val blame-id swap-blame? free-vars recf base-pred this that))
(define (opt/info-positive-position? oi)
(if (opt/info-position-swap? oi)
#`(not #,(opt/info-position-var oi))
(opt/info-position-var oi)))
(define (opt/info-blame oi)
(if (opt/info-swap-blame? oi)
#`(blame-swap #,(opt/info-blame-id oi))
(opt/info-blame-id oi)))
;; opt/info-swap-blame : opt/info -> opt/info
;; swaps pos and neg
(define (opt/info-swap-blame info)
(let ((ctc (opt/info-contract info))
(val (opt/info-val info))
(pos (opt/info-pos info))
(neg (opt/info-neg info))
(position-var (opt/info-position-var info))
(position-swap? (opt/info-position-swap? info))
(src-info (opt/info-src-info info))
(orig-str (opt/info-orig-str info))
(free-vars (opt/info-free-vars info))
(recf (opt/info-recf info))
(base-pred (opt/info-base-pred info))
(this (opt/info-this info))
(that (opt/info-that info)))
(make-opt/info ctc val neg pos src-info orig-str
position-var (not position-swap?)
free-vars recf base-pred this that)))
(struct-copy opt/info info [swap-blame? (not (opt/info-swap-blame? info))]))
;; opt/info-change-val : identifier opt/info -> opt/info
;; changes the name of the variable that the value-to-be-contracted is bound to
(define (opt/info-change-val val info)
(let ((ctc (opt/info-contract info))
(pos (opt/info-pos info))
(neg (opt/info-neg info))
(position-var (opt/info-position-var info))
(position-swap? (opt/info-position-swap? info))
(src-info (opt/info-src-info info))
(orig-str (opt/info-orig-str info))
(free-vars (opt/info-free-vars info))
(recf (opt/info-recf info))
(base-pred (opt/info-base-pred info))
(this (opt/info-this info))
(that (opt/info-that info)))
(make-opt/info ctc val pos neg src-info orig-str
position-var position-swap?
free-vars recf base-pred this that)))
(struct-copy opt/info info [val val]))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -199,17 +165,13 @@
(list (cons
partial-var
(with-syntax ((lift-var lift-var)
(pos (opt/info-pos opt/info))
(neg (opt/info-neg opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
(positive-position? (opt/info-positive-position? opt/info)))
(syntax (((proj-get lift-var) lift-var) pos neg src-info orig-str positive-position?))))
(blame (opt/info-blame opt/info)))
(syntax ((contract-projection lift-var) blame))))
(cons
partial-flat-var
(with-syntax ((lift-var lift-var))
(syntax (if (flat-pred? lift-var)
((flat-get lift-var) lift-var)
(syntax (if (flat-contract? lift-var)
(flat-contract-predicate lift-var)
(lambda (x) (error 'opt/unknown "flat called on an unknown that had no flat pred ~s ~s"
lift-var
x)))))))

36
collects/scheme/contract/private/opt.ss
View File

@ -62,13 +62,9 @@
(values
(with-syntax ((stx stx)
(val (opt/info-val opt/info))
(pos (opt/info-pos opt/info))
(neg (opt/info-neg opt/info))
(src-info (opt/info-src-info opt/info))
(orig-str (opt/info-orig-str opt/info))
(positive-position? (opt/info-positive-position? opt/info)))
(blame (opt/info-blame opt/info)))
(syntax (let ((ctc stx))
((((proj-get ctc) ctc) pos neg src-info orig-str positive-position?) val))))
(((contract-projection ctc) blame) val))))
null
null
null
@ -122,11 +118,7 @@
[(_ e (opt-recursive-args ...))
(let*-values ([(info) (make-opt/info #'ctc
#'val
#'pos
#'neg
#'src-info
#'orig-str
#'positive-position?
#'blame
#f
(syntax->list #'(opt-recursive-args ...))
#f
@ -141,7 +133,7 @@
lifts
#`(make-opt-contract
(λ (ctc)
(λ (pos neg src-info orig-str positive-position?)
(λ (blame)
#,(if (syntax-parameter-value #'define/opt-recursive-fn)
(with-syntax ([f (syntax-parameter-value #'define/opt-recursive-fn)])
(bind-superlifts
@ -179,16 +171,18 @@
(make-struct-type-property 'original-contract))
(define-struct opt-contract (proj orig-ctc stronger stronger-vars stamp)
#:property proj-prop (λ (ctc) ((opt-contract-proj ctc) ctc))
;; I think provide/contract and contract calls this, so we are in effect allocating
;; the original once
#:property name-prop (λ (ctc) (contract-name ((orig-ctc-get ctc) ctc)))
#:property orig-ctc-prop (λ (ctc) ((opt-contract-orig-ctc ctc)))
#:property stronger-prop
(λ (this that)
(and (opt-contract? that)
(eq? (opt-contract-stamp this) (opt-contract-stamp that))
((opt-contract-stronger this) this that))))
#:property prop:contract
(build-contract-property
#:projection (λ (ctc) ((opt-contract-proj ctc) ctc))
;; I think provide/contract and contract calls this, so we are in effect allocating
;; the original once
#:name (λ (ctc) (contract-name ((orig-ctc-get ctc) ctc)))
#:stronger
(λ (this that)
(and (opt-contract? that)
(eq? (opt-contract-stamp this) (opt-contract-stamp that))
((opt-contract-stronger this) this that)))))
;; opt-stronger-vars-ref : int opt-contract -> any
(define (opt-stronger-vars-ref i ctc)

193
collects/scheme/contract/private/prop.ss Normal file
View File

@ -0,0 +1,193 @@
#lang scheme/base
(require "blame.ss")
(provide prop:contract
contract-struct?
contract-struct-name
contract-struct-first-order
contract-struct-projection
contract-struct-stronger?
prop:flat-contract
flat-contract-struct?
contract-property?
build-contract-property
flat-contract-property?
build-flat-contract-property
simple-contract
simple-flat-contract)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Contract Property
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-struct contract-property [ name first-order projection stronger ]
#:omit-define-syntaxes)
(define (contract-property-guard prop info)
(unless (contract-property? prop)
(raise
(make-exn:fail:contract
(format "~a: expected a contract property; got: ~e"
'prop:contract
prop)
(current-continuation-marks))))
prop)
(define-values [ prop:contract contract-struct? contract-struct-property ]
(make-struct-type-property 'prop:contract contract-property-guard))
(define (contract-struct-name c)
(let* ([prop (contract-struct-property c)]
[get-name (contract-property-name prop)]
[name (get-name c)])
name))
(define (contract-struct-first-order c)
(let* ([prop (contract-struct-property c)]
[get-first-order (contract-property-first-order prop)]
[first-order (get-first-order c)])
first-order))
(define (contract-struct-projection c)
(let* ([prop (contract-struct-property c)]
[get-projection (contract-property-projection prop)]
[projection (get-projection c)])
projection))
(define (contract-struct-stronger? a b)
(let* ([prop (contract-struct-property a)]
[stronger (contract-property-stronger prop)])
(stronger a b)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Flat Contract Property
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-struct flat-contract-property [implementation]
#:omit-define-syntaxes)
(define (flat-contract-property-guard prop info)
(unless (flat-contract-property? prop)
(raise
(make-exn:fail:contract
(format "~a: expected a flat contract property; got: ~e"
'prop:flat-contract
prop)
(current-continuation-marks))))
prop)
(define flat-contract-property->contract-property
flat-contract-property-implementation)
(define (flat-contract-property->procedure-property prop)
(let* ([impl (flat-contract-property-implementation prop)]
[get-predicate (contract-property-first-order impl)])
(lambda (c x) ((get-predicate c) x))))
(define-values [ prop:flat-contract
flat-contract-struct?
flat-contract-struct-property ]
(make-struct-type-property
'prop:flat-contract
flat-contract-property-guard
(list (cons prop:contract flat-contract-property->contract-property)
(cons prop:procedure flat-contract-property->procedure-property))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Friendly Property Construction
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define ((build-property mk default-name)
#:name [get-name #f]
#:first-order [get-first-order #f]
#:projection [get-projection #f]
#:stronger [stronger #f])
(let* ([get-name (or get-name (lambda (c) default-name))]
[get-first-order (or get-first-order get-any?)]
[get-projection (or get-projection
(get-first-order-projection
get-name get-first-order))]
[stronger (or stronger weakest)])
(mk get-name get-first-order get-projection stronger)))
(define build-contract-property
(build-property make-contract-property 'anonymous-contract))
(define build-flat-contract-property
(build-property (compose make-flat-contract-property make-contract-property)
'anonymous-flat-contract))
(define (get-any? c) any?)
(define (any? x) #t)
(define (weakest a b) #f)
(define ((get-first-order-projection get-name get-first-order) c)
(first-order-projection (get-name c) (get-first-order c)))
(define (((first-order-projection name first-order) b) x)
(if (first-order x)
x
(raise-blame-error b x "expected <~a>, given: ~e" name x)))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Simple Contract Construction
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-struct simple-contract [ name first-order projection stronger ]
#:omit-define-syntaxes
#:property prop:contract
(make-contract-property
(lambda (c) (simple-contract-name c))
(lambda (c) (simple-contract-first-order c))
(lambda (c) (simple-contract-projection c))
(lambda (a b) ((simple-contract-stronger a) a b))))
(define-struct simple-flat-contract [ name first-order projection stronger ]
#:omit-define-syntaxes
#:property prop:flat-contract
(make-flat-contract-property
(make-contract-property
(lambda (c) (simple-flat-contract-name c))
(lambda (c) (simple-flat-contract-first-order c))
(lambda (c) (simple-flat-contract-projection c))
(lambda (a b) ((simple-flat-contract-stronger a) a b)))))
(define ((build-contract mk default-name)
#:name [name #f]
#:first-order [first-order #f]
#:projection [projection #f]
#:stronger [stronger #f])
(let* ([name (or name default-name)]
[first-order (or first-order any?)]
[projection (or projection (first-order-projection name first-order))]
[stronger (or stronger as-strong?)])
(mk name first-order projection stronger)))
(define (as-strong? a b)
(procedure-closure-contents-eq?
(contract-struct-projection a)
(contract-struct-projection b)))
(define simple-contract
(build-contract make-simple-contract 'simple-contract))
(define simple-flat-contract
(build-contract make-simple-flat-contract 'simple-flat-contract))

27
collects/scheme/contract/private/provide.ss
View File

@ -8,23 +8,15 @@
"arrow.ss"
"base.ss"
scheme/contract/exists
"guts.ss")
"guts.ss"
unstable/location
unstable/srcloc)
(define-syntax (verify-contract stx)
(syntax-case stx ()
[(_ name x) (a:known-good-contract? #'x) #'x]
[(_ name x) #'(coerce-contract name x)]))
;; id->contract-src-info : identifier -> syntax
;; constructs the last argument to the -contract, given an identifier
(define-for-syntax (id->contract-src-info id)
#`(list (make-srcloc #,id
#,(syntax-line id)
#,(syntax-column id)
#,(syntax-position id)
#,(syntax-span id))
#,(format "~s" (syntax->datum id))))
(define-for-syntax (make-provide/contract-transformer contract-id id pos-module-source)
(make-set!-transformer
(let ([saved-id-table (make-hasheq)])
@ -52,8 +44,9 @@
#`(contract contract-id
id
pos-module-source
(#%variable-reference)
#,(id->contract-src-info #'id))))))])
(quote-module-path)
'id
(quote-syntax id))))))])
(when key
(hash-set! saved-id-table key lifted-id))
;; Expand to a use of the lifted expression:
@ -652,7 +645,7 @@
(with-syntax ([code
(quasisyntax/loc stx
(begin
(define pos-module-source (#%variable-reference))
(define pos-module-source (quote-module-path))
#,@(if no-need-to-check-ctrct?
(list)
@ -669,7 +662,7 @@
(syntax-local-lift-module-end-declaration
#`(begin
(unless extra-test
(contract contract-id id pos-module-source 'ignored #,(id->contract-src-info #'id)))
(contract contract-id id pos-module-source 'ignored 'id (quote-syntax id)))
(void)))
(syntax (code id-rename))))))]))
@ -702,7 +695,9 @@
(contract ctc
val
'not-enough-info-for-blame
'not-enough-info-for-blame))
'not-enough-info-for-blame
'#f
(build-source-location #f)))
ctcs
vals)))))])
struct:struct-name))

35
collects/scheme/contract/regions.ss
View File

@ -22,16 +22,6 @@
[(_ name x) (a:known-good-contract? #'x) #'x]
[(_ name x) #'(coerce-contract name x)]))
;; id->contract-src-info : identifier -> syntax
;; constructs the last argument to the -contract, given an identifier
(define-for-syntax (id->contract-src-info id)
#`(list (make-srcloc #,id
#,(syntax-line id)
#,(syntax-column id)
#,(syntax-position id)
#,(syntax-span id))
#,(format "~s" (syntax->datum id))))
;
@ -322,7 +312,8 @@
#,av-id
'(struct name)
'cant-happen
#,(id->contract-src-info av-id)))))]
(quote #,av-id)
(quote-syntax #,av-id)))))]
;; a list of variables, one for each super field
[(super-fields ...) (generate-temporaries super-fields)]
;; the contract for a super field is any/c becuase the
@ -353,7 +344,8 @@
#:guard (contract (-> super-contracts ... non-auto-contracts ... symbol? any)
guard
(current-contract-region) blame-id
#'maker)))))))))]
(quote maker)
(quote-syntax maker))))))))))]
[(_ name . bad-fields)
(identifier? #'name)
(syntax-error "expected a list of field name/contract pairs"
@ -391,14 +383,16 @@
arg
#,neg-blame-id
#,pos-blame-id
#,(id->contract-src-info id))))]
(quote #,id)
(quote-syntax #,id))))]
[(f arg ...)
(quasisyntax/loc stx
((contract #,contract-stx
#,id
#,pos-blame-id
#,neg-blame-id
#,(id->contract-src-info id))
(quote #,id)
(quote-syntax #,id))
arg ...))]
[ident
(identifier? (syntax ident))
@ -407,7 +401,8 @@
#,id
#,pos-blame-id
#,neg-blame-id
#,(id->contract-src-info id)))]))))
(quote #,id)
(quote-syntax #,id)))]))))
(define-for-syntax (check-and-split-with-contracts args)
(let loop ([args args]
@ -533,15 +528,13 @@
(syntax-property c 'inferred-name v))
free-ctcs
free-vars)]
[(free-src-info ...) (map id->contract-src-info free-vars)]
[(ctc-id ...) (map cid-marker protected)]
[(ctc ...) (map (λ (c v)
(syntax-property (add-context c) 'inferred-name v))
protections
protected)]
[(p ...) protected]
[(marked-p ...) (add-context #`#,protected)]
[(src-info ...) (map (compose id->contract-src-info add-context) protected)])
[(marked-p ...) (add-context #`#,protected)])
(with-syntax ([new-stx (add-context #'(splicing-syntax-parameterize
([current-contract-region (λ (stx) #'blame-stx)])
. body))])
@ -556,7 +549,8 @@
free-var
blame-id
'cant-happen
free-src-info)
(quote free-var)
(quote-syntax free-var))
...
(values)))
(define-syntaxes (free-var-id ...)
@ -573,7 +567,8 @@
marked-p
blame-stx
'cant-happen
src-info)
(quote marked-p)
(quote-syntax marked-p))
...
(values)))
(define-syntaxes (p ...)

11
collects/scheme/exists/lang.ss
View File

@ -25,6 +25,7 @@
'(absolute-path?
arity-at-least?
bitwise-bit-set?
blame?
boolean?
box?
byte-pregexp?
@ -60,6 +61,8 @@
contract-first-order-passes?
contract-stronger?
contract?
contract-property?
contract-struct?
custodian-box?
custodian-memory-accounting-available?
custodian?
@ -84,8 +87,8 @@
exact-positive-integer?
exact?
exn:break?
exn:fail:contract2?
exn:fail:contract:arity?
exn:fail:contract:blame?
exn:fail:contract:continuation?
exn:fail:contract:divide-by-zero?
exn:fail:contract:variable?
@ -111,7 +114,8 @@
file-stream-port?
fixnum?
flat-contract?
flat-pred?
flat-contract-property?
flat-contract-struct?
generic?
handle-evt?
hash-eq?
@ -144,7 +148,6 @@
module-path?
module-provide-protected?
mpair?
name-pred?
namespace-anchor?
namespace?
negative?
@ -176,7 +179,6 @@
procedure-closure-contents-eq?
procedure-struct-type?
procedure?
proj-pred?
promise-forced?
promise-running?
promise?
@ -198,7 +200,6 @@
special-comment?
srcloc?
string?
stronger-pred?
struct-accessor-procedure?
struct-constructor-procedure?
struct-mutator-procedure?

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

@ -817,7 +817,7 @@ The @scheme[define-struct/contract] form only allows a subset of the
positive-blame-expr negative-blame-expr)
(contract contract-expr to-protect-expr
positive-blame-expr negative-blame-expr
contract-source-info)]]{
value-name-expr source-location-expr)]]{
The primitive mechanism for attaching a contract to a value. The
purpose of @scheme[contract] is as a target for the expansion of some
@ -830,35 +830,21 @@ is the result of the @scheme[to-protect-expr] expression, but with the
contract specified by @scheme[contract-expr] enforced on
@scheme[to-protect-expr].
The values of @scheme[positive-blame-expr] and
@scheme[negative-blame-expr] must be symbols indicating how to assign
blame for positive and negative positions of the contract specified by
@scheme[contract-expr].
The values of @scheme[positive-blame-expr] and @scheme[negative-blame-expr]
indicate how to assign blame for positive and negative positions of the contract
specified by @scheme[contract-expr]. They may be any value, and are formatted
as by @scheme[display] for purposes of contract violation error messages.
If specified, @scheme[contract-source-info], indicates where the
contract was assumed. Its value must be a either:
@itemize[
@item{a list of two elements: @scheme[srcloc] struct and
either a string or @scheme[#f]. The srcloc struct indicates
where the contract was assumed. Its @tt{source} field
should be a syntax object, and @scheme[module-path-index-resolve]
is called on it to extract the path of syntax object.
If specified, @scheme[value-name-expr] indicates a name for the protected value
to be used in error messages. If not supplied, or if @scheme[value-name-expr]
produces @scheme[#f], no name is printed. Otherwise, it is also formatted as by
@scheme[display].
If the second element of
the list is not @scheme[#f], it is used as the name of the
identifier whose contract was assumed.}
If specified, @scheme[source-location-expr] indicates the source location
reported by contract violations. The expession must produce a @scheme[srcloc]
structure, @tech{syntax object}, @scheme[#f], or a list or vector in the format
accepted by the third argument to @scheme[datum->syntax].
@item{a syntax object specifying the
source location of the location where the contract was assumed. If the
syntax object wraps a symbol, the symbol is used as the name of the
primitive whose contract was assumed.}
]
If absent, it defaults to the source location of the
@scheme[contract] expression with no identifying name.
The second form above is not recommended, because mzscheme strips
source location information from compiled files.
}
@; ------------------------------------------------------------------------
@ -903,34 +889,30 @@ Although these projections have the right error behavior,
they are not quite ready for use as contracts, because they
do not accomodate blame, and do not provide good error
messages. In order to accomodate these, contracts do not
just use simple projections, but use functions that accept
just use simple projections, but use functions that accept a
@deftech{blame object} encapsulating
the names of two parties that are the candidates for blame,
as well as a record of the source location where the
contract was established and the name of the contract. They
can then, in turn, pass that information
to @scheme[raise-contract-error] to signal a good error
to @scheme[raise-blame-error] to signal a good error
message.
Here is the first of those two projections, rewritten for
use in the contract system:
@schemeblock[
(define (int-proj pos neg src-info name positive-position?)
(define (int-proj blame)
(lambda (x)
(if (integer? x)
x
(raise-contract-error
(raise-blame-error
blame
val
src-info
pos
name
"expected <integer>, given: ~e"
val))))
]
The first two new arguments specify who is to be blamed for
positive and negative contract violations,
respectively.
The new argument specifies who is to be blamed for
positive and negative contract violations.
Contracts, in this system, are always
established between two parties. One party provides some
@ -939,28 +921,24 @@ value, also according to the contract. The first is called
the ``positive'' person and the second the ``negative''. So,
in the case of just the integer contract, the only thing
that can go wrong is that the value provided is not an
integer. Thus, only the positive argument can ever accrue
blame (and thus only @scheme[pos] is passed
to @scheme[raise-contract-error]).
integer. Thus, only the positive party can ever accrue
blame. The @scheme[raise-blame-error] function always blames
the positive party.
Compare that to the projection for our function contract:
@schemeblock[
(define (int->int-proj pos neg src-info name positive-position?)
(let ([dom (int-proj neg pos src-info
name (not positive-position?))]
[rng (int-proj pos neg src-info
name positive-position?)])
(define (int->int-proj blame)
(let ([dom (int-proj (blame-swap blame))]
[rng (int-proj blame)])
(lambda (f)
(if (and (procedure? f)
(procedure-arity-includes? f 1))
(lambda (x)
(rng (f (dom x))))
(raise-contract-error
(raise-blame-error
blame
val
src-info
pos
name
"expected a procedure of one argument, given: ~e"
val)))))
]
@ -970,17 +948,16 @@ where either a non-procedure is supplied to the contract, or
where the procedure does not accept one argument. As with
the integer projection, the blame here also lies with the
producer of the value, which is
why @scheme[raise-contract-error] gets @scheme[pos] and
not @scheme[neg] as its argument.
why @scheme[raise-blame-error] is passed @scheme[blame] unchanged.
The checking for the domain and range are delegated to
the @scheme[int-proj] function, which is supplied its
arguments in the first two line of
the @scheme[int->int-proj] function. The trick here is that,
even though the @scheme[int->int-proj] function always
blames what it sees as positive we can reverse the order of
the @scheme[pos] and @scheme[neg] arguments so that the
positive becomes the negative.
blames what it sees as positive we can swap the blame parties by
calling @scheme[blame-swap] on the given @tech{blame object}, replacing
the positive party with the negative party and vice versa.
This is not just a cheap trick to get this example to work,
however. The reversal of the positive and the negative is a
@ -996,8 +973,8 @@ travelling back from the requiring module to the providing
module! And finally, when the function produces a result,
that result flows back in the original
direction. Accordingly, the contract on the domain reverses
the positive and the negative, just like the flow of values
reverses.
the positive and the negative blame parties, just like the flow
of values reverses.
We can use this insight to generalize the function contracts
and build a function that accepts any two contracts and
@ -1005,21 +982,17 @@ returns a contract for functions between them.
@schemeblock[
(define (make-simple-function-contract dom-proj range-proj)
(lambda (pos neg src-info name positive-position?)
(let ([dom (dom-proj neg pos src-info
name (not positive-position?))]
[rng (range-proj pos neg src-info
name positive-position?)])
(lambda (blame)
(let ([dom (dom-proj (blame-swap blame))]
[rng (range-proj blame)])
(lambda (f)
(if (and (procedure? f)
(procedure-arity-includes? f 1))
(lambda (x)
(rng (f (dom x))))
(raise-contract-error
(raise-blame-error
blame
val
src-info
pos
name
"expected a procedure of one argument, given: ~e"
val))))))
]
@ -1028,37 +1001,90 @@ Projections like the ones described above, but suited to
other, new kinds of value you might make, can be used with
the contract library primitives below.
@defproc[(make-proj-contract [name any/c]
[proj (or/c (-> symbol? symbol? any/c any/c any/c)
(-> symbol? symbol? any/c any/c boolean? any/c))]
[first-order-test (-> any/c any/c)])
contract?]{
@deftogether[(
@defproc[(simple-contract
[#:name name any/c 'simple-contract]
[#:first-order test (-> any/c any/c) (λ (x) #t)]
[#:projection proj (-> blame? (-> any/c any/c))
(λ (b)
(λ (x)
(if (test x)
x
(raise-blame-error
b x "expected <~a>, given: ~e" name x))))])
contract?]
@defproc[(simple-flat-contract
[#:name name any/c 'simple-flat-contract]
[#:first-order test (-> any/c any/c) (λ (x) #t)]
[#:projection proj (-> blame? (-> any/c any/c))
(λ (b)
(λ (x)
(if (test x)
x
(raise-blame-error
b x "expected <~a>, given: ~e" name x))))])
flat-contract?]
)]{
Builds a new contract.
The first argument is the name of the contract. It can be an
arbitrary S-expression. The second is a projection (see
above).
These functions build simple procedure-based contracts and flat contracts,
respectively. They both take the same set of three optional arguments: a name,
a first order predicate, and a blame-tracking projection.
If the projection only takes four arguments, then the
positive position boolean is not passed to it (this is
for backwards compatibility).
The @scheme[name] argument is any value to be rendered using @scheme[display] to
describe the contract when a violation occurs. The default name for simple
higher order contracts is @schemeresult[simple-contract], and for flat contracts
is @schemeresult[simple-flat-contract].
The final argument is a predicate that is a
conservative, first-order test of a value. It should be a
function that accepts one argument and returns a boolean. If
it returns @scheme[#f], its argument must be guaranteed to
fail the contract, and the contract should detect this right
when the projection is invoked. If it returns true,
the value may or may not violate the contract, but any
violations must not be signaled immediately.
The first order predicate @scheme[test] can be used to determine which values
the contract applies to; usually this is the set of values for which the
contract fails immediately without any higher-order wrapping. This test is used
by @scheme[contract-first-order-passes?], and indirectly by @scheme[or/c] to
determine which of multiple higher order contracts to wrap a value with. The
default test accepts any value.
The projection @scheme[proj] defines the behavior of applying the contract. It
is a curried function of two arguments: the first application accepts a blame
object, and the second accepts a value to protect with the contract. The
projection must either produce the value, suitably wrapped to enforce any
higher-order aspects of the contract, or signal a contract violation using
@scheme[raise-blame-error]. The default projection produces an error when the
first order test fails, and produces the value unchanged otherwise.
Projections for flat contracts must fail precisely when the first order test
does, and must produce the input value unchanged otherwise. Applying a flat
contract may result in either an application of the predicate, or the
projection, or both; therefore, the two must be consistent. The existence of a
separate projection only serves to provide more specific error messages. Most
flat contracts do not need to supply an explicit projection.
@defexamples[#:eval (contract-eval)
(define int/c
(simple-flat-contract #:name 'int/c #:first-order integer?))
(contract int/c 1 'positive 'negative)
(contract int/c "not one" 'positive 'negative)
(int/c 1)
(int/c "not one")
(define int->int/c
(simple-contract
#:name 'int->int/c
#:first-order
(λ (x) (and (procedure? x) (procedure-arity-includes? x 1)))
#:projection
(λ (b)
(let ([domain ((contract-projection int/c) (blame-swap b))]
[range ((contract-projection int/c) b)])
(λ (f)
(if (and (procedure? f) (procedure-arity-includes? f 1))
(λ (x) (range (f (domain x))))
(raise-blame-error
b f "expected a function of one argument, got: ~e" f)))))))
(contract int->int/c "not fun" 'positive 'negative)
(define halve (contract int->int/c (λ (x) (/ x 2)) 'positive 'negative))
(halve 2)
(halve 1)
(halve 1/2)
]
This function is a convenience function, implemented
using @scheme[proj-prop], @scheme[name-prop],
@scheme[first-order-prop], and @scheme[stronger-prop].
Consider using those directly (as well as @scheme[flat-prop] as necessary),
as they allow more flexibility
and generally produce more efficient contracts.
}
@defproc[(build-compound-type-name [c/s any/c] ...) any]{
@ -1100,31 +1126,71 @@ contracts. The error messages assume that the function named by
the value cannot be coerced to a contract.
}
@defproc[(raise-contract-error [val any/c]
[src-info any/c]
[to-blame symbol?]
[contract-name any/c]
[fmt string?]
[arg any/c] ...)
any]{
@subsection{Blame Objects}
Signals a contract violation. The first argument is the value that
failed to satisfy the contract. The second argument is is the
@scheme[src-info] passed to the projection and the third should be
either @scheme[pos] or @scheme[neg] (typically @scheme[pos], see the
beginning of this section) that was passed to the projection. The
fourth argument is the @scheme[contract-name] that was passed to the
projection and the remaining arguments are used with @scheme[format]
to build an actual error message.}
@defproc[(blame? [x any/c]) boolean?]{
This predicate recognizes @tech{blame objects}.
}
@;{
% to document:
% proj-prop proj-pred? proj-get
% name-prop name-pred? name-get
% stronger-prop stronger-pred? stronger-get
% flat-prop flat-pred? flat-get
% first-order-prop first-order-get
% contract-stronger?
@deftogether[(
@defproc[(blame-positive [b blame?]) any/c]
@defproc[(blame-negative [b blame?]) any/c]
)]{
These functions produce printable descriptions of the current positive and
negative parties of a blame object.
}
@defproc[(blame-contract [b blame?]) any/c]{
This function produces a description of the contract associated with a blame
object (the result of @scheme[contract-name]).
}
@defproc[(blame-value [b blame?]) any/c]{
This function produces the name of the value to which the contract was applied,
or @scheme[#f] if no name was provided.
}
@defproc[(blame-source [b blame?]) srcloc?]{
This function produces the source location associated with a contract. If no
source location was provided, all fields of the structure will contain
@scheme[#f].
}
@defproc[(blame-swap [b blame?]) blame?]{
This function swaps the positive and negative parties of a @tech{blame object}.
}
@deftogether[(
@defproc[(blame-original? [b blame?]) boolean?]
@defproc[(blame-swapped? [b blame?]) boolean?]
)]{
These functions report whether the current blame of a given blame object is the
same as in the original contract invocation (possibly of a compound contract
containing the current one), or swapped, respectively. Each is the negation of
the other; both are provided for convenience and clarity.
}
@defproc[(raise-blame-error [b blame?] [x any/c] [fmt string?] [v any/c] ...)
none/c]{
Signals a contract violation. The first argument, @scheme[b], records the
current blame information, including positive and negative parties, the name of
the contract, the name of the value, and the source location of the contract
application. The second argument, @scheme[x], is the value that failed to
satisfy the contract. The remaining arguments are a format string,
@scheme[fmt], and its arguments, @scheme[v ...], specifying an error message
specific to the precise violation.
}
@defproc[(exn:fail:contract:blame? [x any/c]) boolean?]{
This predicate recognizes exceptions raised by @scheme[raise-blame-error].
}
@defproc[(exn:fail:contract:blame-object [e exn:fail:contract:blame?]) blame?]{
This accessor extracts the blame object associated with a contract violation.
}
@subsection{Contracts as structs}
@ -1132,98 +1198,104 @@ to build an actual error message.}
@emph{@bold{Note:}
The interface in this section is unstable and subject to change.}
A contract is an arbitrary struct that has all of the
struct properties
(see @secref["structprops"] in the reference manual)
in this section
(except that @scheme[flat-prop] is optional).
Generally speaking, the contract should be a struct with
fields that specialize the contract in some way and then
properties that implement all of the details of checking
the contract and reporting errors, etc.
For example, an @scheme[between/c] contract is a struct that
holds the bounds on the number and then has the properties below
that inspect the bounds and take the corresponding action
(the @scheme[proj-prop] checks the numbers, the @scheme[name-prop]
constructs a name to print out for the contract, etc.).
@deftogether[(@defthing[proj-prop struct-type-property?]
@defproc[(proj-pred? [v any/c]) boolean?]{}
@defproc[(proj-get [v proj-pred?])
(-> proj-prop?
(-> symbol? symbol? (or/c #f syntax?) string? boolean?
(-> any/c any/c)))]{})]{
This is the workhorse property that implements the contract.
The property should be bound to a function that accepts
the struct and then returns a projection, as described
in the docs for @scheme[make-proj-contract] above.
}
@deftogether[(@defthing[name-prop struct-type-property?]{}
@defproc[(name-pred? [v any/c]) boolean?]{}
@defproc[(name-get [v name-pred?]) (-> name-pred? printable/c)]{})]{
This property should be a function that accepts the struct and returns
an s-expression representing the name of the property.
@mz-examples[#:eval (contract-eval)
(write (between/c 1 10))
(let ([c (between/c 1 10)])
((name-get c) c))]
}
@deftogether[(@defthing[stronger-prop struct-type-property?]{}
@defproc[(stronger-pred? [v any/c]) boolean?]{}
@defproc[(stronger-get [v stronger-pred?]) (-> stronger-pred? stronger-pred? boolean?)]{})]{
This property is used when optimizing contracts, in order to tell if some contract is stronger than another one.
In some situations, if a contract that is already in place is stronger than one about to be put in place,
then the new one is ignored.
@para{
The property @scheme[prop:contract] allows arbitrary structures to act as
contracts. The property @scheme[prop:flat-contract] allows arbitrary structures
to act as flat contracts; @scheme[prop:flat-contract] inherits both
@scheme[prop:contract] and @scheme[prop:procedure], so flat contract structures
may also act as general contracts and as predicate procedures.
}
@deftogether[(@defthing[flat-prop struct-type-property?]{}
@defproc[(flat-pred? [v any/c]) boolean?]{}
@defproc[(flat-get [v flat-pred?]) (-> flat-pred? (-> any/c boolean?))]{})]{
This property should only be present if the contract is a flat contract. In the case that it is
a flat contract, the value of the property should be a predicate that determines if the
contract holds.
@mz-examples[#:eval (contract-eval)
(flat-pred? (-> integer? integer?))
(let* ([c (between/c 1 10)]
[pred ((flat-get c) c)])
(list (pred 9)
(pred 11)))]
@deftogether[(
@defthing[prop:contract struct-type-property?]
@defthing[prop:flat-contract struct-type-property?]
)]{
These properties declare structures to be contracts or flat contracts,
respectively. The value for @scheme[prop:contract] must be a @tech{contract
property} constructed by @scheme[build-contract-property]; likewise, the value
for @scheme[prop:flat-contract] must be a @tech{flat contract property}
constructed by @scheme[build-flat-contract-property].
}
@deftogether[(@defthing[first-order-prop struct-type-property?]{}
@defproc[(first-order-pred? [v any/c]) boolean?]{}
@defproc[(first-order-get [v proj-pred?]) (-> first-order-pred? (-> any/c boolean?))]{})]{
@deftogether[(
@defproc[(build-flat-contract-property
[#:name
get-name
(-> contract? any/c)
(λ (c) 'anonymous-flat-contract)]
[#:first-order
get-first-order
(-> contract? (-> any/c boolean?))
(λ (c) (λ (x) #t))]
[#:projection
get-projection
(-> contract? (-> blame? (-> any/c any/c)))
(λ (c)
(λ (b)
(λ (x)
(if ((get-first-order c) x)
x
(raise-blame-error
b x "expected <~a>, given: ~e" (get-name c) x)))))])
flat-contract-property?]
@defproc[(build-contract-property
[#:name
get-name
(-> contract? any/c)
(λ (c) 'anonymous-contract)]
[#:first-order
get-first-order
(-> contract? (-> any/c boolean?))
(λ (c) (λ (x) #t))]
[#:projection
get-projection
(-> contract? (-> blame? (-> any/c any/c)))
(λ (c)
(λ (b)
(λ (x)
(if ((get-first-order c) x)
x
(raise-blame-error
b x "expected <~a>, given: ~e" (get-name c) x)))))])
contract-property?]
)]{
This property is used with @scheme[or/c] to determine which branch of the
@scheme[or/c] applies. These don't have to be precise (i.e., returning @scheme[#f] is always safe),
but the more often a contract can honestly return @scheme[#t], the more often
it will work with @scheme[or/c].
For example, function contracts typically check arity in their @scheme[first-order-prop]s.
These functions build the arguments for @scheme[prop:contract] and
@scheme[prop:flat-contract], respectively.
A @deftech{contract property} specifies the behavior of a structure when used as
a contract. It is specified in terms of three accessors: @scheme[get-name],
which produces a description to @scheme[display] during a contract violation;
@scheme[get-first-order], which produces a first order predicate to be used by
@scheme[contract-first-order-passes?]; and @scheme[get-projection], which
produces a blame-tracking projection defining the behavior of the contract.
These accessors are passed as (optional) keyword arguments to
@scheme[build-contract-property], and are applied to instances of the
appropriate structure type by the contract system. Their results are used
analogously to the arguments of @scheme[simple-contract].
A @deftech{flat contract property} specifies the behavior of a structure when
used as a flat contract. It is specified using
@scheme[build-flat-contract-property], and accepts exactly the same set of
arguments as @scheme[build-contract-property]. The only difference is that the
projection accessor is expected not to wrap its argument in a higher order
fashion, analogous to the constraint on projections in
@scheme[simple-flat-contract].
}
@deftogether[(
@defproc[(contract-property? [x any/c]) boolean?]
@defproc[(flat-contract-property? [x any/c]) boolean?]
)]{
These predicates detect whether a value is a @tech{contract property} or a
@tech{flat contract property}, respectively.
}
@; ------------------------------------------------------------------------
@section{Contract Utilities}
@defproc[(guilty-party [exn exn?]) any]{
Extracts the name of the guilty party from an exception
raised by the contract system.}
@defproc[(contract? [v any/c]) boolean?]{
Returns @scheme[#t] if its argument is a contract (i.e., constructed
@ -1260,6 +1332,18 @@ may or may not hold. If the contract is a first-order
contract, a result of @scheme[#t] guarantees that the
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?)]{
Produces the first order test used by @scheme[or/c] to match values to higher
order contracts.
}
@defproc[(contract-projection [c contract?]) (-> blame? (-> any/c any/c))]{
Produces the projection defining a contract's behavior on protected values.
}
@defproc[(make-none/c [sexp-name any/c]) contract?]{
@ -1267,31 +1351,22 @@ Makes a contract that accepts no values, and reports the
name @scheme[sexp-name] when signaling a contract violation.}
@defparam[contract-violation->string
@defparam[current-blame-format
proc
(-> any/c any/c (or/c #f any/c) any/c string? string?)]{
(-> blame? any/c string?)]{
This is a parameter that is used when constructing a
contract violation error. Its value is procedure that
accepts five arguments:
accepts three arguments:
@itemize[
@item{the value that the contract applies to,}
@item{a syntax object representing the source location where
the contract was established, }
@item{the name of the party that violated the contract (@scheme[#f] indicates that the party is not known, not that the party's name is @scheme[#f]), }
@item{an sexpression representing the contract, and }
@item{a message indicating the kind of violation.
}]
@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.
If the contract was establised via
@scheme[provide/contract], the names of the party to the
contract will be sexpression versions of the module paths
(as returned by @scheme[collapse-module-path]).
}

14
collects/syntax/private/stxparse/lib.ss
View File

@ -4,7 +4,7 @@
"../util.ss"
syntax/stx
scheme/struct-info
scheme/contract/private/helpers
unstable/srcloc
(for-syntax scheme/base
"rep.ss"
(only-in "rep-data.ss" make-literalset))
@ -106,11 +106,13 @@
(define-syntax-class (expr/c ctc)
#:attributes (c)
(pattern x:expr
#:with c #`(contract #,ctc
x
(quote #,(string->symbol (or (build-src-loc-string #'x) "")))
(quote #,(or '<this-macro>))
(quote-syntax #,(syntax/loc #'x (<there>))))))
#:with
c #`(contract #,ctc
x
(quote #,(source-location->string #'x "<<unknown>>"))
'<this-macro>
#f
(quote-syntax x))))
;; Literal sets

16
collects/tests/mzscheme/contract-mzlib-test.ss
View File

@ -78,13 +78,9 @@ of the contract library does not change over time.
(define (test/spec-failed name expression blame)
(let ()
(define (has-proper-blame? msg)
(equal?
blame
(cond
[(regexp-match #rx"(^| )(.*) broke" msg)
=>
(λ (x) (caddr x))]
[else (format "no blame in error message: \"~a\"" msg)])))
(regexp-match?
(string-append "(^| )" (regexp-quote blame) " broke")
msg))
(printf "testing: ~s\n" name)
(contract-eval
`(,thunk-error-test
@ -5127,7 +5123,11 @@ so that propagation occurs.
(and (exn? x)
(regexp-match #rx"expected field name to be b, but found string?" (exn-message x)))))
(contract-eval `(,test 'pos guilty-party (with-handlers ((void values)) (contract not #t 'pos 'neg))))
(contract-eval
`(,test
'pos
(compose blame-positive exn:fail:contract:blame-object)
(with-handlers ((void values)) (contract not #t 'pos 'neg))))
(report-errs)

116
collects/tests/mzscheme/contract-test.ss
View File

@ -73,13 +73,9 @@
(define (test/spec-failed name expression blame)
(let ()
(define (has-proper-blame? msg)
(equal?
blame
(cond
[(regexp-match #rx"(^| )(.*) broke" msg)
=>
(λ (x) (caddr x))]
[else (format "no blame in error message: \"~a\"" msg)])))
(regexp-match?
(string-append "(^| )" (regexp-quote blame) " broke")
msg))
(printf "testing: ~s\n" name)
(contract-eval
`(,thunk-error-test
@ -2291,49 +2287,46 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; make-proj-contract
;; simple-contract
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(contract-eval
'(define proj:add1->sub1
(make-proj-contract
'proj:add1->sub1
(lambda (pos neg src name blame)
(simple-contract
#:name 'proj:add1->sub1
#:projection
(lambda (blame)
(lambda (f)
(unless (and (procedure? f) (procedure-arity-includes? f 1))
(raise-contract-error f src pos name
"expected a unary function, got: ~e"
f))
(raise-blame-error blame f "expected a unary function, got: ~e" f))
(lambda (x)
(unless (and (integer? x) (exact? x))
(raise-contract-error x src neg name
"expected an integer, got: ~e"
x))
(raise-blame-error (blame-swap blame) x
"expected an integer, got: ~e" x))
(let* ([y (f (add1 x))])
(unless (and (integer? y) (exact? y))
(raise-contract-error y src pos name
"expected an integer, got: ~e"
y))
(raise-blame-error blame y "expected an integer, got: ~e" y))
(sub1 y)))))
#:first-order
(lambda (f)
(and (procedure? f) (procedure-arity-includes? f 1))))))
(test/spec-passed/result
'make-proj-contract-1
'simple-contract-1
'((contract proj:add1->sub1 sqrt 'pos 'neg) 15)
3)
(test/pos-blame
'make-proj-contract-2
'simple-contract-2
'(contract proj:add1->sub1 'dummy 'pos 'neg))
(test/pos-blame
'make-proj-contract-3
'simple-contract-3
'((contract proj:add1->sub1 (lambda (x) 'dummy) 'pos 'neg) 2))
(test/neg-blame
'make-proj-contract-4
'simple-contract-4
'((contract proj:add1->sub1 sqrt 'pos 'neg) 'dummy))
;
@ -5263,12 +5256,12 @@
'(begin
(define proj:blame/c
(make-proj-contract
'proj:blame/c
(lambda (pos neg src name blame)
(simple-contract
#:name 'proj:blame/c
#:projection
(lambda (blame)
(lambda (x)
(if blame 'positive 'negative)))
(lambda (x) #t)))
(if (blame-swapped? blame) 'negative 'positive)))))
(define call*0 'dummy)
(define (call*1 x0) x0)
@ -7162,8 +7155,69 @@ so that propagation occurs.
(and (exn? x)
(regexp-match #rx"pce8-bug" (exn-message x)))))
(contract-eval `(,test 'pos guilty-party (with-handlers ((void values)) (contract not #t 'pos 'neg))))
(contract-eval
`(,test
'pos
(compose blame-positive exn:fail:contract:blame-object)
(with-handlers ((void values)) (contract not #t 'pos 'neg))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;;
;;;; Legacy Contract Constructor tests
;;;;
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; make-proj-contract
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(contract-eval
'(define proj:add1->sub1
(make-proj-contract
'proj:add1->sub1
(lambda (pos neg src name blame)
(lambda (f)
(unless (and (procedure? f) (procedure-arity-includes? f 1))
(raise-contract-error f src pos name
"expected a unary function, got: ~e"
f))
(lambda (x)
(unless (and (integer? x) (exact? x))
(raise-contract-error x src neg name
"expected an integer, got: ~e"
x))
(let* ([y (f (add1 x))])
(unless (and (integer? y) (exact? y))
(raise-contract-error y src pos name
"expected an integer, got: ~e"
y))
(sub1 y)))))
(lambda (f)
(and (procedure? f) (procedure-arity-includes? f 1))))))
(test/spec-passed/result
'make-proj-contract-1
'((contract proj:add1->sub1 sqrt 'pos 'neg) 15)
3)
(test/pos-blame
'make-proj-contract-2
'(contract proj:add1->sub1 'dummy 'pos 'neg))
(test/pos-blame
'make-proj-contract-3
'((contract proj:add1->sub1 (lambda (x) 'dummy) 'pos 'neg) 2))
(test/neg-blame
'make-proj-contract-4
'((contract proj:add1->sub1 sqrt 'pos 'neg) 'dummy))
(report-errs)
))

55
collects/tests/units/test-unit-contracts.ss
View File

@ -2,24 +2,14 @@
scheme/unit
scheme/contract)
(define temp-unit-blame #rx"(unit temp[0-9]*)")
(define temp-unit-blame-re "\\(unit temp[0-9]*\\)")
(define top-level "top-level")
(define (get-blame msg)
(cond
[(regexp-match #rx"(^| )(.*) broke" msg)
=>
(λ (x) (caddr x))]
[else (error 'test-contract-error
(format "no blame in error message: \"~a\"" msg))]))
(define (match-blame re msg)
(regexp-match? (string-append "(^| )" re " broke") msg))
(define (get-obj msg)
(cond
[(regexp-match #rx"(^| )on (.*);" msg)
=>
(λ (x) (caddr x))]
[else (error 'test-contract-error
(format "no object in error message: \"~a\"" msg))]))
(define (match-obj re msg)
(regexp-match? (string-append "(^| )on " re ";") msg))
(define (get-ctc-err msg)
(cond
@ -29,28 +19,29 @@
[else (error 'test-contract-error
(format "no specific error in message: \"~a\"" msg))]))
(define-syntax test-contract-error
(define-syntax-rule (test-contract-error blame obj err expr)
(test-contract-error/regexp
(regexp-quote blame) (regexp-quote obj) (regexp-quote err)
expr))
(define-syntax test-contract-error/regexp
(syntax-rules ()
((_ blame obj err expr)
(with-handlers ((exn:fail:contract?
(lambda (exn)
(let ([exn-blame (get-blame (exn-message exn))]
[exn-obj (get-obj (exn-message exn))])
(let ([msg (exn-message exn)])
(cond
[(and (string? blame)
(not (equal? blame exn-blame)))
(error 'test-contract-error "expected blame ~a, got ~a"
blame exn-blame)]
[(and (regexp? blame)
(not (regexp-match blame exn-blame)))
(error 'test-contract-error "expected blame ~a, got ~a"
blame exn-blame)]
[(not (equal? obj exn-obj))
(error 'test-contract-error "expected object ~a, got ~a"
obj exn-obj)]
[(not (match-blame blame msg))
(error 'test-contract-error
"blame \"~a\" not found in:~n\"~a\""
blame msg)]
[(not (match-obj obj msg))
(error 'test-contract-error
"object \"~a\" not found in:~n\"~a\""
obj msg)]
[else
(printf "contract error \"~a\" on ~a blaming ~a: ok\n\t\"~a\"\n\n"
err obj exn-blame (get-ctc-err (exn-message exn)))])))))
err obj blame (get-ctc-err msg))])))))
expr
(error 'test-contract-error
"expected contract error \"~a\" on ~a, got none"
@ -123,7 +114,7 @@
(invoke-unit (compound-unit (import) (export)
(link (((S1 : sig1)) unit1)
(() unit2 S1)))))
(test-contract-error temp-unit-blame "a" "not a number"
(test-contract-error/regexp temp-unit-blame-re "a" "not a number"
(invoke-unit (compound-unit (import) (export)
(link (((S3 : sig3) (S4 : sig4))
(unit (import) (export sig3 sig4)
@ -133,7 +124,7 @@
(define (b t) (if t 3 0))))
(() unit3 S3 S4)))))
(test-contract-error temp-unit-blame "g" "not a boolean"
(test-contract-error/regexp temp-unit-blame-re "g" "not a boolean"
(invoke-unit (compound-unit (import) (export)
(link (((S3 : sig3) (S4 : sig4))
(unit (import) (export sig3 sig4)

3
collects/typed-scheme/typecheck/tc-toplevel.ss
View File

@ -20,6 +20,7 @@
"def-binding.ss"
(for-template
"internal-forms.ss"
unstable/location
mzlib/contract
scheme/base))
@ -268,7 +269,7 @@
([the-variable-reference (generate-temporary #'blame)]
[((new-provs ...) ...) (map (generate-prov stx-defs val-defs #'the-variable-reference) provs)])
#`(begin
(define the-variable-reference (#%variable-reference))
(define the-variable-reference (quote-module-path))
#,(env-init-code)
#,(tname-env-init-code)
#,(talias-env-init-code)

14
collects/typed-scheme/utils/require-contract.ss
View File

@ -1,9 +1,11 @@
#lang scheme/base
(require scheme/contract (for-syntax scheme/base syntax/kerncase
syntax/parse
"../utils/tc-utils.ss"
(prefix-in tr: "../private/typed-renaming.ss")))
(require scheme/contract
(for-syntax scheme/base
syntax/kerncase
syntax/parse
"../utils/tc-utils.ss"
(prefix-in tr: "../private/typed-renaming.ss")))
(provide require/contract define-ignored)
@ -19,7 +21,7 @@
(define name #,(syntax-property #'e*
'inferred-name
(syntax-e #'name))))]
[(begin (begin e))
[(begin e)
#`(define name #,(syntax-property #'e
'inferred-name
(syntax-e #'name)))])]))
@ -42,6 +44,7 @@
(get-alternate nm.r)
'(interface for #,(syntax->datum #'nm))
'never-happen
(quote nm)
(quote-syntax nm))))]
[(require/contract (orig-nm:renameable nm:id) cnt lib)
#`(begin (require (only-in lib [orig-nm orig-nm.r]))
@ -50,4 +53,5 @@
(get-alternate orig-nm.r)
'#,(syntax->datum #'nm)
'never-happen
(quote nm)
(quote-syntax nm))))]))

29
collects/unstable/contract.ss
View File

@ -38,26 +38,29 @@
(if (predicate x) (then-pred x) (else-pred x)))
(flat-named-contract name pred))
;; ho contract
(let ([then-proj ((proj-get then-ctc) then-ctc)]
[then-fo ((first-order-get then-ctc) then-ctc)]
[else-proj ((proj-get else-ctc) else-ctc)]
[else-fo ((first-order-get else-ctc) else-ctc)])
(define ((proj pos neg srcinfo name pos?) x)
(let ([then-proj (contract-projection then-ctc)]
[then-fo (contract-first-order then-ctc)]
[else-proj (contract-projection else-ctc)]
[else-fo (contract-first-order else-ctc)])
(define ((proj blame) x)
(if (predicate x)
((then-proj pos neg srcinfo name pos?) x)
((else-proj pos neg srcinfo name pos?) x)))
(make-proj-contract
name
proj
((then-proj blame) x)
((else-proj blame) x)))
(simple-contract
#:name name
#:projection proj
#:first-order
(lambda (x) (if (predicate x) (then-fo x) (else-fo x))))))))
(define (rename-contract ctc name)
(let ([ctc (coerce-contract 'rename-contract ctc)])
(if (flat-contract? ctc)
(flat-named-contract name (flat-contract-predicate ctc))
(let* ([ctc-fo ((first-order-get ctc) ctc)]
[proj ((proj-get ctc) ctc)])
(make-proj-contract name proj ctc-fo)))))
(let* ([ctc-fo (contract-first-order ctc)]
[proj (contract-projection ctc)])
(simple-contract #:name name
#:projection proj
#:first-order ctc-fo)))))
(provide/contract
[non-empty-string/c contract?]

66
collects/unstable/location.ss Normal file
View File

@ -0,0 +1,66 @@
#lang scheme/base
(require (for-syntax scheme/base unstable/srcloc))
(provide quote-srcloc
quote-source-file
quote-line-number
quote-column-number
quote-character-position
quote-character-span
quote-module-path
quote-module-name)
(define-syntax (quote-srcloc stx)
(syntax-case stx ()
[(_) #`(quote-srcloc #,stx)]
[(_ loc)
(with-syntax ([(arg ...) (build-source-location-list #'loc)])
#'(make-srcloc (quote arg) ...))]))
(define-syntax (quote-source-file stx)
(syntax-case stx ()
[(_) #`(quote-source-file #,stx)]
[(_ loc) #`(quote #,(source-location-source #'loc))]))
(define-syntax (quote-line-number stx)
(syntax-case stx ()
[(_) #`(quote-line-number #,stx)]
[(_ loc) #`(quote #,(source-location-line #'loc))]))
(define-syntax (quote-column-number stx)
(syntax-case stx ()
[(_) #`(quote-column-number #,stx)]
[(_ loc) #`(quote #,(source-location-column #'loc))]))
(define-syntax (quote-character-position stx)
(syntax-case stx ()
[(_) #`(quote-character-position #,stx)]
[(_ loc) #`(quote #,(source-location-position #'loc))]))
(define-syntax (quote-character-span stx)
(syntax-case stx ()
[(_) #`(quote-character-span #,stx)]
[(_ loc) #`(quote #,(source-location-span #'loc))]))
(define-syntax-rule (quote-module-name)
(variable-reference->module-name (#%variable-reference)))
(define-syntax-rule (quote-module-path)
(variable-reference->module-path (#%variable-reference)))
(define (variable-reference->module-path var)
(module-name->module-path
(variable-reference->module-name var)))
(define (variable-reference->module-name var)
(let* ([rmp (variable-reference->resolved-module-path var)])
(if (resolved-module-path? rmp)
(resolved-module-path-name rmp)
rmp)))
(define (module-name->module-path name)
(cond
[(path? name) `(file ,(path->string name))]
[(symbol? name) `(quote ,name)]
[else 'top-level]))

12
collects/unstable/poly-c.ss
View File

@ -38,15 +38,15 @@
(define (apply/c c
#:name [name (build-compound-type-name 'apply/c c)])
(make-proj-contract
name
(lambda (pos neg src name2 positive-position?)
(simple-contract
#:name name
#:projection
(lambda (blame)
(lambda (p)
(let* ([ctc (coerce-contract 'apply/c c)]
[thunk
(lambda ()
((((proj-get ctc) ctc)
pos neg src name2 positive-position?) p))])
(((contract-projection ctc) blame) p))])
(make-keyword-procedure
(lambda (keys vals . args) (keyword-apply (thunk) keys vals args))
(case-lambda
@ -60,7 +60,7 @@
[(a b c d e f g) ((thunk) a b c d e f g)]
[(a b c d e f g h) ((thunk) a b c d e f g h)]
[args (apply (thunk) args)])))))
procedure?)))
#:first-order procedure?)))
(define-syntax (poly/c stx)
(syntax-case stx ()

42
collects/unstable/srcloc.ss
View File

@ -3,6 +3,8 @@
;; Unstable library by: Carl Eastlund <cce@ccs.neu.edu>
;; intended for use in scheme/contract, so don't try to add contracts!
(require setup/main-collects)
(provide
;; type predicates
@ -67,11 +69,11 @@
(define (source-location-end x)
(process-source-location x good-end bad! 'source-location-end))
(define (source-location->string x)
(process-source-location x good-string bad! 'source-location->string))
(define (source-location->string x [s ""])
(process-source-location x (good-string s) bad! 'source-location->string))
(define (source-location->prefix x)
(process-source-location x good-prefix bad! 'source-location->prefix))
(define (source-location->prefix x [s ""])
(process-source-location x (good-prefix s) bad! 'source-location->prefix))
(define (build-source-location . locs)
(combine-source-locations locs good-srcloc bad!
@ -124,9 +126,11 @@
[(or (list? x) (vector? x)) (datum->syntax #f null x)]
[else (datum->syntax #f null (vector src line col pos span))]))
(define (good-string x src line col pos span)
(define ((good-string default) x src line col pos span)
(format "~a~a"
(or src "")
(cond [(path? src) (collects-path src)]
[(not src) default]
[else src])
(if line
(if col
(format ":~a.~a" line col)
@ -137,8 +141,18 @@
(format "::~a" pos))
""))))
(define (good-prefix x src line col pos span)
(let ([str (good-string x src line col pos span)])
(define (collects-path path)
(let* ([rel
(with-handlers ([exn:fail? (lambda (exn) path)])
(path->main-collects-relative path))])
(if (pair? rel)
(apply build-path
(bytes->path #"<collects>")
(map bytes->path-element (cdr rel)))
rel)))
(define ((good-prefix default) x src line col pos span)
(let ([str ((good-string default) x src line col pos span)])
(if (string=? str "") "" (string-append str ": "))))
(define (combine-source-locations locs good bad name)
@ -231,12 +245,22 @@
(define (process-syntax x good bad name)
(process-elements x good bad name
(syntax-source x)
(syntax-get-source x)
(syntax-line x)
(syntax-column x)
(syntax-position x)
(syntax-span x)))
(define (syntax-get-source x)
(cond
[(syntax-source-module x) =>
(lambda (src)
(if (module-path-index? src)
(resolved-module-path-name
(module-path-index-resolve src))
src))]
[else (syntax-source x)]))
(define (process-list x good bad name)
(cond
[(null? x)

4
collects/web-server/insta/insta.ss
View File

@ -61,7 +61,7 @@
(provide/contract (#,start (request? . -> . response/c)))
(serve/servlet (contract (request? . -> . response/c) #,start
'you 'web-server
(list (make-srcloc #f #f #f #f #f)
"start"))
"start"
#f)
#:extra-files-paths (if extra-files-path (list extra-files-path) empty)
#:launch-browser? launch-browser?))))]))

10
collects/web-server/private/xexpr.ss
View File

@ -12,9 +12,10 @@
[pretty-xexpr/c contract?])
(define pretty-xexpr/c
(make-proj-contract
'pretty-xexpr/c
(lambda (pos neg src-info name)
(simple-contract
#:name 'pretty-xexpr/c
#:projection
(lambda (blame)
(lambda (val)
(define marks (current-continuation-marks))
(with-handlers ([exn:fail:contract?
@ -25,8 +26,7 @@
marks
`(span ,(drop-after "Context:\n" (exn-message exn)) "\n"
,(make-cdata #f #f (format-xexpr/errors val))))))])
(contract xexpr/c val pos neg src-info))))
(lambda (v) #t)))
(((contract-projection xexpr/c) blame) val))))))
(define (drop-after delim str)
(match (regexp-match-positions (regexp-quote delim) str)

23
collects/web-server/servlet/setup.ss
View File

@ -128,10 +128,7 @@
[neg-blame 'web-server]
[pos-blame path-sym]
[module-name `(file ,path-string)]
[mk-loc
(lambda (name)
(list (make-srcloc a-path #f #f #f #f)
name))]
[loc (make-srcloc a-path #f #f #f #f)]
[s (load/use-compiled a-path)])
(cond
[(void? s)
@ -139,47 +136,47 @@
(contract (symbols 'v1 'v2 'stateless)
(dynamic-require module-name 'interface-version)
pos-blame neg-blame
(mk-loc "interface-version"))])
"interface-version" loc)])
(case version
[(v1)
(let ([timeout (contract number?
(dynamic-require module-name 'timeout)
pos-blame neg-blame
(mk-loc "timeout"))]
"timeout" loc)]
[start (contract (request? . -> . response/c)
(dynamic-require module-name 'start)
pos-blame neg-blame
(mk-loc "start"))])
"start" loc)])
(make-v1.servlet (directory-part a-path) timeout start))]
[(v2)
(let ([start (contract (request? . -> . response/c)
(dynamic-require module-name 'start)
pos-blame neg-blame
(mk-loc "start"))]
"start" loc)]
[manager (contract manager?
(dynamic-require module-name 'manager)
pos-blame neg-blame
(mk-loc "manager"))])
"manager" loc)])
(make-v2.servlet (directory-part a-path) manager start))]
[(stateless)
(let ([start (contract (request? . -> . response/c)
(dynamic-require module-name 'start)
pos-blame neg-blame
(mk-loc "start"))]
"start" loc)]
[manager (contract manager?
(dynamic-require module-name 'manager
(lambda () (create-none-manager (lambda (req) (error "No continuations!")))))
pos-blame neg-blame
(mk-loc "manager"))]
"manager" loc)]
[stuffer (contract (stuffer/c serializable? bytes?)
(dynamic-require module-name 'stuffer (lambda () default-stuffer))
pos-blame neg-blame
(mk-loc "stuffer"))])
"stuffer" loc)])
(make-stateless.servlet (directory-part a-path) stuffer manager start))]))]
[else
(make-v1.servlet (directory-part a-path) timeouts-default-servlet
(v0.response->v1.lambda
(contract response/c s
pos-blame neg-blame
(mk-loc path-string))
path-string loc)
a-path))])))))

24
collects/web-server/stuffers/stuffer.ss
View File

@ -3,28 +3,26 @@
(define-struct stuffer (in out))
(define (stuffer/c dom rng)
(define in (dom . -> . rng))
(define in-proc (contract-proc in))
(define in-proc (contract-projection in))
(define out (rng . -> . dom))
(define out-proc (contract-proc out))
(make-proj-contract
(build-compound-type-name 'stuffer/c in out)
(λ (pos-blame neg-blame src-info orig-str positive-position?)
(define in-app (in-proc pos-blame neg-blame src-info orig-str positive-position?))
(define out-app (out-proc pos-blame neg-blame src-info orig-str positive-position?))
(define out-proc (contract-projection out))
(simple-contract
#:name (build-compound-type-name 'stuffer/c in out)
#:projection
(λ (blame)
(define in-app (in-proc blame))
(define out-app (out-proc blame))
(λ (val)
(unless (stuffer? val)
(raise-contract-error
(raise-blame-error
blame
val
src-info
pos-blame
'ignored
orig-str
"expected <stuffer>, given: ~e"
val))
(make-stuffer
(in-app (stuffer-in val))
(out-app (stuffer-out val)))))
stuffer?))
#:first-order stuffer?))
(define id-stuffer
(make-stuffer

21
collects/xml/private/structures.ss
View File

@ -58,15 +58,18 @@
(define permissive-xexprs (make-parameter #f))
(define permissive/c
(make-proj-contract 'permissive/c
(lambda (pos neg src-info name)
(lambda (v)
(if (permissive-xexprs)
v
(raise-contract-error
v src-info pos name "not in permissive mode"))))
(lambda (v)
(permissive-xexprs))))
(simple-contract
#:name 'permissive/c
#:projection
(lambda (blame)
(lambda (v)
(if (permissive-xexprs)
v
(raise-blame-error
blame v "not in permissive mode"))))
#:first-order
(lambda (v)
(permissive-xexprs))))
; content? : TST -> Bool
(define content/c

37
collects/xml/private/xexpr.ss
View File

@ -33,31 +33,30 @@
(or/c (cons/c (listof (list/c symbol? string?)) (listof xexpr))
(listof xexpr)))))
(define xexpr/c
(make-proj-contract
'xexpr?
(lambda (pos neg src-info name)
(lambda (val)
(with-handlers ([exn:invalid-xexpr?
(lambda (exn)
(raise-contract-error
val
src-info
pos
name
"Not an Xexpr. ~a~n~nContext:~n~a"
(exn-message exn)
(pretty-format val)))])
(validate-xexpr val)
val)))
(lambda (v) #t)))
(define (xexpr? x)
(correct-xexpr? x (lambda () #t) (lambda (exn) #f)))
(define (validate-xexpr x)
(correct-xexpr? x (lambda () #t) (lambda (exn) (raise exn))))
(define xexpr/c
(simple-flat-contract
#:name 'xexpr?
#:projection
(lambda (blame)
(lambda (val)
(with-handlers ([exn:invalid-xexpr?
(lambda (exn)
(raise-blame-error
blame
val
"Not an Xexpr. ~a~n~nContext:~n~a"
(exn-message exn)
(pretty-format val)))])
(validate-xexpr val)
val)))
#:first-order xexpr?))
;; ;; ;; ;; ;; ;; ;
;; ; xexpr? helpers