improved setup-plt printouts
svn: r9996
This commit is contained in:
Eli Barzilay
parent
8e217ad6c6
commit
8df91f2f10
|
|
@ -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)]))
|
||||
33
collects/setup/private/path-utils.ss
Normal file
33
collects/setup/private/path-utils.ss
Normal file
|
|
@ -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)))))
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
(require scribble/xref
|
||||
setup/getinfo
|
||||
scheme/fasl
|
||||
"private/doc-path.ss")
|
||||
"private/path-utils.ss")
|
||||
|
||||
(provide load-collections-xref)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user