1(module require-transform '#%kernel
2  (#%require "private/stxcase-scheme.rkt"
3             "private/stx.rkt"
4             "private/define-struct.rkt"
5             "private/define-et-al.rkt"
6             "private/qq-and-or.rkt"
7             "private/cond.rkt"
8             "private/define.rkt"
9             "phase+space.rkt"
10             (for-template (only '#%kernel quote))
11             (for-syntax '#%kernel))
12
13  (#%provide expand-import
14             current-require-module-path convert-relative-module-path
15             syntax-local-require-certifier
16             make-require-transformer prop:require-transformer require-transformer?
17             ;; the import struct type:
18             import struct:import make-import import?
19             import-local-id import-src-sym import-src-mod-path import-orig-stx import-mode import-req-mode import-orig-mode
20             ;; the import-source struct type:
21             import-source struct:import-source make-import-source import-source?
22             import-source-mod-path-stx import-source-mode)
23
24  (define-struct* import (local-id src-sym src-mod-path mode req-mode orig-mode orig-stx)
25    #:guard (lambda (i s path mode req-mode orig-mode stx info)
26              (unless (identifier? i)
27                (raise-argument-error 'make-import "identifier?" i))
28              (unless (symbol? s)
29                (raise-argument-error 'make-import "symbol?" s))
30              (unless (or (module-path? path)
31                          (and (syntax? path)
32                               (module-path? (syntax->datum path))))
33                (raise-argument-error 'make-import "(or/c module-path? module-path-syntax?)" path))
34              (unless (phase+space? mode)
35                (raise-argument-error 'make-import "phase+space?" mode))
36              (unless (phase+space-shift? req-mode)
37                (raise-argument-error 'make-import "phase+space-shift?" req-mode))
38              (unless (phase+space? orig-mode)
39                (raise-argument-error 'make-import "phase+space?" orig-mode))
40              (unless (equal? mode (phase+space+ orig-mode req-mode))
41                (raise-arguments-error 'make-import
42                                       "original mode and require mode not consistent with mode"
43                                       "original mode" orig-mode
44                                       "require mode" req-mode
45                                       "mode" mode))
46              (unless (syntax? stx)
47                (raise-argument-error 'make-import "syntax?" stx))
48              (values i s path mode req-mode orig-mode stx)))
49
50  (define-struct* import-source (mod-path-stx mode)
51    #:guard (lambda (path mode info)
52              (unless (and (syntax? path)
53                           (module-path? (syntax->datum path)))
54                (raise-argument-error 'make-import-source "(and/c syntax? (lambda (s) (module-path? (syntax->datum s))))" path))
55              (unless (phase+space-shift? mode)
56                (raise-argument-error 'make-import-source "phase+space-shift?" mode))
57              (values path mode)))
58
59  (define-values (prop:require-transformer require-transformer? require-transformer-get-proc)
60    (make-struct-type-property 'require-transformer))
61
62  (define-struct* rt (proc)
63    #:property prop:require-transformer (lambda (t) (rt-proc t)))
64
65  (define (make-require-transformer proc)
66    (make-rt proc))
67
68  ;; For backward compatibility:
69  (define (syntax-local-require-certifier)
70    (case-lambda
71     [(v) v]
72     [(v mark) v]))
73
74  (define orig-insp (variable-reference->module-declaration-inspector
75                     (#%variable-reference)))
76
77  (define current-require-module-path
78    (make-parameter #f
79                    (lambda (v)
80                      (unless (or (not v)
81                                  (module-path-index? v))
82                        (raise-argument-error 'current-require-module-path
83                                              "(or/c module-path-index? #f)"
84                                              v))
85                      v)
86                    'current-require-module-path))
87
88  ;; a simplified version of `collapse-module-path-index', where
89  ;; we don't have to normalize:
90  (define (collapse-mpi mpi)
91    (define-values (a b) (module-path-index-split mpi))
92    (define (recur b)
93      (cond
94       [(not b) (collapse-mpi (module-path-index-join #f #f))]
95       [(resolved-module-path? b)
96        (let ([n (resolved-module-path-name b)])
97          (if (pair? n)
98              (cons 'submod n)
99              n))]
100       [else (collapse-mpi b)]))
101    (define (extract-root bc)
102      (if (and (pair? bc) (eq? 'submod (car bc)))
103          (cadr bc)
104          bc))
105    (define (replace-last s a)
106      ;; replace last path element, and also eliminate "." and "..":
107      (regexp-replace* #rx"(?<=^|/)[.]/"
108                       (regexp-replace* #rx"(?<=^|/)[-+_%a-zA-Z0-9]*/[.][.]/"
109                                        (regexp-replace #rx"[^/]*$" s a)
110                                        "")
111                       ""))
112    (define (string->path* s)
113      ;; for now, module-path strings all works as paths
114      (string->path s))
115    (cond
116     [(and (not a) (not b))
117      (build-path (or (current-load-relative-directory)
118                      (current-directory))
119                  "here.rkt")]
120     [(path? a) a]
121     [(symbol? a) a]
122     [(string? a)
123      (define bc (extract-root (recur b)))
124      (let loop ([bc bc])
125        (cond
126         [(path? bc)
127          (define-values (base name dir?) (split-path bc))
128          (if (eq? base 'relative)
129              (string->path* a)
130              (build-path base (string->path* a)))]
131         [(symbol? bc)
132          (loop `(lib ,(symbol->string bc)))]
133         [(eq? (car bc) 'quote)
134          (build-path (or (current-load-relative-directory)
135                          (current-directory))
136                      (string->path* a))]
137         [(eq? (car bc) 'file)
138          (loop (string->path (cadr bc)))]
139         [(eq? (car bc) 'lib)
140          (cond
141           [(and (null? (cddr bc))
142                 (regexp-match? #rx"[/]" (cadr bc)))
143            `(lib ,(replace-last (cadr bc) a))]
144           [(and (null? (cddr bc))
145                 (not (regexp-match? #rx"[/.]" (cadr bc))))
146            (loop `(lib ,(string-append (cadr bc) "/main.rkt")))]
147           [(and (null? (cddr bc))
148                 (not (regexp-match? #rx"[/]" (cadr bc))))
149            (loop `(lib ,(string-append "mzlib/" (cadr bc))))]
150           [else
151            (loop `(lib ,(apply
152                          string-append
153                          (let loop ([l (cddr bc)])
154                            (if (null? l)
155                                (list (cadr bc))
156                                (list* (car l) "/" (loop (cdr l))))))))])]
157         [(eq? (car bc) 'planet)
158          (cond
159           [(symbol? (cadr bc))
160            (loop `(planet ,(symbol->string (cadr bc))))]
161           [(null? (cddr bc))
162            (define s (cadr bc))
163            (cond
164             [(regexp-match? #rx"/.*/" s)
165              `(planet ,(replace-last s a))]
166             [else
167              `(planet ,(string-append s "/" a))])]
168           [else
169            (define s (cadr bc))
170            `(planet ,(if (regexp-match? #rx"/" s)
171                          (replace-last s a)
172                          a)
173                     ,@(cddr bc))])]
174         [else (error "collapse-mpi failed on recur shape: " bc)]))]
175     [(eq? (car a) 'submod)
176      (define (add bc l)
177        (if (and (pair? bc) (eq? 'submod (car bc)))
178            (append bc l)
179            (list* 'submod bc l)))
180      (cond
181       [(equal? (cadr a) ".")
182        (add (recur b) (cddr a))]
183       [(equal? (cadr a) "..")
184        (add (recur b) (cdr a))]
185       [else
186        (add (collapse-mpi (module-path-index-join (cadr a) b))
187             (cddr a))])]
188     [else a]))
189
190  (define (convert-relative-module-path mp/stx)
191    (define rmp (current-require-module-path))
192    (cond
193     [(not rmp) mp/stx]
194     [else
195      (define mp (if (syntax? mp/stx)
196                     (syntax->datum mp/stx)
197                     mp/stx))
198      (define (d->s d)
199        (if (syntax? mp/stx)
200            (datum->syntax mp/stx d mp/stx mp/stx)
201            d))
202      (cond
203       [(not (module-path? mp)) mp/stx]
204       [(string? mp)
205        ;; collapse a relative reference to an absolute one:
206        (d->s (collapse-mpi (module-path-index-join mp rmp)))]
207       [(symbol? mp) mp/stx]
208       [(eq? (car mp) 'quote)
209        ;; maybe a submodule...
210        (define r (module-path-index-resolve rmp))
211        (if (module-declared? (append '(submod)
212                                      (if (list? r)
213                                          r
214                                          (list r))
215                                      (cddr mp))
216                              #t)
217            ;; Yes, a submodule:
218            (let ([rmp-mod (collapse-mpi rmp)])
219              (if (and (pair? rmp-mod)
220                       (eq? (car rmp-mod) 'submod))
221                  (d->s (append rmp-mod (cadr mp)))
222                  (d->s `(submod ,rmp-mod . ,(cddr mp)))))
223            mp/stx)]
224       [(eq? (car mp) 'file)
225        (define base-path (resolved-module-path-name
226                           (module-path-index-resolve rmp)))
227        (define path (if (pair? base-path)
228                         (car base-path)
229                         base-path))
230        (if (path? path)
231            (let-values ([(base name dir?) (split-path path)])
232              (if (eq? base 'relative)
233                  mp/stx
234                  (d->s (build-path base (cadr mp)))))
235            mp/stx)]
236       [(eq? (car mp) 'submod)
237        (define sub/stx (if (syntax? mp/stx)
238                            (syntax-case mp/stx ()
239                              [(_ sub . _) #'sub])
240                            (cadr mp)))
241        (define sub (if (syntax? sub/stx) (syntax->datum sub/stx) sub/stx))
242        (define new-sub/stx
243          (cond
244           [(equal? sub ".") (d->s (collapse-mpi rmp))]
245           [(equal? sub "..")
246            (define old (collapse-mpi rmp))
247            (if (and (pair? old)
248                     (eq? (car old) 'submod))
249                (d->s (append old ".."))
250                sub/stx)]
251           [else
252            (convert-relative-module-path sub/stx)]))
253        (cond
254         [(eq? sub/stx new-sub/stx) mp/stx]
255         [else
256          (define new-sub (if (syntax? new-sub/stx)
257                              (syntax->datum new-sub/stx)
258                              new-sub/stx))
259          (if (and (pair? new-sub)
260                   (eq? (car new-sub) 'submod))
261              (d->s (append new-sub (cddr sub)))
262              (d->s `(submod ,new-sub/stx . ,(cddr sub))))])]
263       [else mp/stx])]))
264
265  ;; expand-import : stx bool -> (listof import)
266  (define (expand-import stx)
267    (let ([disarmed-stx (syntax-disarm stx orig-insp)])
268      (syntax-case disarmed-stx ()
269        [simple
270         (or (identifier? #'simple)
271             (string? (syntax-e #'simple))
272             (syntax-case stx (quote)
273               [(quote s) #t]
274               [_ #f]))
275         (let ([mod-path
276                (if (pair? (syntax-e #'simple))
277                    `(quote . ,(cdr (syntax->datum #'simple)))
278                    (syntax->datum #'simple))])
279           (unless (module-path? mod-path)
280             (raise-syntax-error
281              #f
282              "invalid module-path form"
283              stx))
284           (let* ([mod-path (convert-relative-module-path mod-path)]
285                  [namess (syntax-local-module-exports mod-path)])
286             (values
287              (apply
288               append
289               (map (lambda (names)
290                      (let ([mode (car names)])
291                        (map (lambda (name)
292                               (make-import (datum->syntax
293                                             stx
294                                             name
295                                             stx)
296                                            name
297                                            (if (equal? (syntax->datum #'simple) mod-path)
298                                                #'simple
299                                                mod-path)
300                                            mode
301                                            0
302                                            mode
303                                            stx))
304                             (cdr names))))
305                    namess))
306              (list (make-import-source (if (equal? (syntax->datum #'simple) mod-path)
307                                            #'simple
308                                            (datum->syntax #'simple mod-path #'simple))
309                                        0)))))]
310        [(id . rest)
311         (identifier? #'id)
312         (let ([t (syntax-local-value #'id (lambda () #f))])
313           (if (require-transformer? t)
314               (call-with-values
315                   (lambda ()
316                     (((require-transformer-get-proc t) t) disarmed-stx))
317                 (case-lambda
318                  [(v mods)
319                   (unless (and (list? v)
320                                (andmap import? v))
321                     (raise-syntax-error
322                      #f
323                      "first result from require transformer is not a list of imports"
324                      stx))
325                   (unless (and (list? mods)
326                                (andmap import-source? mods))
327                     (raise-syntax-error
328                      #f
329                      "second result from require transformer is not a list of import-sources"
330                      stx))
331                   (values v mods)]
332                  [args
333                   (raise-syntax-error
334                    #f
335                    (format "require transformer produced ~a result~a instead of 2"
336                            (length args)
337                            (if (= 1 (length args)) "" "s"))
338                    stx)]))
339               (raise-syntax-error
340                #f
341                "not a require sub-form"
342                stx)))]
343        [_
344         (raise-syntax-error
345          #f
346          "bad syntax for require sub-form"
347          stx)]))))
348