70 lines
2.8 KiB
Scheme
70 lines
2.8 KiB
Scheme
#lang mzscheme
|
|
|
|
(provide make-relativize)
|
|
|
|
(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-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-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
|
|
;; a factor of 2 or so), but it's simpler and more portable.
|
|
(define (explode-path* path)
|
|
(explode-path (simplify-path (path->complete-path path))))
|
|
|
|
(define (explode-path orig-path)
|
|
(let loop ([path orig-path][rest null])
|
|
(let-values ([(base name dir?) (split-path path)])
|
|
(if (path? base)
|
|
(loop base (cons name rest))
|
|
(cons name rest)))))
|
|
|
|
(define main-dir/
|
|
(delay (let ([dir (find-main-dir)])
|
|
(and dir (explode-path* dir)))))
|
|
|
|
;; 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-dir/)])
|
|
(cond
|
|
[(null? main-exploded) (cons tag (map path-element->bytes exploded))]
|
|
[(null? exploded) path]
|
|
[(equal? (normal-case-path (car exploded))
|
|
(normal-case-path (car main-exploded)))
|
|
(loop (cdr exploded) (cdr main-exploded))]
|
|
[else 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)))))
|
|
(let ([dir (or (find-main-dir)
|
|
;; No main "collects"/"doc"/whatever? Use
|
|
;; original working directory:
|
|
(find-system-path 'orig-dir))])
|
|
(if (bytes? (cdr path))
|
|
;; backward compatibilty:
|
|
(if (equal? (cdr path) #"")
|
|
dir
|
|
(build-path dir (bytes->path (cdr path))))
|
|
;; Normal mode:
|
|
(apply build-path dir
|
|
(map bytes->path-element (cdr path)))))]
|
|
[else path]))
|
|
|
|
(values path->main-relative*
|
|
main-relative->path*))
|