improve scribble index support
svn: r7047 original commit: ab9c34a8ecdff19c469d167a16f44f1863f546f3
This commit is contained in:
Matthew Flatt
parent
c0f03edcee
commit
f7803f005e
|
|
@ -69,8 +69,8 @@
|
|||
(let ([p-ht (make-hash-table 'equal)])
|
||||
(when (part-title-content d)
|
||||
(collect-content (part-title-content d) p-ht))
|
||||
(when (part-tag d)
|
||||
(collect-part-tag d p-ht number))
|
||||
(collect-part-tags d p-ht number)
|
||||
(collect-content (part-to-collect d) p-ht)
|
||||
(collect-flow (part-flow d) p-ht)
|
||||
(let loop ([parts (part-parts d)]
|
||||
[pos 1])
|
||||
|
|
@ -91,8 +91,10 @@
|
|||
(lambda (k v)
|
||||
(hash-table-put! ht k v)))))
|
||||
|
||||
(define/public (collect-part-tag d ht number)
|
||||
(hash-table-put! ht `(part ,(part-tag d)) (list (part-title-content d) number)))
|
||||
(define/public (collect-part-tags d ht number)
|
||||
(for-each (lambda (t)
|
||||
(hash-table-put! ht `(part ,t) (list (part-title-content d) number)))
|
||||
(part-tags d)))
|
||||
|
||||
(define/public (collect-content c ht)
|
||||
(for-each (lambda (i)
|
||||
|
|
@ -316,7 +318,7 @@
|
|||
(list
|
||||
(make-element 'hspace '(" "))))
|
||||
(part-title-content part))
|
||||
`(part ,(part-tag part))))))))
|
||||
`(part ,(car (part-tags part)))))))))
|
||||
subs)])
|
||||
(if (and (= 1 (length number))
|
||||
(or (not (car number))
|
||||
|
|
|
|||
|
|
@ -119,10 +119,13 @@
|
|||
|
||||
;; ----------------------------------------
|
||||
|
||||
(provide index index* as-index index-section)
|
||||
(provide section-index index index* as-index index-section)
|
||||
|
||||
(define (section-index . elems)
|
||||
(make-section-index-decl (map element->string elems) elems))
|
||||
|
||||
(define (gen-target)
|
||||
(format "index:~s:~s" (current-seconds) (gensym)))
|
||||
(format "index:~s:~s" (current-inexact-milliseconds) (gensym)))
|
||||
|
||||
(define (record-index word-seq element-seq tag content)
|
||||
(make-index-element
|
||||
|
|
@ -155,9 +158,10 @@
|
|||
|
||||
(define (index-section tag)
|
||||
(make-unnumbered-part
|
||||
tag
|
||||
(and tag (list tag))
|
||||
(list "Index")
|
||||
#f
|
||||
null
|
||||
(make-flow (list (make-delayed-flow-element
|
||||
(lambda (renderer sec ht)
|
||||
(let ([l null])
|
||||
|
|
@ -180,7 +184,14 @@
|
|||
[(string-ci=? (car a) (car b))
|
||||
(loop (cdr a) (cdr b))]
|
||||
[else
|
||||
(string-ci<? (car a) (car b))]))))])
|
||||
(string-ci<? (car a) (car b))]))))]
|
||||
[commas (lambda (l)
|
||||
(if (or (null? l)
|
||||
(null? (cdr l)))
|
||||
l
|
||||
(cdr (apply append (map (lambda (i)
|
||||
(list ", " i))
|
||||
l)))))])
|
||||
(make-table
|
||||
'index
|
||||
(map (lambda (i)
|
||||
|
|
@ -189,11 +200,12 @@
|
|||
(make-paragraph
|
||||
(list
|
||||
(make-link-element
|
||||
#f
|
||||
(caddr i)
|
||||
"indexlink"
|
||||
(commas (caddr i))
|
||||
(car i))))))))
|
||||
l))))))))
|
||||
null))
|
||||
null
|
||||
'index))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -19,7 +19,9 @@
|
|||
[part-start ([depth integer?]
|
||||
[tag (or/c false/c string?)]
|
||||
[title list?])]
|
||||
[splice ([run list?])])
|
||||
[splice ([run list?])]
|
||||
[section-index-decl ([plain-seq (listof string?)]
|
||||
[entry-seq list?])])
|
||||
|
||||
(define (decode-string s)
|
||||
(let loop ([l '((#rx"---" mdash)
|
||||
|
|
@ -49,15 +51,39 @@
|
|||
null
|
||||
(list (decode-paragraph (reverse (skip-whitespace accum))))))
|
||||
|
||||
(define (decode-flow* l tag style title part-depth)
|
||||
(let loop ([l l][next? #f][accum null][title title][tag tag][style style])
|
||||
(define (decode-flow* l keys tag style title part-depth)
|
||||
(let loop ([l l][next? #f][keys keys][accum null][title title][tag tag][style style])
|
||||
(cond
|
||||
[(null? l) (make-styled-part tag
|
||||
title
|
||||
#f
|
||||
(make-flow (decode-accum-para accum))
|
||||
null
|
||||
style)]
|
||||
[(null? l)
|
||||
(let ([tags (map (lambda (k)
|
||||
(format "secindex:~a:~a" (current-inexact-milliseconds) (gensym)))
|
||||
keys)]
|
||||
[tag (or tag (format "sec:~a:~a" (current-inexact-milliseconds) (gensym)))])
|
||||
(make-styled-part (cons tag
|
||||
tags)
|
||||
title
|
||||
#f
|
||||
(let ([l (map (lambda (k tag)
|
||||
(make-index-element
|
||||
#f
|
||||
null
|
||||
`(part ,tag)
|
||||
(section-index-decl-plain-seq k)
|
||||
(section-index-decl-entry-seq k)))
|
||||
keys tags)])
|
||||
(if title
|
||||
(cons (make-index-element
|
||||
#f
|
||||
null
|
||||
`(part ,tag)
|
||||
(list (regexp-replace #px"^(?:A|An|The)\\s" (content->string title)
|
||||
""))
|
||||
(list (make-element #f title)))
|
||||
l)
|
||||
l))
|
||||
(make-flow (decode-accum-para accum))
|
||||
null
|
||||
style))]
|
||||
[(title-decl? (car l))
|
||||
(unless part-depth
|
||||
(error 'decode
|
||||
|
|
@ -67,16 +93,17 @@
|
|||
(error 'decode
|
||||
"found extra title: ~v"
|
||||
(car l)))
|
||||
(loop (cdr l) next? accum
|
||||
(loop (cdr l) next? keys accum
|
||||
(title-decl-content (car l))
|
||||
(title-decl-tag (car l))
|
||||
(title-decl-style (car l)))]
|
||||
[(flow-element? (car l))
|
||||
(let ([para (decode-accum-para accum)]
|
||||
[part (decode-flow* (cdr l) tag style title part-depth)])
|
||||
(make-styled-part (part-tag part)
|
||||
[part (decode-flow* (cdr l) keys tag style title part-depth)])
|
||||
(make-styled-part (part-tags part)
|
||||
(part-title-content part)
|
||||
(part-collected-info part)
|
||||
(part-to-collect part)
|
||||
(make-flow (append para
|
||||
(list (car l))
|
||||
(flow-paragraphs (part-flow part))))
|
||||
|
|
@ -84,10 +111,11 @@
|
|||
(styled-part-style part)))]
|
||||
[(part? (car l))
|
||||
(let ([para (decode-accum-para accum)]
|
||||
[part (decode-flow* (cdr l) tag style title part-depth)])
|
||||
(make-styled-part (part-tag part)
|
||||
[part (decode-flow* (cdr l) keys tag style title part-depth)])
|
||||
(make-styled-part (part-tags part)
|
||||
(part-title-content part)
|
||||
(part-collected-info part)
|
||||
(part-to-collect part)
|
||||
(make-flow (append para
|
||||
(flow-paragraphs
|
||||
(part-flow part))))
|
||||
|
|
@ -112,41 +140,45 @@
|
|||
(part-start-tag s)
|
||||
(part-start-title s)
|
||||
(add1 part-depth))]
|
||||
[part (decode-flow* l tag style title part-depth)])
|
||||
(make-styled-part (part-tag part)
|
||||
[part (decode-flow* l keys tag style title part-depth)])
|
||||
(make-styled-part (part-tags part)
|
||||
(part-title-content part)
|
||||
(part-collected-info part)
|
||||
(part-to-collect part)
|
||||
(make-flow para)
|
||||
(cons s (part-parts part))
|
||||
(styled-part-style part)))
|
||||
(loop (cdr l) (cons (car l) s-accum)))))]
|
||||
[(splice? (car l))
|
||||
(loop (append (splice-run (car l)) (cdr l)) next? accum title tag style)]
|
||||
[(null? (cdr l)) (loop null #f (cons (car l) accum) title tag style)]
|
||||
(loop (append (splice-run (car l)) (cdr l)) next? keys accum title tag style)]
|
||||
[(null? (cdr l)) (loop null #f keys (cons (car l) accum) title tag style)]
|
||||
[(section-index-decl? (car l))
|
||||
(loop (cdr l) next? (cons (car l) keys) accum title tag style)]
|
||||
[(and (pair? (cdr l))
|
||||
(splice? (cadr l)))
|
||||
(loop (cons (car l) (append (splice-run (cadr l)) (cddr l))) next? accum title tag style)]
|
||||
(loop (cons (car l) (append (splice-run (cadr l)) (cddr l))) next? keys accum title tag style)]
|
||||
[(line-break? (car l))
|
||||
(if next?
|
||||
(loop (cdr l) #t accum title tag style)
|
||||
(loop (cdr l) #t keys accum title tag style)
|
||||
(let ([m (match-newline-whitespace (cdr l))])
|
||||
(if m
|
||||
(let ([part (loop m #t null title tag style)])
|
||||
(make-styled-part (part-tag part)
|
||||
(let ([part (loop m #t keys null title tag style)])
|
||||
(make-styled-part (part-tags part)
|
||||
(part-title-content part)
|
||||
(part-collected-info part)
|
||||
(part-to-collect part)
|
||||
(make-flow (append (decode-accum-para accum)
|
||||
(flow-paragraphs (part-flow part))))
|
||||
(part-parts part)
|
||||
(styled-part-style part)))
|
||||
(loop (cdr l) #f (cons (car l) accum) title tag style))))]
|
||||
[else (loop (cdr l) #f (cons (car l) accum) title tag style)])))
|
||||
(loop (cdr l) #f keys (cons (car l) accum) title tag style))))]
|
||||
[else (loop (cdr l) #f keys (cons (car l) accum) title tag style)])))
|
||||
|
||||
(define (decode-part l tag title depth)
|
||||
(decode-flow* l tag #f title depth))
|
||||
(decode-flow* l null tag #f title depth))
|
||||
|
||||
(define (decode-flow l)
|
||||
(part-flow (decode-flow* l #f #f #f #f)))
|
||||
(part-flow (decode-flow* l null #f #f #f #f)))
|
||||
|
||||
(define (match-newline-whitespace l)
|
||||
(cond
|
||||
|
|
|
|||
|
|
@ -19,6 +19,7 @@
|
|||
(define next-separate-page (make-parameter #f))
|
||||
(define collecting-sub (make-parameter 0))
|
||||
(define current-no-links (make-parameter #f))
|
||||
(define extra-breaking? (make-parameter #f))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; main mixin
|
||||
|
|
@ -49,18 +50,20 @@
|
|||
ht))
|
||||
|
||||
(define/public (part-whole-page? p ht)
|
||||
(let ([dest (lookup p ht `(part ,(part-tag p)))])
|
||||
(let ([dest (lookup p ht `(part ,(car (part-tags p))))])
|
||||
(caddr dest)))
|
||||
|
||||
(define/public (current-part-whole-page?)
|
||||
#f)
|
||||
|
||||
(define/override (collect-part-tag d ht number)
|
||||
(hash-table-put! ht
|
||||
`(part ,(part-tag d))
|
||||
(list (current-output-file)
|
||||
(part-title-content d)
|
||||
(current-part-whole-page?))))
|
||||
(define/override (collect-part-tags d ht number)
|
||||
(for-each (lambda (t)
|
||||
(hash-table-put! ht
|
||||
`(part ,t)
|
||||
(list (current-output-file)
|
||||
(part-title-content d)
|
||||
(current-part-whole-page?))))
|
||||
(part-tags d)))
|
||||
|
||||
(define/override (collect-target-element i ht)
|
||||
(hash-table-put! ht
|
||||
|
|
@ -93,7 +96,7 @@
|
|||
,@(format-number (collected-info-number (part-collected-info p))
|
||||
'((tt nbsp))))
|
||||
(td
|
||||
(a ((href ,(let ([dest (lookup p ht `(part ,(part-tag p)))])
|
||||
(a ((href ,(let ([dest (lookup p ht `(part ,(car (part-tags p))))])
|
||||
(format "~a~a~a"
|
||||
(from-root (car dest)
|
||||
(get-dest-directory))
|
||||
|
|
@ -102,7 +105,7 @@
|
|||
"#")
|
||||
(if (caddr dest)
|
||||
""
|
||||
`(part ,(part-tag p))))))
|
||||
`(part ,(car (part-tags p)))))))
|
||||
(class ,(if (eq? p mine)
|
||||
"tocviewselflink"
|
||||
"tocviewlink")))
|
||||
|
|
@ -167,7 +170,8 @@
|
|||
((class "tocsublist")
|
||||
(cellspacing "0"))
|
||||
,@(map (lambda (p)
|
||||
(parameterize ([current-no-links #t])
|
||||
(parameterize ([current-no-links #t]
|
||||
[extra-breaking? #t])
|
||||
`(tr
|
||||
(td
|
||||
,@(if (part? p)
|
||||
|
|
@ -176,9 +180,9 @@
|
|||
'((tt nbsp)))))
|
||||
'(""))
|
||||
(a ((href ,(if (part? p)
|
||||
(let ([dest (lookup p ht `(part ,(part-tag p)))])
|
||||
(let ([dest (lookup p ht `(part ,(car (part-tags p))))])
|
||||
(format "#~a"
|
||||
`(part ,(part-tag p))))
|
||||
`(part ,(car (part-tags p)))))
|
||||
(format "#~a" (target-element-tag p))))
|
||||
(class ,(if (part? p)
|
||||
"tocsubseclink"
|
||||
|
|
@ -221,9 +225,9 @@
|
|||
[(2) 'h4]
|
||||
[else 'h5])
|
||||
,@(format-number number '((tt nbsp)))
|
||||
,@(if (part-tag d)
|
||||
`((a ((name ,(format "~a" `(part ,(part-tag d)))))))
|
||||
null)
|
||||
,@(map (lambda (t)
|
||||
`(a ((name ,(format "~a" `(part ,t))))))
|
||||
(part-tags d))
|
||||
,@(if (part-title-content d)
|
||||
(render-content (part-title-content d) d ht)
|
||||
null))))
|
||||
|
|
@ -399,7 +403,13 @@
|
|||
|
||||
(define/override (render-other i part ht)
|
||||
(cond
|
||||
[(string? i) (list i)]
|
||||
[(string? i) (let ([m (and (extra-breaking?)
|
||||
(regexp-match-positions #rx":" i))])
|
||||
(if m
|
||||
(list* (substring i 0 (cdar m))
|
||||
`(span ((class "mywbr")) " ")
|
||||
(render-other (substring i (cdar m)) part ht))
|
||||
(list i)))]
|
||||
[(eq? i 'mdash) `(" " ndash " ")]
|
||||
[(eq? i 'hline) `((hr))]
|
||||
[(symbol? i) (list i)]
|
||||
|
|
@ -428,9 +438,7 @@
|
|||
(define/private (derive-filename d ht)
|
||||
(let ([fn (format "~a.html" (regexp-replace*
|
||||
"[^-a-zA-Z0-9_=]"
|
||||
(or (format "~a" (part-tag d))
|
||||
(content->string (part-title-content d)
|
||||
this d ht))
|
||||
(format "~a" (car (part-tags d)))
|
||||
"_"))])
|
||||
(when ((string-length fn) . >= . 48)
|
||||
(error "file name too long (need a tag):" fn))
|
||||
|
|
@ -560,7 +568,7 @@
|
|||
(make-link-element
|
||||
#f
|
||||
index-content
|
||||
`(part ,(part-tag index)))))))))
|
||||
`(part ,(car (part-tags index))))))))))
|
||||
null))))
|
||||
d ht)
|
||||
,@(render-table (make-table
|
||||
|
|
|
|||
|
|
@ -6,6 +6,7 @@
|
|||
|
||||
(define current-table-mode (make-parameter #f))
|
||||
(define rendering-tt (make-parameter #f))
|
||||
(define show-link-page-numbers (make-parameter #f))
|
||||
|
||||
(define-struct (toc-paragraph paragraph) ())
|
||||
|
||||
|
|
@ -69,8 +70,9 @@
|
|||
(printf "\\newcommand{\\schemeinput}[1]{\\colorbox{LightGray}{\\hspace{-0.5ex}\\schemeinputbg{#1}\\hspace{-0.5ex}}}\n")
|
||||
(printf "\\newcommand{\\highlighted}[1]{\\colorbox{PaleBlue}{\\hspace{-0.5ex}\\schemeinputbg{#1}\\hspace{-0.5ex}}}\n")
|
||||
(printf "\\newcommand{\\techlink}[1]{#1}\n")
|
||||
(printf "\\newcommand{\\indexlink}[1]{#1}\n")
|
||||
(printf "\\newcommand{\\imageleft}[1]{} % drop it\n")
|
||||
(printf "\\begin{document}\n")
|
||||
(printf "\\begin{document}\n\\sloppy\n")
|
||||
(when (part-title-content d)
|
||||
(printf "\\title{")
|
||||
(render-content (part-title-content d) d ht)
|
||||
|
|
@ -82,6 +84,9 @@
|
|||
(let ([number (collected-info-number (part-collected-info d))])
|
||||
(when (and (part-title-content d)
|
||||
(pair? number))
|
||||
(when (and (styled-part? d)
|
||||
(eq? 'index (styled-part-style d)))
|
||||
(printf "\\twocolumn\n\\parskip=0pt\n\\addcontentsline{toc}{section}{Index}\n"))
|
||||
(printf "\\~a~a{"
|
||||
(case (length number)
|
||||
[(0 1) "newpage\n\n\\section"]
|
||||
|
|
@ -93,10 +98,13 @@
|
|||
"*"
|
||||
""))
|
||||
(render-content (part-title-content d) d ht)
|
||||
(printf "}"))
|
||||
#;
|
||||
(when (part-tag d)
|
||||
(printf "\\label{section:~a}" (protect-tag (part-tag d))))
|
||||
(printf "}")
|
||||
(when (and (styled-part? d)
|
||||
(eq? 'index (styled-part-style d)))
|
||||
(printf "\n\n")))
|
||||
(for-each (lambda (t)
|
||||
(printf "\\label{t:~a}" (t-encode `(part ,t))))
|
||||
(part-tags d))
|
||||
(render-flow (part-flow d) d ht)
|
||||
(for-each (lambda (sec) (render-part sec ht))
|
||||
(part-parts d))
|
||||
|
|
@ -121,48 +129,68 @@
|
|||
(pair? (link-element-tag e))
|
||||
(eq? 'part (car (link-element-tag e)))
|
||||
(null? (element-content e)))])
|
||||
(parameterize ([show-link-page-numbers #f])
|
||||
(when (target-element? e)
|
||||
(printf "\\label{t:~a}" (t-encode (target-element-tag e))))
|
||||
(when part-label?
|
||||
(printf "\\S")
|
||||
(render-content (let ([dest (lookup part ht (link-element-tag e))])
|
||||
(if dest
|
||||
(format-number (cadr dest) null)
|
||||
(list "???")))
|
||||
part
|
||||
ht)
|
||||
(printf " ``"))
|
||||
(let ([style (and (element? e)
|
||||
(element-style e))]
|
||||
[wrap (lambda (e s tt?)
|
||||
(printf "{\\~a{" s)
|
||||
(parameterize ([rendering-tt (or tt?
|
||||
(rendering-tt))])
|
||||
(super render-element e part ht))
|
||||
(printf "}}"))])
|
||||
(cond
|
||||
[(symbol? style)
|
||||
(case style
|
||||
[(italic) (wrap e "textit" #f)]
|
||||
[(bold) (wrap e "textbf" #f)]
|
||||
[(tt) (wrap e "mytexttt" #t)]
|
||||
[(sf) (wrap e "textsf" #f)]
|
||||
[(subscript) (wrap e "textsub" #f)]
|
||||
[(superscript) (wrap e "textsuper" #f)]
|
||||
[(hspace) (let ([s (content->string (element-content e))])
|
||||
(case (string-length s)
|
||||
[(0) (void)]
|
||||
[else
|
||||
(printf "{\\mytexttt{~a}}"
|
||||
(regexp-replace* #rx"." s "~"))]))]
|
||||
[else (error 'latex-render "unrecognzied style symbol: ~s" style)])]
|
||||
[(string? style)
|
||||
(wrap e style (regexp-match? #px"^scheme(?!error)" style))]
|
||||
[(image-file? style)
|
||||
(let ([fn (install-file (image-file-path style))])
|
||||
(printf "\\includegraphics{~a}" fn))]
|
||||
[else (super render-element e part ht)])))
|
||||
(when part-label?
|
||||
(printf "\\S")
|
||||
(render-content (let ([dest (lookup part ht (link-element-tag e))])
|
||||
(if dest
|
||||
(format-number (cadr dest) null)
|
||||
(list "???")))
|
||||
part
|
||||
ht)
|
||||
(printf " ``"))
|
||||
(let ([style (and (element? e)
|
||||
(element-style e))]
|
||||
[wrap (lambda (e s tt?)
|
||||
(printf "{\\~a{" s)
|
||||
(parameterize ([rendering-tt (or tt?
|
||||
(rendering-tt))])
|
||||
(super render-element e part ht))
|
||||
(printf "}}"))])
|
||||
(cond
|
||||
[(symbol? style)
|
||||
(case style
|
||||
[(italic) (wrap e "textit" #f)]
|
||||
[(bold) (wrap e "textbf" #f)]
|
||||
[(tt) (wrap e "mytexttt" #t)]
|
||||
[(sf) (wrap e "textsf" #f)]
|
||||
[(subscript) (wrap e "textsub" #f)]
|
||||
[(superscript) (wrap e "textsuper" #f)]
|
||||
[(hspace) (let ([s (content->string (element-content e))])
|
||||
(case (string-length s)
|
||||
[(0) (void)]
|
||||
[else
|
||||
(printf "{\\mytexttt{~a}}"
|
||||
(regexp-replace* #rx"." s "~"))]))]
|
||||
[else (error 'latex-render "unrecognzied style symbol: ~s" style)])]
|
||||
[(string? style)
|
||||
(wrap e style (regexp-match? #px"^scheme(?!error)" style))]
|
||||
[(image-file? style)
|
||||
(let ([fn (install-file (image-file-path style))])
|
||||
(printf "\\includegraphics{~a}" fn))]
|
||||
[else (super render-element e part ht)]))
|
||||
(when part-label?
|
||||
(printf "''")))
|
||||
null)
|
||||
(printf "''"))
|
||||
(when (and (link-element? e)
|
||||
(show-link-page-numbers))
|
||||
(printf ", \\pageref{t:~a}" (t-encode (link-element-tag e))))
|
||||
null))
|
||||
|
||||
(define/private (t-encode s)
|
||||
(apply
|
||||
string-append
|
||||
(map (lambda (c)
|
||||
(cond
|
||||
[(and (or (char-alphabetic? c)
|
||||
(char-numeric? c))
|
||||
((char->integer c) . < . 128))
|
||||
(string c)]
|
||||
[(char=? c #\space) "_"]
|
||||
[else
|
||||
(format "x~x" (char->integer c))]))
|
||||
(string->list (format "~s" s)))))
|
||||
|
||||
(define/override (render-table t part ht)
|
||||
(let* ([boxed? (eq? 'boxed (table-style t))]
|
||||
|
|
@ -176,7 +204,7 @@
|
|||
(equal? "longtable" (car m))
|
||||
(= 1 (length (car (table-flowss (cadr m))))))))]
|
||||
[tableform (cond
|
||||
[index? "theindex"]
|
||||
[index? "list"]
|
||||
[(not (current-table-mode))
|
||||
"longtable"]
|
||||
[else "tabular"])]
|
||||
|
|
@ -188,10 +216,11 @@
|
|||
(null? (car (table-flowss t))))
|
||||
(parameterize ([current-table-mode (if inline?
|
||||
(current-table-mode)
|
||||
(list tableform t))])
|
||||
(list tableform t))]
|
||||
[show-link-page-numbers (or index?
|
||||
(show-link-page-numbers))])
|
||||
(cond
|
||||
[index?
|
||||
(printf "\n\n\\begin{theindex}\n")]
|
||||
[index? (printf "\\begin{list}{}{\\parsep=0pt \\itemsep=1pt \\leftmargin=2ex \\itemindent=-2ex}\n")]
|
||||
[inline? (void)]
|
||||
[else
|
||||
(printf "\n\n~a\\begin{~a}~a{@{}~a}\n"
|
||||
|
|
@ -223,6 +252,8 @@
|
|||
[row-style (car row-styles)])
|
||||
(let loop ([flows flows])
|
||||
(unless (null? flows)
|
||||
(when index?
|
||||
(printf "\\item "))
|
||||
(unless (eq? 'cont (car flows))
|
||||
(let ([cnt (let loop ([flows (cdr flows)][n 1])
|
||||
(cond
|
||||
|
|
|
|||
|
|
@ -88,11 +88,23 @@
|
|||
(make-element 'tt (list (substring s spaces))))))))))
|
||||
strs))))
|
||||
|
||||
(define-syntax indexed-scheme
|
||||
(syntax-rules ()
|
||||
[(_ x) (add-scheme-index 'x (scheme x))]))
|
||||
|
||||
(define (add-scheme-index s e)
|
||||
(let ([k (if (and (pair? s)
|
||||
(eq? (car s) 'quote))
|
||||
(cadr s)
|
||||
s)])
|
||||
(index* (list (format "~s" k)) (list e) e)))
|
||||
|
||||
(provide schemeblock SCHEMEBLOCK
|
||||
schemeblock0 SCHEMEBLOCK0
|
||||
schemeinput
|
||||
schememod
|
||||
scheme schemeresult schemeid schememodname
|
||||
indexed-scheme
|
||||
litchar
|
||||
verbatim)
|
||||
|
||||
|
|
@ -100,6 +112,7 @@
|
|||
schemefont schemevalfont schemeresultfont schemeidfont
|
||||
schemeparenfont schemekeywordfont schememetafont schememodfont
|
||||
file exec envvar Flag DFlag
|
||||
indexed-file indexed-envvar
|
||||
link procedure
|
||||
idefterm)
|
||||
|
||||
|
|
@ -130,6 +143,10 @@
|
|||
(make-element "schemekeyword" (decode-content str)))
|
||||
(define (file . str)
|
||||
(make-element 'tt (append (list "\"") (decode-content str) (list "\""))))
|
||||
(define (indexed-file . str)
|
||||
(let* ([f (apply file str)]
|
||||
[s (element->string f)])
|
||||
(index* (list (substring s 1 (sub1 (string-length s)))) (list f) f)))
|
||||
(define (exec . str)
|
||||
(make-element 'tt (decode-content str)))
|
||||
(define (Flag . str)
|
||||
|
|
@ -138,6 +155,10 @@
|
|||
(make-element 'tt (cons "--" (decode-content str))))
|
||||
(define (envvar . str)
|
||||
(make-element 'tt (decode-content str)))
|
||||
(define (indexed-envvar . str)
|
||||
(let* ([f (apply envvar str)]
|
||||
[s (element->string f)])
|
||||
(index* (list s) (list f) f)))
|
||||
(define (procedure . str)
|
||||
(make-element "schemeresult" (append (list "#<procedure:") (decode-content str) (list ">"))))
|
||||
|
||||
|
|
@ -183,7 +204,13 @@
|
|||
(format "tech-term:~a" s))))
|
||||
|
||||
(define (deftech . s)
|
||||
(*tech make-target-element #f (list (apply defterm s))))
|
||||
(let* ([e (apply defterm s)]
|
||||
[t (*tech make-target-element #f (list e))])
|
||||
(make-index-element #f
|
||||
(list t)
|
||||
(target-element-tag t)
|
||||
(list (element->string e))
|
||||
(list e))))
|
||||
|
||||
(define (tech . s)
|
||||
(*tech make-link-element "techlink" s))
|
||||
|
|
@ -487,11 +514,17 @@
|
|||
(loop (cdr a) (cons (car a) o-accum)))))
|
||||
(loop (cdr a) (cons (car a) r-accum))))]
|
||||
[(tagged) (if first?
|
||||
(make-toc-target-element
|
||||
#f
|
||||
(list (to-element (make-just-context (car prototype)
|
||||
stx-id)))
|
||||
(register-scheme-definition stx-id))
|
||||
(let ([tag (register-scheme-definition stx-id)]
|
||||
[content (list (to-element (make-just-context (car prototype)
|
||||
stx-id)))])
|
||||
(make-toc-target-element
|
||||
#f
|
||||
(list (make-index-element #f
|
||||
content
|
||||
tag
|
||||
(list (symbol->string (car prototype)))
|
||||
content))
|
||||
tag))
|
||||
(to-element (make-just-context (car prototype)
|
||||
stx-id)))]
|
||||
[(flat-size) (prototype-size prototype + +)]
|
||||
|
|
@ -667,14 +700,23 @@
|
|||
(make-target-element*
|
||||
make-target-element
|
||||
stx-id
|
||||
(inner-make-target-element
|
||||
#f
|
||||
(list content)
|
||||
(register-scheme-definition
|
||||
(datum->syntax-object stx-id
|
||||
(string->symbol
|
||||
(apply string-append
|
||||
(map symbol->string (car wrappers)))))))
|
||||
(let* ([name
|
||||
(apply string-append
|
||||
(map symbol->string (car wrappers)))]
|
||||
[tag
|
||||
(register-scheme-definition
|
||||
(datum->syntax-object stx-id
|
||||
(string->symbol
|
||||
name)))])
|
||||
(inner-make-target-element
|
||||
#f
|
||||
(list
|
||||
(make-index-element #f
|
||||
(list content)
|
||||
tag
|
||||
(list name)
|
||||
(list (schemeidfont (make-element "schemevaluelink" (list name))))))
|
||||
tag))
|
||||
(cdr wrappers))))
|
||||
|
||||
(define (*defstruct stx-id name fields field-contracts immutable? transparent? content-thunk)
|
||||
|
|
@ -841,10 +883,16 @@
|
|||
(list (make-flow
|
||||
(list
|
||||
(make-paragraph
|
||||
(list (make-toc-target-element
|
||||
#f
|
||||
(list (to-element (make-just-context name stx-id)))
|
||||
(register-scheme-definition stx-id))
|
||||
(list (let ([tag (register-scheme-definition stx-id)]
|
||||
[content (list (to-element (make-just-context name stx-id)))])
|
||||
(make-toc-target-element
|
||||
#f
|
||||
(list (make-index-element #f
|
||||
content
|
||||
tag
|
||||
(list (symbol->string name))
|
||||
content))
|
||||
tag))
|
||||
spacer ":" spacer
|
||||
(to-element result-contract))))))))
|
||||
(content-thunk))))
|
||||
|
|
@ -890,13 +938,21 @@
|
|||
. ,(cdr form)))))))
|
||||
(and kw-id
|
||||
(eq? form (car forms))
|
||||
(make-toc-target-element
|
||||
#f
|
||||
(list (to-element (make-just-context (if (pair? form)
|
||||
(car form)
|
||||
form)
|
||||
kw-id)))
|
||||
(register-scheme-form-definition kw-id))))))))
|
||||
(let ([tag (register-scheme-form-definition kw-id)]
|
||||
[content (list (to-element (make-just-context (if (pair? form)
|
||||
(car form)
|
||||
form)
|
||||
kw-id)))])
|
||||
(make-toc-target-element
|
||||
#f
|
||||
(if kw-id
|
||||
(list (make-index-element #f
|
||||
content
|
||||
tag
|
||||
(list (symbol->string (syntax-e kw-id)))
|
||||
content))
|
||||
content)
|
||||
tag))))))))
|
||||
forms form-procs)
|
||||
(if (null? sub-procs)
|
||||
null
|
||||
|
|
|
|||
|
|
@ -388,6 +388,7 @@
|
|||
[vd
|
||||
(make-link-element "schemevaluelink" (list s) vtag)]
|
||||
[else s]))))
|
||||
(lambda () s)
|
||||
(lambda () s))
|
||||
(literalize-spaces s))
|
||||
(cond
|
||||
|
|
|
|||
|
|
@ -118,6 +118,10 @@
|
|||
font-weight: bold;
|
||||
}
|
||||
|
||||
.indexlink {
|
||||
text-decoration: none;
|
||||
}
|
||||
|
||||
.title {
|
||||
font-size: 200%;
|
||||
font-weight: normal;
|
||||
|
|
@ -405,3 +409,8 @@
|
|||
.colophon a {
|
||||
color: gray;
|
||||
}
|
||||
|
||||
.mywbr {
|
||||
width: 0;
|
||||
font-size: 1px;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -52,13 +52,14 @@
|
|||
(delayed-flow-element? p)))
|
||||
|
||||
(provide-structs
|
||||
[part ([tag (or/c false/c tag?)]
|
||||
[part ([tags (listof tag?)]
|
||||
[title-content (or/c false/c list?)]
|
||||
[collected-info (or/c false/c collected-info?)]
|
||||
[to-collect list?]
|
||||
[flow flow?]
|
||||
[parts (listof part?)])]
|
||||
[(styled-part part) ([style any/c])]
|
||||
[(unnumbered-part part) ()]
|
||||
[(unnumbered-part styled-part) ()]
|
||||
[flow ([paragraphs (listof flow-element?)])]
|
||||
[paragraph ([content list?])]
|
||||
[(styled-paragraph paragraph) ([style any/c])]
|
||||
|
|
@ -96,48 +97,54 @@
|
|||
delayed-element-ref
|
||||
delayed-element-set!)
|
||||
(make-struct-type 'delayed-element #f
|
||||
2 1 #f
|
||||
3 1 #f
|
||||
(list (cons prop:serializable
|
||||
(make-serialize-info
|
||||
(lambda (d)
|
||||
(unless (delayed-element-ref d 2)
|
||||
(unless (delayed-element-ref d 3)
|
||||
(error 'serialize-delayed-element
|
||||
"cannot serialize a delayed element that was not resolved: ~e"
|
||||
d))
|
||||
(vector (delayed-element-ref d 2)))
|
||||
(vector (delayed-element-ref d 3)))
|
||||
#'deserialize-delayed-element
|
||||
#f
|
||||
(or (current-load-relative-directory) (current-directory)))))))
|
||||
(define-syntax delayed-element (list-immutable #'struct:delayed-element
|
||||
#'make-delayed-element
|
||||
#'delayed-element?
|
||||
(list-immutable #'delayed-element-sizer
|
||||
(list-immutable #'delayed-element-plain
|
||||
#'delayed-element-sizer
|
||||
#'delayed-element-render)
|
||||
(list-immutable #'set-delayed-element-sizer!
|
||||
(list-immutable #'set-delayed-element-plain!
|
||||
#'set-delayed-element-sizer!
|
||||
#'set-delayed-element-render!)
|
||||
#t))
|
||||
(define delayed-element-render (make-struct-field-accessor delayed-element-ref 0))
|
||||
(define delayed-element-sizer (make-struct-field-accessor delayed-element-ref 1))
|
||||
(define delayed-element-plain (make-struct-field-accessor delayed-element-ref 2))
|
||||
(define set-delayed-element-render! (make-struct-field-mutator delayed-element-set! 0))
|
||||
(define set-delayed-element-sizer! (make-struct-field-mutator delayed-element-set! 1))
|
||||
(define set-delayed-element-plain! (make-struct-field-mutator delayed-element-set! 2))
|
||||
(provide/contract
|
||||
(struct delayed-element ([render (any/c part? any/c . -> . list?)]
|
||||
[sizer (-> any)])))
|
||||
|
||||
[sizer (-> any)]
|
||||
[plain (-> any)])))
|
||||
|
||||
(provide deserialize-delayed-element)
|
||||
(define deserialize-delayed-element
|
||||
(make-deserialize-info values values))
|
||||
|
||||
(provide force-delayed-element)
|
||||
(define (force-delayed-element d renderer sec ht)
|
||||
(or (delayed-element-ref d 2)
|
||||
(or (delayed-element-ref d 3)
|
||||
(let ([v ((delayed-element-ref d 0) renderer sec ht)])
|
||||
(delayed-element-set! d 2 v)
|
||||
(delayed-element-set! d 3 v)
|
||||
v)))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(provide content->string)
|
||||
(provide content->string
|
||||
element->string)
|
||||
|
||||
(define content->string
|
||||
(case-lambda
|
||||
|
|
@ -154,6 +161,7 @@
|
|||
[(c)
|
||||
(cond
|
||||
[(element? c) (content->string (element-content c))]
|
||||
[(delayed-element? c) (element->string ((delayed-element-plain c)))]
|
||||
[(string? c) c]
|
||||
[else (case c
|
||||
[(ndash) "--"]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user