diff --git a/collects/syntax/location.rkt b/collects/syntax/location.rkt index 5a6ba8d7a4..d687e81b2c 100644 --- a/collects/syntax/location.rkt +++ b/collects/syntax/location.rkt @@ -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)]))) diff --git a/collects/syntax/scribblings/srcloc.scrbl b/collects/syntax/scribblings/srcloc.scrbl index 803c0accf9..5aa3e07e9f 100644 --- a/collects/syntax/scribblings/srcloc.scrbl +++ b/collects/syntax/scribblings/srcloc.scrbl @@ -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) ] diff --git a/collects/tests/syntax/location.rkt b/collects/tests/syntax/location.rkt new file mode 100644 index 0000000000..0f1567e3bf --- /dev/null +++ b/collects/tests/syntax/location.rkt @@ -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))