Added 'newline items, made index pages use them instead of
table rows. (And some reformatting, of course.) svn: r8426 original commit: 642c0d60718d0d3daa5266f6402bea9957807aea
This commit is contained in:
Eli Barzilay
parent
d2002d0a0d
commit
81179a7eea
|
|
@ -1,295 +1,279 @@
|
|||
|
||||
(module basic scheme/base
|
||||
(require "decode.ss"
|
||||
"struct.ss"
|
||||
"config.ss"
|
||||
mzlib/list
|
||||
mzlib/class
|
||||
setup/main-collects
|
||||
syntax/modresolve
|
||||
(for-syntax scheme/base))
|
||||
#lang scheme/base
|
||||
|
||||
(provide title
|
||||
section
|
||||
subsection
|
||||
subsubsection
|
||||
subsubsub*section
|
||||
include-section)
|
||||
(require "decode.ss"
|
||||
"struct.ss"
|
||||
"config.ss"
|
||||
mzlib/list
|
||||
mzlib/class
|
||||
setup/main-collects
|
||||
syntax/modresolve
|
||||
(for-syntax scheme/base))
|
||||
|
||||
(define (gen-tag content)
|
||||
(regexp-replace* "[^-a-zA-Z0-9_=]"
|
||||
(content->string content)
|
||||
"_"))
|
||||
(provide title
|
||||
section
|
||||
subsection
|
||||
subsubsection
|
||||
subsubsub*section
|
||||
include-section)
|
||||
|
||||
(define (prefix->string p)
|
||||
(and p
|
||||
(if (string? p)
|
||||
p
|
||||
(module-path-prefix->string p))))
|
||||
(define (gen-tag content)
|
||||
(regexp-replace* "[^-a-zA-Z0-9_=]" (content->string content) "_"))
|
||||
|
||||
(define (convert-tag tag content)
|
||||
(if (list? tag)
|
||||
(apply append (map (lambda (t) (convert-tag t content)) tag))
|
||||
`((part ,(or tag (gen-tag content))))))
|
||||
(define (prefix->string p)
|
||||
(and p (if (string? p) p (module-path-prefix->string p))))
|
||||
|
||||
(define (title #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style #f] #:version [version #f] . str)
|
||||
(let ([content (decode-content str)])
|
||||
(make-title-decl (prefix->string prefix)
|
||||
(convert-tag tag content)
|
||||
version
|
||||
style
|
||||
content)))
|
||||
(define (convert-tag tag content)
|
||||
(if (list? tag)
|
||||
(apply append (map (lambda (t) (convert-tag t content)) tag))
|
||||
`((part ,(or tag (gen-tag content))))))
|
||||
|
||||
(define (section #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style #f] . str)
|
||||
(let ([content (decode-content str)])
|
||||
(make-part-start 0 (prefix->string prefix)
|
||||
(convert-tag tag content)
|
||||
style
|
||||
content)))
|
||||
(define (title #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style #f]
|
||||
#:version [version #f] . str)
|
||||
(let ([content (decode-content str)])
|
||||
(make-title-decl (prefix->string prefix)
|
||||
(convert-tag tag content)
|
||||
version
|
||||
style
|
||||
content)))
|
||||
|
||||
(define (subsection #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style #f] . str)
|
||||
(let ([content (decode-content str)])
|
||||
(make-part-start 1
|
||||
(prefix->string prefix)
|
||||
(convert-tag tag content)
|
||||
style
|
||||
content)))
|
||||
(define (section #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style #f]
|
||||
. str)
|
||||
(let ([content (decode-content str)])
|
||||
(make-part-start 0 (prefix->string prefix)
|
||||
(convert-tag tag content)
|
||||
style
|
||||
content)))
|
||||
|
||||
(define (subsubsection #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style #f] . str)
|
||||
(let ([content (decode-content str)])
|
||||
(make-part-start 2
|
||||
(prefix->string prefix)
|
||||
(convert-tag tag content)
|
||||
style
|
||||
content)))
|
||||
(define (subsection #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style #f]
|
||||
. str)
|
||||
(let ([content (decode-content str)])
|
||||
(make-part-start 1
|
||||
(prefix->string prefix)
|
||||
(convert-tag tag content)
|
||||
style
|
||||
content)))
|
||||
|
||||
(define (subsubsub*section #:tag [tag #f] . str)
|
||||
(let ([content (decode-content str)])
|
||||
(make-paragraph (list (make-element 'bold content)))))
|
||||
(define (subsubsection #:tag [tag #f] #:tag-prefix [prefix #f]
|
||||
#:style [style #f] . str)
|
||||
(let ([content (decode-content str)])
|
||||
(make-part-start 2
|
||||
(prefix->string prefix)
|
||||
(convert-tag tag content)
|
||||
style
|
||||
content)))
|
||||
|
||||
(define-syntax (include-section stx)
|
||||
(syntax-case stx ()
|
||||
[(_ mod)
|
||||
(with-syntax ([mod (syntax-local-introduce #'mod)])
|
||||
#'(begin
|
||||
(require (only-in mod doc))
|
||||
doc))]))
|
||||
(define (subsubsub*section #:tag [tag #f] . str)
|
||||
(let ([content (decode-content str)])
|
||||
(make-paragraph (list (make-element 'bold content)))))
|
||||
|
||||
;; ----------------------------------------
|
||||
(define-syntax (include-section stx)
|
||||
(syntax-case stx ()
|
||||
[(_ mod)
|
||||
(with-syntax ([mod (syntax-local-introduce #'mod)])
|
||||
#'(begin
|
||||
(require (only-in mod doc))
|
||||
doc))]))
|
||||
|
||||
(provide module-path-prefix->string)
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (module-path-prefix->string p)
|
||||
(format "~a" (path->main-collects-relative
|
||||
(resolve-module-path p #f))))
|
||||
(provide module-path-prefix->string)
|
||||
|
||||
;; ----------------------------------------
|
||||
(define (module-path-prefix->string p)
|
||||
(format "~a" (path->main-collects-relative
|
||||
(resolve-module-path p #f))))
|
||||
|
||||
(provide itemize item item?)
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (itemize . items)
|
||||
(let ([items (filter (lambda (v) (not (whitespace? v))) items)])
|
||||
(for ([v items])
|
||||
(unless (an-item? v)
|
||||
(error 'itemize "expected an item, found something else: ~e" v)))
|
||||
(make-itemization (map an-item-flow items))))
|
||||
(provide itemize item item?)
|
||||
|
||||
(define-struct an-item (flow))
|
||||
(define (item? x) (an-item? x))
|
||||
(define (itemize . items)
|
||||
(let ([items (filter (lambda (v) (not (whitespace? v))) items)])
|
||||
(for ([v items])
|
||||
(unless (an-item? v)
|
||||
(error 'itemize "expected an item, found something else: ~e" v)))
|
||||
(make-itemization (map an-item-flow items))))
|
||||
|
||||
(define (item . str)
|
||||
(make-an-item (decode-flow str)))
|
||||
(define-struct an-item (flow))
|
||||
(define (item? x) (an-item? x))
|
||||
|
||||
;; ----------------------------------------
|
||||
(define (item . str)
|
||||
(make-an-item (decode-flow str)))
|
||||
|
||||
(provide hspace
|
||||
elem aux-elem
|
||||
italic bold
|
||||
tt span-class
|
||||
subscript superscript)
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (hspace n)
|
||||
(make-element 'hspace (list (make-string n #\space))))
|
||||
(provide hspace
|
||||
elem aux-elem
|
||||
italic bold
|
||||
tt span-class
|
||||
subscript superscript)
|
||||
|
||||
(define (elem . str)
|
||||
(make-element #f (decode-content str)))
|
||||
(define (hspace n)
|
||||
(make-element 'hspace (list (make-string n #\space))))
|
||||
|
||||
(define (aux-elem . s)
|
||||
(make-aux-element #f (decode-content s)))
|
||||
(define (elem . str)
|
||||
(make-element #f (decode-content str)))
|
||||
|
||||
(define (italic . str)
|
||||
(make-element 'italic (decode-content str)))
|
||||
(define (aux-elem . s)
|
||||
(make-aux-element #f (decode-content s)))
|
||||
|
||||
(define (bold . str)
|
||||
(make-element 'bold (decode-content str)))
|
||||
(define (italic . str)
|
||||
(make-element 'italic (decode-content str)))
|
||||
|
||||
(define (tt . str)
|
||||
(let ([l (decode-content str)])
|
||||
(let ([l (let ([m (and (pair? l)
|
||||
(string? (car l))
|
||||
(regexp-match-positions #rx"^ +" (car l)))])
|
||||
(if m
|
||||
(cons (hspace (- (cdar m) (caar m)))
|
||||
(cons
|
||||
(substring (car l) (cdar m))
|
||||
(cdr l)))
|
||||
l))])
|
||||
(if (andmap string? l)
|
||||
(make-element 'tt l)
|
||||
(make-element #f (map (lambda (s)
|
||||
(if (or (string? s)
|
||||
(symbol? s))
|
||||
(make-element 'tt (list s))
|
||||
s))
|
||||
l))))))
|
||||
(define (bold . str)
|
||||
(make-element 'bold (decode-content str)))
|
||||
|
||||
(define (span-class classname . str)
|
||||
(make-element classname (decode-content str)))
|
||||
(define (tt . str)
|
||||
(let* ([l (decode-content str)]
|
||||
[l (let ([m (and (pair? l)
|
||||
(string? (car l))
|
||||
(regexp-match-positions #rx"^ +" (car l)))])
|
||||
(if m
|
||||
(list* (hspace (- (cdar m) (caar m)))
|
||||
(substring (car l) (cdar m))
|
||||
(cdr l))
|
||||
l))])
|
||||
(if (andmap string? l)
|
||||
(make-element 'tt l)
|
||||
(make-element #f (map (lambda (s)
|
||||
(if (or (string? s) (symbol? s))
|
||||
(make-element 'tt (list s))
|
||||
s))
|
||||
l)))))
|
||||
|
||||
(define (subscript . str)
|
||||
(make-element 'subscript (decode-content str)))
|
||||
(define (span-class classname . str)
|
||||
(make-element classname (decode-content str)))
|
||||
|
||||
(define (superscript . str)
|
||||
(make-element 'superscript (decode-content str)))
|
||||
(define (subscript . str)
|
||||
(make-element 'subscript (decode-content str)))
|
||||
|
||||
;; ----------------------------------------
|
||||
(define (superscript . str)
|
||||
(make-element 'superscript (decode-content str)))
|
||||
|
||||
(provide section-index index index* as-index index-section index-flow-elements)
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (section-index . elems)
|
||||
(make-part-index-decl (map element->string elems) elems))
|
||||
(provide section-index index index* as-index index-section index-flow-elements)
|
||||
|
||||
(define (record-index word-seq element-seq tag content)
|
||||
(make-index-element
|
||||
#f
|
||||
(list (make-target-element #f content `(idx ,tag)))
|
||||
`(idx ,tag)
|
||||
word-seq
|
||||
element-seq
|
||||
#f))
|
||||
(define (section-index . elems)
|
||||
(make-part-index-decl (map element->string elems) elems))
|
||||
|
||||
(define (index* word-seq content-seq . s)
|
||||
(let ([key (make-generated-tag)])
|
||||
(record-index word-seq
|
||||
content-seq
|
||||
key
|
||||
(decode-content s))))
|
||||
(define (record-index word-seq element-seq tag content)
|
||||
(make-index-element #f
|
||||
(list (make-target-element #f content `(idx ,tag)))
|
||||
`(idx ,tag)
|
||||
word-seq
|
||||
element-seq
|
||||
#f))
|
||||
|
||||
(define (index word-seq . s)
|
||||
(let ([word-seq (if (string? word-seq)
|
||||
(list word-seq)
|
||||
word-seq)])
|
||||
(apply index* word-seq word-seq s)))
|
||||
(define (index* word-seq content-seq . s)
|
||||
(let ([key (make-generated-tag)])
|
||||
(record-index word-seq content-seq key (decode-content s))))
|
||||
|
||||
(define (as-index . s)
|
||||
(let ([key (make-generated-tag)]
|
||||
[content (decode-content s)])
|
||||
(record-index (list (content->string content))
|
||||
(list (make-element #f content))
|
||||
key
|
||||
content)))
|
||||
(define (index word-seq . s)
|
||||
(let ([word-seq (if (string? word-seq) (list word-seq) word-seq)])
|
||||
(apply index* word-seq word-seq s)))
|
||||
|
||||
(define (index-section #:title [title "Index"] #:tag [tag #f])
|
||||
(make-unnumbered-part #f
|
||||
`((part ,(or tag "doc-index")))
|
||||
(list title)
|
||||
'index
|
||||
null
|
||||
(make-flow (index-flow-elements))
|
||||
null))
|
||||
(define (as-index . s)
|
||||
(let ([key (make-generated-tag)]
|
||||
[content (decode-content s)])
|
||||
(record-index (list (content->string content))
|
||||
(list (make-element #f content))
|
||||
key
|
||||
content)))
|
||||
|
||||
(define (index-flow-elements)
|
||||
(define (commas l)
|
||||
(if (or (null? l) (null? (cdr l)))
|
||||
l
|
||||
(cdr (apply append (map (lambda (i) (list ", " i)) l)))))
|
||||
(define (cadr-string-lists<? a b)
|
||||
(let loop ([a (cadr a)] [b (cadr b)])
|
||||
(cond [(null? b) #f]
|
||||
[(null? a) #t]
|
||||
[(string-ci=? (car a) (car b))
|
||||
(or (loop (cdr a) (cdr b))
|
||||
;; Try string<? so "Foo" still precedes "foo"
|
||||
(string<? (car a) (car b)))]
|
||||
[else (string-ci<? (car a) (car b))])))
|
||||
(define alpha (string->list "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
|
||||
(define contents
|
||||
(make-delayed-flow-element
|
||||
(lambda (renderer sec ri)
|
||||
(define l null)
|
||||
(define alpha-starts (make-hash-table))
|
||||
(hash-table-for-each
|
||||
(let ([parent (collected-info-parent (part-collected-info sec ri))])
|
||||
(if parent
|
||||
(collected-info-info (part-collected-info parent ri))
|
||||
(collect-info-ext-ht (resolve-info-ci ri))))
|
||||
(lambda (k v)
|
||||
(when (and (pair? k) (eq? 'index-entry (car k)))
|
||||
(set! l (cons (cons (cadr k) v) l)))))
|
||||
(set! l (sort l cadr-string-lists<?))
|
||||
(make-table
|
||||
'index
|
||||
(list*
|
||||
(list
|
||||
(make-flow
|
||||
(list
|
||||
(make-paragraph
|
||||
(let loop ([i l] [alpha alpha])
|
||||
(define (add-letter letter l)
|
||||
(list* (make-element "nonavigation" (list (string letter)))
|
||||
" " l))
|
||||
(cond [(null? alpha) null]
|
||||
[(null? i) (add-letter (car alpha) (loop i (cdr alpha)))]
|
||||
[else
|
||||
(let* ([strs (cadr (car i))]
|
||||
[letter (if (or (null? strs)
|
||||
(string=? "" (car strs)))
|
||||
#f
|
||||
(string-ref (car strs) 0))])
|
||||
(cond
|
||||
[(not letter) (loop (cdr i) alpha)]
|
||||
[(char-ci>? letter (car alpha))
|
||||
(add-letter (car alpha) (loop i (cdr alpha)))]
|
||||
[(char-ci=? letter (car alpha))
|
||||
(hash-table-put! alpha-starts (car i) letter)
|
||||
(list*
|
||||
(make-element
|
||||
(make-target-url
|
||||
(format "#alpha:~a" (char-upcase letter))
|
||||
#f)
|
||||
(list (string (car alpha))))
|
||||
" "
|
||||
(loop (cdr i) (cdr alpha)))]
|
||||
[else (loop (cdr i) alpha)]))]))))))
|
||||
(list (make-flow (list (make-paragraph (list 'nbsp)))))
|
||||
(map (lambda (i)
|
||||
(let* ([e (make-link-element "indexlink"
|
||||
(commas (caddr i))
|
||||
(car i))]
|
||||
[letter (hash-table-get alpha-starts i #f)]
|
||||
[e (if letter
|
||||
(make-element
|
||||
(make-url-anchor (format "alpha:~a" letter))
|
||||
(list e))
|
||||
e)])
|
||||
(list (make-flow (list (make-paragraph (list e)))))))
|
||||
l))))))
|
||||
(list contents))
|
||||
(define (index-section #:title [title "Index"] #:tag [tag #f])
|
||||
(make-unnumbered-part #f
|
||||
`((part ,(or tag "doc-index")))
|
||||
(list title)
|
||||
'index
|
||||
null
|
||||
(make-flow (index-flow-elements))
|
||||
null))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(provide table-of-contents
|
||||
local-table-of-contents)
|
||||
|
||||
(define (table-of-contents)
|
||||
(define (index-flow-elements)
|
||||
(define (commas l)
|
||||
(if (or (null? l) (null? (cdr l)))
|
||||
l
|
||||
(cdr (apply append (map (lambda (i) (list ", " i)) l)))))
|
||||
(define (cadr-string-lists<? a b)
|
||||
(let loop ([a (cadr a)] [b (cadr b)])
|
||||
(cond [(null? b) #f]
|
||||
[(null? a) #t]
|
||||
[(string-ci=? (car a) (car b))
|
||||
(or (loop (cdr a) (cdr b))
|
||||
;; Try string<? so "Foo" still precedes "foo"
|
||||
(string<? (car a) (car b)))]
|
||||
[else (string-ci<? (car a) (car b))])))
|
||||
(define alpha (string->list "ABCDEFGHIJKLMNOPQRSTUVWXYZ"))
|
||||
(define contents
|
||||
(make-delayed-flow-element
|
||||
(lambda (renderer part ri)
|
||||
(send renderer table-of-contents part ri))))
|
||||
(lambda (renderer sec ri)
|
||||
(define l null)
|
||||
(define alpha-starts (make-hash-table))
|
||||
(define (rows . rows)
|
||||
(make-table 'index
|
||||
(map (lambda (row)
|
||||
(list (make-flow (list (make-paragraph row)))))
|
||||
rows)))
|
||||
(hash-table-for-each
|
||||
(let ([parent (collected-info-parent (part-collected-info sec ri))])
|
||||
(if parent
|
||||
(collected-info-info (part-collected-info parent ri))
|
||||
(collect-info-ext-ht (resolve-info-ci ri))))
|
||||
(lambda (k v)
|
||||
(when (and (pair? k) (eq? 'index-entry (car k)))
|
||||
(set! l (cons (cons (cadr k) v) l)))))
|
||||
(set! l (sort l cadr-string-lists<?))
|
||||
(rows
|
||||
(let loop ([i l] [alpha alpha])
|
||||
(define (add-letter let l)
|
||||
(list* (make-element "nonavigation" (list (string let))) " " l))
|
||||
(cond [(null? alpha) null]
|
||||
[(null? i) (add-letter (car alpha) (loop i (cdr alpha)))]
|
||||
[else
|
||||
(let* ([strs (cadr (car i))]
|
||||
[letter (if (or (null? strs) (string=? "" (car strs)))
|
||||
#f
|
||||
(char-upcase (string-ref (car strs) 0)))])
|
||||
(cond [(not letter) (loop (cdr i) alpha)]
|
||||
[(char-ci>? letter (car alpha))
|
||||
(add-letter (car alpha) (loop i (cdr alpha)))]
|
||||
[(char-ci=? letter (car alpha))
|
||||
(hash-table-put! alpha-starts (car i) letter)
|
||||
(list* (make-element
|
||||
(make-target-url (format "#alpha:~a" letter)
|
||||
#f)
|
||||
(list (string (car alpha))))
|
||||
" "
|
||||
(loop (cdr i) (cdr alpha)))]
|
||||
[else (loop (cdr i) alpha)]))]))
|
||||
(list 'nbsp)
|
||||
(apply append
|
||||
(map (lambda (i)
|
||||
(define e (make-link-element
|
||||
"indexlink" (commas (caddr i)) (car i)))
|
||||
(list (cond [(hash-table-get alpha-starts i #f)
|
||||
=> (lambda (let)
|
||||
(make-element
|
||||
(make-url-anchor
|
||||
(format "alpha:~a" (char-upcase let)))
|
||||
(list e)))]
|
||||
[else e])
|
||||
'newline))
|
||||
l))))))
|
||||
(list contents))
|
||||
|
||||
(define (local-table-of-contents)
|
||||
(make-delayed-flow-element
|
||||
(lambda (renderer part ri)
|
||||
(send renderer local-table-of-contents part ri)))))
|
||||
;; ----------------------------------------
|
||||
|
||||
(provide table-of-contents
|
||||
local-table-of-contents)
|
||||
|
||||
(define (table-of-contents)
|
||||
(make-delayed-flow-element
|
||||
(lambda (renderer part ri)
|
||||
(send renderer table-of-contents part ri))))
|
||||
|
||||
(define (local-table-of-contents)
|
||||
(make-delayed-flow-element
|
||||
(lambda (renderer part ri)
|
||||
(send renderer local-table-of-contents part ri))))
|
||||
|
|
|
|||
|
|
@ -581,21 +581,23 @@
|
|||
|
||||
(define/override (render-other i part ri)
|
||||
(cond
|
||||
[(string? i) (let ([m (and (extra-breaking?)
|
||||
(regexp-match-positions #rx"[-:/]" i))])
|
||||
(if m
|
||||
(list* (substring i 0 (cdar m))
|
||||
;; Most browsers wrap after a hyphen. The
|
||||
;; one that doesn't, Firefox, pays attention
|
||||
;; to wbr. Some browsers ignore wbr, but
|
||||
;; at they don't do strange things with it.
|
||||
(if (equal? #\- (string-ref i (caar m)))
|
||||
'(wbr)
|
||||
`(span ((class "mywbr")) " "))
|
||||
(render-other (substring i (cdar m)) part ri))
|
||||
(ascii-ize i)))]
|
||||
[(string? i)
|
||||
(let ([m (and (extra-breaking?)
|
||||
(regexp-match-positions #rx"[-:/]" i))])
|
||||
(if m
|
||||
(list* (substring i 0 (cdar m))
|
||||
;; Most browsers wrap after a hyphen. The
|
||||
;; one that doesn't, Firefox, pays attention
|
||||
;; to wbr. Some browsers ignore wbr, but
|
||||
;; at least they don't do strange things with it.
|
||||
(if (equal? #\- (string-ref i (caar m)))
|
||||
'(wbr)
|
||||
`(span ((class "mywbr")) " "))
|
||||
(render-other (substring i (cdar m)) part ri))
|
||||
(ascii-ize i)))]
|
||||
[(eq? i 'mdash) `(" " ndash " ")]
|
||||
[(eq? i 'hline) `((hr))]
|
||||
[(eq? i 'newline) `((br))]
|
||||
[(symbol? i) (list i)]
|
||||
[else (list (format "~s" i))]))
|
||||
|
||||
|
|
|
|||
|
|
@ -343,6 +343,7 @@
|
|||
[(string? i) (display-protected i)]
|
||||
[(symbol? i) (display
|
||||
(case i
|
||||
[(newline) "\\\\"]
|
||||
[(nbsp) "~"]
|
||||
[(mdash) "---"]
|
||||
[(ndash) "--"]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user