syntax-parse.rkt (9430B)
1 #lang typed/racket 2 (require "typed-untyped.rkt") 3 4 (module m-stx-identifier racket 5 (require racket/stxparam) 6 7 (provide stx) 8 9 (define-syntax-parameter stx 10 (lambda (call-stx) 11 (raise-syntax-error 12 'stx 13 (string-append "Can only be used in define-syntax/parse, λ/syntax-parse" 14 " or other similar forms") 15 call-stx)))) 16 17 (define-typed/untyped-modules #:no-test 18 (provide stx 19 define-and-for-syntax 20 define-syntax/parse 21 define-syntax/case 22 ;define-for-syntax/parse-args 23 define-for-syntax/case-args 24 λ/syntax-parse 25 λ/syntax-case 26 define/case-args 27 λstx 28 ~maybe 29 ~maybe* 30 ~optkw 31 ~oncekw 32 ~optkw… 33 ~oncekw… 34 ~kw 35 ~lit 36 ~with 37 ~attr 38 ~or-bug 39 ~rx-id 40 (rename-out [~or-bug ~either]) 41 define-simple-macro 42 ;template/loc 43 ;quasitemplate/loc 44 template/debug 45 quasitemplate/debug 46 meta-eval 47 define/with-parse 48 identity-macro 49 name-or-curry 50 (all-from-out "untyped-only/syntax-parse.rkt")) 51 52 (begin-for-syntax 53 (provide stx)) 54 55 (require (for-syntax (submod "stx.rkt" untyped))) 56 (require "untyped-only/syntax-parse.rkt") 57 58 (define-syntax (define-and-for-syntax stx) 59 (syntax-case stx () 60 [(_ id value) 61 (remove-use-site-scope 62 #'(begin 63 (define-for-syntax id value) 64 (define id value)))])) 65 66 67 (require (rename-in syntax/parse 68 [define/syntax-parse define/with-parse]) 69 syntax/parse/define 70 syntax/parse/experimental/template 71 (for-syntax racket/syntax 72 racket/stxparam) 73 (for-meta 2 racket/base racket/syntax) 74 racket/stxparam) 75 76 (require "typed-untyped.rkt" 77 (for-syntax "typed-untyped.rkt")) 78 (require-typed/untyped "backtrace.rkt") 79 (begin-for-syntax (require-typed/untyped "backtrace.rkt")) 80 81 (define-syntax ~maybe 82 (pattern-expander 83 (λ (stx) 84 (syntax-parse stx 85 [(_ pat ...) 86 #'(~optional (~seq pat ...))])))) 87 88 (define-syntax ~maybe* 89 (pattern-expander 90 (λ (stx) 91 (syntax-parse stx 92 [(_ name pat ...) 93 #'(~and name (~optional (~seq pat ...)))])))) 94 95 (define-for-syntax ((|make ~*kw| base-pattern name?) stx) 96 (syntax-case stx () 97 [(_ kw pat ...) 98 (keyword? (syntax-e #'kw)) 99 (let () 100 (define/with-syntax name 101 (format-id #'kw "~a" (keyword->string (syntax-e #'kw)))) 102 #`(#,base-pattern (~seq (~and name kw) pat ...) 103 #,@(if name? 104 #`(#:name #,(format "the ~a keyword" 105 (syntax-e #'kw))) 106 #'())))])) 107 108 (define-syntax ~optkw 109 (pattern-expander 110 (|make ~*kw| #'~optional #f))) 111 112 (define-syntax ~oncekw 113 (pattern-expander 114 (|make ~*kw| #'~once #f))) 115 116 (define-syntax ~optkw… 117 (pattern-expander 118 (|make ~*kw| #'~optional #t))) 119 120 (define-syntax ~oncekw… 121 (pattern-expander 122 (|make ~*kw| #'~once #t))) 123 124 (define-syntax ~kw 125 (pattern-expander 126 (λ (stx) 127 (syntax-parse stx 128 [(_ kw:keyword) 129 (define/with-syntax name 130 (format-id #'kw "~a" (keyword->string (syntax-e #'kw)))) 131 #'(~and name kw)])))) 132 133 ;; Circumvent the bug that causes "syntax-parse: duplicate attribute in: a" in 134 ;; (syntax-parse #'(x y z) [((~or a (a b c)) ...) #'(a ...)]) 135 (define-syntax ~or-bug 136 (pattern-expander 137 (λ (stx) 138 (syntax-parse stx 139 [(_ pat ...) 140 #'(~and (~or pat ...))])))) 141 142 (define-syntax ~lit 143 (pattern-expander 144 (λ (stx) 145 (syntax-parse stx 146 [(self (~optional (~seq name:id (~literal ~))) lit) 147 (if (attribute name) 148 #'(~and name (~literal lit)) 149 #'(~literal lit))] 150 [(self (~optional (~seq name:id (~literal ~))) lit ...) 151 (define (s stx) (datum->syntax #'self stx stx stx)) 152 (if (attribute name) 153 #'(~and name (~seq (~literal lit) ...)) 154 #'(~seq (~literal lit) ...))])))) 155 156 (define-syntax ~with 157 (pattern-expander 158 (λ (stx) 159 (syntax-parse stx 160 [(_ pat val) 161 #'(~parse pat val)])))) 162 163 (define-syntax ~attr 164 (pattern-expander 165 (λ (stx) 166 (syntax-parse stx 167 [(_ attr-name val) 168 #'(~bind [attr-name val])])))) 169 170 (require (submod ".." m-stx-identifier) 171 (for-syntax (submod ".." m-stx-identifier))) 172 173 ;; TODO: try to factor out the common parts of these definitions (problem: 174 ;; the same code is used at different meta-levels, we would need a separate 175 ;; module to declare it). 176 (define-simple-macro (define-syntax/parse (name . args) body0 . body) 177 (define-syntax (name stx2) 178 (with-backtrace (syntax->datum stx2) 179 (syntax-parameterize ([stx (make-rename-transformer #'stx2)]) 180 (syntax-parse stx2 181 [(_ . args) body0 . body]))))) 182 183 (define-syntax-rule (define-syntax/case (name . args) literals body0 . body) 184 (define-syntax (name stx2) 185 (syntax-parameterize ([stx (make-rename-transformer #'stx2)]) 186 (syntax-case stx2 literals 187 [(_ . args) (let () body0 . body)])))) 188 189 (define-syntax-rule (λ/syntax-parse args . body) 190 (λ (stx2) 191 (with-backtrace (syntax->datum stx2) 192 (syntax-parameterize ([stx (make-rename-transformer #'stx2)]) 193 (syntax-parse stx2 194 [args . body]))))) 195 196 (define-syntax-rule (λ/syntax-case args literals . body) 197 (λ (stx2) 198 (with-backtrace (syntax->datum stx2) 199 (syntax-parameterize ([stx (make-rename-transformer #'stx2)]) 200 (syntax-case stx2 literals 201 [args (let () . body)]))))) 202 203 (define-syntax (define-for-syntax/case-args wstx) 204 (syntax-case wstx () 205 [(_ (name args ...) . body) 206 (with-syntax ([(param ...) (generate-temporaries #'(args ...))]) 207 #'(define-for-syntax (name param ...) 208 (with-syntax ([args param] ...) 209 . body)))])) 210 211 (define-syntax (define/case-args wstx) 212 (syntax-case wstx () 213 [(_ (name args ...) . body) 214 (with-syntax ([(param ...) (generate-temporaries #'(args ...))]) 215 #'(define (name param ...) 216 (with-syntax ([args param] ...) 217 . body)))])) 218 219 ;; λstx 220 (begin 221 (define-syntax-rule (λstx (param ...) body ...) 222 (λ (param ...) 223 (with-syntax ([param param] ...) 224 body ...))) 225 226 (module+ test 227 (require typed/rackunit) 228 (check-equal? (syntax->datum ((λstx (foo bar) #'(foo bar)) #'a #'b)) 229 (syntax->datum #'(a b))))) 230 231 ;; template/loc 232 (begin 233 (define-syntax-rule (template/loc loc . tmpl) 234 (quasisyntax/loc loc #,(template . tmpl)))) 235 236 ;; quasitemplate/loc 237 (begin 238 (define-syntax-rule (quasitemplate/loc loc . tmpl) 239 (quasisyntax/loc loc #,(quasitemplate . tmpl)))) 240 241 ;; template/debug 242 (begin 243 (define-syntax (template/debug stx) 244 (syntax-parse stx 245 [(_ debug-attribute:id . rest) 246 #'((λ (x) 247 (when (attribute debug-attribute) 248 (pretty-write (syntax->datum x))) 249 x) 250 (template . rest))]))) 251 252 ;; quasitemplate/debug 253 (begin 254 (define-syntax (quasitemplate/debug stx) 255 (syntax-parse stx 256 [(_ debug-attribute:id . rest) 257 #'((λ (x) 258 (when (attribute debug-attribute) 259 (pretty-write (syntax->datum x))) 260 x) 261 (quasitemplate . rest))]))) 262 263 ;; meta-eval 264 (begin 265 ;; TODO: this is kind of a hack, as we have to write: 266 #;(with-syntax ([(x ...) #'(a bb ccc)]) 267 (let ([y 70]) 268 (quasitemplate 269 ([x (meta-eval (+ #,y (string-length 270 (symbol->string 271 (syntax-e #'x)))))] 272 ...)))) 273 ;; Where we need #,y instead of using: 274 ;; (+ y (string-length etc.)). 275 (module m-meta-eval racket 276 (provide meta-eval) 277 (require syntax/parse/experimental/template) 278 279 (define-template-metafunction (meta-eval stx) 280 (syntax-case stx () 281 [(_ . body) 282 #`#,(eval #'(begin . body))]))) 283 (require 'm-meta-eval)) 284 285 (define-syntax (identity-macro stx) 286 (syntax-case stx () 287 [(_ . rest) 288 (remove-use-site-scope #'rest)])) 289 290 (module m-name-or-curry racket/base 291 (provide (all-defined-out)) 292 (require syntax/parse) 293 (define-syntax-class name-or-curry 294 #:attributes (id) 295 (pattern id:id) 296 (pattern (:name-or-curry . curry-args)))) 297 (require 'm-name-or-curry) 298 299 (define (match-id [rx : Regexp] [id : Identifier]) 300 (let ([m (regexp-match rx (symbol->string (syntax-e id)))]) 301 (and m (map (λ ([% : (U #f String)]) 302 (and % (datum->syntax id (string->symbol %) id id))) 303 (cdr m))))) 304 (define-syntax ~rx-id 305 (pattern-expander 306 (λ (stx) 307 (syntax-case stx () 308 [(_ rx . g*) 309 #'(~and x:id 310 {~parse g* (match-id rx #'x)})])))))