suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

quote-module-name and quote-module-path now take an optional submodule path

Browse Source 
(quote-module-name "..")
(quote-module-path ".." 'A 'B)
This commit is contained in:
Kevin Tew 2012-03-28 14:36:27 -06:00
parent f6b2913b26
commit bba967144b
3 changed files with 148 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
collects/syntax/location.rkt
View File

@ -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)])))

55
collects/syntax/scribblings/srcloc.scrbl
View File

@ -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
View 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))