1#lang racket/base
2(require (for-syntax racket/base
3                     syntax/define
4                     syntax/boundmap
5                     racket/pretty))
6
7(provide define-package
8         package-begin
9
10         open-package
11         open*-package
12
13         define*
14         define*-values
15         define*-syntax
16         define*-syntaxes
17
18         (for-syntax package?
19                     package-exported-identifiers
20                     package-original-identifiers))
21
22
23;; For permission to move scopes from a definition in a package
24;; to a binding of the identifier when the package is opened:
25(define-for-syntax code-insp
26  (variable-reference->module-declaration-inspector
27   (#%variable-reference)))
28
29;; ----------------------------------------
30
31(begin-for-syntax
32  (struct package (root-id sig-ids impl-ids))
33
34  (define (get-package who id)
35    (let ([p (syntax-local-value id (lambda () #f))])
36      (unless (package? p)
37        (error who
38               "not defined as a package\n  identifier: ~a"
39               id))))
40
41  (define (package-exported-identifiers id)
42    (define p (get-package 'package-exported-identifiers id))
43    (map
44     (lambda (sig-id)
45       (make-syntax-delta-introducer sig-id (package-root-id p))
46       (datum->syntax id (syntax-e sig-id) sig-id sig-id))
47     (syntax->list (package-sig-ids p))))
48
49  (define (package-original-identifiers id)
50    (define p (get-package 'package-original-identifiers id))
51    (syntax->list (package-impl-ids p))))
52
53(define-syntax (define-package stx)
54  (check-definition-context stx)
55  (syntax-case stx ()
56    [(_ id . _)
57     (let ([id #'id])
58       (unless (identifier? id)
59         (raise-syntax-error #f
60                             "expected an identifier for the package name"
61                             stx
62                             id))
63       (define (accumulate exports forms)
64         (define intro (make-syntax-introducer #t))
65         #`(drive-top-level
66            (accumulate-package #,id #,(intro id) #,(intro id) #f #,stx
67                                #,exports
68                                ()
69                                #,(intro forms))))
70       (syntax-case stx ()
71         [(_ _ #:only (export-id ...) form ...)
72          (accumulate #'(#:only (export-id ...)) #'(form ...))]
73         [(_ _ #:all-defined-except (export-id ...) form ...)
74          (accumulate #'(#:all-defined-except (export-id ...)) #'(form ...))]
75         [(_ _ #:all-defined form ...)
76          (accumulate #'(#:all-defined-except ()) #'(form ...))]
77         [(_ _ (export-id ...) form ...)
78          (accumulate #'(#:only (export-id ...)) #'(form ...))]))]))
79
80(define-syntax (accumulate-package stx)
81  (syntax-case stx ()
82    [(_ id intro-id star-id any-stars? orig-form exports defined-ids (form . forms))
83     (let ([exp-form (local-expand #'form
84                                   (list (gensym))
85                                   (list #'define-values
86                                         #'-define*-values
87                                         #'define-syntaxes
88                                         #'-define*-syntaxes
89                                         #'begin)
90                                   #f)])
91       (syntax-case exp-form (begin)
92         [(begin seq-form ...)
93          #`(accumulate-package id intro-id star-id any-stars? orig-form
94                                exports
95                                defined-ids
96                                (seq-form ... . forms))]
97         [(def (new-def-id ...) rhs)
98          (or (free-identifier=? #'def #'define-values)
99              (free-identifier=? #'def #'define-syntaxes)
100              (free-identifier=? #'def #'-define*-values)
101              (free-identifier=? #'def #'-define*-syntaxes))
102          (let* ([star? (or (free-identifier=? #'def #'-define*-values)
103                            (free-identifier=? #'def #'-define*-syntaxes))]
104                 [next-intro (if star?
105                                 (make-syntax-introducer #t)
106                                 (lambda (s) s))]
107                 [exp-form
108                  (with-syntax ([(new-def-id ...) (if star?
109                                                      ;; Add another scope layer:
110                                                      (next-intro #'(new-def-id ...))
111                                                      ;; Remove star layers:
112                                                      ((make-syntax-delta-introducer #'star-id #'intro-id)
113                                                       #'(new-def-id ...)
114                                                       'remove))])
115                    (syntax/loc exp-form
116                      (def (new-def-id ...) rhs)))])
117            (with-syntax ([(_ (new-def-id ...) _) exp-form]) ; sync with above adjustments to `new-def-id`
118              (when (and (not star?)
119                         (syntax-e #'any-stars?))
120                ;; Make sure that a name is not defined with `define` if
121                ;; there's a preceeding `define*`
122                (let ([intro (make-syntax-delta-introducer #'star-id #'intro-id)])
123                  (for ([id (in-list (syntax->list #'(new-def-id ...)))])
124                    (unless (free-identifier=? id (intro id))
125                      (raise-syntax-error #f
126                                          "duplicate definition for identifier"
127                                          #'orig-form
128                                          id)))))
129              ;; Let definition out of `accumulate-package` form, accumulate new
130              ;; defintions, and continue with the rest of the package body:
131              (with-syntax ([forms (next-intro #'forms)]
132                            [star-id (next-intro #'star-id)]
133                            [any-stars? (or star? (syntax-e #'any-stars?))])
134                #`(begin
135                    #,exp-form
136                    (accumulate-package id intro-id star-id any-stars? orig-form
137                                        exports
138                                        (new-def-id ... . defined-ids)
139                                        forms)))))]
140         [_
141          (and (not (syntax-e #'id))
142               (null? (syntax-e #'forms)))
143          ;; Allow last expression to produce a result for `package-begin`
144          exp-form]
145         [_
146          #`(begin
147              (begin0 (void) #,exp-form)
148              (accumulate-package id intro-id star-id any-stars? orig-form
149                                  exports
150                                  defined-ids
151                                  forms))]))]
152    [(_ #f #f #f _ orig-form exports defined-ids ())
153     ;; Last thing in `begin-package` was a definition; add a `(void)`
154     #'(void)]
155    [(_ id intro-id star-id any-stars? orig-form exports defined-ids ())
156     (let ()
157       (define (find-ids ids keep?)
158         (define intro (make-syntax-delta-introducer #'star-id #'id))
159         (let ([ids (syntax->list ids)]
160               [defined-ids (syntax->list #'defined-ids)])
161           (define defined-bindings (make-bound-identifier-mapping))
162           ;; `defined-ids` were accumulated in reverse order; add them
163           ;; in the original order, so that we end up with the last
164           ;; definition of each equilavent id (in the case of `define*`s
165           (for-each
166            (lambda (defined-id)
167              (bound-identifier-mapping-put! defined-bindings
168                                             (syntax-local-identifier-as-binding
169                                              (intro defined-id 'remove))
170                                             defined-id))
171            (reverse defined-ids))
172           ;; Check that each explicitly named `id` is defined:
173           (define mentioned-ids (make-bound-identifier-mapping))
174           (for-each (lambda (id)
175                       (define bind-id (syntax-local-identifier-as-binding
176                                        id))
177                       (unless (bound-identifier-mapping-get defined-bindings
178                                                             bind-id
179                                                             (lambda () #f))
180                         (raise-syntax-error #f
181                                             "identifier not defined within the package"
182                                             #'orig-form
183                                             id))
184                       (bound-identifier-mapping-put! mentioned-ids
185                                                      bind-id
186                                                      #t))
187                     ids)
188           ;; Get identifiers that should be exported:
189           (filter
190            values
191            (bound-identifier-mapping-map
192             defined-bindings
193             (lambda (bind-id defined-id)
194               (and (keep? (bound-identifier-mapping-get mentioned-ids bind-id
195                                                         (lambda () #f)))
196                    (cons bind-id
197                          defined-id)))))))
198       (define mapping
199         (syntax-case #'exports ()
200           [(#:only (id ...))
201            (find-ids #'(id ...) values)]
202           [(#:all-defined-except (id ...))
203            (find-ids #'(id ...) not)]))
204       (cond
205        [(not (syntax-e #'id))
206         #'(begin)]
207        [else
208         #`(define-syntax id (package (quote-syntax star-id)
209                                      (quote-syntax #,(map car mapping))
210                                      (quote-syntax #,(map cdr mapping))))]))]))
211
212(define-for-syntax (do-open-package stx def-stxes)
213  (check-definition-context stx)
214  (syntax-case stx ()
215    [(_ id)
216     (let ([id #'id])
217       (unless (identifier? id)
218         (raise-syntax-error #f
219                             "not an identifier for a package to open"
220                             stx
221                             id))
222       (let ([p (syntax-local-value id (lambda () #f))])
223         (unless (package? p)
224           (raise-syntax-error #f
225                               "not defined as a package"
226                               stx
227                               id))
228         (define (locally sig-id)
229           (define local-id
230             ((make-syntax-delta-introducer (syntax-disarm sig-id code-insp) (package-root-id p))
231              (datum->syntax (syntax-disarm id code-insp) (syntax-e sig-id) sig-id sig-id)))
232           (syntax-rearm (syntax-rearm local-id sig-id) id))
233         #`(begin
234             #,@(map (lambda (sig-id impl-id)
235                       #`(#,def-stxes (#,(locally sig-id))
236                           (make-rename-transformer (quote-syntax #,impl-id))))
237                     (syntax->list (package-sig-ids p))
238                     (syntax->list (syntax-local-introduce (package-impl-ids p)))))))]))
239
240(define-syntax (open-package stx)
241  (do-open-package stx #'define-syntaxes))
242(define-syntax (open*-package stx)
243  (do-open-package stx #'define*-syntaxes))
244
245(define-syntax (package-begin stx)
246  (if (eq? 'expression (syntax-local-context))
247      #`(let () #,stx)
248      (syntax-case stx ()
249        [(_ form ...)
250         #`(drive-top-level
251            (accumulate-package #f id id #f #,stx
252                                (#:only ())
253                                ()
254                                #,((make-syntax-introducer)
255                                   #'(form ...))))])))
256
257(define-for-syntax (check-definition-context stx)
258  (when (eq? 'expression (syntax-local-context))
259    (raise-syntax-error #f
260                        "not in a definition context"
261                        stx)))
262
263;; ----------------------------------------
264
265(define-syntax (drive-top-level stx)
266  (syntax-case stx ()
267    [(_ form)
268     (cond
269      [(eq? 'top-level (syntax-local-context))
270       ;; In a opt-level context, we need to use the `(define-syntaxes
271       ;; (...) (values))` trick to introduce all defined names before
272       ;; expanding expressions.
273       #'(accumulate-top-level () (form))]
274      [else
275       ;; No special treatment needed:
276       #'form])]))
277
278(define-syntax (accumulate-top-level stx)
279  (syntax-case stx ()
280    [(_ exp-forms ())
281     #`(begin
282         #,@(reverse (syntax->list #'exp-forms)))]
283    [(_ exp-forms (form . forms))
284     (let ([exp-form (local-expand #'form
285                                   (list (gensym))
286                                   (list #'define-values
287                                         #'define-syntaxes
288                                         #'begin)
289                                   #f)])
290       (syntax-case exp-form (begin define-values define-syntaxes)
291         [(begin form ...)
292          #'(accumulate-top-level exp-forms (form ... . forms))]
293         [(define-values (new-def-id ...) rhs)
294          #`(begin
295              (define-syntaxes (new-def-id ...) (values))
296              (accumulate-top-level (#,exp-form . exp-forms)
297                                    forms))]
298         [(define-syntaxes . _)
299          #`(begin
300              #,exp-form
301              (accumulate-top-level exp-forms forms))]
302         [_
303          #`(accumulate-top-level (#,exp-form . exp-forms) forms)]))]))
304
305;; ----------------------------------------
306
307(define-for-syntax (do-define-* stx define-values-id)
308  (syntax-case stx ()
309    [(_ (id ...) rhs)
310     (let ([ids (syntax->list #'(id ...))])
311       (for-each (lambda (id)
312                   (unless (identifier? id)
313                     (raise-syntax-error
314                      #f
315                      "expected an identifier for definition"
316                      stx
317                      id)))
318                 ids)
319       (with-syntax ([define-values define-values-id])
320         (syntax/loc stx
321           (define-values (id ...) rhs))))]))
322(define-syntax (-define*-values stx)
323  (do-define-* stx #'define-values))
324(define-syntax (-define*-syntaxes stx)
325  (do-define-* stx #'define-syntaxes))
326(define-syntax (define*-values stx)
327  (syntax-case stx ()
328    [(_ (id ...) rhs)
329     (syntax-property
330      (syntax/loc stx (-define*-values (id ...) rhs))
331      'certify-mode
332      'transparent-binding)]))
333(define-syntax (define*-syntaxes stx)
334  (syntax-case stx ()
335    [(_ (id ...) rhs)
336     (syntax-property
337      (syntax/loc stx (-define*-syntaxes (id ...) rhs))
338      'certify-mode
339      'transparent-binding)]))
340
341(define-syntax (define* stx)
342  (let-values ([(id rhs) (normalize-definition stx #'lambda)])
343    (quasisyntax/loc stx
344      (define*-values (#,id) #,rhs))))
345(define-syntax (define*-syntax stx)
346  (let-values ([(id rhs) (normalize-definition stx #'lambda)])
347    (quasisyntax/loc stx
348      (define*-syntaxes (#,id) #,rhs))))
349