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

Trunk merging, taking care to integrate Robby's changes appropriately. Only

Browse Source 
change from what he did was that I added a name arg to the verify/contract
macro (he already has coerce-contract take a name appropriately, so this
was very simple, yay!).

svn: r11737
This commit is contained in:
Stevie Strickland 2008-09-13 23:17:58 +00:00
commit 4ac235f534
15 changed files with 389 additions and 269 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/mzlib/contract.ss
View File

@ -88,3 +88,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))))

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

@ -7,8 +7,6 @@
(*twocolumns (list (scheme id) ...)))
@(define (*twocolumns l)
(let* ([len (length l)]
[l (if (odd? len) (append l (list #f)) l)]
[len (length l)]
[half (quotient len 2)]
[a (for/list ([i (in-range half)]
[e l])
@ -18,12 +16,10 @@
[to-flow (compose make-flow list make-paragraph list)])
(make-table #f
(map (lambda (a b)
(append (list (to-flow spacer)
(to-flow a))
(if b
(list (to-flow spacer)
(to-flow b))
null)))
(list (to-flow spacer)
(to-flow a)
(to-flow spacer)
(to-flow b)))
a b))))
@mzlib[#:mode title contract]
@ -54,7 +50,6 @@ from @schememodname[scheme/contract]:
false/c
flat-contract
flat-contract-predicate
flat-contract/predicate?
flat-contract?
flat-murec-contract
flat-named-contract

7
collects/scheme/contract.ss
View File

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

270
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)]))
[(and (procedure? x) (procedure-arity-includes? x 1))
(make-predicate-contract (or (object-name x) '???) x)]
[(or (symbol? x) (boolean? x) (char? x)) (make-eq-contract x)]
[(or (bytes? 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?
@ -275,8 +316,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
@ -295,56 +335,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)
@ -391,37 +405,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
@ -455,7 +455,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))

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

@ -38,14 +38,7 @@ improve method arity mismatch contract violation error messages?
(define-syntax (verify-contract stx)
(syntax-case stx ()
[(_ name x) (a:known-good-contract? #'x) #'x]
[(_ name x) #'(verify-contract/proc name x)]))
(define (verify-contract/proc name x)
(unless (or (contract? x)
(and (procedure? x)
(procedure-arity-includes? x 1)))
(error name "expected a contract or a procedure of arity one, got ~e" x))
x)
[(_ name x) #'(coerce-contract name x)]))
;; id->contract-src-info : identifier -> syntax
;; constructs the last argument to the -contract, given an identifier
@ -861,19 +854,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)
@ -1025,53 +1005,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
@ -1096,11 +1063,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)
@ -1117,8 +1084,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)
@ -1167,7 +1133,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)
@ -1330,10 +1296,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)
@ -1661,11 +1624,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 ()
@ -1711,43 +1674,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
@ -1814,6 +1769,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)
@ -1842,7 +1804,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)
@ -1872,7 +1834,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)])
@ -1955,19 +1917,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,
bytess, 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?]{
@ -912,18 +917,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 or a bytes, 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]
@ -1001,7 +1032,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

@ -188,7 +188,10 @@
(test/no-error '(listof any/c))
(test/no-error '(listof (lambda (x) #t)))
(test/no-error '(list/c 'x "x" #t #f #\c #rx"a" #rx#"b"))
;
@ -4766,6 +4769,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 ()
@ -4833,6 +4852,10 @@ so that propagation occurs.
(with-handlers ((exn? exn:fail:syntax?))
(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)
;
@ -4983,13 +5006,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%)))
@ -5378,6 +5410,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)
;
;
;

2
collects/typed-scheme/infer/infer-unit.ss
View File

