diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt index 26be4d13..ae24c5b5 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt @@ -1,8 +1,37 @@ #lang racket/base +(module cross-phase-failure racket/base + (require + rackunit + racket/contract) + + (provide + (contract-out + [rename cross-phase-failure* cross-phase-failure + (->* (string?) (#:actual any/c #:expected any/c) cross-phase-failure?)] + [cross-phase-failure? predicate/c] + [cross-phase-failure-message (-> cross-phase-failure? string?)] + [rename cross-phase-failure-check-infos* cross-phase-failure-check-infos + (-> cross-phase-failure? (listof check-info?))])) + + (struct cross-phase-failure (message check-infos) #:prefab) + + (define no-arg (gensym 'no-arg)) + + (define (cross-phase-failure* message #:actual [actual no-arg] #:expected [expected no-arg]) + (cross-phase-failure + message + (append + (if (eq? actual no-arg) null (list (list 'actual actual))) + (if (eq? expected no-arg) null (list (list 'expected expected)))))) + + (define (cross-phase-failure-check-infos* cpf) + (map (λ (args) (apply check-info args)) (cross-phase-failure-check-infos cpf)))) + ;; Functions for testing correct behavior of typechecking (module tester racket/base (require + (submod ".." cross-phase-failure) typed-racket/utils/utils racket/base syntax/parse @@ -10,7 +39,9 @@ (typecheck typechecker) (utils mutated-vars) (env mvar-env)) - (provide test-literal test test/proc tc tc-literal tr-expand) + (provide + test-literal test-literal/fail + test test/proc test/fail) (do-standard-inits) @@ -43,20 +74,59 @@ (define result (tc expanded-expr expected)) (define golden (golden-fun expanded-expr)) (unless (equal? golden result) - (error 'test "failed: ~a != ~a" golden result))) + (raise (cross-phase-failure + #:actual result + #:expected golden + "tc-expr did not return the expected value")))) - ;; test/literal syntax? tc-results? [(option/c tc-results?)] -> void? + ;; test/fail syntax? (or/c string? regexp?) (option/c tc-results?) -> void? + ;; Checks that the expression doesn't typecheck using the expected type and the golden message + (define (test/fail code message expected) + (with-handlers ([exn:fail:syntax? + (lambda (exn) + (when message + (unless (regexp-match? message (exn-message exn)) + (raise (cross-phase-failure + #:actual (exn-message exn) + #:expected message + "tc-expr raised the wrong error message")))))]) + (define result (tc (tr-expand code) expected)) + (raise (cross-phase-failure + #:actual result + "tc-expr did not raise an error")))) + + + ;; test-literal syntax? tc-results? (option/c tc-results?) -> void? ;; Checks that the literal typechecks using the expected type to the golden result. (define (test-literal literal golden expected) (define result (tc-literal literal expected)) (unless (equal? golden result) - (error 'test "failed: ~a != ~a" golden result)))) + (raise (cross-phase-failure + #:actual result + #:expected golden + "tc-literal did not return the expected value")))) + + ;; test-literal/fail syntax? (or/c string? regexp?) (option/c tc-results?) -> void? + ;; Checks that the literal doesn't typecheck using the expected type and the golden message + (define (test-literal/fail literal message expected) + (with-handlers ([exn:fail:syntax? + (lambda (exn) + (unless (regexp-match? message (exn-message exn)) + (raise (cross-phase-failure + #:actual (exn-message exn) + #:expected message + "tc-literal raised the wrong error message"))))]) + (define result (tc-literal literal expected)) + (raise (cross-phase-failure + #:actual result + "tc-literal did not raise an error"))))) (require + 'cross-phase-failure "evaluator.rkt" (except-in "test-utils.rkt" private) - syntax/location + syntax/location syntax/srcloc (for-syntax racket/base syntax/parse @@ -90,32 +160,34 @@ ;; for specifying the error message in a test (define-splicing-syntax-class expected-msg (pattern (~seq #:msg v:expr)) - (pattern (~seq) #:attr v #'#f)) + (pattern (~seq) #:attr v #'#f))) - - (define (test-no-error stx name body) - (quasisyntax/loc stx - (test-not-exn (format "~a ~a" (quote-line-number #,name) '#,name) - (lambda () #,body)))) - - (define (test-syntax-error stx name msg body) - (quasisyntax/loc stx - (test-exn (format "~a ~a" (quote-line-number #,name) '#,name) - (λ (exn) (and (exn:fail:syntax? exn) - (or (not #,msg) - (regexp-match? #,msg (exn-message exn))))) - (lambda () #,body))))) +(define-syntax (test-phase1 stx) + (syntax-parse stx + ([_ name:expr body:expr ...] + (quasisyntax/loc stx + (test-case (format "~a ~a" (quote-line-number name) 'name) + (with-check-info (['location (build-source-location-list (quote-srcloc #,stx))]) + (with-handlers ([cross-phase-failure? + (λ (tf) + (with-check-info* + (cross-phase-failure-check-infos tf) + (lambda () + (fail-check (cross-phase-failure-message tf)))))]) + (phase1-eval body ...)))))))) ;;Constructs the syntax that calls eval and returns the answer to the user (define-syntax (tc-e stx) (syntax-parse stx [(_ code:expr #:proc p) - (test-no-error stx #'code - #'(phase1-eval (test/proc (quote-syntax code) p)))] - [(_ code:expr return:return x:expected) - (test-no-error stx #'code - #'(phase1-eval (test (quote-syntax code) return.v x.v)))])) + (quasisyntax/loc stx + (test-phase1 code + (test/proc (quote-syntax code) p)))] + [(_ code:expr return:return ex:expected) + (quasisyntax/loc stx + (test-phase1 code + (test (quote-syntax code) return.v ex.v)))])) (define-syntax (tc-e/t stx) (syntax-parse stx @@ -125,23 +197,25 @@ (define-syntax (tc-l stx) (syntax-parse stx [(_ lit ty exp:expected) - (test-no-error stx (syntax/loc #'lit (LITERAL lit)) - #'(phase1-eval (test-literal #'lit ty exp.v)))])) + (quasisyntax/loc stx + (test-phase1 #,(syntax/loc #'lit (LITERAL lit)) + (test-literal (quote-syntax lit) ty exp.v)))])) ;; check that typechecking this expression fails (define-syntax (tc-err stx) (syntax-parse stx [(_ code:expr ex:expected msg:expected-msg) - (test-syntax-error stx (syntax/loc #'code (FAIL code)) #'msg.v - #'(phase1-eval (tc (tr-expand (quote-syntax code)) ex.v)))])) + (quasisyntax/loc stx + (test-phase1 #,(syntax/loc #'code (FAIL code)) + (test/fail (quote-syntax code) msg.v ex.v)))])) (define-syntax (tc-l/err stx) (syntax-parse stx [(_ lit:expr ex:expected msg:expected-msg) - (test-syntax-error stx #'(syntax/loc #'lit (LITERAL/FAIL lit)) #'msg.v - #'(phase1-eval (tc-literal #'lit ex.v)))])) - + (quasisyntax/loc stx + (test-phase1 #,(syntax/loc #'lit (LITERAL/FAIL lit)) + (test-literal/fail (quote-syntax lit) msg.v ex.v)))])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;