44 lines
1.3 KiB
Racket
44 lines
1.3 KiB
Racket
#lang racket/base
|
|
(require rackunit)
|
|
|
|
(module A racket
|
|
(define (f x) (if (positive? x) x 'wrong))
|
|
(provide (contract-out [f (-> real? real?)])))
|
|
|
|
(module B racket
|
|
(require unstable/recontract
|
|
(submod ".." A))
|
|
(provide (rename-out [f f-from-a])
|
|
(recontract-out f)))
|
|
|
|
(module C racket
|
|
(require (submod ".." B))
|
|
(define (af x) (f-from-a x))
|
|
(define (bf x) (f x))
|
|
(provide af bf))
|
|
|
|
(require 'C)
|
|
|
|
(define-syntax-rule (tcerr expr from blame)
|
|
(do-tcerr (lambda () expr) 'expr from blame))
|
|
|
|
(define (do-tcerr thunk quoted-expr from blame)
|
|
(test-case (format "~s" quoted-expr)
|
|
(check-exn (lambda (e)
|
|
(let ([msg (exn-message e)])
|
|
(let ([from-m (regexp-match #rx"contract from:[ \n]*\\([^)]* ([A-Z])\\)" msg)])
|
|
(check-equal? (and from-m (cadr from-m)) from "contract from"))
|
|
(let ([blame-m (regexp-match #rx"blaming:[ \n]*\\([^)]* ([A-Z])\\)" msg)])
|
|
(check-equal? (and blame-m (cadr blame-m)) blame "blaming"))))
|
|
thunk)))
|
|
|
|
;; Normally, A is the positive blame party
|
|
(test-equal? "af ok" (af 1) 1)
|
|
(tcerr (af -2) "A" "A")
|
|
(tcerr (af 'apple) "A" "C")
|
|
|
|
;; Check that recontract-out changes positive party to B
|
|
(test-equal? "bf ok" (bf 1) 1)
|
|
(tcerr (bf -2) "B" "B")
|
|
(tcerr (bf 'apple) "B" "C")
|