diff --git a/turnstile/examples/tests/rackunit-typechecking.rkt b/turnstile/examples/tests/rackunit-typechecking.rkt index 6925b18..86c70c2 100644 --- a/turnstile/examples/tests/rackunit-typechecking.rkt +++ b/turnstile/examples/tests/rackunit-typechecking.rkt @@ -1,7 +1,7 @@ #lang racket/base (require (for-syntax rackunit syntax/srcloc) rackunit macrotypes/typecheck) (provide check-type typecheck-fail check-not-type check-props check-runtime-exn - check-equal/rand + check-equal/rand typecheck-fail/toplvl (rename-out [typecheck-fail check-stx-err])) (begin-for-syntax @@ -88,6 +88,27 @@ (expand/df #'e))))) #'(void)])) +(define-syntax (typecheck-fail/toplvl stx) + (syntax-parse stx #:datum-literals (:) + [(_ e (~optional (~seq #:with-msg msg-pat) #:defaults ([msg-pat #'""]))) + #:with msg:str + (eval-syntax (datum->syntax #'here (syntax->datum #'msg-pat))) + #:when (with-check-info* + (list (make-check-expected (syntax-e #'msg)) + (make-check-expression (syntax->datum stx)) + (make-check-location (build-source-location-list stx)) + (make-check-name 'typecheck-fail) + (make-check-params (list (syntax->datum #'e) (syntax-e #'msg)))) + (λ () + (check-exn + (λ (ex) + (and (or (exn:fail? ex) (exn:test:check? ex)) + ; check err msg matches + (regexp-match? (syntax-e #'msg) (exn-message ex)))) + (λ () + (local-expand #'e 'top-level null))))) + #'(void)])) + (define-syntax (check-runtime-exn stx) (syntax-parse stx [(_ e)