1147 lines
49 KiB
Racket
1147 lines
49 KiB
Racket
#lang scheme/base
|
|
|
|
(require "core.rkt"
|
|
"private/render-utils.rkt"
|
|
mzlib/class
|
|
mzlib/serialize
|
|
scheme/file
|
|
scheme/path
|
|
setup/collects
|
|
setup/path-relativize
|
|
file/convertible
|
|
net/url-structs
|
|
"render-struct.rkt")
|
|
|
|
(provide render%
|
|
render<%>)
|
|
|
|
(define render<%>
|
|
(interface ()
|
|
traverse
|
|
collect
|
|
resolve
|
|
render
|
|
serialize-info
|
|
deserialize-info
|
|
get-external
|
|
get-undefined
|
|
|
|
;; undocumented:
|
|
current-render-mode
|
|
get-substitutions
|
|
render-part
|
|
render-flow
|
|
render-intrapara-block
|
|
render-table
|
|
render-itemization
|
|
render-paragraph
|
|
render-content
|
|
render-nested-flow
|
|
render-block
|
|
render-other
|
|
get-dest-directory
|
|
format-number
|
|
number-depth))
|
|
|
|
(define render%
|
|
(class* object% (render<%>)
|
|
|
|
(init-field dest-dir
|
|
[refer-to-existing-files #f]
|
|
[root-path #f]
|
|
[prefix-file #f]
|
|
[style-file #f]
|
|
[style-extra-files null]
|
|
[extra-files null]
|
|
[image-preferences null]
|
|
[helper-file-prefix #f])
|
|
|
|
(define/public (current-render-mode)
|
|
'())
|
|
|
|
(define/public (get-dest-directory [create? #f])
|
|
(when (and dest-dir create? (not (directory-exists? dest-dir)))
|
|
(make-directory* dest-dir))
|
|
dest-dir)
|
|
|
|
(define/public (get-substitutions) null)
|
|
|
|
(define/public (get-suffix) #".txt")
|
|
|
|
(define/public (index-manual-newlines?)
|
|
#f)
|
|
|
|
(define/public (format-number number sep [keep-separator? #f])
|
|
(if (or (null? number)
|
|
(andmap (lambda (x) (or (not x) (equal? x "")))
|
|
number)
|
|
(and (not (car number))
|
|
(not (ormap number? number))))
|
|
null
|
|
(cons (let ([s (string-append
|
|
(apply
|
|
string-append
|
|
(map (lambda (n)
|
|
(cond
|
|
[(number? n) (format "~a." n)]
|
|
[(or (not n) (string? n)) ""]
|
|
[(pair? n) (string-append (car n) (cadr n))]))
|
|
(reverse (cdr number))))
|
|
(if (and (car number)
|
|
(not (equal? "" (car number))))
|
|
(if (pair? (car number))
|
|
(if keep-separator?
|
|
(string-append (caar number)
|
|
(cadar number))
|
|
(caar number))
|
|
(format "~a." (car number)))
|
|
""))])
|
|
(if (or keep-separator?
|
|
(pair? (car number)))
|
|
s
|
|
(substring s 0 (sub1 (string-length s)))))
|
|
sep)))
|
|
|
|
(define/public (number-depth number)
|
|
(if (null? number)
|
|
0
|
|
(+ 1 (for/sum ([i (in-list (cdr number))]) (if (not (string? i)) 1 0)))))
|
|
|
|
(field [report-output?? #f])
|
|
(define/public (report-output?) report-output??)
|
|
(define/public (report-output!) (set! report-output?? #t))
|
|
|
|
;; should work up to 3999:
|
|
(define/private (number->roman n)
|
|
(let loop ([n n]
|
|
[I #\I] [V #\V]
|
|
[X #\X] [L #\L]
|
|
[C #\C] [D #\D]
|
|
[M #\M])
|
|
(case n
|
|
[(0) ""]
|
|
[(1 2 3) (make-string n I)]
|
|
[(4) (string I V)]
|
|
[(5) (string V)]
|
|
[(6 7 8) (string-append (string V) (make-string (- n 5) I))]
|
|
[(9) (string I X)]
|
|
[else
|
|
(string-append (loop (quotient n 10) X L C D M D M)
|
|
(loop (modulo n 10) I V X L C D M))])))
|
|
|
|
;; ----------------------------------------
|
|
;; Methods that really only work on some renderers:
|
|
|
|
(define/public (set-external-tag-path p) (void))
|
|
(define/public (set-external-root-url p) (void))
|
|
(define/public (add-extra-script-file s) (void))
|
|
(define/public (set-directory-depth n) (void))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define/public (extract-part-style-files d ri stop-at-part? pred extract)
|
|
(let ([ht (make-hash)])
|
|
(let loop ([p d] [up? #t] [only-up? #f])
|
|
(let ([s (part-style p)])
|
|
(when up?
|
|
(let ([p (collected-info-parent (part-collected-info p ri))])
|
|
(if p
|
|
(loop p #t #t)
|
|
null)))
|
|
(extract-style-style-files (part-style p) ht pred extract)
|
|
(unless only-up?
|
|
(extract-content-style-files (part-to-collect p) d ri ht pred extract)
|
|
(extract-content-style-files (part-title-content p) d ri ht pred extract)
|
|
(extract-flow-style-files (part-blocks p) d ri ht pred extract))
|
|
(unless only-up?
|
|
(for-each (lambda (p)
|
|
(unless (stop-at-part? p)
|
|
(loop p #f #f)))
|
|
(part-parts p)))))
|
|
(map cdr
|
|
(sort
|
|
(for/list ([(k v) (in-hash ht)])
|
|
(cons v (if (or (bytes? k) (url? k))
|
|
k
|
|
(collects-relative->path k))))
|
|
<
|
|
#:key car))))
|
|
|
|
(define/private (extract-style-style-files s ht pred extract)
|
|
(for ([v (in-list (style-properties s))])
|
|
(when (pred v)
|
|
(hash-update! ht (extract v) values (hash-count ht)))))
|
|
|
|
(define/private (extract-flow-style-files blocks d ri ht pred extract)
|
|
(for ([b (in-list blocks)])
|
|
(extract-block-style-files b d ri ht pred extract)))
|
|
|
|
(define/private (extract-block-style-files p d ri ht pred extract)
|
|
(cond
|
|
[(table? p)
|
|
(extract-style-style-files (table-style p) ht pred extract)
|
|
(for-each (lambda (blocks)
|
|
(for-each (lambda (block)
|
|
(unless (eq? block 'cont)
|
|
(extract-block-style-files block d ri ht pred extract)))
|
|
blocks))
|
|
(table-blockss p))]
|
|
[(itemization? p)
|
|
(extract-style-style-files (itemization-style p) ht pred extract)
|
|
(for-each (lambda (blocks)
|
|
(extract-flow-style-files blocks d ri ht pred extract))
|
|
(itemization-blockss p))]
|
|
[(nested-flow? p)
|
|
(extract-style-style-files (nested-flow-style p) ht pred extract)
|
|
(extract-flow-style-files (nested-flow-blocks p) d ri ht pred extract)]
|
|
[(compound-paragraph? p)
|
|
(extract-style-style-files (compound-paragraph-style p) ht pred extract)
|
|
(extract-flow-style-files (compound-paragraph-blocks p) d ri ht pred extract)]
|
|
[(delayed-block? p)
|
|
(let ([v (delayed-block-blocks p ri)])
|
|
(extract-block-style-files v d ri ht pred extract))]
|
|
[(traverse-block? p)
|
|
(extract-block-style-files (traverse-block-block p ri) d ri ht pred extract)]
|
|
[else
|
|
(extract-style-style-files (paragraph-style p) ht pred extract)
|
|
(extract-content-style-files (paragraph-content p) d ri ht pred extract)]))
|
|
|
|
(define/public (string-to-implicit-styles e) null)
|
|
|
|
(define/private (extract-content-style-files e d ri ht pred extract)
|
|
(cond
|
|
[(string? e) (let ([ses (string-to-implicit-styles e)])
|
|
(when (pair? ses)
|
|
(for ([s (in-list ses)])
|
|
(extract-style-style-files s ht pred extract))))]
|
|
[(element? e)
|
|
(when (style? (element-style e))
|
|
(extract-style-style-files (element-style e) ht pred extract))
|
|
(extract-content-style-files (element-content e) d ri ht pred extract)]
|
|
[(multiarg-element? e)
|
|
(when (style? (multiarg-element-style e))
|
|
(extract-style-style-files (multiarg-element-style e) ht pred extract))
|
|
(extract-content-style-files (multiarg-element-contents e) d ri ht pred extract)]
|
|
[(list? e)
|
|
(for ([e (in-list e)])
|
|
(extract-content-style-files e d ri ht pred extract))]
|
|
[(delayed-element? e)
|
|
(extract-content-style-files (delayed-element-content e ri) d ri ht pred extract)]
|
|
[(traverse-element? e)
|
|
(extract-content-style-files (traverse-element-content e ri) d ri ht pred extract)]
|
|
[(part-relative-element? e)
|
|
(extract-content-style-files (part-relative-element-content e ri) d ri ht pred extract)]))
|
|
|
|
(define/public (extract-version d)
|
|
(or (ormap (lambda (v)
|
|
(and (document-version? v)
|
|
(document-version-text v)))
|
|
(style-properties (part-style d)))
|
|
""))
|
|
|
|
(define/public (extract-date d)
|
|
(ormap (lambda (v)
|
|
(and (document-date? v)
|
|
(document-date-text v)))
|
|
(style-properties (part-style d))))
|
|
|
|
(define/private (extract-pre-paras d sym)
|
|
(let loop ([l (part-blocks d)])
|
|
(cond
|
|
[(null? l) null]
|
|
[else (let ([v (car l)])
|
|
(cond
|
|
[(and (paragraph? v)
|
|
(eq? sym (style-name (paragraph-style v))))
|
|
(cons v (loop (cdr l)))]
|
|
[(compound-paragraph? v)
|
|
(append (loop (compound-paragraph-blocks v))
|
|
(loop (cdr l)))]
|
|
[else (loop (cdr l))]))])))
|
|
|
|
(define/public (extract-authors d)
|
|
(extract-pre-paras d 'author))
|
|
|
|
(define/public (extract-pretitle d)
|
|
(extract-pre-paras d 'pretitle))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define root (make-mobile-root root-path))
|
|
|
|
(define-values (:path->root-relative
|
|
:root-relative->path)
|
|
(if root-path
|
|
(make-relativize (lambda () root-path)
|
|
root
|
|
'path->root-relative
|
|
'root-relative->path)
|
|
(values #f #f)))
|
|
|
|
(define/public (path->root-relative p)
|
|
(if root-path
|
|
(:path->root-relative p)
|
|
p))
|
|
|
|
(define/public (root-relative->path p)
|
|
(if (root-relative? p)
|
|
(apply build-path (or (mobile-root-path (car p))
|
|
(current-directory))
|
|
(map bytes->path-element (cdr p)))
|
|
p))
|
|
|
|
(define/public (root-relative? p)
|
|
(and (pair? p)
|
|
(mobile-root? (car p))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define/public (fresh-tag-collect-context? d ci)
|
|
#f)
|
|
(define/public (fresh-tag-resolve-context? d ri)
|
|
#f)
|
|
(define/public (fresh-tag-render-context? d ri)
|
|
#f)
|
|
|
|
(define/private (extend-prefix d fresh?)
|
|
(cond
|
|
[fresh? null]
|
|
[(part-tag-prefix d)
|
|
(cons (part-tag-prefix d) (current-tag-prefixes))]
|
|
[else (current-tag-prefixes)]))
|
|
|
|
;; ----------------------------------------
|
|
;; marshal info
|
|
|
|
(define/public (get-serialize-version)
|
|
4)
|
|
|
|
(define/public (serialize-infos ri n d)
|
|
(if (= n 1)
|
|
(list (serialize-info ri))
|
|
(map (lambda (ht) (serialize-one-ht ri ht))
|
|
(partition-info (resolve-info-ci ri) n d))))
|
|
|
|
(define/private (partition-info all-ci n d)
|
|
;; partition information in `all-ci' based on `d's:
|
|
(let ([prefix (part-tag-prefix d)]
|
|
[new-hts (for/list ([i (in-range n)])
|
|
(make-hash))]
|
|
[covered (make-hash)])
|
|
;; Fill in new-hts from parts:
|
|
(for ([sub-d (in-list (part-parts d))]
|
|
[i (in-naturals)])
|
|
(define ht (list-ref new-hts (min (add1 i) (sub1 n))))
|
|
(define cdi (hash-ref (collect-info-parts all-ci) sub-d #f))
|
|
(define sub-prefix (part-tag-prefix sub-d))
|
|
(when cdi
|
|
(for ([(k v) (in-hash (collected-info-info cdi))])
|
|
(when (cadr k)
|
|
(define sub-k (if sub-prefix
|
|
(convert-key sub-prefix k)
|
|
k))
|
|
(define full-k (if prefix
|
|
(convert-key prefix sub-k)
|
|
sub-k))
|
|
(hash-set! ht full-k v)
|
|
(hash-set! covered full-k #t)))))
|
|
;; Anything not covered in the new-hts must go in the main hts:
|
|
(let ([ht0 (car new-hts)])
|
|
(for ([(k v) (in-hash (collect-info-ht all-ci))])
|
|
(unless (hash-ref covered k #f)
|
|
(hash-set! ht0 k v))))
|
|
;; Return hts:
|
|
new-hts))
|
|
|
|
(define/public (serialize-info ri)
|
|
(serialize-one-ht ri (collect-info-ht (resolve-info-ci ri))))
|
|
|
|
(define/public (serialize-one-ht ri ht)
|
|
(parameterize ([current-serialize-resolve-info ri])
|
|
(let ([rp (mobile-root-path root)])
|
|
(when rp
|
|
(set-mobile-root-path! root #f))
|
|
(begin0
|
|
(serialize (cons root ht))
|
|
(when rp
|
|
(set-mobile-root-path! root rp))))))
|
|
|
|
(define/public (deserialize-info v ci #:root [root-path #f] #:doc-id [doc-id #f])
|
|
(let ([root+ht (deserialize v)]
|
|
[in-ht (collect-info-ext-ht ci)])
|
|
(when root-path
|
|
(set-mobile-root-path! (car root+ht) root-path))
|
|
(for ([(k v) (cdr root+ht)])
|
|
(hash-set! in-ht k (if doc-id (known-doc v doc-id) v)))))
|
|
|
|
(define/public (get-defined ci)
|
|
(hash-map (collect-info-ht ci) (lambda (k v) k)))
|
|
|
|
(define/public (get-defineds ci n d)
|
|
(for/list ([ht (partition-info ci n d)])
|
|
(hash-map ht (lambda (k v) k))))
|
|
|
|
(define/public (get-external ri)
|
|
(hash-map (resolve-info-undef ri) (lambda (k v) k)))
|
|
|
|
(define/public (get-undefined ri)
|
|
(for/list ([(k v) (in-hash (resolve-info-undef ri))]
|
|
#:unless (or (eq? v 'found)
|
|
(and v
|
|
;; v is a search key; see if any key in the set was resolved:
|
|
(let ([ht (hash-ref (resolve-info-searches ri) v)])
|
|
(for/or ([k2 (in-hash-keys ht)])
|
|
(eq? 'found (hash-ref (resolve-info-undef ri) k2 #f)))))))
|
|
k))
|
|
|
|
(define/public (transfer-info ci src-ci)
|
|
(let ([in-ht (collect-info-ext-ht ci)])
|
|
(for ([(k v) (collect-info-ext-ht src-ci)])
|
|
(hash-set! in-ht k v)))
|
|
(set-demand-chain-demands!
|
|
(collect-info-ext-demand ci)
|
|
(cons (collect-info-ext-demand src-ci)
|
|
(demand-chain-demands (collect-info-ext-demand ci)))))
|
|
|
|
;; ----------------------------------------
|
|
;; document-order traversal
|
|
|
|
(define/public (traverse ds fns)
|
|
(let loop ([fp #hasheq()])
|
|
(let ([fp2 (start-traverse ds fns fp)])
|
|
(if (equal? fp fp2)
|
|
fp
|
|
(loop fp2)))))
|
|
|
|
(define/public (start-traverse ds fns fp)
|
|
(for/fold ([fp fp]) ([d (in-list ds)])
|
|
(traverse-part d fp)))
|
|
|
|
(define/public (traverse-part d fp)
|
|
(let* ([fp (if (part-title-content d)
|
|
(traverse-content (part-title-content d) fp)
|
|
fp)]
|
|
[fp (traverse-content (part-to-collect d) fp)]
|
|
[fp (traverse-flow (part-blocks d) fp)])
|
|
(for/fold ([fp fp]) ([p (in-list (part-parts d))])
|
|
(traverse-part p fp))))
|
|
|
|
(define/public (traverse-paragraph p fp)
|
|
(traverse-content (paragraph-content p) fp))
|
|
|
|
(define/public (traverse-flow p fp)
|
|
(for/fold ([fp fp]) ([p (in-list p)])
|
|
(traverse-block p fp)))
|
|
|
|
(define/public (traverse-block p fp)
|
|
(cond [(table? p) (traverse-table p fp)]
|
|
[(itemization? p) (traverse-itemization p fp)]
|
|
[(nested-flow? p) (traverse-nested-flow p fp)]
|
|
[(compound-paragraph? p) (traverse-compound-paragraph p fp)]
|
|
[(delayed-block? p) fp]
|
|
[(traverse-block? p) (traverse-force fp p
|
|
(traverse-block-traverse p)
|
|
(lambda (p fp) (traverse-block p fp)))]
|
|
[else (traverse-paragraph p fp)]))
|
|
|
|
(define/public (traverse-table i fp)
|
|
(for*/fold ([fp fp]) ([ds (in-list (table-blockss i))]
|
|
[d (in-list ds)])
|
|
(if (eq? d 'cont)
|
|
fp
|
|
(traverse-block d fp))))
|
|
|
|
(define/public (traverse-itemization i fp)
|
|
(for/fold ([fp fp]) ([d (in-list (itemization-blockss i))])
|
|
(traverse-flow d fp)))
|
|
|
|
(define/public (traverse-nested-flow i fp)
|
|
(for/fold ([fp fp]) ([d (in-list (nested-flow-blocks i))])
|
|
(traverse-block d fp)))
|
|
|
|
(define/public (traverse-compound-paragraph i fp)
|
|
(for/fold ([fp fp]) ([d (in-list (compound-paragraph-blocks i))])
|
|
(traverse-block d fp)))
|
|
|
|
(define/public (traverse-content i fp)
|
|
(cond
|
|
[(traverse-element? i) (traverse-force fp i (traverse-element-traverse i)
|
|
(lambda (i fp) (traverse-content i fp)))]
|
|
[(element? i) (traverse-content (element-content i) fp)]
|
|
[(list? i) (for/fold ([fp fp]) ([c (in-list i)])
|
|
(traverse-content c fp))]
|
|
[(multiarg-element? i)
|
|
(for/fold ([fp fp]) ([c (in-list (multiarg-element-contents i))])
|
|
(traverse-content c fp))]
|
|
[else fp]))
|
|
|
|
(define/private (traverse-force fp p proc again)
|
|
(let ([v (hash-ref fp p (lambda () proc))])
|
|
(if (procedure? v)
|
|
(let ([fp fp])
|
|
(let ([v2 (v (lambda (key default)
|
|
(if (eq? key 'scribble:current-render-mode)
|
|
(current-render-mode)
|
|
(hash-ref fp key default)))
|
|
(lambda (key val)
|
|
(if (eq? key 'scribble:current-render-mode)
|
|
(raise-mismatch-error
|
|
'traverse-info-set!
|
|
"cannot set value for built-in key: "
|
|
key)
|
|
(set! fp (hash-set fp key val)))))])
|
|
(let ([fp (hash-set fp p v2)])
|
|
(if (procedure? v2)
|
|
fp
|
|
(again v2 fp)))))
|
|
fp)))
|
|
|
|
;; ----------------------------------------
|
|
;; global-info collection
|
|
|
|
(define/public (collect ds fns fp [demand (lambda (key ci) #f)])
|
|
(let ([ci (make-collect-info fp
|
|
(make-hash)
|
|
(make-hash)
|
|
(make-demand-chain (list demand))
|
|
(make-hasheq)
|
|
(make-hasheq)
|
|
null
|
|
(make-hasheq)
|
|
null)])
|
|
(start-collect ds fns ci)
|
|
ci))
|
|
|
|
(define/public (start-collect ds fns ci)
|
|
(for-each (lambda (d) (collect-part d #f ci null 1 #hash()))
|
|
ds))
|
|
|
|
(define/public (collect-part d parent ci number init-sub-number init-sub-numberers)
|
|
(let ([p-ci (make-collect-info
|
|
(collect-info-fp ci)
|
|
(make-hash)
|
|
(collect-info-ext-ht ci)
|
|
(collect-info-ext-demand ci)
|
|
(collect-info-parts ci)
|
|
(collect-info-tags ci)
|
|
(if (part-tag-prefix d)
|
|
(append (collect-info-gen-prefix ci)
|
|
(list (part-tag-prefix d)))
|
|
(collect-info-gen-prefix ci))
|
|
(collect-info-relatives ci)
|
|
(cons d (collect-info-parents ci)))])
|
|
(hash-set! (collect-info-parts ci)
|
|
d
|
|
(make-collected-info number
|
|
parent
|
|
(collect-info-ht p-ci)))
|
|
(define grouper? (and (pair? number) (part-style? d 'grouper)))
|
|
(define-values (next-sub-number next-sub-numberers)
|
|
(parameterize ([current-tag-prefixes
|
|
(extend-prefix d (fresh-tag-collect-context? d p-ci))])
|
|
(when (part-title-content d)
|
|
(collect-content (part-title-content d) p-ci))
|
|
(collect-part-tags d p-ci number)
|
|
(collect-content (part-to-collect d) p-ci)
|
|
(collect-flow (part-blocks d) p-ci)
|
|
(let loop ([parts (part-parts d)]
|
|
[pos init-sub-number]
|
|
[numberers init-sub-numberers]
|
|
[sub-pos 1]
|
|
[sub-numberers #hash()])
|
|
(if (null? parts)
|
|
(values pos numberers)
|
|
(let ([s (car parts)])
|
|
(define unnumbered? (part-style? s 'unnumbered))
|
|
(define hidden-number? (or unnumbered?
|
|
(part-style? s 'hidden-number)))
|
|
(define sub-grouper? (part-style? s 'grouper))
|
|
(define numberer (and (not unnumbered?)
|
|
(for/or ([p (style-properties (part-style s))]
|
|
#:when (numberer? p))
|
|
p)))
|
|
(define-values (numberer-str next-numberers)
|
|
(if numberer
|
|
(numberer-step numberer number p-ci numberers)
|
|
(values #f numberers)))
|
|
(define-values (next-sub-pos next-sub-numberers)
|
|
(collect-part s d p-ci
|
|
(cons (if hidden-number?
|
|
(if sub-grouper?
|
|
""
|
|
#f)
|
|
(if numberer
|
|
numberer-str
|
|
(if sub-grouper?
|
|
(number->roman pos)
|
|
pos)))
|
|
(if hidden-number?
|
|
(for/list ([i (in-list number)])
|
|
(if (string? i)
|
|
i
|
|
#f))
|
|
number))
|
|
sub-pos
|
|
sub-numberers))
|
|
(loop (cdr parts)
|
|
(if (or unnumbered? numberer)
|
|
pos
|
|
(add1 pos))
|
|
next-numberers
|
|
(if sub-grouper?
|
|
next-sub-pos
|
|
1)
|
|
(if sub-grouper?
|
|
next-sub-numberers
|
|
#hash())))))))
|
|
(let ([prefix (part-tag-prefix d)])
|
|
(for ([(k v) (collect-info-ht p-ci)])
|
|
(when (cadr k)
|
|
(collect-put! ci (if prefix
|
|
(convert-key prefix k)
|
|
k)
|
|
v))))
|
|
(values next-sub-number next-sub-numberers)))
|
|
|
|
(define/private (convert-key prefix k)
|
|
(case (car k)
|
|
[(part tech cite)
|
|
(let ([rhs (cadr k)])
|
|
(if (or (string? rhs) (pair? rhs))
|
|
(list (car k) (cons prefix (if (pair? rhs) rhs (list rhs))))
|
|
k))]
|
|
[(index-entry)
|
|
(let ([v (convert-key prefix (cadr k))])
|
|
(if (eq? v (cadr k)) k (list 'index-entry v)))]
|
|
[else
|
|
(if (and (pair? (cadr k))
|
|
(eq? 'prefixable (caadr k)))
|
|
(list (car k) (list* 'prefixable prefix (cdadr k)))
|
|
k)]))
|
|
|
|
(define/public (collect-part-tags d ci number)
|
|
(for ([t (part-tags d)])
|
|
(let ([t (generate-tag t ci)])
|
|
(collect-put! ci
|
|
t
|
|
;; INFO SHAPE:
|
|
;; The HTML renderer defines its info as an
|
|
;; extension of this vector's shape, so that
|
|
;; other renderers can use HTML info.
|
|
(vector (or (part-title-content d) '("???"))
|
|
(add-current-tag-prefix t)
|
|
number)))))
|
|
|
|
(define/public (collect-paragraph p ci)
|
|
(collect-content (paragraph-content p) ci))
|
|
|
|
(define/public (collect-flow p ci)
|
|
(for ([p (in-list p)])
|
|
(collect-block p ci)))
|
|
|
|
(define/public (collect-block p ci)
|
|
(cond [(table? p) (collect-table p ci)]
|
|
[(itemization? p) (collect-itemization p ci)]
|
|
[(nested-flow? p) (collect-nested-flow p ci)]
|
|
[(compound-paragraph? p) (collect-compound-paragraph p ci)]
|
|
[(delayed-block? p) (void)]
|
|
[(traverse-block? p) (collect-block (traverse-block-block p ci) ci)]
|
|
[else (collect-paragraph p ci)]))
|
|
|
|
(define/public (collect-table i ci)
|
|
(for ([d (in-list (apply append (table-blockss i)))])
|
|
(unless (eq? d 'cont) (collect-block d ci))))
|
|
|
|
(define/public (collect-itemization i ci)
|
|
(for ([d (in-list (itemization-blockss i))])
|
|
(collect-flow d ci)))
|
|
|
|
(define/public (collect-nested-flow i ci)
|
|
(for ([d (in-list (nested-flow-blocks i))])
|
|
(collect-block d ci)))
|
|
|
|
(define/public (collect-compound-paragraph i ci)
|
|
(for ([d (in-list (compound-paragraph-blocks i))])
|
|
(collect-block d ci)))
|
|
|
|
(define/public (collect-content i ci)
|
|
(if (part-relative-element? i)
|
|
(let ([content (or (hash-ref (collect-info-relatives ci) i #f)
|
|
(let ([v ((part-relative-element-collect i) ci)])
|
|
(hash-set! (collect-info-relatives ci) i v)
|
|
v))])
|
|
(collect-content content ci))
|
|
(begin (when (target-element? i) (collect-target-element i ci))
|
|
(when (index-element? i) (collect-index-element i ci))
|
|
(when (collect-element? i) ((collect-element-collect i) ci))
|
|
(when (element? i)
|
|
(collect-content (element-content i) ci))
|
|
(when (multiarg-element? i)
|
|
(collect-content (multiarg-element-contents i) ci))
|
|
(when (list? i)
|
|
(for ([e (in-list i)]) (collect-content e ci)))
|
|
(when (toc-element? i)
|
|
(collect-content (toc-element-toc-content i) ci))
|
|
(when (toc-target2-element? i)
|
|
(collect-content (toc-target2-element-toc-content i) ci)))))
|
|
|
|
(define/public (collect-target-element i ci)
|
|
(let ([t (generate-tag (target-element-tag i) ci)])
|
|
(collect-put! ci t
|
|
;; See "INFO SHAPE" above.
|
|
(vector (element-content i)
|
|
(add-current-tag-prefix t)))))
|
|
|
|
(define/public (collect-index-element i ci)
|
|
(collect-put! ci
|
|
`(index-entry ,(generate-tag (index-element-tag i) ci))
|
|
(list (index-element-plain-seq i)
|
|
(index-element-entry-seq i)
|
|
(index-element-desc i))))
|
|
|
|
;; ----------------------------------------
|
|
;; global-info resolution
|
|
|
|
(define/public (resolve ds fns ci)
|
|
(let ([ri (make-resolve-info ci (make-hasheq) (make-hash) (make-hash))])
|
|
(start-resolve ds fns ri)
|
|
ri))
|
|
|
|
(define/public (start-resolve ds fns ri)
|
|
(map (lambda (d) (resolve-part d ri)) ds))
|
|
|
|
(define/public (resolve-part d ri)
|
|
(parameterize ([current-tag-prefixes
|
|
(extend-prefix d (fresh-tag-resolve-context? d ri))])
|
|
(when (part-title-content d)
|
|
(resolve-content (part-title-content d) d ri))
|
|
(resolve-flow (part-blocks d) d ri)
|
|
(for ([p (part-parts d)])
|
|
(resolve-part p ri))))
|
|
|
|
(define/public (resolve-paragraph p d ri)
|
|
(resolve-content (paragraph-content p) d ri))
|
|
|
|
(define/public (resolve-flow f d ri)
|
|
(for ([p (in-list f)])
|
|
(resolve-block p d ri)))
|
|
|
|
(define/public (resolve-block p d ri)
|
|
(cond
|
|
[(table? p) (resolve-table p d ri)]
|
|
[(itemization? p) (resolve-itemization p d ri)]
|
|
[(nested-flow? p) (resolve-nested-flow p d ri)]
|
|
[(compound-paragraph? p) (resolve-compound-paragraph p d ri)]
|
|
[(delayed-block? p)
|
|
(let ([v ((delayed-block-resolve p) this d ri)])
|
|
(hash-set! (resolve-info-delays ri) p v)
|
|
(resolve-block v d ri))]
|
|
[(traverse-block? p) (resolve-block (traverse-block-block p ri) d ri)]
|
|
[else (resolve-paragraph p d ri)]))
|
|
|
|
(define/public (resolve-table i d ri)
|
|
(for ([f (in-list (apply append (table-blockss i)))])
|
|
(unless (eq? f 'cont) (resolve-block f d ri))))
|
|
|
|
(define/public (resolve-itemization i d ri)
|
|
(for ([f (in-list (itemization-blockss i))])
|
|
(resolve-flow f d ri)))
|
|
|
|
(define/public (resolve-nested-flow i d ri)
|
|
(for ([f (in-list (nested-flow-blocks i))])
|
|
(resolve-block f d ri)))
|
|
|
|
(define/public (resolve-compound-paragraph i d ri)
|
|
(for ([f (in-list (compound-paragraph-blocks i))])
|
|
(resolve-block f d ri)))
|
|
|
|
(define/public (resolve-content i d ri)
|
|
(cond
|
|
[(part-relative-element? i)
|
|
(resolve-content (part-relative-element-content i ri) d ri)]
|
|
[(delayed-element? i)
|
|
(resolve-content (or (hash-ref (resolve-info-delays ri) i #f)
|
|
(let ([v ((delayed-element-resolve i) this d ri)])
|
|
(hash-set! (resolve-info-delays ri) i v)
|
|
v))
|
|
d ri)]
|
|
[(traverse-element? i)
|
|
(resolve-content (traverse-element-content i ri) d ri)]
|
|
[(list? i)
|
|
(for ([i (in-list i)])
|
|
(resolve-content i d ri))]
|
|
[(element? i)
|
|
(cond
|
|
[(index-element? i)
|
|
(let ([e (index-element-desc i)])
|
|
(when (delayed-index-desc? e)
|
|
(let ([v ((delayed-index-desc-resolve e) this d ri)])
|
|
(hash-set! (resolve-info-delays ri) e v))))]
|
|
[(link-element? i)
|
|
(resolve-get d ri (link-element-tag i))])
|
|
(resolve-content (element-content i) d ri)
|
|
(cond
|
|
[(toc-target2-element? i) (resolve-content (toc-target2-element-toc-content i) d ri)]
|
|
[(toc-element? i) (resolve-content (toc-element-toc-content i) d ri)])]
|
|
[(multiarg-element? i)
|
|
(resolve-content (multiarg-element-contents i) d ri)]))
|
|
|
|
;; ----------------------------------------
|
|
;; render methods
|
|
|
|
(define/public (sort-image-requests reqs prefs)
|
|
(for/fold ([reqs reqs]) ([pref (in-list (reverse prefs))])
|
|
(define matches
|
|
(for/list ([req (in-list reqs)]
|
|
#:when (case pref
|
|
[(png) (or (eq? req 'png@2x-bytes)
|
|
(eq? req 'png-bytes))]
|
|
[(svg) (eq? req 'svg-bytes)]
|
|
[(pdf) (eq? req 'pdf-bytes)]
|
|
[(ps) (eq? req 'eps-bytes)]
|
|
[(gif) (eq? req 'gif-bytes)]
|
|
[else #f]))
|
|
req))
|
|
(if (null? matches)
|
|
reqs
|
|
(append matches (remove* matches reqs)))))
|
|
|
|
(define/public (auto-extra-files? v) #f)
|
|
(define/public (auto-extra-files-paths v) null)
|
|
(define/public (skip-extra-file? v) #f)
|
|
|
|
(define/public (install-extra-files ds)
|
|
(for ([fn extra-files])
|
|
(unless (skip-extra-file? fn)
|
|
(install-file fn #:private-name? #f)))
|
|
(unless prefix-file
|
|
(for ([d (in-list ds)])
|
|
(let ([extras (ormap (lambda (v) (and (auto-extra-files? v) v))
|
|
(style-properties (part-style d)))])
|
|
(when extras
|
|
(for ([fn (in-list (auto-extra-files-paths extras))])
|
|
(unless (skip-extra-file? fn)
|
|
(install-file (collects-relative->path fn)
|
|
#:private-name? #f))))))))
|
|
|
|
(define/public (render ds fns ri)
|
|
;; maybe this should happen even if fns is empty or all #f?
|
|
;; or maybe it should happen for each file rendered (when d is not #f)?
|
|
(unless (andmap not ds) (install-extra-files ds))
|
|
(map (lambda (d fn)
|
|
(define (one) (render-one d ri fn))
|
|
(when (report-output?) (printf " [Output to ~a]\n" fn))
|
|
(if fn
|
|
(with-output-to-file fn #:exists 'truncate/replace one)
|
|
;; a #f filename means return the contents as a string
|
|
(let ([o (open-output-string)])
|
|
(parameterize ([current-output-port o])
|
|
(one)
|
|
(get-output-string o)))))
|
|
ds
|
|
fns))
|
|
|
|
(define/public (render-one d ri fn)
|
|
(render-part d ri))
|
|
|
|
(define/public (render-part d ri)
|
|
(parameterize ([current-tag-prefixes
|
|
(extend-prefix d (fresh-tag-render-context? d ri))])
|
|
(render-part-content d ri)))
|
|
|
|
(define/public (render-part-content d ri)
|
|
(list
|
|
(when (part-title-content d)
|
|
(render-content (part-title-content d) d ri))
|
|
(render-flow (part-blocks d) d ri #f)
|
|
(map (lambda (s) (render-part s ri))
|
|
(part-parts d))))
|
|
|
|
(define/public (render-paragraph p part ri)
|
|
(render-content (paragraph-content p) part ri))
|
|
|
|
(define/public (render-compound-paragraph p part ri starting-item?)
|
|
(apply append (let loop ([l (compound-paragraph-blocks p)]
|
|
[first? #t])
|
|
(cond
|
|
[(null? l) null]
|
|
[else (cons
|
|
(render-intrapara-block (car l) part ri first? (null? (cdr l))
|
|
(and first? starting-item?))
|
|
(loop (cdr l) #f))]))))
|
|
|
|
(define/public (render-flow p part ri starting-item?)
|
|
(if (null? p)
|
|
null
|
|
(append
|
|
(render-block (car p)
|
|
part ri starting-item?)
|
|
(apply append
|
|
(map (lambda (p)
|
|
(render-block p part ri #f))
|
|
(cdr p))))))
|
|
|
|
(define/public (render-intrapara-block p part ri first? last? starting-item?)
|
|
(render-block p part ri starting-item?))
|
|
|
|
(define/public (render-block p part ri starting-item?)
|
|
(cond
|
|
[(table? p) (if (memq 'aux (style-properties (table-style p)))
|
|
(render-auxiliary-table p part ri)
|
|
(render-table p part ri starting-item?))]
|
|
[(itemization? p) (render-itemization p part ri)]
|
|
[(nested-flow? p) (render-nested-flow p part ri starting-item?)]
|
|
[(compound-paragraph? p) (render-compound-paragraph p part ri starting-item?)]
|
|
[(delayed-block? p)
|
|
(render-block (delayed-block-blocks p ri) part ri starting-item?)]
|
|
[(traverse-block? p)
|
|
(render-block (traverse-block-block p ri) part ri starting-item?)]
|
|
[else (render-paragraph p part ri)]))
|
|
|
|
(define/public (render-auxiliary-table i part ri)
|
|
null)
|
|
|
|
(define/public (render-table i part ri starting-item?)
|
|
(map (lambda (d) (if (eq? i 'cont) null (render-block d part ri #f)))
|
|
(apply append (table-blockss i))))
|
|
|
|
(define/public (render-itemization i part ri)
|
|
(map (lambda (d) (render-flow d part ri #t))
|
|
(itemization-blockss i)))
|
|
|
|
(define/public (render-nested-flow i part ri starting-item?)
|
|
(for/list ([b (in-list (nested-flow-blocks i))]
|
|
[pos (in-naturals)])
|
|
(render-block b part ri (and starting-item? (zero? pos)))))
|
|
|
|
(define/public (render-content i part ri)
|
|
(cond
|
|
[(string? i) (render-other i part ri)] ; short-cut for common case
|
|
[(list? i)
|
|
(apply append (for/list ([i (in-list i)]) (render-content i part ri)))]
|
|
[(and (link-element? i)
|
|
(null? (element-content i)))
|
|
(let ([v (resolve-get part ri (link-element-tag i))])
|
|
(if v
|
|
(render-content (strip-aux (or (vector-ref v 0) "???")) part ri)
|
|
(render-content (list "[missing]") part ri)))]
|
|
[(element? i)
|
|
(when (render-element? i)
|
|
((render-element-render i) this part ri))
|
|
(render-content (element-content i) part ri)]
|
|
[(multiarg-element? i)
|
|
(render-content (multiarg-element-contents i) part ri)]
|
|
[(delayed-element? i)
|
|
(render-content (delayed-element-content i ri) part ri)]
|
|
[(traverse-element? i)
|
|
(render-content (traverse-element-content i ri) part ri)]
|
|
[(part-relative-element? i)
|
|
(render-content (part-relative-element-content i ri) part ri)]
|
|
[(convertible? i) (list "???")]
|
|
[else (render-other i part ri)]))
|
|
|
|
(define/public (render-other i part ri)
|
|
(list i))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define copied-srcs (make-hash))
|
|
(define copied-dests (make-hash))
|
|
|
|
(define/public (install-file fn [content #f] #:private-name? [private-name? #t])
|
|
(if (and refer-to-existing-files
|
|
(not content))
|
|
(if (string? fn)
|
|
(string->path fn)
|
|
fn)
|
|
(let ([normalized (normal-case-path (simplify-path (path->complete-path fn)))])
|
|
(or (and (not content)
|
|
(hash-ref copied-srcs normalized #f))
|
|
(let ([src-dir (path-only fn)]
|
|
[dest-dir (get-dest-directory #t)]
|
|
[fn (file-name-from-path fn)])
|
|
(let ([src-file (build-path (or src-dir (current-directory)) fn)]
|
|
[dest-file (build-path (or dest-dir (current-directory))
|
|
(if (and private-name?
|
|
helper-file-prefix)
|
|
(string-append helper-file-prefix
|
|
(path-element->string fn))
|
|
fn))]
|
|
[next-file-name (lambda (dest)
|
|
(let-values ([(base name dir?) (split-path dest)])
|
|
(build-path
|
|
base
|
|
(let ([s (path-element->string (path-replace-suffix name #""))])
|
|
(let ([n (regexp-match #rx"^(.*)_([0-9]+)$" s)])
|
|
(format "~a_~a~a"
|
|
(if n (cadr n) s)
|
|
(if n (add1 (string->number (caddr n))) 2)
|
|
(let ([ext (filename-extension name)])
|
|
(if ext
|
|
(bytes-append #"." ext)
|
|
""))))))))])
|
|
(let-values ([(dest-file normalized-dest-file)
|
|
(let loop ([dest-file dest-file])
|
|
(let* ([normalized-dest-file
|
|
(normal-case-path (simplify-path (path->complete-path dest-file)))]
|
|
[check-same
|
|
(lambda (src dest-file)
|
|
(call-with-input-file*
|
|
dest-file
|
|
(lambda (dest)
|
|
(or (and (not content)
|
|
(equal? (port-file-identity src)
|
|
(port-file-identity dest)))
|
|
(let loop ()
|
|
(let ([s (read-bytes 4096 src)]
|
|
[d (read-bytes 4096 dest)])
|
|
(and (equal? s d)
|
|
(or (eof-object? s) (loop)))))))))]
|
|
[same-directories?
|
|
(lambda (s d)
|
|
(let loop ([s s] [d d])
|
|
(cond
|
|
[(and (file-exists? s) (file-exists? d))
|
|
(call-with-input-file* s (lambda (in)
|
|
(check-same in d)))]
|
|
[(directory-exists? s)
|
|
(and (directory-exists? d)
|
|
(let ([sl (sort (directory-list s) bytes<? #:key path-element->bytes)]
|
|
[dl (sort (directory-list d) bytes<? #:key path-element->bytes)])
|
|
(and (equal? sl dl)
|
|
(andmap loop sl dl))))]
|
|
[else #f])))]
|
|
[not-same
|
|
(lambda (delete-dest)
|
|
(cond
|
|
[(hash-ref copied-dests normalized-dest-file #f)
|
|
;; need a different file/directory
|
|
(loop (next-file-name dest-file))]
|
|
[else
|
|
;; replace the file/directory
|
|
(delete-dest dest-file)
|
|
(values dest-file normalized-dest-file)]))])
|
|
(cond
|
|
[(and (file-exists? src-file)
|
|
(file-exists? dest-file))
|
|
(cond
|
|
[(or (and content
|
|
(check-same (open-input-bytes content) dest-file))
|
|
(and (not content)
|
|
(call-with-input-file* src-file (lambda (in) (check-same in dest-file)))))
|
|
;; same content at that destination
|
|
(values dest-file normalized-dest-file)]
|
|
[else
|
|
(not-same delete-file)])]
|
|
[(and (directory-exists? src-file)
|
|
(directory-exists? dest-file))
|
|
(if (same-directories? src-file dest-file)
|
|
(values dest-file normalized-dest-file)
|
|
(not-same delete-directory/files))]
|
|
[(file-exists? dest-file)
|
|
(not-same delete-file)]
|
|
[(directory-exists? dest-file)
|
|
(not-same delete-directory/files)]
|
|
[else
|
|
;; new file/directory
|
|
(values dest-file normalized-dest-file)])))])
|
|
(unless (or (file-exists? dest-file)
|
|
(directory-exists? dest-file))
|
|
(if content
|
|
(call-with-output-file*
|
|
dest-file
|
|
(lambda (dest) (write-bytes content dest)))
|
|
(if (directory-exists? src-file)
|
|
(copy-directory/files src-file dest-file)
|
|
(copy-file src-file dest-file))))
|
|
(hash-set! copied-dests normalized-dest-file #t)
|
|
(let ([result (path->string (file-name-from-path dest-file))])
|
|
(unless content
|
|
(hash-set! copied-srcs normalized result))
|
|
result))))))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define/private (do-table-of-contents part ri delta quiet depth)
|
|
(make-table plain (generate-toc part
|
|
ri
|
|
(+ delta
|
|
(length (collected-info-number
|
|
(part-collected-info part ri))))
|
|
#t
|
|
quiet
|
|
depth
|
|
null)))
|
|
|
|
(define/public (table-of-contents part ri)
|
|
(do-table-of-contents part ri -1 not +inf.0))
|
|
|
|
(define/public (local-table-of-contents part ri style)
|
|
(do-table-of-contents part ri -1 not (if (eq? style 'immediate-only)
|
|
1
|
|
+inf.0)))
|
|
|
|
(define/public (quiet-table-of-contents part ri)
|
|
(do-table-of-contents part ri 1 (lambda (x) #t) +inf.0))
|
|
|
|
(define/private (generate-toc part ri base-len skip? quiet depth prefixes)
|
|
(let* ([number (collected-info-number (part-collected-info part ri))]
|
|
[prefixes (if (part-tag-prefix part)
|
|
(cons (part-tag-prefix part) prefixes)
|
|
prefixes)]
|
|
[subs
|
|
(if (and (quiet (and (part-style? part 'quiet)
|
|
(not (= base-len (sub1 (length number))))))
|
|
(positive? depth))
|
|
(apply append (map (lambda (p)
|
|
(generate-toc p ri base-len (part-style? p 'toc-hidden)
|
|
quiet (sub1 depth) prefixes))
|
|
(part-parts part)))
|
|
null)])
|
|
(if skip?
|
|
subs
|
|
(let ([l (cons
|
|
(list (make-paragraph
|
|
plain
|
|
(list
|
|
(make-element
|
|
'hspace
|
|
(list (make-string (* 2 (- (length number)
|
|
base-len))
|
|
#\space)))
|
|
(make-link-element
|
|
(if (= 1 (length number)) "toptoclink" "toclink")
|
|
(append
|
|
(format-number
|
|
number
|
|
(list (make-element 'hspace '(" "))))
|
|
(or (part-title-content part) '("???")))
|
|
(for/fold ([t (car (part-tags part))])
|
|
([prefix (in-list prefixes)])
|
|
(convert-key prefix t))))))
|
|
subs)])
|
|
(if (and (= 1 (length number))
|
|
(or (not (car number))
|
|
(and (number? (car number))
|
|
((car number) . > . 1))
|
|
(and (string? (car number))
|
|
(not (string=? (car number) "I")))))
|
|
(cons (list (make-paragraph
|
|
plain
|
|
(list (make-element 'hspace (list "")))))
|
|
l)
|
|
l)))))
|
|
|
|
;; ----------------------------------------
|
|
|
|
(super-new)))
|
|
|
|
|
|
;; ----------------------------------------
|
|
|
|
(define-struct demand-chain ([demands #:mutable])
|
|
#:property prop:procedure (lambda (self key ci)
|
|
(for/or ([demand (in-list (demand-chain-demands self))])
|
|
(demand key ci))))
|
|
|