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

* Improved code in setup/scribble

Browse Source 
* Made it avoid user mannuals if -U is specified

svn: r8787
This commit is contained in:
Eli Barzilay 2008-02-25 00:00:13 +00:00
parent bb34f747b6
commit c71f59b2f8
2 changed files with 294 additions and 328 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

275
collects/setup/scribble.ss
View File

@ -3,11 +3,11 @@
(require "getinfo.ss" (require "getinfo.ss"
"dirs.ss" "dirs.ss"
"private/doc-path.ss" "private/doc-path.ss"
"main-collects.ss"
scheme/class scheme/class
scheme/file scheme/file
scheme/fasl scheme/fasl
scheme/serialize scheme/serialize
setup/main-collects
scribble/base-render scribble/base-render
scribble/struct scribble/struct
scribble/manual ; really shouldn't be here... see dynamic-require-doc scribble/manual ; really shouldn't be here... see dynamic-require-doc
@ -30,105 +30,83 @@
(or (memq 'user-doc-root (doc-flags doc)) (or (memq 'user-doc-root (doc-flags doc))
(memq 'user-doc (doc-flags doc)))) (memq 'user-doc (doc-flags doc))))
(define (filter-user-start docs) (define (filter-user-docs docs make-user?)
;; If we've built user-specific before... (define (filtered) (filter (lambda (doc) (not (user-doc? doc))) docs))
(if (file-exists? (build-path (find-user-doc-dir) "index.html")) (cond ;; Specifically disabled user stuff, filter
;; Keep building: [(not make-user?) (filtered)]
docs ;; If we've built user-specific before, keep building
[(file-exists? (build-path (find-user-doc-dir) "index.html")) docs]
;; Otherwise, see if we need it: ;; Otherwise, see if we need it:
(let ([cnt-not-main (apply + [(ormap (lambda (doc)
(map (lambda (doc) (not (or (doc-under-main? doc)
(if (or (doc-under-main? doc) (memq 'no-depend-on (doc-flags doc)))))
(memq 'no-depend-on (doc-flags doc))) docs)
0
1))
docs))])
(let ([any-not-main? (positive? cnt-not-main)])
(cond
[any-not-main?
;; Need user-specific:
docs] docs]
[else [else (filtered)])) ; Don't need them, so drop them
;; Don't need them, so drop them:
(filter (lambda (doc) (not (user-doc? doc)))
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
make-user? ; are we making user stuff?
with-record-error) ; catch & record exceptions with-record-error) ; catch & record exceptions
(let* ([dirs (find-relevant-directories '(scribblings))] (define (scribblings-flag? sym)
[infos (map get-info/full dirs)] (memq sym '(main-doc main-doc-root user-doc-root user-doc multi-page
[docs (map (lambda (i dir) depends-all depends-all-main no-depend-on always-run)))
(let ([s (i 'scribblings)]) (define (validate-scribblings-infos infos dir)
(if (and (list? s) (define (validate path [flags '()] [name #f])
(andmap (lambda (v) (and (string? path) (relative-path? path)
(and (list? v) (list? flags) (andmap scribblings-flag? flags)
(<= 1 (length v) 3) (or (not name) (and (path-string? name) (relative-path? name) name))
(string? (car v)) (list path flags
(relative-path? (car v)) (or name (let-values ([(_1 name _2) (split-path path)])
(or (null? (cdr v)) (path-replace-suffix name #""))))))
(and (list? (cadr v)) (and (list? infos)
(andmap (lambda (i) (let ([infos (map (lambda (i)
(member i '(main-doc (and (list? i) (<= 1 (length i) 3)
main-doc-root (apply validate i)))
user-doc-root infos)])
user-doc (and (not (memq #f infos)) infos))))
multi-page (define (get-docs i dir)
depends-all (let ([s (validate-scribblings-infos (i 'scribblings) dir)])
depends-all-main (if s
no-depend-on
always-run)))
(cadr v))
(or (null? (cddr v))
(and (path-string? (caddr v))
(relative-path? (caddr v))))))))
s))
(map (lambda (d cat) (map (lambda (d cat)
(let* ([flags (if (pair? (cdr d)) (cadr d) null)] (let* ([flags (cadr d)]
[under-main? (and (not (memq 'main-doc-root flags)) [under-main?
(and (not (memq 'main-doc-root flags))
(not (memq 'user-doc-root flags)) (not (memq 'user-doc-root flags))
(not (memq 'user-doc flags)) (not (memq 'user-doc flags))
(or (memq 'main-doc flags) (or (memq 'main-doc flags)
(pair? (path->main-collects-relative dir))))]) (pair? (path->main-collects-relative dir))))])
(make-doc dir (make-doc dir
(build-path dir (car d)) (build-path dir (car d))
(let ([name (if (and (pair? (cdr d)) (doc-path dir (caddr d) flags)
(pair? (cddr d)) flags under-main? cat)))
(caddr d))
(cadr d)
(let-values ([(base name dir?) (split-path (car d))])
(path-replace-suffix name #"")))])
(doc-path dir name flags))
flags
under-main?
cat)))
s s
(i 'doc-categories (lambda () (map (lambda (a) 'library) s)))) (i 'doc-categories (lambda () (map (lambda (a) 'library) s))))
(begin (begin (fprintf (current-error-port)
(fprintf (current-error-port) " bad 'scribblings info: ~e from: ~e\n" s dir)
" bad 'scribblings info: ~e from: ~e\n"
s
dir)
null)))) null))))
infos dirs)] (define docs
[docs (filter-user-start (apply append docs))]) (let* ([dirs (find-relevant-directories '(scribblings))]
(when (ormap (can-build? only-dirs) docs) [infos (map get-info/full dirs)])
(let* ([auto-main? (and auto-start-doc? (filter-user-docs (apply append (map get-docs infos dirs)) make-user?)))
(ormap (can-build? only-dirs) (define main-docs (filter doc-under-main? docs))
(filter doc-under-main? docs)))] (define user-docs (filter (lambda (d) (not (doc-under-main? d))) docs))
[auto-user? (and auto-start-doc? (define (can-build*? docs) (can-build? only-dirs docs))
(ormap (can-build? only-dirs) (define auto-main? (and auto-start-doc? (ormap can-build*? main-docs)))
(filter (lambda (doc) (not (doc-under-main? doc))) (define auto-user? (and auto-start-doc? (ormap can-build*? user-docs)))
docs)))] (define infos
[infos (filter values (map (get-doc-info only-dirs latex-dest (and (ormap can-build*? docs)
auto-main? auto-user? with-record-error) (filter values
docs))]) (map (get-doc-info only-dirs latex-dest auto-main? auto-user?
(let loop ([first? #t] [iter 0]) with-record-error)
docs))))
(define (make-loop first? iter)
(let ([ht (make-hash-table 'equal)] (let ([ht (make-hash-table 'equal)]
[infos (filter (lambda (i) [infos (filter (lambda (i) (not (info-failed? i))) infos)]
(not (info-failed? i))) [src->info (make-hash-table 'equal)])
infos)])
;; Collect definitions ;; Collect definitions
(for* ([info infos] (for* ([info infos]
[k (info-provides info)]) [k (info-provides info)])
@ -141,71 +119,59 @@
(doc-src-file (info-doc info)))) (doc-src-file (info-doc info))))
(hash-table-put! ht k info))) (hash-table-put! ht k info)))
;; Build deps: ;; Build deps:
(let ([src->info (make-hash-table 'equal)])
(for ([i infos]) (for ([i infos])
(hash-table-put! src->info (doc-src-file (info-doc i)) i)) (hash-table-put! src->info (doc-src-file (info-doc i)) i))
(for ([info infos] (for ([info infos] #:when (info-build? info))
#:when (info-build? info))
(let ([one? #f] (let ([one? #f]
[added? #f] [added? #f]
[deps (make-hash-table)]) [deps (make-hash-table)]
[all-main? (memq 'depends-all-main (doc-flags (info-doc info)))])
(set-info-deps! (set-info-deps!
info info
(map (lambda (d) (map (lambda (d)
(if (info? d) (if (info? d) d (or (hash-table-get src->info d #f) d)))
d
(or (hash-table-get src->info d #f)
d)))
(info-deps info))) (info-deps info)))
(for ([d (info-deps info)]) (for ([d (info-deps info)])
(let ([i (if (info? d) (let ([i (if (info? d) d (hash-table-get src->info d #f))])
d
(hash-table-get src->info d #f))])
(if i (if i
(hash-table-put! deps i #t) (hash-table-put! deps i #t)
(unless (or (memq 'depends-all (doc-flags (info-doc info))) (unless
(or (memq 'depends-all (doc-flags (info-doc info)))
(and (if (info? d) (and (if (info? d)
(doc-under-main? (info-doc d)) (doc-under-main? (info-doc d))
(not (path? (path->main-collects-relative d)))) (not (path? (path->main-collects-relative d))))
(memq 'depends-all-main (doc-flags (info-doc info))))) all-main?))
(set! added? #t) (set! added? #t)
(when (verbose) (when (verbose)
(printf " [Removed Dependency: ~a]\n" (printf " [Removed Dependency: ~a]\n"
(doc-src-file (info-doc info)))))))) (doc-src-file (info-doc info))))))))
(let ([all-main? (memq 'depends-all-main (doc-flags (info-doc info)))]) (when (or (memq 'depends-all (doc-flags (info-doc info))) all-main?)
(when (or (memq 'depends-all (doc-flags (info-doc info)))
all-main?)
;; Add all: ;; Add all:
(when (verbose) (when (verbose)
(printf " [Adding all~a as dependencies: ~a]\n" (printf " [Adding all~a as dependencies: ~a]\n"
(if all-main? " main" "") (if all-main? " main" "")
(doc-src-file (info-doc info)))) (doc-src-file (info-doc info))))
(for ([i infos]) (for ([i infos])
(unless (eq? i info) (when (and (not (eq? i info))
(when (not (hash-table-get deps i #f)) (not (hash-table-get deps i #f))
(when (and (or (not all-main?) (or (not all-main?) (doc-under-main? (info-doc i)))
(doc-under-main? (info-doc i)))
(not (memq 'no-depend-on (doc-flags (info-doc i))))) (not (memq 'no-depend-on (doc-flags (info-doc i)))))
(set! added? #t) (set! added? #t)
(hash-table-put! deps i #t))))))) (hash-table-put! deps i #t))))
(let ([not-found (let ([not-found
(lambda (k) (lambda (k)
(unless one? (unless one?
(fprintf (current-error-port) (fprintf (current-error-port)
"In ~a:\n" "In ~a:\n" (doc-src-file (info-doc info)))
(doc-src-file (info-doc info)))
(set! one? #t)) (set! one? #t))
(fprintf (current-error-port) (fprintf (current-error-port) " undefined tag: ~s\n" k))])
" undefined tag: ~s\n"
k))])
(for ([k (info-undef info)]) (for ([k (info-undef info)])
(let ([i (hash-table-get ht k #f)]) (let ([i (hash-table-get ht k #f)])
(if i (if i
(when (not (hash-table-get deps i #f)) (when (not (hash-table-get deps i #f))
(set! added? #t) (set! added? #t)
(hash-table-put! deps i #t)) (hash-table-put! deps i #t))
(when first? (when first? (unless (eq? (car k) 'dep) (not-found k))))))
(unless (eq? (car k) 'dep) (not-found k))))))
(when first? (when first?
(for ([(s-key s-ht) (info-searches info)]) (for ([(s-key s-ht) (info-searches info)])
(unless (ormap (lambda (k) (hash-table-get ht k #f)) (unless (ormap (lambda (k) (hash-table-get ht k #f))
@ -217,7 +183,7 @@
(doc-src-file (info-doc info)))) (doc-src-file (info-doc info))))
(set-info-deps! info (hash-table-map deps (lambda (k v) k))) (set-info-deps! info (hash-table-map deps (lambda (k v) k)))
(set-info-need-in-write?! info #t) (set-info-need-in-write?! info #t)
(set-info-need-run?! info #t))))) (set-info-need-run?! info #t))))
;; If a dependency changed, then we need a re-run: ;; If a dependency changed, then we need a re-run:
(for ([i infos] (for ([i infos]
#:when (not (or (info-need-run? i) (not (info-build? i))))) #:when (not (or (info-need-run? i) (not (info-build? i)))))
@ -236,46 +202,43 @@
(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 with-record-error)) (build-again! latex-dest i with-record-error))
(loop #f (add1 iter))))) (make-loop #f (add1 iter)))))
(when infos
(make-loop #t 0)
;; cache info to disk ;; cache info to disk
(unless latex-dest (unless latex-dest
(for ([i infos] #:when (info-need-in-write? i)) (for ([i infos] #:when (info-need-in-write? i)) (write-in i)))))
(write-in i)))))))
(define (make-renderer latex-dest doc) (define (make-renderer latex-dest doc)
(if latex-dest (if latex-dest
(new (latex:render-mixin render%) (new (latex:render-mixin render%)
[dest-dir latex-dest]) [dest-dir latex-dest])
(new ((if (memq 'multi-page (doc-flags doc)) html:render-multi-mixin values) (let ([multi? (memq 'multi-page (doc-flags doc))]
[main? (doc-under-main? doc)]
[ddir (doc-dest-dir doc)])
(new ((if multi? html:render-multi-mixin values)
(html:render-mixin render%)) (html:render-mixin render%))
[dest-dir (if (memq 'multi-page (doc-flags doc)) [dest-dir (if multi?
(let-values ([(base name dir?) (split-path (doc-dest-dir doc))]) (let-values ([(base name dir?) (split-path ddir)]) base)
base) ddir)]
(doc-dest-dir doc))] [css-path (and main? "../scribble.css")]
[css-path (if (doc-under-main? doc) [up-path (and main? "../index.html")]))))
"../scribble.css"
#f)]
[up-path (if (doc-under-main? doc)
"../index.html"
#f)])))
(define (pick-dest latex-dest doc) (define (pick-dest latex-dest doc)
(if latex-dest (cond [latex-dest
(build-path latex-dest (let-values ([(base name dir?) (split-path (doc-src-file doc))]) (let-values ([(base name dir?) (split-path (doc-src-file doc))])
(path-replace-suffix name #".tex"))) (build-path latex-dest (path-replace-suffix name #".tex")))]
(if (memq 'multi-page (doc-flags doc)) [(memq 'multi-page (doc-flags doc)) (doc-dest-dir doc)]
(doc-dest-dir doc) [else (build-path (doc-dest-dir doc) "index.html")]))
(build-path (doc-dest-dir doc) "index.html"))))
(define ((can-build? only-dirs) doc) (define (can-build? only-dirs doc)
(or (not only-dirs) (or (not only-dirs)
(ormap (lambda (d) (ormap (lambda (d)
(let ([d (path->directory-path d)]) (let ([d (path->directory-path d)])
(let loop ([dir (path->directory-path (doc-src-dir doc))]) (let loop ([dir (path->directory-path (doc-src-dir doc))])
(or (equal? dir d) (or (equal? dir d)
(let-values ([(base name dir?) (split-path dir)]) (let-values ([(base name dir?) (split-path dir)])
(and (path? base) (and (path? base) (loop base)))))))
(loop base)))))))
only-dirs))) only-dirs)))
(define (ensure-doc-prefix v src-file) (define (ensure-doc-prefix v src-file)
@ -291,7 +254,8 @@
[tags (if (member '(part "top") (part-tags v)) [tags (if (member '(part "top") (part-tags v))
(part-tags v) (part-tags v)
(cons '(part "top") (part-tags v)))]) (cons '(part "top") (part-tags v)))])
(make-versioned-part tag-prefix (make-versioned-part
tag-prefix
tags tags
(part-title-content v) (part-title-content v)
(part-style v) (part-style v)
@ -309,14 +273,16 @@
(define (read-out-sxref) (define (read-out-sxref)
(fasl->s-exp (current-input-port))) (fasl->s-exp (current-input-port)))
(define ((get-doc-info only-dirs latex-dest auto-main? auto-user? with-record-error) 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")]
[src-zo (let-values ([(base name dir?) (split-path (doc-src-file doc))]) [src-zo (let-values ([(base name dir?) (split-path (doc-src-file doc))])
(build-path base "compiled" (path-add-suffix name ".zo")))] (build-path base "compiled" (path-add-suffix name ".zo")))]
[renderer (make-renderer latex-dest doc)] [renderer (make-renderer latex-dest doc)]
[can-run? ((can-build? only-dirs) doc)] [can-run? (can-build? only-dirs doc)]
[aux-time (max (file-or-directory-modify-seconds [aux-time (max (file-or-directory-modify-seconds
(build-path (collection-path "scribble") (build-path (collection-path "scribble")
"compiled" "compiled"
@ -357,14 +323,16 @@
(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? ((get-doc-info only-dirs latex-dest auto-main?
with-record-error) doc))]) 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-out-sxref)]) [v-out (with-input-from-file info-out-file read-out-sxref)])
(unless (and (equal? (car v-in) (list vers (doc-flags doc))) (unless (and (equal? (car v-in) (list vers (doc-flags doc)))
(equal? (car v-out) (list vers (doc-flags doc)))) (equal? (car v-out) (list vers (doc-flags doc))))
(error "old info has wrong version or flags")) (error "old info has wrong version or flags"))
(make-info doc (make-info
doc
(list-ref v-out 1) ; sci (list-ref v-out 1) ; sci
(list-ref v-out 2) ; provides (list-ref v-out 2) ; provides
(let ([v (list-ref v-in 1)]) ; undef (let ([v (list-ref v-in 1)]) ; undef
@ -380,8 +348,7 @@
(map rel->path (list-ref v-in 2)) ; deps, in case we don't need to build... (map rel->path (list-ref v-in 2)) ; deps, in case we don't need to build...
can-run? can-run?
my-time info-out-time my-time info-out-time
(and can-run? (and can-run? (memq 'always-run (doc-flags doc)))
(memq 'always-run (doc-flags doc)))
#f #f #f #f
vers vers
#f #f
@ -392,7 +359,8 @@
(doc-src-file doc) (doc-src-file doc)
(lambda () (lambda ()
(parameterize ([current-directory (doc-src-dir doc)]) (parameterize ([current-directory (doc-src-dir doc)])
(let* ([v (ensure-doc-prefix (dynamic-require-doc (doc-src-file doc)) (let* ([v (ensure-doc-prefix
(dynamic-require-doc (doc-src-file doc))
(doc-src-file doc))] (doc-src-file doc))]
[dest-dir (pick-dest latex-dest doc)] [dest-dir (pick-dest latex-dest doc)]
[ci (send renderer collect (list v) (list dest-dir))] [ci (send renderer collect (list v) (list dest-dir))]
@ -433,10 +401,9 @@
#f)))) #f))))
(define (build-again! latex-dest info with-record-error) (define (build-again! latex-dest info with-record-error)
(let* ([doc (info-doc info)] (define doc (info-doc info))
[renderer (make-renderer latex-dest doc)]) (define 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)
(with-record-error (with-record-error
@ -482,14 +449,12 @@
(delete-file (build-path dir f))))) (delete-file (build-path dir f)))))
(with-record-error (with-record-error
(doc-src-file doc) (doc-src-file doc)
(lambda () (lambda () (send renderer render (list v) (list dest-dir) ri))
(send renderer render (list v) (list dest-dir) ri))
void) void)
(set-info-time! info (/ (current-inexact-milliseconds) 1000)) (set-info-time! info (/ (current-inexact-milliseconds) 1000))
(gc-point) (gc-point)
(void))))) (void)))))
(lambda () (lambda () (set-info-failed?! info #t))))
(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.
@ -498,8 +463,8 @@
(define-namespace-anchor anchor) (define-namespace-anchor anchor)
(define (dynamic-require-doc path) (define (dynamic-require-doc path)
;; Use a separate namespace so that we don't end up with all the documentation ;; Use a separate namespace so that we don't end up with all the
;; loaded at once. ;; documentation loaded at once.
;; Use a custodian to compensate for examples executed during the build ;; Use a custodian to compensate for examples executed during the build
;; that may not be entirely clean (e.g., leaves a stuck thread). ;; that may not be entirely clean (e.g., leaves a stuck thread).
(let ([p (make-empty-namespace)] (let ([p (make-empty-namespace)]

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

@ -756,6 +756,7 @@
(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)))
(make-user)
(lambda (what go alt) (record-error what "Building docs" go alt))))) (lambda (what go alt) (record-error what "Building docs" go alt)))))
(define (render-pdf file) (define (render-pdf file)