syntax.rkt (10626B)
1 #lang racket/base 2 (require (only-in "stxloc.rkt" syntax-case) 3 stxparse-info/current-pvars 4 (for-syntax racket/base 5 racket/private/sc 6 auto-syntax-e/utils)) 7 (provide define/with-syntax 8 9 current-recorded-disappeared-uses 10 with-disappeared-uses 11 syntax-local-value/record 12 record-disappeared-uses 13 14 format-symbol 15 format-id 16 17 current-syntax-context 18 wrong-syntax 19 20 generate-temporary 21 internal-definition-context-apply 22 syntax-local-eval 23 with-syntax*) 24 25 ;; == Defining pattern variables == 26 27 (define-syntax (define/with-syntax stx) 28 (syntax-case stx () 29 [(define/with-syntax pattern rhs) 30 (let* ([pvar-env (get-match-vars #'define/with-syntax 31 stx 32 #'pattern 33 '())] 34 [depthmap (for/list ([x pvar-env]) 35 (let loop ([x x] [d 0]) 36 (if (pair? x) 37 (loop (car x) (add1 d)) 38 (cons x d))))] 39 [pvars (map car depthmap)] 40 [depths (map cdr depthmap)] 41 [mark (make-syntax-introducer)]) 42 (with-syntax ([(pvar ...) pvars] 43 [(depth ...) depths] 44 [(valvar ...) (generate-temporaries pvars)]) 45 #'(begin (define-values (valvar ...) 46 (with-syntax ([pattern rhs]) 47 (values (pvar-value pvar) ...))) 48 (define-syntax pvar 49 (make-auto-pvar 'depth (quote-syntax valvar))) 50 ... 51 (define-pvars pvar ...))))])) 52 ;; Ryan: alternative name: define/syntax-pattern ?? 53 54 ;; auxiliary macro 55 (define-syntax (pvar-value stx) 56 (syntax-case stx () 57 [(_ pvar) 58 (identifier? #'pvar) 59 (let ([mapping (syntax-local-value #'pvar)]) 60 (unless (syntax-pattern-variable? mapping) 61 (raise-syntax-error #f "not a pattern variable" #'pvar)) 62 (syntax-mapping-valvar mapping))])) 63 64 65 ;; == Disappeared uses == 66 67 (define current-recorded-disappeared-uses (make-parameter #f #f 'current-recorded-disappeared-uses)) 68 69 (define-syntax-rule (with-disappeared-uses body-expr ... stx-expr) 70 (let-values ([(stx disappeared-uses) 71 (parameterize ((current-recorded-disappeared-uses null)) 72 (let ([result (let () body-expr ... stx-expr)]) 73 (values result (current-recorded-disappeared-uses))))]) 74 (syntax-property stx 75 'disappeared-use 76 (append (or (syntax-property stx 'disappeared-use) null) 77 disappeared-uses)))) 78 79 (define (syntax-local-value/record id pred) 80 (unless (identifier? id) 81 (raise-argument-error 'syntax-local-value/record 82 "identifier?" 83 0 id pred)) 84 (unless (and (procedure? pred) 85 (procedure-arity-includes? pred 1)) 86 (raise-argument-error 'syntax-local-value/record 87 "(-> any/c boolean?)" 88 1 id pred)) 89 (let ([value (syntax-local-value id (lambda () #f))]) 90 (and (pred value) 91 (begin (record-disappeared-uses (list id)) 92 value)))) 93 94 (define (record-disappeared-uses ids [intro? (syntax-transforming?)]) 95 (cond 96 [(identifier? ids) (record-disappeared-uses (list ids) intro?)] 97 [(and (list? ids) (andmap identifier? ids)) 98 (let ([uses (current-recorded-disappeared-uses)]) 99 (when uses 100 (current-recorded-disappeared-uses 101 (append 102 (if intro? 103 (map syntax-local-introduce ids) 104 ids) 105 uses))))] 106 [else (raise-argument-error 'record-disappeared-uses 107 "(or/c identifier? (listof identifier?))" 108 ids)])) 109 110 111 ;; == Identifier formatting == 112 113 (define (format-id lctx 114 #:source [src #f] 115 #:props [props #f] 116 #:cert [cert #f] 117 #:subs? [subs? #f] 118 #:subs-intro [subs-intro (default-intro)] 119 fmt . args) 120 (check-restricted-format-string 'format-id fmt) 121 (define arg-strs (map (lambda (a) (->string a 'format-id)) args)) 122 (define str (apply format fmt arg-strs)) 123 (define id (datum->syntax lctx (string->symbol str) src props)) 124 (cond [subs? 125 (syntax-property id 'sub-range-binders 126 (make-subs 'format-id id fmt args arg-strs subs-intro))] 127 [else id])) 128 ;; Eli: This looks very *useful*, but I'd like to see it more convenient to 129 ;; "preserve everything". Maybe add a keyword argument that when #t makes 130 ;; all the others use values lctx, and when syntax makes the others use that 131 ;; syntax? 132 ;; Finally, if you get to add this, then another useful utility in the same 133 ;; spirit is one that concatenates symbols and/or strings and/or identifiers 134 ;; into a new identifier. I considered something like that, which expects a 135 ;; single syntax among its inputs, and will use it for the context etc, or 136 ;; throw an error if there's more or less than 1. 137 138 (define (format-symbol fmt . args) 139 (define (convert x) (->string x 'format-symbol)) 140 (check-restricted-format-string 'format-symbol fmt) 141 (let ([args (map convert args)]) 142 (string->symbol (apply format fmt args)))) 143 144 (define (restricted-format-string? fmt) 145 (regexp-match? #rx"^(?:[^~]|~[aAn~%])*$" fmt)) 146 147 (define (check-restricted-format-string who fmt) 148 (unless (restricted-format-string? fmt) 149 (raise-arguments-error who 150 "format string should have only ~a placeholders" 151 "format string" fmt))) 152 153 (define (make-subs who id fmt args arg-strs intro) 154 (define seglens (restricted-format-string-segment-lengths fmt)) 155 (for/fold ([len 0] [subs null] #:result subs) ;; len is total length so far 156 ([arg (in-list args)] [arg-str (in-list arg-strs)] [seglen (in-list seglens)]) 157 (define len* (+ len seglen)) 158 (values (+ len* (string-length arg-str)) 159 (cond [(identifier? arg) 160 (cons (make-subrange (intro id) (intro arg) 161 len* (string-length arg-str)) 162 subs)] 163 [else subs])))) 164 165 (define (make-subrange new-id old-id start-in-new-id old-id-len) 166 (vector-immutable new-id start-in-new-id old-id-len 0.5 0.5 167 old-id 0 old-id-len 0.5 0.5)) 168 169 (define (restricted-format-string-segment-lengths fmt) 170 ;; Returns (list p1 p2 ...) s.t. the Nth placeholder follows pN characters 171 ;; generated from the format string since the previous placeholder. 172 ;; Example: for "~ax~~ayz~aw~a", want '(0 5 1). 173 ;; PRE: fmt is restricted-format-string. 174 (let loop ([start 0] [since-last 0]) 175 (cond [(regexp-match-positions #rx"~." fmt start) 176 => (lambda (p) 177 (let ([m-start (caar p)] [m-end (cdar p)]) 178 (case (string-ref fmt (add1 m-start)) 179 [(#\a #\A) 180 (cons (+ since-last (- m-start start)) (loop m-end 0))] 181 [else ;; "~[^aA]" produces 1 char 182 (loop (+ since-last (- m-start start) 1))])))] 183 [else null]))) 184 185 (define (default-intro) 186 (if (syntax-transforming?) syntax-local-introduce values)) 187 188 (define (->string x err) 189 (cond [(string? x) x] 190 [(symbol? x) (symbol->string x)] 191 [(identifier? x) (symbol->string (syntax-e x))] 192 [(keyword? x) (keyword->string x)] 193 [(number? x) (number->string x)] 194 [(char? x) (string x)] 195 [else (raise-argument-error err 196 "(or/c string? symbol? identifier? keyword? char? number?)" 197 x)])) 198 199 200 ;; == Error reporting == 201 202 (define current-syntax-context 203 (make-parameter #f 204 (lambda (new-value) 205 (unless (or (syntax? new-value) (eq? new-value #f)) 206 (raise-argument-error 'current-syntax-context 207 "(or/c syntax? #f)" 208 new-value)) 209 new-value) 210 'current-syntax-context)) 211 212 (define (wrong-syntax stx #:extra [extras null] format-string . args) 213 (unless (or (eq? stx #f) (syntax? stx)) 214 (raise-argument-error 'wrong-syntax "(or/c syntax? #f)" 0 (list* stx format-string args))) 215 (let* ([ctx (current-syntax-context)] 216 [blame (and (syntax? ctx) (syntax-property ctx 'report-error-as))]) 217 (raise-syntax-error (if (symbol? blame) blame #f) 218 (apply format format-string args) 219 ctx 220 stx 221 extras))) 222 ;; Eli: The `report-error-as' thing seems arbitrary to me. 223 224 225 ;; == Other utilities == 226 227 ;; generate-temporary : any -> identifier 228 (define (generate-temporary [stx 'g]) 229 (car (generate-temporaries (list stx)))) 230 231 ;; Included for backwards compatibility. 232 (define (internal-definition-context-apply intdefs stx) 233 ; The old implementation of internal-definition-context-apply implicitly converted its stx argument 234 ; to syntax, which some things seem to (possibly unintentionally) rely on, so replicate that 235 ; behavior here: 236 (internal-definition-context-introduce intdefs (datum->syntax #f stx) 'add)) 237 238 (define (syntax-local-eval stx [intdefs '()]) 239 (let* ([name (generate-temporary)] 240 [intdef (syntax-local-make-definition-context)] 241 [all-intdefs (if (list? intdefs) 242 (cons intdef intdefs) 243 (list intdef intdefs))]) 244 (syntax-local-bind-syntaxes (list name) 245 #`(call-with-values (lambda () #,stx) list) 246 intdef 247 intdefs) 248 (apply values 249 (syntax-local-value (for/fold ([name name]) ([intdef all-intdefs]) 250 (internal-definition-context-introduce intdef name 'add)) 251 #f 252 intdef)))) 253 254 (define-syntax (with-syntax* stx) 255 (syntax-case stx () 256 [(_ () body ...) (syntax/loc stx (let () body ...))] 257 [(_ (cl) body ...) (syntax/loc stx (with-syntax (cl) body ...))] 258 [(_ (cl cls ...) body ...) 259 (with-syntax ([with-syntax/rest (syntax/loc stx (with-syntax* (cls ...) body ...))]) 260 (syntax/loc stx (with-syntax (cl) with-syntax/rest)))]))