348 lines
14 KiB
Racket
348 lines
14 KiB
Racket
(module require-transform '#%kernel
|
|
(#%require "private/stxcase-scheme.rkt"
|
|
"private/stx.rkt"
|
|
"private/define-struct.rkt"
|
|
"private/small-scheme.rkt"
|
|
"private/define.rkt"
|
|
(for-template (only '#%kernel quote))
|
|
(for-syntax '#%kernel))
|
|
|
|
(#%provide expand-import
|
|
current-require-module-path convert-relative-module-path
|
|
syntax-local-require-certifier
|
|
make-require-transformer prop:require-transformer require-transformer?
|
|
;; the import struct type:
|
|
import struct:import make-import import?
|
|
import-local-id import-src-sym import-src-mod-path import-orig-stx import-mode import-req-mode import-orig-mode
|
|
;; the import-source struct type:
|
|
import-source struct:import-source make-import-source import-source?
|
|
import-source-mod-path-stx import-source-mode)
|
|
|
|
(define-struct* import (local-id src-sym src-mod-path mode req-mode orig-mode orig-stx)
|
|
#:guard (lambda (i s path mode req-mode orig-mode stx info)
|
|
(unless (identifier? i)
|
|
(raise-argument-error 'make-import "identifier?" i))
|
|
(unless (symbol? s)
|
|
(raise-argument-error 'make-import "symbol?" s))
|
|
(unless (or (module-path? path)
|
|
(and (syntax? path)
|
|
(module-path? (syntax->datum path))))
|
|
(raise-argument-error 'make-import "(or/c module-path? module-path-syntax?)" path))
|
|
(unless (or (not mode)
|
|
(exact-integer? mode))
|
|
(raise-argument-error 'make-import "(or/c exact-integer? #f)" mode))
|
|
(unless (or (not req-mode)
|
|
(exact-integer? req-mode))
|
|
(raise-argument-error 'make-import "(or/c exact-integer? #f)" req-mode))
|
|
(unless (or (not orig-mode)
|
|
(exact-integer? orig-mode))
|
|
(raise-argument-error 'make-import "(or/c exact-integer? #f)" orig-mode))
|
|
(unless (equal? mode (and req-mode orig-mode (+ req-mode orig-mode)))
|
|
(raise-arguments-error 'make-import
|
|
"original mode and require mode not consistent with mode"
|
|
"original mode" orig-mode
|
|
"require mode" req-mode
|
|
"mode" mode))
|
|
(unless (syntax? stx)
|
|
(raise-argument-error 'make-import "syntax?" stx))
|
|
(values i s path mode req-mode orig-mode stx)))
|
|
|
|
(define-struct* import-source (mod-path-stx mode)
|
|
#:guard (lambda (path mode info)
|
|
(unless (and (syntax? path)
|
|
(module-path? (syntax->datum path)))
|
|
(raise-argument-error 'make-import-source "(and/c syntax? (lambda (s) (module-path? (syntax->datum s))))" path))
|
|
(unless (or (not mode)
|
|
(exact-integer? mode))
|
|
(raise-argument-error 'make-import-source "(or/c exact-integer? #f)" mode))
|
|
(values path mode)))
|
|
|
|
(define-values (prop:require-transformer require-transformer? require-transformer-get-proc)
|
|
(make-struct-type-property 'require-transformer))
|
|
|
|
(define-struct* rt (proc)
|
|
#:property prop:require-transformer (lambda (t) (rt-proc t)))
|
|
|
|
(define (make-require-transformer proc)
|
|
(make-rt proc))
|
|
|
|
;; For backward compatibility:
|
|
(define (syntax-local-require-certifier)
|
|
(case-lambda
|
|
[(v) v]
|
|
[(v mark) v]))
|
|
|
|
(define orig-insp (variable-reference->module-declaration-inspector
|
|
(#%variable-reference)))
|
|
|
|
(define current-require-module-path
|
|
(make-parameter #f
|
|
(lambda (v)
|
|
(unless (or (not v)
|
|
(module-path-index? v))
|
|
(raise-argument-error 'current-require-module-path
|
|
"(or/c module-path-index? #f)"
|
|
v))
|
|
v)))
|
|
|
|
;; a simplified version of `collapse-module-path-index', where
|
|
;; we don't have to normalize:
|
|
(define (collapse-mpi mpi)
|
|
(define-values (a b) (module-path-index-split mpi))
|
|
(define (recur b)
|
|
(cond
|
|
[(not b) (collapse-mpi (module-path-index-join #f #f))]
|
|
[(resolved-module-path? b)
|
|
(let ([n (resolved-module-path-name b)])
|
|
(if (pair? n)
|
|
(cons 'submod n)
|
|
n))]
|
|
[else (collapse-mpi b)]))
|
|
(define (extract-root bc)
|
|
(if (and (pair? bc) (eq? 'submod (car bc)))
|
|
(cadr bc)
|
|
bc))
|
|
(define (replace-last s a)
|
|
;; replace last path element, and also eliminate "." and "..":
|
|
(regexp-replace* #rx"(?<=^|/)[.]/"
|
|
(regexp-replace* #rx"(?<=^|/)[-+_%a-zA-Z0-9]*/[.][.]/"
|
|
(regexp-replace #rx"[^/]*$" s a)
|
|
"")
|
|
""))
|
|
(define (string->path* s)
|
|
;; for now, module-path strings all works as paths
|
|
(string->path s))
|
|
(cond
|
|
[(and (not a) (not b))
|
|
(build-path (or (current-load-relative-directory)
|
|
(current-directory))
|
|
"here.rkt")]
|
|
[(path? a) a]
|
|
[(symbol? a) a]
|
|
[(string? a)
|
|
(define bc (extract-root (recur b)))
|
|
(let loop ([bc bc])
|
|
(cond
|
|
[(path? bc)
|
|
(define-values (base name dir?) (split-path bc))
|
|
(if (eq? base 'relative)
|
|
(string->path* a)
|
|
(build-path base (string->path* a)))]
|
|
[(symbol? bc)
|
|
(loop `(lib ,(symbol->string bc)))]
|
|
[(eq? (car bc) 'quote)
|
|
(build-path (or (current-load-relative-directory)
|
|
(current-directory))
|
|
(string->path* a))]
|
|
[(eq? (car bc) 'file)
|
|
(loop (string->path (cadr bc)))]
|
|
[(eq? (car bc) 'lib)
|
|
(cond
|
|
[(and (null? (cddr bc))
|
|
(regexp-match? #rx"[/]" (cadr bc)))
|
|
`(lib ,(replace-last (cadr bc) a))]
|
|
[(and (null? (cddr bc))
|
|
(not (regexp-match? #rx"[/.]" (cadr bc))))
|
|
(loop `(lib ,(string-append (cadr bc) "/main.rkt")))]
|
|
[(and (null? (cddr bc))
|
|
(not (regexp-match? #rx"[/]" (cadr bc))))
|
|
(loop `(lib ,(string-append "mzlib/" (cadr bc))))]
|
|
[else
|
|
(loop `(lib ,(apply
|
|
string-append
|
|
(let loop ([l (cddr bc)])
|
|
(if (null? l)
|
|
(list (cadr bc))
|
|
(list* (car l) "/" (loop (cdr l))))))))])]
|
|
[(eq? (car bc) 'planet)
|
|
(cond
|
|
[(symbol? (cadr bc))
|
|
(loop `(planet ,(symbol->string (cadr bc))))]
|
|
[(null? (cddr bc))
|
|
(define s (cadr bc))
|
|
(cond
|
|
[(regexp-match? #rx"/.*/" s)
|
|
`(planet ,(replace-last s a))]
|
|
[else
|
|
`(planet ,(string-append s "/" a))])]
|
|
[else
|
|
(define s (cadr bc))
|
|
`(planet ,(if (regexp-match? #rx"/" s)
|
|
(replace-last s a)
|
|
a)
|
|
,@(cddr bc))])]
|
|
[else (error "collapse-mpi failed on recur shape: " bc)]))]
|
|
[(eq? (car a) 'submod)
|
|
(define (add bc l)
|
|
(if (and (pair? bc) (eq? 'submod (car bc)))
|
|
(append bc l)
|
|
(list* 'submod bc l)))
|
|
(cond
|
|
[(equal? (cadr a) ".")
|
|
(add (recur b) (cddr a))]
|
|
[(equal? (cadr a) "..")
|
|
(add (recur b) (cdr a))]
|
|
[else
|
|
(add (collapse-mpi (module-path-index-join (cadr a) b))
|
|
(cddr a))])]
|
|
[else a]))
|
|
|
|
(define (convert-relative-module-path mp/stx)
|
|
(define rmp (current-require-module-path))
|
|
(cond
|
|
[(not rmp) mp/stx]
|
|
[else
|
|
(define mp (if (syntax? mp/stx)
|
|
(syntax->datum mp/stx)
|
|
mp/stx))
|
|
(define (d->s d)
|
|
(if (syntax? mp/stx)
|
|
(datum->syntax mp/stx d mp/stx mp/stx)
|
|
d))
|
|
(cond
|
|
[(not (module-path? mp)) mp/stx]
|
|
[(string? mp)
|
|
;; collapse a relative reference to an absolute one:
|
|
(d->s (collapse-mpi (module-path-index-join mp rmp)))]
|
|
[(symbol? mp) mp/stx]
|
|
[(eq? (car mp) 'quote)
|
|
;; maybe a submodule...
|
|
(define r (module-path-index-resolve rmp))
|
|
(if (module-declared? (append '(submod)
|
|
(if (list? r)
|
|
r
|
|
(list r))
|
|
(cddr mp))
|
|
#t)
|
|
;; Yes, a submodule:
|
|
(let ([rmp-mod (collapse-mpi rmp)])
|
|
(if (and (pair? rmp-mod)
|
|
(eq? (car rmp-mod) 'submod))
|
|
(d->s (append rmp-mod (cadr mp)))
|
|
(d->s `(submod ,rmp-mod . ,(cddr mp)))))
|
|
mp/stx)]
|
|
[(eq? (car mp) 'file)
|
|
(define base-path (resolved-module-path-name
|
|
(module-path-index-resolve rmp)))
|
|
(define path (if (pair? base-path)
|
|
(car base-path)
|
|
base-path))
|
|
(if (path? path)
|
|
(let-values ([(base name dir?) (split-path path)])
|
|
(if (eq? base 'relative)
|
|
mp/stx
|
|
(d->s (build-path base (cadr mp)))))
|
|
mp/stx)]
|
|
[(eq? (car mp) 'submod)
|
|
(define sub/stx (if (syntax? mp/stx)
|
|
(syntax-case mp/stx ()
|
|
[(_ sub . _) #'sub])
|
|
(cadr mp)))
|
|
(define sub (if (syntax? sub/stx) (syntax->datum sub/stx) sub/stx))
|
|
(define new-sub/stx
|
|
(cond
|
|
[(equal? sub ".") (d->s (collapse-mpi rmp))]
|
|
[(equal? sub "..")
|
|
(define old (collapse-mpi rmp))
|
|
(if (and (pair? old)
|
|
(eq? (car old) 'submod))
|
|
(d->s (append old ".."))
|
|
sub/stx)]
|
|
[else
|
|
(convert-relative-module-path sub/stx)]))
|
|
(cond
|
|
[(eq? sub/stx new-sub/stx) mp/stx]
|
|
[else
|
|
(define new-sub (if (syntax? new-sub/stx)
|
|
(syntax->datum new-sub/stx)
|
|
new-sub/stx))
|
|
(if (and (pair? new-sub)
|
|
(eq? (car new-sub) 'submod))
|
|
(d->s (append new-sub (cddr sub)))
|
|
(d->s `(submod ,new-sub/stx . ,(cddr sub))))])]
|
|
[else mp/stx])]))
|
|
|
|
;; expand-import : stx bool -> (listof import)
|
|
(define (expand-import stx)
|
|
(let ([disarmed-stx (syntax-disarm stx orig-insp)])
|
|
(syntax-case disarmed-stx ()
|
|
[simple
|
|
(or (identifier? #'simple)
|
|
(string? (syntax-e #'simple))
|
|
(syntax-case stx (quote)
|
|
[(quote s) #t]
|
|
[_ #f]))
|
|
(let ([mod-path
|
|
(if (pair? (syntax-e #'simple))
|
|
`(quote . ,(cdr (syntax->datum #'simple)))
|
|
(syntax->datum #'simple))])
|
|
(unless (module-path? mod-path)
|
|
(raise-syntax-error
|
|
#f
|
|
"invalid module-path form"
|
|
stx))
|
|
(let* ([mod-path (convert-relative-module-path mod-path)]
|
|
[namess (syntax-local-module-exports mod-path)])
|
|
(values
|
|
(apply
|
|
append
|
|
(map (lambda (names)
|
|
(let ([mode (car names)])
|
|
(map (lambda (name)
|
|
(make-import (datum->syntax
|
|
stx
|
|
name
|
|
stx)
|
|
name
|
|
(if (equal? (syntax->datum #'simple) mod-path)
|
|
#'simple
|
|
mod-path)
|
|
mode
|
|
0
|
|
mode
|
|
stx))
|
|
(cdr names))))
|
|
namess))
|
|
(list (make-import-source (if (equal? (syntax->datum #'simple) mod-path)
|
|
#'simple
|
|
(datum->syntax #'simple mod-path #'simple))
|
|
0)))))]
|
|
[(id . rest)
|
|
(identifier? #'id)
|
|
(let ([t (syntax-local-value #'id (lambda () #f))])
|
|
(if (require-transformer? t)
|
|
(call-with-values
|
|
(lambda ()
|
|
(((require-transformer-get-proc t) t) disarmed-stx))
|
|
(case-lambda
|
|
[(v mods)
|
|
(unless (and (list? v)
|
|
(andmap import? v))
|
|
(raise-syntax-error
|
|
#f
|
|
"first result from require transformer is not a list of imports"
|
|
stx))
|
|
(unless (and (list? mods)
|
|
(andmap import-source? mods))
|
|
(raise-syntax-error
|
|
#f
|
|
"second result from require transformer is not a list of import-sources"
|
|
stx))
|
|
(values v mods)]
|
|
[args
|
|
(raise-syntax-error
|
|
#f
|
|
(format "require transformer produced ~a result~a instead of 2"
|
|
(length args)
|
|
(if (= 1 (length args)) "" "s"))
|
|
stx)]))
|
|
(raise-syntax-error
|
|
#f
|
|
"not a require sub-form"
|
|
stx)))]
|
|
[_
|
|
(raise-syntax-error
|
|
#f
|
|
"bad syntax for require sub-form"
|
|
stx)]))))
|