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 flat-prop flat-pred? flat-get
first-order-prop first-order-get first-order-prop first-order-get
(rename-out [or/c union])) (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 false/c
flat-contract flat-contract
flat-contract-predicate flat-contract-predicate
flat-contract/predicate?
flat-contract? flat-contract?
flat-murec-contract flat-murec-contract
flat-named-contract flat-named-contract
@ -81,4 +80,5 @@ from @schememodname[scheme/contract]:
vector-immutable/c vector-immutable/c
vector-immutableof vector-immutableof
vector/c vector/c
vectorof] ]
@scheme[vectorof]

5
collects/scheme/contract.ss
View File

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

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

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

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

@ -690,15 +690,7 @@ improve method arity mismatch contract violation error messages?
(define-syntax (verify-contract stx) (define-syntax (verify-contract stx)
(syntax-case stx () (syntax-case stx ()
[(_ x) (a:known-good-contract? #'x) #'x] [(_ x) (a:known-good-contract? #'x) #'x]
[(_ x) #'(verify-contract/proc x)])) [(_ x) #'(coerce-contract 'provide/contract 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)
(define (make-pc-struct-type struct-name struct:struct-name . ctcs) (define (make-pc-struct-type struct-name struct:struct-name . ctcs)
(let-values ([(struct:struct-name _make _pred _get _set) (let-values ([(struct:struct-name _make _pred _get _set)
@ -727,19 +719,6 @@ improve method arity mismatch contract violation error messages?
vals)))))]) vals)))))])
struct:struct-name)) 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) (define-syntax (-contract stx)
(syntax-case stx () (syntax-case stx ()
[(_ a-contract to-check pos-blame-e neg-blame-e) [(_ a-contract to-check pos-blame-e neg-blame-e)
@ -891,41 +870,28 @@ improve method arity mismatch contract violation error messages?
(define or/c (define or/c
(case-lambda (case-lambda
[() (make-none/c '(or/c))] [() (make-none/c '(or/c))]
[args [raw-args
(for-each (let ([args (coerce-contracts 'or/c raw-args)])
(λ (x) (let-values ([(ho-contracts flat-contracts)
(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 '()] (let loop ([ho-contracts '()]
[fc/predicates null] [flat-contracts '()]
[args args]) [args args])
(cond (cond
[(null? args) (values ho-contracts (reverse fc/predicates))] [(null? args) (values ho-contracts (reverse flat-contracts))]
[else [else
(let ([arg (car args)]) (let ([arg (car args)])
(cond (cond
[(and (contract? arg) [(flat-contract? arg)
(not (flat-contract? arg))) (loop ho-contracts (cons arg flat-contracts) (cdr args))]
(loop (cons arg ho-contracts) fc/predicates (cdr args))]
[else [else
(loop ho-contracts (cons arg fc/predicates) (cdr args))]))]))]) (loop (cons arg ho-contracts) flat-contracts (cdr args))]))]))])
(let ([flat-contracts (map (λ (x) (if (flat-contract? x) (let ([pred
x
(flat-contract x)))
fc/predicates)]
[pred
(cond (cond
[(null? fc/predicates) not] [(null? flat-contracts) not]
[else [else
(let loop ([fst (car fc/predicates)] (let loop ([fst (car flat-contracts)]
[rst (cdr fc/predicates)]) [rst (cdr flat-contracts)])
(let ([fst-pred (if (flat-contract? fst) (let ([fst-pred (flat-contract-predicate fst)])
((flat-get fst) fst)
fst)])
(cond (cond
[(null? rst) fst-pred] [(null? rst) fst-pred]
[else [else
@ -937,7 +903,7 @@ improve method arity mismatch contract violation error messages?
[(null? (cdr ho-contracts)) [(null? (cdr ho-contracts))
(make-or/c pred flat-contracts (car ho-contracts))] (make-or/c pred flat-contracts (car ho-contracts))]
[else [else
(make-multi-or/c flat-contracts ho-contracts)])))])) (make-multi-or/c flat-contracts ho-contracts)]))))]))
(define-struct or/c (pred flat-ctcs ho-ctc) (define-struct or/c (pred flat-ctcs ho-ctc)
#:omit-define-syntaxes #:omit-define-syntaxes
@ -962,11 +928,11 @@ improve method arity mismatch contract violation error messages?
#:property first-order-prop #:property first-order-prop
(λ (ctc) (λ (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))]) [ho ((first-order-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))])
(λ (x) (λ (x)
(or (ho x) (or (ho x)
(ormap (λ (f) (f x)) flats))))) (pred x)))))
#:property stronger-prop #:property stronger-prop
(λ (this that) (λ (this that)
@ -983,8 +949,7 @@ improve method arity mismatch contract violation error messages?
(let* ([ho-contracts (multi-or/c-ho-ctcs ctc)] (let* ([ho-contracts (multi-or/c-ho-ctcs ctc)]
[c-procs (map (λ (x) ((proj-get x) x)) ho-contracts)] [c-procs (map (λ (x) ((proj-get x) x)) ho-contracts)]
[first-order-checks (map (λ (x) ((first-order-get x) x)) ho-contracts)] [first-order-checks (map (λ (x) ((first-order-get x) x)) ho-contracts)]
[predicates (map (λ (x) ((flat-get x) x)) [predicates (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))])
(multi-or/c-flat-ctcs ctc))])
(λ (pos-blame neg-blame src-info orig-str) (λ (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)]) (let ([partial-contracts (map (λ (c-proc) (c-proc pos-blame neg-blame src-info orig-str)) c-procs)])
(λ (val) (λ (val)
@ -1033,7 +998,7 @@ improve method arity mismatch contract violation error messages?
#:property first-order-prop #:property first-order-prop
(λ (ctc) (λ (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))]) [hos (map (λ (x) ((first-order-get x) x)) (multi-or/c-ho-ctcs ctc))])
(λ (x) (λ (x)
(or (ormap (λ (f) (f x)) hos) (or (ormap (λ (f) (f x)) hos)
@ -1196,10 +1161,7 @@ improve method arity mismatch contract violation error messages?
[(or/c p ...) [(or/c p ...)
(opt/or-ctc (syntax->list (syntax (p ...))))])) (opt/or-ctc (syntax->list (syntax (p ...))))]))
(define false/c (define false/c #f)
(flat-named-contract
'false/c
(λ (x) (not x))))
(define (string-len/c n) (define (string-len/c n)
(unless (number? n) (unless (number? n)
@ -1527,11 +1489,11 @@ improve method arity mismatch contract violation error messages?
(<= start x end))))) (<= start x end)))))
(define (not/c f) (define (not/c f)
(unless (flat-contract/predicate? f) (let* ([ctc (coerce-flat-contract 'not/c f)]
(error 'not/c "expected a procedure of arity 1 or <flat-named-contract>, given: ~e" f)) [pred (flat-contract-predicate ctc)])
(build-flat-contract (build-flat-contract
(build-compound-type-name 'not/c (proc/ctc->ctc f)) (build-compound-type-name 'not/c ctc)
(λ (x) (not (test-proc/flat-contract f x))))) (λ (x) (not (pred x))))))
(define-syntax (*-immutableof stx) (define-syntax (*-immutableof stx)
(syntax-case stx () (syntax-case stx ()
@ -1577,43 +1539,35 @@ improve method arity mismatch contract violation error messages?
vector-immutableof)) vector-immutableof))
(define (vectorof p) (define (vectorof p)
(unless (flat-contract/predicate? p) (let* ([ctc (coerce-flat-contract 'vectorof p)]
(error 'vectorof "expected a flat contract or procedure of arity 1 as argument, got: ~e" p)) [pred (flat-contract-predicate ctc)])
(build-flat-contract (build-flat-contract
(build-compound-type-name 'vectorof (proc/ctc->ctc p)) (build-compound-type-name 'vectorof ctc)
(λ (v) (λ (v)
(and (vector? v) (and (vector? v)
(andmap (λ (ele) (test-proc/flat-contract p ele)) (andmap pred (vector->list v)))))))
(vector->list v))))))
(define (vector/c . args) (define (vector/c . args)
(unless (andmap flat-contract/predicate? args) (let* ([ctcs (coerce-flat-contracts 'vector/c args)]
(error 'vector/c "expected flat contracts as arguments, got: ~a" [largs (length args)]
(let loop ([args args]) [procs (map flat-contract-predicate ctcs)])
(cond
[(null? args) ""]
[(null? (cdr args)) (format "~e" (car args))]
[else (string-append
(format "~e " (car args))
(loop (cdr args)))]))))
(let ([largs (length args)])
(build-flat-contract (build-flat-contract
(apply build-compound-type-name 'vector/c (map proc/ctc->ctc args)) (apply build-compound-type-name 'vector/c ctcs)
(λ (v) (λ (v)
(and (vector? v) (and (vector? v)
(= (vector-length v) largs) (= (vector-length v) largs)
(andmap test-proc/flat-contract (andmap (λ (p? x) (p? x))
args procs
(vector->list v))))))) (vector->list v)))))))
(define (box/c pred) (define (box/c pred)
(unless (flat-contract/predicate? pred) (let* ([ctc (coerce-flat-contract 'box/c pred)]
(error 'box/c "expected a flat contract or a procedure of arity 1, got: ~e" pred)) [p? (flat-contract-predicate ctc)])
(build-flat-contract (build-flat-contract
(build-compound-type-name 'box/c (proc/ctc->ctc pred)) (build-compound-type-name 'box/c ctc)
(λ (x) (λ (x)
(and (box? x) (and (box? x)
(test-proc/flat-contract pred (unbox x)))))) (p? (unbox x)))))))
;; ;;
;; cons/c opter ;; cons/c opter
@ -1680,6 +1634,13 @@ improve method arity mismatch contract violation error messages?
[(cons/c hdp tlp) [(cons/c hdp tlp)
(opt/cons-ctc #'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) (define-syntax (*-immutable/c stx)
(syntax-case stx () (syntax-case stx ()
[(_ predicate? constructor (arb? selectors ...) type-name name) [(_ 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)] ...) (let ([procs (contract-proc ctc-x)] ...)
(make-proj-contract (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) (λ (pos-blame neg-blame src-info orig-str)
(let ([p-apps (procs pos-blame neg-blame src-info orig-str)] ...) (let ([p-apps (procs pos-blame neg-blame src-info orig-str)] ...)
(λ (v) (λ (v)
@ -1738,7 +1699,7 @@ improve method arity mismatch contract violation error messages?
(let ([ctcs (map (λ (param) (coerce-contract 'name param)) params)]) (let ([ctcs (map (λ (param) (coerce-contract 'name param)) params)])
(let ([procs (map contract-proc ctcs)]) (let ([procs (map contract-proc ctcs)])
(make-proj-contract (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) (λ (pos-blame neg-blame src-info orig-str)
(let ([p-apps (map (λ (proc) (proc pos-blame neg-blame src-info orig-str)) procs)] (let ([p-apps (map (λ (proc) (proc pos-blame neg-blame src-info orig-str)) procs)]
[count (length params)]) [count (length params)])
@ -1821,19 +1782,7 @@ improve method arity mismatch contract violation error messages?
[(_ hdp tlp) (opt/cons-ctc #'hdp #'tlp)])) [(_ hdp tlp) (opt/cons-ctc #'hdp #'tlp)]))
(define (list/c . args) (define (list/c . args)
(unless (andmap (λ (x) (or (contract? x) (let loop ([args (coerce-contracts 'list/c args)])
(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])
(cond (cond
[(null? args) (flat-contract null?)] [(null? args) (flat-contract null?)]
[else (cons/c (car args) (loop (cdr args)))]))) [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} @ctc-section{Contracts on Higher-order Functions}
Function contracts are not just restricted to having simple 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 @scheme[provide/contract] form is the primary mechanism for
associating a contract with a binding. 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 @note-lib[scheme/contract #:use-sources (scheme/private/contract-ds
scheme/private/contract scheme/private/contract
scheme/private/contract-guts)] 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.} 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?]{ flat-contract?]{
Like @scheme[flat-contract], but the first argument must be a string 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?]{ @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?]{ @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 symbols. It wraps parenthesis around its arguments and
extracts the names from any contracts it is supplied with.} 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 If @scheme[x] is a contract, it returns it. If it is a procedure of
contract, just returns it. If the result is a procedure of arity arity one, it converts that into a contract by treating the result as
one, it converts that into a contract. If the result is neither, it 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 signals an error, using the first argument in the error
message. The message says that a contract or a procedure of message.}
arity one was expected.}
@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] @defproc[(raise-contract-error [val any/c]
[src-info any/c] [src-info any/c]
@ -987,7 +1018,7 @@ name @scheme[sexp-name] when signaling a contract violation.}
@defparam[contract-violation->string @defparam[contract-violation->string
proc 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 This is a parameter that is used when constructing a
contract violation error. Its value is procedure that 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 '(real-in 1 10) (real-in 1 10))
(test-name '(string-len/c 3) (string/len 3)) (test-name '(string-len/c 3) (string/len 3))
(test-name 'natural-number/c natural-number/c) (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 'printable/c printable/c)
(test-name '(symbols 'a 'b 'c) (symbols 'a 'b '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 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 '(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 '(string-len/c 3) "ab" "abc")
(test-flat-contract 'natural-number/c 5 -1) (test-flat-contract 'natural-number/c 5 -1)
(test-flat-contract 'false/c #f #t) (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/spec-passed 'any/c '(contract any/c 1 'pos 'neg))
(test-flat-contract 'printable/c (vector (cons 1 (box #f))) (lambda (x) x)) (test-flat-contract 'printable/c (vector (cons 1 (box #f))) (lambda (x) x))
(let () (let ()
@ -4590,6 +4609,10 @@ so that propagation occurs.
(contract-eval '(flat-murec-contract ([x y]))) (contract-eval '(flat-murec-contract ([x y])))
'no-err)) '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 '(real-in 1 10) (real-in 1 10))
(test-name '(string-len/c 3) (string-len/c 3)) (test-name '(string-len/c 3) (string-len/c 3))
(test-name 'natural-number/c natural-number/c) (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 'printable/c printable/c)
(test-name '(symbols 'a 'b 'c) (symbols 'a 'b '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 1 2 3) (one-of/c 1 2 3))
(test-name '(one-of/c '() 'x 1 #f #\a (void) (letrec ([x x]) x)) (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))) (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%) (test-name '(subclass?/c class:c%)
(let ([c% (class object% (super-new))]) (subclass?/c c%))) (let ([c% (class object% (super-new))]) (subclass?/c c%)))
@ -5134,6 +5166,12 @@ so that propagation occurs.
(with-continuation-mark 'x 'x (with-continuation-mark 'x 'x
(f 1)))) (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)
; ;
; ;
; ;