From 6b44974b4205caac4aa8c26696a16bd9008d31f3 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 30 Jun 2011 01:20:02 -0400 Subject: [PATCH] Improvements around uses of the current `unstable/dirs', and `setup/path-relativize'. `setup/path-relativize' is freed from a bunch of things that were due to historical baggage, but some remain. (Also, update its docs.) --- collects/racket/contract/private/provide.rkt | 28 ++--- collects/scribblings/raco/setup.scrbl | 10 +- collects/setup/path-relativize.rkt | 103 +++++++++---------- collects/setup/private/path-utils.rkt | 13 +-- collects/unstable/dirs.rkt | 8 +- 5 files changed, 71 insertions(+), 91 deletions(-) diff --git a/collects/racket/contract/private/provide.rkt b/collects/racket/contract/private/provide.rkt index a33565599b..1c20992e49 100644 --- a/collects/racket/contract/private/provide.rkt +++ b/collects/racket/contract/private/provide.rkt @@ -40,7 +40,8 @@ (current-inspector) #f '(0))]) make-)) -(define-for-syntax (make-provide/contract-transformer contract-id id external-id pos-module-source) +(define-for-syntax (make-provide/contract-transformer + contract-id id external-id pos-module-source) (make-set!-transformer (let ([saved-id-table (make-hasheq)]) (λ (stx) @@ -56,19 +57,18 @@ [external-id external-id] [pos-module-source pos-module-source] [loc-id (identifier-prune-to-source-module id)]) - (let ([srcloc-code - (with-syntax ([src - (cond - [(and - (path-string? (syntax-source #'id)) - (path->directory-relative-string (syntax-source #'id) #:default #f)) - => - (lambda (rel) rel)] - [else (syntax-source #'id)])] - [line (syntax-line #'id)] - [col (syntax-column #'id)] - [pos (syntax-position #'id)] - [span (syntax-span #'id)]) + (let ([srcloc-code + (with-syntax + ([src + (or (and + (path-string? (syntax-source #'id)) + (path->directory-relative-string + (syntax-source #'id) #:default #f)) + (syntax-source #'id))] + [line (syntax-line #'id)] + [col (syntax-column #'id)] + [pos (syntax-position #'id)] + [span (syntax-span #'id)]) #'(make-srcloc 'src 'line 'col 'pos 'span))]) (syntax-local-introduce (syntax-local-lift-expression diff --git a/collects/scribblings/raco/setup.scrbl b/collects/scribblings/raco/setup.scrbl index 328eba88f1..99d8812ecc 100644 --- a/collects/scribblings/raco/setup.scrbl +++ b/collects/scribblings/raco/setup.scrbl @@ -1166,20 +1166,14 @@ converted to a path using @racket[bytes->path].} @defproc[(main-collects-relative->path [rel (or/c bytes? path-string? - (cons/c 'collects - (or/c (listof bytes?) bytes?)))]) + (cons/c 'collects (listof bytes?)))]) path?]{ The inverse of @racket[path->main-collects-relative]: if @racket[rel] is a pair that starts with @racket['collects], then it is converted back to a path relative to @racket[(find-collects-dir)]. -For historical reasons, a single byte string is allowed in place of a -list of byte strings after @racket['collects], in which case it is -assumed to be a relative path after conversion with -@racket[bytes->path]. - -Also for historical reasons, if @racket[rel] is any kind of value other +For historical reasons, if @racket[rel] is any kind of value other than specified in the contract above, it is returned as-is.} @; ------------------------------------------------------------------------ diff --git a/collects/setup/path-relativize.rkt b/collects/setup/path-relativize.rkt index e7364a3541..90ed58c550 100644 --- a/collects/setup/path-relativize.rkt +++ b/collects/setup/path-relativize.rkt @@ -3,71 +3,63 @@ (provide make-relativize) -(define (make-relativize find-main-dir tag to-rel-name from-rel-name) +(define (make-relativize find-root-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.) + ;; The `path->relative' and `relative->path' functions that this + ;; generates are used to store paths that are relative to the root + ;; directory (specified by `find-root-dir'), such as in .dep files. + ;; This means that if the racket tree is moved, .dep files still + ;; work. It is generally fine if `path->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]) + ;; We need to compare paths to find when something is in the racket + ;; tree, so we explode the paths. This is slower than the old way + ;; (by a factor of 2 or so), but it's simpler and more portable. + (define (explode-path path) + (let loop ([path (simplify-path + (normal-case-path (path->complete-path 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))))) + (define exploded-root + (delay (cond [(find-root-dir) => explode-path] [else #f]))) - ;; path->main-relative* : path-or-bytes -> datum-containing-bytes-or-path - (define (path->main-relative* path) - (let loop ([exploded - (explode-path* - (cond [(bytes? path) (bytes->path path)] - [(path-string? path) path] - [else (raise-type-error - to-rel-name "path, string, or bytes" 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]))) + ;; path->relative : path-or-bytes -> datum-containing-bytes-or-path + (define (path->relative path0) + (define path1 + (cond [(bytes? path0) (bytes->path path0)] + [(path-string? path0) path0] + [else (raise-type-error to-rel-name "path, string, or bytes" + path0)])) + (let loop ([path (explode-path path1)] [root (force exploded-root)]) + (cond [(null? root) (cons tag (map path-element->bytes path))] + ;; Note: in some cases this returns the input path as is, which + ;; could be a byte string -- it should be possible to return + ;; `path1', but that messes up the xform compilation somehow, by + ;; having # vaules written into dep files. + [(null? path) path0] + [(equal? (car path) (car root)) (loop (cdr path) (cdr root))] + [else path0]))) - ;; 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)))))] + (define root-or-orig + (delay (or (find-root-dir) + ;; No main "collects"/"doc"/whatever => use the + ;; original working directory: + (find-system-path 'orig-dir)))) + + ;; relative->path : datum-containing-bytes-or-path -> path + (define (relative->path path) + (cond [(and (pair? path) (eq? tag (car path)) + (and (list? (cdr path)) (andmap bytes? (cdr path)))) + (apply build-path (force root-or-orig) + (map bytes->path-element (cdr path)))] [(path? path) path] [(bytes? path) (bytes->path path)] [(string? path) (string->path path)] @@ -76,5 +68,4 @@ (format "path, string, bytes, or a list beginning with ~a" tag) path)])) - (values path->main-relative* - main-relative->path*)) + (values path->relative relative->path)) diff --git a/collects/setup/private/path-utils.rkt b/collects/setup/private/path-utils.rkt index 54a86cae4f..5c7d0bd7d3 100644 --- a/collects/setup/private/path-utils.rkt +++ b/collects/setup/private/path-utils.rkt @@ -1,10 +1,6 @@ #lang scheme/base -(require setup/dirs - setup/main-collects - setup/path-relativize - unstable/dirs - (rename-in planet/config [CACHE-DIR planet-dir])) +(require setup/dirs setup/main-collects unstable/dirs) (provide doc-path path->name) @@ -34,7 +30,6 @@ (define (path->name path #:prefix [prefix #f] #:base [find-base #f]) (path->directory-relative-string path - #:dirs (cond - [find-base (list (cons find-base prefix))] - [prefix (list (cons find-collects-dir prefix))] - [else setup-relative-directories]))) + #:dirs (cond [find-base (list (cons find-base prefix))] + [prefix (list (cons find-collects-dir prefix))] + [else setup-relative-directories]))) diff --git a/collects/unstable/dirs.rkt b/collects/unstable/dirs.rkt index 2530024b6d..4f15a5e985 100644 --- a/collects/unstable/dirs.rkt +++ b/collects/unstable/dirs.rkt @@ -59,11 +59,11 @@ (with-handlers ([exn:fail? (lambda (e) #f)]) (path->relative path))) (when (list? exploded) - (let* ([relative (path->string - (apply build-path - (map bytes->path-element (cdr exploded))))]) + (let ([relative (path->string + (apply build-path + (map bytes->path-element (cdr exploded))))]) (return (if dir-name (format "<~a>/~a" dir-name relative) - (format "~a" relative)))))))) + relative))))))) default))