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

10
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
'collects
'path->main-collects-relative 'path->main-collects-relative
'main-collects-relative->path))) 'main-collects-relative->path))

10
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
'doc
'path->main-doc-relative 'path->main-doc-relative
'main-doc-relative->path))) 'main-doc-relative->path))

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

@ -1,23 +1,19 @@
(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
@ -32,16 +28,15 @@
(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]
@ -50,15 +45,15 @@
(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 original working directory: ;; No main "collects"/"doc"/whatever? Use
;; 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:
@ -71,4 +66,4 @@
[else path])) [else path]))
(values path->main-relative* (values path->main-relative*
main-relative->path*))) main-relative->path*))