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
(require "dirs.ss"
"path-relativize.ss")
#lang mzscheme
(require "dirs.ss" "path-relativize.ss")
(provide path->main-collects-relative
main-collects-relative->path)
(define-values (path->main-collects-relative
main-collects-relative->path)
(make-relativize find-collects-dir 'collects
(make-relativize find-collects-dir
'collects
'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
(require "dirs.ss"
"path-relativize.ss")
#lang mzscheme
(require "dirs.ss" "path-relativize.ss")
(provide path->main-doc-relative
main-doc-relative->path)
(define-values (path->main-doc-relative
main-doc-relative->path)
(make-relativize find-doc-dir 'doc
(make-relativize find-doc-dir
'doc
'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)
(define (make-relativize find-main-dir
tag
to-rel-name
from-rel-name)
(define (make-relativize find-main-dir tag to-rel-name from-rel-name)
;; Historical note: this module is based on the old "plthome.ss"
;; The `path->main-collects-relative' and
;; `main-collects-relative->path' functions are used to store paths
;; that are relative to the main "collects" directory, such as in
;; The `path->main-relative' and `main-relative->path' functions
;; that this generates are used to store paths that are relative to
;; the main directory (specified by `find-main-dir'), such as in
;; .dep files. This means that if the plt tree is moved, .dep files
;; still work. It is generally fine if
;; `path->main-collects-relative' misses some usages, as long as it
;; works when we prepare a distribution tree. Otherwise, things
;; will continue to work fine and .dep files will just contain
;; absolute path names.
;; still work. It is generally fine if `path->main-relative' misses
;; some usages, as long as it works when we prepare a distribution
;; tree. (If it misses, things will continue to work fine and .dep
;; files will contain absolute path names.)
;; 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
@ -32,16 +28,15 @@
(loop base (cons name rest))
(cons name rest)))))
(define main-collects-dir/
(define main-dir/
(delay (let ([dir (find-main-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)
(let loop ([exploded (explode-path* (if (bytes? path)
(bytes->path path)
path))]
[main-exploded (force main-collects-dir/)])
(let loop ([exploded (explode-path*
(if (bytes? path) (bytes->path path) path))]
[main-exploded (force main-dir/)])
(cond
[(null? main-exploded) (cons tag (map path-element->bytes exploded))]
[(null? exploded) path]
@ -50,15 +45,15 @@
(loop (cdr exploded) (cdr main-exploded))]
[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)
(cond [(and (pair? path)
(eq? tag (car path))
(or (bytes? (cdr path)) ; backward compatibility
(and (list? (cdr path))
(andmap bytes? (cdr path)))))
(and (list? (cdr path)) (andmap bytes? (cdr path)))))
(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))])
(if (bytes? (cdr path))
;; backward compatibilty:
@ -71,4 +66,4 @@
[else path]))
(values path->main-relative*
main-relative->path*)))
main-relative->path*))