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

fix 'lib' path collapsing to always use Unix style

Browse Source 
svn: r2422
This commit is contained in:
Matthew Flatt 2006-03-13 20:19:05 +00:00
parent e9b3b863d8
commit 1c10a636cb
3 changed files with 142 additions and 115 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/syntax/doc.txt
View File

@ -290,7 +290,7 @@ currently exist).
> (with-module-reading-parameterization thunk) - calls `thunk' with
all reader parameters reset to their default values.
> (check-module-form stx expected-module-sym filename-string-or-#f) -
> (check-module-form stx expected-module-sym source-or-#f) -
inspects `stx' to check whether evaluating it will declare a module
named `expected-module-sym' (plus a prefix, if
`current-module-name-prefix' is set) --- at least if `module' is
@ -301,8 +301,9 @@ currently exist).
`check-module-form' procedure returns a syntax object that certainly
will declare a module (adding explicit context to the leading
`module' if necessary) in any top-level. Otherwise, if
`filename-string-or-#f' is a string, a suitable exception is raised,
and if `filename-string-or-#f' is #f, #f is returned.
`source-string-or-#f' is not #f, a suitable exception is raised
using the `write' form of the source in the message; if
`source-or-#f' is #f, #f is returned.
If stx is eof or eof wrapped as a syntax object, then an error is
raised or #f is returned.

235
collects/syntax/moddep.ss
View File

@ -2,6 +2,7 @@
(module moddep mzscheme
(require (lib "etc.ss")
(lib "port.ss")
(lib "list.ss")
(lib "contract.ss")
(lib "resolver.ss" "planet"))
@ -297,112 +298,136 @@
;; relto-mp should be a relative path, '(lib relative-path collection), or '(file path)
;; or a thunk that produces one of those
(lambda (s relto-mp)
(let ([combine-relative-elements
(lambda (elements)
(define (attach-to-relative-path relto)
(apply build-path
(let-values ([(base n d?) (split-path relto)])
(if (eq? base 'relative)
'same
base))
(map (lambda (i)
(cond
[(bytes? i) (bytes->path i)]
[else i]))
elements)))
(when (procedure? relto-mp)
(set! relto-mp (relto-mp)))
(cond
[(path-string? relto-mp)
((if (path? relto-mp)
bytes->path
bytes->string/locale)
(apply
bytes-append
(let ([m (regexp-match re:path-only (if (path? relto-mp)
(path->bytes relto-mp)
(string->bytes/locale relto-mp)))])
(if m
(cadr m)
#"."))
(map (lambda (e)
(cond
[(eq? e 'same) #"/."]
[(eq? e 'up) #"/.."]
[else (bytes-append #"/" (if (path? e)
(path->bytes e)
e))]))
elements)))]
[(eq? (car relto-mp) 'file)
(let ([path ((if (ormap path? elements)
values
path->string)
(attach-to-relative-path (cadr relto-mp)))])
(if (path? path)
path
`(file ,path)))]
[(eq? (car relto-mp) 'lib)
(let ([path (path->string
(attach-to-relative-path (cadr relto-mp)))])
`(lib ,path ,(caddr relto-mp)))]
[(eq? (car relto-mp) 'planet)
(let ([pathstr (path->string (attach-to-relative-path (cadr relto-mp)))])
`(planet ,pathstr ,(caddr relto-mp)))]
[else (error 'combine-relative-elements "don't know how to deal with: ~s" relto-mp)]))])
;; Used for 'lib paths, so it's always Unix-style
(define (attach-to-relative-path-string elements relto)
(let ([elem-str (substring
(apply string-append
(map (lambda (i)
(string-append
"/"
(cond
[(bytes? i) (bytes->string/locale i)]
[(path? i) (path->string i)]
[(eq? i 'up) ".."]
[else i])))
(filter (lambda (x)
(not (eq? x 'same)))
elements)))
1)])
(if (or (regexp-match #rx"^[.]/+[^/]*" relto)
(not (regexp-match #rx"/" relto)))
elem-str
(let ([m (regexp-match #rx"^(.*/)/*[^/]*$" relto)])
(string-append (cadr m) elem-str)))))
(define (combine-relative-elements elements)
;; Used for 'file paths, so it's platform specific:
(define (attach-to-relative-path relto)
(apply build-path
(let-values ([(base n d?) (split-path relto)])
(if (eq? base 'relative)
'same
base))
(map (lambda (i)
(cond
[(bytes? i) (bytes->path i)]
[else i]))
elements)))
(when (procedure? relto-mp)
(set! relto-mp (relto-mp)))
(cond
[(string? s)
;; Parse Unix-style relative path string
(let loop ([elements null][s (string->bytes/utf-8 s)])
(let ([prefix (regexp-match re:dir s)])
(if prefix
(loop (cons (let ([p (cadr prefix)])
(cond
[(bytes=? p #".") 'same]
[(bytes=? p #"..") 'up]
[else (bytes->path p)]))
elements)
(caddr prefix))
(combine-relative-elements
(reverse (cons s elements))))))]
[(and (or (not (pair? s))
(not (list? s)))
(not (path? s)))
#f]
[(or (path? s)
(eq? (car s) 'file))
(let ([p (if (path? s)
s
(cadr s))])
(if (absolute-path? p)
s
(let loop ([p p][elements null])
(let-values ([(base name dir?) (split-path p)])
(cond
[(eq? base 'relative)
(combine-relative-elements
(cons name elements))]
[else (loop base (cons name elements))])))))]
[(eq? (car s) 'lib)
(let ([cols (let ([len (length s)])
(if (= len 2)
(list "mzlib")
(cddr s)))])
`(lib ,(path->string
(build-path (if (null? (cdr cols))
'same
(apply build-path 'same (cdr cols)))
(cadr s)))
,(car cols)))]
[(eq? (car s) 'planet)
(let ((cols (cdddr s)))
`(planet
,(path->string (build-path (if (null? cols)
'same
(apply build-path 'same cols))
(cadr s)))
,(caddr s)))]
[else #f]))))
[(path-string? relto-mp)
((if (path? relto-mp)
bytes->path
bytes->string/locale)
(apply
bytes-append
(let ([m (regexp-match re:path-only (if (path? relto-mp)
(path->bytes relto-mp)
(string->bytes/locale relto-mp)))])
(if m
(cadr m)
#"."))
(map (lambda (e)
(cond
[(eq? e 'same) #"/."]
[(eq? e 'up) #"/.."]
[else (bytes-append #"/" (if (path? e)
(path->bytes e)
e))]))
elements)))]
[(eq? (car relto-mp) 'file)
(let ([path ((if (ormap path? elements)
values
path->string)
(attach-to-relative-path (cadr relto-mp)))])
(if (path? path)
path
`(file ,path)))]
[(eq? (car relto-mp) 'lib)
(let ([path (attach-to-relative-path-string elements
(cadr relto-mp))])
`(lib ,path ,(caddr relto-mp)))]
[(eq? (car relto-mp) 'planet)
(let ([pathstr (attach-to-relative-path-string elements
(cadr relto-mp))])
`(planet ,pathstr ,(caddr relto-mp)))]
[else (error 'combine-relative-elements "don't know how to deal with: ~s" relto-mp)]))
(cond
[(string? s)
;; Parse Unix-style relative path string
(let loop ([elements null][s (string->bytes/utf-8 s)])
(let ([prefix (regexp-match re:dir s)])
(if prefix
(loop (cons (let ([p (cadr prefix)])
(cond
[(bytes=? p #".") 'same]
[(bytes=? p #"..") 'up]
[else (bytes->path p)]))
elements)
(caddr prefix))
(combine-relative-elements
(reverse (cons s elements))))))]
[(and (or (not (pair? s))
(not (list? s)))
(not (path? s)))
#f]
[(or (path? s)
(eq? (car s) 'file))
(let ([p (if (path? s)
s
(cadr s))])
(if (absolute-path? p)
s
(let loop ([p p][elements null])
(let-values ([(base name dir?) (split-path p)])
(cond
[(eq? base 'relative)
(combine-relative-elements
(cons name elements))]
[else (loop base (cons name elements))])))))]
[(eq? (car s) 'lib)
(let ([cols (let ([len (length s)])
(if (= len 2)
(list "mzlib")
(cddr s)))])
`(lib ,(attach-to-relative-path-string
(append (cdr cols)
(list (cadr s)))
".")
,(car cols)))]
[(eq? (car s) 'planet)
(let ((cols (cdddr s)))
`(planet
,(attach-to-relative-path-string
(append (cdr cols)
(list (cadr s)))
".")
,(caddr s)))]
[else #f])))
(define (collapse-module-path-index mpi relto-mp)
(let-values ([(path base) (module-path-index-split mpi)])

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

@ -78,12 +78,13 @@
(module-path-index-join #f #f)))
rel-to))
(test-cmp '(lib "./x.ss" "nonesuch") "x.ss" '(lib "y.ss" "nonesuch"))
(test-cmp '(lib "./x.ss" "nonesuch") "x.ss" (lambda () '(lib "y.ss" "nonesuch")))
(test-cmp '(lib "./down/x.ss" "nonesuch") "down/x.ss" '(lib "y.ss" "nonesuch"))
(test-cmp '(lib "./x.ss" "mzlib") '(lib "x.ss") '(lib "y.ss" "nonesuch"))
(test-cmp '(lib "./../x.ss" "nonesuch/private") "../x.ss" '(lib "y.ss" "nonesuch/private"))
(test-cmp '(lib "./private/x.ss" "alsonot") '(lib "x.ss" "alsonot" "private") '(lib "y.ss" "nonesuch"))
(test-cmp '(lib "x.ss" "nonesuch") "x.ss" '(lib "y.ss" "nonesuch"))
(test-cmp '(lib "x.ss" "nonesuch") "x.ss" (lambda () '(lib "y.ss" "nonesuch")))
(test-cmp '(lib "down/x.ss" "nonesuch") "down/x.ss" '(lib "y.ss" "nonesuch"))
(test-cmp '(lib "x.ss" "mzlib") '(lib "x.ss") '(lib "y.ss" "nonesuch"))
(test-cmp '(lib "../x.ss" "nonesuch/private") "../x.ss" '(lib "y.ss" "nonesuch/private"))
(test-cmp '(lib "private/../x.ss" "nonesuch") "../x.ss" '(lib "private/y.ss" "nonesuch"))
(test-cmp '(lib "private/x.ss" "alsonot") '(lib "x.ss" "alsonot" "private") '(lib "y.ss" "nonesuch"))
(test-cmp (build-path (current-directory) "x.ss") "x.ss" (build-path (current-directory) "other"))
(test-cmp `(file ,(path->string (build-path (current-directory) "x.ss")))
@ -102,7 +103,7 @@
(bytes->path #"\xFF")
`(file ,(path->string (build-path (current-directory) "other"))))
(test '(lib "./x.ss" "alsonot")
(test '(lib "x.ss" "alsonot")
collapse-module-path-index
(module-path-index-join "x.ss"
(module-path-index-join