420 lines
22 KiB
Scheme
420 lines
22 KiB
Scheme
|
|
(module scribble scheme/base
|
|
(require "getinfo.ss"
|
|
"dirs.ss"
|
|
scheme/class
|
|
scheme/file
|
|
setup/main-collects
|
|
scribble/base-render
|
|
scribble/struct
|
|
syntax/namespace-reflect
|
|
scribble/manual ; really shouldn't be here... see dynamic-require-doc
|
|
(prefix-in html: scribble/html-render)
|
|
(prefix-in latex: scribble/latex-render))
|
|
|
|
(provide setup-scribblings
|
|
verbose)
|
|
|
|
(define verbose (make-parameter #t))
|
|
|
|
(define-struct doc (src-dir src-file dest-dir flags))
|
|
(define-struct info (doc sci provides undef deps
|
|
build? time out-time need-run?
|
|
need-in-write? need-out-write?
|
|
vers rendered?)
|
|
#:mutable)
|
|
|
|
(define (setup-scribblings only-dirs latex-dest)
|
|
(let* ([dirs (find-relevant-directories '(scribblings))]
|
|
[infos (map get-info/full dirs)]
|
|
[docs (apply
|
|
append
|
|
(map (lambda (i dir)
|
|
(let ([s (i 'scribblings)])
|
|
(if (and (list? s)
|
|
(andmap (lambda (v)
|
|
(and (list? v)
|
|
(<= 1 (length v) 3)
|
|
(string? (car v))
|
|
(relative-path? (car v))
|
|
(or (null? (cdr v))
|
|
(and (and (list? (cadr v))
|
|
(andmap (lambda (i)
|
|
(member i '(main-doc
|
|
multi-page)))
|
|
(cadr v)))
|
|
(or (null? (cddr v))
|
|
(and (path-string? (caddr v))
|
|
(relative-path? (caddr v))))))))
|
|
s))
|
|
(map (lambda (d)
|
|
(let ([flags (if (pair? (cdr d))
|
|
(cadr d)
|
|
null)])
|
|
(make-doc dir
|
|
(build-path dir (car d))
|
|
(let ([name (if (and (pair? (cdr d))
|
|
(pair? (cddr d))
|
|
(caddr d))
|
|
(cadr d)
|
|
(let-values ([(base name dir?) (split-path (car d))])
|
|
(path-replace-suffix name #"")))])
|
|
(if (memq 'main-doc flags)
|
|
(build-path (find-doc-dir) name)
|
|
(build-path dir "compiled" "doc" name)))
|
|
flags)))
|
|
s)
|
|
(begin
|
|
(fprintf (current-error-port)
|
|
" bad 'scribblings info: ~e from: ~e\n"
|
|
s
|
|
dir)
|
|
null))))
|
|
infos dirs))])
|
|
(when (ormap (can-build? only-dirs) docs)
|
|
(let ([infos (map (get-doc-info only-dirs latex-dest) docs)])
|
|
(let loop ([first? #t][iter 0])
|
|
(let ([ht (make-hash-table 'equal)])
|
|
;; Collect definitions
|
|
(for-each (lambda (info)
|
|
(for-each (lambda (k)
|
|
(let ([prev (hash-table-get ht k #f)])
|
|
(when (and first? prev)
|
|
(fprintf (current-error-port)
|
|
"DUPLICATE tag: ~s\n in: ~a\n and: ~a\n"
|
|
k
|
|
(doc-src-file (info-doc prev))
|
|
(doc-src-file (info-doc info))))
|
|
(hash-table-put! ht k info)))
|
|
(info-provides info)))
|
|
infos)
|
|
;; Build deps:
|
|
(let ([src->info (make-hash-table 'equal)])
|
|
(for-each (lambda (i)
|
|
(hash-table-put! src->info (doc-src-file (info-doc i)) i))
|
|
infos)
|
|
(for-each (lambda (info)
|
|
(when (info-build? info)
|
|
(let ([one? #f]
|
|
[added? #f]
|
|
[deps (make-hash-table)])
|
|
(set-info-deps! info
|
|
(map (lambda (d)
|
|
(let ([i (if (info? d)
|
|
d
|
|
(hash-table-get src->info d #f))])
|
|
(or i d)))
|
|
(info-deps info)))
|
|
(for-each (lambda (d)
|
|
(let ([i (if (info? d)
|
|
d
|
|
(hash-table-get src->info d #f))])
|
|
(if i
|
|
(hash-table-put! deps i #t)
|
|
(begin
|
|
(set! added? #t)
|
|
(when (verbose)
|
|
(printf " [Removed Dependency: ~a]\n"
|
|
(doc-src-file (info-doc info))))))))
|
|
(info-deps info))
|
|
(for-each (lambda (k)
|
|
(let ([i (hash-table-get ht k #f)])
|
|
(if i
|
|
(when (not (hash-table-get deps i #f))
|
|
(set! added? #t)
|
|
(hash-table-put! deps i #t))
|
|
(when first?
|
|
(unless one?
|
|
(fprintf (current-error-port)
|
|
"In ~a:\n"
|
|
(doc-src-file (info-doc info)))
|
|
(set! one? #t))
|
|
(fprintf (current-error-port)
|
|
" undefined tag: ~s\n"
|
|
k)))))
|
|
(info-undef info))
|
|
(when added?
|
|
(when (verbose)
|
|
(printf " [Added Dependency: ~a]\n"
|
|
(doc-src-file (info-doc info))))
|
|
(set-info-deps! info (hash-table-map deps (lambda (k v) k)))
|
|
(set-info-need-run?! info #t)))))
|
|
infos))
|
|
;; If a dependency changed, then we need a re-run:
|
|
(for-each (lambda (i)
|
|
(unless (or (info-need-run? i)
|
|
(not (info-build? i)))
|
|
(let ([ch (ormap (lambda (i2)
|
|
(and (>= (info-out-time i2)
|
|
(info-time i))
|
|
i2))
|
|
(info-deps i))])
|
|
(when ch
|
|
(when (verbose)
|
|
(printf " [Dependency: ~a\n <- ~a]\n"
|
|
(doc-src-file (info-doc i))
|
|
(doc-src-file (info-doc ch))))
|
|
(set-info-need-run?! i #t)))))
|
|
infos)
|
|
;; Iterate, if any need to run:
|
|
(when (and (ormap info-need-run? infos)
|
|
(iter . < . 30))
|
|
;; Build again, using dependencies
|
|
(for-each (lambda (i)
|
|
(when (info-need-run? i)
|
|
(set-info-need-run?! i #f)
|
|
(build-again! latex-dest i)))
|
|
infos)
|
|
(loop #f (add1 iter)))))
|
|
;; cache info to disk
|
|
(unless latex-dest
|
|
(for-each (lambda (i)
|
|
(when (info-need-in-write? i)
|
|
(write-in i)))
|
|
infos))))))
|
|
|
|
(define (make-renderer latex-dest doc)
|
|
(if latex-dest
|
|
(new (latex:render-mixin render%)
|
|
[dest-dir latex-dest])
|
|
(new ((if (memq 'multi-page (doc-flags doc))
|
|
html:render-multi-mixin
|
|
values)
|
|
(html:render-mixin render%))
|
|
[dest-dir (if (memq 'multi-page (doc-flags doc))
|
|
(let-values ([(base name dir?) (split-path (doc-dest-dir doc))])
|
|
base)
|
|
(doc-dest-dir doc))])))
|
|
|
|
(define (pick-dest latex-dest doc)
|
|
(if latex-dest
|
|
(build-path latex-dest (let-values ([(base name dir?) (split-path (doc-src-file doc))])
|
|
(path-replace-suffix name #".tex")))
|
|
(if (memq 'multi-page (doc-flags doc))
|
|
(doc-dest-dir doc)
|
|
(build-path (doc-dest-dir doc) "index.html"))))
|
|
|
|
(define ((can-build? only-dirs) doc)
|
|
(or (not only-dirs)
|
|
(ormap (lambda (d)
|
|
(let ([d (path->directory-path d)])
|
|
(let loop ([dir (path->directory-path (doc-src-dir doc))])
|
|
(or (equal? dir d)
|
|
(let-values ([(base name dir?) (split-path dir)])
|
|
(and (path? base)
|
|
(loop base)))))))
|
|
only-dirs)))
|
|
|
|
(define (ensure-doc-prefix! src-file v)
|
|
(let ([p (format "~a"
|
|
(path->main-collects-relative src-file))])
|
|
(if (part-tag-prefix v)
|
|
(unless (equal? p
|
|
(part-tag-prefix v))
|
|
(error 'setup
|
|
"bad tag prefix: ~e for: ~a expected: ~e"
|
|
(part-tag-prefix v)
|
|
src-file
|
|
p))
|
|
(set-part-tag-prefix! v p))
|
|
(unless (member '(part "top") (part-tags v))
|
|
(set-part-tags! v (cons '(part "top") (part-tags v))))))
|
|
|
|
(define ((get-doc-info only-dirs latex-dest) doc)
|
|
(let ([info-out-file (build-path (or latex-dest (doc-dest-dir doc)) "xref-out.ss")]
|
|
[info-in-file (build-path (or latex-dest (doc-dest-dir doc)) "xref-in.ss")]
|
|
[out-file (build-path (doc-dest-dir doc) "index.html")]
|
|
[src-zo (let-values ([(base name dir?) (split-path (doc-src-file doc))])
|
|
(build-path base "compiled" (path-add-suffix name ".zo")))]
|
|
[renderer (make-renderer latex-dest doc)]
|
|
[can-run? ((can-build? only-dirs) doc)])
|
|
(let ([my-time (file-or-directory-modify-seconds out-file #f (lambda () -inf.0))]
|
|
[info-out-time (file-or-directory-modify-seconds info-out-file #f (lambda () #f))]
|
|
[info-in-time (file-or-directory-modify-seconds info-in-file #f (lambda () #f))]
|
|
[vers (send renderer get-serialize-version)])
|
|
(let ([up-to-date?
|
|
(and info-out-time
|
|
info-in-time
|
|
(or (not can-run?)
|
|
(my-time
|
|
. >= .
|
|
(file-or-directory-modify-seconds src-zo #f (lambda () +inf.0)))))])
|
|
(printf " [~a ~a]\n"
|
|
(if up-to-date? "Using" "Running")
|
|
(doc-src-file doc))
|
|
(if up-to-date?
|
|
;; Load previously calculated info:
|
|
(with-handlers ([exn? (lambda (exn)
|
|
(fprintf (current-error-port)
|
|
"~a\n"
|
|
(exn-message exn))
|
|
(delete-file info-out-file)
|
|
(delete-file info-in-file)
|
|
((get-doc-info only-dirs latex-dest) doc))])
|
|
(let* ([v-in (with-input-from-file info-in-file read)]
|
|
[v-out (with-input-from-file info-out-file read)])
|
|
(unless (and (equal? (car v-in) (list vers (doc-flags doc)))
|
|
(equal? (car v-out) (list vers (doc-flags doc))))
|
|
(error "old info has wrong version or flags"))
|
|
(make-info doc
|
|
(list-ref v-out 1) ; sci
|
|
(list-ref v-out 2) ; provides
|
|
(list-ref v-in 1) ; undef
|
|
(map string->path (list-ref v-in 2)) ; deps, in case we don't need to build...
|
|
can-run?
|
|
my-time info-out-time #f
|
|
#f #f
|
|
vers
|
|
#f)))
|
|
;; Run the doc once:
|
|
(parameterize ([current-directory (doc-src-dir doc)])
|
|
(let ([v (dynamic-require-doc (doc-src-file doc))]
|
|
[dest-dir (pick-dest latex-dest doc)])
|
|
(ensure-doc-prefix! (doc-src-file doc) v)
|
|
(let* ([ci (send renderer collect (list v) (list dest-dir))])
|
|
(let ([ri (send renderer resolve (list v) (list dest-dir) ci)]
|
|
[out-v (and info-out-time
|
|
(with-handlers ([exn? (lambda (exn) #f)])
|
|
(let ([v (with-input-from-file info-out-file read)])
|
|
(unless (equal? (car v) (list vers (doc-flags doc)))
|
|
(error "old info has wrong version or flags"))
|
|
v)))])
|
|
(let ([sci (send renderer serialize-info ri)]
|
|
[defs (send renderer get-defined ci)])
|
|
(let ([need-out-write?
|
|
(or (not (equal? (list (list vers (doc-flags doc)) sci defs)
|
|
out-v))
|
|
(info-out-time . > . (current-seconds)))])
|
|
(when (verbose)
|
|
(when need-out-write?
|
|
(fprintf (current-error-port)
|
|
" [New out ~a]\n"
|
|
(doc-src-file doc))))
|
|
(make-info doc
|
|
sci
|
|
defs
|
|
(send renderer get-undefined ri)
|
|
null ; no deps, yet
|
|
can-run?
|
|
-inf.0
|
|
(if need-out-write?
|
|
(/ (current-inexact-milliseconds) 1000)
|
|
info-out-time)
|
|
#t
|
|
can-run? need-out-write?
|
|
vers
|
|
#f))))))))))))
|
|
|
|
(define (build-again! latex-dest info)
|
|
(let* ([doc (info-doc info)]
|
|
[renderer (make-renderer latex-dest doc)])
|
|
(printf " [R~aendering ~a]\n"
|
|
(if (info-rendered? info)
|
|
"e-r"
|
|
"")
|
|
(doc-src-file doc))
|
|
(set-info-rendered?! info #t)
|
|
(parameterize ([current-directory (doc-src-dir doc)])
|
|
(let ([v (dynamic-require-doc (doc-src-file doc))]
|
|
[dest-dir (pick-dest latex-dest doc)])
|
|
(ensure-doc-prefix! (doc-src-file doc) v)
|
|
(let* ([ci (send renderer collect (list v) (list dest-dir))])
|
|
(for-each (lambda (i)
|
|
(send renderer deserialize-info (info-sci i) ci))
|
|
(info-deps info))
|
|
(let ([ri (send renderer resolve (list v) (list dest-dir) ci)])
|
|
(let ([sci (send renderer serialize-info ri)]
|
|
[defs (send renderer get-defined ci)]
|
|
[undef (send renderer get-undefined ri)])
|
|
(let ([in-delta? (not (equal? undef (info-undef info)))]
|
|
[out-delta? (not (equal? (list sci defs)
|
|
(list (info-sci info)
|
|
(info-provides info))))])
|
|
(when (verbose)
|
|
(printf " [~a~afor ~a]\n"
|
|
(if in-delta?
|
|
"New in "
|
|
"")
|
|
(if out-delta?
|
|
"New out "
|
|
(if in-delta?
|
|
""
|
|
"No change "))
|
|
(doc-src-file doc)))
|
|
(when out-delta?
|
|
(set-info-out-time! info (/ (current-inexact-milliseconds) 1000)))
|
|
(set-info-sci! info sci)
|
|
(set-info-provides! info defs)
|
|
(set-info-undef! info undef)
|
|
(when in-delta?
|
|
(set-info-deps! info null)) ; recompute deps outside
|
|
(when (or out-delta?
|
|
(info-need-out-write? info))
|
|
(unless latex-dest
|
|
(write-out info))
|
|
(set-info-need-out-write?! info #f))
|
|
(when in-delta?
|
|
(set-info-need-in-write?! info #t))
|
|
(unless latex-dest
|
|
(let ([dir (doc-dest-dir doc)])
|
|
(unless (directory-exists? dir)
|
|
(make-directory dir))
|
|
(for-each (lambda (f)
|
|
(when (regexp-match? #"[.]html$" (path-element->bytes f))
|
|
(delete-file (build-path dir f))))
|
|
(directory-list dir))))
|
|
(send renderer render (list v) (list dest-dir) ri)
|
|
(set-info-time! info (/ (current-inexact-milliseconds) 1000))
|
|
(void)))))))))
|
|
|
|
(define-reflection-anchor anchor)
|
|
|
|
(define (dynamic-require-doc path)
|
|
;; Use a separate namespace so that we don't end up with all the documentation
|
|
;; loaded at once.
|
|
;; Use a custodian to compensate for examples executed during the build
|
|
;; that may not be entirely clean (e.g., leaves a stuck thread).
|
|
(let ([p (make-namespace)]
|
|
[c (make-custodian)]
|
|
[ch (make-channel)]
|
|
[ns (reflection-anchor->namespace anchor)])
|
|
(parameterize ([current-custodian c])
|
|
(namespace-attach-module ns 'scribble/base-render p)
|
|
(namespace-attach-module ns 'scribble/html-render p)
|
|
;; This is here for de-serialization; we need a better repair than
|
|
;; hard-wiring the "manual.ss" library:
|
|
(namespace-attach-module ns 'scribble/manual p)
|
|
(parameterize ([current-namespace p])
|
|
(call-in-nested-thread
|
|
(lambda ()
|
|
(dynamic-require path 'doc)))))))
|
|
|
|
(define (write- info name sel)
|
|
(let* ([doc (info-doc info)]
|
|
[info-file (build-path (doc-dest-dir doc) name)])
|
|
(when (verbose)
|
|
(printf " [Caching ~a]\n" info-file))
|
|
(with-output-to-file info-file
|
|
#:exists 'truncate/replace
|
|
(lambda ()
|
|
(write ((sel (lambda ()
|
|
(list (list (info-vers info) (doc-flags doc))
|
|
(info-sci info)
|
|
(info-provides info)))
|
|
(lambda ()
|
|
(list
|
|
(list (info-vers info) (doc-flags doc))
|
|
(info-undef info)
|
|
(map (lambda (i)
|
|
(path->string (doc-src-file (info-doc i))))
|
|
(info-deps info)))))))))))
|
|
|
|
(define (write-out info)
|
|
(make-directory* (doc-dest-dir (info-doc info)))
|
|
(write- info "xref-out.ss" (lambda (o i) o)))
|
|
(define (write-in info)
|
|
(make-directory* (doc-dest-dir (info-doc info)))
|
|
(write- info "xref-in.ss" (lambda (o i) i)))
|
|
|
|
)
|