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

Equip parameter/c with separate in/out contracts

Browse Source
This commit is contained in:
Asumu Takikawa 2013-01-23 13:04:57 -05:00
parent c3dcf823cb
commit 3ddde6a7e9
3 changed files with 85 additions and 18 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -850,20 +850,25 @@
(values p-app promise))))))))
#:first-order promise?))))
(define/subexpression-pos-prop (parameter/c x)
(make-parameter/c (coerce-contract 'parameter/c x)))
;; (parameter/c in/out-ctc)
;; (parameter/c in-ctc out-ctc)
(define/subexpression-pos-prop parameter/c
(λ (in-ctc [out-ctc in-ctc])
(make-parameter/c (coerce-contract 'parameter/c in-ctc)
(coerce-contract 'parameter-c out-ctc))))
(define-struct parameter/c (ctc)
(define-struct parameter/c (in out)
#:omit-define-syntaxes
#:property prop:contract
(build-contract-property
#:projection
(λ (ctc)
(let ([c-proc (contract-projection (parameter/c-ctc ctc))])
(let* ([in-proc (contract-projection (parameter/c-in ctc))]
[out-proc (contract-projection (parameter/c-out ctc))])
(λ (blame)
(define blame/c (blame-add-context blame "the parameter of"))
(define partial-neg-contract (c-proc (blame-swap blame/c)))
(define partial-pos-contract (c-proc blame/c))
(define partial-neg-contract (in-proc (blame-swap blame/c)))
(define partial-pos-contract (out-proc blame/c))
(λ (val)
(cond
[(parameter? val)
@ -875,23 +880,23 @@
(raise-blame-error blame val '(expected "a parameter"))])))))
#:name
(λ (ctc) (build-compound-type-name 'parameter/c (parameter/c-ctc ctc)))
(λ (ctc) (build-compound-type-name 'parameter/c
(parameter/c-in ctc)
(parameter/c-out ctc)))
#:first-order
(λ (ctc)
(let ([tst (contract-first-order (parameter/c-ctc ctc))])
(let ([tst (contract-first-order (parameter/c-out ctc))])
(λ (x)
(and (parameter? x)
(tst (x))))))
#:stronger
(λ (this that)
;; must be invariant (because the library doesn't currently split out pos/neg contracts
;; which could be tested individually ....)
(and (parameter/c? that)
(contract-stronger? (parameter/c-ctc this)
(parameter/c-ctc that))
(contract-stronger? (parameter/c-ctc that)
(parameter/c-ctc this))))))
(and (contract-stronger? (parameter/c-out this)
(parameter/c-out that))
(contract-stronger? (parameter/c-in that)
(parameter/c-in this)))))))
(define-struct procedure-arity-includes/c (n)
#:omit-define-syntaxes

21
collects/scribblings/reference/contracts.scrbl
View File

@ -476,10 +476,27 @@ inspect the entire tree.
}
@defproc[(parameter/c [c contract?]) contract?]{
@defproc[(parameter/c [in contract?] [out contract? in])
contract?]{
Produces a contract on parameters whose values must match
@racket[contract].}
@racket[_out]. When the value in the contracted parameter
is set, it must match @racket[_in].
@examples[#:eval (contract-eval)
(define/contract current-snack
(parameter/c string?)
(make-parameter "potato-chip"))
(define baked/c
(flat-named-contract 'baked/c (λ (s) (regexp-match #rx"baked" s))))
(define/contract current-dinner
(parameter/c string? baked/c)
(make-parameter "turkey" (λ (s) (string-append "roasted " s))))
(current-snack 'not-a-snack)
(parameterize ([current-dinner "tofurkey"])
(current-dinner))
]}
@defproc[(procedure-arity-includes/c [n exact-nonnegative-integer?]) flat-contract?]{

49
collects/tests/racket/contract-test.rktl
View File

@ -3869,11 +3869,42 @@
#f))
(test/pos-blame
'parameter/c1
'parameter/c2
'((contract (parameter/c integer?)
(make-parameter 'not-an-int)
'pos 'neg)))
(test/pos-blame
'parameter/c3
'((contract (parameter/c integer? string?)
(make-parameter 'not-an-int number->string)
'pos 'neg)))
(test/neg-blame
'parameter/c4
'((contract (parameter/c integer? string?)
(make-parameter 5 number->string)
'pos 'neg)
'not-an-int))
(test/spec-passed
'parameter/c5
'((contract (parameter/c integer? string?)
(make-parameter "foo" number->string)
'pos 'neg)))
(test/spec-passed
'parameter/c6
'((contract (parameter/c integer? string?)
(make-parameter "foo" number->string)
'pos 'neg)
5))
(test/pos-blame
'parameter/c7
'((contract (parameter/c integer? string?)
(make-parameter 5 values)
'pos 'neg)))
;
;
@ -12185,7 +12216,8 @@ so that propagation occurs.
(test-name '(list/c (-> boolean? boolean?) integer?)
(list/c (-> boolean? boolean?) integer?))
(test-name '(parameter/c integer?) (parameter/c integer?))
(test-name '(parameter/c integer? integer?) (parameter/c integer?))
(test-name '(parameter/c integer? string?) (parameter/c integer? string?))
(test-name '(hash/c symbol? boolean?) (hash/c symbol? boolean?))
(test-name '(hash/c symbol? boolean? #:immutable #t) (hash/c symbol? boolean? #:immutable #t))
@ -12363,6 +12395,19 @@ so that propagation occurs.
(ctest #f contract-stronger? (parameter/c (between/c 0 5)) (parameter/c (between/c 1 4)))
(ctest #f contract-stronger? (parameter/c (between/c 1 4)) (parameter/c (between/c 0 5)))
(ctest #f contract-stronger? (parameter/c (between/c 1 4) (between/c 0 5))
(parameter/c (between/c 0 5)))
(ctest #t contract-stronger? (parameter/c (between/c 0 5) (between/c 1 4))
(parameter/c (between/c 1 4)))
(ctest #t contract-stronger? (parameter/c (between/c 0 5))
(parameter/c (between/c 1 4) (between/c 0 5)))
(ctest #f contract-stronger? (parameter/c (between/c 1 4))
(parameter/c (between/c 0 5) (between/c 0 5)))
(ctest #t contract-stronger? (parameter/c (between/c 0 5) (between/c 1 4))
(parameter/c (between/c 1 4) (between/c 0 5)))
(ctest #f contract-stronger? (parameter/c (between/c 1 4) (between/c 0 5))
(parameter/c (between/c 0 5) (between/c 1 4)))
(ctest #t contract-stronger? (symbols 'x 'y) (symbols 'x 'y 'z))
(ctest #f contract-stronger? (symbols 'x 'y 'z) (symbols 'x 'y))
(ctest #t contract-stronger? (symbols 'x 'y) (symbols 'z 'x 'y))