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

minor

Browse Source 
svn: r8609
This commit is contained in:
Eli Barzilay 2008-02-10 05:40:06 +00:00
parent 937e912728
commit 2c99aaa75c
3 changed files with 83 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

20
collects/setup/main-collects.ss
View File

@ -1,13 +1,13 @@
(module main-collects mzscheme #lang mzscheme
(require "dirs.ss" (require "dirs.ss" "path-relativize.ss")
"path-relativize.ss")
(provide path->main-collects-relative (provide path->main-collects-relative
main-collects-relative->path) main-collects-relative->path)
(define-values (path->main-collects-relative (define-values (path->main-collects-relative
main-collects-relative->path) main-collects-relative->path)
(make-relativize find-collects-dir 'collects (make-relativize find-collects-dir
'path->main-collects-relative 'collects
'main-collects-relative->path))) 'path->main-collects-relative
'main-collects-relative->path))

20
collects/setup/main-doc.ss
View File

@ -1,13 +1,13 @@
(module main-doc mzscheme #lang mzscheme
(require "dirs.ss" (require "dirs.ss" "path-relativize.ss")
"path-relativize.ss")
(provide path->main-doc-relative (provide path->main-doc-relative
main-doc-relative->path) main-doc-relative->path)
(define-values (path->main-doc-relative (define-values (path->main-doc-relative
main-doc-relative->path) main-doc-relative->path)
(make-relativize find-doc-dir 'doc (make-relativize find-doc-dir
'path->main-doc-relative 'doc
'main-doc-relative->path))) 'path->main-doc-relative
'main-doc-relative->path))

123
collects/setup/path-relativize.ss
View File

@ -1,74 +1,69 @@
(module path-relativize mzscheme #lang mzscheme
(provide make-relativize) (provide make-relativize)
(define (make-relativize find-main-dir (define (make-relativize find-main-dir tag to-rel-name from-rel-name)
tag
to-rel-name
from-rel-name)
;; Historical note: this module is based on the old "plthome.ss" ;; Historical note: this module is based on the old "plthome.ss"
;; The `path->main-collects-relative' and ;; The `path->main-relative' and `main-relative->path' functions
;; `main-collects-relative->path' functions are used to store paths ;; that this generates are used to store paths that are relative to
;; that are relative to the main "collects" directory, such as in ;; the main directory (specified by `find-main-dir'), such as in
;; .dep files. This means that if the plt tree is moved, .dep files ;; .dep files. This means that if the plt tree is moved, .dep files
;; still work. It is generally fine if ;; still work. It is generally fine if `path->main-relative' misses
;; `path->main-collects-relative' misses some usages, as long as it ;; some usages, as long as it works when we prepare a distribution
;; works when we prepare a distribution tree. Otherwise, things ;; tree. (If it misses, things will continue to work fine and .dep
;; will continue to work fine and .dep files will just contain ;; files will contain absolute path names.)
;; absolute path names.
;; We need to compare paths to find when something is in the plt ;; We need to compare paths to find when something is in the plt
;; tree, so we explode the paths. This slower than the old way (by ;; tree, so we explode the paths. This slower than the old way (by
;; a factor of 2 or so), but it's simpler and more portable. ;; a factor of 2 or so), but it's simpler and more portable.
(define (explode-path* path) (define (explode-path* path)
(explode-path (simplify-path (path->complete-path path)))) (explode-path (simplify-path (path->complete-path path))))
(define (explode-path orig-path) (define (explode-path orig-path)
(let loop ([path orig-path][rest null]) (let loop ([path orig-path][rest null])
(let-values ([(base name dir?) (split-path path)]) (let-values ([(base name dir?) (split-path path)])
(if (path? base) (if (path? base)
(loop base (cons name rest)) (loop base (cons name rest))
(cons name rest))))) (cons name rest)))))
(define main-collects-dir/ (define main-dir/
(delay (let ([dir (find-main-dir)]) (delay (let ([dir (find-main-dir)])
(and dir (explode-path* dir))))) (and dir (explode-path* dir)))))
;; path->main-collects-relative* : path-or-bytes -> datum-containing-bytes-or-path ;; path->main-relative* : path-or-bytes -> datum-containing-bytes-or-path
(define (path->main-relative* path) (define (path->main-relative* path)
(let loop ([exploded (explode-path* (if (bytes? path) (let loop ([exploded (explode-path*
(bytes->path path) (if (bytes? path) (bytes->path path) path))]
path))] [main-exploded (force main-dir/)])
[main-exploded (force main-collects-dir/)]) (cond
(cond [(null? main-exploded) (cons tag (map path-element->bytes exploded))]
[(null? main-exploded) (cons tag (map path-element->bytes exploded))] [(null? exploded) path]
[(null? exploded) path] [(equal? (normal-case-path (car exploded))
[(equal? (normal-case-path (car exploded)) (normal-case-path (car main-exploded)))
(normal-case-path (car main-exploded))) (loop (cdr exploded) (cdr main-exploded))]
(loop (cdr exploded) (cdr main-exploded))] [else path])))
[else path])))
;; main-collects-relative->path* : datum-containing-bytes-or-path -> path ;; main-relative->path* : datum-containing-bytes-or-path -> path
(define (main-relative->path* path) (define (main-relative->path* path)
(cond [(and (pair? path) (cond [(and (pair? path)
(eq? tag (car path)) (eq? tag (car path))
(or (bytes? (cdr path)) ; backward compatibility (or (bytes? (cdr path)) ; backward compatibility
(and (list? (cdr path)) (and (list? (cdr path)) (andmap bytes? (cdr path)))))
(andmap bytes? (cdr path))))) (let ([dir (or (find-main-dir)
(let ([dir (or (find-main-dir) ;; No main "collects"/"doc"/whatever? Use
;; No main "collects"/"doc"/whatever? Use original working directory: ;; original working directory:
(find-system-path 'orig-dir))]) (find-system-path 'orig-dir))])
(if (bytes? (cdr path)) (if (bytes? (cdr path))
;; backward compatibilty: ;; backward compatibilty:
(if (equal? (cdr path) #"") (if (equal? (cdr path) #"")
dir dir
(build-path dir (bytes->path (cdr path)))) (build-path dir (bytes->path (cdr path))))
;; Normal mode: ;; Normal mode:
(apply build-path dir (apply build-path dir
(map bytes->path-element (cdr path)))))] (map bytes->path-element (cdr path)))))]
[else path])) [else path]))
(values path->main-relative* (values path->main-relative*
main-relative->path*))) main-relative->path*))