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

extended collapse-module-path to handle planet

Browse Source 
svn: r2412
This commit is contained in:
Jacob Matthews 2006-03-10 16:29:44 +00:00
parent 4a8811c6b0
commit 566bcba4d5
1 changed files with 101 additions and 81 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

182
collects/syntax/moddep.ss
View File

@ -299,93 +299,110 @@
(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)))]
[else (let ([path ((if (and (ormap path? elements)
(eq? (car relto-mp) 'file))
values
path->string)
(apply build-path
(let-values ([(base n d?) (split-path (cadr relto-mp))])
(if (eq? base 'relative)
'same
base))
(map (lambda (i)
(cond
[(bytes? i) (bytes->path i)]
[else i]))
elements)))])
[(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
(if (eq? (car relto-mp) 'lib)
`(lib ,path ,(caddr relto-mp))
`(file ,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)]))])
(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)))]
[else #f]))))
[(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]))))
(define (collapse-module-path-index mpi relto-mp)
(let-values ([(path base) (module-path-index-split mpi)])
@ -449,6 +466,9 @@
(or/c
(list/c (symbols 'lib) module-path-v-string? module-path-v-string?)
(list/c (symbols 'file) (and/c string? path-string?))
;; not quite specific enough of a contract -- it should also spell out what's
;; allowed in the package spec
(cons/c (symbols 'planet) (cons/c (listof any/c) (listof string?)))
path-string?))
(define rel-to-module-path-v/c