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.)
This commit is contained in:
Eli Barzilay
parent
3e755eba11
commit
6b44974b42
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.}
|
||||
|
||||
@; ------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -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 #<path...> 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))
|
||||
|
|
|
|||
|
|
@ -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])))
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user