syntax/location: fix and change `quote-submodule-{name,path}'

Paths are left as paths, instead of trying to convert them to strings
or byte strings. Submodule path elements should be unquoted -- in the
same form as a `submod' form. All extra parts are submodule path elements,
never module paths or ".".

collects/syntax/location.rkt

@@ -51,42 +51,45 @@
  (variable-reference->module-source
   (#%variable-reference)))
 
-(define-syntax (quote-module-name stx)
+(define-for-syntax (do-quote-module stx fixup)
   (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 ...))]))
+    [(_ path ...) 
+     (for ([path (in-list (syntax->list #'(path ...)))]
+           [i (in-naturals)])
+       (unless (or (symbol? (syntax-e path))
+                   (equal? (syntax-e path) ".."))
+         (raise-syntax-error #f "not a submodule path element" stx path)))
+     (with-syntax ([fixup fixup])
+       #'(fixup (module-source) (list 'path ...)))]))
+
+(define-syntax (quote-module-name stx)
+  (do-quote-module stx #'module-name-fixup))
 
 (define (module-name-fixup src path)
-  (or
-    (cond 
-      [(null? path) src]
-      [(list? src) (append src path)]
-      [else (append (list src) path)])
-    'top-level))
+  (do-fixup src path #f))
 
 (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 ...))]))
-
+  (do-quote-module stx #'module-path-fixup))
+    
 (define (module-path-fixup src path)
-  (define (map-path->string l)
-    (for/list ([i l])
-      (cond 
-        [(path? i) (path->bytes i)]
-        [else i])))
+  (do-fixup src path #t))
+
+(define (do-fixup src path as-modpath?)
   (define (last-pass src)
     (cond
-     [(path? src) `(file ,(path->bytes src))]
-     [(symbol? src) `(quote ,src)]
-     [(list? src) (map-path->string `(submod ,@src))]
+     [(path? src) src]
+     [(symbol? src) (if as-modpath?
+                        `(quote ,src)
+                        src)]
+     [(list? src) 
+      (define base (last-pass (car src)))
+      (define sm (cdr src))
+      (if as-modpath?
+          `(submod ,base ,@sm)
+          (cons base sm))]
      [else 'top-level]))
   (last-pass
     (cond 
       [(null? path) src]
-      [(list? src) (append src path)]
-      [else (append (list src) path)])))
+      [(pair? src) (append src path)]
+      [else (cons src path)])))

collects/syntax/scribblings/srcloc.scrbl

@@ -293,39 +293,35 @@ the whole macro application if no @racket[form] is given.
 }
 
 @(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.})))
 
-@defform[(quote-module-name optional-submod-path ...)]{
+@defform[(quote-module-name submod-path-element ...)]{
 
 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.
+symbol, list, or @racket['top-level], where @racket['top-level] is
+produced when used outside of a module. A list corresponds to a
+submodule in the same format as the result of
+@racket[variable-reference->module-name]. Any given
+@racket[submod-path-element]s (as in a @racket[submod] form) are added
+to form a result submodule path.
+
+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 c-name 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)
@@ -335,38 +331,36 @@ c-name2
 (require 'B)
 b-name
 (quote-module-name)
-[current-namespace (module->namespace (quote 'A))]
+(current-namespace (module->namespace (quote 'A)))
 (quote-module-name)
 ]
 
 }
 
-@defform[(quote-module-path optional-submod-path ...)]{
+@defform[(quote-module-path submod-path-element ...)]{
 
 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],
-@racket[submod], or produces @racket['top-level] when used outside of a module.
-@|submod-note|
+@tech[#:doc reference-path]{module path} using @racket[quote], a path,
+@racket[submod], or @racket['top-level], where @racket['top-level] is
+produced when used outside of a module. Any given
+@racket[submod-path-element]s (as in a @racket[submod] form) are added
+to form a result submodule path.
 
 @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 c-path 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)
@@ -376,7 +370,7 @@ c-path2
 (require 'B)
 b-path
 (quote-module-path)
-[current-namespace (module->namespace (quote 'A))]
+(current-namespace (module->namespace (quote 'A)))
 (quote-module-path)
 ]
 

collects/tests/syntax/location.rkt

@@ -8,28 +8,22 @@
 
 (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))
+ (quote-module-name ".." A) => (list (module-source) ".." 'A) 
+ (quote-module-name A B) => (list (module-source) 'A 'B))
 
 (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 c-name c-name2 c-path c-path2))
   (provide (all-defined-out)))
 (module B racket
   (require syntax/location)
@@ -43,24 +37,18 @@
 (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))
+ (quote-module-path) => (module-source)
+ (quote-module-path "..") => (list 'submod (module-source) "..")
+ (quote-module-path ".." A) => (list 'submod (module-source) ".." 'A) 
+ (quote-module-path A B) => (list 'submod (module-source) 'A 'B))
 
 (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))
+  a-path => (list 'submod (module-source) 'A)
+  c-path => (list 'submod (module-source) 'A 'C)
+  c-path2 => (list 'submod (module-source) 'A 'C "..")
+  b-path =>  (list 'submod (module-source) 'B))