diff --git a/collects/racket/contract/private/provide.rkt b/collects/racket/contract/private/provide.rkt index d266093187..d6666e50e0 100644 --- a/collects/racket/contract/private/provide.rkt +++ b/collects/racket/contract/private/provide.rkt @@ -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)] diff --git a/collects/scribblings/raco/setup.scrbl b/collects/scribblings/raco/setup.scrbl index 99d8812ecc..93675cdada 100644 --- a/collects/scribblings/raco/setup.scrbl +++ b/collects/scribblings/raco/setup.scrbl @@ -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 @@ -1138,13 +1139,21 @@ An @deftech{unpackable} is one of the following: file for this collection or @PLaneT package exists on the filesystem the @racket[syms] field holds the identifiers defined in that file. } - + @defproc[(reset-relevant-directories-state!) void?]{ Resets the cache used by @racket[find-relevant-directories].} @; ------------------------------------------------------------------------ -@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["/"]. + Similarly, a path in the user-specific collects results in a prefix of + @racket["/"], and a @PLaneT path results in + @racket["/"]. 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[""] 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} diff --git a/collects/setup/path-to-relative.rkt b/collects/setup/path-to-relative.rkt new file mode 100644 index 0000000000..44584ac550 --- /dev/null +++ b/collects/setup/path-to-relative.rkt @@ -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 "/") + (cons find-user-collects-dir "/") + (cons find-planet-dir "/")))) + +(define path->relative-string/setup + (make-path->relative-string + (list (cons find-collects-dir "") + (cons find-user-collects-dir "/") + (cons find-planet-dir "/")))) diff --git a/collects/setup/private/path-utils.rkt b/collects/setup/private/path-utils.rkt index 5c7d0bd7d3..90bd6de733 100644 --- a/collects/setup/private/path-utils.rkt +++ b/collects/setup/private/path-utils.rkt @@ -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]))) diff --git a/collects/setup/scribble.rkt b/collects/setup/scribble.rkt index e7c745ad42..35a7eda501 100644 --- a/collects/setup/scribble.rkt +++ b/collects/setup/scribble.rkt @@ -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)] @@ -541,10 +542,10 @@ (and auto-user? (memq 'depends-all (doc-flags doc)))))]) (when (or (not up-to-date?) (verbose)) - (setup-printf + (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: diff --git a/collects/setup/setup-unit.rkt b/collects/setup/setup-unit.rkt index e8fef2f8d5..74025617b6 100644 --- a/collects/setup/setup-unit.rkt +++ b/collects/setup/setup-unit.rkt @@ -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 "/")))) + (define path->relative-string/gui-bin + (make-path->relative-string + (list (cons find-gui-bin-dir "/")))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; 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)))) @@ -648,9 +655,11 @@ (begin-record-error cc "making" (setup-printf "making" "~a" (cc-name cc)) (control-io - (lambda (p where) - (set! gcs 2) - (setup-fprintf p #f " in ~a" (path->name (path->complete-path where (cc-path cc))))) + (lambda (p where) + (set! gcs 2) + (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 diff --git a/collects/syntax/location.rkt b/collects/syntax/location.rkt index f79db55f75..5a6ba8d7a4 100644 --- a/collects/syntax/location.rkt +++ b/collects/syntax/location.rkt @@ -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] diff --git a/collects/unstable/dirs.rkt b/collects/unstable/dirs.rkt index bb68b2786f..b651025a7e 100644 --- a/collects/unstable/dirs.rkt +++ b/collects/unstable/dirs.rkt @@ -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 ;; intended for use in racket/contract, so don't try to add contracts! diff --git a/collects/unstable/scribblings/dirs.scrbl b/collects/unstable/scribblings/dirs.scrbl deleted file mode 100644 index 99bcd08319..0000000000 --- a/collects/unstable/scribblings/dirs.scrbl +++ /dev/null @@ -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["/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] diff --git a/collects/unstable/scribblings/unstable.scrbl b/collects/unstable/scribblings/unstable.scrbl index 5896efdd2b..80d58556fb 100644 --- a/collects/unstable/scribblings/unstable.scrbl +++ b/collects/unstable/scribblings/unstable.scrbl @@ -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"] diff --git a/collects/unstable/tests/test-docs-complete.rkt b/collects/unstable/tests/test-docs-complete.rkt index 3b2391115d..a16c585914 100644 --- a/collects/unstable/tests/test-docs-complete.rkt +++ b/collects/unstable/tests/test-docs-complete.rkt @@ -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))