add `relative-in'
This commit is contained in:
Matthew Flatt
parent
0c6719319f
commit
e35337dcfd
|
|
@ -2,7 +2,7 @@
|
|||
(#%require "define.rkt"
|
||||
(for-syntax '#%kernel
|
||||
"stx.rkt" "stxcase-scheme.rkt" "small-scheme.rkt"
|
||||
"stxloc.rkt" "qqstx.rkt"
|
||||
"stxloc.rkt" "qqstx.rkt" "more-scheme.rkt"
|
||||
"../require-transform.rkt"
|
||||
"../provide-transform.rkt"
|
||||
"struct-info.rkt"))
|
||||
|
|
@ -11,6 +11,7 @@
|
|||
for-syntax for-template for-label for-meta
|
||||
require
|
||||
only-in rename-in prefix-in except-in combine-in only-meta-in
|
||||
relative-in
|
||||
provide
|
||||
all-defined-out all-from-out
|
||||
rename-out except-out prefix-out struct-out combine-out
|
||||
|
|
@ -30,36 +31,41 @@
|
|||
;; lib, file, planet, submod
|
||||
|
||||
(define-for-syntax (xlate-path stx)
|
||||
(if (pair? (syntax-e stx))
|
||||
(let ([kw
|
||||
;; symbolic-identifier=? identifiers are not necessarily free-identifier=?
|
||||
(syntax-case stx (lib planet file submod quote)
|
||||
[(quote . _) 'quote]
|
||||
[(lib . _) 'lib]
|
||||
[(planet . _) 'planet]
|
||||
[(file . _) 'file]
|
||||
[(submod . _) 'submod])]
|
||||
[d (syntax->datum stx)])
|
||||
(cond
|
||||
[(eq? kw 'submod)
|
||||
(syntax-case stx ()
|
||||
[(_ mp . rest)
|
||||
(let ([new-mp (xlate-path #'mp)])
|
||||
(if (and (eq? new-mp #'mp)
|
||||
(eq? (car d) 'submod))
|
||||
stx
|
||||
(datum->syntax
|
||||
;; Converts a path based on `require' submform bindings into
|
||||
;; one based on `#%require' symbolic combinations. For example,
|
||||
;; is `quote' is imported as `alt:quote', changes the `alt:quote'
|
||||
;; to plain `quote'.
|
||||
(convert-relative-module-path
|
||||
(if (pair? (syntax-e stx))
|
||||
(let ([kw
|
||||
;; symbolic-identifier=? identifiers are not necessarily free-identifier=?
|
||||
(syntax-case stx (lib planet file submod quote)
|
||||
[(quote . _) 'quote]
|
||||
[(lib . _) 'lib]
|
||||
[(planet . _) 'planet]
|
||||
[(file . _) 'file]
|
||||
[(submod . _) 'submod])]
|
||||
[d (syntax->datum stx)])
|
||||
(cond
|
||||
[(eq? kw 'submod)
|
||||
(syntax-case stx ()
|
||||
[(_ mp . rest)
|
||||
(let ([new-mp (xlate-path #'mp)])
|
||||
(if (and (eq? new-mp #'mp)
|
||||
(eq? (car d) 'submod))
|
||||
stx
|
||||
(list* kw new-mp #'rest)
|
||||
stx
|
||||
stx)))])]
|
||||
[(eq? (car d) kw) stx]
|
||||
[else (datum->syntax
|
||||
stx
|
||||
(cons kw (cdr d))
|
||||
stx
|
||||
stx)]))
|
||||
stx))
|
||||
(datum->syntax
|
||||
stx
|
||||
(list* kw new-mp #'rest)
|
||||
stx
|
||||
stx)))])]
|
||||
[(eq? (car d) kw) stx]
|
||||
[else (datum->syntax
|
||||
stx
|
||||
(cons kw (cdr d))
|
||||
stx
|
||||
stx)]))
|
||||
stx)))
|
||||
|
||||
(define-for-syntax (check-lib-form stx)
|
||||
(unless (module-path? (syntax->datum (xlate-path stx)))
|
||||
|
|
@ -238,127 +244,128 @@
|
|||
(raise-syntax-error #f
|
||||
"not at module level or top level"
|
||||
stx))
|
||||
(letrec ([mode-wrap
|
||||
(lambda (mode base)
|
||||
(cond
|
||||
[(eq? mode 0) base]
|
||||
[else #`(for-meta #,mode #,base)]))]
|
||||
[simple-path? (lambda (p)
|
||||
(syntax-case p (lib quote)
|
||||
[(lib . _)
|
||||
(check-lib-form p)]
|
||||
[(quote . _)
|
||||
(check-lib-form p)]
|
||||
[_
|
||||
(or (identifier? p)
|
||||
(and (string? (syntax-e p))
|
||||
(module-path? (syntax-e p))))]))]
|
||||
[transform-simple
|
||||
(lambda (in base-mode)
|
||||
(syntax-case in (lib file planet submod prefix-in except-in quote)
|
||||
;; Detect simple cases first:
|
||||
[_
|
||||
(string? (syntax-e in))
|
||||
(begin
|
||||
(unless (module-path? (syntax-e in))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad module-path string"
|
||||
stx
|
||||
in))
|
||||
(list (mode-wrap base-mode in)))]
|
||||
[_
|
||||
(and (identifier? in)
|
||||
(module-path? (syntax-e #'in)))
|
||||
(list (mode-wrap base-mode in))]
|
||||
[(quote . s)
|
||||
(check-lib-form in)
|
||||
(list (mode-wrap base-mode (xlate-path in)))]
|
||||
[(lib . s)
|
||||
(check-lib-form in)
|
||||
(list (mode-wrap base-mode (xlate-path in)))]
|
||||
[(file . s)
|
||||
(check-lib-form in)
|
||||
(list (mode-wrap base-mode (xlate-path in)))]
|
||||
[(planet . s)
|
||||
(check-lib-form in)
|
||||
(list (mode-wrap base-mode (xlate-path in)))]
|
||||
[(submod . s)
|
||||
(check-lib-form in)
|
||||
(list (mode-wrap base-mode (xlate-path in)))]
|
||||
[(prefix-in pfx path)
|
||||
(simple-path? #'path)
|
||||
(list (mode-wrap
|
||||
base-mode
|
||||
(datum->syntax
|
||||
#'path
|
||||
(syntax-e
|
||||
(quasisyntax
|
||||
(prefix pfx #,(xlate-path #'path))))
|
||||
in
|
||||
in)))]
|
||||
[(except-in path id ...)
|
||||
(and (simple-path? #'path)
|
||||
;; check that it's well-formed...
|
||||
(call-with-values (lambda () (expand-import in))
|
||||
(lambda (a b) #t)))
|
||||
(list (mode-wrap
|
||||
base-mode
|
||||
(datum->syntax
|
||||
#'path
|
||||
(syntax-e
|
||||
(quasisyntax/loc in
|
||||
(all-except #,(xlate-path #'path) id ...))))))]
|
||||
;; General case:
|
||||
[_ (let-values ([(imports sources) (expand-import in)])
|
||||
;; TODO: collapse back to simple cases when possible
|
||||
(append
|
||||
(map (lambda (import)
|
||||
#`(just-meta
|
||||
#,(import-orig-mode import)
|
||||
#,(mode-wrap (phase+ base-mode (import-req-mode import))
|
||||
#`(rename #,(import-src-mod-path import)
|
||||
#,(import-local-id import)
|
||||
#,(import-src-sym import)))))
|
||||
imports)
|
||||
(map (lambda (src)
|
||||
(mode-wrap (phase+ base-mode (import-source-mode src))
|
||||
#`(only #,(import-source-mod-path-stx src))))
|
||||
sources)))]))]
|
||||
[transform-one
|
||||
(lambda (in)
|
||||
;; Recognize `for-syntax', etc. for simple cases:
|
||||
(syntax-case in (for-meta)
|
||||
[(for-meta n elem ...)
|
||||
(or (exact-integer? (syntax-e #'n))
|
||||
(not (syntax-e #'n)))
|
||||
(apply append
|
||||
(map (lambda (in)
|
||||
(transform-simple in (syntax-e #'n)))
|
||||
(syntax->list #'(elem ...))))]
|
||||
[(for-something elem ...)
|
||||
(and (identifier? #'for-something)
|
||||
(ormap (lambda (i) (free-identifier=? i #'for-something))
|
||||
(list #'for-syntax #'for-template #'for-label)))
|
||||
(apply append
|
||||
(map (lambda (in)
|
||||
(transform-simple in
|
||||
(cond
|
||||
[(free-identifier=? #'for-something #'for-syntax)
|
||||
1]
|
||||
[(free-identifier=? #'for-something #'for-template)
|
||||
-1]
|
||||
[(free-identifier=? #'for-something #'for-label)
|
||||
#f])))
|
||||
(syntax->list #'(elem ...))))]
|
||||
[_ (transform-simple in 0 #| run phase |#)]))])
|
||||
(syntax-case stx ()
|
||||
[(_ in)
|
||||
(with-syntax ([(new-in ...) (transform-one #'in)])
|
||||
(syntax/loc stx
|
||||
(#%require new-in ...)))]
|
||||
[(_ in ...)
|
||||
(syntax/loc stx (begin (require in) ...))])))
|
||||
(parameterize ([current-require-module-path #f])
|
||||
(letrec ([mode-wrap
|
||||
(lambda (mode base)
|
||||
(cond
|
||||
[(eq? mode 0) base]
|
||||
[else #`(for-meta #,mode #,base)]))]
|
||||
[simple-path? (lambda (p)
|
||||
(syntax-case p (lib quote)
|
||||
[(lib . _)
|
||||
(check-lib-form p)]
|
||||
[(quote . _)
|
||||
(check-lib-form p)]
|
||||
[_
|
||||
(or (identifier? p)
|
||||
(and (string? (syntax-e p))
|
||||
(module-path? (syntax-e p))))]))]
|
||||
[transform-simple
|
||||
(lambda (in base-mode)
|
||||
(syntax-case in (lib file planet submod prefix-in except-in quote)
|
||||
;; Detect simple cases first:
|
||||
[_
|
||||
(string? (syntax-e in))
|
||||
(begin
|
||||
(unless (module-path? (syntax-e in))
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad module-path string"
|
||||
stx
|
||||
in))
|
||||
(list (mode-wrap base-mode in)))]
|
||||
[_
|
||||
(and (identifier? in)
|
||||
(module-path? (syntax-e #'in)))
|
||||
(list (mode-wrap base-mode in))]
|
||||
[(quote . s)
|
||||
(check-lib-form in)
|
||||
(list (mode-wrap base-mode (xlate-path in)))]
|
||||
[(lib . s)
|
||||
(check-lib-form in)
|
||||
(list (mode-wrap base-mode (xlate-path in)))]
|
||||
[(file . s)
|
||||
(check-lib-form in)
|
||||
(list (mode-wrap base-mode (xlate-path in)))]
|
||||
[(planet . s)
|
||||
(check-lib-form in)
|
||||
(list (mode-wrap base-mode (xlate-path in)))]
|
||||
[(submod . s)
|
||||
(check-lib-form in)
|
||||
(list (mode-wrap base-mode (xlate-path in)))]
|
||||
[(prefix-in pfx path)
|
||||
(simple-path? #'path)
|
||||
(list (mode-wrap
|
||||
base-mode
|
||||
(datum->syntax
|
||||
#'path
|
||||
(syntax-e
|
||||
(quasisyntax
|
||||
(prefix pfx #,(xlate-path #'path))))
|
||||
in
|
||||
in)))]
|
||||
[(except-in path id ...)
|
||||
(and (simple-path? #'path)
|
||||
;; check that it's well-formed...
|
||||
(call-with-values (lambda () (expand-import in))
|
||||
(lambda (a b) #t)))
|
||||
(list (mode-wrap
|
||||
base-mode
|
||||
(datum->syntax
|
||||
#'path
|
||||
(syntax-e
|
||||
(quasisyntax/loc in
|
||||
(all-except #,(xlate-path #'path) id ...))))))]
|
||||
;; General case:
|
||||
[_ (let-values ([(imports sources) (expand-import in)])
|
||||
;; TODO: collapse back to simple cases when possible
|
||||
(append
|
||||
(map (lambda (import)
|
||||
#`(just-meta
|
||||
#,(import-orig-mode import)
|
||||
#,(mode-wrap (phase+ base-mode (import-req-mode import))
|
||||
#`(rename #,(import-src-mod-path import)
|
||||
#,(import-local-id import)
|
||||
#,(import-src-sym import)))))
|
||||
imports)
|
||||
(map (lambda (src)
|
||||
(mode-wrap (phase+ base-mode (import-source-mode src))
|
||||
#`(only #,(import-source-mod-path-stx src))))
|
||||
sources)))]))]
|
||||
[transform-one
|
||||
(lambda (in)
|
||||
;; Recognize `for-syntax', etc. for simple cases:
|
||||
(syntax-case in (for-meta)
|
||||
[(for-meta n elem ...)
|
||||
(or (exact-integer? (syntax-e #'n))
|
||||
(not (syntax-e #'n)))
|
||||
(apply append
|
||||
(map (lambda (in)
|
||||
(transform-simple in (syntax-e #'n)))
|
||||
(syntax->list #'(elem ...))))]
|
||||
[(for-something elem ...)
|
||||
(and (identifier? #'for-something)
|
||||
(ormap (lambda (i) (free-identifier=? i #'for-something))
|
||||
(list #'for-syntax #'for-template #'for-label)))
|
||||
(apply append
|
||||
(map (lambda (in)
|
||||
(transform-simple in
|
||||
(cond
|
||||
[(free-identifier=? #'for-something #'for-syntax)
|
||||
1]
|
||||
[(free-identifier=? #'for-something #'for-template)
|
||||
-1]
|
||||
[(free-identifier=? #'for-something #'for-label)
|
||||
#f])))
|
||||
(syntax->list #'(elem ...))))]
|
||||
[_ (transform-simple in 0 #| run phase |#)]))])
|
||||
(syntax-case stx ()
|
||||
[(_ in)
|
||||
(with-syntax ([(new-in ...) (transform-one #'in)])
|
||||
(syntax/loc stx
|
||||
(#%require new-in ...)))]
|
||||
[(_ in ...)
|
||||
(syntax/loc stx (begin (require in) ...))]))))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; require transformers
|
||||
|
|
@ -615,6 +622,22 @@
|
|||
imports)
|
||||
sources))]))))
|
||||
|
||||
(define-syntax relative-in
|
||||
(make-require-transformer
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ mod-path in ...)
|
||||
(let ([mp (syntax->datum #'mod-path)])
|
||||
(unless (module-path? mp)
|
||||
(raise-syntax-error #f
|
||||
"bad module path"
|
||||
stx
|
||||
#'mod-path))
|
||||
(parameterize ([current-require-module-path (module-path-index-join
|
||||
mp
|
||||
(current-require-module-path))])
|
||||
(expand-import #`(combine-in in ...))))]))))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; provide
|
||||
|
||||
|
|
|
|||
|
|
@ -8,7 +8,8 @@
|
|||
(for-syntax '#%kernel))
|
||||
|
||||
(#%provide expand-import
|
||||
syntax-local-require-certifier
|
||||
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?
|
||||
|
|
@ -72,6 +73,193 @@
|
|||
(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-type-error 'current-require-module-path
|
||||
"#f or module path index"
|
||||
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)])
|
||||
|
|
@ -91,7 +279,8 @@
|
|||
#f
|
||||
"invalid module-path form"
|
||||
stx))
|
||||
(let ([namess (syntax-local-module-exports mod-path)])
|
||||
(let* ([mod-path (convert-relative-module-path mod-path)]
|
||||
[namess (syntax-local-module-exports mod-path)])
|
||||
(values
|
||||
(apply
|
||||
append
|
||||
|
|
|
|||
|
|
@ -602,13 +602,16 @@ by the expander, the result is the @tech{phase level} of the form
|
|||
being expanded. Otherwise, the result is @racket[0].}
|
||||
|
||||
|
||||
@defproc[(syntax-local-module-exports [mod-path module-path?])
|
||||
@defproc[(syntax-local-module-exports [mod-path (or/c module-path?
|
||||
(and/c syntax?
|
||||
(lambda (stx)
|
||||
(module-path? (syntax->datum stx)))))])
|
||||
(listof (cons/c (or/c exact-integer? #f) (listof symbol?)))]{
|
||||
|
||||
Returns an association list from @tech{phase-level} numbers (or
|
||||
@racket[#f] for the @tech{label phase level}) to lists of symbols,
|
||||
where the symbols are the names of @racket[provide]d
|
||||
bindings at the corresponding @tech{phase level}.
|
||||
bindings from @racket[mod-path] at the corresponding @tech{phase level}.
|
||||
|
||||
@transform-time[]}
|
||||
|
||||
|
|
@ -929,6 +932,44 @@ into a module.
|
|||
]}
|
||||
|
||||
|
||||
@defparam[current-require-module-path module-path (or/c #f module-path-index?)]{
|
||||
|
||||
A parameter that determines how relative @racket[require]-level module
|
||||
paths are expanded to @racket[#%require]-level module paths by
|
||||
@racket[convert-relative-module-path] (which is used implicitly by all
|
||||
built-in @racket[require] sub-forms).
|
||||
|
||||
When the value of @racket[current-require-module-path] is @racket[#f],
|
||||
relative module paths are left as-is, which means that the
|
||||
@racket[require] context determines the resolution of the module
|
||||
path.
|
||||
|
||||
The @racket[require] form @racket[parameterize]s
|
||||
@racket[current-require-module-path] as @racket[#f] while invoking
|
||||
sub-form transformers, while @racket[relative-in] @racket[parameterize]s
|
||||
to a given module path.}
|
||||
|
||||
|
||||
@defproc[(convert-relative-module-path [module-path
|
||||
(or/c module-path?
|
||||
(and/c syntax?
|
||||
(lambda (stx)
|
||||
(module-path? (syntax-e stx)))))])
|
||||
(or/c module-path?
|
||||
(and/c syntax?
|
||||
(lambda (stx)
|
||||
(module-path? (syntax-e stx)))))]{
|
||||
|
||||
Converts @racket[module-path] according to @racket[current-require-module-path].
|
||||
|
||||
If @racket[module-path] is not relative or if the value of
|
||||
@racket[current-require-module-path] is @racket[#f], then
|
||||
@racket[module-path] is returned. Otherwise, @racket[module-path] is
|
||||
converted to an absolute module path that is equivalent to
|
||||
@racket[module-path] relative to the value of
|
||||
@racket[current-require-module-path].}
|
||||
|
||||
|
||||
@defproc[(syntax-local-require-certifier)
|
||||
((syntax?) (or/c #f (syntax? . -> . syntax?))
|
||||
. ->* . syntax?)]{
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
#lang scribble/doc
|
||||
@(require "mz.rkt" scribble/bnf scribble/core
|
||||
(for-label (only-in racket/require-transform
|
||||
make-require-transformer)
|
||||
make-require-transformer
|
||||
current-require-module-path)
|
||||
racket/require-syntax
|
||||
racket/require
|
||||
(only-in racket/provide-transform
|
||||
|
|
@ -348,7 +349,8 @@ Legal only in a @tech{module begin context}, and handled by the
|
|||
@guideintro["module-require"]{@racket[require]}
|
||||
|
||||
@defform/subs[#:literals (only-in prefix-in except-in rename-in lib file planet submod + - =
|
||||
for-syntax for-template for-label for-meta only-meta-in combine-in quote)
|
||||
for-syntax for-template for-label for-meta only-meta-in combine-in
|
||||
relative-in quote)
|
||||
(require require-spec ...)
|
||||
([require-spec module-path
|
||||
(only-in require-spec id-maybe-renamed ...)
|
||||
|
|
@ -356,6 +358,7 @@ Legal only in a @tech{module begin context}, and handled by the
|
|||
(prefix-in prefix-id require-spec)
|
||||
(rename-in require-spec [orig-id bind-id] ...)
|
||||
(combine-in require-spec ...)
|
||||
(relative-in module-path require-spec ...)
|
||||
(only-meta-in phase-level require-spec ...)
|
||||
(for-syntax require-spec ...)
|
||||
(for-template require-spec ...)
|
||||
|
|
@ -491,6 +494,16 @@ bindings of each @racket[require-spec] are visible for expanding later
|
|||
tcp-listen
|
||||
]}
|
||||
|
||||
@defsubform[(relative-in module-path require-spec ...)]{
|
||||
Like the union of the @racket[require-spec]s, but each
|
||||
relative module path in a @racket[require-spec] is treated
|
||||
as relative to @racket[module-path] instead of the enclosing
|
||||
context.
|
||||
|
||||
The @tech{require transformer} that implements @racket[relative-in]
|
||||
sets @racket[current-require-module-path] to adjust module paths
|
||||
in the @racket[require-spec]s.}
|
||||
|
||||
@defsubform[(only-meta-in phase-level require-spec ...)]{
|
||||
Like the combination of @racket[require-spec]s, but removing any
|
||||
binding that is not for @racket[phase-level], where @racket[#f] for
|
||||
|
|
|
|||
|
|
@ -470,6 +470,27 @@
|
|||
(test #t module-path? '(planet "foo.rkt" ("robby" "redex.plt") "sub" "deeper"))
|
||||
(test #t module-path? '(planet "foo%2e.rkt" ("robby%2e" "redex%2e.plt") "sub%2e" "%2edeeper"))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; check `relative-in'
|
||||
|
||||
(let ([check
|
||||
(lambda (path)
|
||||
(parameterize ([current-namespace (make-base-namespace)])
|
||||
(eval
|
||||
`(module relative-in-test racket/base
|
||||
(require ,path)
|
||||
(provide x)
|
||||
(define x (string-join '("a" "b" "c") "."))))
|
||||
(test "a.b.c" dynamic-require ''relative-in-test 'x)))])
|
||||
(check 'racket/string)
|
||||
(check '(relative-in racket/delay "string.rkt"))
|
||||
(check '(relative-in racket "string.rkt"))
|
||||
(check '(relative-in (lib "racket/main.rkt") "string.rkt"))
|
||||
(check '(relative-in (lib "racket") "string.rkt"))
|
||||
(check '(relative-in (lib "main.rkt" "racket") "string.rkt"))
|
||||
(check `(relative-in ,(collection-file-path "delay.rkt" "racket") "string.rkt"))
|
||||
(check '(relative-in racket (relative-in "private/reqprov.rkt" "../string.rkt"))))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; check collection-path details
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
Version 5.3.0.8
|
||||
Added variable-reference->module-path-index
|
||||
Added syntax-local-submodules
|
||||
Added relative-in
|
||||
|
||||
Version 5.3.0.7
|
||||
compiler/zo-struct: added cancel-id field to phase-shift
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user