#lang scheme/base

(require "getinfo.rkt"
         "dirs.rkt"
         "path-to-relative.rkt"
         "private/path-utils.rkt"
         "main-collects.rkt"
         "main-doc.rkt"
         "parallel-do.rkt"
         scheme/class
         scheme/list
         scheme/file
         scheme/fasl
         scheme/match
         scheme/serialize
         compiler/cm
         syntax/modread
         scribble/base-render
         scribble/core
         scribble/html-properties
         scribble/manual ; really shouldn't be here... see dynamic-require-doc
         scribble/private/run-pdflatex
         unstable/file
         (prefix-in html: scribble/html-render)
         (prefix-in latex: scribble/latex-render))

(provide setup-scribblings
         verbose
         run-pdflatex)

(define verbose (make-parameter #t))

(define-serializable-struct doc (src-dir src-spec src-file dest-dir flags under-main? category) #:transparent)
(define-serializable-struct info (doc      ; doc structure above
                                  provides ; provides
                                  undef    ; unresolved requires
                                  searches 
                                  deps 
                                  known-deps
                                  build? time out-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 (filter-user-docs docs make-user?)
  (cond ;; Specifically disabled user stuff, filter
   [(not make-user?) (filter main-doc? docs)]
   ;; If we've built user-specific before, keep building
   [(file-exists? (build-path (find-user-doc-dir) "index.html")) docs]
   ;; Otherwise, see if we need it:
   [(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 setup-printf doc errmsg outstr errstr)
  (setup-printf "error running" (module-path-prefix->string (doc-src-spec doc)))
  (eprintf errstr))

(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?
         with-record-error  ; catch & record exceptions
         setup-printf)
  (define (scribblings-flag? sym)
    (memq sym '(main-doc main-doc-root user-doc-root user-doc multi-page
                         depends-all depends-all-main no-depend-on always-run)))
  (define (validate-scribblings-infos infos)
    (define (validate path [flags '()] [cat '(library)] [name #f])
      (and (string? path) (relative-path? path)
           (list? flags) (andmap scribblings-flag? flags)
           (or (not name) (and (path-string? name) (relative-path? name) name))
           (and (list? cat)
                (<= 1 (length cat) 2)
                (symbol? (car cat))
                (or (null? (cdr cat))
                    (real? (cadr cat))))
           (list path flags cat
                 (or name (let-values ([(_1 name _2) (split-path path)])
                            (path-replace-suffix name #""))))))
    (and (list? infos)
         (let ([infos (map (lambda (i)
                             (and (list? i) (<= 1 (length i) 4)
                                  (apply validate i)))
                           infos)])
           (and (not (memq #f infos)) infos))))
  (define ((get-docs main-dirs) i rec)
    (let ([s (validate-scribblings-infos (i 'scribblings))]
          [dir (directory-record-path rec)])
      (if s
          (map (lambda (d)
                 (let* ([flags (cadr d)]
                        [under-main?
                         (and (not (memq 'main-doc-root flags))
                              (not (memq 'user-doc-root flags))
                              (not (memq 'user-doc flags))
                              (or (memq 'main-doc flags)
                                  (hash-ref main-dirs dir #f)
                                  (pair? (path->main-collects-relative dir))))])
                   (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))))
                             (simplify-path (build-path dir (car d)) #f)
                             (doc-path dir (cadddr d) flags under-main?)
                             flags under-main? (caddr d))))
               s)
          (begin (setup-printf
                  "WARNING"
                  "bad 'scribblings info: ~e from: ~e" (i 'scribblings) dir)
                 null))))
  (define docs
    (let* ([recs (find-relevant-directory-records '(scribblings) 'all-available)]
           [main-dirs (parameterize ([current-library-collection-paths
                                      (list (find-collects-dir))])
                        (for/hash ([k (in-list (find-relevant-directories '(scribblings) 'no-planet))])
                          (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?)))
  (define-values (main-docs user-docs) (partition doc-under-main? docs))
  (define (can-build*? docs) (can-build? only-dirs docs))
  (define auto-main? (and auto-start-doc? (ormap can-build*? main-docs)))
  (define auto-user? (and auto-start-doc? (ormap can-build*? user-docs)))
  (define infos
    (and (ormap can-build*? docs)
         (filter values
                 (if (not (worker-count . > . 1))
                     (map (get-doc-info only-dirs latex-dest auto-main? auto-user? 
                                        with-record-error setup-printf #f) 
                          docs)
                     (parallel-do 
                      worker-count
                      (lambda (workerid)
                        (list workerid program-name (verbose) only-dirs latex-dest auto-main? auto-user?))
                      (list-queue
                       docs
                       (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 setup-printf work errmsg outstr errstr)))
                      (define-worker (get-doc-info-worker workerid program-name verbosev only-dirs latex-dest 
                                                          auto-main? auto-user?) 
                        (define ((get-doc-info-local program-name only-dirs latex-dest auto-main? auto-user?) 
                                 doc)
                          (define (setup-printf subpart formatstr . rest)
                            (let ([task (if subpart
                                            (format "~a: " subpart)
                                            "")])
                              (printf "~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)
                                               (eprintf "~a\n" (exn-message exn))
                                               (raise exn))])
                              (go)))
                          (s-exp->fasl (serialize 
                                        ((get-doc-info only-dirs latex-dest auto-main? auto-user?  
                                                       with-record-error setup-printf workerid)
                                         (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?) 
                                doc))])))))))

  (define (make-loop first? iter)
    (let ([ht (make-hash)]
          [infos (filter-not info-failed? infos)]
          [src->info (make-hash)])
      ;; Collect definitions
      (for* ([info infos]
             [k (info-provides info)])
        (let ([prev (hash-ref ht k #f)])
          (when (and first? prev)
            (setup-printf "WARNING" "duplicate tag: ~s" k)
            (setup-printf #f " in: ~a" (doc-src-file (info-doc prev)))
            (setup-printf #f " and: ~a" (doc-src-file (info-doc info))))
          (hash-set! ht k info)))
      ;; Build deps:
      (for ([i infos])
        (hash-set! src->info (doc-src-file (info-doc i)) i))
      (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)))])
          ;; Convert current deps from paths to infos, keeping paths that have no info
          (set-info-deps!
           info
           (map (lambda (d)
                  (if (info? d) d (or (hash-ref src->info d #f) d)))
                (info-deps info)))
          (unless (andmap info? (info-deps info))
            (set-info-need-in-write?! info #t))
          ;; Propagate existing dependencies as expected dependencies:
          (for ([d (info-deps info)])
            (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 (memq 'depends-all (doc-flags (info-doc info)))
                              (and (if (info? d)
                                       (doc-under-main? (info-doc d))
                                       (not (path? (path->main-collects-relative d))))
                                   all-main?))
                    (set! added? #t)
                    (when (verbose)
                      (printf " [Removed Dependency: ~a]\n"
                              (doc-src-file (info-doc info))))))))
          (when (or (memq 'depends-all (doc-flags (info-doc info))) all-main?)
            ;; Add all as expected dependency:
            (when (verbose)
              (printf " [Adding all~a as dependencies: ~a]\n"
                      (if all-main? " main" "")
                      (doc-src-file (info-doc info))))
            (for ([i infos])
              (when (and (not (eq? i info))
                         (not (hash-ref deps i #f))
                         (or (not all-main?) (doc-under-main? (info-doc i)))
                         (not (memq 'no-depend-on (doc-flags (info-doc i)))))
                (set! added? #t)
                (hash-set! deps i #t))))
          ;; Add defeinite dependencies based on referenced keys
          (let ([not-found
                 (lambda (k)
                   (unless (or (memq 'depends-all (doc-flags (info-doc info)))
                               (memq 'depends-all-main (doc-flags (info-doc info))))
                     (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)))])
            (for ([k (info-undef info)])
              (let ([i (hash-ref ht k #f)])
                (if i
                    (begin
                      ;; Record a definite dependency:
                      (when (not (hash-ref known-deps i #f))
                        (hash-set! known-deps i #t))
                      ;; Record also in the expected-dependency list:
                      (when (not (hash-ref deps i #f))
                        (set! added? #t)
                        (when (verbose)
                          (printf " [Adding... ~a]\n"
                                  (doc-src-file (info-doc i))))
                        (hash-set! deps i #t)))
                    (when first? 
                      ;; FIXME: instead of special-casing 'dep, we should
                      ;; skip any key that is covered by `(info-searches info)'.
                      (unless (eq? (car k) 'dep) 
                        (not-found k))))))
            (when first?
              (for ([(s-key s-ht) (info-searches info)])
                (unless (ormap (lambda (k) (hash-ref ht k #f))
                               (hash-map s-ht (lambda (k v) k)))
                  (not-found s-key)))))
          ;; If we added anything (expected or known), then mark as needed to run
          (when added?
            (when (verbose)
              (printf " [Added Dependency: ~a]\n"
                      (doc-src-file (info-doc info))))
            (set-info-deps! info (hash-map deps (lambda (k v) k)))
            (set-info-known-deps! info (hash-map known-deps (lambda (k v) k)))
            (set-info-need-in-write?! info #t)
            (set-info-need-run?! info #t))))
      ;; If any expected dependency changed, then we need a re-run:
      (for ([i infos]
            #:unless (or (info-need-run? i) (not (info-build? i))))
        (let ([ch (ormap (lambda (i2)
                           (or (and (not (info? i2))
                                    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))
                      (if (info? ch)
                          (doc-src-file (info-doc ch))
                          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
        (let ([need-rerun (filter-map (lambda (i) 
                                        (and (info-need-run? i)
                                             (begin
                                               (when (info-need-in-write? i) 
                                                 (write-in/info latex-dest i)
                                                 (set-info-need-in-write?! i #f))
                                               (set-info-deps! i (filter info? (info-deps i)))
                                               (set-info-need-run?! i #f)
                                               i)))
                                      infos)])
          (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 (update-info info response)
            (match response 
              [#f (set-info-failed?! info #t)]
              [(list in-delta? out-delta? defs undef)
               (set-info-rendered?! info #t)
               (set-info-provides! info defs)
               (set-info-undef! info undef)
               (when out-delta?
                 (set-info-out-time! info (/ (current-inexact-milliseconds) 1000)))
               (when in-delta? 
                 ;; Reset expected dependencies to known dependencies, and recompute later:
                 (set-info-deps! info (info-known-deps info))
                 (set-info-need-in-write?! info #t))
               (set-info-time! info (/ (current-inexact-milliseconds) 1000))]))
          (if (not (worker-count . > . 1))
              (map (lambda (i) 
                     (say-rendering i #f)
                     (update-info i (build-again! latex-dest i with-record-error))) need-rerun)
              (parallel-do 
               worker-count
               (lambda (workerid) (list workerid (verbose) latex-dest))
               (list-queue
                need-rerun
                (lambda (i workerid) 
                  (say-rendering i workerid)
                  (s-exp->fasl (serialize (info-doc 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 setup-printf (info-doc i) errmsg outstr errstr)))
               (define-worker (build-again!-worker2 workerid verbosev latex-dest)
                 (define (with-record-error cc go fail-k)
                   (with-handlers ([exn:fail?
                                    (lambda (x)
                                      (eprintf "~a\n" (exn-message 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))))])))))
        ;; 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))))))
  (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))))

(define (make-renderer latex-dest doc)
  (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))])
        (new ((if multi? html:render-multi-mixin values)
              (html:render-mixin render%))
             [dest-dir (if multi?
                           (let-values ([(base name dir?) (split-path ddir)]) base)
                           ddir)]
             [alt-paths   (if main?
                              (let ([std-path (lambda (s)
                                                (cons (collection-file-path s "scribble")
                                                      (format "../~a" s)))])
                                (list (std-path "scribble.css")
                                      (std-path "scribble-style.css")
                                      (std-path "racket.css")
                                      (std-path "scribble-common.js")))
                              null)]
             ;; For main-directory, non-start files, up-path is #t, which makes the
             ;; "up" link go to the (user's) start page using cookies. For other files,
             ;; 
             [up-path     (and (not root?)
                               (if main?
                                   #t
                                   (build-path (find-user-doc-dir) "index.html")))]
             [search-box? #t]))))

(define (pick-dest latex-dest doc)
  (cond [latex-dest
         (let-values ([(base name dir?) (split-path (doc-src-file doc))])
           (build-path latex-dest (path-replace-suffix name #".tex")))]
        [(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 [latex-dest
         (let-values ([(base name dir?) (split-path (doc-src-file doc))])
           (build-path latex-dest (path-replace-suffix name (string-append "." file))))]
        [else (build-path (doc-dest-dir doc) file)]))

(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 (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))])
           (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)
  (call-with-input-file filename (lambda (x) (fasl->s-exp x))))

(define (file-or-directory-modify-seconds/stamp file
                                                stamp-time stamp-data pos
                                                get-sha1)
  (let ([t (file-or-directory-modify-seconds file #f (lambda () +inf.0))])
    (cond
     [(t . <= . stamp-time) stamp-time]
     [(equal? (list-ref stamp-data pos) (get-sha1 file)) stamp-time]
     [else t])))

(define ((get-doc-info only-dirs latex-dest auto-main? auto-user?
                       with-record-error setup-printf workerid)
         doc)
  (let* ([info-out-file (sxref-path latex-dest doc "out.sxref")]
         [info-in-file  (sxref-path latex-dest doc "in.sxref")]
         [stamp-file  (sxref-path latex-dest doc "stamp.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)]
         [stamp-time (file-or-directory-modify-seconds stamp-file #f (lambda () -inf.0))]
         [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 (build-path (collection-path "scribble")
                                    "compiled"
                                    (path-add-suffix
                                     (if latex-dest
                                         "latex-render.rkt"
                                         "html-render.rkt")
                                     ".zo"))]
         [css-path (collection-file-path "scribble.css" "scribble")]
         [aux-time (max (file-or-directory-modify-seconds/stamp
                         renderer-path
                         stamp-time stamp-data 1
                         get-compiled-file-sha1)
                        (file-or-directory-modify-seconds/stamp
                         css-path
                         stamp-time stamp-data 2
                         get-file-sha1))]
         [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))]
         [info-time (min (or info-out-time -inf.0) (or info-in-time -inf.0))]
         [vers (send renderer get-serialize-version)]
         [src-time (file-or-directory-modify-seconds/stamp
                    src-zo
                    stamp-time stamp-data 0
                    get-compiled-file-sha1)]
         [up-to-date?
          (and info-out-time
               info-in-time
               (or (not can-run?)
                   ;; Need to rebuild if output file is older than input:
                   (my-time . >= . src-time)
                   ;; But we can use in/out information if they're already built;
                   ;; this is mostly useful if we interrupt setup-plt after
                   ;; it runs some documents without rendering them:
                   (info-time . >= . src-time)))]
         [can-run? (and (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?
                                 (memq 'depends-all (doc-flags doc)))))])
    (when (or (not up-to-date?) (verbose))
      (setup-printf
       (string-append
        (if workerid (format "~a " workerid) "")
        (cond [up-to-date? "using"] [can-run? "running"] [else "skipping"]))
       "~a"
       (path->relative-string/setup (doc-src-file doc))))

    (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)))
                                      (delete-file info-out-file)
                                      (delete-file info-in-file)
                                      ((get-doc-info only-dirs latex-dest auto-main?
                                                     auto-user? with-record-error
                                                     setup-printf workerid)
                                       doc))])
           (let* ([v-in  (load-sxref info-in-file)]
                  [v-out (load-sxref info-out-file)])
             (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
              (let ([v (list-ref v-out 2)]) ; provides
                (with-my-namespace
                 (lambda ()
                   (deserialize v))))
              (let ([v (list-ref v-in 1)])  ; undef
                (with-my-namespace
                 (lambda ()
                   (deserialize v))))
              (let ([v (list-ref v-in 3)])  ; searches
                (with-my-namespace
                 (lambda ()
                   (deserialize v))))
              (map rel->path (list-ref v-in 2)) ; expected deps, in case we don't need to build...
              null ; known deps (none at this point)
              can-run?
              my-time info-out-time
              (and can-run? (memq 'always-run (doc-flags doc)))
              #f 
              #f
              vers
              #f
              #f))))
        (if can-run?
            ;; Run the doc once:
            (with-record-error
             (doc-src-file doc)
             (lambda ()
               (parameterize ([current-directory (doc-src-dir doc)])
                 (let* ([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)]
                        [ri (send renderer resolve (list v) (list dest-dir) ci)]
                        [out-v (and info-out-time
                                    (info-out-time . >= . src-time)
                                    (with-handlers ([exn:fail? (lambda (exn) #f)])
                                      (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)))]
                        [sci (send renderer serialize-info ri)]
                        [defs (send renderer get-defined ci)]
                        [undef (send renderer get-external ri)]
                        [searches (resolve-info-searches ri)]
                        [need-out-write?
                         (or (not out-v)
                             (not (equal? (list vers (doc-flags doc))
                                          (car out-v)))
                             (not (serialized=? sci (cadr out-v)))
                             (not (equal? (any-order defs) (any-order (deserialize (caddr 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)))
                   (gc-point)
                   (let ([info
                          (make-info doc
                                     defs     ; provides
                                     undef
                                     searches
                                     null ; no deps, yet
                                     null ; no known 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)])
                     (when need-out-write?
                       (render-time "xref-out" (write-out/info latex-dest info sci))
                       (set-info-need-out-write?! info #f))
                     (when (info-need-in-write? info)
                       (render-time "xref-in" (write-in/info latex-dest info))
                       (set-info-need-in-write?! info #f))

                     (when (or (stamp-time . < . aux-time)
                               (stamp-time . < . src-time))
                       (let ([data (list (get-compiled-file-sha1 src-zo)
                                         (get-compiled-file-sha1 renderer-path)
                                         (get-file-sha1 css-path))])
                         (with-compile-output stamp-file (lambda (out tmp-filename) (write data out)))
                         (let ([m (max aux-time src-time)])
                           (unless (equal? m +inf.0)
                             (file-or-directory-modify-seconds stamp-file m)))))
                     info))))
             (lambda () #f))
            #f))))

(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)
  expr
  #;
  (begin
  (printf "For ~a\n" what)
  (time expr))
  #;
  (begin
  (collect-garbage) (collect-garbage) (printf "pre: ~a ~s\n" what (current-memory-use))
  (begin0
  (time expr)
  (collect-garbage) (collect-garbage) (printf "post ~a ~s\n" what (current-memory-use)))))

(define (load-sxrefs latex-dest doc vers)
  (match (list (load-sxref (sxref-path latex-dest doc "in.sxref")) (load-sxref (sxref-path latex-dest doc "out.sxref")))
    [(list (list in-version undef deps-rel searches dep-docs) (list out-version sci provides))
     (unless (and (equal? in-version  (list vers (doc-flags doc)))
                  (equal? out-version (list vers (doc-flags doc))))
       (error "old info has wrong version or flags"))
     (with-my-namespace*
      (values (deserialize undef) 
              deps-rel
              (deserialize searches)
              (map rel-doc->doc (deserialize dep-docs))
              sci
              (deserialize provides)))]))

(define (build-again! latex-dest info with-record-error)
  (define (cleanup-dest-dir doc)
    (unless latex-dest
      (let ([dir (doc-dest-dir doc)])
        (if (not (directory-exists? dir))
            (make-directory*/ignore-exists-exn 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-sci doc)
    (cadr (load-sxref (sxref-path latex-dest doc "out.sxref"))))
  (define doc (if (info? info ) (info-doc info) info))
  (define renderer (make-renderer latex-dest doc))
  (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-dep-docs ff-sci ff-provides)
       (if (info? info)
           (values (info-undef info) 
                   (info-deps->rel-doc-src-file info)
                   (info-searches info)
                   (info-deps->doc info)
                   (load-doc-sci doc)
                   (info-provides info))
           (load-sxrefs latex-dest doc vers)))
     
     (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))]
              [ri (begin 
                    (render-time "deserialize" 
                                 (with-my-namespace* 
                                  (for ([dep-doc ff-dep-docs]) 
                                    (send renderer deserialize-info (load-doc-sci dep-doc) ci))))
                    (render-time "resolve" (send renderer resolve (list v) (list dest-dir) ci)))]
              [sci (render-time "serialize" (send renderer serialize-info ri))]
              [defs (render-time "defined" (send renderer get-defined ci))]
              [undef (render-time "undefined" (send renderer get-external ri))]
              [in-delta? (not (equal? (any-order undef) (any-order ff-undef)))]
              [out-delta? (or (not (serialized=? sci ff-sci))
                              (not (equal? (any-order defs) (any-order ff-provides))))])
         (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 in-delta?
           (render-time "xref-in" (write-in latex-dest vers doc undef ff-deps-rel ff-searches ff-dep-docs)))
         (when out-delta?
           (render-time "xref-out" (write-out latex-dest vers doc sci defs)))

         (cleanup-dest-dir doc)
         (render-time
          "render"
          (with-record-error
           (doc-src-file doc)
           (lambda () (send renderer render (list v) (list dest-dir) ri))
           void))
         (gc-point)
         (list in-delta? out-delta? defs undef))))
   (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 (dynamic-require-doc mod-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.rkt" library:
      (namespace-attach-module ns 'scribble/manual p)
      (parameterize ([current-namespace p])
        (call-in-nested-thread (lambda () (dynamic-require mod-path 'doc)))))))

(define (write- latex-dest vers doc name data)
  (let* ([filename (sxref-path latex-dest doc name)])
    (when (verbose) (printf " [Caching to disk ~a]\n" filename))
    (make-directory*/ignore-exists-exn (doc-dest-dir doc))
    (with-compile-output filename 
                         (lambda (out tmp-filename)
                           (write-bytes (s-exp->fasl (append (list (list vers (doc-flags doc))) data)) out)))))

(define (write-out latex-dest vers doc sci provides)
  (write- latex-dest vers doc "out.sxref" 
          (list sci
                (serialize provides))))

(define (write-out/info latex-dest info sci)
  (write-out latex-dest (info-vers info) (info-doc info) sci (info-provides info)))

(define (write-in latex-dest vers doc undef rels searches dep-docs)
  (write- latex-dest vers doc "in.sxref" 
          (list (serialize undef)
                rels
                (serialize searches)
                ;; The following last element is used only by the parallel build.
                ;; It's redundant in the sense that the same information
                ;; is in `rels' --- the docs that this one depends on ---
                ;; but putting the whole `doc' record here makes it easier
                ;; for a place to reconstruct a suitable `doc' record.
                ;; It probably would be better to reconstruct the `doc'
                ;; record in a place from the path.
                (serialize (map doc->rel-doc dep-docs)))))

(define (write-in/info latex-dest info)
  (write-in latex-dest
            (info-vers info)
            (info-doc info)
            (info-undef info)
            (info-deps->rel-doc-src-file info)
            (info-searches info)
            (info-deps->doc info)))

(define (rel->path r)
  (if (bytes? r)
      (bytes->path r)
      (main-collects-relative->path r)))

(define (path->rel r)
  (let ([r (path->main-collects-relative r)])
    (if (path? r)
        (path->bytes r)
        r)))

(define (doc->rel-doc d)
  (struct-copy doc 
               d
               [src-dir (path->main-collects-relative (doc-src-dir d))]
               [src-file (path->main-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 (main-collects-relative->path (doc-src-dir d))]
               [src-file (main-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 (i) (and (info? i) 
                               (path->rel (doc-src-file (info-doc i))))) 
              (info-deps info)))

(define (info-deps->doc info)
  (filter-map (lambda (i) (and (info? i) (info-doc i))) (info-deps info)))
