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

a bunch more values are now converted into contracts automatically

Browse Source 
svn: r11729
This commit is contained in:
Robby Findler 2008-09-13 22:35:09 +00:00
parent 06a4d0df4a
commit 85e489219c
9 changed files with 351 additions and 250 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/mzlib/contract.ss
View File

@ -79,3 +79,10 @@
flat-prop flat-pred? flat-get
first-order-prop first-order-get
(rename-out [or/c union]))
;; copied here because not provided by scheme/contract anymore
(define (flat-contract/predicate? pred)
(or (flat-contract? pred)
(and (procedure? pred)
(procedure-arity-includes? pred 1))))

4
collects/mzlib/scribblings/contract.scrbl
View File

@ -51,7 +51,6 @@ from @schememodname[scheme/contract]:
false/c
flat-contract
flat-contract-predicate
flat-contract/predicate?
flat-contract?
flat-murec-contract
flat-named-contract
@ -81,4 +80,5 @@ from @schememodname[scheme/contract]:
vector-immutable/c
vector-immutableof
vector/c
vectorof]
]
@scheme[vectorof]

5
collects/scheme/contract.ss
View File

@ -61,8 +61,11 @@ differences from v3:
contract-stronger?
coerce-contract/f
coerce-contract
flat-contract/predicate?
coerce-contracts
coerce-flat-contract
coerce-flat-contracts
build-compound-type-name
raise-contract-error

268
collects/scheme/private/contract-guts.ss
View File

