2084 lines
127 KiB
Racket
2084 lines
127 KiB
Racket
#lang racket
|
|
|
|
|
|
(require rackunit rackunit/text-ui unstable/options)
|
|
|
|
|
|
(define-syntax-rule (test-pass test-name expr)
|
|
(test-case test-name (check-pass expr)))
|
|
|
|
(define-syntax-rule (check-pass expr)
|
|
(check-not-exn (λ () expr)))
|
|
|
|
(define-syntax-rule (test-fail test-name expr error-msg)
|
|
(test-case test-name (check-fail expr error-msg)))
|
|
|
|
(define-syntax-rule (check-fail expr error-msg)
|
|
(check-exn (λ (exn)
|
|
(and
|
|
(exn:fail? exn)
|
|
(regexp-match?
|
|
(regexp-quote error-msg)
|
|
(exn-message exn))))
|
|
(λ () expr)))
|
|
|
|
|
|
(define-syntax test-contract-fail
|
|
(syntax-rules ()
|
|
[(test-contract-fail test-name expr error-msg)
|
|
(test-case test-name (check-contract-fail expr error-msg))]
|
|
[(test-contract-fail test-name expr error-msg extra-msg)
|
|
(test-case test-name
|
|
(check-contract-fail expr error-msg extra-msg))]))
|
|
|
|
|
|
(define-syntax check-contract-fail
|
|
(syntax-rules ()
|
|
[(check-contract-fail expr error-msg)
|
|
(check-exn (λ (exn)
|
|
(and (exn:fail? exn)
|
|
(has-proper-blame? error-msg (exn-message exn))))
|
|
(λ () expr))]
|
|
[(check-contract-fail expr error-msg extra-msg)
|
|
(check-exn (λ (exn)
|
|
(and (exn:fail? exn)
|
|
(has-proper-blame? error-msg (exn-message exn) extra-msg)))
|
|
(λ () expr))]))
|
|
|
|
(define (has-proper-blame? blame msg [extra ""])
|
|
(define options-preface
|
|
(regexp-quote "blaming multiple parties:"))
|
|
(define (multi-blame->regexp blame)
|
|
(foldr
|
|
(λ (fst rst) (string-append (format "\n ~a" fst) rst))
|
|
""
|
|
blame))
|
|
(define reg
|
|
(cond
|
|
[(string? blame) (string-append "blaming: " (regexp-quote blame))]
|
|
[(list? blame) (string-append
|
|
options-preface
|
|
(multi-blame->regexp blame))]
|
|
[else #f]))
|
|
(define extra-reg (regexp-quote extra))
|
|
(and reg (regexp-match? reg msg) (regexp-match? extra-reg msg)))
|
|
|
|
|
|
(define-syntax-rule (script e ...)
|
|
(parameterize ([current-namespace (make-base-namespace)])
|
|
(namespace-require '(for-syntax racket/base))
|
|
(eval 'e) ...))
|
|
|
|
|
|
(run-tests
|
|
(test-suite "options.rkt"
|
|
|
|
|
|
(test-suite "options"
|
|
|
|
(test-suite "option/c"
|
|
|
|
(test-contract-fail
|
|
"failed tester"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[vec
|
|
(option/c
|
|
any/c
|
|
#: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?)
|
|
#: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
|
|
#: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
|
|
#: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
|
|
#: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?))]))
|
|
(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
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[vec (option/c
|
|
any/c
|
|
#: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
|
|
#:invariant values
|
|
#:immutable #t)]))
|
|
(define vec (vector 1 2 3 4 5)))
|
|
(module client racket
|
|
(require unstable/options)
|
|
(require 'server)
|
|
(exercise-option vec))
|
|
(require 'client))
|
|
"server")
|
|
|
|
(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)]))
|
|
(define f values))
|
|
(module client racket
|
|
(require unstable/options)
|
|
(require 'server)
|
|
(exercise-option f))
|
|
(require 'client))
|
|
"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
|
|
#: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)]))
|
|
(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)]))
|
|
(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)]))
|
|
(struct foo (a b))
|
|
(define s (vector 2 2)))
|
|
(require 'server))
|
|
"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/c"
|
|
|
|
(test-pass
|
|
"passes after two transfers"
|
|
(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 (contract-out [boo transfer/c])))
|
|
(module middle1 racket
|
|
(require unstable/options 'middle0)
|
|
(provide (contract-out [boo transfer/c])))
|
|
(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 (contract-out [boo transfer/c])))
|
|
(module middle1 racket
|
|
(require unstable/options 'middle0)
|
|
(provide (contract-out [boo transfer/c])))
|
|
(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 (contract-out [boo transfer/c])))
|
|
(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 (contract-out [boo transfer/c])))
|
|
(require 'client)
|
|
(boo 'wrong))
|
|
(list "top-level" "top-level"))
|
|
|
|
(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 (contract-out [boo transfer/c])))
|
|
(module middle1 racket
|
|
(require unstable/options 'middle0)
|
|
(provide (contract-out [boo transfer/c])))
|
|
(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 (contract-out [boo transfer/c])))
|
|
(module middle1 racket
|
|
(require unstable/options 'middle0)
|
|
(provide (contract-out [boo transfer/c])))
|
|
(require unstable/options 'middle1)
|
|
(boo 'wrong))
|
|
(list "top-level" "top-level" "top-level"))
|
|
|
|
(test-pass
|
|
"passes after void transfer"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out [boo transfer/c]))
|
|
(define (boo x) x))
|
|
(require 'server)))
|
|
|
|
(test-pass
|
|
"passes after void client's transfer"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out [boo (-> number? number?)]))
|
|
(define (boo x) x))
|
|
(module client racket
|
|
(require unstable/options 'server)
|
|
(provide (contract-out [boo transfer/c])))
|
|
(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 (contract-out [e-boo transfer/c])))
|
|
(require 'client)
|
|
(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 (contract-out [e-boo transfer/c])))
|
|
(require 'client)
|
|
(e-boo 42)))
|
|
|
|
(test-contract-fail
|
|
"fails (positive-ho) after three transfers and exercise (with-contract)"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out [boo
|
|
(option/c
|
|
(-> number? number?)
|
|
#:with-contract #t)]
|
|
[bar (-> transfer/c number?)]))
|
|
(define (boo x) 'wrong)
|
|
(define (bar f) ((exercise-option f) 42)))
|
|
(module client racket
|
|
(require unstable/options 'server)
|
|
(provide (contract-out [boo transfer/c]
|
|
[bar transfer/c])))
|
|
(module client1 racket
|
|
(require unstable/options 'client)
|
|
(provide (contract-out [boo transfer/c]
|
|
[bar transfer/c])))
|
|
(require 'client1)
|
|
(bar boo))
|
|
(list "top-level" "client1" "client" "server"))
|
|
|
|
(test-contract-fail
|
|
"fails (negative-ho) after three transfers and exercise (with-contract)"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out [boo
|
|
(option/c
|
|
(-> number? number?)
|
|
#:with-contract #t)]
|
|
[bar (-> transfer/c number?)]))
|
|
(define (boo x) 'wrong)
|
|
(define (bar f) ((exercise-option f) 'wrong)))
|
|
(module client racket
|
|
(require unstable/options 'server)
|
|
(provide (contract-out [boo transfer/c]
|
|
[bar transfer/c])))
|
|
(module client1 racket
|
|
(require unstable/options 'client)
|
|
(provide (contract-out [boo transfer/c]
|
|
[bar transfer/c])))
|
|
(require 'client1)
|
|
(bar boo))
|
|
(list "server" "top-level" "top-level" "top-level")))
|
|
|
|
(test-suite "exercise-option"
|
|
|
|
(test-pass
|
|
"passes after two transfers and exercise"
|
|
(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 (contract-out [boo transfer/c])))
|
|
(module middle1 racket
|
|
(require unstable/options 'middle0)
|
|
(provide (contract-out [boo transfer/c])))
|
|
(require unstable/options 'middle1)
|
|
((exercise-option boo) 1)))
|
|
|
|
(test-contract-fail
|
|
"positive contract failure after successful transfer and exercise"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out [boo (option/c (-> number? number?))]))
|
|
(define (boo x) "wrong!"))
|
|
(module middle racket
|
|
(require unstable/options 'server)
|
|
(provide (contract-out [boo transfer/c])))
|
|
(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"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out [boo (option/c (-> number? number?))]))
|
|
(define (boo x) x))
|
|
(module middle racket
|
|
(require unstable/options 'server)
|
|
(provide (contract-out [boo transfer/c])))
|
|
(module client racket
|
|
(require unstable/options 'middle)
|
|
((exercise-option boo) "wrong!"))
|
|
(require 'client))
|
|
(list "client" "client"))
|
|
|
|
(test-pass
|
|
"passes after void exercise"
|
|
(script
|
|
(require unstable/options)
|
|
(define (boo x) x)
|
|
(exercise-option boo)))
|
|
|
|
(test-contract-fail
|
|
"passes after exercise 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)
|
|
((exercise-option (exercise-option boo)) "error"))
|
|
(require 'client))
|
|
"client")
|
|
|
|
(test-pass
|
|
"passes after transfer 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)
|
|
(define e-boo (exercise-option boo))
|
|
(provide (contract-out [e-boo transfer/c])))
|
|
(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 (contract-out [boo transfer/c])))
|
|
(module middle1 racket
|
|
(require unstable/options 'middle0)
|
|
(provide (contract-out [boo transfer/c])))
|
|
(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 (contract-out [boo transfer/c])))
|
|
(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 (contract-out [boo transfer/c])))
|
|
(module client racket
|
|
(require unstable/options 'middle)
|
|
((exercise-option boo) "wrong!"))
|
|
(require 'client))
|
|
(list "client" "client"))
|
|
|
|
|
|
(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 (contract-out [e-boo transfer/c])))
|
|
(require 'client))))
|
|
|
|
|
|
(test-suite "waive-option"
|
|
|
|
(test-pass
|
|
"passes after two transfers and waive"
|
|
(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 (contract-out [boo transfer/c])))
|
|
(module middle1 racket
|
|
(require unstable/options 'middle0)
|
|
(provide (contract-out [boo transfer/c])))
|
|
(require unstable/options 'middle1)
|
|
((waive-option boo) 1)))
|
|
|
|
|
|
(test-pass
|
|
"passes after waive"
|
|
(script
|
|
(require unstable/options)
|
|
(define (boo x) x)
|
|
(waive-option boo)))
|
|
|
|
(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))
|
|
(require unstable/options 'server)
|
|
((waive-option (waive-option boo)) "error")))
|
|
|
|
(test-contract-fail
|
|
"fails with waive 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)
|
|
((waive-option (exercise-option boo)) "error"))
|
|
(require 'client))
|
|
"client")
|
|
|
|
(test-pass
|
|
"passes with transfer 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)
|
|
(define e-boo (waive-option boo))
|
|
(provide (contract-out [e-boo transfer/c])))
|
|
(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 (contract-out [boo transfer/c])))
|
|
(module middle1 racket
|
|
(require unstable/options 'middle0)
|
|
(provide (contract-out [boo transfer/c])))
|
|
(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 (contract-out [e-boo transfer/c])))
|
|
(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 (contract-out [boo transfer/c])))
|
|
(module middle1 racket
|
|
(require unstable/options 'middle0)
|
|
(provide (contract-out [boo transfer/c])))
|
|
(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 (contract-out [boo transfer/c])))
|
|
(module middle1 racket
|
|
(require unstable/options 'middle0)
|
|
(provide (contract-out [boo transfer/c])))
|
|
(require unstable/options 'middle1)
|
|
((tweak-option boo) 'wrong))
|
|
(list "top-level" "top-level" "top-level"))
|
|
|
|
(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 (contract-out [boo transfer/c])))
|
|
(module middle1 racket
|
|
(require unstable/options 'middle0)
|
|
(provide (contract-out [boo transfer/c])))
|
|
(require unstable/options 'middle1)
|
|
((tweak-option boo) 42))
|
|
(list "middle1" "middle0" "server"))
|
|
|
|
(test-contract-fail
|
|
"fails (negative) 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 (contract-out [boo transfer/c])))
|
|
(module middle1 racket
|
|
(require unstable/options 'middle0)
|
|
(provide (contract-out [boo transfer/c])))
|
|
(require unstable/options 'middle1)
|
|
((tweak-option boo) 42)
|
|
((tweak-option boo) 'wrong))
|
|
(list "top-level" "top-level" "top-level"))
|
|
|
|
(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 (contract-out [boo transfer/c])))
|
|
(module middle1 racket
|
|
(require unstable/options 'middle0)
|
|
(provide (contract-out [boo transfer/c])))
|
|
(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"
|
|
|
|
(test-suite "general"
|
|
|
|
(test-contract-fail
|
|
"failed invariant/c on invalid kind of data"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[f (invariant/c
|
|
any/c
|
|
values)]))
|
|
(define f (λ (x) x)))
|
|
(require 'server))
|
|
"server"
|
|
"a vector or a hash")
|
|
|
|
(test-contract-fail
|
|
"failed invariant/c because of misbehaving invariant (indy)"
|
|
(script
|
|
(module ctc racket
|
|
(require unstable/options)
|
|
(provide indy-ctc)
|
|
(define (sorted? vec)
|
|
(vector-set! vec 1 'a)
|
|
(for/and ([el vec]
|
|
[cel (vector-drop vec 1)])
|
|
(<= el cel)))
|
|
(define indy-ctc
|
|
(invariant/c (vectorof number?) sorted?)))
|
|
(module server racket
|
|
(require unstable/options)
|
|
(require 'ctc)
|
|
(provide (contract-out
|
|
[vec indy-ctc]))
|
|
(define vec (vector 1 2 3 4 5)))
|
|
(require 'server))
|
|
"ctc"))
|
|
|
|
|
|
|
|
(test-suite "vectors"
|
|
|
|
(test-pass
|
|
"passes with invariant for vector"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[vec (invariant/c
|
|
any/c
|
|
sorted?)]))
|
|
(define vec (vector 1 2 3 4 5))
|
|
(define (sorted? vec)
|
|
(for/and ([el vec]
|
|
[cel (vector-drop vec 1)])
|
|
(<= el cel))))
|
|
(require 'server)))
|
|
|
|
(test-contract-fail
|
|
"failed invariant for vector"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[vec (invariant/c
|
|
any/c
|
|
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"
|
|
"expected vector that satisfies")
|
|
|
|
(test-contract-fail
|
|
"failed underlying vector/c contract"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[vec (invariant/c
|
|
(vectorof number?)
|
|
sorted?)
|
|
]))
|
|
(define vec (vector 1 'foo 3 4 5))
|
|
(define (sorted? vec)
|
|
(for/and ([el vec]
|
|
[cel (vector-drop vec 1)])
|
|
(<= el cel))))
|
|
(require 'server))
|
|
"server")
|
|
|
|
(test-contract-fail
|
|
"failed immutable invariant/c for vector"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[vec (invariant/c
|
|
any/c
|
|
sorted?
|
|
#:immutable #t)]))
|
|
(define vec (vector 1 2 3 4 5))
|
|
(define (sorted? vec)
|
|
(for/and ([el vec]
|
|
[cel (vector-drop vec 1)])
|
|
(<= el cel))))
|
|
(require 'server))
|
|
"server"
|
|
"immutable data")
|
|
|
|
(test-contract-fail
|
|
"failed mutable invariant/c for vector"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[vec (invariant/c
|
|
any/c
|
|
sorted?
|
|
#:immutable #f)]))
|
|
(define vec #(1 2 3 4 5))
|
|
(define (sorted? vec)
|
|
(for/and ([el vec]
|
|
[cel (vector-drop vec 1)])
|
|
(<= el cel))))
|
|
(require 'server))
|
|
"server"
|
|
"mutable data")
|
|
|
|
|
|
(test-pass
|
|
"passes with immutable invariant/c for vector"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[vec (invariant/c
|
|
any/c
|
|
sorted?
|
|
#:immutable #t)]))
|
|
(define vec #(1 2 3 4 5))
|
|
(define (sorted? vec)
|
|
(for/and ([el vec]
|
|
[cel (vector-drop vec 1)])
|
|
(<= el cel))))
|
|
(require 'server)))
|
|
|
|
(test-pass
|
|
"passes with mutable invariant/c for vector"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[vec (invariant/c
|
|
any/c
|
|
sorted?
|
|
#:immutable #f)]))
|
|
(define vec (vector 1 2 3 4 5))
|
|
(define (sorted? vec)
|
|
(for/and ([el vec]
|
|
[cel (vector-drop vec 1)])
|
|
(<= el cel))))
|
|
(require 'server)))
|
|
|
|
(test-pass
|
|
"passes with mutable flat invariant/c for vector"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[vec (invariant/c
|
|
any/c
|
|
sorted?
|
|
#:immutable #f
|
|
#:flat? #t)]))
|
|
(define vec (vector 1 2 3 4 5))
|
|
(define (sorted? vec)
|
|
(for/and ([el vec]
|
|
[cel (vector-drop vec 1)])
|
|
(<= el cel))))
|
|
(require 'server)))
|
|
|
|
(test-pass
|
|
"passes with mutation on mutable flat invariant/c for vector"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[vec (invariant/c
|
|
any/c
|
|
sorted?
|
|
#:immutable #f
|
|
#:flat? #t)]))
|
|
(define vec (vector 1 2 3 4 5))
|
|
(define (sorted? vec)
|
|
(for/and ([el vec]
|
|
[cel (vector-drop vec 1)])
|
|
(<= el cel))))
|
|
(module client racket
|
|
(require unstable/options)
|
|
(require 'server)
|
|
(vector-set! vec 1 10))
|
|
(require 'client)))
|
|
|
|
(test-contract-fail
|
|
"failed mutation on mutable invariant/c for vector"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[vec (invariant/c
|
|
any/c
|
|
sorted?
|
|
#:immutable #f
|
|
#:flat? #f)]))
|
|
(define vec (vector 1 2 3 4 5))
|
|
(define (sorted? vec)
|
|
(for/and ([el vec]
|
|
[cel (vector-drop vec 1)])
|
|
(<= el cel))))
|
|
(module client racket
|
|
(require unstable/options)
|
|
(require 'server)
|
|
(vector-set! vec 1 10))
|
|
(require 'client))
|
|
"client"
|
|
"expected vector that satisfies")
|
|
|
|
(test-contract-fail
|
|
"failed read after callback mutation on mutable invariant/c for vector"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide
|
|
change
|
|
(contract-out
|
|
[vec (invariant/c
|
|
any/c
|
|
sorted?
|
|
#:immutable #f
|
|
#:flat? #f)]))
|
|
(define vec (vector 1 2 3 4 5))
|
|
(define (change) (vector-set! vec 1 10))
|
|
(define (sorted? vec)
|
|
(for/and ([el vec]
|
|
[cel (vector-drop vec 1)])
|
|
(<= el cel))))
|
|
(module client racket
|
|
(require unstable/options)
|
|
(require 'server)
|
|
(change)
|
|
(vector-ref vec 2))
|
|
(require 'client))
|
|
"server"
|
|
"expected vector that satisfies"))
|
|
|
|
|
|
(test-suite "hashes"
|
|
|
|
(test-pass
|
|
"passes with invariant for hash"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[h (invariant/c
|
|
any/c
|
|
a-is-one)]))
|
|
(define h (hash 'a 1 'b 2 'c 3 'd 4 'd 5))
|
|
(define (a-is-one h)
|
|
(= (hash-ref h 'a) 1)))
|
|
(require 'server)))
|
|
|
|
(test-contract-fail
|
|
"failed invariant for hash"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[h (invariant/c
|
|
any/c
|
|
a-is-one)]))
|
|
(define h (hash 'a 2 'b 2 'c 3 'd 4 'd 5))
|
|
(define (a-is-one h)
|
|
(= (hash-ref h 'a) 1)))
|
|
(require 'server))
|
|
"server"
|
|
"expected hash that satisfies")
|
|
|
|
(test-contract-fail
|
|
"failed underlying hash/c contract"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[h (invariant/c
|
|
(hash/c symbol? number?)
|
|
a-is-one)]))
|
|
(define h (hash 'a 2 'b 'b 'c 3 'd 4 'd 5))
|
|
(define (a-is-one h)
|
|
(= (hash-ref h 'a) 1)))
|
|
(require 'server))
|
|
"server")
|
|
|
|
(test-contract-fail
|
|
"failed immutable invariant/c for hash"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[h (invariant/c
|
|
(hash/c symbol? number?)
|
|
a-is-one
|
|
#:immutable #t)]))
|
|
(define h (make-hash (list (cons 'a 2) (cons 'b 2))))
|
|
(define (a-is-one h)
|
|
(= (hash-ref h 'a) 1)))
|
|
(require 'server))
|
|
"server"
|
|
"immutable data")
|
|
|
|
(test-contract-fail
|
|
"failed mutable invariant/c for hash"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[h (invariant/c
|
|
(hash/c symbol? number?)
|
|
a-is-one
|
|
#:immutable #f)]))
|
|
(define h (hash 'a 2 'b 2))
|
|
(define (a-is-one h)
|
|
(= (hash-ref h 'a) 1)))
|
|
(require 'server))
|
|
"server"
|
|
"mutable data")
|
|
|
|
(test-pass
|
|
"passes with immutable invariant/c for hash"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[h (invariant/c
|
|
(hash/c symbol? number?)
|
|
a-is-one
|
|
#:immutable #t)]))
|
|
(define h (hash 'a 1 'b 2))
|
|
(define (a-is-one h)
|
|
(= (hash-ref h 'a) 1)))
|
|
(require 'server)))
|
|
|
|
(test-pass
|
|
"passes with mutable invariant/c for hash"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[h (invariant/c
|
|
(hash/c symbol? number?)
|
|
a-is-one
|
|
#:immutable #f)]))
|
|
(define h (make-hash (list (cons 'a 1) (cons 'b 2))))
|
|
(define (a-is-one h)
|
|
(= (hash-ref h 'a) 1)))
|
|
(require 'server)))
|
|
|
|
|
|
(test-pass
|
|
"passes with mutable flat invariant/c for hash"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[h (invariant/c
|
|
(hash/c symbol? number?)
|
|
a-is-one
|
|
#:flat? #t
|
|
#:immutable #f)]))
|
|
(define h (make-hash (list (cons 'a 1) (cons 'b 2))))
|
|
(define (a-is-one h)
|
|
(= (hash-ref h 'a) 1)))
|
|
(require 'server)))
|
|
|
|
(test-pass
|
|
"passes with mutation on mutable flat invariant/c for hash"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[h (invariant/c
|
|
(hash/c symbol? number?)
|
|
a-is-one
|
|
#:flat? #t
|
|
#:immutable #f)]))
|
|
(define h (make-hash (list (cons 'a 1) (cons 'b 2))))
|
|
(define (a-is-one h)
|
|
(= (hash-ref h 'a) 1)))
|
|
(module client racket
|
|
(require unstable/options)
|
|
(require 'server)
|
|
(hash-set! h 'a 10))
|
|
(require 'client)))
|
|
|
|
|
|
(test-contract-fail
|
|
"failed mutation on mutable invariant/c for hash"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[h (invariant/c
|
|
(hash/c symbol? number?)
|
|
a-is-one
|
|
#:flat? #f
|
|
#:immutable #f)]))
|
|
(define h (make-hash (list (cons 'a 1) (cons 'b 2))))
|
|
(define (a-is-one h)
|
|
(= (hash-ref h 'a) 1)))
|
|
(module client racket
|
|
(require unstable/options)
|
|
(require 'server)
|
|
(hash-set! h 'a 10))
|
|
(require 'client))
|
|
"client"
|
|
"expected hash that satisfies")
|
|
|
|
(test-contract-fail
|
|
"failed read after callback mutation on mutable invariant/c for hash"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide
|
|
change
|
|
(contract-out
|
|
[h (invariant/c
|
|
(hash/c symbol? number?)
|
|
a-is-one
|
|
#:flat? #f
|
|
#:immutable #f)]))
|
|
(define h (make-hash (list (cons 'a 1) (cons 'b 2))))
|
|
(define (change) (hash-set! h 'a 2))
|
|
(define (a-is-one h)
|
|
(= (hash-ref h 'a) 1)))
|
|
(module client racket
|
|
(require unstable/options)
|
|
(require 'server)
|
|
(change)
|
|
(hash-ref h 'b))
|
|
(require 'client))
|
|
"server"
|
|
"expected hash that satisfies"))
|
|
|
|
(test-suite "structs"
|
|
|
|
(test-pass
|
|
"passes with invariant for struct"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide
|
|
(contract-out
|
|
[s (invariant/c
|
|
any/c
|
|
a-is-one
|
|
#:struct foo)]))
|
|
(struct foo (a b))
|
|
(define s (foo 1 2))
|
|
(define (a-is-one s)
|
|
(= (foo-a s) 1)))
|
|
(require 'server)))
|
|
|
|
(test-contract-fail
|
|
"failed invariant for struct"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[s (invariant/c
|
|
any/c
|
|
a-is-one
|
|
#:struct foo)]))
|
|
(struct foo (a b))
|
|
(define s (foo 2 2))
|
|
(define (a-is-one s)
|
|
(= (foo-a s) 1)))
|
|
(require 'server))
|
|
"server"
|
|
"expected struct that satisfies")
|
|
|
|
|
|
(test-fail
|
|
"failed invariant/c for struct (unbound struct id)"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[s (invariant/c
|
|
any/c
|
|
a-is-one
|
|
#:struct boo)]))
|
|
(struct foo (a b))
|
|
(define s (foo 2 2))
|
|
(define (a-is-one s)
|
|
(= (foo-a s) 1)))
|
|
(require 'server))
|
|
"expected a struct identifier")
|
|
|
|
(test-contract-fail
|
|
"failed invariant/c for struct (missing struct id)"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[s (invariant/c
|
|
any/c
|
|
a-is-one)]))
|
|
(struct foo (a b))
|
|
(struct boo (a b))
|
|
(define s (foo 2 2))
|
|
(define (a-is-one s)
|
|
(= (foo-a s) 1)))
|
|
(require 'server))
|
|
"server"
|
|
"a vector or a hash")
|
|
|
|
(test-contract-fail
|
|
"failed invariant/c for struct (wrong struct id)"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[s (invariant/c
|
|
any/c
|
|
a-is-one
|
|
#:struct boo)]))
|
|
(struct foo (a b))
|
|
(struct boo (a b))
|
|
(define s (foo 2 2))
|
|
(define (a-is-one s)
|
|
(= (foo-a s) 1)))
|
|
(require 'server))
|
|
"server"
|
|
"a struct of type boo")
|
|
|
|
(test-contract-fail
|
|
"failed invariant/c for struct (vector for struct id)"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[s (invariant/c
|
|
any/c
|
|
a-is-one
|
|
#:struct foo)]))
|
|
(struct foo (a b))
|
|
(define s (vector 2 2))
|
|
(define (a-is-one s)
|
|
(= (foo-a s) 1)))
|
|
(require 'server))
|
|
"server"
|
|
"a struct of type foo")
|
|
|
|
|
|
(test-contract-fail
|
|
"failed underlying struct/dc contract"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[s (invariant/c
|
|
(struct/dc foo [a number?] [b number?])
|
|
a-is-one
|
|
#:struct foo)]))
|
|
(struct foo (a b))
|
|
(define s (foo '3 2))
|
|
(define (a-is-one s)
|
|
(= (foo-a s) 1)))
|
|
(require 'server))
|
|
"server")
|
|
|
|
(test-contract-fail
|
|
"failed immutable invariant/c for struct"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[s (invariant/c
|
|
(struct/dc foo [a number?] [b number?])
|
|
a-is-one
|
|
#:immutable #t
|
|
#:struct foo)]))
|
|
(struct foo (a b) #:mutable)
|
|
(define s (foo '3 2))
|
|
(define (a-is-one s)
|
|
(= (foo-a s) 1)))
|
|
(require 'server))
|
|
"server"
|
|
"immutable data")
|
|
|
|
(test-contract-fail
|
|
"failed mutable invariant/c for struct"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[s (invariant/c
|
|
(struct/dc foo [a number?] [b number?])
|
|
a-is-one
|
|
#:immutable #f
|
|
#:struct foo)]))
|
|
(struct foo (a b))
|
|
(define s (foo '3 2))
|
|
(define (a-is-one s)
|
|
(= (foo-a s) 1)))
|
|
(require 'server))
|
|
"server"
|
|
"mutable data")
|
|
|
|
(test-pass
|
|
"passes with immutable invariant/c for struct"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[s (invariant/c
|
|
(struct/dc foo [a number?] [b number?])
|
|
a-is-one
|
|
#:immutable #t
|
|
#:struct foo)]))
|
|
(struct foo (a b))
|
|
(define s (foo 1 2))
|
|
(define (a-is-one s)
|
|
(= (foo-a s) 1)))
|
|
(require 'server)))
|
|
|
|
(test-pass
|
|
"passes with mutable invariant/c for struct"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[s (invariant/c
|
|
(struct/dc foo [a number?] [b number?])
|
|
a-is-one
|
|
#:immutable #f
|
|
#:struct foo)]))
|
|
(struct foo (a b) #:mutable)
|
|
(define s (foo 1 2))
|
|
(define (a-is-one s)
|
|
(= (foo-a s) 1)))
|
|
(require 'server)))
|
|
|
|
(test-pass
|
|
"passes with mutable flat invariant/c for struct"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide (contract-out
|
|
[s (invariant/c
|
|
(struct/dc foo [a number?] [b number?])
|
|
a-is-one
|
|
#:flat? #t
|
|
#:immutable #f
|
|
#:struct foo)]))
|
|
(struct foo (a b) #:mutable)
|
|
(define s (foo 1 2))
|
|
(define (a-is-one s)
|
|
(= (foo-a s) 1)))
|
|
(require 'server)))
|
|
|
|
(test-pass
|
|
"passes with mutation on mutable flat invariant/c for struct"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide
|
|
set-foo-a!
|
|
(contract-out
|
|
[s (invariant/c
|
|
(struct/dc foo [a number?] [b number?])
|
|
a-is-one
|
|
#:flat? #t
|
|
#:immutable #f
|
|
#:struct foo)]))
|
|
(struct foo (a b) #:mutable)
|
|
(define s (foo 1 2))
|
|
(define (a-is-one s)
|
|
(= (foo-a s) 1)))
|
|
(module client racket
|
|
(require unstable/options)
|
|
(require 'server)
|
|
(set-foo-a! s 10))
|
|
(require 'client)))
|
|
|
|
|
|
(test-contract-fail
|
|
"failed mutation on mutable invariant/c for struct"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide
|
|
set-foo-a!
|
|
foo-b
|
|
(contract-out
|
|
[s (invariant/c
|
|
(struct/dc foo [a (-> any/c number?)] [b number?])
|
|
a-is-one
|
|
#:immutable #f
|
|
#:struct foo)]))
|
|
(struct foo (a b) #:mutable)
|
|
(define s (foo (λ (x) 1) 2))
|
|
(define (a-is-one s)
|
|
(= ((foo-a s) 'anything) 1)))
|
|
(module client racket
|
|
(require unstable/options)
|
|
(require 'server)
|
|
(set-foo-a! s (λ (x) 2))
|
|
(foo-b s))
|
|
(require 'client))
|
|
"client"
|
|
"expected struct that satisfies")
|
|
|
|
(test-contract-fail
|
|
"failed mutation on mutable invariant/c for struct"
|
|
(script
|
|
(module server racket
|
|
(require unstable/options)
|
|
(provide
|
|
change
|
|
foo-b
|
|
(contract-out
|
|
[s (invariant/c
|
|
(struct/dc foo [a (-> any/c number?)] [b number?])
|
|
a-is-one
|
|
#:immutable #f
|
|
#:struct foo)]))
|
|
(struct foo (a b) #:mutable)
|
|
(define s (foo (λ (x) 1) 2))
|
|
(define (change) (set-foo-a! s (λ (x) 2)))
|
|
(define (a-is-one s)
|
|
(= ((foo-a s) 'anything) 1)))
|
|
(module client racket
|
|
(require unstable/options)
|
|
(require 'server)
|
|
(change)
|
|
(foo-b s))
|
|
(require 'client))
|
|
"server"
|
|
"expected struct that satisfies")))))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|