1656 lines
75 KiB
Racket
1656 lines
75 KiB
Racket
#lang racket/base
|
|
|
|
(require setup/getinfo
|
|
setup/dirs
|
|
setup/path-to-relative
|
|
"private/doc-path.rkt"
|
|
setup/collects
|
|
setup/collection-name
|
|
setup/main-doc
|
|
setup/parallel-do
|
|
setup/doc-db
|
|
racket/class
|
|
racket/list
|
|
racket/file
|
|
racket/fasl
|
|
racket/match
|
|
racket/serialize
|
|
racket/set
|
|
compiler/cm
|
|
scribble/base-render
|
|
scribble/core
|
|
scribble/html-properties
|
|
scribble/tag
|
|
scribble/private/manual-class-struct ; really shouldn't be here... see make-isolated-namespace
|
|
scribble/private/run-pdflatex
|
|
setup/xref
|
|
scribble/xref
|
|
syntax/modcollapse
|
|
racket/place
|
|
pkg/lib
|
|
pkg/strip
|
|
openssl/sha1
|
|
compiler/compilation-path
|
|
(prefix-in u: net/url)
|
|
(prefix-in html: scribble/html-render)
|
|
(prefix-in latex: scribble/latex-render)
|
|
(prefix-in contract: scribble/contract-render))
|
|
|
|
(provide setup-scribblings
|
|
verbose
|
|
run-pdflatex)
|
|
|
|
(define verbose (make-parameter #t))
|
|
|
|
(define-logger setup)
|
|
|
|
(define-syntax-rule (verbose/log format-str arg ...)
|
|
(begin
|
|
(when (verbose)
|
|
(printf (string-append " [" format-str "]\n")
|
|
arg ...)
|
|
(flush-output))
|
|
(log-setup-debug format-str arg ...)))
|
|
|
|
(define-serializable-struct doc (src-dir
|
|
src-spec
|
|
src-file
|
|
dest-dir
|
|
flags
|
|
under-main?
|
|
pkg?
|
|
category
|
|
out-count
|
|
name
|
|
order-hint)
|
|
#:transparent)
|
|
(define-serializable-struct info (doc ; doc structure above
|
|
undef ; unresolved requires
|
|
searches
|
|
deps ; (listof (cons <path-or-info> hash))
|
|
build?
|
|
out-hash
|
|
start-time done-time
|
|
need-run?
|
|
need-in-write? need-out-write?
|
|
vers rendered? failed?)
|
|
#:transparent
|
|
#:mutable)
|
|
|
|
(define (main-doc? doc)
|
|
(pair? (path->main-doc-relative (doc-dest-dir doc))))
|
|
|
|
(define (doc<? a b)
|
|
(or (< (doc-order-hint a)
|
|
(doc-order-hint b))
|
|
(and (= (doc-order-hint a)
|
|
(doc-order-hint b))
|
|
(string<? (doc-name a)
|
|
(doc-name b)))))
|
|
(define (info<? a b)
|
|
(doc<? (info-doc a) (info-doc b)))
|
|
|
|
(define (filter-user-docs docs make-user? always-user?)
|
|
(cond ;; Specifically disabled user stuff, filter
|
|
[(not make-user?) (filter main-doc? docs)]
|
|
;; If we've built user-specific before, keep building
|
|
[(or always-user?
|
|
(file-exists? (build-path (find-user-doc-dir) "index.html")))
|
|
docs]
|
|
;; Otherwise, see if we need it:
|
|
[(ormap (lambda (doc)
|
|
(not (or (doc-under-main? doc)
|
|
(memq 'no-depend-on (doc-flags doc)))))
|
|
docs)
|
|
docs]
|
|
[else (filter main-doc? docs)])) ; Don't need them, so drop them
|
|
|
|
(define (parallel-do-error-handler with-record-error doc errmsg outstr errstr)
|
|
(with-record-error
|
|
(doc-src-file doc)
|
|
(lambda () (error errmsg))
|
|
void))
|
|
|
|
;; We use a lock to control writing to the database. It's not
|
|
;; strictly necessary, but place channels can deal with blocking
|
|
;; more efficiently than the database connection.
|
|
(define no-lock void)
|
|
(define (lock-via-channel lock-ch)
|
|
(if lock-ch
|
|
(let ([saved-ch #f])
|
|
(lambda (mode)
|
|
(case mode
|
|
[(lock)
|
|
(define ch (sync lock-ch))
|
|
(place-channel-put ch 'lock)
|
|
(set! saved-ch ch)]
|
|
[(unlock)
|
|
(place-channel-put saved-ch 'done)
|
|
(set! saved-ch #f)])))
|
|
void))
|
|
(define (call-with-lock lock thunk)
|
|
(lock 'lock)
|
|
(dynamic-wind
|
|
void
|
|
thunk
|
|
(lambda () (lock 'unlock))))
|
|
|
|
(define (setup-scribblings
|
|
worker-count ; number of cores to use to create documentation
|
|
program-name ; name of program that calls setup-scribblings
|
|
only-dirs ; limits doc builds
|
|
latex-dest ; if not #f, generate Latex output
|
|
auto-start-doc? ; if #t, expands `only-dir' with [user-]start to catch new docs
|
|
make-user? ; are we making user stuff?
|
|
always-user? ; make user-specific even if otherwise unneeded
|
|
tidy? ; clean up, even beyond `only-dirs'
|
|
avoid-main? ; avoid main collection, even for `tidy?'
|
|
with-record-error ; catch & record exceptions
|
|
setup-printf)
|
|
(unless (doc-db-available?)
|
|
(error 'setup "install SQLite to build documentation"))
|
|
(when latex-dest
|
|
(log-setup-info "latex working directory: ~a" latex-dest))
|
|
(define (scribblings-flag? sym)
|
|
(memq sym '(main-doc main-doc-root user-doc-root user-doc multi-page
|
|
depends-all depends-all-main depends-all-user
|
|
no-depend-on always-run keep-style no-search)))
|
|
(define (validate-scribblings-infos infos)
|
|
(define (validate path [flags '()] [cat '(library)] [name #f] [out-count 1] [order-hint 0])
|
|
(and (string? path) (relative-path? path)
|
|
(list? flags) (andmap scribblings-flag? flags)
|
|
(or (not name) (collection-name-element? name))
|
|
(and (list? cat)
|
|
(<= 1 (length cat) 2)
|
|
(or (symbol? (car cat))
|
|
(string? (car cat)))
|
|
(or (null? (cdr cat))
|
|
(real? (cadr cat))))
|
|
(and (exact-positive-integer? out-count))
|
|
(and (real? order-hint))
|
|
(list path flags cat
|
|
(or name (let-values ([(_1 name _2) (split-path path)])
|
|
(path-replace-suffix name #"")))
|
|
out-count
|
|
order-hint)))
|
|
(and (list? infos)
|
|
(let ([infos (map (lambda (i)
|
|
(and (list? i) (<= 1 (length i) 6)
|
|
(apply validate i)))
|
|
infos)])
|
|
(and (not (memq #f infos)) infos))))
|
|
(define ((get-docs main-dirs) i rec)
|
|
(let* ([pre-s (and i (i 'scribblings))]
|
|
[s (validate-scribblings-infos pre-s)]
|
|
[dir (directory-record-path rec)])
|
|
(if s
|
|
(map (lambda (d)
|
|
(let* ([flags (cadr d)]
|
|
[under-main?
|
|
(and (not (memq 'user-doc-root flags))
|
|
(not (memq 'user-doc flags))
|
|
(or (memq 'main-doc flags)
|
|
(hash-ref main-dirs dir #f)))])
|
|
(define src (simplify-path (build-path dir (car d)) #f))
|
|
(define name (cadddr d))
|
|
(define dest (doc-path dir name flags under-main?))
|
|
(make-doc dir
|
|
(let ([spec (directory-record-spec rec)])
|
|
(list* (car spec)
|
|
(car d)
|
|
(if (eq? 'planet (car spec))
|
|
(list (append (cdr spec)
|
|
(list (directory-record-maj rec)
|
|
(list '= (directory-record-min rec)))))
|
|
(cdr spec))))
|
|
src
|
|
dest
|
|
flags under-main? (and (path->pkg src) #t)
|
|
(caddr d)
|
|
(list-ref d 4)
|
|
(if (path? name) (path-element->string name) name)
|
|
(list-ref d 5))))
|
|
s)
|
|
(begin (setup-printf
|
|
"WARNING"
|
|
"bad 'scribblings info: ~e from: ~e"
|
|
pre-s dir)
|
|
null))))
|
|
(log-setup-info "getting documents")
|
|
(define docs
|
|
(sort
|
|
(let* ([recs (find-relevant-directory-records '(scribblings) 'all-available)]
|
|
[main-dirs (for/hash ([k (in-list
|
|
(find-relevant-directories '(scribblings) 'no-user))])
|
|
(values k #t))]
|
|
[infos (map get-info/full (map directory-record-path recs))])
|
|
(filter-user-docs (append-map (get-docs main-dirs) infos recs)
|
|
make-user?
|
|
always-user?))
|
|
doc<?))
|
|
(define-values (main-docs user-docs) (partition doc-under-main? docs))
|
|
(define main-doc-exists? (ormap (lambda (d) (member 'main-doc-root (doc-flags d)))
|
|
main-docs))
|
|
|
|
(define (can-build*? docs) (can-build? only-dirs docs))
|
|
|
|
(define main-db (find-doc-db-path latex-dest #f main-doc-exists?))
|
|
(define user-db (find-doc-db-path latex-dest #t main-doc-exists?))
|
|
|
|
;; Ensure that databases are created:
|
|
(define (touch-db db-file)
|
|
(unless (file-exists? db-file)
|
|
(define-values (base name dir?) (split-path db-file))
|
|
(make-directory* base)
|
|
(doc-db-disconnect
|
|
(doc-db-file->connection db-file #t))))
|
|
(when (or (ormap can-build*? main-docs)
|
|
(and tidy? (not avoid-main?)))
|
|
(touch-db main-db))
|
|
(when (or (ormap can-build*? user-docs)
|
|
(and tidy? make-user?))
|
|
(touch-db user-db))
|
|
|
|
(when (and (or (not only-dirs) tidy?)
|
|
(not avoid-main?)
|
|
(not latex-dest))
|
|
;; Check for extra document directories that we should remove
|
|
;; in the main installation:
|
|
(log-setup-info "checking installation document directories")
|
|
(define main-doc-dir (find-doc-dir))
|
|
(define expected (for/set ([doc (in-list main-docs)])
|
|
(doc-dest-dir doc)))
|
|
(for ([i (in-list (if (directory-exists? main-doc-dir)
|
|
(directory-list main-doc-dir)
|
|
null))])
|
|
(define p (build-path main-doc-dir i))
|
|
(when (directory-exists? p)
|
|
(unless (set-member? expected (build-path p))
|
|
(setup-printf
|
|
"removing"
|
|
"~a (documentation directory)"
|
|
(path->relative-string/setup p))
|
|
(delete-directory/files p)))))
|
|
|
|
(define auto-main? (and auto-start-doc?
|
|
(or (ormap can-build*? main-docs)
|
|
(and tidy? (not avoid-main?)))))
|
|
(define auto-user? (and auto-start-doc?
|
|
(or (ormap can-build*? user-docs)
|
|
(and tidy? make-user?)
|
|
always-user?)))
|
|
(define (can-build**? doc) (can-build? only-dirs doc auto-main? auto-user?))
|
|
|
|
(unless latex-dest
|
|
;; Make sure "scribble.css", etc., is in place:
|
|
(let ([ht (make-hash)])
|
|
(for ([doc (in-list docs)])
|
|
(when (can-build**? doc)
|
|
(check-shared-files (doc-dest-dir doc)
|
|
(or (memq 'main-doc-root (doc-flags doc))
|
|
(memq 'user-doc-root (doc-flags doc)))
|
|
(doc-under-main? doc)
|
|
ht
|
|
setup-printf)))))
|
|
|
|
(define force-out-of-date? #f)
|
|
|
|
(define lock-ch #f)
|
|
(define lock-ch-in #f)
|
|
(define (init-lock-ch!)
|
|
(unless lock-ch
|
|
;; If places are not available, then tasks will be run
|
|
;; in separate OS processes, and we can do without an
|
|
;; extra lock.
|
|
(when (place-enabled?)
|
|
(set!-values (lock-ch lock-ch-in) (place-channel))
|
|
(thread (lambda ()
|
|
(define-values (ch ch-in) (place-channel))
|
|
(let loop ()
|
|
(place-channel-put lock-ch-in ch)
|
|
(place-channel-get ch-in)
|
|
(place-channel-get ch-in)
|
|
(loop)))))))
|
|
|
|
(log-setup-info "getting document information")
|
|
(define (make-sequential-get-info only-fast?)
|
|
(get-doc-info only-dirs latex-dest
|
|
auto-main? auto-user? main-doc-exists?
|
|
with-record-error setup-printf #f
|
|
only-fast? force-out-of-date?
|
|
no-lock))
|
|
(define num-sequential (let loop ([docs docs])
|
|
(cond
|
|
[(null? docs) 0]
|
|
[((doc-order-hint (car docs)) . > . -10) 0]
|
|
[else
|
|
(add1 (loop (cdr docs)))])))
|
|
(define infos
|
|
(and (ormap can-build**? docs)
|
|
(filter
|
|
values
|
|
(if ((min worker-count (length docs)) . < . 2)
|
|
;; non-parallel version:
|
|
(map (make-sequential-get-info #f) docs)
|
|
;; maybe parallel...
|
|
(or
|
|
(let ([infos (map (make-sequential-get-info #t)
|
|
docs)])
|
|
;; check fast result
|
|
(and (andmap values infos)
|
|
infos))
|
|
;; parallel:
|
|
(append
|
|
(map (make-sequential-get-info #f)
|
|
(take docs num-sequential))
|
|
(parallel-do
|
|
(min worker-count (length (list-tail docs num-sequential)))
|
|
(lambda (workerid)
|
|
(init-lock-ch!)
|
|
(list workerid program-name (verbose) only-dirs latex-dest
|
|
auto-main? auto-user? main-doc-exists?
|
|
force-out-of-date? lock-ch))
|
|
(list-queue
|
|
(list-tail docs num-sequential)
|
|
(lambda (x workerid) (s-exp->fasl (serialize x)))
|
|
(lambda (work r outstr errstr)
|
|
(printf "~a" outstr)
|
|
(printf "~a" errstr)
|
|
(deserialize (fasl->s-exp r)))
|
|
(lambda (work errmsg outstr errstr)
|
|
(parallel-do-error-handler with-record-error work errmsg outstr errstr)))
|
|
(define-worker (get-doc-info-worker workerid program-name verbosev only-dirs latex-dest
|
|
auto-main? auto-user? main-doc-exists?
|
|
force-out-of-date? lock-ch)
|
|
(define ((get-doc-info-local program-name only-dirs latex-dest
|
|
auto-main? auto-user? main-doc-exists?
|
|
force-out-of-date? lock
|
|
send/report)
|
|
doc)
|
|
(define (setup-printf subpart formatstr . rest)
|
|
(let ([task (if subpart
|
|
(format "~a: " subpart)
|
|
"")])
|
|
(send/report
|
|
(format "~a: ~a~a\n" program-name task (apply format formatstr rest)))))
|
|
(define (with-record-error cc go fail-k)
|
|
(with-handlers ([exn:fail?
|
|
(lambda (exn)
|
|
((error-display-handler) (exn-message exn) exn)
|
|
(raise exn))])
|
|
(go)))
|
|
(s-exp->fasl (serialize
|
|
((get-doc-info only-dirs latex-dest
|
|
auto-main? auto-user? main-doc-exists?
|
|
with-record-error setup-printf workerid
|
|
#f force-out-of-date? lock)
|
|
(deserialize (fasl->s-exp doc))))))
|
|
|
|
(verbose verbosev)
|
|
(match-message-loop
|
|
[doc (send/success
|
|
((get-doc-info-local program-name only-dirs latex-dest
|
|
auto-main? auto-user? main-doc-exists?
|
|
force-out-of-date? (lock-via-channel lock-ch)
|
|
send/report)
|
|
doc))])))))))))
|
|
|
|
(define (out-path->info path infos out-path->info-cache)
|
|
(or (hash-ref out-path->info-cache path #f)
|
|
(let ([filename (main-doc-relative->path path)])
|
|
(for*/or ([i (in-list infos)]
|
|
[c (in-range (add1 (doc-out-count (info-doc i))))])
|
|
(and (equal? (sxref-path latex-dest (info-doc i) (format "out~a.sxref" c))
|
|
filename)
|
|
(hash-set! out-path->info-cache path i)
|
|
i)))))
|
|
|
|
(define (tidy-database)
|
|
(when (and (or (not only-dirs) tidy?)
|
|
(not latex-dest)
|
|
infos)
|
|
(log-setup-info "tidying database")
|
|
(define files (make-hash))
|
|
(define tidy-docs (if tidy?
|
|
docs
|
|
(map info-doc infos)))
|
|
(define (get-files! main?)
|
|
(for ([doc (in-list tidy-docs)]
|
|
#:when (eq? main? (main-doc? doc)))
|
|
(hash-set! files (sxref-path latex-dest doc "in.sxref") #t)
|
|
(for ([c (in-range (add1 (doc-out-count doc)))])
|
|
(hash-set! files (sxref-path latex-dest doc (format "out~a.sxref" c)) #t))))
|
|
(unless avoid-main?
|
|
(get-files! #t)
|
|
(doc-db-clean-files main-db files))
|
|
(when (and (file-exists? user-db)
|
|
(not (equal? main-db user-db)))
|
|
(get-files! #f)
|
|
(doc-db-clean-files user-db files))))
|
|
|
|
(define (make-loop first? iter)
|
|
(let ([infos (filter-not info-failed? infos)]
|
|
[src->info (make-hash)]
|
|
[out-path->info-cache (make-hash)])
|
|
(tidy-database)
|
|
;; Check for duplicate definitions
|
|
(when first?
|
|
(log-setup-info "checking for duplicates")
|
|
(let ([dups (append
|
|
(if (file-exists? main-db)
|
|
(doc-db-check-duplicates main-db #:main-doc-relative-ok? #t)
|
|
null)
|
|
(if (and make-user?
|
|
(file-exists? user-db)
|
|
(not (equal? main-db user-db)))
|
|
(doc-db-check-duplicates user-db
|
|
#:attach (and (file-exists? main-db) main-db)
|
|
#:main-doc-relative-ok? #t)
|
|
null))])
|
|
(for ([dup dups])
|
|
(let ([k (car dup)]
|
|
[paths (cdr dup)])
|
|
(setup-printf "WARNING" "duplicate tag: ~s" k)
|
|
(for ([path paths])
|
|
(define i (out-path->info path infos out-path->info-cache))
|
|
(setup-printf #f " in: ~a" (if i
|
|
(doc-src-file (info-doc i))
|
|
"<unknown>")))))))
|
|
;; Build deps:
|
|
(log-setup-info "determining dependencies")
|
|
(for ([i infos])
|
|
(hash-set! src->info (doc-src-file (info-doc i)) i))
|
|
(define quick-fix? #f)
|
|
(for ([info infos] #:when (info-build? info))
|
|
(let ([one? #f]
|
|
[added? #f]
|
|
[deps (make-hasheq)]
|
|
[known-deps (make-hasheq)]
|
|
[all-main? (memq 'depends-all-main (doc-flags (info-doc info)))]
|
|
[all-user? (memq 'depends-all-user (doc-flags (info-doc info)))]
|
|
[all? (memq 'depends-all (doc-flags (info-doc info)))])
|
|
;; Convert current deps from paths to infos, keeping paths that have no info
|
|
(set-info-deps!
|
|
info
|
|
(map (lambda (d)
|
|
(cons (if (info? (car d))
|
|
(car d)
|
|
(or (hash-ref src->info (car d) #f)
|
|
(car d)))
|
|
(cdr d)))
|
|
(info-deps info)))
|
|
(unless (andmap (lambda (d) (info? (car d)))
|
|
(info-deps info))
|
|
(set-info-need-in-write?! info #t))
|
|
;; Propagate existing dependencies as expected dependencies:
|
|
(for ([dd (info-deps info)])
|
|
(define d (car dd))
|
|
(let ([i (if (info? d) d (hash-ref src->info d #f))])
|
|
(if i
|
|
;; Normal case:
|
|
(hash-set! deps i #t)
|
|
;; Path has no info; normally keep it as expected, and it gets
|
|
;; removed later.
|
|
(unless (or all?
|
|
(and (info? d)
|
|
(cond
|
|
[all-main?
|
|
(doc-under-main? (info-doc d))]
|
|
[all-user?
|
|
(not (doc-under-main? (info-doc d)))]
|
|
[else #f])))
|
|
(set! added? #t)
|
|
(verbose/log "Removed Dependency for ~a: ~a"
|
|
(doc-name (info-doc info))
|
|
(if i
|
|
(doc-name (info-doc i))
|
|
d))))))
|
|
(define (add-dependency info i)
|
|
(cond
|
|
[((info-start-time info) . < . (info-done-time info))
|
|
;; Although this dependency wasn't in the list, yet,
|
|
;; the build actually happened after the dependency's "out.sxref"
|
|
;; files were written, so they would have been used.
|
|
;; Fix up the dependency list.
|
|
(verbose/log "Quick-add for ~a: ~a"
|
|
(doc-name (info-doc info))
|
|
(doc-name (info-doc i)))
|
|
(hash-set! deps i #t)
|
|
(set-info-deps! info (cons (cons i (info-out-hash i))
|
|
(info-deps info)))
|
|
(set-info-need-in-write?! info #t)]
|
|
[else
|
|
(verbose/log "Adding for ~a: ~a"
|
|
(doc-name (info-doc info))
|
|
(doc-name (info-doc i)))
|
|
(set! added? #t)
|
|
(hash-set! deps i #t)]))
|
|
;; Add expected dependencies for an "all dependencies" doc:
|
|
(when (or all? all-main? all-user?)
|
|
(verbose/log "Adding all~a as dependencies for ~a"
|
|
(cond
|
|
[all-main? " main"]
|
|
[all-user? " user"]
|
|
[else ""])
|
|
(doc-name (info-doc info)))
|
|
(for ([i infos])
|
|
(hash-set! known-deps i #t)
|
|
(when (and (not (eq? i info))
|
|
(not (hash-ref deps i #f))
|
|
(cond
|
|
[all-main? (doc-under-main? (info-doc i))]
|
|
[all-user? (not (doc-under-main? (info-doc i)))]
|
|
[else #t])
|
|
(not (memq 'no-depend-on (doc-flags (info-doc i)))))
|
|
(add-dependency info i))))
|
|
;; Determine definite dependencies based on referenced keys, and also
|
|
;; report missing links.
|
|
(let ([not-found
|
|
(lambda (k)
|
|
(unless (or all? all-main? all-user?)
|
|
(unless one?
|
|
(setup-printf
|
|
"WARNING" "undefined tag in ~a:"
|
|
(path->relative-string/setup
|
|
(doc-src-file (info-doc info))))
|
|
(set! one? #t))
|
|
(setup-printf #f " ~s" k)))])
|
|
(let* ([filename (sxref-path latex-dest (info-doc info) "in.sxref")]
|
|
[as-user? (and (not (main-doc? (info-doc info)))
|
|
(not (equal? main-db user-db)))]
|
|
[found-deps (doc-db-get-dependencies filename
|
|
(if as-user? user-db main-db)
|
|
#:attach (if as-user? main-db #f)
|
|
#:main-doc-relative-ok? #t)]
|
|
[missing (if first?
|
|
(doc-db-check-unsatisfied filename
|
|
(if as-user? user-db main-db)
|
|
#:attach (if as-user? main-db #f))
|
|
null)])
|
|
(for ([found-dep (in-list found-deps)])
|
|
;; Record a definite dependency:
|
|
(define i (out-path->info found-dep infos out-path->info-cache))
|
|
(unless i
|
|
(setup-printf
|
|
"WARNING" "failed to find info for path: ~a"
|
|
found-dep))
|
|
(when i
|
|
;; Record this known dependency:
|
|
(when (not (hash-ref known-deps i #f))
|
|
(hash-set! known-deps i #t))
|
|
(when (not (hash-ref deps i #f))
|
|
;; Record dependency in "expected", too, which triggers
|
|
;; a re-run if needed:
|
|
(add-dependency info i))))
|
|
(for ([s-key (in-list missing)])
|
|
(not-found s-key))))
|
|
;; Check whether this document needs a re-run:
|
|
(when (or
|
|
;; If we added anything (expected or known), then mark as needed to run:
|
|
(and added?
|
|
(verbose/log "Rerun, since added dependencies for ~a"
|
|
(doc-name (info-doc info))))
|
|
;; If any dependency change, then mark as needed to run:
|
|
(and (let ([ch (ormap (lambda (p)
|
|
(define i2 (car p))
|
|
(or (and (not (info? i2))
|
|
i2)
|
|
(and (not (equal? (info-out-hash i2) (cdr p)))
|
|
(if ((info-start-time info) . < . (info-done-time info))
|
|
(begin
|
|
;; Actually used more recent:
|
|
(set! quick-fix? #t)
|
|
#f)
|
|
#t)
|
|
i2)))
|
|
(info-deps info))])
|
|
(and ch
|
|
(verbose/log "Rerun, since dependency changed for ~a: ~a"
|
|
(doc-name (info-doc info))
|
|
(if (info? ch)
|
|
(doc-name (info-doc ch))
|
|
ch))))))
|
|
(define (key->dep i v) (cons i (info-out-hash i)))
|
|
(set-info-deps! info (hash-map known-deps key->dep))
|
|
(set-info-need-in-write?! info #t)
|
|
(set-info-need-run?! info #t))
|
|
(when (and quick-fix? (not (info-need-run? info)))
|
|
;; Because the run was later enough, it actually used the latest
|
|
;; "out.sxref" for all dependencies.
|
|
(set-info-deps! info (for/list ([dep (in-list (info-deps info))])
|
|
(cons (car dep)
|
|
(info-out-hash (car dep)))))
|
|
(set-info-need-in-write?! info #t))))
|
|
;; Write out any "in.sxref" files that have been updated with dependency
|
|
;; information, and where another run isn't needed:
|
|
(for ([info (in-list infos)])
|
|
(when (and (info-need-in-write? info)
|
|
(not (info-need-run? info)))
|
|
(write-in/info latex-dest info no-lock main-doc-exists?)
|
|
(set-info-need-in-write?! info #f)))
|
|
;; Iterate, if any need to run:
|
|
(when (and (ormap info-need-run? infos) (iter . < . 30))
|
|
(log-setup-info "building")
|
|
;; Build again, using dependencies
|
|
(let ([need-rerun (sort (filter-map (lambda (i)
|
|
(and (info-need-run? i)
|
|
(begin
|
|
(set-info-need-run?! i #f)
|
|
i)))
|
|
infos)
|
|
info<?)])
|
|
(define (say-rendering i workerid)
|
|
(setup-printf (string-append
|
|
(if workerid (format "~a " workerid) "")
|
|
(if (info-rendered? i) "re-rendering" "rendering") )
|
|
"~a"
|
|
(path->relative-string/setup (doc-src-file (info-doc i)))))
|
|
(define (prep-info! i)
|
|
(set-info-start-time! i (current-inexact-milliseconds)))
|
|
(define (update-info! info response)
|
|
(match response
|
|
[#f (set-info-failed?! info #t)]
|
|
[(list undef searches out-delta?)
|
|
(set-info-rendered?! info #t)
|
|
(set-info-undef! info undef)
|
|
(set-info-searches! info searches)
|
|
(set-info-need-in-write?! info #f)
|
|
(when out-delta?
|
|
(set-info-out-hash! info (get-info-out-hash (info-doc info) latex-dest))
|
|
(set-info-done-time! info (current-inexact-milliseconds)))]))
|
|
(if ((min worker-count (length need-rerun)) . < . 2)
|
|
(for ([i (in-list need-rerun)])
|
|
(say-rendering i #f)
|
|
(prep-info! i)
|
|
(update-info! i (build-again! latex-dest i with-record-error no-lock
|
|
main-doc-exists?)))
|
|
(parallel-do
|
|
(min worker-count (length need-rerun))
|
|
(lambda (workerid)
|
|
(init-lock-ch!)
|
|
(list workerid (verbose) latex-dest lock-ch main-doc-exists?))
|
|
(list-queue
|
|
need-rerun
|
|
(lambda (i workerid)
|
|
(say-rendering i workerid)
|
|
(prep-info! i)
|
|
(s-exp->fasl (serialize (list (info-doc i)
|
|
;; Other content of `info' can be re-read from
|
|
;; "in.sxref", but not the dependencies and the
|
|
;; fact that we need to write the dependencies,
|
|
;; because those should only be written after
|
|
;; a successful render. So, we pass them along
|
|
;; in this list:
|
|
(info-deps->rel-doc-src-file i)
|
|
(info-need-in-write? i)))))
|
|
(lambda (i r outstr errstr)
|
|
(printf "~a" outstr)
|
|
(printf "~a" errstr)
|
|
(update-info! i (deserialize (fasl->s-exp r))))
|
|
(lambda (i errmsg outstr errstr)
|
|
(parallel-do-error-handler with-record-error (info-doc i) errmsg outstr errstr)))
|
|
(define-worker (build-again!-worker2 workerid verbosev latex-dest lock-ch
|
|
main-doc-exists?)
|
|
(define (with-record-error cc go fail-k)
|
|
(with-handlers ([exn:fail?
|
|
(lambda (x)
|
|
((error-display-handler) (exn-message x) x)
|
|
(raise x))])
|
|
(go)))
|
|
(verbose verbosev)
|
|
(match-message-loop
|
|
[info
|
|
(send/success
|
|
(s-exp->fasl (serialize (build-again! latex-dest
|
|
(deserialize (fasl->s-exp info))
|
|
with-record-error
|
|
(lock-via-channel lock-ch)
|
|
main-doc-exists?))))])))))
|
|
;; If we only build 1, then it reaches it own fixpoint
|
|
;; even if the info doesn't seem to converge immediately.
|
|
;; This is a useful shortcut when re-building a single
|
|
;; document.
|
|
(unless (= 1 (for/fold ([count 0])
|
|
([i infos]
|
|
#:when (info-build? i))
|
|
(add1 count)))
|
|
(make-loop #f (add1 iter))))))
|
|
|
|
(unless infos
|
|
;; since we won't use `make-loop':
|
|
(tidy-database))
|
|
|
|
(when infos
|
|
(make-loop #t 0)
|
|
;; cache info to disk
|
|
(for ([i infos] #:when (info-need-in-write? i))
|
|
(write-in/info latex-dest i no-lock main-doc-exists?))))
|
|
|
|
(define shared-style-files
|
|
(list "scribble.css"
|
|
"scribble-style.css"
|
|
"racket.css"
|
|
"manual-style.css"
|
|
"manual-racket.css"
|
|
"manual-racket.js"
|
|
"manual-fonts.css"
|
|
"scribble-common.js"))
|
|
(define shared-empty-style-files
|
|
(list "doc-site.css"))
|
|
(define shared-empty-script-files
|
|
(list "doc-site.js"))
|
|
|
|
(define (make-renderer latex-dest doc main-doc-exists?)
|
|
(if latex-dest
|
|
(new (latex:render-mixin render%)
|
|
[dest-dir latex-dest]
|
|
;; Use PLT manual style:
|
|
[prefix-file (collection-file-path "manual-prefix.tex" "scribble")]
|
|
[style-file (collection-file-path "manual-style.tex" "scribble")]
|
|
;; All .tex files go to the same directory, so prefix
|
|
;; generated/copied file names to keep them separate:
|
|
[helper-file-prefix (let-values ([(base name dir?) (split-path
|
|
(doc-dest-dir doc))])
|
|
(path-element->string name))])
|
|
(let* ([flags (doc-flags doc)]
|
|
[multi? (memq 'multi-page flags)]
|
|
[main? (doc-under-main? doc)]
|
|
[ddir (doc-dest-dir doc)]
|
|
[root? (or (memq 'main-doc-root flags)
|
|
(memq 'user-doc-root flags))]
|
|
[contract-override-mixin
|
|
(if multi?
|
|
contract:override-render-mixin-multi
|
|
contract:override-render-mixin-single)]
|
|
[allow-indirect? (and (doc-pkg? doc)
|
|
;; (not main?)
|
|
(not (memq 'no-depend-on (doc-flags doc))))]
|
|
[local-redirect-file (build-path (if main-doc-exists?
|
|
(find-doc-dir)
|
|
(find-user-doc-dir))
|
|
"local-redirect"
|
|
"local-redirect.js")]
|
|
[local-user-redirect-file (build-path (if main?
|
|
(find-doc-dir)
|
|
(find-user-doc-dir))
|
|
"local-redirect"
|
|
"local-user-redirect.js")])
|
|
(define r
|
|
(new (contract-override-mixin
|
|
((if multi? html:render-multi-mixin values)
|
|
(html:render-mixin render%)))
|
|
;; Use PLT manual style:
|
|
[style-file (if (memq 'keep-style flags)
|
|
#f
|
|
(collection-file-path "manual-style.css" "scribble"))]
|
|
[extra-files (if (memq 'keep-style flags)
|
|
null
|
|
(list (collection-file-path "manual-fonts.css" "scribble")))]
|
|
;; See also `style-extra-files`, below
|
|
[dest-dir (if multi?
|
|
(let-values ([(base name dir?) (split-path ddir)]) base)
|
|
ddir)]
|
|
[alt-paths (let ([std-path (lambda (s)
|
|
(cons (collection-file-path s "scribble")
|
|
(if root?
|
|
s
|
|
(format "../~a" s))))])
|
|
(list* (cons local-redirect-file
|
|
(if main?
|
|
"../local-redirect/local-redirect.js"
|
|
(u:url->string (u:path->url local-redirect-file))))
|
|
(cons local-user-redirect-file
|
|
(if main?
|
|
"../local-redirect/local-user-redirect.js"
|
|
(u:url->string (u:path->url local-user-redirect-file))))
|
|
(map std-path (append
|
|
shared-style-files
|
|
shared-empty-style-files
|
|
shared-empty-script-files))))]
|
|
[up-path (cond
|
|
[root? #f] ; no up from root
|
|
[main?
|
|
;; #t make the "up" link go to the (user's) start page
|
|
;; using cookies:
|
|
#t]
|
|
[allow-indirect?
|
|
;; building a package, so also rely on cookies in this
|
|
;; case:
|
|
#t]
|
|
[else
|
|
;; user-installed and not a package, so hard link is ok:
|
|
(build-path (find-user-doc-dir) "index.html")])]
|
|
|
|
;; In cross-reference information, use paths that are relative
|
|
;; to the target rendering directory for documentation that might
|
|
;; be moved into a binary package:
|
|
[root-path (and allow-indirect? ddir)]
|
|
|
|
[style-extra-files (if (memq 'keep-style flags)
|
|
null
|
|
(cons
|
|
(collection-file-path "manual-racket.css" "scribble")
|
|
(map (lambda (s)
|
|
(collection-file-path s "scribble"))
|
|
shared-empty-style-files)))]
|
|
|
|
[search-box? (not (memq 'no-search flags))]))
|
|
(unless (memq 'keep-style flags)
|
|
(send r add-extra-script-file (collection-file-path "manual-racket.js" "scribble"))
|
|
(for ([s (in-list shared-empty-script-files)])
|
|
(send r add-extra-script-file (collection-file-path s "scribble"))))
|
|
(when allow-indirect?
|
|
;; For documentation that might be moved into a binary package
|
|
;; or that can contain an indirect reference, use a server indirection
|
|
;; for all links external to the document, but also install the
|
|
;; "local-[user-]redirect.js" hooks:
|
|
(send r set-external-tag-path
|
|
(u:url->string
|
|
(let ([u (u:string->url (get-doc-search-url))])
|
|
(struct-copy
|
|
u:url
|
|
u
|
|
[query
|
|
(cons (cons 'version (version))
|
|
(u:url-query u))]))))
|
|
(send r add-extra-script-file local-redirect-file)
|
|
(send r add-extra-script-file local-user-redirect-file))
|
|
;; Result is the renderer:
|
|
r)))
|
|
|
|
(define (pick-dest latex-dest doc)
|
|
(cond [(path? latex-dest)
|
|
(let-values ([(base name dir?) (split-path (doc-dest-dir doc))])
|
|
(build-path latex-dest (path-replace-suffix name #".tex")))]
|
|
[(not latex-dest)
|
|
(cond
|
|
[(memq 'multi-page (doc-flags doc)) (doc-dest-dir doc)]
|
|
[else (build-path (doc-dest-dir doc) "index.html")])]))
|
|
|
|
(define (sxref-path latex-dest doc file)
|
|
(cond [(path? latex-dest)
|
|
(let-values ([(base name dir?) (split-path (doc-src-file doc))])
|
|
(build-path latex-dest (path-replace-suffix name (string-append "." file))))]
|
|
[(not latex-dest) (build-path (doc-dest-dir doc) file)]))
|
|
|
|
(define (find-doc-db-path latex-dest user? main-doc-exists?)
|
|
(cond
|
|
[latex-dest
|
|
(build-path latex-dest "docindex.sqlite")]
|
|
[else
|
|
(build-path (if (or user? (not main-doc-exists?))
|
|
(find-user-doc-dir)
|
|
(find-doc-dir))
|
|
"docindex.sqlite")]))
|
|
|
|
(define (can-build? only-dirs doc [auto-main? #f] [auto-user? #f])
|
|
(or (not only-dirs)
|
|
(and auto-main?
|
|
(memq 'depends-all-main (doc-flags doc)))
|
|
(and auto-user?
|
|
(or (memq 'depends-all (doc-flags doc))
|
|
(memq 'depends-all-user (doc-flags doc))))
|
|
(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 (load-doc/ensure-prefix doc)
|
|
(define (ensure-doc-prefix v src-spec)
|
|
(let ([p (module-path-prefix->string src-spec)])
|
|
(when (and (part-tag-prefix v)
|
|
(not (equal? p (part-tag-prefix v))))
|
|
(error 'setup
|
|
"bad tag prefix: ~e for: ~a expected: ~e"
|
|
(part-tag-prefix v)
|
|
src-spec
|
|
p))
|
|
(let ([tag-prefix p]
|
|
[tags (if (member '(part "top") (part-tags v))
|
|
(part-tags v)
|
|
(cons '(part "top") (part-tags v)))]
|
|
[style (part-style v)])
|
|
(make-part
|
|
tag-prefix
|
|
tags
|
|
(part-title-content v)
|
|
(let* ([v (style-properties style)]
|
|
[v (if (ormap body-id? v)
|
|
v
|
|
(cons (make-body-id "doc-racket-lang-org")
|
|
v))]
|
|
[v (if (ormap document-version? v)
|
|
v
|
|
(cons (make-document-version (version))
|
|
v))]
|
|
[v (cons (document-source
|
|
(collapse-module-path src-spec
|
|
'scribble))
|
|
v)])
|
|
(make-style (style-name style) v))
|
|
(part-to-collect v)
|
|
(part-blocks v)
|
|
(part-parts v)))))
|
|
(ensure-doc-prefix
|
|
(dynamic-require-doc (doc-src-spec doc))
|
|
(doc-src-spec doc)))
|
|
|
|
(define (omit? cat)
|
|
(or (eq? cat 'omit)
|
|
(and (pair? cat)
|
|
(eq? (car cat) 'omit))))
|
|
|
|
(define (any-order keys)
|
|
(let ([ht (make-hash)])
|
|
(for-each (lambda (k) (hash-set! ht k #t)) keys)
|
|
ht))
|
|
|
|
(define (load-sxref filename #:skip [skip 0])
|
|
(call-with-input-file* filename
|
|
(lambda (x)
|
|
(for ([i skip]) (fasl->s-exp x))
|
|
(fasl->s-exp x))))
|
|
|
|
(define (find-db-file doc latex-dest main-doc-exists?)
|
|
(define p (find-doc-db-path latex-dest (not (main-doc? doc)) main-doc-exists?))
|
|
(define-values (base name dir?) (split-path p))
|
|
(unless (directory-exists? base)
|
|
(make-directory* base))
|
|
p)
|
|
|
|
(define (xref-transfer-db renderer ci doc latex-dest
|
|
main-doc-exists?
|
|
#:quiet-fail? [quiet-fail? #f])
|
|
(define shutdown void)
|
|
(define xref (make-collections-xref
|
|
#:quiet-fail? quiet-fail?
|
|
#:no-user? (main-doc? doc)
|
|
#:no-main? (or (not main-doc-exists?)
|
|
(memq 'depends-all-user (doc-flags doc)))
|
|
#:doc-db (and latex-dest
|
|
(find-doc-db-path latex-dest #t main-doc-exists?))
|
|
#:register-shutdown! (lambda (s)
|
|
(set! shutdown s))))
|
|
(xref-transfer-info renderer ci xref)
|
|
shutdown)
|
|
|
|
(define (get-info-out-hash doc latex-dest)
|
|
(define info-out-files (for/list ([i (add1 (doc-out-count doc))])
|
|
(sxref-path latex-dest doc (format "out~a.sxref" i))))
|
|
(define-values (i o) (make-pipe))
|
|
(for/list ([info-out-file info-out-files])
|
|
(display (get-file-sha1 info-out-file) o))
|
|
(close-output-port o)
|
|
(sha1 i))
|
|
|
|
(define ((get-doc-info only-dirs latex-dest
|
|
auto-main? auto-user? main-doc-exists?
|
|
with-record-error setup-printf workerid
|
|
only-fast? force-out-of-date? lock)
|
|
doc)
|
|
|
|
;; First, move pre-rendered documentation, if any, into place
|
|
(let ([rendered-dir (let-values ([(base name dir?) (split-path (doc-dest-dir doc))])
|
|
(build-path (doc-src-dir doc) "doc" name))])
|
|
(when (and (can-build? only-dirs doc)
|
|
(directory-exists? rendered-dir)
|
|
(not (file-exists? (build-path rendered-dir "synced.rktd")))
|
|
(or (not (directory-exists? (doc-dest-dir doc)))
|
|
force-out-of-date?
|
|
(not (file-exists? (build-path (doc-dest-dir doc) "synced.rktd")))))
|
|
(move-documentation-into-place doc rendered-dir setup-printf workerid lock
|
|
main-doc-exists?)))
|
|
|
|
(let* ([info-out-files (for/list ([i (add1 (doc-out-count doc))])
|
|
(sxref-path latex-dest doc (format "out~a.sxref" i)))]
|
|
[info-in-file (sxref-path latex-dest doc "in.sxref")]
|
|
[db-file (find-db-file doc latex-dest main-doc-exists?)]
|
|
[stamp-file (sxref-path latex-dest doc "stamp.sxref")]
|
|
[out-file (build-path (doc-dest-dir doc) "index.html")]
|
|
[src-zo (let ([path (get-compilation-bytecode-file (doc-src-file doc))])
|
|
(or (and (file-exists? path)
|
|
path)
|
|
(if (file-exists? out-file)
|
|
;; assume installed as pre-rendered:
|
|
#f
|
|
;; need to render, so complain if no source is available:
|
|
path)))]
|
|
[src-sha1 (and src-zo (get-compiled-file-sha1 src-zo))]
|
|
[renderer (make-renderer latex-dest doc main-doc-exists?)]
|
|
[can-run? (can-build? only-dirs doc)]
|
|
[stamp-data (with-handlers ([exn:fail:filesystem? (lambda (exn) (list "" "" ""))])
|
|
(let ([v (call-with-input-file* stamp-file read)])
|
|
(if (and (list? v)
|
|
(= 3 (length v))
|
|
(andmap string? v))
|
|
v
|
|
(list "" "" ""))))]
|
|
[renderer-path (let ([p (collection-file-path
|
|
#:check-compiled? #t
|
|
(cond
|
|
[(path? latex-dest) "latex-render.rkt"]
|
|
[(not latex-dest) "html-render.rkt"])
|
|
"scribble")])
|
|
(get-compilation-bytecode-file p))]
|
|
[css-path (collection-file-path "scribble.css" "scribble")]
|
|
[aux-sha1s (list (get-compiled-file-sha1 renderer-path)
|
|
(get-file-sha1 css-path))]
|
|
[out-exists? (file-exists? out-file)]
|
|
[info-out-time (for/fold ([t +inf.0]) ([info-out-file info-out-files])
|
|
(and t
|
|
(let ([t2 (file-or-directory-modify-seconds info-out-file #f (lambda () #f))])
|
|
(and t2 (if (not (eq? 'modify-seconds (use-compiled-file-check)))
|
|
0
|
|
(min t t2))))))]
|
|
[provides-time (for/fold ([t +inf.0]) ([info-out-file info-out-files])
|
|
(and t
|
|
(let ([t2 (and (file-exists? db-file)
|
|
(if (not (eq? 'modify-seconds (use-compiled-file-check)))
|
|
0
|
|
(doc-db-get-provides-timestamp db-file info-out-file)))])
|
|
(and t2 (min t t2)))))]
|
|
[info-in-exists? (file-exists? info-in-file)]
|
|
[vers (send renderer get-serialize-version)]
|
|
[use-built? (and (not src-zo)
|
|
info-in-exists?
|
|
info-out-time)]
|
|
[out-of-date (and (not use-built?)
|
|
(or (and force-out-of-date?
|
|
'force)
|
|
(and (not info-out-time)
|
|
'missing-out)
|
|
(and (not info-in-exists?)
|
|
'missing-in)
|
|
(and can-run?
|
|
(not (equal? (car stamp-data)
|
|
src-sha1))
|
|
'newer)
|
|
(and (or (not provides-time)
|
|
(provides-time . < . info-out-time))
|
|
(not (file-exists? (build-path (doc-dest-dir doc) "provides.sxref"))))))]
|
|
[up-to-date? (not out-of-date)]
|
|
[can-run? (and src-zo
|
|
(or (not latex-dest)
|
|
(not (omit? (doc-category doc))))
|
|
(or can-run?
|
|
(and auto-main?
|
|
(memq 'depends-all-main (doc-flags doc)))
|
|
(and auto-user?
|
|
(or (memq 'depends-all (doc-flags doc))
|
|
(memq 'depends-all-user (doc-flags doc))))))])
|
|
|
|
(when (or (and (not up-to-date?) (not only-fast?))
|
|
(verbose))
|
|
(when out-of-date
|
|
(verbose/log "Need run (~a) ~a" out-of-date (doc-name doc)))
|
|
(setup-printf
|
|
(string-append
|
|
(if workerid (format "~a " workerid) "")
|
|
(cond
|
|
[up-to-date? "using"]
|
|
[can-run? (if only-fast?
|
|
"checking"
|
|
"running")]
|
|
[else "skipping"]))
|
|
"~a"
|
|
(path->relative-string/setup (doc-src-file doc))))
|
|
|
|
(when force-out-of-date?
|
|
(for ([p (in-list info-out-files)])
|
|
(when (file-exists? p)
|
|
(delete-file p))))
|
|
|
|
(if up-to-date?
|
|
;; Load previously calculated info:
|
|
(render-time
|
|
"use"
|
|
(with-handlers ([exn:fail? (lambda (exn)
|
|
(log-error (format "get-doc-info error: ~a"
|
|
(exn-message exn)))
|
|
(for-each delete-file info-out-files)
|
|
(delete-file info-in-file)
|
|
((get-doc-info only-dirs latex-dest
|
|
auto-main? auto-user? main-doc-exists?
|
|
with-record-error setup-printf workerid
|
|
#f #f lock)
|
|
doc))])
|
|
(let ([v-in (load-sxref info-in-file)])
|
|
(unless (equal? (car v-in) (list vers (doc-flags doc)))
|
|
(error "old info has wrong version or flags"))
|
|
(when (and (or (not provides-time)
|
|
(provides-time . < . info-out-time))
|
|
(can-build? only-dirs doc))
|
|
;; Database is out of sync, and we don't need to build
|
|
;; this document, so update databse now. Note that a
|
|
;; timestamp is good enough for determing a sync,
|
|
;; instead of sha1s, because a database is never moved
|
|
;; across installations.
|
|
(move-documentation-into-place doc #f
|
|
setup-printf workerid lock
|
|
main-doc-exists?))
|
|
(define out-hash (get-info-out-hash doc latex-dest))
|
|
(make-info
|
|
doc
|
|
'delayed
|
|
'delayed
|
|
;; expected deps, in case we don't need to build:
|
|
(map (lambda (p) (cons (rel->path (car p)) (cdr p)))
|
|
(list-ref v-in 1))
|
|
can-run?
|
|
out-hash
|
|
-inf.0 -inf.0
|
|
(and can-run?
|
|
(or (memq 'always-run (doc-flags doc))
|
|
;; maybe info is up-to-date but not rendered doc:
|
|
(not out-exists?)))
|
|
#f
|
|
#f
|
|
vers
|
|
#f
|
|
#f))))
|
|
(if (and can-run?
|
|
(not only-fast?))
|
|
;; Run the doc once:
|
|
(with-record-error
|
|
(doc-src-file doc)
|
|
(lambda ()
|
|
(parameterize ([current-directory (doc-src-dir doc)])
|
|
(let* ([start-time (current-inexact-milliseconds)]
|
|
[v (load-doc/ensure-prefix doc)]
|
|
[dest-dir (pick-dest latex-dest doc)]
|
|
[fp (send renderer traverse (list v) (list dest-dir))]
|
|
[ci (send renderer collect (list v) (list dest-dir) fp)]
|
|
;; It's ok if cross-reference information isn't available
|
|
;; at this point, but we can sometimes save another iteration
|
|
;; if the information is available at this pass.
|
|
[db-shutdown (xref-transfer-db renderer ci doc latex-dest
|
|
main-doc-exists?
|
|
#:quiet-fail? #t)]
|
|
[ri (send renderer resolve (list v) (list dest-dir) ci)]
|
|
[out-vs (and info-out-time
|
|
(with-handlers ([exn:fail? (lambda (exn) #f)])
|
|
(for/list ([info-out-file info-out-files])
|
|
(let ([v (load-sxref info-out-file)])
|
|
(unless (equal? (car v) (list vers (doc-flags doc)))
|
|
(error "old info has wrong version or flags"))
|
|
v))))]
|
|
[scis (send renderer serialize-infos ri (add1 (doc-out-count doc)) v)]
|
|
[defss (send renderer get-defineds ci (add1 (doc-out-count doc)) v)]
|
|
[undef (send renderer get-external ri)]
|
|
[searches (resolve-info-searches ri)]
|
|
[need-out-write
|
|
(or (and force-out-of-date? 'forced)
|
|
(and (not out-vs) 'missing)
|
|
(and (not (for/and ([out-v out-vs])
|
|
(equal? (list vers (doc-flags doc))
|
|
(car out-v))))
|
|
'version/flags)
|
|
(and (not (for/and ([sci scis]
|
|
[out-v out-vs])
|
|
(serialized=? sci (cadr out-v))))
|
|
'content)
|
|
(and (not provides-time) 'db-missing)
|
|
(and (info-out-time . > . provides-time) 'db-older))])
|
|
(when need-out-write
|
|
(verbose/log "New out (~a) ~a" need-out-write (doc-name doc)))
|
|
(gc-point)
|
|
(let ([info
|
|
(make-info doc
|
|
undef
|
|
searches
|
|
null ; haven't figured out deps, yet
|
|
can-run?
|
|
(and (not need-out-write)
|
|
(get-info-out-hash doc latex-dest))
|
|
start-time +inf.0
|
|
#t
|
|
can-run?
|
|
(and need-out-write #t)
|
|
vers
|
|
#f
|
|
#f)])
|
|
(when need-out-write
|
|
(render-time "xref-out" (write-out/info latex-dest info scis defss db-file lock))
|
|
(set-info-out-hash! info (get-info-out-hash doc latex-dest))
|
|
(set-info-need-out-write?! info #f)
|
|
(set-info-done-time! info (current-inexact-milliseconds)))
|
|
|
|
(when (info-need-in-write? info)
|
|
(render-time "xref-in" (write-in/info latex-dest info lock main-doc-exists?))
|
|
(set-info-need-in-write?! info #f))
|
|
|
|
(let ([data (cons src-sha1 aux-sha1s)])
|
|
(unless (equal? data stamp-data)
|
|
(with-compile-output
|
|
stamp-file
|
|
(lambda (out tmp-filename) (write data out)))))
|
|
(db-shutdown)
|
|
info))))
|
|
(lambda () #f))
|
|
#f))))
|
|
|
|
(define (check-shared-files dir root? main? done setup-printf)
|
|
(define dest-dir (simplify-path (if root?
|
|
dir
|
|
(build-path dir 'up))))
|
|
(unless (hash-ref done dir #f)
|
|
(for ([f (in-list shared-style-files)])
|
|
(define src (collection-file-path f "scribble"))
|
|
(define dest (build-path dest-dir f))
|
|
(unless (and (file-exists? dest)
|
|
(equal? (file->bytes src)
|
|
(file->bytes dest)))
|
|
(when (or (verbose) main?)
|
|
(setup-printf "installing" "~a" dest))
|
|
(make-directory* dest-dir)
|
|
;; Copy new file into place, and if that fails,
|
|
;; try deleting the old file first (because it might
|
|
;; exist and not have write permission, while the
|
|
;; encloding directory might allow file deletes)
|
|
(with-handlers ([exn:fail:filesystem?
|
|
(lambda (exn)
|
|
(when (file-exists? dest)
|
|
(delete-file dest)
|
|
(copy-file src dest)))])
|
|
(copy-file src dest #t))))
|
|
(for ([f (in-list (append shared-empty-style-files
|
|
shared-empty-script-files))])
|
|
(define dest (build-path dest-dir f))
|
|
(unless (file-exists? dest)
|
|
(when (or (verbose) main?)
|
|
(setup-printf "installing" "~a" dest))
|
|
(make-directory* dest-dir)
|
|
(call-with-output-file* dest void)))
|
|
(hash-set! done dir #t)))
|
|
|
|
(define (move-documentation-into-place doc src-dir setup-printf workerid lock
|
|
main-doc-exists?)
|
|
(with-handlers ([exn:fail? (lambda (exn)
|
|
;; On any failure, log the error and give up.
|
|
;; Maybe further actions are appropriate, but
|
|
;; overall clean-up and repair is intended to be
|
|
;; the job of the regular documentation builder.
|
|
(log-error (format "error moving documentation: ~a"
|
|
(exn-message exn))))])
|
|
(define dest-dir (doc-dest-dir doc))
|
|
(define move? (and src-dir
|
|
(not (equal? (file-or-directory-identity src-dir)
|
|
(and (directory-exists? dest-dir)
|
|
(file-or-directory-identity dest-dir))))))
|
|
(setup-printf (string-append
|
|
(if workerid (format "~a " workerid) "")
|
|
(if move? "moving" "syncing"))
|
|
"~a"
|
|
(path->relative-string/setup (or src-dir dest-dir)))
|
|
(when move?
|
|
(when (directory-exists? dest-dir)
|
|
(delete-directory/files dest-dir))
|
|
(let-values ([(base name dir?) (split-path dest-dir)])
|
|
(when (and (path? base) (not (directory-exists? base)))
|
|
(make-directory* base)))
|
|
(copy-directory/files src-dir dest-dir)
|
|
(delete-directory/files src-dir))
|
|
;; Register provided-tag information with the database:
|
|
(let ([provides-path (build-path dest-dir "provides.sxref")])
|
|
(when (file-exists? provides-path)
|
|
;; register keys provided in "out<n>.sxref" with
|
|
;; the database
|
|
(define providess (call-with-input-file*
|
|
provides-path
|
|
(lambda (in) (fasl->s-exp in))))
|
|
(define db-file (find-db-file doc #f main-doc-exists?))
|
|
(for ([provides (in-list providess)]
|
|
[n (in-naturals)])
|
|
(define filename (sxref-path #f doc (format "out~a.sxref" n)))
|
|
(call-with-lock
|
|
lock
|
|
(lambda ()
|
|
(doc-db-clear-provides db-file filename)
|
|
(doc-db-add-provides db-file provides filename)
|
|
(doc-db-set-provides-timestamp db-file filename
|
|
(file-or-directory-modify-seconds filename)))))))
|
|
;; For each ".html" file, check for a reference to "local-redirect.js",
|
|
;; and fix up the path if there is a reference:
|
|
(define js-path (if (doc-under-main? doc)
|
|
"../local-redirect"
|
|
(u:url->string
|
|
(u:path->url
|
|
(build-path (if main-doc-exists?
|
|
(find-doc-dir)
|
|
(find-user-doc-dir))
|
|
"local-redirect")))))
|
|
(define user-js-path (if (doc-under-main? doc)
|
|
"../local-redirect"
|
|
(u:url->string
|
|
(u:path->url
|
|
(build-path (find-user-doc-dir) "local-redirect")))))
|
|
(for ([p (in-directory dest-dir)])
|
|
(when (regexp-match? #rx#"[.]html$" (path->bytes p))
|
|
(fixup-local-redirect-reference p js-path #:user user-js-path)))
|
|
;; The existence of "synced.rktd" means that the db is in sync
|
|
;; with "provides.sxref" and ".html" files have been updated.
|
|
(let ([provided-path (build-path dest-dir "synced.rktd")])
|
|
(unless (file-exists? provided-path)
|
|
(call-with-output-file provided-path (lambda (o) (write '#t o)))))))
|
|
|
|
(define (read-delayed-in! info latex-dest)
|
|
(let* ([doc (info-doc info)]
|
|
[info-in-file (sxref-path latex-dest doc "in.sxref")]
|
|
[v-in (load-sxref info-in-file #:skip 1)])
|
|
(if (and (equal? (car v-in) (list (info-vers info) (doc-flags doc))))
|
|
;; version is ok:
|
|
(let ([undef+searches
|
|
(let ([v (list-ref v-in 1)])
|
|
(with-my-namespace
|
|
(lambda ()
|
|
(deserialize v))))])
|
|
(set-info-undef! info (car undef+searches))
|
|
(set-info-searches! info (cadr undef+searches)))
|
|
;; version was bad:
|
|
(begin
|
|
(set-info-undef! info null)
|
|
(set-info-searches! info #hash())))))
|
|
|
|
(define (make-prod-thread)
|
|
;; periodically dumps a stack trace, which can give us some idea of
|
|
;; what the main thread is doing; usually used in `render-time'.
|
|
(let ([t (current-thread)])
|
|
(thread (lambda ()
|
|
(let loop ()
|
|
(sleep 0.05)
|
|
(for-each (lambda (i)
|
|
(printf "~s\n" i))
|
|
(continuation-mark-set->context (continuation-marks t)))
|
|
(newline)
|
|
(loop))))))
|
|
|
|
(define-syntax-rule (render-time what expr)
|
|
(do-render-time
|
|
what
|
|
(lambda () expr)))
|
|
|
|
(define (do-render-time what thunk)
|
|
(define start (current-process-milliseconds))
|
|
(begin0
|
|
(thunk)
|
|
(let ([end (current-process-milliseconds)])
|
|
(log-setup-debug "~a: ~a msec" what (- end start)))))
|
|
|
|
(define (load-sxrefs latex-dest doc vers new-deps-rel)
|
|
(define in-filename (sxref-path latex-dest doc "in.sxref"))
|
|
(match (list (load-sxref in-filename)
|
|
(load-sxref in-filename #:skip 1)
|
|
(for/list ([i (add1 (doc-out-count doc))])
|
|
(load-sxref (sxref-path latex-dest doc (format "out~a.sxref" i)))))
|
|
[(list (list in-version deps-rel)
|
|
(list in-version2 undef+searches)
|
|
(list (list out-versions scis) ...))
|
|
(define expected (list vers (doc-flags doc)))
|
|
(unless (and (equal? in-version expected)
|
|
(equal? in-version2 expected)
|
|
(for/and ([out-version out-versions])
|
|
(equal? out-version expected)))
|
|
(error "old info has wrong version or flags"))
|
|
(match (with-my-namespace
|
|
(lambda ()
|
|
(deserialize undef+searches)))
|
|
[(list undef searches)
|
|
(with-my-namespace*
|
|
(values undef
|
|
new-deps-rel
|
|
searches
|
|
scis))])]))
|
|
|
|
(define (build-again! latex-dest info-or-list with-record-error lock
|
|
main-doc-exists?)
|
|
;; If `info-or-list' is a list, then we're in a parallel build, and
|
|
;; it provides just enough of `info' from the main place to re-build
|
|
;; in this place along with the content of "in.sxref".
|
|
(define (cleanup-dest-dir doc)
|
|
(unless latex-dest
|
|
(let ([dir (doc-dest-dir doc)])
|
|
(if (not (directory-exists? dir))
|
|
(make-directory* dir)
|
|
(for ([f (directory-list dir)]
|
|
#:when
|
|
(and (file-exists? f)
|
|
(not (regexp-match? #"[.]sxref$"
|
|
(path-element->bytes f)))))
|
|
(delete-file (build-path dir f)))))))
|
|
(define (load-doc-scis doc)
|
|
(map cadr (for/list ([i (add1 (doc-out-count doc))])
|
|
(load-sxref (sxref-path latex-dest doc (format "out~a.sxref" i))))))
|
|
(define info (and (info? info-or-list) info-or-list))
|
|
(define doc (if info (info-doc info) (car info-or-list)))
|
|
(define renderer (make-renderer latex-dest doc main-doc-exists?))
|
|
(with-record-error
|
|
(doc-src-file doc)
|
|
(lambda ()
|
|
(define vers (send renderer get-serialize-version))
|
|
(define-values (ff-undef ff-deps-rel ff-searches ff-scis)
|
|
(if info
|
|
(begin
|
|
(when (eq? 'delayed (info-undef info))
|
|
(read-delayed-in! info latex-dest))
|
|
(values (info-undef info)
|
|
(info-deps->rel-doc-src-file info)
|
|
(info-searches info)
|
|
(load-doc-scis doc)))
|
|
(load-sxrefs latex-dest doc vers (cadr info-or-list))))
|
|
|
|
(parameterize ([current-directory (doc-src-dir doc)])
|
|
(let* ([v (render-time "load" (load-doc/ensure-prefix doc))]
|
|
[dest-dir (pick-dest latex-dest doc)]
|
|
[fp (render-time "traverse" (send renderer traverse (list v) (list dest-dir)))]
|
|
[ci (render-time "collect" (send renderer collect (list v) (list dest-dir) fp))]
|
|
[db-shutdown (xref-transfer-db renderer ci doc latex-dest main-doc-exists?)]
|
|
[ri (render-time "resolve" (send renderer resolve (list v) (list dest-dir) ci))]
|
|
[scis (render-time "serialize" (send renderer serialize-infos ri (add1 (doc-out-count doc)) v))]
|
|
[defss (render-time "defined" (send renderer get-defineds ci (add1 (doc-out-count doc)) v))]
|
|
[undef (render-time "undefined" (send renderer get-external ri))]
|
|
[searches (render-time "searches" (resolve-info-searches ri))]
|
|
[in-delta? (not (and (equal? (any-order undef) (any-order ff-undef))
|
|
(equal? searches ff-searches)))]
|
|
[out-delta? (not (for/and ([sci scis]
|
|
[ff-sci ff-scis])
|
|
(serialized=? sci ff-sci)))]
|
|
[db-file (find-db-file doc latex-dest main-doc-exists?)])
|
|
(verbose/log "~a~afor ~a"
|
|
(if in-delta? "New in " "")
|
|
(cond [out-delta? "New out "]
|
|
[in-delta? ""]
|
|
[else "No change "])
|
|
(doc-name doc))
|
|
|
|
(when (or in-delta?
|
|
(and info (info-need-in-write? info))
|
|
(and (not info) (caddr info-or-list)))
|
|
(render-time "xref-in" (write-in latex-dest vers doc undef ff-deps-rel searches db-file lock)))
|
|
(when out-delta?
|
|
(render-time "xref-out" (write-out latex-dest vers doc scis defss db-file lock)))
|
|
|
|
(cleanup-dest-dir doc)
|
|
(render-time
|
|
"render"
|
|
(with-record-error
|
|
(doc-src-file doc)
|
|
(lambda ()
|
|
(parameterize ([current-namespace (make-isolated-namespace)])
|
|
(send renderer render (list v) (list dest-dir) ri)))
|
|
void))
|
|
(unless (or latex-dest (main-doc? doc))
|
|
;; Since dest dir is the same place as pre-built documentation,
|
|
;; mark it so that it is not treated as needing an install:
|
|
(let ([synced (build-path (doc-dest-dir doc) "synced.rktd")])
|
|
(unless (file-exists? synced)
|
|
(close-output-port (open-output-file synced)))))
|
|
(db-shutdown)
|
|
(gc-point)
|
|
(list undef searches out-delta?))))
|
|
(lambda () #f)))
|
|
|
|
(define (gc-point)
|
|
;; Forcing a GC on document boundaries helps keep peak memory use down.
|
|
(collect-garbage))
|
|
|
|
(define-namespace-anchor anchor)
|
|
|
|
(define (with-my-namespace thunk)
|
|
(parameterize ([current-namespace (namespace-anchor->empty-namespace anchor)])
|
|
(thunk)))
|
|
|
|
(define-syntax-rule (with-my-namespace* body ...)
|
|
(parameterize ([current-namespace (namespace-anchor->empty-namespace anchor)])
|
|
body ...))
|
|
|
|
(define (make-isolated-namespace)
|
|
;; For loading documents or contexts where deserialization
|
|
;; might load additional modules.
|
|
(let ([p (make-empty-namespace)]
|
|
[ns (namespace-anchor->empty-namespace anchor)])
|
|
(namespace-attach-module ns 'scribble/base-render p)
|
|
(namespace-attach-module ns 'scribble/html-render p)
|
|
(namespace-attach-module ns 'scribble/latex-render p)
|
|
;; This is here for de-serialization; we need a better repair than
|
|
;; hard-wiring the "manual.rkt" library:
|
|
(namespace-attach-module ns 'scribble/private/manual-class-struct p)
|
|
p))
|
|
|
|
(define (dynamic-require-doc mod-path)
|
|
;; Use a separate namespace so that we don't end up with all the
|
|
;; documentation loaded at once.
|
|
(parameterize ([current-namespace (make-isolated-namespace)])
|
|
(call-in-nested-thread (lambda ()
|
|
(define sub
|
|
(if (and (pair? mod-path)
|
|
(eq? (car mod-path) 'submod))
|
|
(append mod-path '(doc))
|
|
`(submod ,mod-path doc)))
|
|
(if (module-declared? sub #t)
|
|
(dynamic-require sub 'doc)
|
|
(dynamic-require mod-path 'doc))))))
|
|
|
|
(define (write- latex-dest vers doc name datas prep! final!)
|
|
(let* ([filename (sxref-path latex-dest doc name)])
|
|
(prep! filename)
|
|
(verbose/log "Caching to disk ~a" filename)
|
|
(make-directory* (doc-dest-dir doc))
|
|
(with-compile-output
|
|
filename
|
|
(lambda (out tmp-filename)
|
|
(for ([data (in-list datas)])
|
|
(write-bytes (s-exp->fasl (append (list (list vers (doc-flags doc)))
|
|
data))
|
|
out))))
|
|
(final! filename)))
|
|
|
|
(define (write-out latex-dest vers doc scis providess db-file lock)
|
|
;; A "provides.sxref" file is used when a package is converted to binary
|
|
;; form, in which case cross-reference information needs to be loaded
|
|
;; into the database at install time:
|
|
(when (and (doc-pkg? doc)
|
|
(not (doc-under-main? doc))
|
|
(not latex-dest))
|
|
(make-directory* (doc-dest-dir doc))
|
|
(with-compile-output
|
|
(sxref-path latex-dest doc "provides.sxref")
|
|
(lambda (out tmp-filename)
|
|
(s-exp->fasl providess out))))
|
|
;; Write each "out.sxref" file and install the corresponding provides
|
|
;; into the database:
|
|
(for ([i (add1 (doc-out-count doc))]
|
|
[sci scis]
|
|
[provides providess])
|
|
(write- latex-dest vers doc (format "out~a.sxref" i)
|
|
(list (list sci))
|
|
(lambda (filename)
|
|
(call-with-lock
|
|
lock
|
|
(lambda ()
|
|
(doc-db-clear-provides db-file filename)
|
|
(doc-db-add-provides db-file provides filename))))
|
|
(lambda (filename)
|
|
(call-with-lock
|
|
lock
|
|
(lambda ()
|
|
(doc-db-set-provides-timestamp
|
|
db-file filename
|
|
(file-or-directory-modify-seconds filename))))))))
|
|
|
|
(define (write-out/info latex-dest info scis providess db-file lock)
|
|
(write-out latex-dest (info-vers info) (info-doc info) scis providess db-file lock))
|
|
|
|
(define (write-in latex-dest vers doc undef rels searches db-file lock)
|
|
(write- latex-dest vers doc "in.sxref"
|
|
(list (list rels)
|
|
(list (serialize (list undef
|
|
searches))))
|
|
(lambda (filename)
|
|
(call-with-lock
|
|
lock
|
|
(lambda ()
|
|
(doc-db-clear-dependencies db-file filename)
|
|
(doc-db-clear-searches db-file filename)
|
|
(doc-db-add-dependencies db-file undef filename)
|
|
(doc-db-add-searches db-file searches filename))))
|
|
void))
|
|
|
|
(define (write-in/info latex-dest info lock main-doc-exists?)
|
|
(when (eq? 'delayed (info-undef info))
|
|
(read-delayed-in! info latex-dest))
|
|
(write-in latex-dest
|
|
(info-vers info)
|
|
(info-doc info)
|
|
(info-undef info)
|
|
(info-deps->rel-doc-src-file info)
|
|
(info-searches info)
|
|
(find-db-file (info-doc info) latex-dest main-doc-exists?)
|
|
lock))
|
|
|
|
(define (rel->path r)
|
|
(if (bytes? r)
|
|
(bytes->path r)
|
|
(collects-relative->path r)))
|
|
|
|
(define (path->rel r)
|
|
(let ([r (path->collects-relative r)])
|
|
(if (path? r)
|
|
(path->bytes r)
|
|
r)))
|
|
|
|
(define (doc->rel-doc d)
|
|
(struct-copy doc
|
|
d
|
|
[src-dir (path->collects-relative (doc-src-dir d))]
|
|
[src-file (path->collects-relative (doc-src-file d))]
|
|
[dest-dir (path->main-doc-relative (doc-dest-dir d))]))
|
|
|
|
(define (rel-doc->doc d)
|
|
(struct-copy doc
|
|
d
|
|
[src-dir (collects-relative->path (doc-src-dir d))]
|
|
[src-file (collects-relative->path (doc-src-file d))]
|
|
[dest-dir (main-doc-relative->path (doc-dest-dir d))]))
|
|
|
|
(define (info-deps->rel-doc-src-file info)
|
|
(filter-map (lambda (ii)
|
|
(define i (car ii))
|
|
(and (info? i)
|
|
(cons (path->rel (doc-src-file (info-doc i)))
|
|
(cdr ii))))
|
|
(info-deps info)))
|
|
|
|
(define (info-deps->doc info)
|
|
(filter-map (lambda (i) (and (info? i) (info-doc i))) (info-deps info)))
|
|
|
|
(define (reroot-path* base root)
|
|
(cond
|
|
[(eq? root 'same) base]
|
|
[(relative-path? root)
|
|
(build-path base root)]
|
|
[else
|
|
(reroot-path base root)]))
|