From 3ddde6a7e9106087c0d9f41325ac9bc5d66f8d36 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Wed, 23 Jan 2013 13:04:57 -0500 Subject: [PATCH] Equip `parameter/c` with separate in/out contracts --- collects/racket/contract/private/misc.rkt | 33 +++++++------ .../scribblings/reference/contracts.scrbl | 21 +++++++- collects/tests/racket/contract-test.rktl | 49 ++++++++++++++++++- 3 files changed, 85 insertions(+), 18 deletions(-) diff --git a/collects/racket/contract/private/misc.rkt b/collects/racket/contract/private/misc.rkt index eaead9fc4a..2d9e8965dc 100644 --- a/collects/racket/contract/private/misc.rkt +++ b/collects/racket/contract/private/misc.rkt @@ -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 diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index cbd2f8cd6b..ed66dace5b 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -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?]{ diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index c3daa0bfea..07c858faa1 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -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))