improved setup-plt printouts

svn: r9996

collects/setup/private/doc-path.ss

@@ -1,15 +0,0 @@
-#lang scheme/base
-
-(require setup/dirs
-         setup/main-collects)
-
-(provide doc-path)
-
-(define (doc-path dir name flags)
-  (cond [(memq 'main-doc-root flags) (find-doc-dir)]
-        [(memq 'user-doc-root flags) (find-user-doc-dir)]
-        [(memq 'user-doc flags)      (build-path (find-user-doc-dir) name)]
-        [(or (memq 'main-doc flags)
-             (pair? (path->main-collects-relative dir)))
-         (build-path (find-doc-dir) name)]
-        [else (build-path dir "doc" name)]))

collects/setup/private/path-utils.ss

@@ -0,0 +1,33 @@
+#lang scheme/base
+
+(require setup/dirs
+         setup/main-collects
+         scheme/list)
+
+(provide doc-path path->name)
+
+(define (doc-path dir name flags)
+  (cond [(memq 'main-doc-root flags) (find-doc-dir)]
+        [(memq 'user-doc-root flags) (find-user-doc-dir)]
+        [(memq 'user-doc flags)      (build-path (find-user-doc-dir) name)]
+        [(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.)
+(define (path->name path)
+  (if (not (complete-path? path))
+    (if (string? path) path (path->string path))
+    (let ([rel (path->main-collects-relative path)])
+      (if (pair? rel)
+        (bytes->string/utf-8
+         (apply bytes-append
+                (cdr (append-map (lambda (p) (list #"/" p)) (cdr rel)))))
+        (path->string rel)))))

collects/setup/scribble.ss

@@ -2,7 +2,7 @@
 
 (require "getinfo.ss"
          "dirs.ss"
-         "private/doc-path.ss"
+         "private/path-utils.ss"
          "main-collects.ss"
          scheme/class
          scheme/list
@@ -165,7 +165,8 @@
                  (lambda (k)
                    (unless one?
                      (fprintf (current-error-port)
-                              "In ~a:\n" (doc-src-file (info-doc info)))
+                              "In ~a:\n" (path->name (doc-src-file
+                                                      (info-doc info))))
                      (set! one? #t))
                    (fprintf (current-error-port) "  undefined tag: ~s\n" k))])
             (for ([k (info-undef info)])
@@ -333,8 +334,8 @@
                             (and auto-user?
                                  (memq 'depends-all (doc-flags doc)))))])
     (printf " [~a ~a]\n"
-            (if up-to-date? "Using" (if can-run? "Running" "Skipping"))
+            (cond [up-to-date? "Using"] [can-run? "Running"] [else "Skipping"])
-            (doc-src-file doc))
+            (path->name (doc-src-file doc)))
     (if up-to-date?
       ;; Load previously calculated info:
       (with-handlers ([exn:fail? (lambda (exn)
@@ -435,7 +436,7 @@
   (define doc (info-doc info))
   (define renderer (make-renderer latex-dest doc))
   (printf " [R~aendering ~a]\n" (if (info-rendered? info) "e-r" "")
-          (doc-src-file doc))
+          (path->name (doc-src-file doc)))
   (set-info-rendered?! info #t)
   (with-record-error
    (doc-src-file doc)

collects/setup/setup-unit.ss

@@ -22,7 +22,8 @@
          "unpack.ss"
          "getinfo.ss"
          "dirs.ss"
-         "main-collects.ss")
+         "main-collects.ss"
+         "private/path-utils.ss")
 
 (define-namespace-anchor anchor)
 
@@ -174,7 +175,7 @@
            (error 'setup-plt
                   "'name' result from collection ~e is not a string: ~e"
                   path x)))))
-    (define path-string (path->string path))
+    (define path-name (path->name path))
     (define basename
       (let-values ([(base name dir?) (split-path path)])
         (if (path? name)
@@ -183,12 +184,12 @@
                  "Internal error: cc had invalid info-path: ~e" path))))
     (when (info 'compile-subcollections (lambda () #f))
       (setup-printf "Warning: ignoring `compile-subcollections' entry in info ~a\n"
-                    path))
+                    path-name))
     ;; this check is also done in compiler/compiler-unit, in compile-directory
     (and (not (or (regexp-match? #rx"^[.]" basename) (equal? "compiled" basename)
                   (eq? 'all (info 'compile-omit-paths void))))
          (make-cc collection path
-                  (if name (string-append path-string " (" name ")") path-string)
+                  (if name (string-append path-name " (" name ")") path-name)
                   info root-dir info-path shadowing-policy)))
 
   (define ((warning-handler v) exn)
@@ -351,7 +352,7 @@
         (let ([mark (cc-mark cc)])
           (when (file-exists? mark)
             (setup-printf "Warning: found a marker file, deleting: ~a"
-                          (cc-mark cc))
+                          (path->name mark))
             (delete-file mark)))))
     ;; Now create all marker files, signalling an error if duplicate
     (define (put-markers)
@@ -479,7 +480,7 @@
                 (unless printed?
                   (set! printed? #t)
                   (setup-printf "Deleting files for ~a at ~a"
-                                (cc-name cc) (path->string (cc-path cc)))))])
+                                (cc-name cc) (path->name (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))
@@ -528,7 +529,7 @@
                         [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" zo)
+                     (setup-printf "  deleting ~a" (path->name zo))
                      (delete-file/record-dependency zo dependencies)
                      (delete-file/record-dependency dep dependencies))))))
             (when did-something? (loop dependencies))))
@@ -592,23 +593,20 @@
     ;; `current-namespace' for `get-namespace'.
     (for ([cc ccs-to-compile])
       (parameterize ([current-namespace (get-namespace)])
-        (begin-record-error cc (format "Compiling ~a" desc)
+        (begin-record-error cc (format "~a: compiling..." desc)
           (unless (control-io-apply
                    (case-lambda
                      [(p)
                       ;; Main "doing something" message
-                      (setup-fprintf p "Compiling ~a used by ~a"
+                      (setup-fprintf p "~a: compiling ~a" (cc-name cc) desc)]
-                                     desc (cc-name cc))]
                      [(p where)
                       ;; Doing something specifically in "where"
                       (setup-fprintf p "  in ~a"
-                                     (path->string
+                                     (path->name (path->complete-path
-                                      (path->complete-path where
+                                                  where (cc-path cc))))])
-                                                           (cc-path cc))))])
                    compile-directory
                    (list (cc-path cc) (cc-info cc)))
-            (setup-printf "No more ~a to compile for ~a"
+            (setup-printf "~a: all ~a done" (cc-name cc) desc))))
-                          desc (cc-name cc)))))
       (collect-garbage)))
 
   (define (with-specified-mode thunk)
@@ -754,7 +752,7 @@
                        info-path))
               (make-directory* base)
               (let ([p info-path])
-                (setup-printf "Updating ~a" p)
+                (setup-printf "Updating ~a" (path->name p))
                 (with-handlers ([exn:fail? (warning-handler (void))])
                   (with-output-to-file p
                     #:exists 'truncate/replace

collects/setup/xref.ss

@@ -3,7 +3,7 @@
 (require scribble/xref
          setup/getinfo
          scheme/fasl
-         "private/doc-path.ss")
+         "private/path-utils.ss")
 
 (provide load-collections-xref)