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.

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
+                                             (path->relative-string/library
-                                              (syntax-source #'id) #:default #f))
+                                              (syntax-source #'id) #f))
                                         (syntax-source #'id))]
                                    [line (syntax-line     #'id)]
                                    [col  (syntax-column   #'id)]

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["<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}

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      "<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>/"))))

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])))

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"
+                       (setup-printf
-                                     "undefined tag in ~a:" 
+                        "WARNING" "undefined tag in ~a:"
-                                     (path->name (doc-src-file
+                        (path->relative-string/setup
-                                                  (info-doc info))))
+                         (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:

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 "<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))))
@@ -648,9 +655,11 @@
       (begin-record-error cc "making"
         (setup-printf "making" "~a" (cc-name cc))
         (control-io
-          (lambda (p where) 
+          (lambda (p where)
-            (set! gcs 2) 
+            (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)
+                      (case kind
-                                    #:base (if (equal? kind 'console)
+                        [(gui)     (path->relative-string/gui-bin p)]
-                                             find-console-bin-dir
+                        [(console) (path->relative-string/console-bin p)]
-                                             find-gui-bin-dir))
+                        [else (error 'make-launcher "internal error (~s)" kind)])
                       (let ([v (current-launcher-variant)])
                         (if (eq? v (system-type 'gc)) "" (format " [~a]" v))))
                      (make-launcher

collects/syntax/location.rkt

@@ -1,8 +1,6 @@
 #lang racket/base
 (require syntax/srcloc
-         (for-syntax racket/base
+         (for-syntax racket/base syntax/srcloc setup/path-to-relative))
-                     syntax/srcloc
-                     unstable/dirs))
 (provide quote-srcloc
          quote-source-file
          quote-line-number
@@ -18,9 +16,8 @@
     [(_ loc)
      (let* ([src (build-source-location #'loc)])
        (cond
-        [(and
+        [(and (path-string? (srcloc-source src))
-          (path-string? (srcloc-source src))
+              (path->relative-string/library (srcloc-source src) #f))
-          (path->directory-relative-string (srcloc-source src) #:default #f))
          =>
          (lambda (rel)
            (with-syntax ([src rel]

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 <cce@ccs.neu.edu>
 ;; intended for use in racket/contract, so don't try to add contracts!
 

collects/unstable/scribblings/dirs.scrbl

@@ -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]

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"]

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))