original commit: 0e9ff6840c15084a7f262a474d011b9010790974
This commit is contained in:
Robby Findler 2003-09-08 21:50:17 +00:00
parent 934b4700da
commit c88f87161c
2 changed files with 482 additions and 10 deletions

View File

@ -591,9 +591,7 @@
pos-blame
a-contract-raw
name))
;((a-contract pos-blame neg-blame src-info) name)
(((contract-proc a-contract) pos-blame neg-blame src-info) name)
)))])))
(((contract-proc a-contract) pos-blame neg-blame src-info) name))))])))
;; raise-contract-error : (union syntax #f) symbol symbol string args ... -> alpha
;; doesn't return
@ -1570,7 +1568,7 @@
[else (cons (- n i)
(loop (- i 1)))]))))))
;; coerce/select-contract : (union contract? procedure-arity-1) -> contract-proc
;; coerce/select-contract : id (union contract? procedure-arity-1) -> contract-proc
;; 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.
@ -1653,8 +1651,10 @@
printable?
symbols
is-a?/c subclass?/c implementation?/c
listof vectorof
vector/p cons/p list/p box/p
listof list-immutableof
vectorof vector-immutableof vector/p vector-immutable/c
cons-immutable/c cons/p list-immutable/c list/p
box-immutable/c box/p
mixin-contract make-mixin-contract)
(define (union . args)
@ -1877,6 +1877,53 @@
(andmap (lambda (ele) (test-flat-contract p ele))
v)))))
(define-syntax (*-immutableof stx)
(syntax-case stx ()
[(_ predicate? fill type-name name)
(syntax
(let ([predicate?-name predicate?]
[fill-name fill])
(lambda (_p)
(let ([p (coerce/select-contract name _p)])
(make-contract
(lambda (pos neg src-info)
(let ([p-app (p pos neg src-info)])
(lambda (val)
(unless (predicate?-name val)
(raise-contract-error
src-info
pos
neg
"expected <~a>, given: ~e"
'type-name
val))
(fill-name p-app val)))))))))]))
(define (map-immutable f lst)
(let loop ([lst lst])
(cond
[(pair? lst)
(cons-immutable (f (car lst))
(loop (cdr lst)))]
[(null? lst) null])))
(define (immutable-list? lst)
(cond
[(and (pair? lst)
(immutable? lst))
(immutable-list? (cdr lst))]
[(null? lst) #t]
[else #f]))
(define list-immutableof
(*-immutableof immutable-list? map-immutable immutable-list list-immutableof))
(define vector-immutableof
(*-immutableof (lambda (x) (and (vector? x) (immutable? x)))
(lambda (f v) (vector->immutable-vector (list->vector (map f (vector->list v)))))
immutable-vector
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))
@ -1919,7 +1966,7 @@
(define (cons/p hdp tlp)
(unless (and (flat-contract/predicate? hdp)
(flat-contract/predicate? tlp))
(error 'cons/p "expected two flat contracts, got: ~e and ~e" hdp tlp))
(error 'cons/p "expected two flat contracts or procedures of arity 1, got: ~e and ~e" hdp tlp))
(flat-named-contract
(build-compound-type-name "cons/p" hdp tlp)
(lambda (x)
@ -1927,6 +1974,75 @@
(test-flat-contract hdp (car x))
(test-flat-contract tlp (cdr x))))))
(define-syntax (*-immutable/c stx)
(syntax-case stx ()
[(_ predicate? constructor (arb? selectors ...) type-name name)
(eq? #f (syntax-object->datum (syntax arb?)))
(with-syntax ([(params ...) (generate-temporaries (syntax (selectors ...)))]
[(p-apps ...) (generate-temporaries (syntax (selectors ...)))]
[(procs ...) (generate-temporaries (syntax (selectors ...)))]
[(selector-names ...) (generate-temporaries (syntax (selectors ...)))])
(syntax
(let ([predicate?-name predicate?]
[constructor-name constructor]
[selector-names selectors] ...)
(lambda (params ...)
(let ([procs (coerce/select-contract name params)] ...)
(make-contract
(lambda (pos neg src-info)
(let ([p-apps (procs pos neg src-info)] ...)
(lambda (v)
(if (and (immutable? v)
(predicate?-name v))
(constructor-name (p-apps (selector-names v)) ...)
(raise-contract-error
src-info
pos
neg
"expected <~a>, given: ~e"
'type-name
v)))))))))))]
[(_ predicate? constructor (arb? selector) correct-size type-name name)
(eq? #t (syntax-object->datum (syntax arb?)))
(syntax
(let ([predicate?-name predicate?]
[constructor-name constructor]
[selector-name selector])
(lambda params
(let ([procs (map (lambda (param) (coerce/select-contract name param)) params)])
(make-contract
(lambda (pos neg src-info)
(let ([p-apps (map (lambda (proc) (proc pos neg src-info)) procs)]
[count (length params)])
(lambda (v)
(if (and (immutable? v)
(predicate?-name v)
(correct-size count v))
(apply constructor-name
(let loop ([p-apps p-apps]
[i 0])
(cond
[(null? p-apps) null]
[else (let ([p-app (car p-apps)])
(cons (p-app (selector-name v i))
(loop (cdr p-apps) (+ i 1))))])))
(raise-contract-error
src-info
pos
neg
"expected <~a>, given: ~e"
'type-name
v))))))))))]))
(define cons-immutable/c (*-immutable/c pair? cons (#f car cdr) immutable-cons cons-immutable/c))
(define box-immutable/c (*-immutable/c box? box (#f unbox) immutable-box box-immutable/c))
(define vector-immutable/c (*-immutable/c vector?
vector
(#t (lambda (v i) (vector-ref v i)))
(lambda (n v) (= n (vector-length v)))
immutable-vector
vector-immutable/c))
(define (list/p . args)
(unless (andmap flat-contract/predicate? args)
(error 'list/p "expected flat contracts, got: ~a"
@ -1939,9 +2055,27 @@
(loop (cdr args)))]))))
(let loop ([args args])
(cond
[(null? args) null?]
[(null? args) (flat-contract null?)]
[else (cons/p (car args) (loop (cdr args)))])))
(define (list-immutable/c . args)
(unless (andmap (lambda (x) (or (contract? x)
(and (procedure? x)
(procedure-arity-includes? x 1))))
args)
(error 'list/p "expected flat 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
[(null? args) (flat-contract null?)]
[else (cons-immutable/c (car args) (loop (cdr args)))])))
(define (syntax/p c)
(unless (flat-contract/predicate? c)
(error 'syntax/p "expected argument of type <flat-contract> or procedure of arity 1, got ~e" c))

View File

@ -22,6 +22,7 @@
;; test/spec-failed : symbol sexp string -> void
;; tests a failing specification with blame assigned to `blame'
#;
(define (test/spec-failed name expression blame)
(define (ensure-contract-failed x)
(let ([result (with-handlers ([(lambda (x) (and (not-break-exn? x) (exn? x)))
@ -39,6 +40,22 @@
ensure-contract-failed
expression))
(define (test/spec-failed name expression blame)
(define (has-proper-blame? msg)
(equal?
blame
(cond
[(regexp-match ": ([^ ]*) broke" msg) => cadr]
[(regexp-match "([^ ]+): .* does not imply" msg) => cadr]
[else (format "no blame in error message: \"~a\"" msg)])))
(printf "testing: ~s\n" name)
(thunk-error-test
(lambda () (eval expression))
(datum->syntax-object #'here expression)
(lambda (exn)
(and (exn? exn)
(has-good-blame? (exn-message exn))))))
(define (test/well-formed stx)
(test (void)
(let ([expand/ret-void (lambda (x) (expand x) (void))]) expand/ret-void)
@ -96,6 +113,7 @@
(test/no-error '(opt->* ((flat-contract integer?)) ((flat-contract integer?)) ((flat-contract integer?))))
(test/no-error '(listof any?))
(test/no-error '(listof (lambda (x) #t)))
(test/spec-passed
'contract-arrow-star0a
@ -873,6 +891,309 @@
"c-neg")
|#
(test/spec-failed
'immutable1
'(let ([ct (contract (list-immutableof (boolean? . -> . boolean?))
#f
'pos
'neg)])
((car ct) 1))
"pos")
(test/spec-failed
'immutable2
'(let ([ct (contract (list-immutableof (boolean? . -> . boolean?))
(list (lambda (x) x))
'pos
'neg)])
((car ct) 1))
"pos")
(test/spec-failed
'immutable3
'(let ([ct (contract (list-immutableof (number? . -> . boolean?))
(list-immutable (lambda (x) 1))
'pos
'neg)])
((car ct) #f))
"neg")
(test/spec-failed
'immutable4
'(let ([ct (contract (list-immutableof (number? . -> . boolean?))
(list-immutable (lambda (x) 1))
'pos
'neg)])
((car ct) 1))
"pos")
(test/spec-passed
'immutable5
'(let ([ct (contract (list-immutableof (number? . -> . boolean?))
(list-immutable (lambda (x) #t))
'pos
'neg)])
((car ct) 1)))
(test/spec-failed
'immutable6
'(contract (cons-immutable/c (boolean? . -> . boolean?) (boolean? . -> . boolean?))
#f
'pos
'neg)
"pos")
(test/spec-failed
'immutable7
'(contract (cons-immutable/c (boolean? . -> . boolean?) (boolean? . -> . boolean?))
(cons (lambda (x) x) (lambda (x) x))
'pos
'neg)
"pos")
(test/spec-failed
'immutable8
'(let ([ct (contract (cons-immutable/c (number? . -> . boolean?) (number? . -> . boolean?))
(cons-immutable (lambda (x) 1) (lambda (x) 1))
'pos
'neg)])
((car ct) #f))
"neg")
(test/spec-failed
'immutable9
'(let ([ct (contract (cons-immutable/c (number? . -> . boolean?) (number? . -> . boolean?))
(cons-immutable (lambda (x) 1) (lambda (x) 1))
'pos
'neg)])
((cdr ct) #f))
"neg")
(test/spec-failed
'immutable10
'(let ([ct (contract (cons-immutable/c (number? . -> . boolean?) (number? . -> . boolean?))
(cons-immutable (lambda (x) 1) (lambda (x) 1))
'pos
'neg)])
((car ct) 1))
"pos")
(test/spec-failed
'immutable11
'(let ([ct (contract (cons-immutable/c (number? . -> . boolean?) (number? . -> . boolean?))
(cons-immutable (lambda (x) 1) (lambda (x) 1))
'pos
'neg)])
((cdr ct) 1))
"pos")
(test/spec-passed
'immutable12
'(let ([ct (contract (cons-immutable/c (number? . -> . boolean?) (number? . -> . boolean?))
(cons-immutable (lambda (x) #t) (lambda (x) #t))
'pos
'neg)])
((car ct) 1)))
(test/spec-passed
'immutable13
'(let ([ct (contract (cons-immutable/c (number? . -> . boolean?) (number? . -> . boolean?))
(cons-immutable (lambda (x) #t) (lambda (x) #t))
'pos
'neg)])
((cdr ct) 1)))
(test/spec-passed/result
'immutable14
'(contract (cons-immutable/c number? boolean?)
(cons-immutable 1 #t)
'pos
'neg)
(cons-immutable 1 #t))
(test/spec-failed
'immutable15
'(contract (list-immutable/c (number? . -> . boolean?) (number? . -> . boolean?))
#f
'pos
'neg)
"pos")
(test/spec-failed
'immutable16
'(contract (list-immutable/c (number? . -> . boolean?) (number? . -> . boolean?))
(list (lambda (x) #t) (lambda (x) #t))
'pos
'neg)
"pos")
(test/spec-failed
'immutable17
'(contract (list-immutable/c (number? . -> . boolean?) (number? . -> . boolean?))
(list-immutable (lambda (x) #t))
'pos
'neg)
"pos")
(test/spec-failed
'immutable18
'(contract (list-immutable/c (number? . -> . boolean?) (number? . -> . boolean?))
(list-immutable (lambda (x) #t) (lambda (x) #t) (lambda (x) #t))
'pos
'neg)
"pos")
(test/spec-passed
'immutable19
'(let ([ctc (contract (list-immutable/c (number? . -> . boolean?) (number? . -> . boolean?))
(list-immutable (lambda (x) #t) (lambda (x) #t))
'pos
'neg)])
(for-each (lambda (x) (x 1)) ctc)))
(test/spec-failed
'vector-immutable1
'(contract (vector-immutableof (boolean? . -> . boolean?))
#f
'pos
'neg)
"pos")
(test/spec-failed
'vector-immutable2
'(contract (vector-immutableof (boolean? . -> . boolean?))
(vector (lambda (x) x))
'pos
'neg)
"pos")
(test/spec-failed
'vector-immutable3
'(let ([ct (contract (vector-immutableof (number? . -> . boolean?))
(vector->immutable-vector (vector (lambda (x) 1)))
'pos
'neg)])
((vector-ref ct 0) #f))
"neg")
(test/spec-failed
'vector-immutable4
'(let ([ct (contract (vector-immutableof (number? . -> . boolean?))
(vector->immutable-vector (vector (lambda (x) 1)))
'pos
'neg)])
((vector-ref ct 0) 1))
"pos")
(test/spec-passed
'vector-immutable5
'(let ([ct (contract (vector-immutableof (number? . -> . boolean?))
(vector->immutable-vector (vector (lambda (x) #t)))
'pos
'neg)])
((vector-ref ct 0) 1)))
(test/spec-failed
'vector-immutable6
'(contract (vector-immutable/c (number? . -> . boolean?) (number? . -> . boolean?))
#f
'pos
'neg)
"pos")
(test/spec-failed
'vector-immutable7
'(contract (vector-immutable/c (number? . -> . boolean?) (number? . -> . boolean?))
(vector (lambda (x) #t) (lambda (x) #t))
'pos
'neg)
"pos")
(test/spec-failed
'vector-immutable8
'(contract (vector-immutable/c (number? . -> . boolean?) (number? . -> . boolean?))
(vector->immutable-vector (vector (lambda (x) #t)))
'pos
'neg)
"pos")
(test/spec-failed
'vector-immutable9
'(contract (vector-immutable/c (number? . -> . boolean?) (number? . -> . boolean?))
(vector->immutable-vector (vector (lambda (x) #t) (lambda (x) #t) (lambda (x) #t)))
'pos
'neg)
"pos")
(test/spec-passed
'vector-immutable10
'(let ([ctc (contract (vector-immutable/c (number? . -> . boolean?) (number? . -> . boolean?))
(vector->immutable-vector (vector (lambda (x) #t) (lambda (x) #t)))
'pos
'neg)])
((vector-ref ctc 0) 1)
((vector-ref ctc 1) 1)))
(test/spec-passed/result
'vector-immutable11
'(contract (vector-immutable/c number? boolean?)
(vector->immutable-vector (vector 1 #t))
'pos
'neg)
(vector->immutable-vector (vector 1 #t)))
(test/spec-failed
'box-immutable1
'(contract (box-immutable/c (number? . -> . boolean?))
#f
'pos
'neg)
"pos")
(test/spec-failed
'box-immutable2
'(contract (box-immutable/c (number? . -> . boolean?))
(box (lambda (x) #t))
'pos
'neg)
"pos")
(test/spec-failed
'box-immutable3
'(let ([ctc (contract (box-immutable/c (number? . -> . boolean?))
(box-immutable (lambda (x) #t))
'pos
'neg)])
((unbox ctc) #f))
"neg")
(test/spec-failed
'box-immutable4
'(let ([ctc (contract (box-immutable/c (number? . -> . boolean?))
(box-immutable (lambda (x) 1))
'pos
'neg)])
((unbox ctc) 1))
"pos")
(test/spec-passed
'box-immutable5
'(let ([ctc (contract (box-immutable/c (number? . -> . boolean?))
(box-immutable (lambda (x) #t))
'pos
'neg)])
((unbox ctc) 1)))
(test/spec-passed/result
'vector-immutable6
'(contract (box-immutable/c boolean?)
(box-immutable #t)
'pos
'neg)
(box-immutable #t))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; Flat Contract Tests ;;
@ -922,15 +1243,32 @@
(test-flat-contract '(listof boolean?) (list #t #f) (list #f 3 #t))
(test-flat-contract '(listof any?) (list #t #f) 3)
;(test-flat-contract '(list-immutableof boolean?) (list-immutable #t #f) (list-immutable #f 3 #t))
;(test-flat-contract '(list-immutableof any?) (list-immutable #t #f) 3)
;(test-flat-contract '(list-immutableof boolean?) (list-immutable) (list))
;(test-flat-contract '(list-immutableof (-> boolean? boolean?)) (list-immutable (lambda (x) x)) (list (lambda (x) x)))
(test-flat-contract '(vectorof boolean?) (vector #t #f) (vector #f 3 #t))
(test-flat-contract '(vectorof any?) (vector #t #f) 3)
(test-flat-contract '(vector/p boolean? (flat-contract integer?)) (vector #t 1) (vector 1 #f))
(test-flat-contract '(vector/p boolean? (flat-contract integer?)) (vector #t 1) #f)
(test-flat-contract '(cons/p boolean? (flat-contract integer?)) (cons #t 1) (cons 1 #f))
(test-flat-contract '(cons/p boolean? (flat-contract integer?)) (cons #t 1) #f)
(test-flat-contract '(list/p boolean? (flat-contract integer?)) (list #t 1) (list 1 #f))
(test-flat-contract '(list/p boolean? (flat-contract integer?)) (list #t 1) #f)
;(test-flat-contract '(cons-immutable/c boolean? (flat-contract integer?)) (cons-immutable #t 1) (cons-immutable 1 #f))
;(test-flat-contract '(cons-immutable/c boolean? (flat-contract integer?)) (cons-immutable #t 1) #f)
;(test-flat-contract '(cons-immutable/c boolean? (flat-contract integer?)) (cons-immutable #t 1) (cons #t 1))
;(test-flat-contract '(cons-immutable/c (-> boolean? boolean?) integer?) (cons-immutable (lambda (x) x) 1) #f)
;(test-flat-contract '(list-immutable/c boolean? (flat-contract integer?)) (list-immutable #t 1) (list-immutable 1 #f))
;(test-flat-contract '(list-immutable/c boolean? (flat-contract integer?)) (list-immutable #t 1) #f)
;(test-flat-contract '(list-immutable/c boolean? (flat-contract integer?)) (list-immutable #t 1) (list #t 1))
;(test-flat-contract '(list-immutable/c (-> boolean? boolean?) integer?) (list-immutable (lambda (x) x) 1) #f)
(test-flat-contract '(box/p boolean?) (box #f) (box 1))
(test-flat-contract '(box/p (flat-contract boolean?)) (box #t) #f)