unsyntax-preparse.rkt (10171B)
1 #lang racket/base 2 3 (provide template-ddd 4 subtemplate-ddd 5 quasitemplate-ddd 6 quasisubtemplate-ddd) 7 8 (require (rename-in stxparse-info/parse/experimental/template 9 [?? stxparse:??] 10 [?@ stxparse:?@]) 11 subtemplate/private/ddd-forms 12 subtemplate/private/template-subscripts 13 (only-in racket/base [... …]) 14 stxparse-info/parse 15 stxparse-info/case 16 syntax/stx 17 racket/list 18 version-case 19 (for-syntax racket/base 20 racket/list 21 racket/syntax 22 stxparse-info/parse 23 (only-in racket/base [... …]) 24 phc-toolkit/untyped)) 25 26 (version-case 27 [(version< (version) "6.90.0.24") 28 (begin)] 29 [else 30 (require (only-in racket/private/template 31 [metafunction? template-metafunction?]))]) 32 33 (define-for-syntax lifted (make-parameter #f)) 34 35 (begin-for-syntax 36 (define-syntax-class qq 37 (pattern {~or {~literal stxparse:??} {~literal ??}})) 38 (define-syntax-class qa 39 (pattern {~or {~literal stxparse:?@} {~literal ?@}}))) 40 41 (define-for-syntax (pre-parse-unsyntax tmpl depth escapes quasi? form) 42 ;; TODO: a nested quasisubtemplate should escape an unsyntax! 43 (define (ds e) 44 ;; TODO: should preserve the shape of the original stx 45 ;; (syntax list vs syntax pair) 46 (datum->syntax tmpl e tmpl tmpl)) 47 (define-syntax-class ooo 48 (pattern {~and ooo {~literal ...}})) 49 (define (recur t) (pre-parse-unsyntax t depth escapes quasi? form)) 50 (define (stx-length stx) (length (syntax->list stx))) 51 (define (lift! e) (set-box! (lifted) (cons e (unbox (lifted))))) 52 (syntax-parse tmpl 53 #:literals (unsyntax unsyntax-splicing unquote unquote-splicing 54 quasitemplate ?if ?cond ?attr ?@@) 55 [({~and u unsyntax} (unquote e)) 56 #:when (and (= escapes 0) quasi?) 57 ;; full unsyntax with #,,e 58 (ds `(,#'u ,#'e))] 59 [({~and u unsyntax-splicing} (unquote e)) 60 #:when (and (= escapes 0) quasi?) 61 ;; full unsyntax-splicing with #,@,e 62 (ds `(,#'u ,#'e))] 63 [({~and u unsyntax} (unquote-splicing e)) 64 #:when (and (= escapes 0) quasi?) 65 ;; full unsyntax-splicing with #,,@e 66 (ds `(,(datum->syntax #'here 'unsyntax-splicing #'u) ,#'e))] 67 [({~and u unsyntax} e) 68 #:when (and (= escapes 0) quasi?) 69 ;; ellipsis-preserving unsyntax with #,e 70 ;; If we are nested at depth D, this lifts a syntax pattern variable 71 ;; definition for (((tmp ...) ...) ...), with D levels of nesting. 72 ;; It uses "begin" from subtemplate/private/ddd-forms to generate the 73 ;; values for tmp succinctly. The template #'e is evaluated as many times 74 ;; as necessary by "begin", each time stepping the variables under 75 ;; ellipses. 76 (with-syntax ([tmp (generate-temporary #'e)] 77 [ooo* (map (λ (_) (quote-syntax …)) (range depth))]) 78 ;; The value returned by e is wrapped in a list via (splice-append e). 79 ;; Normally, the list will contain a single element, unless e was a 80 ;; splicing list, in which case it may contain multiple elements. 81 (lift! #`(begin (define/with-syntax tmp (splice-append e)) . ooo*)) 82 ;; Finally, tmp is inserted into the template (the current position is 83 ;; under D levels of ellipses) using (?@) to destroy the wrapper list. 84 ;; This allows #,(?@ 1 2 3) to be equivalent to #,@(list 1 2 3). 85 (ds `(,#'stxparse:?@ . ,(datum->syntax #'tmp #'tmp #'e))))] 86 [({~and u unsyntax-splicing} e) 87 ;; ellipsis-preserving unsyntax-splicing with #,@e 88 ;; This works in the same way as the #,e case just above… 89 #:when (and (= escapes 0) quasi?) 90 (with-syntax ([tmp (generate-temporary #'e)] 91 [ooo* (map (λ (_) (quote-syntax …)) (range depth))]) 92 ;; … with the notable difference that splice-append* is used instead of 93 ;; splice-append. 94 (lift! #`(begin (define/with-syntax tmp (splice-append* e)) . ooo*)) 95 (ds `(,#'stxparse:?@ . ,(datum->syntax #'tmp #'tmp #'e))))] 96 [({~and u {~or unsyntax unsyntax-splicing}} e) 97 ;; Undo one level of protection, so that in #`#`#,x the inner #` adds one 98 ;; level of escapement, and #, undoes that escapement. 99 ;; Normally, escapes > 0 here (or quasi? is #false) 100 (ds `(,#'u ,(pre-parse-unsyntax #'e depth (sub1 escapes) quasi? form)))] 101 [(quasitemplate t . opts) 102 ;; #`#`#,x does not unquote x, because it is nested within two levels of 103 ;; quasitemplate. We reproduce this behaviour here. 104 (ds `(,#'quasitemplate 105 ,(pre-parse-unsyntax #'t depth (add1 escapes) quasi? form) 106 . ,#'opts))] 107 [({~and self ?if} condition a b) 108 ;; Special handling for the (?if condition a b) meta-operator 109 (with-syntax ([tmp (generate-temporary #'self)] 110 [ooo* (map (λ (_) (quote-syntax …)) (range depth))]) 111 (lift! #`(begin (define/with-syntax tmp (?if #,(form (recur #'condition)) 112 #,(form (recur #'(a))) 113 #,(form (recur #'(b))))) 114 . ooo*)) 115 #'(stxparse:?@ . tmp))] 116 [({~and self ?cond} [{~and condition {~not {~literal else}}} . v] . rest) 117 ;; Special handling for the ?cond meta-operator, when the first case has 118 ;; the shape [condition . v], but not [else . v] 119 (recur (ds `(,#'?if ,#'condition 120 ,(ds `(,#'?@ . ,#'v)) 121 ,(ds `(,#'self . ,#'rest)))))] 122 [({~and self ?cond} [{~literal else}]) 123 ;; ?cond meta-operator, when the only case has the shape [else] 124 #'(stxparse:?@)] 125 [({~and self ?cond} [{~literal else} . v] . rest) 126 ;; ?cond meta-operator, when the first case has the shape [else . v] 127 (recur (ds `(,#'?@ . ,#'v)))] 128 [({~and self ?@@} . e) 129 ;; Special handling for the special (?@@ . e) meta-operator 130 (with-syntax ([tmp (generate-temporary #'self)] 131 [ooo* (map (λ (_) (quote-syntax …)) (range depth))]) 132 (lift! #`(begin (define/with-syntax tmp 133 (append* (stx-map*syntax->list #,(form (recur #'e))))) 134 . ooo*)) 135 #'(stxparse:?@ . tmp))] 136 [({~and self ?attr} condition) 137 ;; Special handling for the special (?attr a) meta-operator 138 (recur (ds `(,#'?if ,#'condition 139 #t 140 #f)))] 141 [(:ooo t) 142 ;; Ellipsis used to escape part of a template, i.e. (... escaped) 143 tmpl] ;; tmpl is fully escaped: do not change anything, pass the ... along 144 [(self:qq a b c . rest) 145 ;; Extended ?? from syntax/parse with three or more cases 146 (ds `(,#'stxparse:?? ,(recur #'a) 147 ,(recur (ds `(,#'self ,#'b ,#'c . ,#'rest)))))] 148 [(:qq a b) 149 ;; ?? from syntax/parse with two cases 150 (ds `(,#'stxparse:?? ,(recur #'a) ,(recur #'b)))] 151 [(:qq a) 152 ;; ?? from syntax/parse with a single case (implicit (?@) as the else case) 153 (ds `(,#'stxparse:?? ,(recur #'a)))] 154 [(:qa . args) 155 ;; ?@ from syntax/parse 156 (ds `(,#'stxparse:?@ . ,(recur #'args)))] 157 [({~var mf (static template-metafunction? "template metafunction")} . args) 158 ;; template metafunction from stxparse-info/parse (incompatible with 159 ;; syntax/parse's metafunctions until PR racket/racket#1591 is merged). 160 (ds `(,#'mf . ,(recur #'args)))] 161 [(hd :ooo ...+ . tl) 162 ;; (hd ... . tl), with one or more ellipses after hd 163 (ds `(,(pre-parse-unsyntax #'hd 164 (+ depth (stx-length #'(ooo …))) 165 escapes 166 quasi? 167 form) 168 ,@(syntax->list #'(ooo ...)) 169 . ,(recur #'tl)))] 170 [(hd . tl) 171 ;; (hd . tl) 172 (ds `(,(recur #'hd) . ,(recur #'tl)))] 173 [#(t …) 174 ;; #(t …) 175 (ds (vector->immutable-vector (list->vector (stx-map recur #'(t …)))))] 176 ;; other ids, empty list, numbers, strings, chars, … 177 [_ tmpl])) 178 179 (define (check-single-result result stx form) 180 (unless (and (stx-pair? result) (stx-null? (stx-cdr result))) 181 (raise-syntax-error form 182 (string-append "the outer ?@ in the template produced" 183 " more than one syntax object") 184 stx)) 185 (stx-car result)) 186 187 (define-for-syntax ((*template-ddd quasi? form) stx) 188 (syntax-case stx () 189 [(_ tmpl . opts) 190 (parameterize ([lifted (box '())]) 191 (let ([new-tmpl (pre-parse-unsyntax #'tmpl 0 0 quasi? 192 (λ (e) #`(#,form #,e . opts)))]) 193 (if (null? (unbox (lifted))) 194 (datum->syntax stx 195 `(,form ,new-tmpl . ,#'opts) 196 stx 197 stx) 198 ((λ (~) 199 ;(local-require racket/pretty) 200 ;(pretty-write (syntax->datum ~)) 201 ~) 202 (quasisyntax/top-loc stx 203 (let-values () 204 #,@(reverse (unbox (lifted))) 205 (define result 206 #,(datum->syntax stx 207 `(,form (,new-tmpl) . ,#'opts) 208 stx 209 stx)) 210 (check-single-result result 211 (quote-syntax #,stx) 212 'form)))))))])) 213 214 (define-syntax quasitemplate-ddd (*template-ddd #t #'quasitemplate)) 215 (define-syntax quasisubtemplate-ddd (*template-ddd #t #'quasisubtemplate)) 216 (define-syntax template-ddd (*template-ddd #f #'template)) 217 (define-syntax subtemplate-ddd (*template-ddd #f #'subtemplate)) 218 219 (define (stx-map*syntax->list e) 220 (let loop ([l (syntax->list e)]) 221 (cond 222 [(null? l) l] 223 [(pair? l) (cons (syntax->list (car l)) (loop (cdr l)))] 224 ;; Special treatment for the last element of e: it does not need to 225 ;; be a list (as long as ?@ is used in tail position). 226 [else l])))