01a0bb28a7
- speed up by eliminating duplicate expansion in check-type - use given type annotation as expected-type - eliminates unneeded type annotations
91 lines
3.9 KiB
Racket
91 lines
3.9 KiB
Racket
#lang racket/base
|
|
(require (for-syntax rackunit) rackunit "../typecheck.rkt")
|
|
(provide check-type typecheck-fail check-not-type check-props)
|
|
|
|
(begin-for-syntax
|
|
(define (add-esc s) (string-append "\\" s))
|
|
(define escs (map add-esc '("(" ")" "[" "]")))
|
|
(define (replace-brackets str)
|
|
(regexp-replace* "\\]" (regexp-replace* "\\[" str "(") ")"))
|
|
(define (add-escs str)
|
|
(replace-brackets
|
|
(foldl (lambda (c s) (regexp-replace* c s (add-esc c))) str escs)))
|
|
(define (expected tys #:given [givens ""] #:note [note ""])
|
|
(string-append
|
|
note ".*Expected.+argument\\(s\\) with type\\(s\\).+"
|
|
(add-escs tys) ".*Given:.*"
|
|
(string-join (map add-escs (string-split givens ", ")) ".*"))))
|
|
|
|
(define-syntax (check-type stx)
|
|
(syntax-parse stx #:datum-literals (: ⇒ ->)
|
|
;; duplicate code to avoid redundant expansions
|
|
[(_ e : τ-expected (~or ⇒ ->) v)
|
|
#:with e+ (expand/df #'(add-expected e τ-expected))
|
|
#:with τ (typeof #'e+)
|
|
#:fail-unless (typecheck? #'τ ((current-type-eval) #'τ-expected))
|
|
(format
|
|
"Expression ~a [loc ~a:~a] has type ~a, expected ~a"
|
|
(syntax->datum #'e) (syntax-line #'e) (syntax-column #'e)
|
|
(type->str #'τ) (type->str #'τ-expected))
|
|
(syntax/loc stx (check-equal? e+ (add-expected v τ-expected)))]
|
|
[(_ e : τ-expected)
|
|
#:with τ (typeof (expand/df #'(add-expected e τ-expected)))
|
|
#:fail-unless
|
|
(typecheck? #'τ ((current-type-eval) #'τ-expected))
|
|
(format
|
|
"Expression ~a [loc ~a:~a] has type ~a, expected ~a"
|
|
(syntax->datum #'e) (syntax-line #'e) (syntax-column #'e)
|
|
(type->str #'τ) (type->str #'τ-expected))
|
|
#'(void)]))
|
|
|
|
;; for checking properties other than types
|
|
(define-syntax (check-props stx)
|
|
(syntax-parse stx #:datum-literals (: ⇒ ->)
|
|
[(_ prop e : v ... (~optional (~seq (~or ⇒ ->) v2) #:defaults ([v2 #'e])))
|
|
#:with props (or (syntax-property (expand/df #'e) (syntax->datum #'prop))
|
|
#'())
|
|
#:fail-unless (set=? (apply set (syntax->datum #'(v ...)))
|
|
(apply set (syntax->datum #'props)))
|
|
(format
|
|
"Expression ~a [loc ~a:~a:~a] does not have prop ~a, actual: ~a"
|
|
(syntax->datum #'e) (syntax-line #'e) (syntax-column #'e) (syntax-position #'e)
|
|
(syntax->datum #'(v ...)) (syntax->datum #'props))
|
|
(syntax/loc stx (check-equal? e v2))]))
|
|
|
|
(define-syntax (check-not-type stx)
|
|
(syntax-parse stx #:datum-literals (:)
|
|
[(_ e : not-τ)
|
|
#:with τ (typeof (expand/df #'e))
|
|
#:fail-when
|
|
(typecheck? #'τ ((current-type-eval) #'not-τ))
|
|
(format
|
|
"(~a:~a) Expression ~a has type ~a; should not typecheck with ~a"
|
|
(syntax-line stx) (syntax-column stx)
|
|
(syntax->datum #'e) (type->str #'τ) (type->str #'not-τ))
|
|
#'(void)]))
|
|
|
|
(define-syntax (typecheck-fail 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 (check-exn
|
|
(λ (ex) (or (exn:fail? ex) (exn:test:check? ex)))
|
|
(λ ()
|
|
(with-handlers
|
|
; check err msg matches
|
|
([exn:fail?
|
|
(λ (ex)
|
|
(unless (regexp-match? (syntax-e #'msg) (exn-message ex))
|
|
(printf
|
|
(string-append
|
|
"ERROR-MSG ERROR: wrong err msg produced by expression ~v:\n"
|
|
"EXPECTED:\nmsg matching pattern ~v,\nGOT:\n~v\n")
|
|
(syntax->datum #'e) (syntax-e #'msg) (exn-message ex)))
|
|
(raise ex))])
|
|
(expand/df #'e)))
|
|
(format
|
|
"Expected type check failure but expression ~a has valid type, OR wrong err msg received."
|
|
(syntax->datum #'e)))
|
|
#'(void)]))
|