@ -466,7 +466,7 @@
;; like infer, but dotted-var is the bound on the ...
;; and T-dotted is the repeated type
(define (infer/dots X dotted-var S T T-dotted R must-vars [expected #f])
(define (infer/dots X dotted-var S T T-dotted R must-vars #:expected [expected #f])
(with-handlers ([exn:infer? (lambda _ #f)])
(let* ([short-S (take S (length T))]
[rest-S (drop S (length T))]

21
collects/typed-scheme/infer/infer.ss
View File

@ -3,10 +3,25 @@
(require (except-in "../utils/utils.ss" infer))
(require "infer-unit.ss" "constraints.ss" "dmap.ss" "signatures.ss"
"restrict.ss" "promote-demote.ss"
(only-in scheme/unit provide-signature-elements)
scheme/contract
(rep type-rep)
(utils unit-utils))
(provide/contract
[infer (((listof symbol?) (listof Type?) (listof Type?) (or/c (one-of/c #f) Type?) (listof symbol?))
((or/c (one-of/c #f) Type?))
. ->* .
(listof (list/c symbol? Type?)))]
[infer/vararg (((listof symbol?) (listof Type?) (listof Type?) Type? (or/c (one-of/c #f) Type?) (listof symbol?))
((or/c (one-of/c #f) Type?))
. ->* .
(listof (list/c symbol? Type?)))]
[infer/dots (((listof symbol?) symbol? (listof Type?) (listof Type?) Type? (or/c (one-of/c #f) Type?) (listof symbol?))
(#:expected (or/c (one-of/c #f) Type?))
. ->* .
(listof (list/c symbol? Type?)))])
(provide-signature-elements restrict^ infer^)
(provide restrict)
(define-values/link-units/infer
infer@ constraints@ dmap@ restrict@ promote-demote@)
infer@ constraints@ dmap@ restrict@ promote-demote@)

3
collects/typed-scheme/private/type-utils.ss
View File

@ -19,7 +19,8 @@
ret
instantiate-poly
instantiate-poly-dotted
tc-result:
tc-result:
tc-result?
tc-result-equal?
effects-equal?
tc-result-t

2
collects/typed-scheme/rep/type-rep.ss
View File

@ -97,7 +97,7 @@
(dt Keyword (kw ty required?)
[#:frees (free-vars* ty)
(free-idxs* ty)]
[#:fold-rhs (*Keyword kw (type-rec-id ty))])
[#:fold-rhs (*Keyword kw (type-rec-id ty) required?)])
;; dom : Listof[Type]
;; rng : Type

14
collects/typed-scheme/typecheck/tc-app-unit.ss
View File

@ -11,6 +11,7 @@
(only-in srfi/1 alist-delete)
(only-in scheme/private/class-internal make-object do-make-object)
mzlib/trace mzlib/pretty syntax/kerncase scheme/match
(prefix-in c: scheme/contract)
(for-syntax scheme/base)
(for-template
"internal-forms.ss" scheme/base
@ -474,7 +475,8 @@
(handle-clauses (doms dtys dbounds rngs) f-stx
(lambda (dom dty dbound rng) (and (<= (length dom) (length argtypes))
(eq? dotted-var dbound)))
(lambda (dom dty dbound rng) (infer/dots fixed-vars dotted-var argtypes dom dty rng (fv rng) expected))
(lambda (dom dty dbound rng)
(infer/dots fixed-vars dotted-var argtypes dom dty rng (fv rng) #:expected expected))
t argtypes expected)]
;; Union of function types works if we can apply all of them
[(tc-result: (Union: (list (and fs (Function: _)) ...)) e1 e2)
@ -486,12 +488,14 @@
;(trace tc/funapp)
(define (tc/app form) (tc/app/internal form #f))
(define (tc/app form) (tc/app/internal form #f))
(define (tc/app/check form expected)
(define t (tc/app/internal form expected))
(check-below t expected)
(ret expected))
(define t (tc/app/internal form expected))
(check-below t expected)
(ret expected))
;; expr id -> type or #f
;; if there is a binding in stx of the form:

7
collects/typed-scheme/typed-scheme.scrbl
View File

@ -436,13 +436,16 @@ The following base types are parameteric in their type arguments.
@defform*[#:id -> #:literals (* ...)
[(dom ... -> rng)
(dom ... rest * -> rng)
(dom ... rest ... bound -> rng)]]{is the type of functions from the (possibly-empty)
(dom ... rest ... bound -> rng)
(dom -> rng : pred)]]{is the type of functions from the (possibly-empty)
sequence @scheme[dom ...] to the @scheme[rng] type. The second form
specifies a uniform rest argument of type @scheme[rest], and the
third form specifies a non-uniform rest argument of type
@scheme[rest] with bound @scheme[bound]. In the third form, the
second occurrence of @scheme[...] is literal, and @scheme[bound]
must be an identifier denoting a type variable.}
must be an identifier denoting a type variable. In the fourth form,
there must be only one @scheme[dom] and @scheme[pred] is the type
checked by the predicate.}
@defform[(U t ...)]{is the union of the types @scheme[t ...]}
@defform[(case-lambda fun-ty ...)]{is a function that behaves like all of
the @scheme[fun-ty]s. The @scheme[fun-ty]s must all be function