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

support for keyword argumnets + transfer-option, exercise-option and waive-option do not raise an error on values without an option

Browse Source
This commit is contained in:
chrdimo 2013-02-25 22:18:17 -05:00
parent 2846c17cb4
commit a3a98fd933
3 changed files with 181 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

153
collects/tests/unstable/options.rkt
View File

@ -158,6 +158,74 @@
"server" "server"
"an invariant keyword argument (based on presence of other keyword arguments)") "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 (test-pass
"passes with option/c with invariant and flat and immutable" "passes with option/c with invariant and flat and immutable"
(script (script
@ -285,19 +353,17 @@
(require unstable/options 'middle1) (require unstable/options 'middle1)
(boo 1))) (boo 1)))
(test-contract-fail (test-pass
"fails upon transfer" "passes after void transfer"
(script (script
(module server racket (module server racket
(require unstable/options) (require unstable/options)
(provide [transfer-option boo]) (provide [transfer-option boo])
(define (boo x) x)) (define (boo x) x))
(require 'server)) (require 'server)))
"server"
"does not have an option in")
(test-contract-fail (test-pass
"fails upon client's transfer" "passes after void client's transfer"
(script (script
(module server racket (module server racket
(require unstable/options) (require unstable/options)
@ -306,9 +372,22 @@
(module client racket (module client racket
(require unstable/options 'server) (require unstable/options 'server)
(provide (transfer-option boo))) (provide (transfer-option boo)))
(require 'client)) (require 'client)
"client" (boo 42)))
"does not have an option in"))
(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" (test-suite "exercise-option"
@ -360,18 +439,15 @@
(require 'client)) (require 'client))
(list "client" "middle")) (list "client" "middle"))
(test-fail (test-pass
"failed exercise" "passes after void exercise"
(script (script
(module server racket
(require unstable/options) (require unstable/options)
(define (boo x) x) (define (boo x) x)
(exercise-option boo)) (exercise-option boo)))
(require 'server))
"has no option to exercise")
(test-fail (test-contract-fail
"failed exercise after succesful exercise" "passes after exercise after succesful exercise"
(script (script
(module server racket (module server racket
(require unstable/options) (require unstable/options)
@ -381,10 +457,10 @@
(require unstable/options 'server) (require unstable/options 'server)
((exercise-option (exercise-option boo)) "error")) ((exercise-option (exercise-option boo)) "error"))
(require 'client)) (require 'client))
"has no option to exercise") "client")
(test-contract-fail (test-pass
"failed transfer after succesful exercise" "passes after transfer after succesful exercise"
(script (script
(module server racket (module server racket
(require unstable/options) (require unstable/options)
@ -394,9 +470,7 @@
(require unstable/options 'server) (require unstable/options 'server)
(define e-boo (exercise-option boo)) (define e-boo (exercise-option boo))
(provide (transfer-option e-boo))) (provide (transfer-option e-boo)))
(require 'client)) (require 'client))))
"client"
"does not have an option in"))
(test-suite "waive-option" (test-suite "waive-option"
@ -418,31 +492,25 @@
((exercise-option boo) 1))) ((exercise-option boo) 1)))
(test-fail (test-pass
"failed waive" "passes after waive"
(script (script
(module server racket
(require unstable/options) (require unstable/options)
(define (boo x) x) (define (boo x) x)
(waive-option boo)) (waive-option boo)))
(require 'server))
"has no option to waive")
(test-fail (test-pass
"failed waive after succesful waive" "passes after waive after succesful waive"
(script (script
(module server racket (module server racket
(require unstable/options) (require unstable/options)
(provide (contract-out [boo (option/c (-> number? number?))])) (provide (contract-out [boo (option/c (-> number? number?))]))
(define (boo x) x)) (define (boo x) x))
(module client racket
(require unstable/options 'server) (require unstable/options 'server)
((waive-option (waive-option boo)) "error")) ((waive-option (waive-option boo)) "error")))
(require 'client))
"has no option to waive")
(test-fail (test-contract-fail
"failed waive after succesful exercise" "passes with waive after succesful exercise"
(script (script
(module server racket (module server racket
(require unstable/options) (require unstable/options)
@ -452,10 +520,10 @@
(require unstable/options 'server) (require unstable/options 'server)
((waive-option (exercise-option boo)) "error")) ((waive-option (exercise-option boo)) "error"))
(require 'client)) (require 'client))
"has no option to waive") "client")
(test-contract-fail (test-pass
"failed transfer after succesful waive" "passes transfer after succesful waive"
(script (script
(module server racket (module server racket
(require unstable/options) (require unstable/options)
@ -465,8 +533,7 @@
(require unstable/options 'server) (require unstable/options 'server)
(define e-boo (waive-option boo)) (define e-boo (waive-option boo))
(provide (transfer-option e-boo))) (provide (transfer-option e-boo)))
(require 'client)) (require 'client)))))
"client")))
(test-suite "invariant/c" (test-suite "invariant/c"

64
collects/unstable/options.rkt
View File

@ -55,22 +55,31 @@
#t #t
(andmap boolean? (third s-info)))) (andmap boolean? (third s-info))))
(struct info (val proj blame)) (struct info (val proj blame))
(define-values (impersonator-prop:proxy proxy? proxy-info) (define-values (impersonator-prop:proxy proxy? proxy-info)
(make-impersonator-property 'proxy)) (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) (define (build-proxy ctc val proj blame)
(let ([proxy-info (info val proj blame)]) (let ([proxy-info (info val proj blame)])
(cond [(procedure? val) (cond [(procedure? val)
(chaperone-procedure (build-proc-proxy ctc proxy-info)]
val
values
impersonator-prop:contracted ctc
impersonator-prop:proxy proxy-info)]
[(vector? val) [(vector? val)
(chaperone-vector (chaperone-vector
val val
@ -202,6 +211,12 @@
(define-syntax (option/c stx) (define-syntax (option/c stx)
(syntax-case 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 ...) [(optionc arg ...)
(let ([args (syntax->list #'(arg ...))] (let ([args (syntax->list #'(arg ...))]
[this-one (gensym 'option-ctc)]) [this-one (gensym 'option-ctc)])
@ -240,10 +255,23 @@
(info-val info) (info-val info)
(info-proj info) (info-proj info)
(blame-update (info-blame info) pos-blame neg-blame)))] (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) (define-syntax (transfer/c stx)
(syntax-case 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) [(transferc id)
(let ([this-one (gensym 'transfer-ctc)]) (let ([this-one (gensym 'transfer-ctc)])
(syntax-property (syntax-property
@ -275,17 +303,19 @@
(option? (value-contract val)))) (option? (value-contract val))))
(define (exercise-option val) (define (exercise-option val)
(cond [(has-option? val) (cond [(and (has-contract? val) (option? (value-contract val)))
(let ((info (proxy-info val))) (let ((info (cond [(proxy? val) (proxy-info val)]
[else (proc-proxy-proc-info val)])))
(((info-proj info) (((info-proj info)
(info-blame info)) (info-blame info))
(info-val info)))] (info-val info)))]
[else (error 'exercise-option-error "~a has no option to exercise" val)])) [else val]))
(define (waive-option val) (define (waive-option val)
(cond [(has-option? val) (cond [(and (has-contract? val) (option? (value-contract val)))
(info-val (proxy-info val))] (cond [(proxy? val) (info-val (proxy-info val))]
[else (error 'waive-option-error "~a has no option to waive" val)])) [else (info-val (proc-proxy-proc-info val))])]
[else val]))
@ -504,6 +534,12 @@
(define-syntax (invariant/c stx) (define-syntax (invariant/c stx)
(syntax-case 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 ...) [(invc arg ...)
(let ([args (syntax->list #'(arg ...))] (let ([args (syntax->list #'(arg ...))]
[this-one (gensym 'invariant-ctc)]) [this-one (gensym 'invariant-ctc)])

28
collects/unstable/scribblings/options.scrbl
View File

@ -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]{ @defproc[(exercise-option [x has-option?]) any/c]{
Returns @racket[x] with contract ckecking enabled if an @racket[option/c] guards 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[ @defexamples[
#:eval the-eval #:eval the-eval
@ -79,9 +79,10 @@ Returns @racket[x] with contract ckecking enabled if an @racket[option/c] guards
(define foo (λ (x) x))) (define foo (λ (x) x)))
(require 'server2 unstable/options) (require 'server2 unstable/options)
(define e-foo (exercise-option foo)) (define e-foo (exercise-option foo))
(foo 1) (foo 42)
(e-foo 'wrong) (e-foo 'wrong)
(exercise-option e-foo)] ((exercise-option e-foo) 'wrong)
]
} }
@defform[(transfer-option id ...)]{ @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 @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 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 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[ @defexamples[
@ -114,15 +116,16 @@ to the positive and negative blame parties respectively. If @racket[id] is not b
(require unstable/options) (require unstable/options)
(provide [transfer-option boo]) (provide [transfer-option boo])
(define (boo x) x)) (define (boo x) x))
(require 'server4)] (require 'server4)
} (boo 42)]
@defproc[(waive-option [x has-option?]) any/c]{ @defproc[(waive-option [x has-option?]) any/c]{
If an @racket[option/c] guards @racket[x], then @racket[waive-option] returns If an @racket[option/c] guards @racket[x], then @racket[waive-option] returns
@racket[x] without the @racket[option/c] guard. @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[ @defexamples[
#:eval the-eval #:eval the-eval
@ -132,11 +135,12 @@ In any other case the result is an error.
(define bar (λ (x) x))) (define bar (λ (x) x)))
(require 'server5 unstable/options) (require 'server5 unstable/options)
(define e-bar (waive-option bar)) (define e-bar (waive-option bar))
(e-bar 1) (e-bar 'wrong)
(exercise-option e-bar) ((waive-option e-bar) 42)]
(waive-option e-bar)]
} }
@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) @(close-eval the-eval)