suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix problems collapsing planet module paths

Browse Source 
svn: r11488
This commit is contained in:
Matthew Flatt 2008-08-29 21:35:40 +00:00
parent fa8ffb417e
commit 797c141ede
2 changed files with 40 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
collects/syntax/modcollapse.ss
View File

@ -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

9
collects/tests/mzscheme/moddep.ss
View File

@ -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))