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 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))))

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

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

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)] [(or (bytes? 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?
@ -275,8 +316,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
@ -295,56 +335,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)
@ -391,37 +405,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
@ -455,7 +455,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))

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

@ -38,14 +38,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 ()
[(_ name x) (a:known-good-contract? #'x) #'x] [(_ name x) (a:known-good-contract? #'x) #'x]
[(_ name x) #'(verify-contract/proc name x)])) [(_ name x) #'(coerce-contract 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)
;; id->contract-src-info : identifier -> syntax ;; id->contract-src-info : identifier -> syntax
;; constructs the last argument to the -contract, given an identifier ;; constructs the last argument to the -contract, given an identifier
@ -861,19 +854,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)
@ -1025,41 +1005,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
@ -1071,7 +1038,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
@ -1096,11 +1063,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)
@ -1117,8 +1084,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)
@ -1167,7 +1133,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)
@ -1330,10 +1296,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)
@ -1661,11 +1624,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 ()
@ -1711,43 +1674,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
@ -1814,6 +1769,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)
@ -1842,7 +1804,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)
@ -1872,7 +1834,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)])
@ -1955,19 +1917,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,
bytess, 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?]{
@ -912,18 +917,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 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 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]
@ -1001,7 +1032,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"))
; ;
; ;
@ -4766,6 +4769,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 ()
@ -4834,6 +4853,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)
; ;
; ;
@ -4983,13 +5006,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%)))
@ -5378,6 +5410,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)
; ;
; ;
; ;

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

@ -466,7 +466,7 @@
;; like infer, but dotted-var is the bound on the ... ;; like infer, but dotted-var is the bound on the ...
;; and T-dotted is the repeated type ;; 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)]) (with-handlers ([exn:infer? (lambda _ #f)])
(let* ([short-S (take S (length T))] (let* ([short-S (take S (length T))]
[rest-S (drop S (length T))] [rest-S (drop S (length T))]

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

@ -3,10 +3,25 @@
(require (except-in "../utils/utils.ss" infer)) (require (except-in "../utils/utils.ss" infer))
(require "infer-unit.ss" "constraints.ss" "dmap.ss" "signatures.ss" (require "infer-unit.ss" "constraints.ss" "dmap.ss" "signatures.ss"
"restrict.ss" "promote-demote.ss" "restrict.ss" "promote-demote.ss"
(only-in scheme/unit provide-signature-elements) scheme/contract
(rep type-rep)
(utils unit-utils)) (utils unit-utils))
(provide-signature-elements restrict^ infer^) (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 restrict)
(define-values/link-units/infer (define-values/link-units/infer
infer@ constraints@ dmap@ restrict@ promote-demote@) infer@ constraints@ dmap@ restrict@ promote-demote@)

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

@ -20,6 +20,7 @@
instantiate-poly instantiate-poly
instantiate-poly-dotted instantiate-poly-dotted
tc-result: tc-result:
tc-result?
tc-result-equal? tc-result-equal?
effects-equal? effects-equal?
tc-result-t tc-result-t

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

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

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

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

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 (* ...) @defform*[#:id -> #:literals (* ...)
[(dom ... -> rng) [(dom ... -> rng)
(dom ... rest * -> 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 sequence @scheme[dom ...] to the @scheme[rng] type. The second form
specifies a uniform rest argument of type @scheme[rest], and the specifies a uniform rest argument of type @scheme[rest], and the
third form specifies a non-uniform rest argument of type third form specifies a non-uniform rest argument of type
@scheme[rest] with bound @scheme[bound]. In the third form, the @scheme[rest] with bound @scheme[bound]. In the third form, the
second occurrence of @scheme[...] is literal, and @scheme[bound] 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[(U t ...)]{is the union of the types @scheme[t ...]}
@defform[(case-lambda fun-ty ...)]{is a function that behaves like all of @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 the @scheme[fun-ty]s. The @scheme[fun-ty]s must all be function