diff --git a/collects/setup/private/doc-path.ss b/collects/setup/private/doc-path.ss deleted file mode 100644 index 41908d98ef..0000000000 --- a/collects/setup/private/doc-path.ss +++ /dev/null @@ -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)])) diff --git a/collects/setup/private/path-utils.ss b/collects/setup/private/path-utils.ss new file mode 100644 index 0000000000..3530443007 --- /dev/null +++ b/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))))) diff --git a/collects/setup/scribble.ss b/collects/setup/scribble.ss index cee568b9ac..97a71c46c7 100644 --- a/collects/setup/scribble.ss +++ b/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")) - (doc-src-file doc)) + (cond [up-to-date? "Using"] [can-run? "Running"] [else "Skipping"]) + (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) diff --git a/collects/setup/setup-unit.ss b/collects/setup/setup-unit.ss index 5f1fbc3d86..3d859ee278 100644 --- a/collects/setup/setup-unit.ss +++ b/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" - desc (cc-name cc))] + (setup-fprintf p "~a: compiling ~a" (cc-name cc) desc)] [(p where) ;; Doing something specifically in "where" (setup-fprintf p " in ~a" - (path->string - (path->complete-path where - (cc-path cc))))]) + (path->name (path->complete-path + where (cc-path cc))))]) compile-directory (list (cc-path cc) (cc-info cc))) - (setup-printf "No more ~a to compile for ~a" - desc (cc-name cc))))) + (setup-printf "~a: all ~a done" (cc-name cc) desc)))) (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 diff --git a/collects/setup/xref.ss b/collects/setup/xref.ss index 1b127664a2..41bf64eef6 100644 --- a/collects/setup/xref.ss +++ b/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)