resyntax/private/fully-expanded-syntax.rkt at a278b56f2048761d23fe69785cc6b65e1389969c · jackfirth/resyntax · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
#lang racket/base


(require racket/contract/base)


(provide
 (contract-out
  [fully-expanded-syntax-binding-table
   (-> syntax?
       (hash/c (or/c exact-integer? #false)
               (free-id-table/c identifier? (listof identifier?) #:immutable #true)
               #:immutable #true))]
  [fully-expanded-syntax-disappeared-visits
   (-> syntax? (vectorof syntax? #:immutable #true #:flat? #true))]))


(require racket/hash
         racket/list
         racket/match
         racket/set
         racket/treelist
         rebellion/collection/hash
         rebellion/collection/vector/builder
         resyntax/private/syntax-traversal
         syntax/id-table
         syntax/parse)


;@----------------------------------------------------------------------------------------------------


(define (append-all-id-maps id-maps)
  (for/fold ([combined (hash)])
            ([map id-maps])
    (hash-union combined map #:combine treelist-append)))


(define (id-map-shift-phase id-map levels)
  (for/hash ([(phase ids) (in-hash id-map)])
    (values (and phase (+ phase levels)) ids)))


(define-syntax-class (fully-expanded-top-level-form [phase 0])
  #:attributes (bound-ids-by-phase used-ids-by-phase)
  #:literal-sets ((kernel-literals #:phase phase))

  (pattern (~var subform (fully-expanded-general-top-level-form phase))
    #:attr bound-ids-by-phase (attribute subform.bound-ids-by-phase)
    #:attr used-ids-by-phase (attribute subform.used-ids-by-phase))

  (pattern (#%expression (~var subexpr (fully-expanded-expression phase)))
    #:attr bound-ids-by-phase (attribute subexpr.bound-ids-by-phase)
    #:attr used-ids-by-phase (attribute subexpr.used-ids-by-phase))

  (pattern (module :id :module-path
             (#%plain-module-begin (~var body (fully-expanded-module-level-form phase)) ...))
    #:attr bound-ids-by-phase (append-all-id-maps (attribute body.bound-ids-by-phase))
    #:attr used-ids-by-phase (append-all-id-maps (attribute body.used-ids-by-phase)))

  (pattern (begin (~var body (fully-expanded-top-level-form phase)) ...)
    #:attr bound-ids-by-phase (append-all-id-maps (attribute body.bound-ids-by-phase))
    #:attr used-ids-by-phase (append-all-id-maps (attribute body.used-ids-by-phase)))

  (pattern (begin-for-syntax (~var body (fully-expanded-top-level-form (add1 phase))) ...)
    #:attr bound-ids-by-phase (append-all-id-maps (attribute body.bound-ids-by-phase))
    #:attr used-ids-by-phase (append-all-id-maps (attribute body.used-ids-by-phase))))


(define-syntax-class (fully-expanded-module-level-form phase)
  #:attributes (bound-ids-by-phase used-ids-by-phase)
  #:literal-sets ((kernel-literals #:phase phase))

  (pattern (~var subform (fully-expanded-general-top-level-form phase))
    #:attr bound-ids-by-phase (attribute subform.bound-ids-by-phase)
    #:attr used-ids-by-phase (attribute subform.used-ids-by-phase))

  (pattern (#%provide :raw-provide-spec ...)
    #:attr bound-ids-by-phase (hash)
    #:attr used-ids-by-phase (hash))

  (pattern (begin-for-syntax (~var body (fully-expanded-module-level-form (add1 phase))) ...)
    #:attr bound-ids-by-phase (append-all-id-maps (attribute body.bound-ids-by-phase))
    #:attr used-ids-by-phase (append-all-id-maps (attribute body.used-ids-by-phase)))

  (pattern (~var subform (fully-expanded-submodule-form phase))
    #:attr bound-ids-by-phase (attribute subform.bound-ids-by-phase)
    #:attr used-ids-by-phase (attribute subform.used-ids-by-phase))

  (pattern (#%declare _ ...)
    #:attr bound-ids-by-phase (hash)
    #:attr used-ids-by-phase (hash)))


(define-syntax-class (fully-expanded-submodule-form phase)
  #:attributes (bound-ids-by-phase used-ids-by-phase)
  #:literal-sets ((kernel-literals #:phase phase))

  (pattern (module :id :module-path
             (#%plain-module-begin (~var body (fully-expanded-module-level-form phase)) ...))
    #:attr bound-ids-by-phase (append-all-id-maps (attribute body.bound-ids-by-phase))
    #:attr used-ids-by-phase (append-all-id-maps (attribute body.used-ids-by-phase)))

  (pattern (module* :id (~or #false :module-path)
             (#%plain-module-begin (~var body (fully-expanded-module-level-form phase)) ...))
    #:attr bound-ids-by-phase (append-all-id-maps (attribute body.bound-ids-by-phase))
    #:attr used-ids-by-phase (append-all-id-maps (attribute body.used-ids-by-phase))))


(define-syntax-class (fully-expanded-general-top-level-form phase)
  #:attributes (bound-ids-by-phase used-ids-by-phase)
  #:literal-sets ((kernel-literals #:phase phase))

  (pattern (~var subexpr (fully-expanded-expression phase))
    #:attr bound-ids-by-phase (attribute subexpr.bound-ids-by-phase)
    #:attr used-ids-by-phase (attribute subexpr.used-ids-by-phase))

  (pattern (define-values (id:id ...) (~var rhs (fully-expanded-expression phase)))
    #:attr bound-ids-by-phase
    (append-all-id-maps (list (hash phase (list->treelist (attribute id)))
                              (attribute rhs.bound-ids-by-phase)))
    #:attr used-ids-by-phase (attribute rhs.used-ids-by-phase))

  (pattern (define-syntaxes (id:id ...) (~var rhs (fully-expanded-expression (add1 phase))))
    #:attr bound-ids-by-phase
    (append-all-id-maps (list (hash phase (list->treelist (attribute id)))
                              (attribute rhs.bound-ids-by-phase)))
    #:attr used-ids-by-phase (attribute rhs.used-ids-by-phase))

  (pattern (#%require :raw-require-spec ...)
    #:attr bound-ids-by-phase (hash)
    #:attr used-ids-by-phase (hash)))


(define-syntax-class (fully-expanded-expression phase)
  #:attributes (bound-ids-by-phase used-ids-by-phase)
  #:literal-sets ((kernel-literals #:phase phase))

  (pattern id:id
    #:attr bound-ids-by-phase (hash)
    #:attr used-ids-by-phase (hash phase (treelist (attribute id))))

  (pattern (#%plain-lambda (~var formals (fully-expanded-formals phase))
                           (~var body (fully-expanded-expression phase)) ...+)
    #:attr bound-ids-by-phase
    (append-all-id-maps (cons (attribute formals.bound-ids-by-phase)
                              (attribute body.bound-ids-by-phase)))
    #:attr used-ids-by-phase (append-all-id-maps (attribute body.used-ids-by-phase)))

  (pattern (case-lambda
             ((~var formals (fully-expanded-formals phase))
              (~var body (fully-expanded-expression phase)) ...+)
             ...)
    #:attr bound-ids-by-phase
    (append-all-id-maps (append* (attribute formals.bound-ids-by-phase)
                                 (attribute body.bound-ids-by-phase)))
    #:attr used-ids-by-phase (append-all-id-maps (append* (attribute body.used-ids-by-phase))))

  (pattern (if (~var condition (fully-expanded-expression phase))
               (~var true-branch (fully-expanded-expression phase))
               (~var false-branch (fully-expanded-expression phase)))
    #:attr bound-ids-by-phase
    (append-all-id-maps
     (list (attribute condition.bound-ids-by-phase)
           (attribute true-branch.bound-ids-by-phase)
           (attribute false-branch.bound-ids-by-phase)))
    #:attr used-ids-by-phase
    (append-all-id-maps
     (list (attribute condition.used-ids-by-phase)
           (attribute true-branch.used-ids-by-phase)
           (attribute false-branch.used-ids-by-phase))))

  (pattern (begin (~var body (fully-expanded-expression phase)) ...+)
    #:attr bound-ids-by-phase (append-all-id-maps (attribute body.bound-ids-by-phase))
    #:attr used-ids-by-phase (append-all-id-maps (attribute body.used-ids-by-phase)))

  (pattern (begin0 (~var result (fully-expanded-expression phase))
             (~var post-body (fully-expanded-expression phase)) ...)
    #:attr bound-ids-by-phase
    (append-all-id-maps
     (cons (attribute result.bound-ids-by-phase) (attribute post-body.bound-ids-by-phase)))
    #:attr used-ids-by-phase
    (append-all-id-maps
     (cons (attribute result.used-ids-by-phase) (attribute post-body.used-ids-by-phase))))

  (pattern (let-values ([(id:id ...) (~var rhs (fully-expanded-expression phase))] ...)
             (~var body (fully-expanded-expression phase)) ...+)
    #:do [(define immediately-bound-ids (list->treelist (append* (attribute id))))]
    #:attr bound-ids-by-phase
    (append-all-id-maps
     (append (list (hash phase immediately-bound-ids))
             (attribute rhs.bound-ids-by-phase)
             (attribute body.bound-ids-by-phase)))
    #:attr used-ids-by-phase
    (append-all-id-maps
     (append (attribute rhs.used-ids-by-phase) (attribute body.used-ids-by-phase))))

  (pattern (letrec-values ([(id:id ...) (~var rhs (fully-expanded-expression phase))] ...)
             (~var body (fully-expanded-expression phase)) ...+)
    #:do [(define immediately-bound-ids (list->treelist (append* (attribute id))))]
    #:attr bound-ids-by-phase
    (append-all-id-maps
     (append (list (hash phase immediately-bound-ids))
             (attribute rhs.bound-ids-by-phase)
             (attribute body.bound-ids-by-phase)))
    #:attr used-ids-by-phase
    (append-all-id-maps
     (append (attribute rhs.used-ids-by-phase) (attribute body.used-ids-by-phase))))

  (pattern (set! id:id (~var rhs (fully-expanded-expression phase)))
    #:attr bound-ids-by-phase (attribute rhs.bound-ids-by-phase)
    #:attr used-ids-by-phase
    (append-all-id-maps
     (list (hash phase (treelist (attribute id))) (attribute rhs.used-ids-by-phase))))

  (pattern (quote _)
    #:attr bound-ids-by-phase (hash)
    #:attr used-ids-by-phase (hash))

  (pattern (quote-syntax _)
    #:attr bound-ids-by-phase (hash)
    #:attr used-ids-by-phase (hash))

  (pattern (quote-syntax _ #:local)
    #:attr bound-ids-by-phase (hash)
    #:attr used-ids-by-phase (hash))

  (pattern (with-continuation-mark
               (~var key (fully-expanded-expression phase))
             (~var value (fully-expanded-expression phase))
             (~var result (fully-expanded-expression phase)))
    #:attr bound-ids-by-phase
    (append-all-id-maps
     (list (attribute key.bound-ids-by-phase)
           (attribute value.bound-ids-by-phase)
           (attribute result.bound-ids-by-phase)))
    #:attr used-ids-by-phase
    (append-all-id-maps
     (list (attribute key.used-ids-by-phase)
           (attribute value.used-ids-by-phase)
           (attribute result.used-ids-by-phase))))

  (pattern (#%plain-app (~var subexpr (fully-expanded-expression phase)) ...+)
    #:attr bound-ids-by-phase (append-all-id-maps (attribute subexpr.bound-ids-by-phase))
    #:attr used-ids-by-phase (append-all-id-maps (attribute subexpr.used-ids-by-phase)))

  (pattern (#%top . id:id)
    #:attr bound-ids-by-phase (hash)
    #:attr used-ids-by-phase (hash phase (treelist (attribute id))))

  (pattern (#%variable-reference id:id)
    #:attr bound-ids-by-phase (hash)
    #:attr used-ids-by-phase (hash phase (treelist (attribute id))))

  (pattern (#%variable-reference (#%top . id:id))
    #:attr bound-ids-by-phase (hash)
    #:attr used-ids-by-phase (hash phase (treelist (attribute id))))

  (pattern (#%variable-reference)
    #:attr bound-ids-by-phase (hash)
    #:attr used-ids-by-phase (hash)))


(define-syntax-class (fully-expanded-formals phase)
  #:attributes (bound-ids-by-phase used-ids-by-phase)

  (pattern (id:id ...)
    #:attr bound-ids-by-phase (hash phase (list->treelist (attribute id)))
    #:attr used-ids-by-phase (hash))

  (pattern (id:id ...+ . rest-id:id)
    #:attr bound-ids-by-phase (hash phase (list->treelist (attribute id)))
    #:attr used-ids-by-phase (hash))

  (pattern id:id
    #:attr bound-ids-by-phase (hash phase (treelist (attribute id)))
    #:attr used-ids-by-phase (hash)))


(define-syntax-class module-path
  (pattern _))


(define-syntax-class raw-require-spec
  (pattern _))


(define-syntax-class raw-provide-spec
  (pattern _))


(define (phase-binding-table bound-ids used-ids #:phase phase)
  (for*/fold ([map (make-immutable-free-id-table #:phase phase)])
             ([bound bound-ids]
              [used used-ids]
              #:when (free-identifier=? bound used))
    (free-id-table-update map bound (λ (previous) (cons used previous)) '())))


(define (identifier-binding-table bound-ids-by-phase used-ids-by-phase)
  (for/hash
      ([phase
        (in-set (set-union (hash-key-set bound-ids-by-phase) (hash-key-set used-ids-by-phase)))])
    (define bound-ids (hash-ref bound-ids-by-phase phase '()))
    (define used-ids (hash-ref used-ids-by-phase phase '()))
    (values phase (phase-binding-table bound-ids used-ids #:phase phase))))


(define (fully-expanded-syntax-binding-table stx)
  (syntax-parse stx
    [:fully-expanded-top-level-form
     (identifier-binding-table (attribute bound-ids-by-phase) (attribute used-ids-by-phase))]))


(define (fully-expanded-syntax-disappeared-visits stx)
  (define builder (make-vector-builder))
  (let loop ([stx stx])
    (syntax-traverse stx
      [form
       #:when (syntax-property #'form 'disappeared-visit)
       (vector-builder-add-cons-tree builder (syntax-property #'form 'disappeared-visit))
       (loop (syntax-property #'form 'disappeared-visit #false))]))
  (build-vector builder))


(define (vector-builder-add-cons-tree builder cons-tree)
  (match cons-tree
    [(cons left right)
     (vector-builder-add-cons-tree builder left)
     (vector-builder-add-cons-tree builder right)]
    ['() builder]
    [_
     (vector-builder-add builder cons-tree)]))