diff --git a/collects/setup/main-collects.ss b/collects/setup/main-collects.ss index fdedea4c10..dc6ba162a9 100644 --- a/collects/setup/main-collects.ss +++ b/collects/setup/main-collects.ss @@ -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) +(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 - 'path->main-collects-relative - 'main-collects-relative->path))) +(define-values (path->main-collects-relative + main-collects-relative->path) + (make-relativize find-collects-dir + 'collects + 'path->main-collects-relative + 'main-collects-relative->path)) diff --git a/collects/setup/main-doc.ss b/collects/setup/main-doc.ss index 9db119ccce..57c3d87377 100644 --- a/collects/setup/main-doc.ss +++ b/collects/setup/main-doc.ss @@ -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) +(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 - 'path->main-doc-relative - 'main-doc-relative->path))) +(define-values (path->main-doc-relative + main-doc-relative->path) + (make-relativize find-doc-dir + 'doc + 'path->main-doc-relative + 'main-doc-relative->path)) diff --git a/collects/setup/path-relativize.ss b/collects/setup/path-relativize.ss index a896686e8c..69b6ca05b6 100644 --- a/collects/setup/path-relativize.ss +++ b/collects/setup/path-relativize.ss @@ -1,74 +1,69 @@ -(module path-relativize mzscheme +#lang mzscheme - (provide make-relativize) +(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-collects-relative' and - ;; `main-collects-relative->path' functions are used to store paths - ;; that are relative to the main "collects" directory, 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. - - ;; 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 (make-relativize find-main-dir tag to-rel-name from-rel-name) - (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-collects-dir/ - (delay (let ([dir (find-main-dir)]) - (and dir (explode-path* dir))))) + ;; Historical note: this module is based on the old "plthome.ss" - ;; path->main-collects-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/)]) - (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]))) + ;; 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.) - ;; main-collects-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])) + ;; 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)))) - (values path->main-relative* - main-relative->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*))