replacing applicable structures for procedure options with chaperones + tweak-option + with-contract mode
This commit is contained in:
chrdimo
parent
be0e32b224
commit
7f67252cb3
|
|
@ -77,7 +77,7 @@
|
|||
(test-suite "options"
|
||||
|
||||
(test-suite "option/c"
|
||||
|
||||
|
||||
(test-contract-fail
|
||||
"failed tester"
|
||||
(script
|
||||
|
|
@ -114,7 +114,7 @@
|
|||
(define f values))
|
||||
(require 'server))
|
||||
"ctc")
|
||||
|
||||
|
||||
(test-contract-fail
|
||||
"failed option/c no invariant but immutable"
|
||||
(script
|
||||
|
|
@ -129,7 +129,7 @@
|
|||
"server"
|
||||
"an invariant keyword argument (based on presence of other keyword arguments)")
|
||||
|
||||
(test-contract-fail
|
||||
(test-contract-fail
|
||||
"failed option/c no invariant but flat"
|
||||
(script
|
||||
(module server racket
|
||||
|
|
@ -206,7 +206,7 @@
|
|||
((exercise-option f) 2 4)
|
||||
((exercise-option f) 2)))
|
||||
|
||||
(test-contract-fail
|
||||
(test-contract-fail
|
||||
"fails with option/c on function with case-lambda"
|
||||
(script
|
||||
(module server racket
|
||||
|
|
@ -240,7 +240,7 @@
|
|||
(define vec #(1 2 3 4 5)))
|
||||
(require 'server)))
|
||||
|
||||
(test-contract-fail
|
||||
(test-contract-fail
|
||||
"failed derived invariant/c (immutable) "
|
||||
(script
|
||||
(module server racket
|
||||
|
|
@ -249,33 +249,33 @@
|
|||
[vec (option/c
|
||||
any/c
|
||||
#:invariant values
|
||||
#:immutable #t)]))
|
||||
#:immutable #t)]))
|
||||
(define vec (vector 1 2 3 4 5)))
|
||||
(module client racket
|
||||
(require unstable/options)
|
||||
(require 'server)
|
||||
(exercise-option vec))
|
||||
(require 'client))
|
||||
"server")
|
||||
"server")
|
||||
|
||||
(test-contract-fail
|
||||
(test-contract-fail
|
||||
"failed derived invariant/c (procedure) "
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out
|
||||
[f (option/c
|
||||
any/c
|
||||
#:invariant values)]))
|
||||
any/c
|
||||
#:invariant values)]))
|
||||
(define f values))
|
||||
(module client racket
|
||||
(require unstable/options)
|
||||
(require 'server)
|
||||
(exercise-option f))
|
||||
(require 'client))
|
||||
"server")
|
||||
|
||||
(test-fail
|
||||
"server")
|
||||
|
||||
(test-fail
|
||||
"failed option/c for struct (unbound struct id)"
|
||||
(script
|
||||
(module server racket
|
||||
|
|
@ -333,7 +333,310 @@
|
|||
"server"
|
||||
"a struct of type foo"))
|
||||
|
||||
|
||||
(test-suite "option/c with contract"
|
||||
|
||||
(test-pass
|
||||
"passes with simple procedure contract"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [boo
|
||||
(option/c
|
||||
(-> number? number?)
|
||||
#:with-contract #t)]))
|
||||
(define (boo x) x))
|
||||
(require 'server)
|
||||
(boo 42)))
|
||||
|
||||
(test-contract-fail
|
||||
"fails (negative) with simple procedure contract"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [boo
|
||||
(option/c
|
||||
(-> number? number?)
|
||||
#:with-contract #t)]))
|
||||
(define (boo x) 42))
|
||||
(require 'server)
|
||||
(boo 'wrong))
|
||||
"top-level")
|
||||
|
||||
(test-contract-fail
|
||||
"fails (positive) with simple procedure contract"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [boo
|
||||
(option/c
|
||||
(-> number? number?)
|
||||
#:with-contract #t)]))
|
||||
(define (boo x) 'wrong))
|
||||
(require unstable/options 'server)
|
||||
(boo 42))
|
||||
"server")
|
||||
|
||||
(test-contract-fail
|
||||
"failed tester"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out
|
||||
[vec
|
||||
(option/c
|
||||
any/c
|
||||
#:with-contract #t
|
||||
#:tester sorted?)]))
|
||||
(define vec (vector 1 3 2 4 5))
|
||||
(define (sorted? vec)
|
||||
(for/and ([el vec]
|
||||
[cel (vector-drop vec 1)])
|
||||
(<= el cel))))
|
||||
(require 'server))
|
||||
"server"
|
||||
"option contract tester")
|
||||
|
||||
(test-contract-fail
|
||||
"failed option/c with misbehaving tester (indy)"
|
||||
(script
|
||||
(module ctc racket
|
||||
(require unstable/options)
|
||||
(provide indy-ctc)
|
||||
(define indy-ctc
|
||||
(option/c
|
||||
(-> number? number?)
|
||||
#:with-contract #t
|
||||
#:tester (λ (f) (f 'foo)))))
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(require 'ctc)
|
||||
(provide (contract-out [f indy-ctc]))
|
||||
(define f values))
|
||||
(require 'server))
|
||||
"ctc")
|
||||
|
||||
(test-contract-fail
|
||||
"failed option/c no invariant but immutable"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out
|
||||
[vec (option/c
|
||||
any/c
|
||||
#:with-contract #t
|
||||
#:immutable #t)]))
|
||||
(define vec (vector 1 2 3 4 5)))
|
||||
(require 'server))
|
||||
"server"
|
||||
"an invariant keyword argument (based on presence of other keyword arguments)")
|
||||
|
||||
(test-contract-fail
|
||||
"failed option/c no invariant but flat"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out
|
||||
[vec (option/c
|
||||
any/c
|
||||
#:with-contract #t
|
||||
#:flat? #t)]))
|
||||
(define vec (vector 1 2 3 4 5)))
|
||||
(require 'server))
|
||||
"server"
|
||||
"an invariant keyword argument (based on presence of other keyword arguments)")
|
||||
|
||||
(test-contract-fail
|
||||
"failed option/c no invariant but flat and immutable"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out
|
||||
[vec (option/c
|
||||
any/c
|
||||
#:flat? #t
|
||||
#:with-contract #t
|
||||
#:immutable #t)]))
|
||||
(define vec (vector 1 2 3 4 5)))
|
||||
(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?)
|
||||
#:with-contract #t)]))
|
||||
(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?)
|
||||
#:with-contract #t)]))
|
||||
(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?))
|
||||
#:with-contract #t)]))
|
||||
(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?))
|
||||
#:with-contract #t)]))
|
||||
(define f (case-lambda
|
||||
[(lo hi) (max lo hi)]
|
||||
[(single) single])))
|
||||
(require unstable/options)
|
||||
(require 'server)
|
||||
(f 2 "boo"))
|
||||
"top-level")
|
||||
|
||||
(test-pass
|
||||
"passes with option/c with invariant and flat and immutable"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out
|
||||
[vec (option/c
|
||||
any/c
|
||||
#:with-contract #t
|
||||
#:invariant values
|
||||
#:flat? #t
|
||||
#:immutable #t)]))
|
||||
(define vec #(1 2 3 4 5)))
|
||||
(require 'server)))
|
||||
|
||||
(test-contract-fail
|
||||
"failed derived invariant/c (immutable) "
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out
|
||||
[vec (option/c
|
||||
any/c
|
||||
#:with-contract #t
|
||||
#:invariant values
|
||||
#:immutable #t)]))
|
||||
(define vec (vector 1 2 3 4 5)))
|
||||
(require 'server))
|
||||
"server")
|
||||
|
||||
(test-contract-fail
|
||||
"failed derived invariant/c (procedure) "
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out
|
||||
[f (option/c
|
||||
any/c
|
||||
#:with-contract #t
|
||||
#:invariant values)]))
|
||||
(define f values))
|
||||
(require 'server))
|
||||
"server")
|
||||
|
||||
(test-fail
|
||||
"failed option/c for struct (unbound struct id)"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out
|
||||
[s (option/c
|
||||
any/c
|
||||
#:with-contract #t
|
||||
#:struct boo)]))
|
||||
(struct foo (a b))
|
||||
(define s (foo 2 2)))
|
||||
(require 'server))
|
||||
"expected a struct identifier")
|
||||
|
||||
(test-contract-fail
|
||||
"failed option/c for struct (missing struct id)"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out
|
||||
[s (option/c any/c #:with-contract #t)]))
|
||||
(struct foo (a b))
|
||||
(define s (foo 2 2)))
|
||||
(require 'server))
|
||||
"server"
|
||||
"a vector or a hash")
|
||||
|
||||
(test-contract-fail
|
||||
"failed option/c for struct (wrong struct id)"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out
|
||||
[s (option/c
|
||||
any/c
|
||||
#:struct boo
|
||||
#:with-contract #t)]))
|
||||
(struct foo (a b))
|
||||
(struct boo (a b))
|
||||
(define s (foo 2 2)))
|
||||
(require 'server))
|
||||
"server"
|
||||
"a struct of type boo")
|
||||
|
||||
(test-contract-fail
|
||||
"failed option/c for struct (vector for struct id)"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out
|
||||
[s (option/c
|
||||
any/c
|
||||
#:struct foo
|
||||
#:with-contract #t)]))
|
||||
(struct foo (a b))
|
||||
(define s (vector 2 2)))
|
||||
(require 'server))
|
||||
"server"
|
||||
"a struct of type foo"))
|
||||
|
||||
(test-suite "transfer-option"
|
||||
|
||||
|
|
@ -353,6 +656,102 @@
|
|||
(require unstable/options 'middle1)
|
||||
(boo 1)))
|
||||
|
||||
(test-pass
|
||||
"passes after two transfers (with contract)"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [boo
|
||||
(option/c
|
||||
(-> number? number?)
|
||||
#:with-contract #t)]))
|
||||
(define (boo x) x))
|
||||
(module middle0 racket
|
||||
(require unstable/options 'server)
|
||||
(provide (transfer-option boo)))
|
||||
(module middle1 racket
|
||||
(require unstable/options 'middle0)
|
||||
(provide (transfer-option boo)))
|
||||
(require unstable/options 'middle1)
|
||||
(boo 1)))
|
||||
|
||||
|
||||
|
||||
(test-contract-fail
|
||||
"fails (positive) after one transfer (with-contract)"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [boo
|
||||
(option/c
|
||||
(-> number? number?)
|
||||
#:with-contract #t)]))
|
||||
(define (boo x) 'wrong))
|
||||
(module client racket
|
||||
(require unstable/options 'server)
|
||||
(provide (transfer-option boo)))
|
||||
(require 'client)
|
||||
(displayln (boo 42))
|
||||
(boo 42))
|
||||
(list "client" "server"))
|
||||
|
||||
(test-contract-fail
|
||||
"fails (negative) after one transfer (with-contract)"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [boo
|
||||
(option/c
|
||||
(-> number? number?)
|
||||
#:with-contract #t)]))
|
||||
(define (boo x) x))
|
||||
(module client racket
|
||||
(require unstable/options 'server)
|
||||
(provide (transfer-option boo)))
|
||||
(require 'client)
|
||||
(boo 'wrong))
|
||||
(list "top-level" "client"))
|
||||
|
||||
(test-contract-fail
|
||||
"fails (positive) after two transfers (with contract)"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [boo
|
||||
(option/c
|
||||
(-> number? number?)
|
||||
#:with-contract #t)]))
|
||||
(define (boo x) 'wrong))
|
||||
(module middle0 racket
|
||||
(require unstable/options 'server)
|
||||
(provide (transfer-option boo)))
|
||||
(module middle1 racket
|
||||
(require unstable/options 'middle0)
|
||||
(provide (transfer-option boo)))
|
||||
(require unstable/options 'middle1)
|
||||
(boo 1))
|
||||
(list "middle1" "middle0" "server"))
|
||||
|
||||
(test-contract-fail
|
||||
"fails (negative) after two transfers (with contract)"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [boo
|
||||
(option/c
|
||||
(-> number? number?)
|
||||
#:with-contract #t)]))
|
||||
(define (boo x) x))
|
||||
(module middle0 racket
|
||||
(require unstable/options 'server)
|
||||
(provide (transfer-option boo)))
|
||||
(module middle1 racket
|
||||
(require unstable/options 'middle0)
|
||||
(provide (transfer-option boo)))
|
||||
(require unstable/options 'middle1)
|
||||
(boo 'wrong))
|
||||
(list "top-level" "middle1" "middle0"))
|
||||
|
||||
(test-pass
|
||||
"passes after void transfer"
|
||||
(script
|
||||
|
|
@ -373,9 +772,9 @@
|
|||
(require unstable/options 'server)
|
||||
(provide (transfer-option boo)))
|
||||
(require 'client)
|
||||
(boo 42)))
|
||||
(boo 42)))
|
||||
|
||||
(test-pass
|
||||
(test-pass
|
||||
"passes after void client's transfer after exercise"
|
||||
(script
|
||||
(module server racket
|
||||
|
|
@ -387,12 +786,26 @@
|
|||
(define e-boo (exercise-option boo))
|
||||
(provide (transfer-option e-boo)))
|
||||
(require 'client)
|
||||
(e-boo 42))))
|
||||
(e-boo 42)))
|
||||
|
||||
(test-pass
|
||||
"passes after void client's transfer after exercise (with-contract)"
|
||||
(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-pass
|
||||
"passes after two transfers and waive"
|
||||
"passes after two transfers and exercise"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
|
|
@ -405,7 +818,7 @@
|
|||
(require unstable/options 'middle0)
|
||||
(provide (transfer-option boo)))
|
||||
(require unstable/options 'middle1)
|
||||
((waive-option boo) 1)))
|
||||
((exercise-option boo) 1)))
|
||||
|
||||
(test-contract-fail
|
||||
"positive contract failure after successful transfer and exercise"
|
||||
|
|
@ -470,13 +883,99 @@
|
|||
(require unstable/options 'server)
|
||||
(define e-boo (exercise-option boo))
|
||||
(provide (transfer-option e-boo)))
|
||||
(require 'client)))
|
||||
|
||||
|
||||
(test-pass
|
||||
"passes after two transfers and exercise (with contract)"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [boo (option/c
|
||||
(-> number? number?)
|
||||
#:with-contract #t)]))
|
||||
(define (boo x) x))
|
||||
(module middle0 racket
|
||||
(require unstable/options 'server)
|
||||
(provide (transfer-option boo)))
|
||||
(module middle1 racket
|
||||
(require unstable/options 'middle0)
|
||||
(provide (transfer-option boo)))
|
||||
(require unstable/options 'middle1)
|
||||
((exercise-option boo) 1)))
|
||||
|
||||
(test-contract-fail
|
||||
"positive contract failure after successful transfer and exercise (with contract)"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [boo (option/c
|
||||
(-> number? number?)
|
||||
#:with-contract #t)]))
|
||||
(define (boo x) "wrong!"))
|
||||
(module middle racket
|
||||
(require unstable/options 'server)
|
||||
(provide (transfer-option boo)))
|
||||
(module client racket
|
||||
(require unstable/options 'middle)
|
||||
((exercise-option boo) 42))
|
||||
(require 'client))
|
||||
(list "middle" "server"))
|
||||
|
||||
(test-contract-fail
|
||||
"negative contract failure after successful transfer and exercise (with contract)"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [boo (option/c
|
||||
(-> number? number?)
|
||||
#:with-contract #t)]))
|
||||
(define (boo x) x))
|
||||
(module middle racket
|
||||
(require unstable/options 'server)
|
||||
(provide (transfer-option boo)))
|
||||
(module client racket
|
||||
(require unstable/options 'middle)
|
||||
((exercise-option boo) "wrong!"))
|
||||
(require 'client))
|
||||
(list "client" "middle"))
|
||||
|
||||
|
||||
(test-contract-fail
|
||||
"passes after exercise after succesful exercise (with contract)"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [boo (option/c
|
||||
(-> number? number?)
|
||||
#:with-contract #t)]))
|
||||
(define (boo x) x))
|
||||
(module client racket
|
||||
(require unstable/options 'server)
|
||||
((exercise-option (exercise-option boo)) "error"))
|
||||
(require 'client))
|
||||
"client")
|
||||
|
||||
(test-pass
|
||||
"passes after transfer after succesful exercise (with contract)"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [boo (option/c
|
||||
(-> number? number?)
|
||||
#:with-contract #t)]))
|
||||
(define (boo x) x))
|
||||
(module client racket
|
||||
(require unstable/options 'server)
|
||||
(define e-boo (exercise-option boo))
|
||||
(provide (transfer-option e-boo)))
|
||||
(require 'client))))
|
||||
|
||||
|
||||
(test-suite "waive-option"
|
||||
|
||||
(test-pass
|
||||
"passes after two transfers and exercise"
|
||||
"passes after two transfers and waive"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
|
|
@ -489,7 +988,7 @@
|
|||
(require unstable/options 'middle0)
|
||||
(provide (transfer-option boo)))
|
||||
(require unstable/options 'middle1)
|
||||
((exercise-option boo) 1)))
|
||||
((waive-option boo) 1)))
|
||||
|
||||
|
||||
(test-pass
|
||||
|
|
@ -510,7 +1009,7 @@
|
|||
((waive-option (waive-option boo)) "error")))
|
||||
|
||||
(test-contract-fail
|
||||
"passes with waive after succesful exercise"
|
||||
"fails with waive after succesful exercise"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
|
|
@ -523,7 +1022,7 @@
|
|||
"client")
|
||||
|
||||
(test-pass
|
||||
"passes transfer after succesful waive"
|
||||
"passes with transfer after succesful waive"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
|
|
@ -533,7 +1032,233 @@
|
|||
(require unstable/options 'server)
|
||||
(define e-boo (waive-option boo))
|
||||
(provide (transfer-option e-boo)))
|
||||
(require 'client)))))
|
||||
(require 'client)))
|
||||
|
||||
(test-pass
|
||||
"passes after two transfers and waive (with contract)"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [boo (option/c
|
||||
(-> number? number?)
|
||||
#:with-contract #t)]))
|
||||
(define (boo x) x))
|
||||
(module middle0 racket
|
||||
(require unstable/options 'server)
|
||||
(provide (transfer-option boo)))
|
||||
(module middle1 racket
|
||||
(require unstable/options 'middle0)
|
||||
(provide (transfer-option boo)))
|
||||
(require unstable/options 'middle1)
|
||||
((waive-option boo) 1)))
|
||||
|
||||
|
||||
(test-pass
|
||||
"passes after waive after succesful waive (with contract)"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [boo (option/c
|
||||
(-> number? number?)
|
||||
#:with-contract #t)]))
|
||||
(define (boo x) x))
|
||||
(require unstable/options 'server)
|
||||
((waive-option (waive-option boo)) "error")))
|
||||
|
||||
(test-contract-fail
|
||||
"fails with waive after succesful exercise (with contract)"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [boo (option/c
|
||||
(-> number? number?)
|
||||
#:with-contract #t)]))
|
||||
(define (boo x) x))
|
||||
(module client racket
|
||||
(require unstable/options 'server)
|
||||
((waive-option (exercise-option boo)) "error"))
|
||||
(require 'client))
|
||||
"client")
|
||||
|
||||
(test-pass
|
||||
"passes with transfer after succesful waive (with contract)"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [boo (option/c
|
||||
(-> number? number?)
|
||||
#:with-contract #t)]))
|
||||
(define (boo x) x))
|
||||
(module client racket
|
||||
(require unstable/options 'server)
|
||||
(define e-boo (waive-option boo))
|
||||
(provide (transfer-option e-boo)))
|
||||
(require 'client))))
|
||||
|
||||
(test-suite "tweak-option"
|
||||
|
||||
(test-pass
|
||||
"passes after two transfers and tweak"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [boo (option/c (-> number? number?))]))
|
||||
(define (boo x) x))
|
||||
(module middle0 racket
|
||||
(require unstable/options 'server)
|
||||
(provide (transfer-option boo)))
|
||||
(module middle1 racket
|
||||
(require unstable/options 'middle0)
|
||||
(provide (transfer-option boo)))
|
||||
(require unstable/options 'middle1)
|
||||
((tweak-option boo) 1)))
|
||||
|
||||
(test-contract-fail
|
||||
"fails (negative) after two transfers and tweak"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [boo (option/c (-> number? number?))]))
|
||||
(define (boo x) x))
|
||||
(module middle0 racket
|
||||
(require unstable/options 'server)
|
||||
(provide (transfer-option boo)))
|
||||
(module middle1 racket
|
||||
(require unstable/options 'middle0)
|
||||
(provide (transfer-option boo)))
|
||||
(require unstable/options 'middle1)
|
||||
((tweak-option boo) 'wrong))
|
||||
(list "top-level" "middle1" "middle0"))
|
||||
|
||||
(test-contract-fail
|
||||
"fails (positive) after two transfers and tweak"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [boo (option/c (-> number? number?))]))
|
||||
(define (boo x) 'wrong))
|
||||
(module middle0 racket
|
||||
(require unstable/options 'server)
|
||||
(provide (transfer-option boo)))
|
||||
(module middle1 racket
|
||||
(require unstable/options 'middle0)
|
||||
(provide (transfer-option boo)))
|
||||
(require unstable/options 'middle1)
|
||||
((tweak-option boo) 42))
|
||||
(list "middle1" "middle0" "server"))
|
||||
|
||||
(test-contract-fail
|
||||
"passes after two transfers and tweak"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [boo (option/c (-> number? number?))]))
|
||||
(define (boo x) x))
|
||||
(module middle0 racket
|
||||
(require unstable/options 'server)
|
||||
(provide (transfer-option boo)))
|
||||
(module middle1 racket
|
||||
(require unstable/options 'middle0)
|
||||
(provide (transfer-option boo)))
|
||||
(require unstable/options 'middle1)
|
||||
((tweak-option boo) 42)
|
||||
((tweak-option boo) 'wrong))
|
||||
(list "top-level" "middle1" "middle0"))
|
||||
|
||||
(test-pass
|
||||
"passes after two transfers and tweak (with-contract)"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [boo (option/c
|
||||
(-> number? number?)
|
||||
#:with-contract #t)]))
|
||||
(define (boo x) x))
|
||||
(module middle0 racket
|
||||
(require unstable/options 'server)
|
||||
(provide (transfer-option boo)))
|
||||
(module middle1 racket
|
||||
(require unstable/options 'middle0)
|
||||
(provide (transfer-option boo)))
|
||||
(require unstable/options 'middle1)
|
||||
((tweak-option boo) 1)))
|
||||
|
||||
|
||||
|
||||
|
||||
(test-pass
|
||||
"passes after tweak"
|
||||
(script
|
||||
(require unstable/options)
|
||||
(define (boo x) x)
|
||||
(tweak-option boo)))
|
||||
|
||||
(test-pass
|
||||
"fails after tweak after succesful tweak"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [boo (option/c (-> number? number?))]))
|
||||
(define (boo x) x))
|
||||
(require unstable/options 'server)
|
||||
((tweak-option (tweak-option boo)) "error")))
|
||||
|
||||
(test-contract-fail
|
||||
"fails after tweak after succesful tweak (with contract)"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [boo (option/c
|
||||
(-> number? number?)
|
||||
#:with-contract #t)]))
|
||||
(define (boo x) x))
|
||||
(require unstable/options 'server)
|
||||
((tweak-option (tweak-option boo)) "error"))
|
||||
"top-level")
|
||||
|
||||
|
||||
(test-contract-fail
|
||||
"fails with tweak after succesful 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)
|
||||
((tweak-option (exercise-option boo)) "error"))
|
||||
(require 'client))
|
||||
"client")
|
||||
|
||||
(test-contract-fail
|
||||
"fails with exercise after tweak 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)
|
||||
((exercise-option (tweak-option boo)) "error"))
|
||||
(require 'client))
|
||||
"client")
|
||||
|
||||
(test-contract-fail
|
||||
"fails with exercise after tweak exercise (with contract)"
|
||||
(script
|
||||
(module server racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [boo (option/c
|
||||
(-> number? number?)
|
||||
#:with-contract #t)]))
|
||||
(define (boo x) x))
|
||||
(module client racket
|
||||
(require unstable/options 'server)
|
||||
((exercise-option (tweak-option boo)) "error"))
|
||||
(require 'client))
|
||||
"client")))
|
||||
|
||||
|
||||
|
||||
|
||||
(test-suite "invariant/c"
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
#lang racket
|
||||
|
||||
|
||||
(provide option/c transfer-option exercise-option waive-option invariant/c
|
||||
has-option?)
|
||||
(provide option/c transfer-option exercise-option waive-option tweak-option
|
||||
has-option? has-option-with-contract?
|
||||
invariant/c)
|
||||
|
||||
|
||||
(require syntax/location
|
||||
|
|
@ -55,54 +56,50 @@
|
|||
#t
|
||||
(andmap boolean? (third s-info))))
|
||||
|
||||
(struct info (val proj blame))
|
||||
(struct info (val proj blame with))
|
||||
|
||||
(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)
|
||||
(build-proc-proxy ctc proxy-info)]
|
||||
[(vector? val)
|
||||
(chaperone-vector
|
||||
val
|
||||
(λ (v i val) val)
|
||||
(λ (v i val) val)
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:proxy proxy-info)]
|
||||
[(hash? val)
|
||||
(chaperone-hash
|
||||
val
|
||||
(λ (h k) (values k (λ (h k v) v)))
|
||||
(λ (h k v) (values k v))
|
||||
(λ (h k) k)
|
||||
(λ (h k) k)
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:proxy proxy-info)]
|
||||
[else
|
||||
(chaperone-struct
|
||||
val
|
||||
(first (second (option-structid ctc)))
|
||||
(λ (v f) f)
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:proxy proxy-info)])))
|
||||
(define (build-proxy with ctc val proj blame)
|
||||
(let* ([proxy-info (info val proj blame with)]
|
||||
[ival
|
||||
(cond [(procedure? val)
|
||||
(chaperone-procedure
|
||||
val
|
||||
(make-keyword-procedure
|
||||
(λ (kwds kwd-args . other-args)
|
||||
(apply values kwd-args other-args))
|
||||
(λ args
|
||||
(apply values args)))
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:proxy proxy-info)]
|
||||
[(vector? val)
|
||||
(chaperone-vector
|
||||
val
|
||||
(λ (v i val) val)
|
||||
(λ (v i val) val)
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:proxy proxy-info)]
|
||||
[(hash? val)
|
||||
(chaperone-hash
|
||||
val
|
||||
(λ (h k) (values k (λ (h k v) v)))
|
||||
(λ (h k v) (values k v))
|
||||
(λ (h k) k)
|
||||
(λ (h k) k)
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:proxy proxy-info)]
|
||||
[else
|
||||
(chaperone-struct
|
||||
val
|
||||
(first (second (option-structid ctc)))
|
||||
(λ (v f) f)
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:proxy proxy-info)])])
|
||||
(cond [with ((proj blame) ival)]
|
||||
[else ival])))
|
||||
|
||||
|
||||
(define (run-tester tester val orig-ctc blame here)
|
||||
|
|
@ -122,19 +119,22 @@
|
|||
(apply build-compound-type-name 'option/c
|
||||
(contract-name (option-orig-ctc c))
|
||||
(append
|
||||
(if (option-with c)
|
||||
(list '#:with-contract #t)
|
||||
null)
|
||||
(if (eq? (option-tester c) 'dont-care)
|
||||
null
|
||||
(list '#:tester (option-tester c)))
|
||||
(if (eq? (option-flat c) #f)
|
||||
null
|
||||
(list '#:flat? #t))
|
||||
(if (eq? (option-immutable c) 'dont-care)
|
||||
(if (eq? (option-immutable c) 'dont-care)
|
||||
null
|
||||
(list '#:immutable (option-immutable c)))
|
||||
(if (eq? (option-invariant c) 'dont-care)
|
||||
(if (eq? (option-invariant c) 'dont-care)
|
||||
null
|
||||
(list '#:invariant (option-invariant c)))
|
||||
(if (eq? (option-structid c) 'none)
|
||||
(if (eq? (option-structid c) 'none)
|
||||
null
|
||||
(list '#:struct (fourth (option-structid c)))))))
|
||||
|
||||
|
|
@ -150,11 +150,11 @@
|
|||
(when (and (eq? invariant 'dont-care)
|
||||
(or (not (eq? immutable 'dont-care))
|
||||
(not (eq? flat #f))))
|
||||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
'(expected "an invariant keyword argument (based on presence of other keyword arguments)")))
|
||||
(unless (or (and (procedure? val) (eq? structid 'none))
|
||||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
'(expected "an invariant keyword argument (based on presence of other keyword arguments)")))
|
||||
(unless (or (and (procedure? val) (not (parameter? val)) (eq? structid 'none))
|
||||
(and (vector? val) (eq? structid 'none))
|
||||
(and (hash? val) (eq? structid 'none))
|
||||
(and (not (eq? structid 'none)) (same-type val structid)))
|
||||
|
|
@ -165,11 +165,11 @@
|
|||
|
||||
|
||||
(define (build-orig-proj c inv flat immutable structid here)
|
||||
(cond [(eq? inv 'dont-care) (option-orig-ctc c)]
|
||||
(cond [(eq? inv 'dont-care) c]
|
||||
[else
|
||||
(invariantc (option-orig-ctc c) inv #:struct structid #:flat? flat #:immutable immutable here)]))
|
||||
(invariantc c inv #:struct structid #:flat? flat #:immutable immutable here)]))
|
||||
|
||||
(struct option (orig-ctc tester invariant flat immutable structid here)
|
||||
(struct option (orig-ctc with tester invariant flat immutable structid here)
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:name
|
||||
|
|
@ -183,29 +183,31 @@
|
|||
(λ (blame)
|
||||
(λ (val)
|
||||
(check-option ctc val blame)
|
||||
(let* ([tester (option-tester ctc)]
|
||||
(let* ([with (option-with ctc)]
|
||||
[tester (option-tester ctc)]
|
||||
[invariant (option-invariant ctc)]
|
||||
[flat (option-flat ctc)]
|
||||
[immutable (option-immutable ctc)]
|
||||
[structid (option-structid ctc)]
|
||||
[here (option-here ctc)]
|
||||
[orig-ctc (option-orig-ctc ctc)]
|
||||
[exec-ctc (build-orig-proj ctc invariant flat immutable structid here)])
|
||||
[exec-ctc (build-orig-proj orig-ctc invariant flat immutable structid here)])
|
||||
(unless (symbol? tester)
|
||||
(run-tester tester val orig-ctc blame here))
|
||||
(build-proxy ctc val (contract-projection exec-ctc)
|
||||
(build-proxy with ctc val (contract-projection exec-ctc)
|
||||
(blame-add-context
|
||||
blame
|
||||
"the option of"))))))))
|
||||
|
||||
(define (build-option ctc
|
||||
#:with-contract [with #f]
|
||||
#:tester [tester 'dont-care]
|
||||
#:invariant [invariant 'dont-care]
|
||||
#:flat? [flat #f]
|
||||
#:immutable [immutable 'dont-care]
|
||||
#:struct [structid 'none]
|
||||
here)
|
||||
(option ctc tester invariant flat immutable structid here))
|
||||
(option ctc with tester invariant flat immutable structid here))
|
||||
|
||||
|
||||
|
||||
|
|
@ -251,13 +253,7 @@
|
|||
(cond [(proxy? val)
|
||||
(let ((info (proxy-info val)))
|
||||
(build-proxy
|
||||
(value-contract val)
|
||||
(info-val info)
|
||||
(info-proj info)
|
||||
(blame-update (info-blame info) pos-blame neg-blame)))]
|
||||
[(proc-proxy? val)
|
||||
(let ((info (proc-proxy-proc-info val)))
|
||||
(build-proxy
|
||||
(info-with info)
|
||||
(value-contract val)
|
||||
(info-val info)
|
||||
(info-proj info)
|
||||
|
|
@ -275,10 +271,10 @@
|
|||
[(transferc id)
|
||||
(let ([this-one (gensym 'transfer-ctc)])
|
||||
(syntax-property
|
||||
(syntax/loc stx
|
||||
(transfer 'id))
|
||||
'racket/contract:contract
|
||||
(vector this-one null (list #'transferc))))]))
|
||||
(syntax/loc stx
|
||||
(transfer 'id))
|
||||
'racket/contract:contract
|
||||
(vector this-one null (list #'transferc))))]))
|
||||
|
||||
(define-syntax transfer-option
|
||||
(make-provide-pre-transformer
|
||||
|
|
@ -302,22 +298,35 @@
|
|||
(and (has-contract? val)
|
||||
(option? (value-contract val))))
|
||||
|
||||
(define (has-option-with-contract? val)
|
||||
(and (has-contract? val)
|
||||
(option? (value-contract val))
|
||||
(info-with (proxy-info val))))
|
||||
|
||||
(define (tweak-option val)
|
||||
(cond [(proxy? val)
|
||||
(let ((info (proxy-info val)))
|
||||
(build-proxy
|
||||
(not (info-with info))
|
||||
(value-contract val)
|
||||
(info-val info)
|
||||
(info-proj info)
|
||||
(info-blame info)))]
|
||||
[else val]))
|
||||
|
||||
(define (exercise-option val)
|
||||
(cond [(and (has-contract? val) (option? (value-contract val)))
|
||||
(let ((info (cond [(proxy? val) (proxy-info val)]
|
||||
[else (proc-proxy-proc-info val)])))
|
||||
(cond [(proxy? val)
|
||||
(let ([info (proxy-info val)])
|
||||
(((info-proj info)
|
||||
(info-blame info))
|
||||
(info-val info)))]
|
||||
[else val]))
|
||||
|
||||
(define (waive-option 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))])]
|
||||
(cond [(proxy? val) (info-val (proxy-info val))]
|
||||
[else val]))
|
||||
|
||||
|
||||
|
||||
|
||||
;
|
||||
;
|
||||
|
|
@ -473,14 +482,14 @@
|
|||
(if (procedure? first)
|
||||
(list* first a-wrap rest)
|
||||
rest))
|
||||
'()
|
||||
(second s-info))]
|
||||
'()
|
||||
(second s-info))]
|
||||
[wrapped-mutators (foldr (λ (first rest)
|
||||
(if (procedure? first)
|
||||
(list* first (m-wrap first) rest)
|
||||
rest))
|
||||
'()
|
||||
(third s-info))]
|
||||
'()
|
||||
(third s-info))]
|
||||
[struct-wrapper
|
||||
(λ (wrapper)
|
||||
(apply
|
||||
|
|
@ -508,13 +517,13 @@
|
|||
(λ (val)
|
||||
(check val raise-blame #f)
|
||||
(unless (invariant (((contract-projection orig-ctc) indy-blame) val))
|
||||
(let ([kind (cond [(vector? val) 'vector]
|
||||
[(hash? val) 'hash]
|
||||
[else 'struct])])
|
||||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
(format "expected ~s that satisfies ~s given: ~e" kind invariant val))))
|
||||
(let ([kind (cond [(vector? val) 'vector]
|
||||
[(hash? val) 'hash]
|
||||
[else 'struct])])
|
||||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
(format "expected ~s that satisfies ~s given: ~e" kind invariant val))))
|
||||
(build-inv-proxy ctc val invariant proj blame indy-blame impersonate?)))))))
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -10,6 +10,7 @@
|
|||
@defmodule[unstable/options]
|
||||
|
||||
@defproc[(option/c [c contract?]
|
||||
[#:with-contract with boolean? #f]
|
||||
[#:tester tester (or/c (-> any boolean?) 'dont-care) 'dont-care]
|
||||
[#:invariant invariant (or/c (-> any boolean?) 'dont-care) 'dont-care]
|
||||
[#:immutable immutable (or/c #t #f 'dont-care) 'dont-care]
|
||||
|
|
@ -22,8 +23,12 @@ struct @racket[struct-id]. The data structure must match @racket[c] and pass the
|
|||
@racket[tester].
|
||||
|
||||
When an @racket[option/c] contract is attached to a value, the value is checked against the
|
||||
@racket[tester], if @racket[tester] is a predicate. After that, contract checking is disabled for the value.
|
||||
@racket[tester], if @racket[tester] is a predicate. After that,
|
||||
contract checking is disabled for the value, if @racket[with] is @racket[#f]. If @racket[with]
|
||||
is @racket[#t] contract checking for the value remains enabled for @racket[c].
|
||||
|
||||
If @racket[waive-option] is applied to a value guarded by an @racket[option/c]
|
||||
contract, then @racket[waive-option] returns the value after removing the @racket[option/c] guard.
|
||||
If @racket[exercise-option] is applied to a value guarded by an @racket[option/c]
|
||||
contract, then @racket[exercise-option] returns the value with contract checking
|
||||
enabled for @racket[c]. If the @racket[invariant] argument is a predicate, then
|
||||
|
|
@ -51,6 +56,15 @@ is a predicate. In any other case, the result is a contract error.
|
|||
(vector-ref vec 1)
|
||||
|
||||
(module server1 racket
|
||||
(require unstable/options)
|
||||
(provide
|
||||
(contract-out
|
||||
[vec (option/c (vectorof number?) #:with-contract #t)]))
|
||||
(define vec (vector 1 2 3 4)))
|
||||
(require 'server1)
|
||||
(vector-set! vec 1 'foo)
|
||||
|
||||
(module server2 racket
|
||||
(require unstable/options)
|
||||
(provide
|
||||
(contract-out
|
||||
|
|
@ -60,24 +74,25 @@ is a predicate. In any other case, the result is a contract error.
|
|||
(for/and ([el vec]
|
||||
[cel (vector-drop vec 1)])
|
||||
(<= el cel))))
|
||||
(require 'server1)
|
||||
(require 'server2)
|
||||
]
|
||||
|
||||
|
||||
}
|
||||
|
||||
@defproc[(exercise-option [x has-option?]) any/c]{
|
||||
@defproc[(exercise-option [x any/c]) any/c]{
|
||||
|
||||
Returns @racket[x] with contract ckecking enabled if an @racket[option/c] guards
|
||||
@racket[x]. In any other case it returns @racket[x].
|
||||
@racket[x]. In any other case it returns @racket[x]. The result of @racket[exercise-option]
|
||||
loses the guard related to @racket[option/c], if it has one to begin with, and thus its contract checking status cannot change further.
|
||||
|
||||
@defexamples[
|
||||
#:eval the-eval
|
||||
(module server2 racket
|
||||
(module server3 racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [foo (option/c (-> number? symbol?))]))
|
||||
(define foo (λ (x) x)))
|
||||
(require 'server2 unstable/options)
|
||||
(require 'server3 unstable/options)
|
||||
(define e-foo (exercise-option foo))
|
||||
(foo 42)
|
||||
(e-foo 'wrong)
|
||||
|
|
@ -101,49 +116,80 @@ each @racket[id] is provided from the module as usual.
|
|||
|
||||
@defexamples[
|
||||
#:eval the-eval
|
||||
(module server3 racket
|
||||
(module server4 racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [foo (option/c (-> number? symbol?))]))
|
||||
(define foo (λ (x) x)))
|
||||
(module middleman racket
|
||||
(require unstable/options 'server3)
|
||||
(require unstable/options 'server4)
|
||||
(provide (transfer-option foo)))
|
||||
(require 'middleman unstable/options)
|
||||
(define e-foo (exercise-option foo))
|
||||
(e-foo 1)
|
||||
(e-foo 'wrong)
|
||||
(module server4 racket
|
||||
(module server5 racket
|
||||
(require unstable/options)
|
||||
(provide [transfer-option boo])
|
||||
(define (boo x) x))
|
||||
(require 'server4)
|
||||
(require 'server5)
|
||||
(boo 42)]
|
||||
|
||||
|
||||
|
||||
@defproc[(waive-option [x has-option?]) any/c]{
|
||||
@defproc[(waive-option [x any/c]) 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 it returns @racket[x].
|
||||
In any other case it returns @racket[x]. The result of @racket[waive-option]
|
||||
loses the guard related to @racket[option/c], if it had one to begin with, and thus its contract checking status cannot change further.
|
||||
|
||||
@defexamples[
|
||||
#:eval the-eval
|
||||
(module server5 racket
|
||||
(module server6 racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [bar (option/c (-> number? symbol?))]))
|
||||
(define bar (λ (x) x)))
|
||||
(require 'server5 unstable/options)
|
||||
(require 'server6 unstable/options)
|
||||
(define e-bar (waive-option bar))
|
||||
(e-bar 'wrong)
|
||||
((waive-option e-bar) 42)]
|
||||
((waive-option e-bar) 'wrong)]
|
||||
}
|
||||
|
||||
@defproc[(tweak-option [x any/c]) any/c]{
|
||||
|
||||
If an @racket[option/c] guards @racket[x] and contract checking for @racket[x] is enabled,
|
||||
then @racket[tweak-option] returns
|
||||
@racket[x] with contract checking for @racket[x] disabled.
|
||||
If an @racket[option/c] guards @racket[x] and contract checking for @racket[x] is disabled,
|
||||
then @racket[tweak-option] returns
|
||||
@racket[x] with contract checking for @racket[x] enabled.
|
||||
In any other case it returns @racket[x]. The result of @racket[tweak-option]
|
||||
retains the guard related to @racket[option/c] if it has one to begin with and thus its contract checking status can change further
|
||||
using @racket[tweak-option], @racket[exercise-option] or @racket[waive-option].
|
||||
|
||||
@defexamples[
|
||||
#:eval the-eval
|
||||
(module server7 racket
|
||||
(require unstable/options)
|
||||
(provide (contract-out [bar (option/c (-> number? symbol?))]))
|
||||
(define bar (λ (x) x)))
|
||||
(require 'server7 unstable/options)
|
||||
(define t-bar (tweak-option bar))
|
||||
(t-bar 'wrong)
|
||||
((tweak-option t-bar) 'wrong)
|
||||
((waive-option t-bar) 'wrong)
|
||||
((exercise-option t-bar) 'wrong)
|
||||
]
|
||||
}
|
||||
|
||||
|
||||
@defproc[(has-option? [v any/c]) boolean?]{
|
||||
Returns @racket[#t] if @racket[v] has an option contract.
|
||||
}
|
||||
|
||||
|
||||
@defproc[(has-option-with-contract? [v any/c]) boolean?]{
|
||||
Returns @racket[#t] if @racket[v] has an option contract with contract checking enabled.
|
||||
}
|
||||
|
||||
@defproc[(invariant/c [c contract?]
|
||||
[invariant (-> any boolean?)]
|
||||
|
|
@ -168,7 +214,7 @@ are chaperone contracts, then the result will be a chaperone contract.
|
|||
|
||||
@defexamples[
|
||||
#:eval the-eval
|
||||
(module server6 racket
|
||||
(module server8 racket
|
||||
(require unstable/options)
|
||||
(provide
|
||||
change
|
||||
|
|
@ -182,7 +228,7 @@ are chaperone contracts, then the result will be a chaperone contract.
|
|||
(for/and ([el vec]
|
||||
[cel (vector-drop vec 1)])
|
||||
(<= el cel))))
|
||||
(require 'server6)
|
||||
(require 'server8)
|
||||
(vector-set! vec 2 42)
|
||||
(change)
|
||||
(vector-ref vec 2)]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user