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

Add more missing properties.

Browse Source
This commit is contained in:
Vincent St-Amour 2016-11-21 11:19:41 -06:00
parent 02b0a30988
commit 87161fc5f3
10 changed files with 129 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
pkgs/racket-test/tests/racket/contract/arrow-d.rkt
View File

@ -17,7 +17,19 @@
(test/spec-passed
'->d1
'((contract (->d () () [x number?]) (lambda () 1) 'pos 'neg)))
(test/spec-passed/result
'->d1a
'(and (value-contract (contract (->d () () [x number?]) (lambda () 1) 'pos 'neg))
#t)
#t)
(test/spec-passed/result
'->d1b
'(and (value-blame (contract (->d () () [x number?]) (lambda () 1) 'pos 'neg))
#t)
#t)
(test/spec-passed
'->d2
'((contract (->d ([x number?]) () (values [r number?])) (lambda (x) (+ x 1)) 'pos 'neg) 1))

17
pkgs/racket-test/tests/racket/contract/arrow.rkt
View File

@ -250,6 +250,12 @@
integer?)
(lambda (x1 x2 x3 x4 x5 x6 x7 x8 x9 x10) x1) 'pos 'neg))
(test/spec-passed/result
'contract-arrow1c
'(and (value-contract (contract (integer? . -> . integer?) (lambda (x) x) 'pos 'neg))
#t)
#t)
(test/pos-blame
'contract-arrow2
'(contract (integer? . -> . integer?) (lambda (x y) x) 'pos 'neg))
@ -286,6 +292,12 @@
(test/neg-blame
'contract-arrow-any3
'((contract (integer? . -> . any) (lambda (x) #f) 'pos 'neg) #t))
(test/spec-passed/result
'contract-arrow-any4
'(and (value-contract (contract (-> integer? any) (lambda (x) x) 'pos 'neg))
#t)
#t)
(test/spec-passed
'contract-arrow-all-anys1
@ -484,6 +496,11 @@
(struct s ())
((impersonate-procedure s? (λ (x) (values (λ (r) "") x))) 11))
'pos 'neg))
(test/spec-passed/result
'predicate/c15
'(and (value-contract (contract predicate/c boolean? 'pos 'neg))
#t)
#t)
(test/spec-passed/result
'->void.1

6
pkgs/racket-test/tests/racket/contract/evt.rkt
View File

@ -11,6 +11,12 @@
'evt/c-first-order-2
'(contract (evt/c) always-evt 'pos 'neg))
(test/spec-passed/result
'evt/c-first-order-3
'(and (value-contract (contract (evt/c) always-evt 'pos 'neg))
#t)
#t)
(test/pos-blame
'evt/c-higher-order-1
'(let ([evt (contract (evt/c symbol?)

48
pkgs/racket-test/tests/racket/contract/struct-dc.rkt
View File

@ -15,6 +15,28 @@
'pos
'neg)))
(test/spec-passed/result
'struct/c1a
'(let ()
(define-struct s (a))
(and (value-contract (contract (struct/c s (or/c number? (-> void?))) ; want non-flat
(make-s 1)
'pos
'neg))
#t))
#t)
(test/spec-passed/result
'struct/c1b
'(let ()
(define-struct s (a))
(and (value-blame (contract (struct/c s (or/c number? (-> void?))) ; want non-flat
(make-s 1)
'pos
'neg))
#t))
#t)
(test/pos-blame
'struct/c2
'(let ()
@ -240,6 +262,32 @@
(s 1 #f)
'pos
'neg)))
(test/spec-passed/result
'struct/dc-1a
'(let ()
(struct s (a b))
(and (value-contract (contract (struct/dc s
[a () (or/c number? (-> void?))] ; want non-flat
[b (a) boolean?])
(s 1 #f)
'pos
'neg))
#t))
#t)
(test/spec-passed/result
'struct/dc-1b
'(let ()
(struct s (a b))
(and (value-blame (contract (struct/dc s
[a () (or/c number? (-> void?))] ; want non-flat
[b (a) boolean?])
(s 1 #f)
'pos
'neg))
#t))
#t)
(test/spec-passed
'struct/dc-1a

17
pkgs/racket-test/tests/racket/contract/unconstrained-domain.rkt
View File

@ -68,4 +68,21 @@
(test/pos-blame
'unconstrained-domain->11
'((contract (unconstrained-domain-> number? number?) (λ () 1) 'pos 'neg)))
(test/spec-passed/result
'unconstrained-domain->12
'(and (value-contract (contract (unconstrained-domain-> number?)
(lambda (x) 1)
'pos
'neg))
#t)
#t)
(test/spec-passed/result
'unconstrained-domain->13
'(and (value-blame (contract (unconstrained-domain-> number?)
(lambda (x) 1)
'pos
'neg))
#t)
#t)
)

3
racket/collects/racket/contract/private/arr-d.rkt
View File

@ -412,7 +412,8 @@
dom-blame neg-party)
(loop (cdr args)
(cdr non-kwd-ctcs)))]))))))))
impersonator-prop:contracted ->d-stct)))))
impersonator-prop:contracted ->d-stct
impersonator-prop:blame (blame-add-missing-party blame neg-party))))))
(define (build-values-string desc dep-pre-args)
(cond

5
racket/collects/racket/contract/private/misc.rkt
View File

@ -766,7 +766,10 @@
'(expected: "~s" given: "~e")
(contract-name evt-ctc)
val))
(chaperone-evt val (generator (cons blame neg-party))))))
(chaperone-evt val
(generator (cons blame neg-party))
impersonator-prop:contracted evt-ctc
impersonator-prop:blame (blame-add-missing-party blame neg-party)))))
;; evt/c-first-order : Contract -> Any -> Boolean
;; First order check for evt/c

18
racket/collects/racket/contract/private/opters.rkt
View File

@ -464,9 +464,11 @@
(if (and (equal? (procedure-arity val) 1)
(let-values ([(a b) (procedure-keywords val)])
(null? b)))
(chaperone-procedure val exact-proc)
(chaperone-procedure val exact-proc
impersonator-prop:contracted ctc
impersonator-prop:blame blame)
(if (procedure-arity-includes? val 1)
(handle-non-exact-procedure val 1 blame exact-proc)
(handle-non-exact-procedure val 1 blame exact-proc ctc)
(raise-flat-arrow-err blame val 1))))
(raise-flat-arrow-err blame val 1)))))
#:lifts null
@ -567,6 +569,7 @@
(cons (optres-name optres-rng) rng-names))]))])
(values
(with-syntax ((val (opt/info-val opt/info))
(ctc (opt/info-contract opt/info))
(blame (opt/info-blame opt/info))
((dom-arg ...) dom-vars)
((rng-arg ...) rng-vars)
@ -608,8 +611,9 @@
(chaperone-procedure val exact-proc
impersonator-prop:application-mark
(cons opt->/c-cm-key cont-mark-value)
impersonator-prop:contracted ctc
impersonator-prop:blame blame)
(handle-non-exact-procedure val dom-len blame exact-proc))))
(handle-non-exact-procedure val dom-len blame exact-proc ctc))))
(append lifts-doms lifts-rngs)
(append superlifts-doms superlifts-rngs)
(append partials-doms partials-rngs)
@ -668,6 +672,7 @@
(values
(with-syntax ((blame (opt/info-blame opt/info))
(val (opt/info-val opt/info))
(ctc (opt/info-contract opt/info))
((dom-arg ...) dom-vars)
((next-dom ...) next-doms)
(dom-len (length dom-vars)))
@ -680,6 +685,7 @@
[(dom-arg ...) (values next-dom ...)]
[args
(bad-number-of-arguments blame val args dom-len)])
impersonator-prop:contracted ctc
impersonator-prop:blame blame)))
(if all-anys?
#`(if (procedure-arity-exactly/no-kwds val #,(length doms))
@ -739,7 +745,7 @@
(define/opter (predicate/c opt/i opt/info stx) (predicate/c-optres opt/info #t))
(define (handle-non-exact-procedure val dom-len blame exact-proc)
(define (handle-non-exact-procedure val dom-len blame exact-proc ctc)
(check-procedure val #f dom-len 0 '() '() blame #f)
(chaperone-procedure
val
@ -755,7 +761,9 @@
(cond
[(null? (cdr kwds)) '()]
[else (cons " " (loop (cdr kwds)))]))))))
exact-proc)))
exact-proc)
impersonator-prop:contracted ctc
impersonator-prop:blame blame))
(define (raise-flat-arrow-err blame val n)
(raise-blame-error blame val

10
racket/collects/racket/contract/private/struct-dc.rkt
View File

@ -314,7 +314,11 @@
[dep-args '()])
(cond
[(null? subcontracts)
(define (app* f v l) (if (null? l) v (apply f v l)))
(define (app* f v l)
(if (null? l)
v
(apply f v (append l (list impersonator-prop:contracted ctc
impersonator-prop:blame (blame-add-missing-party blame neg-party))))))
(app* chaperone-struct
(app* impersonate-struct
v
@ -1439,7 +1443,9 @@
#,(opt/info-val opt/info)
#,@(reverse s-chap-code) ;; built the last backwards, so reverse it here
stronger-prop-desc
(vector free-var ...)))
(vector free-var ...)
impersonator-prop:contracted #,(opt/info-contract opt/info)
impersonator-prop:blame #,(opt/info-blame opt/info)))
(struct/dc-error #,(opt/info-blame opt/info) #,(opt/info-val opt/info) 'struct-name)))))
#:lifts
s-lifts

1
racket/collects/racket/contract/private/unconstrained-domain-arrow.rkt
View File

@ -88,6 +88,7 @@
neg-party
projs)
impersonator-prop:contracted ctc
impersonator-prop:blame (blame-add-missing-party orig-blame neg-party)
impersonator-prop:application-mark
(cons tail-contract-key (list* neg-party blame-party-info range-contracts)))))))