From a3a98fd93363660133159af84e183b330b4deead Mon Sep 17 00:00:00 2001 From: chrdimo Date: Mon, 25 Feb 2013 22:18:17 -0500 Subject: [PATCH] support for keyword argumnets + transfer-option, exercise-option and waive-option do not raise an error on values without an option --- collects/tests/unstable/options.rkt | 165 ++++++++++++++------ collects/unstable/options.rkt | 64 ++++++-- collects/unstable/scribblings/options.scrbl | 28 ++-- 3 files changed, 181 insertions(+), 76 deletions(-) diff --git a/collects/tests/unstable/options.rkt b/collects/tests/unstable/options.rkt index 6e89f6bb7d..99623891c9 100644 --- a/collects/tests/unstable/options.rkt +++ b/collects/tests/unstable/options.rkt @@ -157,7 +157,75 @@ (require 'server)) "server" "an invariant keyword argument (based on presence of other keyword arguments)") - + + (test-pass + "passes with option/c on function with keyword arguments" + (script + (module server racket + (require unstable/options) + (provide (contract-out + [f (option/c + (-> number? #:more number? number?))])) + (define (f x #:more y) y)) + (require unstable/options) + (require 'server) + (f 2 #:more 3) + ((exercise-option f) 2 #:more 3))) + + (test-pass + "passes with option/c on function with optional keyword arguments" + (script + (module server racket + (require unstable/options) + (provide (contract-out + [f (option/c (->* (number?) (#:more number?) number?))])) + (define (f x #:more [y 3]) y)) + (require unstable/options) + (require 'server) + (f 2) + (f 2 #:more 4) + ((exercise-option f) 2 #:more 4) + ((exercise-option f) 2))) + + (test-pass + "passes with option/c on function with case-lambda" + (script + (module server racket + (require unstable/options) + (provide (contract-out + [f (option/c (case-> + (-> number? number? number?) + (-> number? number?)))])) + (define f (case-lambda + [(lo hi) (max lo hi)] + [(single) single]))) + (require unstable/options) + (require 'server) + (f 2) + (f 2 4) + ((exercise-option f) 2 4) + ((exercise-option f) 2))) + + (test-contract-fail + "fails with option/c on function with case-lambda" + (script + (module server racket + (require unstable/options) + (provide (contract-out + [f (option/c (case-> + (-> number? number? number?) + (-> number? number?)))])) + (define f (case-lambda + [(lo hi) (max lo hi)] + [(single) single]))) + (require unstable/options) + (require 'server) + (f 2) + (f 2 4) + ((exercise-option f) 2 "boo") + ((exercise-option f) 2)) + "top-level") + (test-pass "passes with option/c with invariant and flat and immutable" (script @@ -285,19 +353,17 @@ (require unstable/options 'middle1) (boo 1))) - (test-contract-fail - "fails upon transfer" + (test-pass + "passes after void transfer" (script (module server racket (require unstable/options) (provide [transfer-option boo]) (define (boo x) x)) - (require 'server)) - "server" - "does not have an option in") + (require 'server))) - (test-contract-fail - "fails upon client's transfer" + (test-pass + "passes after void client's transfer" (script (module server racket (require unstable/options) @@ -306,9 +372,22 @@ (module client racket (require unstable/options 'server) (provide (transfer-option boo))) - (require 'client)) - "client" - "does not have an option in")) + (require 'client) + (boo 42))) + + (test-pass + "passes after void client's transfer after exercise" + (script + (module server racket + (require unstable/options) + (provide (contract-out [boo (option/c (-> number? number?))])) + (define (boo x) x)) + (module client racket + (require unstable/options 'server) + (define e-boo (exercise-option boo)) + (provide (transfer-option e-boo))) + (require 'client) + (e-boo 42)))) (test-suite "exercise-option" @@ -360,18 +439,15 @@ (require 'client)) (list "client" "middle")) - (test-fail - "failed exercise" + (test-pass + "passes after void exercise" (script - (module server racket - (require unstable/options) - (define (boo x) x) - (exercise-option boo)) - (require 'server)) - "has no option to exercise") + (require unstable/options) + (define (boo x) x) + (exercise-option boo))) - (test-fail - "failed exercise after succesful exercise" + (test-contract-fail + "passes after exercise after succesful exercise" (script (module server racket (require unstable/options) @@ -381,10 +457,10 @@ (require unstable/options 'server) ((exercise-option (exercise-option boo)) "error")) (require 'client)) - "has no option to exercise") + "client") - (test-contract-fail - "failed transfer after succesful exercise" + (test-pass + "passes after transfer after succesful exercise" (script (module server racket (require unstable/options) @@ -394,9 +470,7 @@ (require unstable/options 'server) (define e-boo (exercise-option boo)) (provide (transfer-option e-boo))) - (require 'client)) - "client" - "does not have an option in")) + (require 'client)))) (test-suite "waive-option" @@ -418,31 +492,25 @@ ((exercise-option boo) 1))) - (test-fail - "failed waive" + (test-pass + "passes after waive" (script - (module server racket - (require unstable/options) - (define (boo x) x) - (waive-option boo)) - (require 'server)) - "has no option to waive") + (require unstable/options) + (define (boo x) x) + (waive-option boo))) - (test-fail - "failed waive after succesful waive" + (test-pass + "passes after waive after succesful waive" (script (module server racket (require unstable/options) (provide (contract-out [boo (option/c (-> number? number?))])) (define (boo x) x)) - (module client racket - (require unstable/options 'server) - ((waive-option (waive-option boo)) "error")) - (require 'client)) - "has no option to waive") + (require unstable/options 'server) + ((waive-option (waive-option boo)) "error"))) - (test-fail - "failed waive after succesful exercise" + (test-contract-fail + "passes with waive after succesful exercise" (script (module server racket (require unstable/options) @@ -452,10 +520,10 @@ (require unstable/options 'server) ((waive-option (exercise-option boo)) "error")) (require 'client)) - "has no option to waive") + "client") - (test-contract-fail - "failed transfer after succesful waive" + (test-pass + "passes transfer after succesful waive" (script (module server racket (require unstable/options) @@ -465,8 +533,7 @@ (require unstable/options 'server) (define e-boo (waive-option boo)) (provide (transfer-option e-boo))) - (require 'client)) - "client"))) + (require 'client))))) (test-suite "invariant/c" diff --git a/collects/unstable/options.rkt b/collects/unstable/options.rkt index 6f22af4144..c6f329c366 100644 --- a/collects/unstable/options.rkt +++ b/collects/unstable/options.rkt @@ -55,22 +55,31 @@ #t (andmap boolean? (third s-info)))) - (struct info (val proj blame)) - (define-values (impersonator-prop:proxy proxy? proxy-info) (make-impersonator-property 'proxy)) +(struct proc-proxy (proc ctc proc-info) + #:property prop:procedure (struct-field-index proc) + #:property prop:contracted (struct-field-index ctc)) + +(define (build-proc-proxy ctc proc-info) + (let ((val (info-val proc-info))) + (proc-proxy + (if (object-name val) + (procedure-rename + val + (object-name val)) + val) + ctc + proc-info))) + (define (build-proxy ctc val proj blame) (let ([proxy-info (info val proj blame)]) (cond [(procedure? val) - (chaperone-procedure - val - values - impersonator-prop:contracted ctc - impersonator-prop:proxy proxy-info)] + (build-proc-proxy ctc proxy-info)] [(vector? val) (chaperone-vector val @@ -202,6 +211,12 @@ (define-syntax (option/c stx) (syntax-case stx () + [x + (identifier? #'x) + (syntax-property + (syntax/loc stx option/c) + 'racket/contract:contract + (vector (gensym 'ctc) (list stx) null))] [(optionc arg ...) (let ([args (syntax->list #'(arg ...))] [this-one (gensym 'option-ctc)]) @@ -240,10 +255,23 @@ (info-val info) (info-proj info) (blame-update (info-blame info) pos-blame neg-blame)))] - [else (raise-blame-error option-blame val "")]))))))) + [(proc-proxy? val) + (let ((info (proc-proxy-proc-info val))) + (build-proxy + (value-contract val) + (info-val info) + (info-proj info) + (blame-update (info-blame info) pos-blame neg-blame)))] + [else val]))))))) (define-syntax (transfer/c stx) (syntax-case stx () + [x + (identifier? #'x) + (syntax-property + (syntax/loc stx transfer/c) + 'racket/contract:contract + (vector (gensym 'ctc) (list stx) null))] [(transferc id) (let ([this-one (gensym 'transfer-ctc)]) (syntax-property @@ -275,17 +303,19 @@ (option? (value-contract val)))) (define (exercise-option val) - (cond [(has-option? val) - (let ((info (proxy-info val))) + (cond [(and (has-contract? val) (option? (value-contract val))) + (let ((info (cond [(proxy? val) (proxy-info val)] + [else (proc-proxy-proc-info val)]))) (((info-proj info) (info-blame info)) (info-val info)))] - [else (error 'exercise-option-error "~a has no option to exercise" val)])) + [else val])) (define (waive-option val) - (cond [(has-option? val) - (info-val (proxy-info val))] - [else (error 'waive-option-error "~a has no option to waive" val)])) + (cond [(and (has-contract? val) (option? (value-contract val))) + (cond [(proxy? val) (info-val (proxy-info val))] + [else (info-val (proc-proxy-proc-info val))])] + [else val])) @@ -504,6 +534,12 @@ (define-syntax (invariant/c stx) (syntax-case stx () + [x + (identifier? #'x) + (syntax-property + (syntax/loc stx invariant/c) + 'racket/contract:contract + (vector (gensym 'ctc) (list stx) null))] [(invc arg ...) (let ([args (syntax->list #'(arg ...))] [this-one (gensym 'invariant-ctc)]) diff --git a/collects/unstable/scribblings/options.scrbl b/collects/unstable/scribblings/options.scrbl index 377a3d5093..8552ccf9b7 100644 --- a/collects/unstable/scribblings/options.scrbl +++ b/collects/unstable/scribblings/options.scrbl @@ -69,7 +69,7 @@ is a predicate. In any other case, the result is a contract error. @defproc[(exercise-option [x has-option?]) any/c]{ Returns @racket[x] with contract ckecking enabled if an @racket[option/c] guards -@racket[x]. In any other case the result is an error. +@racket[x]. In any other case it returns @racket[x]. @defexamples[ #:eval the-eval @@ -79,9 +79,10 @@ Returns @racket[x] with contract ckecking enabled if an @racket[option/c] guards (define foo (λ (x) x))) (require 'server2 unstable/options) (define e-foo (exercise-option foo)) -(foo 1) +(foo 42) (e-foo 'wrong) -(exercise-option e-foo)] +((exercise-option e-foo) 'wrong) +] } @defform[(transfer-option id ...)]{ @@ -94,7 +95,8 @@ is provided from the module if @racket[id] is bound to a value guarded with an @racket[option/c] contract. In addition, @racket[transfer-option] modifies the blame information for the @racket[option/c] contract by adding the providing module and its client to the positive and negative blame parties respectively. If @racket[id] is not bound to a value guarded with an -@racket[option/c] contract, then the result is a contract error. +@racket[option/c] contract, then @racket[(provide [transfer id ...])] is equivalent to @racket[(provide id ...)] i.e. +each @racket[id] is provided from the module as usual. } @defexamples[ @@ -114,15 +116,16 @@ to the positive and negative blame parties respectively. If @racket[id] is not b (require unstable/options) (provide [transfer-option boo]) (define (boo x) x)) -(require 'server4)] -} +(require 'server4) +(boo 42)] + @defproc[(waive-option [x has-option?]) any/c]{ If an @racket[option/c] guards @racket[x], then @racket[waive-option] returns @racket[x] without the @racket[option/c] guard. -In any other case the result is an error. +In any other case it returns @racket[x]. @defexamples[ #:eval the-eval @@ -132,11 +135,12 @@ In any other case the result is an error. (define bar (λ (x) x))) (require 'server5 unstable/options) (define e-bar (waive-option bar)) -(e-bar 1) -(exercise-option e-bar) -(waive-option e-bar)] +(e-bar 'wrong) +((waive-option e-bar) 42)] } +@defproc[(has-option? [v any/c]) boolean?]{ + Returns @racket[#t] if @racket[v] has an option contract. } @@ -185,9 +189,7 @@ are chaperone contracts, then the result will be a chaperone contract. } -@defproc[(has-option? [v any/c]) boolean?]{ - Returns @racket[#t] if @racket[v] has an option contract. -} + @(close-eval the-eval)