define-syntax+simple-api.rkt (4962B)
1 #lang racket/base 2 3 (provide define-syntax/parse+simple 4 (for-syntax define/syntax-parse+simple)) 5 6 (require phc-toolkit/untyped 7 syntax/parse/define 8 (for-syntax racket/base 9 syntax/parse 10 racket/stxparam 11 racket/syntax 12 phc-toolkit/untyped 13 "parameters.rkt") 14 (for-meta 2 (prefix-in syntax/parse: syntax/parse/private/residual-ct)) 15 (for-meta 2 racket/base) 16 (for-meta 2 racket/list) 17 (for-meta 2 racket/syntax) 18 (for-meta 2 syntax/parse) 19 (for-meta 2 syntax/parse/experimental/template) 20 (for-meta 2 phc-toolkit/untyped)) 21 22 (define-syntax/parse (define-syntax/parse+simple 23 [name . args] . body) 24 (with-format-ids/inject-binders 25 ([name-forward #'name "~a-forward-attributes" #'name] 26 [tmp-forward #'tmp "~a-forward-attributes" #'tmp]) 27 #'(begin 28 (begin-for-syntax 29 (inject-sub-range-binders ... 30 (define/syntax-parse+simple [tmp . args] . body) 31 (define-syntax name-forward (make-rename-transformer #'tmp-forward)))) 32 (define-syntax name tmp)))) 33 34 (begin-for-syntax 35 (define-syntax (define/syntax-parse+simple stx) 36 (syntax-parse stx 37 [(_ (name:name-or-curry . args) 38 (~optional (~seq #:define-splicing-syntax-class define-splicing:id)) 39 (~optional (~seq #:define-syntax-class define-class:id)) 40 . body) 41 (let () 42 (define introducer (make-syntax-introducer)) 43 (define/with-syntax args-stxclass 44 (or (attribute define-class) 45 (introducer (datum->syntax #'args 'args-stxclass) 'add))) 46 (define/with-syntax body-introduced 47 (introducer #'body 'add)) 48 (template 49 (begin 50 (?? (define-splicing-syntax-class define-splicing 51 #:auto-nested-attributes 52 (pattern {~seq . args}))) 53 (define-syntax-class args-stxclass 54 #:auto-nested-attributes 55 (pattern args)) 56 (define/syntax-parse+simple/stxclass [name . args-stxclass] 57 . body-introduced))))])) 58 59 (define-for-syntax (change-name-or-curry stx new-name) 60 (if (identifier? stx) 61 new-name 62 #`(#,(change-name-or-curry (stx-car stx) new-name) . #,(stx-cdr stx)))) 63 64 #;(define-for-syntax (pat-name-or-curry stx new-name) 65 (if (identifier? stx) 66 new-name 67 #`(#,(pat-name-or-curry (stx-car stx) new-name) . #,(gensym 'args)))) 68 69 (define-syntax define/syntax-parse+simple/stxclass 70 (syntax-parser-with-arrows 71 [(_ [name:name-or-curry 72 . (~var cls (static syntax/parse:stxclass? "a syntax class"))] 73 . body) 74 #:with colon-stxclass (format-id #'cls ":~a" #'cls) 75 #:with name-forward (format-id/record #'name.id 76 "~a-forward-attributes" #'name.id) 77 (define c (syntax-local-value/record #'cls syntax/parse:stxclass?)) 78 (define attrs (filter-not (λ (a) (is-clause-id-sym? 79 (syntax/parse:attr-name a))) 80 (syntax/parse:stxclass-attrs c))) 81 (define/with-syntax (attr-name …) (map syntax/parse:attr-name attrs)) 82 (define/with-syntax (attr-name/ctx …) 83 (stx-map (λ (a) (datum->syntax #'body (syntax-e a))) 84 #'(attr-name …))) 85 (define-temp-ids "~a/arg" (attr-name …)) 86 (define/with-syntax (attr-depth …) 87 (map syntax/parse:attr-depth attrs)) 88 (define/with-syntax def-private-simple-api 89 (change-name-or-curry #'name 90 #'(private-simple-api stx/arg attr-name/arg …))) 91 (syntax/top-loc this-syntax 92 (begin 93 (define (name stx2) 94 (with-arrows 95 (syntax-parameterize ([stx (make-rename-transformer #'stx2)]) 96 (syntax-parse stx2 97 [(_ . colon-stxclass) . body])))) 98 (define def-private-simple-api 99 (syntax-parameterize ([stx (make-rename-transformer #'stx/arg)]) 100 (syntax-parse #'nothing 101 [(~bind [(attr-name/ctx attr-depth) attr-name/arg] …) 102 . body]))) 103 (define-syntax (name-forward stx3) 104 (syntax-case stx3 () 105 [(_) 106 (quasisyntax/top-loc stx3 107 (private-simple-api 108 stx 109 (attribute #,(datum->syntax stx3 'attr-name)) 110 …))] 111 [(_ forward-args-prefix) 112 (identifier? #'forward-args-prefix) 113 (quasisyntax/top-loc stx3 114 (private-simple-api 115 stx 116 (attribute #,(format-id stx3 "~a.~a" 117 #'forward-args-prefix 118 'attr-name)) 119 …))]))))])))