suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

better handling of doc-build failures

Browse Source 
svn: r8504
This commit is contained in:
Matthew Flatt 2008-02-02 13:20:03 +00:00
parent 36aa1bd3f2
commit 3260e8f34a
2 changed files with 123 additions and 94 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

197
collects/setup/scribble.ss
View File

@ -21,7 +21,7 @@
(define-struct info (doc sci provides undef searches deps (define-struct info (doc sci provides undef searches deps
build? time out-time need-run? build? time out-time need-run?
need-in-write? need-out-write? need-in-write? need-out-write?
vers rendered?) vers rendered? failed?)
#:mutable) #:mutable)
(define (user-doc? doc) (define (user-doc? doc)
@ -51,9 +51,10 @@
(filter (lambda (doc) (not (user-doc? doc))) (filter (lambda (doc) (not (user-doc? doc)))
docs)]))))) docs)])))))
(define (setup-scribblings only-dirs ; limits doc builds (define (setup-scribblings only-dirs ; limits doc builds
latex-dest ; if not #f, generate Latex output latex-dest ; if not #f, generate Latex output
auto-start-doc?) ; if #t, expands `only-dir' with [user-]start to catch new docs auto-start-doc? ; if #t, expands `only-dir' with [user-]start to catch new docs
with-record-error) ; catch & record exceptions
(let* ([dirs (find-relevant-directories '(scribblings))] (let* ([dirs (find-relevant-directories '(scribblings))]
[infos (map get-info/full dirs)] [infos (map get-info/full dirs)]
[docs (map (lambda (i dir) [docs (map (lambda (i dir)
@ -118,10 +119,14 @@
(ormap (can-build? only-dirs) (ormap (can-build? only-dirs)
(filter (lambda (doc) (not (doc-under-main? doc))) (filter (lambda (doc) (not (doc-under-main? doc)))
docs)))] docs)))]
[infos (filter values (map (get-doc-info only-dirs latex-dest auto-main? auto-user?) [infos (filter values (map (get-doc-info only-dirs latex-dest
auto-main? auto-user? with-record-error)
docs))]) docs))])
(let loop ([first? #t] [iter 0]) (let loop ([first? #t] [iter 0])
(let ([ht (make-hash-table 'equal)]) (let ([ht (make-hash-table 'equal)]
[infos (filter (lambda (i)
(not (info-failed? i)))
infos)])
;; Collect definitions ;; Collect definitions
(for* ([info infos] (for* ([info infos]
[k (info-provides info)]) [k (info-provides info)])
@ -226,7 +231,7 @@
;; Build again, using dependencies ;; Build again, using dependencies
(for ([i infos] #:when (info-need-run? i)) (for ([i infos] #:when (info-need-run? i))
(set-info-need-run?! i #f) (set-info-need-run?! i #f)
(build-again! latex-dest i)) (build-again! latex-dest i with-record-error))
(loop #f (add1 iter))))) (loop #f (add1 iter)))))
;; cache info to disk ;; cache info to disk
(unless latex-dest (unless latex-dest
@ -296,7 +301,7 @@
(and (pair? cat) (and (pair? cat)
(eq? (car cat) 'omit)))) (eq? (car cat) 'omit))))
(define ((get-doc-info only-dirs latex-dest auto-main? auto-user?) doc) (define ((get-doc-info only-dirs latex-dest auto-main? auto-user? with-record-error) doc)
(let* ([info-out-file (build-path (or latex-dest (doc-dest-dir doc)) "out.sxref")] (let* ([info-out-file (build-path (or latex-dest (doc-dest-dir doc)) "out.sxref")]
[info-in-file (build-path (or latex-dest (doc-dest-dir doc)) "in.sxref")] [info-in-file (build-path (or latex-dest (doc-dest-dir doc)) "in.sxref")]
[out-file (build-path (doc-dest-dir doc) "index.html")] [out-file (build-path (doc-dest-dir doc) "index.html")]
@ -344,7 +349,8 @@
(fprintf (current-error-port) "~a\n" (exn-message exn)) (fprintf (current-error-port) "~a\n" (exn-message exn))
(delete-file info-out-file) (delete-file info-out-file)
(delete-file info-in-file) (delete-file info-in-file)
((get-doc-info only-dirs latex-dest auto-main? auto-user?) doc))]) ((get-doc-info only-dirs latex-dest auto-main? auto-user?
with-record-error) doc))])
(let* ([v-in (with-input-from-file info-in-file read)] (let* ([v-in (with-input-from-file info-in-file read)]
[v-out (with-input-from-file info-out-file read)]) [v-out (with-input-from-file info-out-file read)])
(unless (and (equal? (car v-in) (list vers (doc-flags doc))) (unless (and (equal? (car v-in) (list vers (doc-flags doc)))
@ -362,97 +368,112 @@
(memq 'always-run (doc-flags doc))) (memq 'always-run (doc-flags doc)))
#f #f #f #f
vers vers
#f
#f))) #f)))
(if can-run? (if can-run?
;; Run the doc once: ;; Run the doc once:
(parameterize ([current-directory (doc-src-dir doc)]) (with-record-error
(let* ([v (ensure-doc-prefix (dynamic-require-doc (doc-src-file doc)) (doc-src-file doc)
(doc-src-file doc))] (lambda ()
[dest-dir (pick-dest latex-dest doc)] (parameterize ([current-directory (doc-src-dir doc)])
[ci (send renderer collect (list v) (list dest-dir))] (let* ([v (ensure-doc-prefix (dynamic-require-doc (doc-src-file doc))
[ri (send renderer resolve (list v) (list dest-dir) ci)] (doc-src-file doc))]
[out-v (and info-out-time [dest-dir (pick-dest latex-dest doc)]
(with-handlers ([exn? (lambda (exn) #f)]) [ci (send renderer collect (list v) (list dest-dir))]
(let ([v (with-input-from-file info-out-file read)]) [ri (send renderer resolve (list v) (list dest-dir) ci)]
(unless (equal? (car v) (list vers (doc-flags doc))) [out-v (and info-out-time
(error "old info has wrong version or flags")) (with-handlers ([exn? (lambda (exn) #f)])
v)))] (let ([v (with-input-from-file info-out-file read)])
[sci (send renderer serialize-info ri)] (unless (equal? (car v) (list vers (doc-flags doc)))
[defs (send renderer get-defined ci)] (error "old info has wrong version or flags"))
[searches (resolve-info-searches ri)] v)))]
[need-out-write? [sci (send renderer serialize-info ri)]
(or (not (equal? (list (list vers (doc-flags doc)) sci defs) [defs (send renderer get-defined ci)]
out-v)) [searches (resolve-info-searches ri)]
(info-out-time . > . (current-seconds)))]) [need-out-write?
(when (and (verbose) need-out-write?) (or (not (equal? (list (list vers (doc-flags doc)) sci defs)
(fprintf (current-error-port) " [New out ~a]\n" (doc-src-file doc))) out-v))
(gc-point) (info-out-time . > . (current-seconds)))])
(make-info doc (when (and (verbose) need-out-write?)
sci (fprintf (current-error-port) " [New out ~a]\n" (doc-src-file doc)))
defs (gc-point)
(send renderer get-undefined ri) (make-info doc
searches sci
null ; no deps, yet defs
can-run? (send renderer get-undefined ri)
-inf.0 searches
(if need-out-write? null ; no deps, yet
(/ (current-inexact-milliseconds) 1000) can-run?
info-out-time) -inf.0
#t (if need-out-write?
can-run? need-out-write? (/ (current-inexact-milliseconds) 1000)
vers info-out-time)
#f))) #t
can-run? need-out-write?
vers
#f
#f))))
(lambda () #f))
#f)))) #f))))
(define (build-again! latex-dest info) (define (build-again! latex-dest info with-record-error)
(let* ([doc (info-doc info)] (let* ([doc (info-doc info)]
[renderer (make-renderer latex-dest doc)]) [renderer (make-renderer latex-dest doc)])
(printf " [R~aendering ~a]\n" (printf " [R~aendering ~a]\n"
(if (info-rendered? info) "e-r" "") (if (info-rendered? info) "e-r" "")
(doc-src-file doc)) (doc-src-file doc))
(set-info-rendered?! info #t) (set-info-rendered?! info #t)
(parameterize ([current-directory (doc-src-dir doc)]) (with-record-error
(let* ([v (ensure-doc-prefix (dynamic-require-doc (doc-src-file doc)) (doc-src-file doc)
(doc-src-file doc))] (lambda ()
[dest-dir (pick-dest latex-dest doc)] (parameterize ([current-directory (doc-src-dir doc)])
[ci (send renderer collect (list v) (list dest-dir))]) (let* ([v (ensure-doc-prefix (dynamic-require-doc (doc-src-file doc))
(for ([i (info-deps info)]) (doc-src-file doc))]
[dest-dir (pick-dest latex-dest doc)]
[ci (send renderer collect (list v) (list dest-dir))])
(for ([i (info-deps info)])
(send renderer deserialize-info (info-sci i) ci)) (send renderer deserialize-info (info-sci i) ci))
(let* ([ri (send renderer resolve (list v) (list dest-dir) ci)] (let* ([ri (send renderer resolve (list v) (list dest-dir) ci)]
[sci (send renderer serialize-info ri)] [sci (send renderer serialize-info ri)]
[defs (send renderer get-defined ci)] [defs (send renderer get-defined ci)]
[undef (send renderer get-undefined ri)] [undef (send renderer get-undefined ri)]
[in-delta? (not (equal? undef (info-undef info)))] [in-delta? (not (equal? undef (info-undef info)))]
[out-delta? (not (equal? (list sci defs) [out-delta? (not (equal? (list sci defs)
(list (info-sci info) (list (info-sci info)
(info-provides info))))]) (info-provides info))))])
(when (verbose) (when (verbose)
(printf " [~a~afor ~a]\n" (printf " [~a~afor ~a]\n"
(if in-delta? "New in " "") (if in-delta? "New in " "")
(cond [out-delta? "New out "] (cond [out-delta? "New out "]
[in-delta? ""] [in-delta? ""]
[else "No change "]) [else "No change "])
(doc-src-file doc))) (doc-src-file doc)))
(when out-delta? (when out-delta?
(set-info-out-time! info (/ (current-inexact-milliseconds) 1000))) (set-info-out-time! info (/ (current-inexact-milliseconds) 1000)))
(set-info-sci! info sci) (set-info-sci! info sci)
(set-info-provides! info defs) (set-info-provides! info defs)
(set-info-undef! info undef) (set-info-undef! info undef)
(when in-delta? (set-info-deps! info null)) ; recompute deps outside (when in-delta? (set-info-deps! info null)) ; recompute deps outside
(when (or out-delta? (info-need-out-write? info)) (when (or out-delta? (info-need-out-write? info))
(unless latex-dest (write-out info)) (unless latex-dest (write-out info))
(set-info-need-out-write?! info #f)) (set-info-need-out-write?! info #f))
(when in-delta? (set-info-need-in-write?! info #t)) (when in-delta? (set-info-need-in-write?! info #t))
(unless latex-dest (unless latex-dest
(let ([dir (doc-dest-dir doc)]) (let ([dir (doc-dest-dir doc)])
(unless (directory-exists? dir) (make-directory dir)) (unless (directory-exists? dir) (make-directory dir))
(for ([f (directory-list dir)] (for ([f (directory-list dir)]
#:when (regexp-match? #"[.]html$" (path-element->bytes f))) #:when (regexp-match? #"[.]html$" (path-element->bytes f)))
(delete-file (build-path dir f))))) (delete-file (build-path dir f)))))
(send renderer render (list v) (list dest-dir) ri) (with-record-error
(set-info-time! info (/ (current-inexact-milliseconds) 1000)) (doc-src-file doc)
(gc-point) (lambda ()
(void)))))) (send renderer render (list v) (list dest-dir) ri))
void)
(set-info-time! info (/ (current-inexact-milliseconds) 1000))
(gc-point)
(void)))))
(lambda ()
(set-info-failed?! info #t)))))
(define (gc-point) (define (gc-point)
;; Forcing a GC on document boundaries helps keep peak memory use down. ;; Forcing a GC on document boundaries helps keep peak memory use down.

20
collects/setup/setup-unit.ss
View File

@ -70,24 +70,28 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define errors null) (define errors null)
(define (record-error cc desc go) (define (record-error cc desc go fail-k)
(with-handlers ([exn:fail? (with-handlers ([exn:fail?
(lambda (x) (lambda (x)
(if (exn? x) (if (exn? x)
(fprintf (current-error-port) "~a\n" (exn-message x)) (fprintf (current-error-port) "~a\n" (exn-message x))
(fprintf (current-error-port) "~s\n" x)) (fprintf (current-error-port) "~s\n" x))
(set! errors (cons (list cc desc x) errors)))]) (set! errors (cons (list cc desc x) errors))
(fail-k))])
(go))) (go)))
(define-syntax begin-record-error (define-syntax begin-record-error
(syntax-rules () (syntax-rules ()
[(_ cc desc body ...) (record-error cc desc (lambda () body ...))])) [(_ cc desc body ...) (record-error cc desc (lambda () body ...) void)]))
(define (show-errors port) (define (show-errors port)
(for ([e (reverse errors)]) (for ([e (reverse errors)])
(let ([cc (car e)] (let ([cc (car e)]
[desc (cadr e)] [desc (cadr e)]
[x (caddr e)]) [x (caddr e)])
(setup-fprintf port "Error during ~a for ~a (~a)" (setup-fprintf port "Error during ~a for ~a"
desc (cc-name cc) (path->string (cc-path cc))) desc
(if (cc? cc)
(format "~a (~a)" (cc-name cc) (path->string (cc-path cc)))
cc))
(if (exn? x) (if (exn? x)
(setup-fprintf port " ~a" (exn-message x)) (setup-fprintf port " ~a" (exn-message x))
(setup-fprintf port " ~s" x))))) (setup-fprintf port " ~s" x)))))
@ -755,7 +759,11 @@
((doc:setup-scribblings) ((doc:setup-scribblings)
(if no-specific-collections? #f (map cc-path ccs-to-compile)) (if no-specific-collections? #f (map cc-path ccs-to-compile))
#f #f
(not (null? (archives)))))) (not (null? (archives)))
(lambda (what go alt)
(record-error what "Building docs"
go
alt)))))
(define (render-pdf file) (define (render-pdf file)
(define cmd (define cmd