support for keyword argumnets + transfer-option, exercise-option and waive-option do not raise an error on values without an option
This commit is contained in:
chrdimo
parent
2846c17cb4
commit
a3a98fd933
|
|
@ -158,6 +158,74 @@
|
|||
"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"
|
||||
|
|
|
|||
|
|
@ -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)])
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user