typed-rackunit.rkt (8643B)
1 #lang typed/racket 2 (require "typed-untyped.rkt") 3 (define-typed/untyped-modules #:no-test 4 ;; TODO: these won't expand types in the ann. 5 (provide check-equal?: 6 check-eq?: 7 check-true: 8 check-not-false: 9 check-false: 10 check-not-equal?: 11 check-exn: 12 check-not-exn:) 13 14 (require "typed-untyped.rkt" 15 (for-syntax type-expander/expander)) 16 17 (require/typed rackunit 18 [(check-true untyped:check-true) 19 (->* (Any) (String) Any)] 20 [(check-exn untyped:check-exn) 21 (->* ((U Regexp (→ Any Any)) (→ Any)) (String) Any)] 22 [(check-not-exn untyped:check-not-exn) 23 (->* ((→ Any)) (String) Any)] 24 [#:struct check-info ([name : Symbol] [value : Any])] 25 [make-check-info (→ Symbol Any check-info)] 26 [make-check-location (→ (List Any 27 (U Number False) 28 (U Number False) 29 (U Number False) 30 (U Number False)) 31 check-info)] 32 [make-check-name (→ Any check-info)] 33 [make-check-params (→ Any check-info)] 34 [make-check-actual (→ Any check-info)] 35 [make-check-expected (→ Any check-info)] 36 [make-check-expression (→ Any check-info)] 37 [make-check-message (→ Any check-info)] 38 [with-check-info* (→ (Listof check-info) (→ Any) Any)]) 39 (require (only-in typed/rackunit check-exn check-not-exn)) 40 41 (require (for-syntax syntax/parse 42 syntax/parse/experimental/template)) 43 (require-typed/untyped "syntax-parse.rkt") 44 45 (define-syntax/parse 46 (check-equal?: actual 47 (~optional (~seq (~datum :) type:type-expand!)) 48 expected 49 (~optional message:expr)) 50 (quasitemplate 51 (with-check-info* (list (make-check-actual (format "~s" actual)) 52 (make-check-expected (format "~s" expected)) 53 (make-check-name 'check-equal?:) 54 (make-check-params 55 (format "~s" `(,actual (?? 'type) ,expected))) 56 (make-check-location '(#,(syntax-source stx) 57 #,(syntax-line stx) 58 #,(syntax-column stx) 59 #,(syntax-position stx) 60 #,(syntax-span stx))) 61 (make-check-expression '#,(syntax->datum stx))) 62 (λ () 63 (untyped:check-true 64 (equal? (?? (ann actual type.expanded) actual) 65 expected)))))) 66 67 ;; TODO: factor out some of this code. 68 (define-syntax/parse 69 (check-eq?: actual 70 (~optional (~seq (~datum :) type:type-expand!)) 71 expected 72 (~optional message:expr)) 73 (quasitemplate 74 (with-check-info* (list (make-check-actual (format "~s" actual)) 75 (make-check-expected (format "~s" expected)) 76 (make-check-name 'check-eq?:) 77 (make-check-params 78 (format "~s" `(,actual (?? 'type) ,expected))) 79 (make-check-location '(#,(syntax-source stx) 80 #,(syntax-line stx) 81 #,(syntax-column stx) 82 #,(syntax-position stx) 83 #,(syntax-span stx))) 84 (make-check-expression '#,(syntax->datum stx))) 85 (λ () 86 (untyped:check-true 87 (eq? (?? (ann actual type.expanded) actual) 88 expected)))))) 89 90 (define-syntax-rule (define-check-1 name process) 91 (define-syntax/parse (name actual (~optional message:expr)) 92 (quasitemplate 93 (with-check-info* (list (make-check-actual (format "~s" actual)) 94 (make-check-expected (format "~s" #t)) 95 (make-check-name 'name) 96 (make-check-params 97 (format "~s" `(,actual))) 98 (make-check-location '(#,(syntax-source stx) 99 #,(syntax-line stx) 100 #,(syntax-column stx) 101 #,(syntax-position stx) 102 #,(syntax-span stx))) 103 (make-check-expression '#,(syntax->datum stx))) 104 (λ () 105 (untyped:check-true (process actual))))))) 106 107 (define-check-1 check-true: identity) 108 (define-check-1 check-not-false: (λ (v) (not (not v)))) 109 (define-check-1 check-false: not) 110 111 (define-syntax/parse 112 (check-not-equal?: actual 113 (~optional (~seq (~datum :) type:type-expand!)) 114 expected 115 (~optional message)) 116 (quasitemplate 117 (with-check-info* (list (make-check-actual (format "~s" actual)) 118 (make-check-expected (format "~s" expected)) 119 (make-check-name 'check-not-equal?:) 120 (make-check-params 121 (format "~s" `(,actual (?? 'type) ,expected))) 122 (make-check-location '(#,(syntax-source stx) 123 #,(syntax-line stx) 124 #,(syntax-column stx) 125 #,(syntax-position stx) 126 #,(syntax-span stx))) 127 (make-check-expression '#,(syntax->datum stx))) 128 (λ () 129 (untyped:check-true 130 (not (equal? (?? (ann actual type.expanded) actual) 131 expected))))))) 132 133 (define-syntax/parse 134 (check-exn: exn-predicate-or-regexp:expr 135 thunk 136 (~optional message:expr)) 137 (quasitemplate 138 (with-check-info* (list (make-check-name 'check-eq?:) 139 (make-check-location '(#,(syntax-source stx) 140 #,(syntax-line stx) 141 #,(syntax-column stx) 142 #,(syntax-position stx) 143 #,(syntax-span stx))) 144 (make-check-params 145 (list exn-predicate-or-regexp thunk)) 146 (?? (make-check-message message)) 147 (make-check-expression '#,(syntax->datum stx))) 148 (λ () 149 (untyped:check-exn 150 exn-predicate-or-regexp 151 thunk 152 (?? message)))))) 153 154 (define-syntax/parse 155 (check-not-exn: thunk 156 (~optional message:expr)) 157 (quasitemplate 158 (with-check-info* (list (make-check-name 'check-eq?:) 159 (make-check-location '(#,(syntax-source stx) 160 #,(syntax-line stx) 161 #,(syntax-column stx) 162 #,(syntax-position stx) 163 #,(syntax-span stx))) 164 (make-check-params 165 (list thunk)) 166 (?? (make-check-message message)) 167 (make-check-expression '#,(syntax->datum stx))) 168 (λ () 169 (untyped:check-not-exn 170 thunk 171 (?? message)))))))