rackunit-typechecking.rkt (5881B)
1 #lang racket/base 2 (require (for-syntax rackunit syntax/srcloc) rackunit macrotypes/typecheck) 3 (provide check-type typecheck-fail check-not-type check-props check-runtime-exn 4 check-equal/rand typecheck-fail/toplvl 5 (rename-out [typecheck-fail check-stx-err])) 6 7 (begin-for-syntax 8 (define (add-esc s) (string-append "\\" s)) 9 (define escs (map add-esc '("(" ")" "[" "]" "+" "*"))) 10 (define (replace-brackets str) 11 (regexp-replace* "\\]" (regexp-replace* "\\[" str "(") ")")) 12 (define (add-escs str) 13 (replace-brackets 14 (foldl (lambda (c s) (regexp-replace* c s (add-esc c))) str escs))) 15 (define (expected tys #:given [givens ""] #:note [note ""]) 16 (string-append 17 note ".*Expected.+argument\\(s\\) with type\\(s\\).+" 18 (add-escs tys) ".*Given:.*" 19 (string-join (map add-escs (string-split givens ", ")) ".*")))) 20 21 (define-syntax (check-type stx) 22 (syntax-parse stx #:datum-literals (⇒ ->) 23 ;; duplicate code to avoid redundant expansions 24 [(_ e tag:id τ-expected (~or ⇒ ->) v) 25 #:with e+ (expand/df #'(add-expected e τ-expected)) 26 #:with τ (detach #'e+ (stx->datum #'tag)) 27 #:fail-unless (typecheck? #'τ ((current-type-eval) #'τ-expected)) 28 (format 29 "Expression ~a [loc ~a:~a] has type ~a, expected ~a" 30 (syntax->datum #'e) (syntax-line #'e) (syntax-column #'e) 31 (type->str #'τ) (type->str #'τ-expected)) 32 (syntax/loc stx (check-equal? e+ (add-expected v τ-expected)))] 33 [(_ e tag:id τ-expected) 34 #:with e+ (expand/df #'(add-expected e τ-expected)) 35 #:with τ (detach #'e+ (stx->datum #'tag)) 36 #:fail-unless 37 (typecheck? #'τ ((current-type-eval) #'τ-expected)) 38 (format 39 "Expression ~a [loc ~a:~a] has type ~a, expected ~a" 40 (syntax->datum #'e) (syntax-line #'e) (syntax-column #'e) 41 (type->str #'τ) (type->str #'τ-expected)) 42 #'(void)])) 43 44 ;; for checking properties other than types 45 (define-syntax (check-props stx) 46 (syntax-parse stx #:datum-literals (: ⇒ ->) 47 [(_ prop e : v (~optional (~seq (~or ⇒ ->) v2) #:defaults ([v2 #'e]))) 48 #:with props (or (syntax-property (expand/df #'e) (syntax->datum #'prop)) 49 #'()) 50 #:fail-unless (equal? (syntax->datum #'v) 51 (syntax->datum #'props)) 52 (format 53 "Expression ~a [loc ~a:~a:~a] does not have prop ~a, actual: ~a" 54 (syntax->datum #'e) (syntax-line #'e) (syntax-column #'e) (syntax-position #'e) 55 (syntax->datum #'v) (syntax->datum #'props)) 56 (syntax/loc stx (check-equal? e v2))])) 57 58 (define-syntax (check-not-type stx) 59 (syntax-parse stx #:datum-literals (:) 60 [(_ e : not-τ) 61 #:with τ (typeof (expand/df #'e)) 62 #:fail-when 63 (typecheck? #'τ ((current-type-eval) #'not-τ)) 64 (format 65 "(~a:~a) Expression ~a has type ~a; should not typecheck with ~a" 66 (syntax-line stx) (syntax-column stx) 67 (syntax->datum #'e) (type->str #'τ) (type->str #'not-τ)) 68 #'(void)])) 69 70 (define-syntax (typecheck-fail stx) 71 (syntax-parse stx #:datum-literals (:) 72 [(_ e (~or 73 (~optional (~seq #:with-msg msg-pat) #:defaults ([msg-pat #'""])) 74 (~optional (~seq #:verb-msg vmsg) #:defaults ([vmsg #'""])))) 75 #:with msg:str 76 (if (attribute msg-pat) 77 (eval-syntax (datum->stx #'h (stx->datum #'msg-pat))) 78 (eval-syntax (datum->stx #'h `(add-escs ,(stx->datum #'vmsg))))) 79 #:when (with-check-info* 80 (list (make-check-expected (syntax-e #'msg)) 81 (make-check-expression (syntax->datum stx)) 82 (make-check-location (build-source-location-list stx)) 83 (make-check-name 'typecheck-fail) 84 (make-check-params (list (syntax->datum #'e) (syntax-e #'msg)))) 85 (λ () 86 (check-exn 87 (λ (ex) 88 (and (or (exn:fail? ex) (exn:test:check? ex)) 89 ; check err msg matches 90 (regexp-match? (syntax-e #'msg) (exn-message ex)))) 91 (λ () 92 (expand/df #'e))))) 93 #'(void)])) 94 95 (define-syntax (typecheck-fail/toplvl stx) 96 (syntax-parse stx #:datum-literals (:) 97 [(_ e (~optional (~seq #:with-msg msg-pat) #:defaults ([msg-pat #'""]))) 98 #:with msg:str 99 (eval-syntax (datum->syntax #'here (syntax->datum #'msg-pat))) 100 #:when (with-check-info* 101 (list (make-check-expected (syntax-e #'msg)) 102 (make-check-expression (syntax->datum stx)) 103 (make-check-location (build-source-location-list stx)) 104 (make-check-name 'typecheck-fail) 105 (make-check-params (list (syntax->datum #'e) (syntax-e #'msg)))) 106 (λ () 107 (check-exn 108 (λ (ex) 109 (and (or (exn:fail? ex) (exn:test:check? ex)) 110 ; check err msg matches 111 (regexp-match? (syntax-e #'msg) (exn-message ex)))) 112 (λ () 113 (local-expand #'e 'top-level null))))) 114 #'(void)])) 115 116 (define-syntax (check-runtime-exn stx) 117 (syntax-parse stx 118 [(_ e) 119 #:with e- (expand/df #'e) 120 (syntax/loc stx (check-exn exn:fail? (lambda () e-)))])) 121 122 (define-simple-macro (check-equal/rand f (~optional (~seq #:process p) 123 #:defaults ([p #'(lambda (x) x)]))) 124 #:with f* (format-id #'f "~a*" #'f) 125 #:with out (syntax/loc this-syntax (check-equal/rand-fn f f* p)) 126 out) 127 (define-check (check-equal/rand-fn f f* process) 128 (for ([i 100000]) 129 (let ([ks (for/list ([n (procedure-arity f)]) (random 4294967087))]) 130 (with-check-info (['f f] ['inputs ks]) 131 (check-equal? (apply f (map process ks)) 132 (apply f* (map process ks)))))))