From 7bee7bbadc3f85f7c4e91e7967dc36e8fb2b8ea6 Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Tue, 27 Jan 2015 07:23:55 -0700
Subject: [PATCH] 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.
---
 .../syntax/scribblings/modcollapse.scrbl      |  32 ++--
 pkgs/racket-test/tests/syntax/modcollapse.rkt | 124 +++++++++++++
 racket/collects/syntax/modcollapse.rkt        |   9 +-
 .../syntax/private/modcollapse-noctc.rkt      | 165 ++++++++++++++----
 racket/src/racket/src/module.c                |  18 +-
 5 files changed, 297 insertions(+), 51 deletions(-)
 create mode 100644 pkgs/racket-test/tests/syntax/modcollapse.rkt

diff --git a/pkgs/racket-doc/syntax/scribblings/modcollapse.scrbl b/pkgs/racket-doc/syntax/scribblings/modcollapse.scrbl
index cde96e2618..91bd6a1680 100644
--- a/pkgs/racket-doc/syntax/scribblings/modcollapse.scrbl
+++ b/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
-@racket[module-path?].
+path.  Otherwise, the result is a module path (in the sense of
+@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?]
-                                     [rel-to-module-path-v (or/c module-path?
-                                                                 (-> module-path?))])
-         (or/c path? module-path?)]{
+@defproc*[([(collapse-module-path-index [module-path-index module-path-index?]
+                                        [rel-to-module-path-v (or/c module-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
-refman]{module path index}; in this case, the
-@racket[rel-to-module-path-v] base is used where the module path index
-contains the ``self'' index.}
+Like @racket[collapse-module-path] when given two arguments, but the
+input is a @techlink[#:doc refman]{module path index}; in this case,
+the @racket[rel-to-module-path-v] base is used where the module path
+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]
diff --git a/pkgs/racket-test/tests/syntax/modcollapse.rkt b/pkgs/racket-test/tests/syntax/modcollapse.rkt
new file mode 100644
index 0000000000..4dd5e95da5
--- /dev/null
+++ b/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))
diff --git a/racket/collects/syntax/modcollapse.rkt b/racket/collects/syntax/modcollapse.rkt
index 0831f4d1fd..bfe0e80501 100644
--- a/racket/collects/syntax/modcollapse.rkt
+++ b/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?)
-                              rel-to-module-path-v/c
-                              . -> . simple-rel-to-module-path-v/c)])
+ [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))])
diff --git a/racket/collects/syntax/private/modcollapse-noctc.rkt b/racket/collects/syntax/private/modcollapse-noctc.rkt
index 98e2da274f..0c1f87f75b 100644
--- a/racket/collects/syntax/private/modcollapse-noctc.rkt
+++ b/racket/collects/syntax/private/modcollapse-noctc.rkt
@@ -330,36 +330,141 @@ 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 (force-relto relto-mp)
-    (if (procedure? relto-mp) 
-        (relto-mp)
-        relto-mp))
-  (let-values ([(path base) (module-path-index-split mpi)])
-    (if path
-        (collapse-module-path
-         path
-         (lambda ()
-           (cond
-            [(module-path-index? base)
-             (collapse-module-path-index base relto-mp)]
-            [(resolved-module-path? base)
-             (let ([n (resolved-module-path-name base)])
-               (if (pair? n)
-                   (if (path? (car n))
-                       (cons 'submod n)
-                       (list* 'submod `(quote ,(car n)) (cdr n)))
-                   (if (path? n)
-                       n
-                       `(quote ,n))))]
-            [else (force-relto relto-mp)])))
-        (let ([r (force-relto relto-mp)]
-              [sm (module-path-index-submodule mpi)])
-          (if sm
-              (if (and (pair? r) (eq? (car r) 'submod))
-                  (append r sm)
-                  (list* 'submod r sm))
-              r)))))
+(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)
+           relto-mp))
+     (let-values ([(path base) (module-path-index-split mpi)])
+       (if path
+           (collapse-module-path
+            path
+            (lambda ()
+              (cond
+               [(module-path-index? base)
+                (collapse-module-path-index base relto-mp)]
+               [(resolved-module-path? base)
+                (let ([n (resolved-module-path-name base)])
+                  (if (pair? n)
+                      (if (path? (car n))
+                          (cons 'submod n)
+                          (list* 'submod `(quote ,(car n)) (cdr n)))
+                      (if (path? n)
+                          n
+                          `(quote ,n))))]
+               [else (force-relto relto-mp)])))
+           (let ([r (force-relto relto-mp)]
+                 [sm (module-path-index-submodule mpi)])
+             (if sm
+                 (if (and (pair? r) (eq? (car r) 'submod))
+                     (append r sm)
+                     (list* 'submod r sm))
+                 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)
diff --git a/racket/src/racket/src/module.c b/racket/src/racket/src/module.c
index ab88c65147..0599d1747e 100644
--- a/racket/src/racket/src/module.c
+++ b/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: */
-  if (SCHEME_CHAR_STRINGP(path)
-      || (SCHEME_PAIRP(path)
-          && SAME_OBJ(file_symbol, SCHEME_CAR(path)))
-      || (SCHEME_PAIRP(path)
-          && SAME_OBJ(submod_symbol, SCHEME_CAR(path))
-          && SCHEME_CHAR_STRINGP(SCHEME_CAR(SCHEME_CDR(path)))))
+     `file' forms, path literals, and `(submod ...)' forms: */
+  if (SCHEME_PAIRP(path)
+      && SAME_OBJ(submod_symbol, SCHEME_CAR(path)))
+    subpath = SCHEME_CAR(SCHEME_CDR(path));
+  else
+    subpath = 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;