* A more noticeable message for starting the doc build

* More paths relative to known places

svn: r10028

collects/setup/private/path-utils.ss

@@ -2,6 +2,7 @@
 
 (require setup/dirs
          setup/main-collects
+         setup/path-relativize
          scheme/list)
 
 (provide doc-path path->name)
@@ -21,13 +22,27 @@
 ;; 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.)
+;; human-readable output.)  Generalized for any base directory and an
-(define (path->name path)
+;; indicative prefix.
+(define (path->rel path find-base)
+  ((if (not find-base)
+     path->main-collects-relative
+     (let-values ([(path->rel rel->path)
+                   (make-relativize find-base 'rel 'path->rel 'rel->path)])
+       path->rel))
+   path))
+(define (path->name path #:prefix [prefix #f] #:base [find-base #f])
   (if (not (complete-path? path))
     (if (string? path) path (path->string path))
-    (let ([rel (path->main-collects-relative path)])
+    (let loop ([rel (path->rel path find-base)]
+               [prefix prefix])
       (if (pair? rel)
-        (bytes->string/utf-8
+        (let* ([p (cdr (append-map (lambda (p) (list #"/" p)) (cdr rel)))]
-         (apply bytes-append
+               [p (bytes->string/utf-8 (apply bytes-append p))])
-                (cdr (append-map (lambda (p) (list #"/" p)) (cdr rel)))))
+          (if prefix (format "<~a>/~a" prefix p) p))
-        (path->string rel)))))
+        (if (or prefix find-base)
+          (path->string rel)
+          ;; by default (both optionals missing) try the user
+          ;; collections too looping with a prefix avoids trying this
+          ;; again
+          (loop (path->rel path find-user-collects-dir) 'user))))))

collects/setup/setup-unit.ss

@@ -1,6 +1,5 @@
-
+;; Expects parameters to be set before invocation.
-; Expects parameters to be set before invocation.
+;; Calls `exit' when done.
-; Calls `exit' when done.
 
 #lang scheme/base
 
@@ -47,14 +46,8 @@
   (export)
 
   (define (setup-fprintf p task s . args)
-    (apply fprintf p (string-append "setup-plt: " 
+    (let ([task (if task (string-append task ": ") "")])
-                                    (if task
+      (apply fprintf p (string-append "setup-plt: " task s "\n") args)))
-                                        (string-append
-                                         task
-                                         ": ")
-                                        "")
-                                    s 
-                                    "\n") args))
 
   (define (setup-printf task s . args)
     (apply setup-fprintf (current-output-port) task s args))
@@ -585,7 +578,10 @@
                                           [(general) 'installer]
                                           [(post)    'post-installer])))])
                 (setup-printf (format "~ainstalling"
-                                      (case part [(pre) "pre-"] [(post) "post-"] [else ""]))
+                                      (case part
+                                        [(pre) "pre-"]
+                                        [(post) "post-"]
+                                        [else ""]))
                               "~a"
                               (cc-name cc))
                 (let ([dir (build-path main-collects-dir 'up)])
@@ -791,7 +787,7 @@
       (dynamic-require 'setup/scribble 'setup-scribblings)))
 
   (when (make-docs)
-    (setup-printf #f "building documentation")
+    (setup-printf #f "--- building documentation ---")
     ((doc:verbose) (verbose))
     (with-handlers ([exn:fail?
                      (lambda (exn)
@@ -897,7 +893,7 @@
                (unless (null? mzlns)
                  (setup-printf
                   "WARNING"
-                  "~a launcher name list ~s has no matching library/flags lists"
+                  "~s launcher name list ~s has no matching library/flags lists"
                   kind mzlns))]
               [(and (or (not mzlls) (= (length mzlns) (length mzlls)))
                     (or (not mzlfs) (= (length mzlns) (length mzlfs))))
@@ -910,15 +906,19 @@
                                     `(relative? . ,(not absolute-installation?))
                                     (build-aux-from-path
                                      (build-path (cc-path cc)
-                                                 (path-replace-suffix (or mzll mzln) #""))))])
+                                                 (path-replace-suffix
+                                                  (or mzll mzln)
+                                                  #""))))])
                     (unless (up-to-date? p aux)
-                      (setup-printf "launcher"
+                      (setup-printf
-                                    "~a [~a~a]"
+                       "launcher"
-                                    (path->string p)
+                       "~a~a"
-                                    kind (let ([v (current-launcher-variant)])
+                       (path->name p #:prefix (format "~a-bin" kind)
-                                           (if (eq? v (system-type 'gc))
+                                   #:base (if (equal? kind 'console)
-                                             ""
+                                            find-console-bin-dir
-                                             (format " ~a" v))))
+                                            find-gui-bin-dir))
+                       (let ([v (current-launcher-variant)])
+                         (if (eq? v (system-type 'gc)) "" (format " [~a]" v))))
                       (make-launcher
                        (or mzlf
                            (if (cc-collection cc)
@@ -942,13 +942,13 @@
                (let ([fault (if (or (not mzlls) (= (length mzlns) (length mzlls))) 'f 'l)])
                  (setup-printf
                   "WARNING"
-                  "~a launcher name list ~s doesn't match ~a list; ~s"
+                  "~s launcher name list ~s doesn't match ~a list; ~s"
                   kind mzlns
                   (if (eq? 'l fault) "library" "flags")
                   (if (eq? fault 'l) mzlls mzlfs)))]))
           (for ([variant (available-mred-variants)])
             (parameterize ([current-launcher-variant variant])
-              (make-launcher "MrEd"
+              (make-launcher 'gui
                              'mred-launcher-names
                              'mred-launcher-libraries
                              'mred-launcher-flags
@@ -957,7 +957,7 @@
                              mred-launcher-up-to-date?)))
           (for ([variant (available-mzscheme-variants)])
             (parameterize ([current-launcher-variant variant])
-              (make-launcher "MzScheme"
+              (make-launcher 'console
                              'mzscheme-launcher-names
                              'mzscheme-launcher-libraries
                              'mzscheme-launcher-flags