From 797c141ede6e436ef13581a06c3c8a65b546987c Mon Sep 17 00:00:00 2001
From: Matthew Flatt <mflatt@racket-lang.org>
Date: Fri, 29 Aug 2008 21:35:40 +0000
Subject: [PATCH] fix problems collapsing planet module paths

svn: r11488
---
 collects/syntax/modcollapse.ss    | 40 +++++++++++++++++++++++++------
 collects/tests/mzscheme/moddep.ss |  9 +++++--
 2 files changed, 40 insertions(+), 9 deletions(-)

diff --git a/collects/syntax/modcollapse.ss b/collects/syntax/modcollapse.ss
index c90c6c9372..2d6def1418 100644
--- a/collects/syntax/modcollapse.ss
+++ b/collects/syntax/modcollapse.ss
@@ -1,7 +1,8 @@
 
 (module modcollapse mzscheme
-  (require mzlib/list
+  (require (only mzlib/list filter)
            scheme/string
+           scheme/list
            mzlib/contract
            (only scheme/base regexp-split)
            "private/modhelp.ss")
@@ -117,10 +118,16 @@
                             "relative path escapes collection: ~s relative to ~s"
                             elements relto-mp))))))]
          [(eq? (car relto-mp) 'planet)
-         (let ([pathstr (simpler-relpath
-                         (attach-to-relative-path-string
-                          elements (cadr relto-mp)))])
-           (normalize-planet `(planet ,pathstr ,(caddr relto-mp))))]
+          (let ([pathstr (simpler-relpath
+                          (attach-to-relative-path-string
+                           elements 
+                           (apply string-append
+                                  (append
+                                   (map (lambda (s)
+                                          (string-append s "/"))
+                                        (cdddr relto-mp))
+                                   (list (cadr relto-mp))))))])
+            (normalize-planet `(planet ,pathstr ,(caddr relto-mp))))]
         [else (error 'combine-relative-elements
                      "don't know how to deal with: ~s" relto-mp)]))
 
@@ -197,8 +204,27 @@
                            null
                            (reverse (cdr (reverse path)))))))]
        [else 
-        ;; Long form is the normal form:
-        s]))
+        ;; Long form is the normal form, but see if we need to split up the
+        ;; path elements:
+        (let ([base (cadr s)]
+              [rest (cdddr s)]
+              [split? (lambda (s)
+                        (regexp-match? #rx"/" s))])
+          (if (or (split? base)
+                  (ormap split? rest))
+              ;; need to split some paths:
+              (let ([split (lambda (s)
+                             (regexp-split #rx"/" s))])
+                (let ([bases (split base)]
+                      [rests (map split rest)])
+                  (list* (car s)
+                         (last bases)
+                         (caddr s)
+                         (append
+                          (apply append rests)
+                          (drop-right bases 1)))))
+              ;; already in normal form:
+              s))]))
 
     (cond [(string? s)
            ;; Parse Unix-style relative path string
diff --git a/collects/tests/mzscheme/moddep.ss b/collects/tests/mzscheme/moddep.ss
index 9ad4d5fe00..40c5a04a26 100644
--- a/collects/tests/mzscheme/moddep.ss
+++ b/collects/tests/mzscheme/moddep.ss
@@ -103,8 +103,8 @@
 
 (test-cmp '(planet "x.ss" ("usr" "pkg.plt" 1)) "x.ss" '(planet "y.ss" ("usr" "pkg.plt" 1)))
 (test-cmp '(planet "x.ss" ("usr" "pkg.plt" 1 0)) "x.ss" (lambda () '(planet "y.ss" ("usr" "pkg.plt" 1 0))))
-(test-cmp '(planet "path/x.ss" ("a" "p.plt" 1)) "path/x.ss" '(planet "z.ss" ("a" "p.plt" 1)))
-(test-cmp '(planet "path/qq/x.ss" ("a" "p.plt" 2)) "qq/x.ss" '(planet "path/z.ss" ("a" "p.plt" 2)))
+(test-cmp '(planet "x.ss" ("a" "p.plt" 1) "path") "path/x.ss" '(planet "z.ss" ("a" "p.plt" 1)))
+(test-cmp '(planet "x.ss" ("a" "p.plt" 2) "path" "qq") "qq/x.ss" '(planet "path/z.ss" ("a" "p.plt" 2)))
 (test-cmp '(planet "x.ss" ("m" "z.plt" 2)) '(planet "x.ss" ("m" "z.plt" 2)) '(planet "o.ss" ("a" "q.plt" 54 3)))
 (test-cmp '(planet "x.ss" ("m" "z.plt" 2)) '(planet "x.ss" ("m" "z.plt" 2)) '(lib "o.ss" "nonesuch"))
 (test-cmp '(planet "x.ss" ("m" "z.plt" 2)) '(planet "x.ss" ("m" "z.plt" 2)) '(file "q.ss"))
@@ -115,9 +115,14 @@
 (test-cmp '(planet "x.ss" ("m" "z.plt" 2 (+ 5))) '(planet "m/z:2:>=5/x.ss") (build-path "yikes"))
 (test-cmp '(planet "x.ss" ("m" "z.plt" 2 (- 5))) '(planet "m/z:2:<=5/x.ss") (build-path "yikes"))
 (test-cmp '(planet "x.ss" ("m" "z.plt" 2 (7 99))) '(planet "m/z:2:7-99/x.ss") (build-path "yikes"))
+(test-cmp '(planet "x.ss" ("m" "z.plt" 2 (7 99))) '(planet "m/z:2:7-99/x.ss") (build-path "yikes"))
 
 (test-cmp '(planet "utils.ss" ("untyped" "unlib.plt" 3 (= 6))) 
           "../utils.ss" '(planet "doc/stuff.ss" ("untyped" "unlib.plt" 3 (= 6))))
+(test-cmp '(planet "utils.ss" ("untyped" "unlib.plt" 3 (= 6))) 
+          "../utils.ss" '(planet "stuff.ss" ("untyped" "unlib.plt" 3 (= 6)) "doc"))
+(test-cmp '(planet "utils.ss" ("untyped" "unlib.plt" 3 (= 6)) "down") 
+          "../down/utils.ss" '(planet "stuff.ss" ("untyped" "unlib.plt" 3 (= 6)) "doc"))
 
 (test-cmp (build-path 'same "x.ss") "x.ss" (build-path 'same))