@ -12,13 +12,18 @@
exn:fail:contract2-srclocs
contract-violation->string
coerce-contract
flat-contract/predicate?
coerce-contract
coerce-contracts
coerce-flat-contract
coerce-flat-contracts
coerce-contract/f
flat-contract?
flat-contract
flat-contract-predicate
flat-named-contract
build-flat-contract
build-compound-type-name
@ -31,7 +36,6 @@
contract-name
contract-proc
make-proj-contract
build-flat-contract
contract-stronger?
@ -66,15 +70,11 @@
(make-struct-type-property 'contract-first-order))
(define (contract-first-order-passes? c v)
(cond
[(first-order-pred? c) (((first-order-get c) c) v)]
[(and (procedure? c)
(procedure-arity-includes? c 1))
;; flat contract as a predicate
(c v)]
[(flat-pred? c) (((flat-get c) c) v)]
[else (error 'contract-first-order-passes?
"expected a contract as first argument, got ~e, other arg ~e" 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
@ -90,25 +90,66 @@
[b-ctc (coerce-contract 'contract-stronger? b)])
((stronger-get a-ctc) a-ctc b-ctc)))
;; coerce-flat-contract : symbol any/c -> contract
(define (coerce-flat-contract name x)
(let ([ctc (coerce-contract/f x)])
(unless (flat-pred? ctc)
(error name
"expected a flat contract or a value that can be coerced into one, got ~e"
x))
ctc))
;; coerce-contract : id (union contract? procedure-arity-1) -> contract
;; contract-proc = sym sym stx -> alpha -> alpha
;; returns the procedure for the contract after extracting it from the
;; struct. Coerces the argument to a flat contract if it is procedure, but first.
;; coerce-flat-contacts : symbol (listof any/c) -> (listof flat-contract)
;; like coerce-contracts, but insists on flat-contracts
(define (coerce-flat-contracts name xs)
(let loop ([xs xs]
[i 1])
(cond
[(null? xs) '()]
[else
(let ([fst (coerce-contract/f (car xs))])
(unless (flat-pred? fst)
(error name
"expected all of the arguments to be flat contracts, but argument ~a was not, got ~e"
i
(car xs)))
(cons fst (loop (cdr xs) (+ i 1))))])))
;; coerce-contract : symbol any/c -> contract
(define (coerce-contract name x)
(or (coerce-contract/f x)
(error name
"expected contract or a value that can be coerced into one, got ~e"
x)))
;; coerce-contracts : symbols (listof any) -> (listof contract)
;; turns all of the arguments in 'xs' into contracts
;; the error messages assume that the function named by 'name'
;; got 'xs' as it argument directly
(define (coerce-contracts name xs)
(let loop ([xs xs]
[i 1])
(cond
[(null? xs) '()]
[(coerce-contract/f (car xs)) => (λ (x) (cons x (loop (cdr xs) (+ i 1))))]
[else
(error name
"expected all of the arguments to be contracts, but argument ~a was not, got ~e"
i
(car xs))])))
;; coerce-contract/f : any -> (or/c #f contract?)
;; returns #f if the argument could not be coerced to a contract
(define (coerce-contract/f x)
(cond
[(contract? x) x]
[(and (procedure? x) (procedure-arity-includes? x 1))
(flat-contract x)]
;[(symbol? x) (symbol-contract x)]
;[(char? x) (char-contract x)]
;[(boolean? x) (boolean-contract x)]
;[(regexp? x) (regexp-contract x)]
;[(string? x) (string-contract x)]
[else
(error name
"expected contract or a value that can be coerced into one, got ~e"
x)]))
(make-predicate-contract (or (object-name x) '???) x)]
[(or (symbol? x) (boolean? x) (char? x)) (make-eq-contract x)]
[(string? x) (make-equal-contract x)]
[(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?
@ -274,8 +315,7 @@
(define (double-any-curred-proj2 pos-blame neg-blame src-info orig-str) values)
(define-values (make-flat-contract
make-proj-contract)
(define-values (make-proj-contract)
(let ()
(define-struct proj-contract (the-name proj first-order-proc)
#:property proj-prop
@ -294,56 +334,30 @@
(proj-contract-proj this)
(proj-contract-proj that)))))
(define-struct flat-contract (the-name predicate)
#:property proj-prop flat-proj
#:property stronger-prop
(λ (this that)
(and (flat-contract? that)
(procedure-closure-contents-eq? (flat-contract-predicate this)
(flat-contract-predicate that))))
#:property name-prop (λ (ctc) (flat-contract-the-name ctc))
#:property flat-prop (λ (ctc) (flat-contract-predicate ctc)))
(values make-flat-contract
make-proj-contract)))
(values make-proj-contract)))
(define (flat-contract-predicate x)
(unless (flat-contract? x)
(error 'flat-contract-predicate "expected a flat contract, got ~e" x))
((flat-get x) x))
(define (flat-contract? x) (flat-pred? x))
(let ([ctc (coerce-flat-contract 'flat-contract-predicate x)])
((flat-get ctc) ctc)))
(define (flat-contract? x)
(let ([c (coerce-contract/f x)])
(and c
(flat-pred? c))))
(define (contract-name ctc)
(if (and (procedure? ctc)
(procedure-arity-includes? ctc 1))
(or (object-name ctc)
'unknown)
((name-get ctc) ctc)))
(let ([ctc (coerce-contract 'contract-name ctc)])
((name-get ctc) ctc)))
(define (contract? x) (proj-pred? x))
(define (contract-proc ctc) ((proj-get ctc) ctc))
(define (check-flat-contract predicate)
(unless (and (procedure? predicate)
(procedure-arity-includes? predicate 1))
(error 'flat-contract
"expected procedure of arity 1 as argument, given ~e"
predicate)))
(define (flat-contract predicate)
(check-flat-contract predicate)
(let ([pname (object-name predicate)])
(if pname
(flat-named-contract pname predicate)
(flat-named-contract '??? predicate))))
(define (check-flat-named-contract predicate)
(unless (and (procedure? predicate)
(procedure-arity-includes? predicate 1))
(error 'flat-named-contract
"expected procedure of arity 1 as second argument, given ~e"
predicate)))
(define (check-flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
(define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
(define (check-flat-named-contract predicate) (coerce-flat-contract 'flat-named-contract predicate))
(define (flat-named-contract name predicate)
(check-flat-named-contract predicate)
(build-flat-contract name predicate))
(define (build-flat-contract name predicate) (make-flat-contract name predicate))
(coerce-flat-contract 'flat-named-contract predicate)
(make-predicate-contract name predicate))
;; build-compound-type-name : (union contract symbol) ... -> (-> sexp)
(define (build-compound-type-name . fs)
@ -390,37 +404,23 @@
this-ctcs
that-ctcs))))))
(define (and/c . fs)
(for-each
(lambda (x)
(unless (or (contract? x)
(and (procedure? x)
(procedure-arity-includes? x 1)))
(error 'and/c "expected procedures of arity 1 or <contract>s, given: ~e" x)))
fs)
(cond
[(null? fs) any/c]
[(andmap flat-contract/predicate? fs)
(let* ([to-predicate
(lambda (x)
(if (flat-contract? x)
(flat-contract-predicate x)
x))]
[contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)]
[pred
(let loop ([pred (to-predicate (car fs))]
[preds (cdr fs)])
(cond
[(null? preds) pred]
[else
(let* ([fst (to-predicate (car preds))])
(loop (let ([and/c-contract? (lambda (x) (and (pred x) (fst x)))])
and/c-contract?)
(cdr preds)))]))])
(flat-named-contract (apply build-compound-type-name 'and/c contracts) pred))]
[else
(let ([contracts (map (lambda (x) (if (contract? x) x (flat-contract x))) fs)])
(make-and/c contracts))]))
(define (and/c . raw-fs)
(let ([contracts (coerce-contracts 'and/c raw-fs)])
(cond
[(null? contracts) any/c]
[(andmap flat-contract? contracts)
(let* ([pred
(let loop ([pred (flat-contract-predicate (car contracts))]
[preds (cdr contracts)])
(cond
[(null? preds) pred]
[else
(let* ([fst (flat-contract-predicate (car preds))])
(loop (let ([and/c-contract? (lambda (x) (and (pred x) (fst x)))])
and/c-contract?)
(cdr preds)))]))])
(flat-named-contract (apply build-compound-type-name 'and/c contracts) pred))]
[else (make-and/c contracts)])))
(define-struct any/c ()
#:omit-define-syntaxes
@ -454,7 +454,63 @@
(define none/c (make-none/c 'none/c))
(define (flat-contract/predicate? pred)
(or (flat-contract? pred)
(and (procedure? pred)
(procedure-arity-includes? pred 1))))
;
;
;
;
; ; ;;; ; ;
; ;;; ;;; ;;;
; ;;;;; ;;;;; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;;;; ;;; ;;;;;;; ;;; ;;;;; ;;;;
; ;;;;;;;;;;;; ;;;;; ;;;;;;;;;;; ;;; ;;;;; ;;;;; ;;;;; ;;;;;;;;;;;; ;;;;;;;;;;;; ;;;;; ;;;;; ;;; ;;
; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;; ;; ;;; ;;;
; ;;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;; ;;; ;;; ;;;;
; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;; ;;;
; ;;; ;;; ;;;; ;;;;; ;;; ;;; ;;; ;;; ;;;;; ;;;;; ;;;;; ;;; ;;; ;;;; ;;; ;;; ;;; ;;;;; ;;;; ;; ;;;
; ;;;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;; ;;; ;;; ;;;;
;
;
;
;
(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)))))
(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)))))
(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)))))
(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)))))
(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)))
(define (build-flat-contract name pred) (make-predicate-contract name pred))

201
collects/scheme/private/contract.ss
View File

@ -690,15 +690,7 @@ improve method arity mismatch contract violation error messages?
(define-syntax (verify-contract stx)
(syntax-case stx ()
[(_ x) (a:known-good-contract? #'x) #'x]
[(_ x) #'(verify-contract/proc x)]))
(define (verify-contract/proc x)
(unless (or (contract? x)
(and (procedure? x)
(procedure-arity-includes? x 1)))
(error 'provide/contract "expected a contract or a procedure of arity one, got ~e" x))
x)
[(_ x) #'(coerce-contract 'provide/contract x)]))
(define (make-pc-struct-type struct-name struct:struct-name . ctcs)
(let-values ([(struct:struct-name _make _pred _get _set)
@ -727,19 +719,6 @@ improve method arity mismatch contract violation error messages?
vals)))))])
struct:struct-name))
(define (test-proc/flat-contract f x)
(if (flat-contract? f)
((flat-contract-predicate f) x)
(f x)))
(define (proc/ctc->ctc f)
(if (contract? f)
f
(flat-named-contract
(or (object-name f)
(string->symbol (format "contract:~e" f)))
f)))
(define-syntax (-contract stx)
(syntax-case stx ()
[(_ a-contract to-check pos-blame-e neg-blame-e)
@ -891,53 +870,40 @@ improve method arity mismatch contract violation error messages?
(define or/c
(case-lambda
[() (make-none/c '(or/c))]
[args
(for-each
(λ (x)
(unless (or (contract? x)
(and (procedure? x)
(procedure-arity-includes? x 1)))
(error 'or/c "expected procedures of arity 1 or contracts, given: ~e" x)))
args)
(let-values ([(ho-contracts fc/predicates)
(let loop ([ho-contracts '()]
[fc/predicates null]
[args args])
(cond
[(null? args) (values ho-contracts (reverse fc/predicates))]
[else
(let ([arg (car args)])
(cond
[(and (contract? arg)
(not (flat-contract? arg)))
(loop (cons arg ho-contracts) fc/predicates (cdr args))]
[else
(loop ho-contracts (cons arg fc/predicates) (cdr args))]))]))])
(let ([flat-contracts (map (λ (x) (if (flat-contract? x)
x
(flat-contract x)))
fc/predicates)]
[pred
(cond
[(null? fc/predicates) not]
[else
(let loop ([fst (car fc/predicates)]
[rst (cdr fc/predicates)])
(let ([fst-pred (if (flat-contract? fst)
((flat-get fst) fst)
fst)])
(cond
[(null? rst) fst-pred]
[else
(let ([r (loop (car rst) (cdr rst))])
(λ (x) (or (fst-pred x) (r x))))])))])])
(cond
[(null? ho-contracts)
(make-flat-or/c pred flat-contracts)]
[(null? (cdr ho-contracts))
(make-or/c pred flat-contracts (car ho-contracts))]
[else
(make-multi-or/c flat-contracts ho-contracts)])))]))
[raw-args
(let ([args (coerce-contracts 'or/c raw-args)])
(let-values ([(ho-contracts flat-contracts)
(let loop ([ho-contracts '()]
[flat-contracts '()]
[args args])
(cond
[(null? args) (values ho-contracts (reverse flat-contracts))]
[else
(let ([arg (car args)])
(cond
[(flat-contract? arg)
(loop ho-contracts (cons arg flat-contracts) (cdr args))]
[else
(loop (cons arg ho-contracts) flat-contracts (cdr args))]))]))])
(let ([pred
(cond
[(null? flat-contracts) not]
[else
(let loop ([fst (car flat-contracts)]
[rst (cdr flat-contracts)])
(let ([fst-pred (flat-contract-predicate fst)])
(cond
[(null? rst) fst-pred]
[else
(let ([r (loop (car rst) (cdr rst))])
(λ (x) (or (fst-pred x) (r x))))])))])])
(cond
[(null? ho-contracts)
(make-flat-or/c pred flat-contracts)]
[(null? (cdr ho-contracts))
(make-or/c pred flat-contracts (car ho-contracts))]
[else
(make-multi-or/c flat-contracts ho-contracts)]))))]))
(define-struct or/c (pred flat-ctcs ho-ctc)
#:omit-define-syntaxes
@ -962,11 +928,11 @@ improve method arity mismatch contract violation error messages?
#:property first-order-prop
(λ (ctc)
(let ([flats (map (λ (x) ((flat-get x) x)) (or/c-flat-ctcs 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)
(ormap (λ (f) (f x)) flats)))))
(pred x)))))
#:property stronger-prop
(λ (this that)
@ -983,8 +949,7 @@ improve method arity mismatch contract violation error messages?
(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)]
[predicates (map (λ (x) ((flat-get x) x))
(multi-or/c-flat-ctcs ctc))])
[predicates (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))])
(λ (pos-blame neg-blame src-info orig-str)
(let ([partial-contracts (map (λ (c-proc) (c-proc pos-blame neg-blame src-info orig-str)) c-procs)])
(λ (val)
@ -1033,7 +998,7 @@ improve method arity mismatch contract violation error messages?
#:property first-order-prop
(λ (ctc)
(let ([flats (map (λ (x) ((flat-get x) x)) (multi-or/c-flat-ctcs 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)
@ -1196,10 +1161,7 @@ improve method arity mismatch contract violation error messages?
[(or/c p ...)
(opt/or-ctc (syntax->list (syntax (p ...))))]))
(define false/c
(flat-named-contract
'false/c
(λ (x) (not x))))
(define false/c #f)
(define (string-len/c n)
(unless (number? n)
@ -1527,11 +1489,11 @@ improve method arity mismatch contract violation error messages?
(<= start x end)))))
(define (not/c f)
(unless (flat-contract/predicate? f)
(error 'not/c "expected a procedure of arity 1 or <flat-named-contract>, given: ~e" f))
(build-flat-contract
(build-compound-type-name 'not/c (proc/ctc->ctc f))
(λ (x) (not (test-proc/flat-contract f x)))))
(let* ([ctc (coerce-flat-contract 'not/c f)]
[pred (flat-contract-predicate ctc)])
(build-flat-contract
(build-compound-type-name 'not/c ctc)
(λ (x) (not (pred x))))))
(define-syntax (*-immutableof stx)
(syntax-case stx ()
@ -1577,43 +1539,35 @@ improve method arity mismatch contract violation error messages?
vector-immutableof))
(define (vectorof p)
(unless (flat-contract/predicate? p)
(error 'vectorof "expected a flat contract or procedure of arity 1 as argument, got: ~e" p))
(build-flat-contract
(build-compound-type-name 'vectorof (proc/ctc->ctc p))
(λ (v)
(and (vector? v)
(andmap (λ (ele) (test-proc/flat-contract p ele))
(vector->list v))))))
(let* ([ctc (coerce-flat-contract 'vectorof p)]
[pred (flat-contract-predicate ctc)])
(build-flat-contract
(build-compound-type-name 'vectorof ctc)
(λ (v)
(and (vector? v)
(andmap pred (vector->list v)))))))
(define (vector/c . args)
(unless (andmap flat-contract/predicate? args)
(error 'vector/c "expected flat contracts as arguments, got: ~a"
(let loop ([args args])
(cond
[(null? args) ""]
[(null? (cdr args)) (format "~e" (car args))]
[else (string-append
(format "~e " (car args))
(loop (cdr args)))]))))
(let ([largs (length args)])
(let* ([ctcs (coerce-flat-contracts 'vector/c args)]
[largs (length args)]
[procs (map flat-contract-predicate ctcs)])
(build-flat-contract
(apply build-compound-type-name 'vector/c (map proc/ctc->ctc args))
(apply build-compound-type-name 'vector/c ctcs)
(λ (v)
(and (vector? v)
(= (vector-length v) largs)
(andmap test-proc/flat-contract
args
(andmap (λ (p? x) (p? x))
procs
(vector->list v)))))))
(define (box/c pred)
(unless (flat-contract/predicate? pred)
(error 'box/c "expected a flat contract or a procedure of arity 1, got: ~e" pred))
(build-flat-contract
(build-compound-type-name 'box/c (proc/ctc->ctc pred))
(λ (x)
(and (box? x)
(test-proc/flat-contract pred (unbox x))))))
(let* ([ctc (coerce-flat-contract 'box/c pred)]
[p? (flat-contract-predicate ctc)])
(build-flat-contract
(build-compound-type-name 'box/c ctc)
(λ (x)
(and (box? x)
(p? (unbox x)))))))
;;
;; cons/c opter
@ -1680,6 +1634,13 @@ improve method arity mismatch contract violation error messages?
[(cons/c hdp tlp)
(opt/cons-ctc #'hdp #'tlp)]))
;; only used by the opters
(define (flat-contract/predicate? pred)
(or (flat-contract? pred)
(and (procedure? pred)
(procedure-arity-includes? pred 1))))
(define-syntax (*-immutable/c stx)
(syntax-case stx ()
[(_ predicate? constructor (arb? selectors ...) type-name name)
@ -1708,7 +1669,7 @@ improve method arity mismatch contract violation error messages?
...))))
(let ([procs (contract-proc ctc-x)] ...)
(make-proj-contract
(build-compound-type-name 'name (proc/ctc->ctc params) ...)
(build-compound-type-name 'name ctc-x ...)
(λ (pos-blame neg-blame src-info orig-str)
(let ([p-apps (procs pos-blame neg-blame src-info orig-str)] ...)
(λ (v)
@ -1738,7 +1699,7 @@ improve method arity mismatch contract violation error messages?
(let ([ctcs (map (λ (param) (coerce-contract 'name param)) params)])
(let ([procs (map contract-proc ctcs)])
(make-proj-contract
(apply build-compound-type-name 'name (map proc/ctc->ctc params))
(apply build-compound-type-name 'name ctcs)
(λ (pos-blame neg-blame src-info orig-str)
(let ([p-apps (map (λ (proc) (proc pos-blame neg-blame src-info orig-str)) procs)]
[count (length params)])
@ -1821,19 +1782,7 @@ improve method arity mismatch contract violation error messages?
[(_ hdp tlp) (opt/cons-ctc #'hdp #'tlp)]))
(define (list/c . args)
(unless (andmap (λ (x) (or (contract? x)
(and (procedure? x)
(procedure-arity-includes? x 1))))
args)
(error 'list/c "expected contracts or procedures of arity 1, got: ~a"
(let loop ([args args])
(cond
[(null? args) ""]
[(null? (cdr args)) (format "~e" (car args))]
[else (string-append
(format "~e " (car args))
(loop (cdr args)))]))))
(let loop ([args args])
(let loop ([args (coerce-contracts 'list/c args)])
(cond
[(null? args) (flat-contract null?)]
[else (cons/c (car args) (loop (cdr args)))])))

17
collects/scribblings/guide/contracts-simple-function.scrbl
View File

@ -276,6 +276,23 @@ scheme
]
@ctc-section[#:tag "coercion"]{Contracts coerced from other values}
The contract library treates a number of Scheme values as if they are
contracts directly. We've already seen one main use of that: predicates. Every
function that accepts one argument can be treated as a predicate
and thus used as a contract.
But many other values also play double duty as contracts.
For example, if your function accepts a number or @scheme[#f],
@scheme[(or/c number? #f)] sufficies. Similarly, the @scheme[result/c] contract
could have been written with a @scheme[0] in place of @scheme[zero?].
Even better, if you use a regular expression as a contract, the contract
accepts strings that match the regular expression. For example,
the @scheme[is-decimal-string?] predicate could have been written
@scheme[#rx"[0-9]*\\.[0-9][0-9][0-9]"].
@ctc-section{Contracts on Higher-order Functions}
Function contracts are not just restricted to having simple

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

@ -14,6 +14,11 @@ expectations of one party are met by another party. The
@scheme[provide/contract] form is the primary mechanism for
associating a contract with a binding.
Note that all of the combinators that accept contracts as arguments
use @scheme[coerce-contract], meaning that symbols, booleans, strings,
characters, numbers, regular expressions, and predicates are all
implicitly converted into contracts.
@note-lib[scheme/contract #:use-sources (scheme/private/contract-ds
scheme/private/contract
scheme/private/contract-guts)]
@ -33,7 +38,7 @@ Constructs a @tech{flat contract} from @scheme[predicate]. A value
satisfies the contract if the predicate returns a true value.}
@defproc[(flat-named-contract [type-name string?][predicate (any/c . -> . any/c)])
@defproc[(flat-named-contract [type-name string?][predicate (any/c . -> . any)])
flat-contract?]{
Like @scheme[flat-contract], but the first argument must be a string
@ -154,7 +159,7 @@ Returns a flat contract that recognizes strings that have fewer than
@defthing[false/c flat-contract?]{
A flat contract that recognizes @scheme[#f].}
This is just @scheme[#f]. It is here for backwards compatibility.}
@defthing[printable/c flat-contract?]{
@ -898,18 +903,44 @@ for a contract. The arguments should be either contracts or
symbols. It wraps parenthesis around its arguments and
extracts the names from any contracts it is supplied with.}
@defform[(coerce-contract id expr)]{
@defproc[(coerce-contract [id symbol?] [x any/c]) contract?]{
Evaluates @scheme[expr] and, if the result is a
contract, just returns it. If the result is a procedure of arity
one, it converts that into a contract. If the result is neither, it
If @scheme[x] is a contract, it returns it. If it is a procedure of
arity one, it converts that into a contract by treating the result as
a predicate. If it is a symbol, boolean, or character, it makes a
contract that accepts values that are @scheme[eq?] to @scheme[x]. If
@scheme[x] is a string, it makes a contract that accespts values that
are @scheme[equal?] to @scheme[x]. If @scheme[x] is a regular
expression or a byte regular expression, it makes a contract that
accepts strings and bytes, as long as they match the regular
expression.
If @scheme[x] is none of the above, @scheme[coerce-contract]
signals an error, using the first argument in the error
message. The message says that a contract or a procedure of
arity one was expected.}
message.}
@defproc[(flat-contract/predicate? [val any/c]) boolean?]{
@defproc[(coerce-contracts [id symbol?] [xs (listof any/c)]) (listof contract?)]{
A predicate that indicates when @scheme[coerce-contract] will fail.}
Coerces all of the arguments in 'xs' into contracts (via
@scheme[coerce-contract/f]) and signals an error if any of them are not
contracts. The error messages assume that the function named by
@scheme[id] got @scheme[xs] as its entire argument list.
}
@defproc[(coerce-flat-contract [id symbol?] [x any/c]) flat-contract?]{
Like @scheme[coerce-contract], but requires the result
to be a flat contract, not an arbitrary contract.
}
@defproc[(coerce-flat-contracts [id symbol?] [x (listof any/c)]) (listof/c flat-contract?)]{
Like @scheme[coerce-contracts], but requires the results
to be flat contracts, not arbitrary contracts.
}
@defproc[(coerce-contract/f [x any/c]) (or/c contract? #f)]{
Like @scheme[coerce-contract], but returns @scheme[#f] if
the value cannot be coerced to a contract.
}
@defproc[(raise-contract-error [val any/c]
[src-info any/c]
@ -987,7 +1018,7 @@ name @scheme[sexp-name] when signaling a contract violation.}
@defparam[contract-violation->string
proc
(-> any/c any/c (or/c false/c any/c) any/c string? string?)]{
(-> any/c any/c (or/c #f any/c) any/c string? string?)]{
This is a parameter that is used when constructing a
contract violation error. Its value is procedure that

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

@ -4162,7 +4162,7 @@ so that propagation occurs.
(test-name '(real-in 1 10) (real-in 1 10))
(test-name '(string-len/c 3) (string/len 3))
(test-name 'natural-number/c natural-number/c)
(test-name 'false/c false/c)
(test-name #f false/c)
(test-name 'printable/c printable/c)
(test-name '(symbols 'a 'b 'c) (symbols 'a 'b 'c))
(test-name '(one-of/c 1 2 3) (one-of/c 1 2 3))

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

@ -190,6 +190,9 @@
(test/no-error '(listof (lambda (x) #t)))
(test/no-error '(list/c 'x "x" #t #f #\c #rx"a" #rx#"b"))
;
;
@ -4522,6 +4525,22 @@ so that propagation occurs.
(test-flat-contract '(string-len/c 3) "ab" "abc")
(test-flat-contract 'natural-number/c 5 -1)
(test-flat-contract 'false/c #f #t)
(test-flat-contract #t #t "x")
(test-flat-contract #f #f "x")
(test-flat-contract #\a #\a #\b)
(test-flat-contract #\a #\a 'a)
(test-flat-contract ''a 'a 'b)
(test-flat-contract ''a 'a #\a)
(test-flat-contract "x" "x" "y")
(test-flat-contract "x" "x" 'x)
(test-flat-contract 1 1 2)
(test-flat-contract #e1 #i1.0 'x)
(test-flat-contract #rx".x." "axq" "x")
(test-flat-contract #rx#".x." #"axq" #"x")
(test-flat-contract #rx".x." #"axq" #"x")
(test-flat-contract #rx#".x." "axq" "x")
(test/spec-passed 'any/c '(contract any/c 1 'pos 'neg))
(test-flat-contract 'printable/c (vector (cons 1 (box #f))) (lambda (x) x))
(let ()
@ -4590,6 +4609,10 @@ so that propagation occurs.
(contract-eval '(flat-murec-contract ([x y])))
'no-err))
;; test flat-contract-predicate
(test #t (flat-contract-predicate integer?) 1)
(test #t (flat-contract-predicate #t) #t)
;
;
@ -4739,13 +4762,22 @@ so that propagation occurs.
(test-name '(real-in 1 10) (real-in 1 10))
(test-name '(string-len/c 3) (string-len/c 3))
(test-name 'natural-number/c natural-number/c)
(test-name 'false/c false/c)
(test-name #f false/c)
(test-name #t #t)
(test-name #\a #\a)
(test-name "x" "x")
(test-name ''x 'x)
;(test-name #rx"x" #rx"x") ;; commented out because regexps don't compare via equal?
;(test-name #rx#"x" #rx#"x") ;; commented out because regexps don't compare via equal?
(test-name 'printable/c printable/c)
(test-name '(symbols 'a 'b 'c) (symbols 'a 'b 'c))
(test-name '(one-of/c 1 2 3) (one-of/c 1 2 3))
(test-name '(one-of/c '() 'x 1 #f #\a (void) (letrec ([x x]) x))
(one-of/c '() 'x 1 #f #\a (void) (letrec ([x x]) x)))
(test-name '(or/c #f #t #\a "x") (or/c #f #t #\a "x"))
;(test-name '(or/c #f #t #\a "x" #rx"x" #rx#"x") (or/c #f #t #\a "x" #rx"x" #rx#"x")) ;; commented out because regexps don't compare via equal?
(test-name '(subclass?/c class:c%)
(let ([c% (class object% (super-new))]) (subclass?/c c%)))
@ -5134,6 +5166,12 @@ so that propagation occurs.
(with-continuation-mark 'x 'x
(f 1))))
(ctest #t contract-first-order-passes? (or/c 'x "x" #rx"x") 'x)
(ctest #t contract-first-order-passes? (or/c 'x "x" #rx"x") "x")
(ctest #t contract-first-order-passes? (or/c 'x "x" #rx"x.") "xy")
(ctest #f contract-first-order-passes? (or/c 'x "x" #rx"x.") "yx")
(ctest #f contract-first-order-passes? (or/c 'x "x" #rx"x.") 'y)
;
;
;