From aa71be72cfc105fb97d55161ecdd79eea8122410 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 11 Jan 2008 08:25:46 +0000 Subject: [PATCH] improve code organization svn: r8293 --- collects/setup/scribble.ss | 858 +++++++++++++++++-------------------- 1 file changed, 400 insertions(+), 458 deletions(-) diff --git a/collects/setup/scribble.ss b/collects/setup/scribble.ss index a00c3413b2..c849bcfdcd 100644 --- a/collects/setup/scribble.ss +++ b/collects/setup/scribble.ss @@ -1,469 +1,411 @@ +#lang scheme/base -(module scribble scheme/base - (require "getinfo.ss" - "dirs.ss" - scheme/class - scheme/file - setup/main-collects - scribble/base-render - scribble/struct - scribble/manual ; really shouldn't be here... see dynamic-require-doc - (prefix-in html: scribble/html-render) - (prefix-in latex: scribble/latex-render)) +(require "getinfo.ss" + "dirs.ss" + scheme/class + scheme/file + setup/main-collects + scribble/base-render + scribble/struct + 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) +(provide setup-scribblings + verbose) - (define verbose (make-parameter #t)) +(define verbose (make-parameter #t)) - (define-struct doc (src-dir src-file dest-dir flags)) - (define-struct info (doc sci provides undef searches deps - build? time out-time need-run? - need-in-write? need-out-write? - vers rendered?) - #:mutable) +(define-struct doc (src-dir src-file dest-dir flags)) +(define-struct info (doc sci provides undef searches 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 - always-run))) - (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 (or (memq 'main-doc flags) - (pair? (path->main-collects-relative dir))) - (build-path (find-doc-dir) name) - (build-path dir "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 (filter values (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)) - (let ([not-found - (lambda (k) - (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))]) - (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 (eq? (car k) 'dep) - (not-found k)))))) - (info-undef info)) - (when first? - (hash-table-for-each (info-searches info) - (lambda (s-key s-ht) - (unless (ormap - (lambda (k) (hash-table-get ht k #f)) - (hash-table-map s-ht (lambda (k v) k))) - (not-found s-key)))))) - (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 v src-file) - (let ([p (format "~a" - (path->main-collects-relative src-file))]) - (when (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))) - (let ([tag-prefix p] - [tags (if (member '(part "top") (part-tags v)) - (part-tags v) - (cons '(part "top") (part-tags v)))]) - (make-versioned-part tag-prefix - tags - (part-title-content v) - (part-style v) - (part-to-collect v) - (part-flow v) - (part-parts v) - (if (versioned-part? v) - (versioned-part-version v) - #f))))) - - (define ((get-doc-info only-dirs latex-dest) doc) - (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")] - [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)] - [aux-time (max - (file-or-directory-modify-seconds (build-path - (collection-path "scribble") - "compiled" - (path-add-suffix - (if latex-dest - "latex-render.ss" - "html-render.ss") - ".zo")) - #f (lambda () -inf.0)) - (file-or-directory-modify-seconds (build-path - (collection-path "scribble") - "scribble.css") - #f (lambda () +inf.0)))]) - (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 - . >= . - (max aux-time - (file-or-directory-modify-seconds src-zo #f (lambda () +inf.0))))))]) - (printf " [~a ~a]\n" - (if up-to-date? - "Using" - (if can-run? - "Running" - "Skipping")) - (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 - (list-ref v-in 3) ; searches - (map string->path (list-ref v-in 2)) ; deps, in case we don't need to build... - can-run? - my-time info-out-time - (and can-run? - (memq 'always-run (doc-flags doc))) - #f #f - vers - #f))) - (if can-run? - ;; Run the doc once: - (parameterize ([current-directory (doc-src-dir doc)]) - (let ([v (ensure-doc-prefix (dynamic-require-doc (doc-src-file doc)) - (doc-src-file doc))] - [dest-dir (pick-dest latex-dest doc)]) - (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)] - [searches (resolve-info-searches ri)]) - (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) - searches - 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))))))) - #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 (ensure-doc-prefix (dynamic-require-doc (doc-src-file doc)) - (doc-src-file doc))] - [dest-dir (pick-dest latex-dest doc)]) - (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))))]) +(define (setup-scribblings only-dirs latex-dest) + (let* ([dirs (find-relevant-directories '(scribblings))] + [infos (map get-info/full dirs)] + [docs (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 (list? (cadr v)) + (andmap (lambda (i) + (member i '(main-doc + multi-page + always-run))) + (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 (or (memq 'main-doc flags) + (pair? (path->main-collects-relative dir))) + (build-path (find-doc-dir) name) + (build-path dir "doc" name))) + flags))) + s) + (begin + (fprintf (current-error-port) + " bad 'scribblings info: ~e from: ~e\n" + s + dir) + null)))) + infos dirs)] + [docs (apply append docs)]) + (when (ormap (can-build? only-dirs) docs) + (let ([infos (filter values (map (get-doc-info only-dirs latex-dest) docs))]) + (let loop ([first? #t] [iter 0]) + (let ([ht (make-hash-table 'equal)]) + ;; Collect definitions + (for* ([info infos] + [k (info-provides info)]) + (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))) + ;; Build deps: + (let ([src->info (make-hash-table 'equal)]) + (for ([i infos]) + (hash-table-put! src->info (doc-src-file (info-doc i)) i)) + (for ([info infos] + #:when (info-build? info)) + (let ([one? #f] + [added? #f] + [deps (make-hash-table)]) + (set-info-deps! + info + (map (lambda (d) + (if (info? d) + d + (or (hash-table-get src->info d #f) + d))) + (info-deps info))) + (for ([d (info-deps info)]) + (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)))))))) + (let ([not-found + (lambda (k) + (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))]) + (for ([k (info-undef info)]) + (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 (eq? (car k) 'dep) (not-found k)))))) + (when first? + (for ([(s-key s-ht) (info-searches info)]) + (unless (ormap (lambda (k) (hash-table-get ht k #f)) + (hash-table-map s-ht (lambda (k v) k))) + (not-found s-key))))) + (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))))) + ;; If a dependency changed, then we need a re-run: + (for ([i infos] + #:when (not (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 " [~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))))))))) + (printf " [Dependency: ~a\n <- ~a]\n" + (doc-src-file (info-doc i)) + (doc-src-file (info-doc ch)))) + (set-info-need-run?! i #t)))) + ;; Iterate, if any need to run: + (when (and (ormap info-need-run? infos) (iter . < . 30)) + ;; Build again, using dependencies + (for ([i infos] #:when (info-need-run? i)) + (set-info-need-run?! i #f) + (build-again! latex-dest i)) + (loop #f (add1 iter))))) + ;; cache info to disk + (unless latex-dest + (for ([i infos] #:when (info-need-in-write? i)) + (write-in i))))))) - (define-namespace-anchor anchor) +(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 (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-empty-namespace)] - [c (make-custodian)] - [ch (make-channel)] - [ns (namespace-anchor->empty-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 (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 (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)) - (info-searches info)))))))))) +(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 (write-out info) - (make-directory* (doc-dest-dir (info-doc info))) - (write- info "out.sxref" (lambda (o i) o))) - (define (write-in info) - (make-directory* (doc-dest-dir (info-doc info))) - (write- info "in.sxref" (lambda (o i) i))) +(define (ensure-doc-prefix v src-file) + (let ([p (format "~a" (path->main-collects-relative src-file))]) + (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-file + p)) + (let ([tag-prefix p] + [tags (if (member '(part "top") (part-tags v)) + (part-tags v) + (cons '(part "top") (part-tags v)))]) + (make-versioned-part tag-prefix + tags + (part-title-content v) + (part-style v) + (part-to-collect v) + (part-flow v) + (part-parts v) + (and (versioned-part? v) (versioned-part-version v)))))) - ) +(define ((get-doc-info only-dirs latex-dest) doc) + (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")] + [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)] + [aux-time (max (file-or-directory-modify-seconds + (build-path (collection-path "scribble") + "compiled" + (path-add-suffix + (if latex-dest + "latex-render.ss" + "html-render.ss") + ".zo")) + #f (lambda () -inf.0)) + (file-or-directory-modify-seconds + (build-path (collection-path "scribble") + "scribble.css") + #f (lambda () +inf.0)))] + [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)] + [up-to-date? + (and info-out-time + info-in-time + (or (not can-run?) + (my-time . >= . (max aux-time + (file-or-directory-modify-seconds + src-zo #f (lambda () +inf.0))))))]) + (printf " [~a ~a]\n" + (if up-to-date? "Using" (if can-run? "Running" "Skipping")) + (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 + (list-ref v-in 3) ; searches + (map string->path (list-ref v-in 2)) ; deps, in case we don't need to build... + can-run? + my-time info-out-time + (and can-run? (memq 'always-run (doc-flags doc))) + #f #f + vers + #f))) + (if can-run? + ;; Run the doc once: + (parameterize ([current-directory (doc-src-dir doc)]) + (let* ([v (ensure-doc-prefix (dynamic-require-doc (doc-src-file doc)) + (doc-src-file doc))] + [dest-dir (pick-dest latex-dest doc)] + [ci (send renderer collect (list v) (list dest-dir))] + [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)))] + [sci (send renderer serialize-info ri)] + [defs (send renderer get-defined ci)] + [searches (resolve-info-searches ri)] + [need-out-write? + (or (not (equal? (list (list vers (doc-flags doc)) sci defs) + out-v)) + (info-out-time . > . (current-seconds)))]) + (when (and (verbose) 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) + searches + 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))) + #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 (ensure-doc-prefix (dynamic-require-doc (doc-src-file doc)) + (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)) + (let* ([ri (send renderer resolve (list v) (list dest-dir) ci)] + [sci (send renderer serialize-info ri)] + [defs (send renderer get-defined ci)] + [undef (send renderer get-undefined ri)] + [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 " "") + (cond [out-delta? "New out "] + [in-delta? ""] + [else "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 ([f (directory-list dir)] + #:when (regexp-match? #"[.]html$" (path-element->bytes f))) + (delete-file (build-path dir f))))) + (send renderer render (list v) (list dest-dir) ri) + (set-info-time! info (/ (current-inexact-milliseconds) 1000)) + (void)))))) + +(define-namespace-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-empty-namespace)] + [c (make-custodian)] + [ch (make-channel)] + [ns (namespace-anchor->empty-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)) + (info-searches info)))))))))) + +(define (write-out info) + (make-directory* (doc-dest-dir (info-doc info))) + (write- info "out.sxref" (lambda (o i) o))) +(define (write-in info) + (make-directory* (doc-dest-dir (info-doc info))) + (write- info "in.sxref" (lambda (o i) i)))