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