From 566bcba4d557bf0335972333644be5d5944ae6f5 Mon Sep 17 00:00:00 2001 From: Jacob Matthews Date: Fri, 10 Mar 2006 16:29:44 +0000 Subject: [PATCH] extended collapse-module-path to handle planet svn: r2412 --- collects/syntax/moddep.ss | 182 +++++++++++++++++++++----------------- 1 file changed, 101 insertions(+), 81 deletions(-) diff --git a/collects/syntax/moddep.ss b/collects/syntax/moddep.ss index 261ad8f4c6..e2002f9e52 100644 --- a/collects/syntax/moddep.ss +++ b/collects/syntax/moddep.ss @@ -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