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