stx.rkt (14886B)
1 #lang typed/racket 2 (require "typed-untyped.rkt") 3 (define-typed/untyped-modules #:no-test 4 ;; intersection types with ∩ were not present in 6.5 5 (require "typed-untyped.rkt") 6 (if-typed 7 (define-syntax (if-typed<6.6 stx) 8 (syntax-case stx () 9 [(_ lt ge) 10 (if (or (regexp-match #px"^6(\\.[012345](\\..*|)|)$" (version)) 11 (regexp-match #px"^[123245]\\..*$" (version))) 12 #'lt 13 #'ge)])) 14 (define-syntax-rule (if-typed<6.6 lt ge) ge)) 15 (define-syntax-rule (skip-typed<6.6 . rest) 16 (if-typed<6.6 (begin) (begin . rest))) 17 18 (skip-typed<6.6 19 (provide stx-e/c 20 stx-e)) 21 (provide (all-from-out syntax/stx 22 "stx/fold.rkt" 23 "untyped-only/stx.rkt") 24 25 stx-list 26 stx-e 27 stx-pair 28 29 stx-list/c 30 stx-car/c 31 stx-cdr/c 32 33 syntax-cons-property 34 stx-map-nested 35 identifier-length 36 identifier->string 37 (rename-out [identifier->string identifier→string]) 38 ;stx-map-nested 39 40 stx-car 41 stx-cdr 42 stx-null? 43 stx-pair? 44 stx-list? 45 46 stx-cons 47 48 Stx-List? 49 Syntax-Pairs-of 50 51 stx-drop-last 52 stx->list 53 54 stx-foldl 55 56 stx-assoc 57 cdr-stx-assoc 58 59 check-duplicate-identifiers 60 61 remove-use-site-scope 62 63 nameof) 64 65 (require syntax/stx 66 (for-syntax racket/syntax 67 "untyped-only/stx.rkt") 68 "typed-untyped.rkt") 69 (require-typed/untyped "sequence.rkt") 70 71 (require "stx/fold.rkt" 72 "untyped-only/stx.rkt") 73 74 ;; match-expanders: 75 ;; stx-list 76 ;; stx-e 77 ;; stx-pair 78 (begin 79 (define-match-expander stx-list 80 (λ (stx) 81 (syntax-case stx () 82 [(_ pat ...) 83 #'(? syntax? 84 (app syntax->list (list pat ...)))]))) 85 86 (define-for-syntax stx-e-match-expander 87 (λ (stx) 88 (syntax-case stx () 89 [(_ pat) 90 #'(? syntax? 91 (app syntax-e pat))]))) 92 93 (if-typed<6.6 94 (define-match-expander stx-e 95 stx-e-match-expander) 96 (define-match-expander stx-e 97 stx-e-match-expander 98 (make-id+call-transformer #'stx-e-fun))) 99 100 (define-match-expander stx-pair 101 (λ (stx) 102 (syntax-case stx () 103 [(_ pat-car pat-cdr) 104 #'(? syntax? 105 (app syntax-e (cons pat-car pat-cdr)))])))) 106 107 ;; utilities: 108 ;; syntax-cons-property 109 ;; identifier-length 110 ;; identifier->string 111 ;; stx-map-nested 112 (begin 113 (: syntax-cons-property (∀ (A) (→ (Syntaxof A) Symbol Any (Syntaxof A)))) 114 (define (syntax-cons-property stx key v) 115 (let ([orig (syntax-property stx key)]) 116 (syntax-property stx key (cons v (or orig '()))))) 117 118 (: identifier-length (→ Identifier Index)) 119 (define (identifier-length id) (string-length (identifier->string id))) 120 121 (: identifier->string (→ Identifier String)) 122 (define (identifier->string id) (symbol->string (syntax-e id))) 123 124 (: stx-map-nested (∀ (A B) (→ (→ A B) 125 (Syntaxof (Listof (Syntaxof (Listof A)))) 126 (Listof (Listof B))))) 127 (define (stx-map-nested f stx) 128 (map (λ ([x : (Syntaxof (Listof A))]) 129 (map f (syntax-e x))) 130 (syntax-e stx)))) 131 132 ;; accessors: 133 ;; stx-car 134 ;; stx-cdr 135 ;; stx-null? 136 ;; stx-pair? 137 (begin 138 #| 139 (require/typed syntax/stx 140 [stx-car (∀ (A B) (→ (Syntaxof (Pairof A B)) A))] 141 [stx-cdr (∀ (A B) (→ (Syntaxof (Pairof A B)) B))]) 142 |# 143 144 (: stx-car (∀ (A B) 145 (case→ (→ (U (Syntaxof (Pairof A B)) (Pairof A B)) A) 146 ;; TODO: Not typesafe! 147 (→ (U (Syntaxof (Listof A)) (Listof A)) A)))) 148 (define (stx-car p) (car (if (syntax? p) (syntax-e p) p))) 149 150 (: stx-cdr (∀ (A B) 151 (case→ (→ (U (Syntaxof (Pairof A B)) (Pairof A B)) B) 152 ;; TODO: Not typesafe! 153 (→ (U (Syntaxof (Listof A)) (Listof A)) 154 (Listof A))))) 155 (define (stx-cdr p) (cdr (if (syntax? p) (syntax-e p) p))) 156 157 (: stx-car/c (∀ (Result) (→ (→ Any Result) 158 (→ Any (U #f Result))))) 159 (define ((stx-car/c car/c) v) 160 (if (syntax? v) 161 (if (pair? (syntax-e v)) 162 (let ([r (car/c (car (syntax-e v)))]) 163 r) 164 #f) 165 #f)) 166 167 (: stx-cdr/c (∀ (Result) (→ (→ Any Result) 168 (→ Any (U #f Result))))) 169 (define ((stx-cdr/c car/c) v) 170 (and (if-typed 171 ((make-predicate (Syntaxof (Pairof Any Any))) v) 172 (and (syntax? v) (pair? (syntax-e v)))) 173 (car/c (stx-cdr v)))) 174 175 (: stx-null? (→ Any Boolean : (U (Syntaxof Null) Null))) 176 (define (stx-null? v) 177 (if-typed 178 ((make-predicate (U (Syntaxof Null) Null)) v) 179 (or (null? v) (and (syntax? v) (null? (syntax-e v)))))) 180 181 (: stx-pair? (→ Any Boolean : (U (Pairof Any Any) 182 (Syntaxof (Pairof Any Any))))) 183 (define (stx-pair? v) 184 (if-typed 185 ((make-predicate (U (Pairof Any Any) 186 (Syntaxof (Pairof Any Any)))) 187 v) 188 (or (pair? v) (and (syntax? v) (pair? (syntax-e v))))))) 189 190 ;; constructors: 191 ;; stx-cons 192 (begin 193 (module m-stx-cons-untyped racket 194 (provide stx-cons list->stx list*->stx) 195 196 (define (stx-cons a b) #`(#,a . #,b)) 197 (define (list->stx l) #`#,l) 198 (define (list*->stx l*) #`#,l*)) 199 200 (if-typed 201 (module m-stx-cons-typed typed/racket 202 (provide stx-cons list->stx list*->stx) 203 (require (only-in typed/racket/unsafe unsafe-require/typed)) 204 (unsafe-require/typed 205 (submod ".." m-stx-cons-untyped) 206 [stx-cons (∀ (A B) 207 (→ (Syntaxof A) 208 (Syntaxof B) 209 (Syntaxof (Pairof (Syntaxof A) (Syntaxof B)))))] 210 [list->stx (∀ (A) 211 (→ (Listof (Syntaxof A)) 212 (Syntaxof (Listof (Syntaxof A)))))] 213 [list*->stx (∀ (A B) 214 (→ (Rec R (U B (Pairof (Syntaxof A) R))) 215 (Syntaxof (Rec R (U B (Pairof (Syntaxof A) R))))))])) 216 (module m-stx-cons-typed racket 217 (provide stx-cons list->stx list*->stx) 218 (require (submod ".." m-stx-cons-untyped)))) 219 220 (require 'm-stx-cons-typed)) 221 222 ;; stx-drop-last 223 (begin 224 (: drop-last (∀ (A) (→ (Listof A) (Listof A)))) 225 (define (drop-last l) 226 (if (and (pair? l) (pair? (cdr l))) 227 (cons (car l) (drop-last (cdr l))) 228 '())) 229 230 (define-type (Stx-List? A) 231 (U Null 232 (Pairof A (Stx-List? A)) 233 (Syntaxof Null) 234 (Syntaxof (Pairof A (Stx-List? A))))) 235 236 (: stx-list? (→ Any Boolean : (Stx-List? Any))) 237 (define (stx-list? v) 238 (if-typed ((make-predicate (Stx-List? Any)) v) 239 (or (null? v) 240 (and (pair? v) (stx-list? (cdr v))) 241 (and (syntax? v) (null? (syntax-e v))) 242 (and (syntax? v) (stx-list? (cdr (syntax-e v))))))) 243 244 (: stx-list/c (∀ (Result) (→ (→ (Listof Any) Result) 245 (→ Any (U #f Result))))) 246 (define ((stx-list/c l/c) v) 247 (and (stx-list? v) 248 (l/c (stx->list v)))) 249 250 (define-type (Syntax-Pairs-of A) 251 (U (Syntaxof Null) 252 (Syntaxof (Pairof A (Syntax-Pairs-of A))))) 253 254 (: stx->list (∀ (A) (→ (Stx-List? A) (Listof A)))) 255 (define (stx->list l) 256 (cond [(null? l) 257 '()] 258 [(pair? l) 259 (cons (car l) (stx->list (cdr l)))] 260 [else 261 (stx->list (syntax-e l))])) 262 263 (: stx-drop-last 264 (∀ (A) (→ (Stx-List? (Syntaxof A)) (Syntaxof (Listof (Syntaxof A)))))) 265 (define (stx-drop-last l) 266 (list->stx (drop-last (stx->list l)))) 267 268 ;; stx-e-fun is used as the fallback for the stx-e match-expander 269 (define-type SexpofAny1 (U Boolean 270 Complex 271 Char 272 Null 273 Symbol 274 String 275 Keyword 276 (Pairof Any Any) 277 VectorTop 278 BoxTop)) 279 280 (skip-typed<6.6 281 (: stx-e/c (∀ (Result) (→ (→ Any Result) 282 (→ Any (U #f Result))))) 283 (define ((stx-e/c e/c) v) 284 (and (if-typed ((make-predicate (U (Syntaxof Any) SexpofAny1)) v) 285 #t) ;; The untyped stx-e-fun is more permissive 286 (e/c (stx-e-fun v)))) 287 288 (: stx-e-fun (∀ (A) (case→ (→ (U (Syntaxof A) (∩ A SexpofAny1)) 289 A)))) 290 (define (stx-e-fun v) 291 (if (syntax? v) 292 (syntax-e v) 293 v))) 294 #| 295 #;(cond [(null? l) 296 #'()] 297 [(pair? l) 298 (cond [(null? (cdr l)) 299 #'()] 300 [(pair? (cdr l)) 301 ] 302 [else 303 (let* ([res (stx-drop-last (cdr l))] 304 [e (syntax-e res)]) 305 (if (null? e) 306 (stx-cons (car l) #'()) 307 (stx-cons (car l) res)))] 308 [else 309 (stx-drop-last (syntax-e l))]) 310 311 #;(if (if-typed ((make-predicate (Syntaxof Any)) l) (syntax? l)) 312 (stx-drop-last (syntax-e l)) 313 (if (null? l) 314 #'() 315 (stx-cons (car l) 316 (stx-drop-last (cdr l))))))) 317 |#) 318 319 ;; stx-foldl 320 (begin 321 (: stx-foldl 322 (∀ (E F G Acc) 323 (case→ (→ (→ E Acc Acc) 324 Acc 325 (U (Syntaxof (Listof E)) (Listof E)) 326 Acc) 327 (→ (→ E F Acc Acc) 328 Acc 329 (U (Syntaxof (Listof E)) (Listof E)) 330 (U (Syntaxof (Listof F)) (Listof F)) 331 Acc) 332 (→ (→ E F G Acc Acc) 333 Acc 334 (U (Syntaxof (Listof E)) (Listof E)) 335 (U (Syntaxof (Listof F)) (Listof F)) 336 (U (Syntaxof (Listof G)) (Listof G)) 337 Acc)))) 338 (define stx-foldl 339 (case-lambda 340 [(f acc l) 341 (if (stx-null? l) 342 acc 343 (stx-foldl f (f (stx-car l) acc) (stx-cdr l)))] 344 [(f acc l l2) 345 (if (or (stx-null? l) (stx-null? l2)) 346 acc 347 (stx-foldl f 348 (f (stx-car l) (stx-car l2) acc) 349 (stx-cdr l) 350 (stx-cdr l2)))] 351 [(f acc l l2 l3) 352 (if (or (stx-null? l) (stx-null? l2) (stx-null? l3)) 353 acc 354 (stx-foldl f 355 (f (stx-car l) (stx-car l2) (stx-car l3) acc) 356 (stx-cdr l) 357 (stx-cdr l2) 358 (stx-cdr l3)))]))) 359 360 ;; stx-assoc 361 ;; cdr-stx-assoc 362 (begin 363 (: stx-assoc (∀ (T) (case→ 364 (→ Identifier 365 (U (Syntaxof (Listof (Syntaxof (Pairof Identifier 366 T)))) 367 (Listof (Syntaxof (Pairof Identifier T)))) 368 (U (Syntaxof (Pairof Identifier T)) #f)) 369 (→ Identifier 370 (Listof (Pairof Identifier T)) 371 (U (Pairof Identifier T) #f))))) 372 (define (stx-assoc id alist) 373 (let* ([e-alist (if (syntax? alist) 374 (syntax->list alist) 375 alist)] 376 [e-e-alist (cond 377 [(null? e-alist) '()] 378 [(syntax? (car e-alist)) 379 (map (λ ([x : (Syntaxof (Pairof Identifier T))]) 380 (cons (stx-car x) x)) 381 e-alist)] 382 [else 383 (map (λ ([x : (Pairof Identifier T)]) 384 (cons (car x) x)) 385 e-alist)])] 386 [result (assoc id e-e-alist free-identifier=?)]) 387 (if result (cdr result) #f))) 388 389 (: cdr-stx-assoc 390 (∀ (T) (case→ (→ Identifier 391 (U (Syntaxof (Listof (Syntaxof (Pairof Identifier T)))) 392 (Listof (Syntaxof (Pairof Identifier T))) 393 (Listof (Pairof Identifier T))) 394 (U T #f))))) 395 (define (cdr-stx-assoc id alist) 396 (if (null? alist) 397 #f 398 ;; The typechecker is not precise enough, and the code below does not 399 ;; work if we factorize it: 400 ;; (if (and (list? alist) (syntax? (car alist))) … …) 401 (if (list? alist) 402 (if (syntax? (car alist)) 403 (let ((res (stx-assoc id alist))) 404 (if res (stx-cdr res) #f)) 405 (let ((res (stx-assoc id alist))) 406 (if res (cdr res) #f))) 407 (let ((res (stx-assoc id alist))) 408 (if res (stx-cdr res) #f)))))) 409 410 ;; check-duplicate-identifiers 411 (begin 412 (: check-duplicate-identifiers (→ (Syntaxof (Listof (Syntaxof Symbol))) 413 Boolean)) 414 (define (check-duplicate-identifiers ids) 415 (if (check-duplicate-identifier (my-in-syntax ids)) #t #f))) 416 417 ;; remove-use-site-scope 418 (begin 419 (define #:∀ (A) (remove-use-site-scope [stx : (Syntaxof A)]) 420 (define bd 421 (syntax-local-identifier-as-binding (syntax-local-introduce #'here))) 422 (define delta 423 (make-syntax-delta-introducer (syntax-local-introduce #'here) bd)) 424 (delta stx 'remove))) 425 426 ;; nameof 427 (begin 428 ;; TODO: use the proper way to introduce arrows if possible. 429 (define-syntax (nameof stx) 430 (syntax-case stx () 431 [(_ x) 432 (record-disappeared-uses (list #'x)) 433 #''x]))) 434 435 #| 436 (define (raise-multi-syntax-error name message exprs) 437 (let ([e (exn:fail:syntax "message" 438 (current-continuation-marks) 439 (list #'aaa #'bbb))]) 440 ((error-display-handler) (exn-message e) e))) 441 |#)