quote-module-name and quote-module-path now take an optional submodule path
(quote-module-name "..") (quote-module-path ".." 'A 'B)
This commit is contained in:
parent
f6b2913b26
commit
bba967144b
|
@ -46,21 +46,46 @@
|
|||
[quote-character-position source-location-position]
|
||||
[quote-character-span source-location-span])
|
||||
|
||||
(define-syntax-rule (quote-module-name)
|
||||
(module-source->module-name
|
||||
(variable-reference->module-source
|
||||
(#%variable-reference))))
|
||||
(define-syntax-rule (module-source)
|
||||
(variable-reference->module-source
|
||||
(#%variable-reference)))
|
||||
|
||||
(define-syntax-rule (quote-module-path)
|
||||
(module-source->module-path
|
||||
(variable-reference->module-source
|
||||
(#%variable-reference))))
|
||||
(define-syntax (quote-module-name stx)
|
||||
(syntax-case stx ()
|
||||
[(_) #'(module-name-fixup (module-source) null)]
|
||||
[(_ "." path ...) #'(module-name-fixup (module-source) (list path ...))]
|
||||
[(_ ".." path ...) #'(module-name-fixup (module-source) (list ".." path ...))]
|
||||
[(_ path ...) #'(module-name-fixup null (list path ...))]))
|
||||
|
||||
(define (module-source->module-name src)
|
||||
(or src 'top-level))
|
||||
(define (module-name-fixup src path)
|
||||
(or
|
||||
(cond
|
||||
[(null? path) src]
|
||||
[(list? src) (append src path)]
|
||||
[else (append (list src) path)])
|
||||
'top-level))
|
||||
|
||||
(define (module-source->module-path src)
|
||||
(cond
|
||||
[(path? src) `(file ,(path->string src))]
|
||||
[(symbol? src) `(quote ,src)]
|
||||
[else 'top-level]))
|
||||
(define-syntax (quote-module-path stx)
|
||||
(syntax-case stx ()
|
||||
[(_) #'(module-path-fixup (module-source) null)]
|
||||
[(_ "." path ...) #'(module-path-fixup (module-source) (list path ...))]
|
||||
[(_ ".." path ...) #'(module-path-fixup (module-source) (list ".." path ...))]
|
||||
[(_ path ...) #'(module-path-fixup null (list path ...))]))
|
||||
|
||||
(define (module-path-fixup src path)
|
||||
(define (map-path->string l)
|
||||
(for/list ([i l])
|
||||
(cond
|
||||
[(path? i) (path->bytes i)]
|
||||
[else i])))
|
||||
(define (last-pass src)
|
||||
(cond
|
||||
[(path? src) `(file ,(path->bytes src))]
|
||||
[(symbol? src) `(quote ,src)]
|
||||
[(list? src) (map-path->string `(submod ,@src))]
|
||||
[else 'top-level]))
|
||||
(last-pass
|
||||
(cond
|
||||
[(null? path) src]
|
||||
[(list? src) (append src path)]
|
||||
[else (append (list src) path)])))
|
||||
|
|
|
@ -1,5 +1,6 @@
|
|||
#lang scribble/manual
|
||||
@(require scribble/eval
|
||||
scribble/decode
|
||||
(for-label racket/base
|
||||
syntax/srcloc
|
||||
syntax/location
|
||||
|
@ -291,21 +292,41 @@ the whole macro application if no @racket[form] is given.
|
|||
|
||||
}
|
||||
|
||||
@defform[(quote-module-name)]{
|
||||
@(define (p . l) (decode-paragraph l))
|
||||
@(define submod-note
|
||||
(make-splice
|
||||
(list
|
||||
@p{Optional submod path arguments, such as @racket["."].
|
||||
@racket[".."]. @racket['D 'E], can be supplied to reference a submodule.})))
|
||||
|
||||
Quotes the name of the module in which the form is compiled as a path or symbol,
|
||||
or @racket['top-level] when used outside of a module. To produce a name
|
||||
suitable for use in printed messages, apply
|
||||
@racket[path->relative-string/library] when the result is a path.
|
||||
@defform[(quote-module-name optional-submod-path ...)]{
|
||||
|
||||
Quotes the name of the module in which the form is compiled as a path,
|
||||
symbol, submodule path, or @racket['top-level] when used outside of a
|
||||
module. @|submod-note| To produce a name suitable for use in printed messages,
|
||||
apply @racket[path->relative-string/library] when the result is a
|
||||
path.
|
||||
|
||||
@defexamples[#:eval (new-evaluator)
|
||||
(module A racket
|
||||
(require syntax/location)
|
||||
(define-syntax-rule (name) (quote-module-name))
|
||||
(define a-name (name))
|
||||
(define a-name1 (quote-module-name "."))
|
||||
(module+ C
|
||||
(require syntax/location)
|
||||
(define c-name (quote-module-name))
|
||||
(define c-name1 (quote-module-name "."))
|
||||
(define c-name2 (quote-module-name ".."))
|
||||
(provide c-name c-name1 c-name2))
|
||||
(provide (all-defined-out)))
|
||||
(require 'A)
|
||||
a-name
|
||||
a-name1
|
||||
(require (submod 'A C))
|
||||
c-name
|
||||
c-name1
|
||||
c-name2
|
||||
(module B racket
|
||||
(require syntax/location)
|
||||
(require 'A)
|
||||
|
@ -320,25 +341,33 @@ b-name
|
|||
|
||||
}
|
||||
|
||||
@defform[(quote-module-path)]{
|
||||
|
||||
@emph{This form is deprecated, as it does not produce module paths that reliably
|
||||
indicate collections or PLaneT packages. Please use @racket[quote-module-name]
|
||||
and @racket[path->relative-string/library] to produce human-readable module
|
||||
names in printed messages.}
|
||||
@defform[(quote-module-path optional-submod-path ...)]{
|
||||
|
||||
Quotes the name of the module in which the form is compiled as a
|
||||
@tech[#:doc reference-path]{module path} using @racket[quote] or @racket[file],
|
||||
or produces @racket['top-level] when used outside of a module.
|
||||
@racket[submod], or produces @racket['top-level] when used outside of a module.
|
||||
@|submod-note|
|
||||
|
||||
@defexamples[#:eval (new-evaluator)
|
||||
(module A racket
|
||||
(require syntax/location)
|
||||
(define-syntax-rule (path) (quote-module-path))
|
||||
(define a-path (path))
|
||||
(define a-path1 (quote-module-path "."))
|
||||
(module+ C
|
||||
(require syntax/location)
|
||||
(define c-path (quote-module-path))
|
||||
(define c-path1 (quote-module-path "."))
|
||||
(define c-path2 (quote-module-path ".."))
|
||||
(provide c-path c-path1 c-path2))
|
||||
(provide (all-defined-out)))
|
||||
(require 'A)
|
||||
a-path
|
||||
a-path1
|
||||
(require (submod 'A C))
|
||||
c-path
|
||||
c-path1
|
||||
c-path2
|
||||
(module B racket
|
||||
(require syntax/location)
|
||||
(require 'A)
|
||||
|
@ -347,7 +376,7 @@ a-path
|
|||
(require 'B)
|
||||
b-path
|
||||
(quote-module-path)
|
||||
[current-pathspace (module->pathspace (quote 'A))]
|
||||
[current-namespace (module->namespace (quote 'A))]
|
||||
(quote-module-path)
|
||||
]
|
||||
|
||||
|
|
66
collects/tests/syntax/location.rkt
Normal file
66
collects/tests/syntax/location.rkt
Normal file
|
@ -0,0 +1,66 @@
|
|||
#lang racket/base
|
||||
(require syntax/location)
|
||||
(require tests/eli-tester)
|
||||
|
||||
(define-syntax-rule (module-source)
|
||||
(variable-reference->module-source
|
||||
(#%variable-reference)))
|
||||
|
||||
(test
|
||||
(quote-module-name) => (module-source)
|
||||
(quote-module-name ".") => (module-source)
|
||||
(quote-module-name "..") => (list (module-source) "..")
|
||||
(quote-module-name ".." 'A) => (list (module-source) ".." 'A)
|
||||
(quote-module-name 'A 'B) => (list 'A 'B)
|
||||
(quote-module-name '(file "foo.rkt") 'A) => '((file "foo.rkt") A))
|
||||
|
||||
(module A racket
|
||||
(require syntax/location)
|
||||
(define-syntax-rule (name) (quote-module-name))
|
||||
(define a-name (name))
|
||||
(define a-name1 (quote-module-name "."))
|
||||
(define a-path (quote-module-path))
|
||||
(define a-path1 (quote-module-path "."))
|
||||
(module+ C
|
||||
(require syntax/location)
|
||||
(define c-name (quote-module-name))
|
||||
(define c-name1 (quote-module-name "."))
|
||||
(define c-name2 (quote-module-name ".."))
|
||||
(define c-path (quote-module-path))
|
||||
(define c-path1 (quote-module-path "."))
|
||||
(define c-path2 (quote-module-path ".."))
|
||||
(provide c-name c-name1 c-name2 c-path c-path1 c-path2))
|
||||
(provide (all-defined-out)))
|
||||
(module B racket
|
||||
(require syntax/location)
|
||||
(require (submod ".." A))
|
||||
(define b-name (name))
|
||||
(define b-path (quote-module-path))
|
||||
(provide (all-defined-out)))
|
||||
(require 'B)
|
||||
|
||||
(require 'A)
|
||||
(require (submod 'A C))
|
||||
(test
|
||||
a-name => (list (module-source) 'A)
|
||||
a-name1 => (list (module-source) 'A)
|
||||
c-name => (list (module-source) 'A 'C)
|
||||
c-name1 => (list (module-source) 'A 'C)
|
||||
c-name2 => (list (module-source) 'A 'C "..")
|
||||
b-name => (list (module-source) 'B))
|
||||
|
||||
(test
|
||||
(quote-module-path) => (list 'file (path->bytes (module-source)))
|
||||
(quote-module-path ".") => (list 'file (path->bytes (module-source)))
|
||||
(quote-module-path "..") => (list 'submod (path->bytes (module-source)) "..")
|
||||
(quote-module-path ".." 'A) => (list 'submod (path->bytes (module-source)) ".." 'A)
|
||||
(quote-module-path 'A 'B) => (list 'submod 'A 'B)
|
||||
(quote-module-path '(file "foo.rkt") 'A) => '(submod (file "foo.rkt") A))
|
||||
|
||||
(test
|
||||
a-path => (list 'submod (path->bytes (module-source)) 'A)
|
||||
a-path1 => (list 'submod (path->bytes (module-source)) 'A)
|
||||
c-path => (list 'submod (path->bytes (module-source)) 'A 'C)
|
||||
c-path1 => (list 'submod (path->bytes (module-source)) 'A 'C)
|
||||
c-path2 => (list 'submod (path->bytes (module-source)) 'A 'C "..")
|
||||
b-path => (list 'submod (path->bytes (module-source)) 'B))
|
Loading…
Reference in New Issue
Block a user