..
original commit: c47c873c27f031a2f5ee2677271dcd5d21814279
This commit is contained in:
Robby Findler
parent
c857d40841
commit
bad9c0f731
|
|
@ -192,7 +192,7 @@
|
|||
pos-blame
|
||||
a-contract
|
||||
name))
|
||||
(check-contract a-contract name pos-blame neg-blame src-info)))))])))
|
||||
(check-contract a-contract name pos-blame neg-blame src-info #f)))))])))
|
||||
|
||||
(define-syntaxes (-> ->* ->d ->d* case->)
|
||||
(let ()
|
||||
|
|
@ -245,7 +245,7 @@
|
|||
(syntax
|
||||
((arg-x ...)
|
||||
(val
|
||||
(check-contract dom-x arg-x neg-blame pos-blame src-info)
|
||||
(check-contract dom-x arg-x neg-blame pos-blame src-info #f)
|
||||
...)))))
|
||||
(lambda (stx)
|
||||
(->*make-body stx)))))))))]))
|
||||
|
|
@ -288,14 +288,15 @@
|
|||
((arg-x ...)
|
||||
(let-values ([(res-x ...)
|
||||
(val
|
||||
(check-contract dom-x arg-x neg-blame pos-blame src-info)
|
||||
(check-contract dom-x arg-x neg-blame pos-blame src-info #f)
|
||||
...)])
|
||||
(values (check-contract
|
||||
rng-x
|
||||
res-x
|
||||
pos-blame
|
||||
neg-blame
|
||||
src-info)
|
||||
src-info
|
||||
#f)
|
||||
...))))))))]
|
||||
[(_ (dom ...) rest (rng ...))
|
||||
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (dom ...)))]
|
||||
|
|
@ -335,15 +336,16 @@
|
|||
(let-values ([(res-x ...)
|
||||
(apply
|
||||
val
|
||||
(check-contract dom-x arg-x neg-blame pos-blame src-info)
|
||||
(check-contract dom-x arg-x neg-blame pos-blame src-info #f)
|
||||
...
|
||||
(check-contract dom-rest-x rest-arg-x neg-blame pos-blame src-info))])
|
||||
(check-contract dom-rest-x rest-arg-x neg-blame pos-blame src-info #f))])
|
||||
(values (check-contract
|
||||
rng-x
|
||||
res-x
|
||||
pos-blame
|
||||
neg-blame
|
||||
src-info)
|
||||
src-info
|
||||
#f)
|
||||
...))))))))]))
|
||||
|
||||
;; ->d/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||
|
|
@ -392,10 +394,11 @@
|
|||
rng-contract))
|
||||
(check-contract
|
||||
rng-contract
|
||||
(val (check-contract dom-x arg-x neg-blame pos-blame src-info) ...)
|
||||
(val (check-contract dom-x arg-x neg-blame pos-blame src-info #f) ...)
|
||||
pos-blame
|
||||
neg-blame
|
||||
src-info)))))))))]))
|
||||
src-info
|
||||
#f)))))))))]))
|
||||
|
||||
;; ->d*/h : stx -> (values (syntax -> syntax) (syntax -> syntax) (syntax -> syntax))
|
||||
(define (->d*/h stx)
|
||||
|
|
@ -440,7 +443,7 @@
|
|||
(call-with-values
|
||||
(lambda ()
|
||||
(val
|
||||
(check-contract dom-x arg-x neg-blame pos-blame src-info)
|
||||
(check-contract dom-x arg-x neg-blame pos-blame src-info #f)
|
||||
...))
|
||||
(lambda results
|
||||
(unless (= (length results) (length rng-contracts))
|
||||
|
|
@ -455,7 +458,8 @@
|
|||
result
|
||||
pos-blame
|
||||
neg-blame
|
||||
src-info))
|
||||
src-info
|
||||
#f))
|
||||
rng-contracts
|
||||
results))))))))))))]
|
||||
[(_ (dom ...) rest rng-mk)
|
||||
|
|
@ -500,9 +504,9 @@
|
|||
(lambda ()
|
||||
(apply
|
||||
val
|
||||
(check-contract dom-x arg-x neg-blame pos-blame src-info)
|
||||
(check-contract dom-x arg-x neg-blame pos-blame src-info #f)
|
||||
...
|
||||
(check-contract dom-rest-x rest-arg-x neg-blame pos-blame src-info)))
|
||||
(check-contract dom-rest-x rest-arg-x neg-blame pos-blame src-info #f)))
|
||||
(lambda results
|
||||
(unless (= (length results) (length rng-contracts))
|
||||
(error '->d*
|
||||
|
|
@ -516,7 +520,8 @@
|
|||
result
|
||||
pos-blame
|
||||
neg-blame
|
||||
src-info))
|
||||
src-info
|
||||
#f))
|
||||
rng-contracts
|
||||
results))))))))))))]))
|
||||
|
||||
|
|
@ -658,8 +663,9 @@
|
|||
(and (procedure? val)
|
||||
(procedure-arity-includes? val 1))))])
|
||||
contract?))
|
||||
|
||||
(define (check-contract contract val pos neg src-info)
|
||||
|
||||
;; check-contract : contract any symbol symbol syntax (union false? string?)
|
||||
(define (check-contract contract val pos neg src-info extra-message)
|
||||
(cond
|
||||
[(contract? contract)
|
||||
((contract-f contract) val pos neg src-info)]
|
||||
|
|
@ -680,9 +686,12 @@
|
|||
src-info
|
||||
pos
|
||||
neg
|
||||
"~agiven: ~e"
|
||||
"~agiven: ~e~a"
|
||||
(predicate->type-name contract)
|
||||
val))]))
|
||||
val
|
||||
(if extra-message
|
||||
extra-message
|
||||
"")))]))
|
||||
|
||||
;; predicate->type-name : function -> string
|
||||
;; if the function has a name and the name ends
|
||||
|
|
|
|||
|
|
@ -1,429 +0,0 @@
|
|||
(module spec-test mzscheme
|
||||
(require "test-suite-utils.ss")
|
||||
|
||||
(load-framework-automatically #f)
|
||||
(send-sexp-to-mred '(require (lib "specs.ss" "framework")))
|
||||
(send-sexp-to-mred '(require (lib "pretty.ss")))
|
||||
|
||||
;; test/spec-passed : symbol sexp -> void
|
||||
;; tests a passing specification
|
||||
(define (test/spec-passed name expression)
|
||||
(test name
|
||||
(lambda (x) (eq? x 'passed))
|
||||
(lambda ()
|
||||
(send-sexp-to-mred `(begin ,expression 'passed)))))
|
||||
|
||||
;; test/spec-failed : symbol sexp string -> void
|
||||
;; tests a failing specification with blame assigned to `blame'
|
||||
(define (test/spec-failed name expression blame)
|
||||
(test name
|
||||
(lambda (x)
|
||||
(and (string? x)
|
||||
(let ([m (regexp-match ": (.*) failed contract:" x)])
|
||||
(equal? (cadr m) blame))))
|
||||
(lambda ()
|
||||
(send-sexp-to-mred `(with-handlers ([(lambda (x) (and (not-break-exn? x) (exn? x)))
|
||||
exn-message])
|
||||
,expression
|
||||
'failed/expected-exn-got-normal-termination)))))
|
||||
|
||||
(test/spec-passed
|
||||
'contract-flat1
|
||||
'(contract not #f 'pos 'neg))
|
||||
|
||||
(test/spec-failed
|
||||
'contract-flat2
|
||||
'(contract not #t 'pos 'neg)
|
||||
"pos")
|
||||
|
||||
(test/spec-passed
|
||||
'contract-arrow-star0a
|
||||
'(contract (->* (integer?) (integer?))
|
||||
(lambda (x) x)
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-star0b
|
||||
'((contract (->* (integer?) (integer?))
|
||||
(lambda (x) x)
|
||||
'pos
|
||||
'neg)
|
||||
#f)
|
||||
"neg")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-star0c
|
||||
'((contract (->* (integer?) (integer?))
|
||||
(lambda (x) #f)
|
||||
'pos
|
||||
'neg)
|
||||
1)
|
||||
"pos")
|
||||
|
||||
(test/spec-passed
|
||||
'contract-arrow-star1
|
||||
'(let-values ([(a b) ((contract (->* (integer?) (integer? integer?))
|
||||
(lambda (x) (values x x))
|
||||
'pos
|
||||
'neg)
|
||||
2)])
|
||||
1))
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-star2
|
||||
'((contract (->* (integer?) (integer? integer?))
|
||||
(lambda (x) (values x x))
|
||||
'pos
|
||||
'neg)
|
||||
#f)
|
||||
"neg")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-star3
|
||||
'((contract (->* (integer?) (integer? integer?))
|
||||
(lambda (x) (values 1 #t))
|
||||
'pos
|
||||
'neg)
|
||||
1)
|
||||
"pos")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-star4
|
||||
'((contract (->* (integer?) (integer? integer?))
|
||||
(lambda (x) (values #t 1))
|
||||
'pos
|
||||
'neg)
|
||||
1)
|
||||
"pos")
|
||||
|
||||
|
||||
(test/spec-passed
|
||||
'contract-arrow-star5
|
||||
'(let-values ([(a b) ((contract (->* (integer?)
|
||||
(listof integer?)
|
||||
(integer? integer?))
|
||||
(lambda (x) (values x x))
|
||||
'pos
|
||||
'neg)
|
||||
2)])
|
||||
1))
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-star6
|
||||
'((contract (->* (integer?) (listof integer?) (integer? integer?))
|
||||
(lambda (x) (values x x))
|
||||
'pos
|
||||
'neg)
|
||||
#f)
|
||||
"neg")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-star7
|
||||
'((contract (->* (integer?) (listof integer?) (integer? integer?))
|
||||
(lambda (x) (values 1 #t))
|
||||
'pos
|
||||
'neg)
|
||||
1)
|
||||
"pos")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-star8
|
||||
'((contract (->* (integer?) (listof integer?) (integer? integer?))
|
||||
(lambda (x) (values #t 1))
|
||||
'pos
|
||||
'neg)
|
||||
1)
|
||||
"pos")
|
||||
|
||||
(test/spec-passed
|
||||
'contract-arrow-star9
|
||||
'((contract (->* (integer?) (listof integer?) (integer?))
|
||||
(lambda (x . y) 1)
|
||||
'pos
|
||||
'neg)
|
||||
1 2))
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-star10
|
||||
'((contract (->* (integer?) (listof integer?) (integer?))
|
||||
(lambda (x . y) 1)
|
||||
'pos
|
||||
'neg)
|
||||
1 2 'bad)
|
||||
"neg")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-d1
|
||||
'(contract (integer? . ->d . (lambda (x) (lambda (y) (= x y))))
|
||||
1
|
||||
'pos
|
||||
'neg)
|
||||
"pos")
|
||||
|
||||
(test/spec-passed
|
||||
'contract-d2
|
||||
'(contract (integer? . ->d . (lambda (x) (lambda (y) (= x y))))
|
||||
(lambda (x) x)
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(test/spec-failed
|
||||
'contract-d2
|
||||
'((contract (integer? . ->d . (lambda (x) (lambda (y) (= x y))))
|
||||
(lambda (x) (+ x 1))
|
||||
'pos
|
||||
'neg)
|
||||
2)
|
||||
"pos")
|
||||
|
||||
(test/spec-passed
|
||||
'contract-arrow1
|
||||
'(contract (integer? . -> . integer?) (lambda (x) x) 'pos 'neg))
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow2
|
||||
'(contract (integer? . -> . integer?) (lambda (x y) x) 'pos 'neg)
|
||||
"pos")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow3
|
||||
'((contract (integer? . -> . integer?) (lambda (x) #f) 'pos 'neg) #t)
|
||||
"neg")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow4
|
||||
'((contract (integer? . -> . integer?) (lambda (x) #f) 'pos 'neg) 1)
|
||||
"pos")
|
||||
|
||||
|
||||
(test/spec-passed
|
||||
'contract-arrow-any1
|
||||
'(contract (integer? . -> . any) (lambda (x) x) 'pos 'neg))
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-any2
|
||||
'(contract (integer? . -> . any) (lambda (x y) x) 'pos 'neg)
|
||||
"pos")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-any3
|
||||
'((contract (integer? . -> . any) (lambda (x) #f) 'pos 'neg) #t)
|
||||
"neg")
|
||||
|
||||
(test/spec-passed
|
||||
'contract-arrow-star-d1
|
||||
'((contract (->d* (integer?) (lambda (arg) (lambda (res) (= arg res))))
|
||||
(lambda (x) x)
|
||||
'pos
|
||||
'neg)
|
||||
1))
|
||||
|
||||
(test/spec-passed
|
||||
'contract-arrow-star-d2
|
||||
'((contract (->d* (integer?) (lambda (arg)
|
||||
(values (lambda (res) (= arg res))
|
||||
(lambda (res) (= arg res)))))
|
||||
(lambda (x) (values x x))
|
||||
'pos
|
||||
'neg)
|
||||
1))
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-star-d3
|
||||
'((contract (->d* (integer?) (lambda (arg)
|
||||
(values (lambda (res) (= arg res))
|
||||
(lambda (res) (= arg res)))))
|
||||
(lambda (x) (values 1 2))
|
||||
'pos
|
||||
'neg)
|
||||
2)
|
||||
"pos")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-star-d4
|
||||
'((contract (->d* (integer?) (lambda (arg)
|
||||
(values (lambda (res) (= arg res))
|
||||
(lambda (res) (= arg res)))))
|
||||
(lambda (x) (values 2 1))
|
||||
'pos
|
||||
'neg)
|
||||
2)
|
||||
"pos")
|
||||
|
||||
(test/spec-passed
|
||||
'contract-arrow-star-d5
|
||||
'((contract (->d* ()
|
||||
(listof integer?)
|
||||
(lambda (arg) (lambda (res) (= arg res))))
|
||||
(lambda (x) x)
|
||||
'pos
|
||||
'neg)
|
||||
1))
|
||||
|
||||
(test/spec-passed
|
||||
'contract-arrow-star-d6
|
||||
'((contract (->d* ()
|
||||
(listof integer?)
|
||||
(lambda (arg)
|
||||
(values (lambda (res) (= arg res))
|
||||
(lambda (res) (= arg res)))))
|
||||
(lambda (x) (values x x))
|
||||
'pos
|
||||
'neg)
|
||||
1))
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-star-d7
|
||||
'((contract (->d* ()
|
||||
(listof integer?)
|
||||
(lambda (arg)
|
||||
(values (lambda (res) (= arg res))
|
||||
(lambda (res) (= arg res)))))
|
||||
(lambda (x) (values 1 2))
|
||||
'pos
|
||||
'neg)
|
||||
2)
|
||||
"pos")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-arrow-star-d8
|
||||
'((contract (->d* ()
|
||||
(listof integer?)
|
||||
(lambda (arg)
|
||||
(values (lambda (res) (= arg res))
|
||||
(lambda (res) (= arg res)))))
|
||||
(lambda (x) (values 2 1))
|
||||
'pos
|
||||
'neg)
|
||||
2)
|
||||
"pos")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-case->1
|
||||
'(contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?))
|
||||
(lambda (x) x)
|
||||
'pos
|
||||
'neg)
|
||||
"pos")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-case->2
|
||||
'((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?))
|
||||
(case-lambda
|
||||
[(x y) 'case1]
|
||||
[(x) 'case2])
|
||||
'pos
|
||||
'neg)
|
||||
1 2)
|
||||
"pos")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-case->3
|
||||
'((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?))
|
||||
(case-lambda
|
||||
[(x y) 'case1]
|
||||
[(x) 'case2])
|
||||
'pos
|
||||
'neg)
|
||||
1)
|
||||
"pos")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-case->4
|
||||
'((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?))
|
||||
(case-lambda
|
||||
[(x y) 'case1]
|
||||
[(x) 'case2])
|
||||
'pos
|
||||
'neg)
|
||||
'a 2)
|
||||
"neg")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-case->5
|
||||
'((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?))
|
||||
(case-lambda
|
||||
[(x y) 'case1]
|
||||
[(x) 'case2])
|
||||
'pos
|
||||
'neg)
|
||||
2 'a)
|
||||
"neg")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-case->6
|
||||
'((contract (case-> (integer? integer? . -> . integer?) (integer? . -> . integer?))
|
||||
(case-lambda
|
||||
[(x y) 'case1]
|
||||
[(x) 'case2])
|
||||
'pos
|
||||
'neg)
|
||||
#t)
|
||||
"neg")
|
||||
|
||||
(test/spec-failed
|
||||
'contract-d-protect-shared-state
|
||||
'(let ([x 1])
|
||||
((contract ((->d (lambda () (let ([pre-x x]) (lambda (res) (= x pre-x)))))
|
||||
. -> .
|
||||
(lambda (x) #t))
|
||||
(lambda (thnk) (thnk))
|
||||
'pos
|
||||
'neg)
|
||||
(lambda () (set! x 2))))
|
||||
"neg")
|
||||
|
||||
(test/spec-failed
|
||||
'combo1
|
||||
'(let ([cf (contract (case->
|
||||
((class? . ->d . (lambda (%) (lambda (x) #f))) . -> . void?)
|
||||
((class? . ->d . (lambda (%) (lambda (x) #f))) boolean? . -> . void?))
|
||||
(letrec ([c% (class object% (super-instantiate ()))]
|
||||
[f
|
||||
(case-lambda
|
||||
[(class-maker) (f class-maker #t)]
|
||||
[(class-maker b)
|
||||
(class-maker c%)
|
||||
(void)])])
|
||||
f)
|
||||
'pos
|
||||
'neg)])
|
||||
(cf (lambda (x%) 'going-to-be-bad)))
|
||||
"neg")
|
||||
|
||||
(test/spec-failed
|
||||
'union1
|
||||
'(contract (union false?) #t 'pos 'neg)
|
||||
"pos")
|
||||
|
||||
(test/spec-passed
|
||||
'union2
|
||||
'(contract (union false?) #f 'pos 'neg))
|
||||
|
||||
(test/spec-passed
|
||||
'union3
|
||||
'((contract (union (-> integer? integer?)) (lambda (x) x) 'pos 'neg) 1))
|
||||
|
||||
(test/spec-failed
|
||||
'union4
|
||||
'((contract (union (-> integer? integer?)) (lambda (x) x) 'pos 'neg) #f)
|
||||
"neg")
|
||||
|
||||
(test/spec-failed
|
||||
'union5
|
||||
'((contract (union (-> integer? integer?)) (lambda (x) #f) 'pos 'neg) 1)
|
||||
"pos")
|
||||
|
||||
(test/spec-passed
|
||||
'union6
|
||||
'(contract (union false? (-> integer? integer?)) #f 'pos 'neg))
|
||||
|
||||
(test/spec-passed
|
||||
'union7
|
||||
'((contract (union false? (-> integer? integer?)) (lambda (x) x) 'pos 'neg) 1))
|
||||
|
||||
)
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user