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