collapse-module-path-index: support relative module path flattening

Unlike `collapse-module-path`, it makes sense for
`collapse-module-path-index` to convert a relative module path index
to a plain module path. In other words, `collapse-module-path-index`
can convert a module path index to a module path.

pkgs/racket-doc/syntax/scribblings/modcollapse.scrbl

@@ -16,7 +16,7 @@
 @defproc[(collapse-module-path [module-path-v module-path?]
                                [rel-to-module-path-v (or/c module-path?
                                                            (-> module-path?))])
-         (or/c path? module-path?)]{
+         module-path?]{
 
 Returns a ``simplified'' module path by combining
 @racket[module-path-v] with @racket[rel-to-module-path-v], where the
@@ -31,8 +31,8 @@ The result can be a path if @racket[module-path-v] contains a path
 element that is needed for the result, or if
 @racket[rel-to-module-path-v] is a non-string path that is needed for
 the result. Similarly, the result can be @racket['submod] wrapping a
-path.  Otherwise, the result is a module path in the sense of
+path.  Otherwise, the result is a module path (in the sense of
-@racket[module-path?].
+@racket[module-path?]) that is not a plain filesystem path.
 
 When the result is a @racket['lib] or @racket['planet] module path, it
 is normalized so that equivalent module paths are represented by
@@ -49,15 +49,25 @@ base.
 
 }
 
-@defproc[(collapse-module-path-index [module-path-index module-path-index?]
+@defproc*[([(collapse-module-path-index [module-path-index module-path-index?]
                                         [rel-to-module-path-v (or/c module-path?
                                                                     (-> module-path?))])
-         (or/c path? module-path?)]{
+            module-path?]
+           [(collapse-module-path-index [module-path-index module-path-index?])
+            module-path?])]{
 
-Like @racket[collapse-module-path], but the input is a @techlink[#:doc
+Like @racket[collapse-module-path] when given two arguments, but the
-refman]{module path index}; in this case, the
+input is a @techlink[#:doc refman]{module path index}; in this case,
-@racket[rel-to-module-path-v] base is used where the module path index
+the @racket[rel-to-module-path-v] base is used where the module path
-contains the ``self'' index.}
+index contains the ``self'' index.
+
+When given a single argument, @racket[collapse-module-path-index]
+returns a module path that is relative if the given module path index
+is relative. The resulting module path is not necessarily normalized.
+
+@history[#:changed "6.1.1.8" @elem{Added the one-argument variant for
+                                   collapsing a relative module path
+                                   index.}]}
 
 
 @close-eval[evaluator]

pkgs/racket-test/tests/syntax/modcollapse.rkt

@@ -0,0 +1,124 @@
+#lang racket/base
+(require syntax/modcollapse)
+
+(define (check got expected)
+  (unless (equal? got expected)
+    (error 'check "failed: ~s vs. ~s" got expected)))
+
+(define here-dir (find-system-path 'temp-dir))
+(define here (build-path here-dir "dummy.rkt"))
+
+(define self (module-path-index-join #f #f))
+
+(define (check-collapse p expected [relative-expected expected])
+  (check (collapse-module-path p here)
+         expected)
+  
+  (define i (module-path-index-join p self))
+  (check (collapse-module-path-index i here)
+         expected)
+  (check (collapse-module-path-index i)
+         relative-expected)
+  
+  (define i2 (module-path-index-join p #f))
+  (check (collapse-module-path-index i2 here)
+         expected)
+  (check (collapse-module-path-index i2)
+         relative-expected))
+
+(check-collapse "local.rkt"
+                (build-path here-dir "local.rkt")
+                "local.rkt")
+
+(check-collapse (string->path "local.rkt")
+                (build-path here-dir "local.rkt")
+                (string->path "local.rkt"))
+
+(check-collapse (path->complete-path "local.rkt")
+                (path->complete-path "local.rkt"))
+
+(check-collapse '(file "local.rkt")
+                (build-path here-dir "local.rkt")
+                '(file "local.rkt"))
+
+(define (check-racket-lib p)
+  (check-collapse p '(lib "racket/main.rkt")))
+(check-racket-lib 'racket)
+(check-racket-lib '(lib "racket"))
+(check-racket-lib '(lib "racket/main.rkt"))
+
+(check-collapse '(planet foo/bar)
+                '(planet "main.rkt" ("foo" "bar.plt")))
+
+(check-collapse '(submod "." test)
+                `(submod ,here test)
+                '(submod "." test))
+
+(define rel-rel (module-path-index-join
+                 "apple.rkt"
+                 (module-path-index-join
+                  "banana.rkt"
+                  self)))
+(check (collapse-module-path-index rel-rel)
+       "apple.rkt")
+(check (collapse-module-path-index rel-rel
+                                   here)
+       (build-path here-dir "apple.rkt"))
+
+(define rel-rel/p (module-path-index-join
+                   "apple.rkt"
+                   (module-path-index-join
+                    (string->path "banana.rkt")
+                    self)))
+(check (collapse-module-path-index rel-rel/p)
+       (build-path 'same "apple.rkt"))
+(check (collapse-module-path-index rel-rel/p
+                                   here)
+       (build-path here-dir "apple.rkt"))
+
+(define rel-rel/f (module-path-index-join
+                   "apple.rkt"
+                   (module-path-index-join
+                    '(file "banana.rkt")
+                    self)))
+(check (collapse-module-path-index rel-rel/f)
+       (build-path 'same "apple.rkt"))
+(check (collapse-module-path-index rel-rel/f
+                                   here)
+       (build-path here-dir "apple.rkt"))
+
+(define rel/f-rel (module-path-index-join
+                   '(file "apple.rkt")
+                   (module-path-index-join
+                    "banana.rkt"
+                    self)))
+(check (collapse-module-path-index rel/f-rel)
+       (build-path 'same "apple.rkt"))
+(check (collapse-module-path-index rel/f-rel
+                                   here)
+       (build-path here-dir "apple.rkt"))
+
+
+(define submod-submod (module-path-index-join
+                       '(submod ".." test)
+                       (module-path-index-join
+                        '(submod "." inner)
+                        self)))
+(check (collapse-module-path-index submod-submod)
+       '(submod "." inner ".." test))
+(check (collapse-module-path-index submod-submod
+                                   here)
+       `(submod ,here test))
+
+(define submod-submod-foo (module-path-index-join
+                           '(submod ".." test)
+                           (module-path-index-join
+                            '(submod "." inner)
+                            (module-path-index-join
+                             "foo.rkt"
+                             self))))
+(check (collapse-module-path-index submod-submod-foo)
+       '(submod "foo.rkt" inner ".." test))
+(check (collapse-module-path-index submod-submod-foo
+                                   here)
+       `(submod ,(build-path here-dir "foo.rkt") test))

racket/collects/syntax/modcollapse.rkt

@@ -30,6 +30,9 @@
  [collapse-module-path (module-path?
                         rel-to-module-path-v/c
                         . -> . simple-rel-to-module-path-v/c)]
- [collapse-module-path-index ((or/c symbol? module-path-index?)
+ [collapse-module-path-index (case->
+                              (module-path-index?
+                               . -> . module-path?)
+                              ((or/c symbol? module-path-index?)
                                rel-to-module-path-v/c
-                              . -> . simple-rel-to-module-path-v/c)])
+                               . -> . simple-rel-to-module-path-v/c))])

racket/collects/syntax/private/modcollapse-noctc.rkt

@@ -330,7 +330,11 @@ Use syntax/modcollapse instead.
              (normalize-submod `(submod ,(normalize-recur (cadr s)) ,@relto-submod ,@(cddr s)))])]
           [else #f])))
 
-(define (collapse-module-path-index mpi relto-mp)
+(define collapse-module-path-index
+  (case-lambda
+    [(mpi)
+     (collapse-module-path-index/relative mpi)]
+    [(mpi relto-mp)
      (define (force-relto relto-mp)
        (if (procedure? relto-mp) 
            (relto-mp)
@@ -359,7 +363,108 @@ Use syntax/modcollapse instead.
                  (if (and (pair? r) (eq? (car r) 'submod))
                      (append r sm)
                      (list* 'submod r sm))
-              r)))))
+                 r))))]))
+
+(define (collapse-module-path-index/relative mpi)
+  (define relative?
+    (let loop ([mpi mpi])
+      (define-values (path base) (module-path-index-split mpi))
+      (let path-loop ([path path])
+        (cond
+         [(not path)
+          (not base)]
+         [(symbol? path)
+          #f]
+         [(and (pair? path)
+               (or (eq? (car path) 'lib)
+                   (eq? (car path) 'planet)
+                   (eq? (car path) 'quote)))
+          #f]
+         [(and (pair? path)
+               (eq? (car path) 'submod)
+               (not (or (equal? (cadr path) ".")
+                        (equal? (cadr path) ".."))))
+          (path-loop (cadr path))]
+         [(and (pair? path)
+               (eq? (car path) 'file)
+               (complete-path? (cadr path)))
+          #f]
+         [(and (path? path)
+               (complete-path? path))
+          #f]
+         [else
+          (or (not base)
+              (and (module-path-index? base)
+                   (loop base)))]))))
+  
+  (if relative?
+      (let loop ([mpi mpi])
+        (define-values (s base) (if mpi
+                                    (module-path-index-split mpi)
+                                    (values #f #f)))
+        (cond
+         [(not s) #f]
+         [else
+          (define full-prev (loop base))
+          (cond
+           [(not full-prev)
+            s]
+           [else
+            (define prev (if (and (pair? full-prev)
+                                  (eq? 'submod (car full-prev)))
+                             (cadr full-prev)
+                             full-prev))
+            (let s-loop ([s s])
+              (cond
+               [(string? s)
+                ;; Unix-style relative path string
+                (cond
+                 [(string? prev)
+                  (define l (drop-right (explode-relpath-string s) 1))
+                  (if (null? l)
+                      s
+                      (string-join (append
+                                    (for/list ([e (in-list l)])
+                                      (case e
+                                        [(same) "."]
+                                        [(up) ".."]
+                                        [else e]))
+                                    (list s))
+                                   "/"))]
+                 [(path? prev)
+                  (define-values (base name dir?) (split-path prev))
+                  (apply build-path (if (path? base) base 'same) (explode-relpath-string s))]
+                 [else ; `(file ,...)
+                  (define-values (base name dir?) (split-path (cadr prev)))
+                  (apply build-path (if (path? base) base 'same) (explode-relpath-string s))])]
+               [(and (pair? s) (eq? 'file (car s)))
+                (build-path
+                 (let-values ([(base name dir?)
+                               (split-path
+                                (cond
+                                 [(string? prev) prev]
+                                 [(path? prev) prev]
+                                 [else ; `(file ,...)
+                                  (cadr prev)]))])
+                   (if (path? base) base 'same))
+                 (cadr s))]
+               [(eq? (car s) 'submod) 
+                (define (as-submod p sm)
+                  (if (and (pair? p) (eq? 'submod (car p)))
+                      (append p sm)
+                      `(submod ,p ,@sm)))
+                (cond
+                 [(equal? (cadr s) ".")
+                  (as-submod full-prev (cddr s))]
+                 [(equal? (cadr s) "..")
+                  (as-submod full-prev (cdr s))]
+                 [else
+                  (as-submod (s-loop (cadr s)) (cddr s))])]))])]))
+      (collapse-module-path-index
+       mpi
+       (lambda ()
+         (error 'collapse-module-path-index
+                "internal error: should not have needed a base path")))))
            
 (provide collapse-module-path
          collapse-module-path-index)

racket/src/racket/src/module.c

@@ -3928,6 +3928,7 @@ Scheme_Object *scheme_make_modidx(Scheme_Object *path,
 				  Scheme_Object *resolved)
 {
   Scheme_Modidx *modidx;
+  Scheme_Object *subpath;
 
   if (SCHEME_MODNAMEP(path))
     return path;
@@ -3945,13 +3946,16 @@ Scheme_Object *scheme_make_modidx(Scheme_Object *path,
   modidx->path = path;
 
   /* base is needed only for relative-path strings,
-     `file' forms, and `(submod "." ...)' forms: */
+     `file' forms, path literals, and `(submod ...)' forms: */
-  if (SCHEME_CHAR_STRINGP(path)
+  if (SCHEME_PAIRP(path)
-      || (SCHEME_PAIRP(path)
+      && SAME_OBJ(submod_symbol, SCHEME_CAR(path)))
-          && SAME_OBJ(file_symbol, SCHEME_CAR(path)))
+    subpath = SCHEME_CAR(SCHEME_CDR(path));
-      || (SCHEME_PAIRP(path)
+  else
-          && SAME_OBJ(submod_symbol, SCHEME_CAR(path))
+    subpath = path;
-          && SCHEME_CHAR_STRINGP(SCHEME_CAR(SCHEME_CDR(path)))))
+  if (SCHEME_CHAR_STRINGP(subpath)
+      || (SCHEME_PAIRP(subpath)
+          && SAME_OBJ(file_symbol, SCHEME_CAR(subpath)))
+      || SCHEME_PATHP(subpath))
     modidx->base = base_modidx;
   else
     modidx->base = scheme_false;