New setup/path-to-relative' that supersedes unstable/dirs' and most of
`setup/private/path-utils'. The API is a little different: instead of getting the alist and the path, there's a curried function that gets the alist and produces a function to do the substitutions.
This commit is contained in:
Eli Barzilay
parent
1276568558
commit
4da4a2759b
|
|
@ -6,7 +6,7 @@
|
|||
(require (for-syntax racket/base
|
||||
racket/list
|
||||
racket/struct-info
|
||||
unstable/dirs
|
||||
setup/path-to-relative
|
||||
(prefix-in a: "helpers.rkt"))
|
||||
"arrow.rkt"
|
||||
"base.rkt"
|
||||
|
|
@ -61,8 +61,8 @@
|
|||
(with-syntax
|
||||
([src
|
||||
(or (and (path-string? (syntax-source #'id))
|
||||
(path->directory-relative-string
|
||||
(syntax-source #'id) #:default #f))
|
||||
(path->relative-string/library
|
||||
(syntax-source #'id) #f))
|
||||
(syntax-source #'id))]
|
||||
[line (syntax-line #'id)]
|
||||
[col (syntax-column #'id)]
|
||||
|
|
|
|||
|
|
@ -9,6 +9,7 @@
|
|||
setup/option-sig
|
||||
setup/dirs
|
||||
setup/main-collects
|
||||
setup/path-to-relative
|
||||
setup/xref scribble/xref
|
||||
;; setup/infotab -- no bindings from this are used
|
||||
setup/getinfo
|
||||
|
|
@ -1144,7 +1145,15 @@ An @deftech{unpackable} is one of the following:
|
|||
|
||||
@; ------------------------------------------------------------------------
|
||||
|
||||
@section[#:tag "main-collects"]{API for Paths Relative to @filepath{collects}}
|
||||
@section[#:tag "relative-paths"]{API for Relative Paths}
|
||||
|
||||
The Racket installation tree can usually be moved around the filesystem.
|
||||
To support this, care must be taken to avoid absolute paths. The
|
||||
following two APIs cover two aspects of this: a way to convert a path to
|
||||
a value that is relative to the @filepath{collets} tree, and a way to
|
||||
display such paths (e.g., in error messages).
|
||||
|
||||
@subsection{Representing paths relative to @filepath{collects}}
|
||||
|
||||
@defmodule[setup/main-collects]
|
||||
|
||||
|
|
@ -1176,6 +1185,49 @@ back to a path relative to @racket[(find-collects-dir)].
|
|||
For historical reasons, if @racket[rel] is any kind of value other
|
||||
than specified in the contract above, it is returned as-is.}
|
||||
|
||||
@subsection{Displaying paths relative to a common root}
|
||||
|
||||
@defmodule[setup/path-to-relative]
|
||||
|
||||
@defproc[(path->relative-string/library [path path-string?]
|
||||
[default any/c (lambda (x) x)])
|
||||
any]{
|
||||
Produces a string suitable for display in error messages. If the path
|
||||
is an absolute one that is inside the @filepath{collects} tree, the
|
||||
result will be a string that begins with @racket["<collects>/"].
|
||||
Similarly, a path in the user-specific collects results in a prefix of
|
||||
@racket["<user-collects>/"], and a @PLaneT path results in
|
||||
@racket["<planet>/"]. If the path is not absolute, or if it is not in
|
||||
any of these, the @racket[default] determines the result: if it is a
|
||||
procedure, it is applied onto the path to get the result, otherwise it
|
||||
is returned.
|
||||
}
|
||||
|
||||
@defproc[(path->relative-string/setup [path path-string?]
|
||||
[default any/c (lambda (x) x)])
|
||||
any]{
|
||||
Similar to @racket[path->relative-string/library], but more suited for
|
||||
output during compilation: @filepath{collects} paths are shown with no
|
||||
prefix, and in the user-specific collects with just a
|
||||
@racket["<user>"] prefix.
|
||||
}
|
||||
|
||||
@defproc[(make-path->relative-string [dirs (listof (cons (-> path?) string?))]
|
||||
[default any/c (lambda (x) x)])
|
||||
(path-string? any/c . -> . any)]{
|
||||
This function produces functions like
|
||||
@racket[path->relative-string/library] and
|
||||
@racket[path->relative-string/setup].
|
||||
|
||||
@racket[dirs] determines the prefix substitutions. It should be an
|
||||
association list mapping a path-producing thunk to a prefix string for
|
||||
paths in the specified path.
|
||||
|
||||
@racket[default] determines the default for the resulting function
|
||||
(which can always be overridden by an additional argument to this
|
||||
function).
|
||||
}
|
||||
|
||||
@; ------------------------------------------------------------------------
|
||||
|
||||
@section[#:tag "xref"]{API for Cross-References for Installed Manuals}
|
||||
|
|
|
|||
56
collects/setup/path-to-relative.rkt
Normal file
56
collects/setup/path-to-relative.rkt
Normal file
|
|
@ -0,0 +1,56 @@
|
|||
#lang racket/base
|
||||
|
||||
;; intended for use in racket/contract, so don't try to add contracts!
|
||||
;; (and try to generally minimize dependencies)
|
||||
|
||||
(require "dirs.rkt" "path-relativize.rkt"
|
||||
(only-in planet/config [CACHE-DIR find-planet-dir]))
|
||||
|
||||
(provide make-path->relative-string
|
||||
path->relative-string/setup
|
||||
path->relative-string/library)
|
||||
|
||||
(define (make-path->relative-string dirs [default (lambda (x) x)])
|
||||
(unless (and (list? dirs)
|
||||
(andmap (lambda (x)
|
||||
(and (pair? x)
|
||||
(and (procedure? (car x))
|
||||
(procedure-arity-includes? (car x) 0)
|
||||
(string? (cdr x)))))
|
||||
dirs))
|
||||
(raise-type-error 'make-path->relative-string
|
||||
"a list of thunk and string pairs" dirs))
|
||||
(define prefixes (map cdr dirs))
|
||||
(define path->relatives
|
||||
(map (lambda (x)
|
||||
(let-values ([(path->relative _)
|
||||
(make-relativize (car x) '_ 'path->relative '_)])
|
||||
path->relative))
|
||||
dirs))
|
||||
(define (path->relative-string path [default default])
|
||||
(unless (path-string? path)
|
||||
(raise-type-error 'path->relative-string "path or string" path))
|
||||
(or (and (complete-path? path)
|
||||
(for/or ([prefix (in-list prefixes)]
|
||||
[path->relative (in-list path->relatives)])
|
||||
(define exploded (path->relative path))
|
||||
(and (pair? exploded)
|
||||
(let* ([r (cdr exploded)]
|
||||
;; note: use "/"s, to get paths as in `require's
|
||||
[r (map (lambda (p) (list #"/" p)) r)]
|
||||
[r (apply bytes-append (cdr (apply append r)))])
|
||||
(string-append prefix (bytes->string/locale r))))))
|
||||
(if (procedure? default) (default path) default)))
|
||||
path->relative-string)
|
||||
|
||||
(define path->relative-string/library
|
||||
(make-path->relative-string
|
||||
(list (cons find-collects-dir "<collects>/")
|
||||
(cons find-user-collects-dir "<user-collects>/")
|
||||
(cons find-planet-dir "<planet>/"))))
|
||||
|
||||
(define path->relative-string/setup
|
||||
(make-path->relative-string
|
||||
(list (cons find-collects-dir "")
|
||||
(cons find-user-collects-dir "<user>/")
|
||||
(cons find-planet-dir "<planet>/"))))
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require setup/dirs setup/main-collects unstable/dirs)
|
||||
(require setup/dirs setup/main-collects)
|
||||
|
||||
(provide doc-path path->name)
|
||||
(provide doc-path)
|
||||
|
||||
;; user-doc-mode can be `false-if-missing' or `never'
|
||||
(define (doc-path dir name flags [user-doc-mode #f])
|
||||
|
|
@ -18,18 +18,3 @@
|
|||
[(or (memq 'main-doc flags) (pair? (path->main-collects-relative dir)))
|
||||
(build-path (find-doc-dir) name)]
|
||||
[else (build-path dir "doc" name)]))
|
||||
|
||||
;; Similar to path->string, except when the path is relative to the
|
||||
;; main collects directory, which returns a string with just the
|
||||
;; relative subpath inside collects. Used for producing less verbose
|
||||
;; printouts during compilation, so the input path is usually
|
||||
;; complete, otherwise it can be ambiguous, so use only when it's
|
||||
;; clear from the context what path is shown. (To be used only for
|
||||
;; human-readable output.) Generalized for any base directory and an
|
||||
;; indicative prefix.
|
||||
(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])))
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
|
||||
(require "getinfo.ss"
|
||||
"dirs.ss"
|
||||
"path-to-relative.rkt"
|
||||
"private/path-utils.ss"
|
||||
"main-collects.ss"
|
||||
"main-doc.ss"
|
||||
|
|
@ -232,10 +233,10 @@
|
|||
(unless (or (memq 'depends-all (doc-flags (info-doc info)))
|
||||
(memq 'depends-all-main (doc-flags (info-doc info))))
|
||||
(unless one?
|
||||
(setup-printf "WARNING"
|
||||
"undefined tag in ~a:"
|
||||
(path->name (doc-src-file
|
||||
(info-doc info))))
|
||||
(setup-printf
|
||||
"WARNING" "undefined tag in ~a:"
|
||||
(path->relative-string/setup
|
||||
(doc-src-file (info-doc info))))
|
||||
(set! one? #t))
|
||||
(setup-printf #f " ~s" k)))])
|
||||
(for ([k (info-undef info)])
|
||||
|
|
@ -300,7 +301,7 @@
|
|||
infos)])
|
||||
(define (say-rendering i)
|
||||
(setup-printf (if (info-rendered? i) "re-rendering" "rendering") "~a"
|
||||
(path->name (doc-src-file (info-doc i)))))
|
||||
(path->relative-string/setup (doc-src-file (info-doc i)))))
|
||||
(define (update-info info response)
|
||||
(match response
|
||||
[#f (set-info-failed?! info #t)]
|
||||
|
|
@ -544,7 +545,7 @@
|
|||
(setup-printf
|
||||
(cond [up-to-date? "using"] [can-run? "running"] [else "skipping"])
|
||||
"~a"
|
||||
(path->name (doc-src-file doc))))
|
||||
(path->relative-string/setup (doc-src-file doc))))
|
||||
|
||||
(if up-to-date?
|
||||
;; Load previously calculated info:
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@
|
|||
"getinfo.rkt"
|
||||
"dirs.rkt"
|
||||
"main-collects.rkt"
|
||||
"private/path-utils.rkt"
|
||||
"path-to-relative.rkt"
|
||||
"private/omitted-paths.rkt"
|
||||
"parallel-build.rkt"
|
||||
"collects.rkt")
|
||||
|
|
@ -88,10 +88,16 @@
|
|||
|
||||
(define (relative-path-string? x) (and (path-string? x) (relative-path? x)))
|
||||
|
||||
|
||||
(define (call-info info flag mk-default test)
|
||||
(let ([v (info flag mk-default)]) (test v) v))
|
||||
|
||||
(define path->relative-string/console-bin
|
||||
(make-path->relative-string
|
||||
(list (cons find-console-bin-dir "<console-bin>/"))))
|
||||
(define path->relative-string/gui-bin
|
||||
(make-path->relative-string
|
||||
(list (cons find-gui-bin-dir "<gui-bin>/"))))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; Errors ;;
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -174,7 +180,7 @@
|
|||
(error name-sym
|
||||
"'name' result from collection ~e is not a string: ~e"
|
||||
path x)))))
|
||||
(define path-name (path->name path))
|
||||
(define path-name (path->relative-string/setup path))
|
||||
(when (info 'compile-subcollections (lambda () #f))
|
||||
(setup-printf "WARNING"
|
||||
"ignoring `compile-subcollections' entry in info ~a"
|
||||
|
|
@ -464,7 +470,7 @@
|
|||
(unless printed?
|
||||
(set! printed? #t)
|
||||
(setup-printf "deleting" "in ~a"
|
||||
(path->name (cc-path cc)))))])
|
||||
(path->relative-string/setup (cc-path cc)))))])
|
||||
(for ([path paths])
|
||||
(let ([full-path (build-path (cc-path cc) path)])
|
||||
(when (or (file-exists? full-path) (directory-exists? full-path))
|
||||
|
|
@ -514,7 +520,8 @@
|
|||
[dep (build-path dir mode-dir (path-add-suffix name #".dep"))])
|
||||
(when (and (file-exists? dep) (file-exists? zo))
|
||||
(set! did-something? #t)
|
||||
(setup-printf "deleting" "~a" (path->name zo))
|
||||
(setup-printf "deleting" "~a"
|
||||
(path->relative-string/setup zo))
|
||||
(delete-file/record-dependency zo dependencies)
|
||||
(delete-file/record-dependency dep dependencies))))))
|
||||
(when did-something? (loop dependencies))))
|
||||
|
|
@ -650,7 +657,9 @@
|
|||
(control-io
|
||||
(lambda (p where)
|
||||
(set! gcs 2)
|
||||
(setup-fprintf p #f " in ~a" (path->name (path->complete-path where (cc-path cc)))))
|
||||
(setup-fprintf p #f " in ~a"
|
||||
(path->relative-string/setup
|
||||
(path->complete-path where (cc-path cc)))))
|
||||
(let ([dir (cc-path cc)]
|
||||
[info (cc-info cc)])
|
||||
(clean-cc dir info)
|
||||
|
|
@ -795,7 +804,7 @@
|
|||
info-path))
|
||||
(make-directory* base)
|
||||
(let ([p info-path])
|
||||
(setup-printf "updating" "~a" (path->name p))
|
||||
(setup-printf "updating" "~a" (path->relative-string/setup p))
|
||||
(with-handlers ([exn:fail? (warning-handler (void))])
|
||||
(with-output-to-file p
|
||||
#:exists 'truncate/replace
|
||||
|
|
@ -917,10 +926,10 @@
|
|||
(setup-printf
|
||||
"launcher"
|
||||
"~a~a"
|
||||
(path->name p #:prefix (format "~a-bin" kind)
|
||||
#:base (if (equal? kind 'console)
|
||||
find-console-bin-dir
|
||||
find-gui-bin-dir))
|
||||
(case kind
|
||||
[(gui) (path->relative-string/gui-bin p)]
|
||||
[(console) (path->relative-string/console-bin p)]
|
||||
[else (error 'make-launcher "internal error (~s)" kind)])
|
||||
(let ([v (current-launcher-variant)])
|
||||
(if (eq? v (system-type 'gc)) "" (format " [~a]" v))))
|
||||
(make-launcher
|
||||
|
|
|
|||
|
|
@ -1,8 +1,6 @@
|
|||
#lang racket/base
|
||||
(require syntax/srcloc
|
||||
(for-syntax racket/base
|
||||
syntax/srcloc
|
||||
unstable/dirs))
|
||||
(for-syntax racket/base syntax/srcloc setup/path-to-relative))
|
||||
(provide quote-srcloc
|
||||
quote-source-file
|
||||
quote-line-number
|
||||
|
|
@ -18,9 +16,8 @@
|
|||
[(_ loc)
|
||||
(let* ([src (build-source-location #'loc)])
|
||||
(cond
|
||||
[(and
|
||||
(path-string? (srcloc-source src))
|
||||
(path->directory-relative-string (srcloc-source src) #:default #f))
|
||||
[(and (path-string? (srcloc-source src))
|
||||
(path->relative-string/library (srcloc-source src) #f))
|
||||
=>
|
||||
(lambda (rel)
|
||||
(with-syntax ([src rel]
|
||||
|
|
|
|||
|
|
@ -1,5 +1,8 @@
|
|||
#lang racket/base
|
||||
|
||||
;; This file needs to be deleted -- it is now superseded by
|
||||
;; `setup/path-relativize'.
|
||||
|
||||
;; Unstable library by: Carl Eastlund <cce@ccs.neu.edu>
|
||||
;; intended for use in racket/contract, so don't try to add contracts!
|
||||
|
||||
|
|
|
|||
|
|
@ -1,88 +0,0 @@
|
|||
#lang scribble/manual
|
||||
@(require scribble/eval "utils.rkt" (for-label racket unstable/dirs))
|
||||
|
||||
@(define unsyntax #f)
|
||||
|
||||
@(define (new-evaluator)
|
||||
(let* ([e (make-base-eval)])
|
||||
(e '(require (for-syntax racket/base)
|
||||
unstable/dirs))
|
||||
e))
|
||||
|
||||
@(define evaluator (new-evaluator))
|
||||
|
||||
@(define reference-path
|
||||
'(lib "scribblings/reference/reference.scrbl"))
|
||||
|
||||
@title[#:tag "dirs"]{Directories}
|
||||
|
||||
@defmodule[unstable/dirs]
|
||||
|
||||
@unstable[@author+email["Carl Eastlund" "cce@ccs.neu.edu"]]
|
||||
|
||||
This library defines utilities dealing with the directory paths used by the
|
||||
Racket distribution.
|
||||
|
||||
@defproc[(path->directory-relative-string
|
||||
[path path-string?]
|
||||
[#:default default any/c (if (path? path) (path->string path) path)]
|
||||
[#:dirs dirs
|
||||
(listof (cons/c (-> path?) any/c))
|
||||
library-relative-directories])
|
||||
(or/c string? (one-of/c default))]{
|
||||
|
||||
Produces a string rendering of @racket[path], replacing distribution-specific
|
||||
paths (normally: collections, user-installed collections, or PLanet cache) with
|
||||
short abbreviations.
|
||||
|
||||
The set of paths and their abbreviations may be overridden by the
|
||||
@racket[#:dirs] option, which accepts an association list. Its keys must be
|
||||
thunks which produce a path. Its values may be either @racket[#f] for no
|
||||
abbreviation (the directory prefix is simply omitted) or any other value to be
|
||||
@racket[display]ed in the output. For instance, @filepath{document.txt}
|
||||
relative to a path abbreviated @racket["path"] would be rendered as
|
||||
@racket["<path>/document.txt"].
|
||||
|
||||
If the path is not relative to one of the given directories, the default return
|
||||
value is a string rendering of the unmodified path. This default may be
|
||||
overridden by providing @racket[default].
|
||||
|
||||
@defexamples[#:eval evaluator
|
||||
(path->directory-relative-string
|
||||
(build-path "source" "project.rkt"))
|
||||
(path->directory-relative-string
|
||||
(build-path (current-directory) "source" "project.rkt"))
|
||||
(path->directory-relative-string
|
||||
(build-path "/" "source" "project.rkt"))
|
||||
(path->directory-relative-string
|
||||
(build-path "/" "source" "project.rkt")
|
||||
#:default #f)
|
||||
(path->directory-relative-string
|
||||
(build-path "/" "source" "project.rkt")
|
||||
#:dirs (list
|
||||
(cons (lambda () (build-path "/" "source"))
|
||||
'src)))
|
||||
]
|
||||
|
||||
}
|
||||
|
||||
@defthing[library-relative-directories (listof (cons (-> path?) any/c))]{
|
||||
|
||||
Represents the default directory substitutions for
|
||||
@racket[path->directory-relative-string]. By default, the collections directory
|
||||
is replaced by @racketresult[collects], the user-installed collections directory
|
||||
is replaced by @racketresult[user], and the PLaneT cache is replaced by
|
||||
@racketresult[planet].
|
||||
|
||||
}
|
||||
|
||||
@defthing[setup-relative-directories (listof (cons (-> path?) any/c))]{
|
||||
|
||||
Represents the directory substitutions used by @exec{setup-plt}. The
|
||||
collections directory is omitted, the user-installed collections directory is
|
||||
replaced by @racketresult[user], and the PLaneT cache is replaced by
|
||||
@racketresult[planet].
|
||||
|
||||
}
|
||||
|
||||
@close-eval[evaluator]
|
||||
|
|
@ -79,7 +79,6 @@ Keep documentation and tests up to date.
|
|||
@include-section["debug.scrbl"]
|
||||
@include-section["define.scrbl"]
|
||||
@include-section["dict.scrbl"]
|
||||
@include-section["dirs.scrbl"]
|
||||
@include-section["exn.scrbl"]
|
||||
@include-section["file.scrbl"]
|
||||
@include-section["find.scrbl"]
|
||||
|
|
|
|||
|
|
@ -20,7 +20,6 @@
|
|||
(check-docs (quote unstable/find))
|
||||
(check-docs (quote unstable/file))
|
||||
(check-docs (quote unstable/exn))
|
||||
(check-docs (quote unstable/dirs))
|
||||
(check-docs (quote unstable/dict))
|
||||
(check-docs (quote unstable/define))
|
||||
(check-docs (quote unstable/debug))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user