b16f0b24b7
Changes: - Allow unit contracts to import and export the same signature. - Add "invoke" contracts that will wrap the result of invoking a unit contract, no wrapping occurs when a body contract is not specified - Improve error messages - Support for init-depend clauses in unit contracts. - Fix documentation to refelct the above - Overhaul of unit related tests Handling init-depend clauses in unit contracts is a rather large and somewhat non-backwards-compatible change to unit contracts. Unit contracts must now specify at least as many initialization dependencies as the unit value being contracted, but may include more. These new dependencies are now actually specified in the unit wrapper so that they will be checked by compound-unit expressions. This commit also adds more information to the first-order-check error messages. If a unit imports tagged signatures, previously the errror message did not specify which tag was missing from the unit contract. Now the tag is printed along with the signature name. Documentation has been edited to reflect the changes to unit/c contracts made by this commit. Additionally this commit overhauls all tests for units and unit contracts. Test cases now actually check that expected error messages are triggered when checking contract, syntax, and runtime errors. Test forms now expand into uses of rackunit's check-exn form so only test failures are reported and all tests in a file are run on every run of the test file.
59 lines
1.8 KiB
Racket
59 lines
1.8 KiB
Racket
(module test-harness racket
|
|
(require syntax/stx rackunit)
|
|
|
|
(provide (all-defined-out))
|
|
|
|
(define (lst-bound-id=? x y)
|
|
(andmap bound-identifier=? x y))
|
|
|
|
(define (stx-bound-id=? x y)
|
|
(cond
|
|
((and (syntax? x) (eq? '_ (syntax-e x)))
|
|
#t)
|
|
((and (syntax? x)
|
|
(vector? (syntax-e x))
|
|
(= 2 (vector-length (syntax-e x))))
|
|
(and (identifier? y)
|
|
(eq? (syntax-e (vector-ref (syntax-e x) 0))
|
|
(free-identifier=? (vector-ref (syntax-e x) 1) y))))
|
|
((and (stx-null? x) (stx-null? y))
|
|
#t)
|
|
((and (stx-pair? x) (stx-pair? y))
|
|
(and (stx-bound-id=? (stx-car x) (stx-car y))
|
|
(stx-bound-id=? (stx-cdr x) (stx-cdr y))))
|
|
((and (identifier? x) (identifier? y))
|
|
(if (bound-identifier=? x y)
|
|
#t
|
|
(begin
|
|
(log-error "Differ:\n ~s\n ~s" x y)
|
|
#f)))
|
|
((and (syntax? x) (number? (syntax-e x))
|
|
(syntax? y) (number? (syntax-e y)))
|
|
(= (syntax-e x) (syntax-e y)))
|
|
(else #f)))
|
|
|
|
(define-syntax test-syntax-error
|
|
(syntax-rules ()
|
|
((_ err expr)
|
|
(check-exn
|
|
(lambda (e) (and (exn:fail:syntax? e)
|
|
(regexp-match? (regexp-quote err)
|
|
(exn-message e))))
|
|
(lambda () (expand #'expr))))))
|
|
|
|
(define-syntax test-runtime-error
|
|
(syntax-rules ()
|
|
((_ err-pred err expr)
|
|
(check-exn
|
|
(λ (exn) (and (err-pred exn)
|
|
(let ([msg (exn-message exn)])
|
|
(and (regexp-match? (regexp-quote err) msg)))))
|
|
(λ () expr (void))))))
|
|
|
|
(define-syntax test
|
|
(syntax-rules ()
|
|
((_ expected-value expr)
|
|
(check-equal? expected-value expr))
|
|
((_ cmp expected-value expr)
|
|
(check cmp expected-value expr)))))
|