typed-rackunit-extensions.rkt (6415B)
1 #lang typed/racket 2 (require "typed-untyped.rkt") 3 (define-typed/untyped-modules #:no-test 4 (provide check-equal?-classes 5 check-equal?-classes: 6 check-tc 7 check-not-tc 8 check-ann 9 (for-syntax eval-tc)) 10 11 (require "typed-untyped.rkt") 12 (require-typed/untyped "syntax-parse.rkt" 13 "sequence.rkt" 14 "typed-rackunit.rkt") 15 16 (require (for-syntax syntax/parse 17 syntax/parse/experimental/template 18 racket/syntax 19 type-expander/expander 20 phc-toolkit/untyped/aliases 21 (submod "syntax-parse.rkt" untyped) 22 (submod "repeat-stx.rkt" untyped) 23 (submod "stx.rkt" untyped)) 24 typed/rackunit) 25 26 27 28 (define-syntax/parse (check-ann value type:type-expand! (~optional message)) 29 (quasitemplate 30 ((λ _ (void)) (ann value type.expanded)))) 31 32 (: check-equal?-classes (∀ (A ...) (→ (Pairof String (Listof A)) ... Void))) 33 (define (check-equal?-classes . classes) 34 (for* ([(head tail) (in-split* classes)]) 35 (let ([this-class (sequence-ref tail 0)] 36 [different-classes (in-sequences head (sequence-tail tail 1))]) 37 (for ([val (cdr this-class)]) 38 (for ([other-val (cdr this-class)]) 39 #;(displayln (format "Test ~a ∈ ~a = ~a ∈ ~a …" 40 val 41 (car this-class) 42 other-val 43 (car this-class))) 44 (check-equal?: val other-val 45 (format "Test ~a ∈ ~a = ~a ∈ ~a failed." 46 val 47 (car this-class) 48 other-val 49 (car this-class)))) 50 (for ([different-class different-classes]) 51 (for ([different-val (cdr different-class)]) 52 #;(displayln (format "Test ~a ∈ ~a != ~a ∈ ~a ∈ ~a …" 53 val 54 (car this-class) 55 different-val 56 (car different-class) 57 (map (λ ([c : (Pairof String Any)]) 58 (car c)) 59 (sequence->list 60 different-classes)))) 61 (check-not-equal?: val different-val 62 (format "Test ~a ∈ ~a != ~a ∈ ~a ∈ ~a failed." 63 val 64 (car this-class) 65 different-val 66 (car different-class) 67 (map (λ ([c : (Pairof String Any)]) 68 (car c)) 69 (sequence->list 70 different-classes)))))))))) 71 72 (define-syntax/parse 73 (check-equal?-classes: 74 [{~maybe #:name {~or name:str name-id:id}} 75 ;; TODO: should be {~lit :), but still accept the ":" 76 ;; from type-expander 77 {~maybe :colon c-type:type-expand!} 78 {~and {~or {~seq single-val-id:id {~maybe {~lit :} _}} 79 {~seq _ …}} 80 {~seq {~seq val {~maybe :colon v-type:type-expand!}} …}}] 81 …) 82 (define/with-syntax ([a-val …] …) 83 (template ([(?? (ann val v-type.expanded) val) …] …))) 84 (define/with-syntax ([aa-val …] …) 85 (let () 86 ;; TODO: this is ugly, repeat-stx should handle missing stuff instead. 87 (define/with-syntax (xx-c-type …) 88 (template ((?? (c-type.expanded) ()) …))) 89 (syntax-parse (repeat-stx (xx-c-type …) ([val …] …)) 90 [([({~optional c-type-rep}) …] …) 91 (template ([(?? (ann a-val c-type-rep) a-val) …] …))]))) 92 (template 93 (check-equal?-classes (list (?? (?? name (symbol->string 'name-id)) 94 (?? (symbol->string 'single-val-id) "")) 95 aa-val …) …))) 96 97 98 ;; check-tc and check-not-tc 99 (begin 100 ;; Adapted from https://github.com/racket/typed-racket/issues/87 101 (define-for-syntax (eval-tc checker expr [loc-stx #f]) 102 (quasisyntax/top-loc (or loc-stx #'here) 103 (begin 104 (: ns-anchor Namespace-Anchor) 105 (define-namespace-anchor ns-anchor) 106 #,(checker (quasisyntax/top-loc loc-stx 107 (λ () 108 (define output (open-output-string)) 109 (parameterize ([current-output-port output]) 110 (eval `(#%top-interaction . #,expr) 111 (namespace-anchor->namespace ns-anchor))) 112 (get-output-string output))))))) 113 114 (define-syntax (check-tc stx) 115 (eval-tc (λ (f) (quasisyntax/top-loc stx 116 (check-not-exn #,f))) 117 (syntax-case stx () 118 [(_ body0) #'body0] 119 [(_ . body) (syntax/top-loc stx 120 (begin . body))]) 121 stx)) 122 123 (define-for-syntax tc-error-regexp 124 (pregexp 125 (string-append 126 "Type Checker: (" 127 "type mismatch" 128 "|Polymorphic function .*could not be applied to arguments)"))) 129 (define-syntax check-not-tc 130 (syntax-parser 131 [(_ (~optional (~seq #:message-regexp message-regexp) 132 #:defaults ([message-regexp #`#,tc-error-regexp])) 133 . (~or (body₀) body*)) 134 (eval-tc (λ (code) (quasisyntax/top-loc this-syntax 135 (check-exn: 136 (λ (ex) 137 (and (exn:fail:syntax? ex) 138 (regexp-match? message-regexp 139 (exn-message ex)))) 140 #,code))) 141 (if (attribute body₀) 142 #'body₀ 143 (syntax/top-loc this-syntax 144 (begin . body*))) 145 this-syntax)]))))