typed-untyped.rkt (8055B)
1 #lang racket 2 3 (provide ;typed/untyped 4 require-typed/untyped-typed 5 require-typed/untyped 6 require/provide-typed/untyped 7 define-typed/untyped-modules 8 define-typed/untyped-light-modules 9 define-typed/untyped-test-module 10 if-typed 11 when-typed 12 when-untyped) 13 14 (require typed/untyped-utils 15 racket/require-syntax 16 (for-syntax syntax/parse 17 racket/syntax 18 syntax/stx 19 syntax/strip-context)) 20 21 (module m-typed typed/racket 22 (provide (rename-out [require tr:require] 23 [provide tr:provide]) 24 ;typed/untyped 25 #;require-typed/untyped) 26 27 #;(require (for-syntax syntax/parse 28 racket/syntax 29 syntax/stx 30 syntax/strip-context) 31 racket/require-syntax) 32 33 34 35 #;(define-syntax (require-typed/untyped stx) 36 (syntax-case stx () 37 [(_ m) 38 (let () 39 (define/with-syntax sb (datum->syntax #'m 'submod #'m #'m)) 40 (define/with-syntax ty (datum->syntax #'m 'typed #'m #'m)) 41 #'(require (sb m ty)))]))) 42 43 #;(require 'm-typed) 44 45 ;; require 46 (define-syntax (require-typed/untyped-typed stx) 47 (syntax-parse stx 48 [(_ . (~and ms (m ...))) 49 (replace-context #'ms #'(require (submod m typed) ...))])) 50 51 #;(define-require-syntax (typed/untyped-typed stx) 52 (syntax-case stx () 53 [(_ m) (replace-context stx #'(submod m typed))])) 54 55 #;(define-require-syntax (typed/untyped-untyped stx) 56 (syntax-case stx () 57 [(_ m) (replace-context stx #'(submod m untyped))])) 58 59 (define-syntax (require-typed/untyped-untyped stx) 60 (syntax-parse stx 61 [(_ . (~and ms (m ...))) 62 (replace-context #'ms #'(require (submod m untyped) ...))])) 63 64 (define-typed/untyped-identifier require-typed/untyped 65 require-typed/untyped-typed 66 require-typed/untyped-untyped) 67 68 #;(define-typed/untyped-identifier typed/untyped 69 typed/untyped-typed 70 typed/untyped-untyped) 71 72 ;; require/provide 73 ;; TODO: make a require expander instead. 74 (define-syntax (require/provide-typed/untyped-typed stx) 75 (syntax-parse stx 76 [(_ . (~and ms (m ...))) 77 (replace-context #'ms 78 #'(begin 79 (require (submod m typed) ...) 80 (provide (all-from-out (submod m typed) ...))))])) 81 82 (define-syntax (require/provide-typed/untyped-untyped stx) 83 (syntax-parse stx 84 [(_ . (~and ms (m ...))) 85 (replace-context #'ms 86 #'(begin 87 (require (submod m untyped) ...) 88 (provide (all-from-out (submod m untyped) ...))))])) 89 90 (define-typed/untyped-identifier require/provide-typed/untyped 91 require/provide-typed/untyped-typed 92 require/provide-typed/untyped-untyped) 93 94 #| 95 (module mt typed/racket 96 (define-syntax-rule (require/provide-typed/untyped m) 97 (require m)) 98 (provide require/provide-typed/untyped)) 99 (require 'mt) 100 |# 101 102 ;; define-typed/untyped-modules 103 (begin 104 (define-syntax (define-typed/untyped-modules stx) 105 (syntax-parse stx 106 [(def-t/u-mod (~optional (~and no-test #:no-test)) 107 (~optional (~and untyped-first #:untyped-first)) . body) 108 (define (ds sym) (datum->syntax #'def-t/u-mod sym #'def-t/u-mod)) 109 (define/with-syntax module-typed 110 #`(module #,(ds 'typed) #,(ds 'typed/racket) 111 . body)) 112 (define/with-syntax module-untyped 113 #`(module #,(ds 'untyped) #,(ds 'typed/racket/no-check) 114 #,(ds '(require (for-syntax racket/base))) 115 . body)) 116 #`(begin 117 #,(if (attribute untyped-first) #'module-untyped #'module-typed) 118 #,(if (attribute untyped-first) #'module-typed #'module-untyped) 119 #,@(if (attribute no-test) 120 #'() 121 #`((module #,(ds 'test) #,(ds 'typed/racket) 122 #,(ds `(require (submod ".." typed test))) 123 #,(ds `(require (submod ".." untyped test)))))) 124 #,(ds '(require 'typed)) 125 #,(ds '(provide (all-from-out 'typed))))])) 126 127 (define-syntax (define-typed/untyped-light-modules stx) 128 (syntax-parse stx 129 [(def-t/u-mod (~optional (~and no-test #:no-test)) 130 (~optional (~and untyped-first #:untyped-first)) . body) 131 (define (ds sym) (datum->syntax #'def-t/u-mod sym #'def-t/u-mod)) 132 (define/with-syntax module-typed 133 #`(module #,(ds 'typed) #,(ds 'typed/racket) 134 . body)) 135 (define/with-syntax module-untyped 136 #`(module #,(ds 'untyped) #,(ds 'racket/base) 137 #,(ds '(require (for-syntax racket/base))) 138 . body)) 139 #`(begin 140 #,(if (attribute untyped-first) #'module-untyped #'module-typed) 141 #,(if (attribute untyped-first) #'module-typed #'module-untyped) 142 #,@(if (attribute no-test) 143 #'() 144 #`((module #,(ds 'test) #,(ds 'typed/racket) 145 #,(ds `(require (submod ".." typed test))) 146 #,(ds `(require (submod ".." untyped test)))))) 147 #,(ds '(require 'typed)) 148 #,(ds '(provide (all-from-out 'typed))))])) 149 150 (define-syntax (define-typed/untyped-test-module stx) 151 (syntax-parse stx 152 [(def-t/u-t-mod (~optional (~and untyped-first #:untyped-first)) . body) 153 (define (ds sym) (datum->syntax #'def-t/u-t-mod sym #'def-t/u-t-mod)) 154 (define/with-syntax module-typed 155 #`(module #,(ds 'typed-test) #,(ds 'typed/racket) 156 #,(ds '(require typed/rackunit 157 "../typed-untyped.rkt")) 158 . body)) 159 (define/with-syntax module-untyped 160 #`(module #,(ds 'untyped-test) #,(ds 'typed/racket/no-check) 161 #,(ds '(require (for-syntax racket/base) 162 rackunit 163 "../typed-untyped.rkt")) 164 . body)) 165 #`(begin 166 #,(if (attribute untyped-first) #'module-untyped #'module-typed) 167 #,(if (attribute untyped-first) #'module-typed #'module-untyped) 168 (module #,(ds 'test) #,(ds 'typed/racket) 169 #,(ds `(require (submod ".." typed-test))) 170 #,(ds `(require (submod ".." untyped-test)))) 171 #,(ds '(require 'typed-test)) 172 #,(ds '(provide (all-from-out 'typed-test))))])) 173 174 #| ;; test: should work in no-check but not in typed: 175 (define-typed/untyped-modules moo 176 (: foo One) 177 (define foo 2)) 178 |#) 179 180 ;; if-typed 181 (define-syntax-rule (if-typed-typed t u) t) 182 (define-syntax-rule (if-typed-untyped t u) u) 183 (define-typed/untyped-identifier if-typed 184 if-typed-typed 185 if-typed-untyped) 186 187 ;; when-typed and when-untyped 188 (define-syntax-rule (when-typed . t) (if-typed (begin . t) (begin))) 189 (define-syntax-rule (when-untyped . t) (if-typed (begin) (begin . t))) 190 191 ;; typed/untyped-prefix 192 (begin 193 (define-syntax-rule (typed/untyped-prefix [typed-prefix ...] 194 [untyped-prefix ...] 195 . rest) 196 (if-typed (typed-prefix ... . rest) 197 (untyped-prefix ... . rest))) 198 #| 199 ;; test: should work in no-check but not in typed: 200 (typed/untyped-prefix 201 [module moo2 typed/racket] 202 [module moo2 typed/racket/no-check] 203 (: foo One) 204 (define foo 2)) 205 |#) 206 207 ;; define-modules 208 (begin 209 ;; define-modules 210 (define-syntax define-modules 211 (syntax-rules (no-submodule) 212 [(_ ([no-submodule] [name lang] ...) . body) 213 (begin (begin . body) 214 (module name lang . body) ...)] 215 [(_ ([name lang] ...) . body) 216 (begin (module name lang . body) ...)])) 217 218 #| 219 ;; TODO: tests: test with a macro and check that we can use it in untyped. 220 ;; TODO: tests: test with two mini-languages with different semantics for some 221 ;; function. 222 (define-modules ([foo typed/racket] [foo-untyped typed/racket/no-check]) 223 (provide x) 224 (: x (→ Syntax Syntax)) 225 (define (x s) s)) 226 227 (module test racket 228 (require (submod ".." foo-untyped)) 229 (x #'a)) 230 |#)