reformat etc
svn: r9957 original commit: ce97fa58c2ac3e8a9e6c295ef7b9cb607d2ff9eb
This commit is contained in:
Eli Barzilay
parent
f2d6ee7e3c
commit
a6f9520273
|
|
@ -22,7 +22,7 @@
|
|||
|
||||
(define literal
|
||||
(let ([loc (xml:make-location 0 0 0)])
|
||||
(lambda strings (xml:make-cdata loc loc (apply string-append strings)))))
|
||||
(lambda strings (xml:make-cdata loc loc (string-append* strings)))))
|
||||
(define (ref-style path)
|
||||
`(link ([rel "stylesheet"] [type "text/css"] [href ,path] [title "default"])))
|
||||
(define (inlined-style . body)
|
||||
|
|
@ -343,19 +343,16 @@
|
|||
(if p
|
||||
(loop p (if (reveal-subparts? d) mine d))
|
||||
(values d mine)))))
|
||||
(define toc-content
|
||||
(parameterize ([extra-breaking? #t])
|
||||
(map (lambda (pp)
|
||||
(let ([p (car pp)]
|
||||
[show-number? (cdr pp)])
|
||||
`(tr
|
||||
(td ([align "right"])
|
||||
(define (do-part pp)
|
||||
(let ([p (car pp)] [show-number? (cdr pp)])
|
||||
`(tr (td ([align "right"])
|
||||
,@(if show-number?
|
||||
(format-number (collected-info-number (part-collected-info p ri))
|
||||
(format-number
|
||||
(collected-info-number (part-collected-info p ri))
|
||||
'((tt nbsp)))
|
||||
'("-" nbsp)))
|
||||
(td
|
||||
(a ([href ,(let ([dest (resolve-get p ri (car (part-tags p)))])
|
||||
(td (a ([href
|
||||
,(let ([dest (resolve-get p ri (car (part-tags p)))])
|
||||
(format "~a~a~a"
|
||||
(from-root (relative->path (dest-path dest))
|
||||
(get-dest-directory))
|
||||
|
|
@ -364,14 +361,17 @@
|
|||
""
|
||||
(anchor-name (dest-anchor dest)))))]
|
||||
[class ,(if (eq? p mine)
|
||||
"tocviewselflink"
|
||||
"tocviewlink")])
|
||||
"tocviewselflink" "tocviewlink")])
|
||||
,@(render-content (or (part-title-content p) '("???"))
|
||||
d ri))))))
|
||||
(define toc-content
|
||||
(parameterize ([extra-breaking? #t])
|
||||
(map do-part
|
||||
(let loop ([l (map (lambda (v) (cons v #t)) (part-parts top))])
|
||||
(cond [(null? l) null]
|
||||
[(reveal-subparts? (caar l))
|
||||
(cons (car l) (loop (append (map (lambda (v) (cons v #f))
|
||||
(cons (car l)
|
||||
(loop (append (map (lambda (v) (cons v #f))
|
||||
(part-parts (caar l)))
|
||||
(cdr l))))]
|
||||
[else (cons (car l) (loop (cdr l)))])))))
|
||||
|
|
@ -393,11 +393,11 @@
|
|||
(toc-wrap
|
||||
`(table ([class "tocviewlist"] [cellspacing "0"])
|
||||
,@toc-content)))))))
|
||||
,@(render-onthispage-contents d ri top (if (part-style? d 'no-toc)
|
||||
"tocview"
|
||||
"tocsub"))
|
||||
,@(render-onthispage-contents
|
||||
d ri top (if (part-style? d 'no-toc) "tocview" "tocsub"))
|
||||
,@(parameterize ([extra-breaking? #t])
|
||||
(append-map (lambda (t)
|
||||
(append-map
|
||||
(lambda (t)
|
||||
(let loop ([t t])
|
||||
(if (table? t)
|
||||
(render-table t d ri #f)
|
||||
|
|
@ -420,68 +420,52 @@
|
|||
(if (ormap (lambda (p) (part-whole-page? p ri))
|
||||
(part-parts d))
|
||||
null
|
||||
(let* ([nearly-top? (lambda (d) (nearly-top? d ri top))]
|
||||
[ps ((if (nearly-top? d) values cdr)
|
||||
(let ([nearly-top? (lambda (d) (nearly-top? d ri top))])
|
||||
(define (flow-targets flow)
|
||||
(append-map block-targets (flow-paragraphs flow)))
|
||||
(define (block-targets e)
|
||||
(cond [(table? e) (table-targets e)]
|
||||
[(paragraph? e) (para-targets e)]
|
||||
[(itemization? e)
|
||||
(append-map flow-targets (itemization-flows e))]
|
||||
[(blockquote? e)
|
||||
(append-map block-targets (blockquote-paragraphs e))]
|
||||
[(delayed-block? e) null]))
|
||||
(define (para-targets para)
|
||||
(let loop ([c (paragraph-content para)])
|
||||
(define a (and (pair? c) (car c)))
|
||||
(cond
|
||||
[(null? c) null]
|
||||
[(toc-target-element? a) (cons a (loop (cdr c)))]
|
||||
[(toc-element? a) (cons a (loop (cdr c)))]
|
||||
[(element? a)
|
||||
(append (loop (element-content a)) (loop (cdr c)))]
|
||||
[(delayed-element? a)
|
||||
(loop (append (delayed-element-content a ri) (cdr c)))]
|
||||
[(part-relative-element? a)
|
||||
(loop (append (part-relative-element-content a ri) (cdr c)))]
|
||||
[else (loop (cdr c))])))
|
||||
(define (table-targets table)
|
||||
(append-map
|
||||
(lambda (flows)
|
||||
(append-map (lambda (f) (if (eq? f 'cont) null (flow-targets f)))
|
||||
flows))
|
||||
(table-flowss table)))
|
||||
(define ps
|
||||
((if (nearly-top? d) values cdr)
|
||||
(let flatten ([d d])
|
||||
(append*
|
||||
;; don't include the section if it's in the TOC
|
||||
(if (nearly-top? d) null (list d))
|
||||
;; get internal targets:
|
||||
(letrec ([flow-targets
|
||||
(lambda (flow)
|
||||
(apply append (map block-targets (flow-paragraphs flow))))]
|
||||
[block-targets
|
||||
(lambda (e)
|
||||
(cond
|
||||
[(table? e) (table-targets e)]
|
||||
[(paragraph? e) (para-targets e)]
|
||||
[(itemization? e)
|
||||
(apply append (map flow-targets (itemization-flows e)))]
|
||||
[(blockquote? e)
|
||||
(apply append (map block-targets (blockquote-paragraphs e)))]
|
||||
[(delayed-block? e)
|
||||
null]))]
|
||||
[para-targets
|
||||
(lambda (para)
|
||||
(let loop ([c (paragraph-content para)])
|
||||
(define a (and (pair? c) (car c)))
|
||||
(cond
|
||||
[(null? c) null]
|
||||
[(toc-target-element? a)
|
||||
(cons a (loop (cdr c)))]
|
||||
[(toc-element? a)
|
||||
(cons a (loop (cdr c)))]
|
||||
[(element? a)
|
||||
(append (loop (element-content a))
|
||||
(loop (cdr c)))]
|
||||
[(delayed-element? a)
|
||||
(loop (append (delayed-element-content a ri)
|
||||
(cdr c)))]
|
||||
[(part-relative-element? a)
|
||||
(loop (append (part-relative-element-content a ri)
|
||||
(cdr c)))]
|
||||
[else (loop (cdr c))])))]
|
||||
[table-targets
|
||||
(lambda (table)
|
||||
(append-map
|
||||
(lambda (flows)
|
||||
(append-map
|
||||
(lambda (f)
|
||||
(if (eq? f 'cont)
|
||||
null
|
||||
(flow-targets f)))
|
||||
flows))
|
||||
(table-flowss table)))])
|
||||
(append-map block-targets
|
||||
(flow-paragraphs (part-flow d))))
|
||||
(map flatten (part-parts d)))))]
|
||||
[any-parts? (ormap part? ps)])
|
||||
(append-map block-targets (flow-paragraphs (part-flow d)))
|
||||
(map flatten (part-parts d))))))
|
||||
(define any-parts? (ormap part? ps))
|
||||
(if (null? ps)
|
||||
null
|
||||
`((div ([class ,box-class])
|
||||
,@(get-onthispage-label)
|
||||
(table ([class "tocsublist"]
|
||||
[cellspacing "0"])
|
||||
(table ([class "tocsublist"] [cellspacing "0"])
|
||||
,@(map (lambda (p)
|
||||
`(tr
|
||||
(td
|
||||
|
|
@ -493,20 +477,29 @@
|
|||
'((tt nbsp)))))
|
||||
'(""))
|
||||
,@(if (toc-element? p)
|
||||
(render-content (toc-element-toc-content p) d ri)
|
||||
(render-content (toc-element-toc-content p)
|
||||
d ri)
|
||||
(parameterize ([current-no-links #t]
|
||||
[extra-breaking? #t])
|
||||
`((a ([href ,(if (part? p)
|
||||
(format "#~a" (anchor-name (tag-key (car (part-tags p)) ri)))
|
||||
(format "#~a" (anchor-name (tag-key (target-element-tag p) ri))))]
|
||||
[class ,(if (part? p)
|
||||
"tocsubseclink"
|
||||
(if any-parts?
|
||||
"tocsubnonseclink"
|
||||
"tocsublink"))])
|
||||
,@(if (part? p)
|
||||
(render-content (or (part-title-content p) '("???")) d ri)
|
||||
(render-content (element-content p) d ri)))))))))
|
||||
`((a ([href
|
||||
,(format
|
||||
"#~a"
|
||||
(anchor-name
|
||||
(tag-key (if (part? p)
|
||||
(car (part-tags p))
|
||||
(target-element-tag p))
|
||||
ri)))]
|
||||
[class
|
||||
,(cond
|
||||
[(part? p) "tocsubseclink"]
|
||||
[any-parts? "tocsubnonseclink"]
|
||||
[else "tocsublink"])])
|
||||
,@(render-content
|
||||
(if (part? p)
|
||||
(or (part-title-content p)
|
||||
'("???"))
|
||||
(element-content p))
|
||||
d ri))))))))
|
||||
ps))))))))
|
||||
|
||||
(define/public (render-one-part d ri fn number)
|
||||
|
|
@ -649,7 +642,8 @@
|
|||
(define/public (render-version d ri)
|
||||
`((div ([class "versionbox"])
|
||||
,@(render-content
|
||||
(list (make-element "version" (list "Version: " (current-version))))
|
||||
(list (make-element "version"
|
||||
(list "Version: " (current-version))))
|
||||
d
|
||||
ri))))
|
||||
|
||||
|
|
@ -668,7 +662,8 @@
|
|||
[else 'h5])
|
||||
,@(format-number number '((tt nbsp)))
|
||||
,@(map (lambda (t)
|
||||
`(a ((name ,(format "~a" (anchor-name (tag-key t ri)))))))
|
||||
`(a ([name ,(format "~a" (anchor-name
|
||||
(tag-key t ri)))])))
|
||||
(part-tags d))
|
||||
,@(if (part-title-content d)
|
||||
(render-content (part-title-content d) d ri)
|
||||
|
|
@ -684,7 +679,7 @@
|
|||
(define/private (render-flow* p part ri start-inline? special-last?)
|
||||
;; Wrap each table with <p>, except for a trailing table
|
||||
;; when `special-last?' is #t
|
||||
(let loop ([f (flow-paragraphs p)][inline? start-inline?])
|
||||
(let loop ([f (flow-paragraphs p)] [inline? start-inline?])
|
||||
(cond
|
||||
[(null? f) null]
|
||||
[(and (table? (car f))
|
||||
|
|
@ -706,21 +701,26 @@
|
|||
(define/override (render-element e part ri)
|
||||
(cond
|
||||
[(hover-element? e)
|
||||
`((span ((title ,(hover-element-text e))) ,@(render-plain-element e part ri)))]
|
||||
`((span ([title ,(hover-element-text e)])
|
||||
,@(render-plain-element e part ri)))]
|
||||
[(target-element? e)
|
||||
`((a ((name ,(format "~a" (anchor-name (tag-key (target-element-tag e) ri))))))
|
||||
`((a ([name ,(format "~a" (anchor-name (tag-key (target-element-tag e)
|
||||
ri)))]))
|
||||
,@(render-plain-element e part ri))]
|
||||
[(and (link-element? e) (not (current-no-links)))
|
||||
(parameterize ([current-no-links #t])
|
||||
(let-values ([(dest ext?) (resolve-get/ext? part ri (link-element-tag e))])
|
||||
(let-values ([(dest ext?)
|
||||
(resolve-get/ext? part ri (link-element-tag e))])
|
||||
(if dest
|
||||
`((a [(href ,(if (and ext? external-tag-path)
|
||||
`((a [(href
|
||||
,(if (and ext? external-tag-path)
|
||||
;; Redirected to search:
|
||||
(format "~a;tag=~a"
|
||||
external-tag-path
|
||||
(base64-encode
|
||||
(string->bytes/utf-8
|
||||
(format "~a" (serialize (link-element-tag e))))))
|
||||
(format "~a" (serialize
|
||||
(link-element-tag e))))))
|
||||
;; Normal link:
|
||||
(format "~a~a~a"
|
||||
(from-root (relative->path (dest-path dest))
|
||||
|
|
@ -747,15 +747,17 @@
|
|||
[else (render-plain-element e part ri)]))
|
||||
|
||||
(define/private (render-plain-element e part ri)
|
||||
(let ([style (and (element? e) (element-style e))])
|
||||
(define style (and (element? e) (element-style e)))
|
||||
(cond
|
||||
[(symbol? style)
|
||||
(case style
|
||||
[(italic) `((i ,@(super render-element e part ri)))]
|
||||
[(bold) `((b ,@(super render-element e part ri)))]
|
||||
[(tt) `((span ([class "stt"]) ,@(super render-element e part ri)))]
|
||||
[(no-break) `((span ([class "nobreak"]) ,@(super render-element e part ri)))]
|
||||
[(sf) `((b (font ([size "-1"][face "Helvetica"]) ,@(super render-element e part ri))))]
|
||||
[(no-break) `((span ([class "nobreak"])
|
||||
,@(super render-element e part ri)))]
|
||||
[(sf) `((b (font ([size "-1"] [face "Helvetica"])
|
||||
,@(super render-element e part ri))))]
|
||||
[(subscript) `((sub ,@(super render-element e part ri)))]
|
||||
[(superscript) `((sup ,@(super render-element e part ri)))]
|
||||
[(hspace) `((span ([class "hspace"])
|
||||
|
|
@ -765,9 +767,7 @@
|
|||
[else (error 'html-render "unrecognized style symbol: ~e" style)])]
|
||||
[(string? style)
|
||||
`((span ([class ,style]) ,@(super render-element e part ri)))]
|
||||
[(and (pair? style)
|
||||
(or (eq? (car style) 'bg-color)
|
||||
(eq? (car style) 'color)))
|
||||
[(and (pair? style) (memq (car style) '(color bg-color)))
|
||||
(unless (and (list? style)
|
||||
(or (and (= 4 (length style))
|
||||
(andmap byte? (cdr style)))
|
||||
|
|
@ -776,17 +776,16 @@
|
|||
'("white" "black" "red" "green" "blue"
|
||||
"cyan" "magenta" "yellow")))))
|
||||
(error 'render-font "bad color style: ~e" style))
|
||||
`((font ([style ,(format "~acolor: ~a"
|
||||
(if (eq? (car style) 'bg-color)
|
||||
"background-"
|
||||
"")
|
||||
`((font ([style
|
||||
,(format "~acolor: ~a"
|
||||
(if (eq? (car style) 'bg-color) "background-" "")
|
||||
(if (= 2 (length style))
|
||||
(cadr style)
|
||||
(string-append*
|
||||
"#"
|
||||
(map (lambda (v)
|
||||
(let ([s (format "0~x" v)])
|
||||
(substring s (- (string-length s) 2))))
|
||||
(let ([s (number->string v 16)])
|
||||
(if (< v 16) (string-append "0" s) s)))
|
||||
(cdr style)))))])
|
||||
,@(super render-element e part ri)))]
|
||||
[(target-url? style)
|
||||
|
|
@ -807,6 +806,11 @@
|
|||
[(image-file? style)
|
||||
(let* ([src (main-collects-relative->path (image-file-path style))]
|
||||
[scale (image-file-scale style)]
|
||||
[to-num
|
||||
(lambda (s)
|
||||
(number->string
|
||||
(inexact->exact
|
||||
(floor (* scale (integer-bytes->integer s #f #t))))))]
|
||||
[sz (if (= 1.0 scale)
|
||||
null
|
||||
;; Try to extract file size:
|
||||
|
|
@ -814,61 +818,35 @@
|
|||
src
|
||||
(lambda (in)
|
||||
(if (regexp-try-match #px#"^\211PNG.{12}" in)
|
||||
(let ([w (read-bytes 4 in)]
|
||||
[h (read-bytes 4 in)]
|
||||
[to-num (lambda (s)
|
||||
(number->string
|
||||
(inexact->exact
|
||||
(floor (* scale (integer-bytes->integer s #f #t))))))])
|
||||
`([width ,(to-num w)]
|
||||
[height ,(to-num h)]))
|
||||
`([width ,(to-num (read-bytes 4 in))]
|
||||
[height ,(to-num (read-bytes 4 in))])
|
||||
null))))])
|
||||
`((img ([src ,(let ([p (install-file src)])
|
||||
(if (path? p)
|
||||
(url->string (path->url (path->complete-path p)))
|
||||
p))])
|
||||
,@sz)))]
|
||||
[else (super render-element e part ri)])))
|
||||
[else (super render-element e part ri)]))
|
||||
|
||||
(define/override (render-table t part ri need-inline?)
|
||||
(define index? (eq? 'index (table-style t)))
|
||||
`(,@(if index? `(,search-script ,search-field) '())
|
||||
(table ([cellspacing "0"]
|
||||
,@(if need-inline?
|
||||
'([style "display: inline; vertical-align: top;"])
|
||||
null)
|
||||
,@(case (table-style t)
|
||||
[(boxed) '([class "boxed"])]
|
||||
[(centered) '([align "center"])]
|
||||
[(at-right) '([align "right"])]
|
||||
[(at-left) '([align "left"])]
|
||||
[else null])
|
||||
,@(let ([a (and (list? (table-style t))
|
||||
(assoc 'style (table-style t)))])
|
||||
(if (and a (string? (cadr a)))
|
||||
`([class ,(cadr a)])
|
||||
null))
|
||||
,@(if (string? (table-style t))
|
||||
`([class ,(table-style t)])
|
||||
null))
|
||||
,@(map (lambda (flows style)
|
||||
(define t-style (table-style t))
|
||||
(define t-style-get (if (and (pair? t-style) (list? t-style))
|
||||
(lambda (k) (assoc k (or t-style null)))
|
||||
(lambda (k) #f)))
|
||||
(define index? (eq? 'index t-style))
|
||||
(define (make-row flows style)
|
||||
`(tr (,@(if style `([class ,style]) null))
|
||||
,@(let loop ([ds flows]
|
||||
[as (cdr (or (and (list? (table-style t))
|
||||
(assoc 'alignment (or (table-style t) null)))
|
||||
[as (cdr (or (t-style-get 'alignment)
|
||||
(cons #f (map (lambda (x) #f) flows))))]
|
||||
[vas
|
||||
(cdr (or (and (list? (table-style t))
|
||||
(assoc 'valignment (or (table-style t) null)))
|
||||
[vas (cdr (or (t-style-get 'valignment)
|
||||
(cons #f (map (lambda (x) #f) flows))))])
|
||||
(cond
|
||||
[(null? ds) null]
|
||||
[(eq? (car ds) 'cont)
|
||||
(loop (cdr ds) (cdr as) (cdr vas))]
|
||||
[else
|
||||
(let ([d (car ds)]
|
||||
[a (car as)]
|
||||
[va (car vas)])
|
||||
(let ([d (car ds)] [a (car as)] [va (car vas)])
|
||||
(cons
|
||||
`(td (,@(case a
|
||||
[(#f) null]
|
||||
|
|
@ -884,18 +862,31 @@
|
|||
(eq? 'cont (cadr ds)))
|
||||
`([colspan
|
||||
,(number->string
|
||||
(let loop ([n 2]
|
||||
[ds (cddr ds)])
|
||||
(cond
|
||||
[(null? ds) n]
|
||||
[(eq? 'cont (car ds)) (loop (+ n 1) (cdr ds))]
|
||||
(let loop ([n 2] [ds (cddr ds)])
|
||||
(cond [(null? ds) n]
|
||||
[(eq? 'cont (car ds))
|
||||
(loop (+ n 1) (cdr ds))]
|
||||
[else n])))])
|
||||
null))
|
||||
,@(render-flow d part ri #f))
|
||||
(loop (cdr ds) (cdr as) (cdr vas))))]))))
|
||||
`(,@(if index? `(,search-script ,search-field) '())
|
||||
(table ([cellspacing "0"]
|
||||
,@(if need-inline?
|
||||
'([style "display: inline; vertical-align: top;"])
|
||||
null)
|
||||
,@(case t-style
|
||||
[(boxed) '([class "boxed"])]
|
||||
[(centered) '([align "center"])]
|
||||
[(at-right) '([align "right"])]
|
||||
[(at-left) '([align "left"])]
|
||||
[else null])
|
||||
,@(let ([a (t-style-get 'style)])
|
||||
(if (and a (string? (cadr a))) `([class ,(cadr a)]) null))
|
||||
,@(if (string? t-style) `([class ,t-style]) null))
|
||||
,@(map make-row
|
||||
(table-flowss t)
|
||||
(cdr (or (and (list? (table-style t))
|
||||
(assoc 'row-styles (or (table-style t) null)))
|
||||
(cdr (or (t-style-get 'row-styles)
|
||||
(cons #f (map (lambda (x) #f) (table-flowss t)))))))))
|
||||
|
||||
(define/override (render-blockquote t part ri)
|
||||
|
|
@ -962,7 +953,8 @@
|
|||
|
||||
(define/override (get-dest-directory)
|
||||
(or (and (current-subdirectory)
|
||||
(build-path (or (super get-dest-directory) (current-directory)) (current-subdirectory)))
|
||||
(build-path (or (super get-dest-directory) (current-directory))
|
||||
(current-subdirectory)))
|
||||
(super get-dest-directory)))
|
||||
|
||||
(define/override (derive-filename d)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user