suzanne.soy/scribble-enhanced
1
0
Fork 0
Code Issues 1 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

improve scribble index support

Browse Source 
svn: r7047

original commit: ab9c34a8ecdff19c469d167a16f44f1863f546f3
This commit is contained in:
Matthew Flatt 2007-08-07 20:39:54 +00:00
parent c0f03edcee
commit f7803f005e
9 changed files with 304 additions and 145 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/scribble/base-render.ss
View File

@ -69,8 +69,8 @@
(let ([p-ht (make-hash-table 'equal)]) (let ([p-ht (make-hash-table 'equal)])
(when (part-title-content d) (when (part-title-content d)
(collect-content (part-title-content d) p-ht)) (collect-content (part-title-content d) p-ht))
(when (part-tag d) (collect-part-tags d p-ht number)
(collect-part-tag d p-ht number)) (collect-content (part-to-collect d) p-ht)
(collect-flow (part-flow d) p-ht) (collect-flow (part-flow d) p-ht)
(let loop ([parts (part-parts d)] (let loop ([parts (part-parts d)]
[pos 1]) [pos 1])
@ -91,8 +91,10 @@
(lambda (k v) (lambda (k v)
(hash-table-put! ht k v))))) (hash-table-put! ht k v)))))
(define/public (collect-part-tag d ht number) (define/public (collect-part-tags d ht number)
(hash-table-put! ht `(part ,(part-tag d)) (list (part-title-content d) 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) (define/public (collect-content c ht)
(for-each (lambda (i) (for-each (lambda (i)
@ -316,7 +318,7 @@
(list (list
(make-element 'hspace '(" ")))) (make-element 'hspace '(" "))))
(part-title-content part)) (part-title-content part))
`(part ,(part-tag part)))))))) `(part ,(car (part-tags part)))))))))
subs)]) subs)])
(if (and (= 1 (length number)) (if (and (= 1 (length number))
(or (not (car number)) (or (not (car number))

26
collects/scribble/basic.ss
View File

@ -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) (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) (define (record-index word-seq element-seq tag content)
(make-index-element (make-index-element
@ -155,9 +158,10 @@
(define (index-section tag) (define (index-section tag)
(make-unnumbered-part (make-unnumbered-part
tag (and tag (list tag))
(list "Index") (list "Index")
#f #f
null
(make-flow (list (make-delayed-flow-element (make-flow (list (make-delayed-flow-element
(lambda (renderer sec ht) (lambda (renderer sec ht)
(let ([l null]) (let ([l null])
@ -180,7 +184,14 @@
[(string-ci=? (car a) (car b)) [(string-ci=? (car a) (car b))
(loop (cdr a) (cdr b))] (loop (cdr a) (cdr b))]
[else [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 (make-table
'index 'index
(map (lambda (i) (map (lambda (i)
@ -189,11 +200,12 @@
(make-paragraph (make-paragraph
(list (list
(make-link-element (make-link-element
#f "indexlink"
(caddr i) (commas (caddr i))
(car i)))))))) (car i))))))))
l)))))))) l))))))))
null)) null
'index))
;; ---------------------------------------- ;; ----------------------------------------

84
collects/scribble/decode.ss
View File

@ -19,7 +19,9 @@
[part-start ([depth integer?] [part-start ([depth integer?]
[tag (or/c false/c string?)] [tag (or/c false/c string?)]
[title list?])] [title list?])]
[splice ([run list?])]) [splice ([run list?])]
[section-index-decl ([plain-seq (listof string?)]
[entry-seq list?])])
(define (decode-string s) (define (decode-string s)
(let loop ([l '((#rx"---" mdash) (let loop ([l '((#rx"---" mdash)
@ -49,15 +51,39 @@
null null
(list (decode-paragraph (reverse (skip-whitespace accum)))))) (list (decode-paragraph (reverse (skip-whitespace accum))))))
(define (decode-flow* l tag style title part-depth) (define (decode-flow* l keys tag style title part-depth)
(let loop ([l l][next? #f][accum null][title title][tag tag][style style]) (let loop ([l l][next? #f][keys keys][accum null][title title][tag tag][style style])
(cond (cond
[(null? l) (make-styled-part tag [(null? l)
title (let ([tags (map (lambda (k)
#f (format "secindex:~a:~a" (current-inexact-milliseconds) (gensym)))
(make-flow (decode-accum-para accum)) keys)]
null [tag (or tag (format "sec:~a:~a" (current-inexact-milliseconds) (gensym)))])
style)] (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)) [(title-decl? (car l))
(unless part-depth (unless part-depth
(error 'decode (error 'decode
@ -67,16 +93,17 @@
(error 'decode (error 'decode
"found extra title: ~v" "found extra title: ~v"
(car l))) (car l)))
(loop (cdr l) next? accum (loop (cdr l) next? keys accum
(title-decl-content (car l)) (title-decl-content (car l))
(title-decl-tag (car l)) (title-decl-tag (car l))
(title-decl-style (car l)))] (title-decl-style (car l)))]
[(flow-element? (car l)) [(flow-element? (car l))
(let ([para (decode-accum-para accum)] (let ([para (decode-accum-para accum)]
[part (decode-flow* (cdr l) tag style title part-depth)]) [part (decode-flow* (cdr l) keys tag style title part-depth)])
(make-styled-part (part-tag part) (make-styled-part (part-tags part)
(part-title-content part) (part-title-content part)
(part-collected-info part) (part-collected-info part)
(part-to-collect part)
(make-flow (append para (make-flow (append para
(list (car l)) (list (car l))
(flow-paragraphs (part-flow part)))) (flow-paragraphs (part-flow part))))
@ -84,10 +111,11 @@
(styled-part-style part)))] (styled-part-style part)))]
[(part? (car l)) [(part? (car l))
(let ([para (decode-accum-para accum)] (let ([para (decode-accum-para accum)]
[part (decode-flow* (cdr l) tag style title part-depth)]) [part (decode-flow* (cdr l) keys tag style title part-depth)])
(make-styled-part (part-tag part) (make-styled-part (part-tags part)
(part-title-content part) (part-title-content part)
(part-collected-info part) (part-collected-info part)
(part-to-collect part)
(make-flow (append para (make-flow (append para
(flow-paragraphs (flow-paragraphs
(part-flow part)))) (part-flow part))))
@ -112,41 +140,45 @@
(part-start-tag s) (part-start-tag s)
(part-start-title s) (part-start-title s)
(add1 part-depth))] (add1 part-depth))]
[part (decode-flow* l tag style title part-depth)]) [part (decode-flow* l keys tag style title part-depth)])
(make-styled-part (part-tag part) (make-styled-part (part-tags part)
(part-title-content part) (part-title-content part)
(part-collected-info part) (part-collected-info part)
(part-to-collect part)
(make-flow para) (make-flow para)
(cons s (part-parts part)) (cons s (part-parts part))
(styled-part-style part))) (styled-part-style part)))
(loop (cdr l) (cons (car l) s-accum)))))] (loop (cdr l) (cons (car l) s-accum)))))]
[(splice? (car l)) [(splice? (car l))
(loop (append (splice-run (car l)) (cdr l)) next? accum title tag style)] (loop (append (splice-run (car l)) (cdr l)) next? keys accum title tag style)]
[(null? (cdr l)) (loop null #f (cons (car l) 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)) [(and (pair? (cdr l))
(splice? (cadr 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)) [(line-break? (car l))
(if next? (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))]) (let ([m (match-newline-whitespace (cdr l))])
(if m (if m
(let ([part (loop m #t null title tag style)]) (let ([part (loop m #t keys null title tag style)])
(make-styled-part (part-tag part) (make-styled-part (part-tags part)
(part-title-content part) (part-title-content part)
(part-collected-info part) (part-collected-info part)
(part-to-collect part)
(make-flow (append (decode-accum-para accum) (make-flow (append (decode-accum-para accum)
(flow-paragraphs (part-flow part)))) (flow-paragraphs (part-flow part))))
(part-parts part) (part-parts part)
(styled-part-style part))) (styled-part-style part)))
(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 (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) (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) (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) (define (match-newline-whitespace l)
(cond (cond

48
collects/scribble/html-render.ss
View File

@ -19,6 +19,7 @@
(define next-separate-page (make-parameter #f)) (define next-separate-page (make-parameter #f))
(define collecting-sub (make-parameter 0)) (define collecting-sub (make-parameter 0))
(define current-no-links (make-parameter #f)) (define current-no-links (make-parameter #f))
(define extra-breaking? (make-parameter #f))
;; ---------------------------------------- ;; ----------------------------------------
;; main mixin ;; main mixin
@ -49,18 +50,20 @@
ht)) ht))
(define/public (part-whole-page? p 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))) (caddr dest)))
(define/public (current-part-whole-page?) (define/public (current-part-whole-page?)
#f) #f)
(define/override (collect-part-tag d ht number) (define/override (collect-part-tags d ht number)
(hash-table-put! ht (for-each (lambda (t)
`(part ,(part-tag d)) (hash-table-put! ht
(list (current-output-file) `(part ,t)
(part-title-content d) (list (current-output-file)
(current-part-whole-page?)))) (part-title-content d)
(current-part-whole-page?))))
(part-tags d)))
(define/override (collect-target-element i ht) (define/override (collect-target-element i ht)
(hash-table-put! ht (hash-table-put! ht
@ -93,7 +96,7 @@
,@(format-number (collected-info-number (part-collected-info p)) ,@(format-number (collected-info-number (part-collected-info p))
'((tt nbsp)))) '((tt nbsp))))
(td (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" (format "~a~a~a"
(from-root (car dest) (from-root (car dest)
(get-dest-directory)) (get-dest-directory))
@ -102,7 +105,7 @@
"#") "#")
(if (caddr dest) (if (caddr dest)
"" ""
`(part ,(part-tag p)))))) `(part ,(car (part-tags p)))))))
(class ,(if (eq? p mine) (class ,(if (eq? p mine)
"tocviewselflink" "tocviewselflink"
"tocviewlink"))) "tocviewlink")))
@ -167,7 +170,8 @@
((class "tocsublist") ((class "tocsublist")
(cellspacing "0")) (cellspacing "0"))
,@(map (lambda (p) ,@(map (lambda (p)
(parameterize ([current-no-links #t]) (parameterize ([current-no-links #t]
[extra-breaking? #t])
`(tr `(tr
(td (td
,@(if (part? p) ,@(if (part? p)
@ -176,9 +180,9 @@
'((tt nbsp))))) '((tt nbsp)))))
'("")) '(""))
(a ((href ,(if (part? p) (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" (format "#~a"
`(part ,(part-tag p)))) `(part ,(car (part-tags p)))))
(format "#~a" (target-element-tag p)))) (format "#~a" (target-element-tag p))))
(class ,(if (part? p) (class ,(if (part? p)
"tocsubseclink" "tocsubseclink"
@ -221,9 +225,9 @@
[(2) 'h4] [(2) 'h4]
[else 'h5]) [else 'h5])
,@(format-number number '((tt nbsp))) ,@(format-number number '((tt nbsp)))
,@(if (part-tag d) ,@(map (lambda (t)
`((a ((name ,(format "~a" `(part ,(part-tag d))))))) `(a ((name ,(format "~a" `(part ,t))))))
null) (part-tags d))
,@(if (part-title-content d) ,@(if (part-title-content d)
(render-content (part-title-content d) d ht) (render-content (part-title-content d) d ht)
null)))) null))))
@ -399,7 +403,13 @@
(define/override (render-other i part ht) (define/override (render-other i part ht)
(cond (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 'mdash) `(" " ndash " ")]
[(eq? i 'hline) `((hr))] [(eq? i 'hline) `((hr))]
[(symbol? i) (list i)] [(symbol? i) (list i)]
@ -428,9 +438,7 @@
(define/private (derive-filename d ht) (define/private (derive-filename d ht)
(let ([fn (format "~a.html" (regexp-replace* (let ([fn (format "~a.html" (regexp-replace*
"[^-a-zA-Z0-9_=]" "[^-a-zA-Z0-9_=]"
(or (format "~a" (part-tag d)) (format "~a" (car (part-tags d)))
(content->string (part-title-content d)
this d ht))
"_"))]) "_"))])
(when ((string-length fn) . >= . 48) (when ((string-length fn) . >= . 48)
(error "file name too long (need a tag):" fn)) (error "file name too long (need a tag):" fn))
@ -560,7 +568,7 @@
(make-link-element (make-link-element
#f #f
index-content index-content
`(part ,(part-tag index))))))))) `(part ,(car (part-tags index))))))))))
null)))) null))))
d ht) d ht)
,@(render-table (make-table ,@(render-table (make-table

131
collects/scribble/latex-render.ss
View File

@ -6,6 +6,7 @@
(define current-table-mode (make-parameter #f)) (define current-table-mode (make-parameter #f))
(define rendering-tt (make-parameter #f)) (define rendering-tt (make-parameter #f))
(define show-link-page-numbers (make-parameter #f))
(define-struct (toc-paragraph paragraph) ()) (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{\\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{\\highlighted}[1]{\\colorbox{PaleBlue}{\\hspace{-0.5ex}\\schemeinputbg{#1}\\hspace{-0.5ex}}}\n")
(printf "\\newcommand{\\techlink}[1]{#1}\n") (printf "\\newcommand{\\techlink}[1]{#1}\n")
(printf "\\newcommand{\\indexlink}[1]{#1}\n")
(printf "\\newcommand{\\imageleft}[1]{} % drop it\n") (printf "\\newcommand{\\imageleft}[1]{} % drop it\n")
(printf "\\begin{document}\n") (printf "\\begin{document}\n\\sloppy\n")
(when (part-title-content d) (when (part-title-content d)
(printf "\\title{") (printf "\\title{")
(render-content (part-title-content d) d ht) (render-content (part-title-content d) d ht)
@ -82,6 +84,9 @@
(let ([number (collected-info-number (part-collected-info d))]) (let ([number (collected-info-number (part-collected-info d))])
(when (and (part-title-content d) (when (and (part-title-content d)
(pair? number)) (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{" (printf "\\~a~a{"
(case (length number) (case (length number)
[(0 1) "newpage\n\n\\section"] [(0 1) "newpage\n\n\\section"]
@ -93,10 +98,13 @@
"*" "*"
"")) ""))
(render-content (part-title-content d) d ht) (render-content (part-title-content d) d ht)
(printf "}")) (printf "}")
#; (when (and (styled-part? d)
(when (part-tag d) (eq? 'index (styled-part-style d)))
(printf "\\label{section:~a}" (protect-tag (part-tag 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) (render-flow (part-flow d) d ht)
(for-each (lambda (sec) (render-part sec ht)) (for-each (lambda (sec) (render-part sec ht))
(part-parts d)) (part-parts d))
@ -121,48 +129,68 @@
(pair? (link-element-tag e)) (pair? (link-element-tag e))
(eq? 'part (car (link-element-tag e))) (eq? 'part (car (link-element-tag e)))
(null? (element-content 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? (when part-label?
(printf "\\S") (printf "''"))
(render-content (let ([dest (lookup part ht (link-element-tag e))]) (when (and (link-element? e)
(if dest (show-link-page-numbers))
(format-number (cadr dest) null) (printf ", \\pageref{t:~a}" (t-encode (link-element-tag e))))
(list "???"))) null))
part
ht) (define/private (t-encode s)
(printf " ``")) (apply
(let ([style (and (element? e) string-append
(element-style e))] (map (lambda (c)
[wrap (lambda (e s tt?) (cond
(printf "{\\~a{" s) [(and (or (char-alphabetic? c)
(parameterize ([rendering-tt (or tt? (char-numeric? c))
(rendering-tt))]) ((char->integer c) . < . 128))
(super render-element e part ht)) (string c)]
(printf "}}"))]) [(char=? c #\space) "_"]
(cond [else
[(symbol? style) (format "x~x" (char->integer c))]))
(case style (string->list (format "~s" s)))))
[(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)
(define/override (render-table t part ht) (define/override (render-table t part ht)
(let* ([boxed? (eq? 'boxed (table-style t))] (let* ([boxed? (eq? 'boxed (table-style t))]
@ -176,7 +204,7 @@
(equal? "longtable" (car m)) (equal? "longtable" (car m))
(= 1 (length (car (table-flowss (cadr m))))))))] (= 1 (length (car (table-flowss (cadr m))))))))]
[tableform (cond [tableform (cond
[index? "theindex"] [index? "list"]
[(not (current-table-mode)) [(not (current-table-mode))
"longtable"] "longtable"]
[else "tabular"])] [else "tabular"])]
@ -188,10 +216,11 @@
(null? (car (table-flowss t)))) (null? (car (table-flowss t))))
(parameterize ([current-table-mode (if inline? (parameterize ([current-table-mode (if inline?
(current-table-mode) (current-table-mode)
(list tableform t))]) (list tableform t))]
[show-link-page-numbers (or index?
(show-link-page-numbers))])
(cond (cond
[index? [index? (printf "\\begin{list}{}{\\parsep=0pt \\itemsep=1pt \\leftmargin=2ex \\itemindent=-2ex}\n")]
(printf "\n\n\\begin{theindex}\n")]
[inline? (void)] [inline? (void)]
[else [else
(printf "\n\n~a\\begin{~a}~a{@{}~a}\n" (printf "\n\n~a\\begin{~a}~a{@{}~a}\n"
@ -223,6 +252,8 @@
[row-style (car row-styles)]) [row-style (car row-styles)])
(let loop ([flows flows]) (let loop ([flows flows])
(unless (null? flows) (unless (null? flows)
(when index?
(printf "\\item "))
(unless (eq? 'cont (car flows)) (unless (eq? 'cont (car flows))
(let ([cnt (let loop ([flows (cdr flows)][n 1]) (let ([cnt (let loop ([flows (cdr flows)][n 1])
(cond (cond

106
collects/scribble/manual.ss
View File

@ -88,11 +88,23 @@
(make-element 'tt (list (substring s spaces)))))))))) (make-element 'tt (list (substring s spaces))))))))))
strs)))) 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 (provide schemeblock SCHEMEBLOCK
schemeblock0 SCHEMEBLOCK0 schemeblock0 SCHEMEBLOCK0
schemeinput schemeinput
schememod schememod
scheme schemeresult schemeid schememodname scheme schemeresult schemeid schememodname
indexed-scheme
litchar litchar
verbatim) verbatim)
@ -100,6 +112,7 @@
schemefont schemevalfont schemeresultfont schemeidfont schemefont schemevalfont schemeresultfont schemeidfont
schemeparenfont schemekeywordfont schememetafont schememodfont schemeparenfont schemekeywordfont schememetafont schememodfont
file exec envvar Flag DFlag file exec envvar Flag DFlag
indexed-file indexed-envvar
link procedure link procedure
idefterm) idefterm)
@ -130,6 +143,10 @@
(make-element "schemekeyword" (decode-content str))) (make-element "schemekeyword" (decode-content str)))
(define (file . str) (define (file . str)
(make-element 'tt (append (list "\"") (decode-content str) (list "\"")))) (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) (define (exec . str)
(make-element 'tt (decode-content str))) (make-element 'tt (decode-content str)))
(define (Flag . str) (define (Flag . str)
@ -138,6 +155,10 @@
(make-element 'tt (cons "--" (decode-content str)))) (make-element 'tt (cons "--" (decode-content str))))
(define (envvar . str) (define (envvar . str)
(make-element 'tt (decode-content 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) (define (procedure . str)
(make-element "schemeresult" (append (list "#<procedure:") (decode-content str) (list ">")))) (make-element "schemeresult" (append (list "#<procedure:") (decode-content str) (list ">"))))
@ -183,7 +204,13 @@
(format "tech-term:~a" s)))) (format "tech-term:~a" s))))
(define (deftech . 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) (define (tech . s)
(*tech make-link-element "techlink" 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) o-accum)))))
(loop (cdr a) (cons (car a) r-accum))))] (loop (cdr a) (cons (car a) r-accum))))]
[(tagged) (if first? [(tagged) (if first?
(make-toc-target-element (let ([tag (register-scheme-definition stx-id)]
#f [content (list (to-element (make-just-context (car prototype)
(list (to-element (make-just-context (car prototype) stx-id)))])
stx-id))) (make-toc-target-element
(register-scheme-definition stx-id)) #f
(list (make-index-element #f
content
tag
(list (symbol->string (car prototype)))
content))
tag))
(to-element (make-just-context (car prototype) (to-element (make-just-context (car prototype)
stx-id)))] stx-id)))]
[(flat-size) (prototype-size prototype + +)] [(flat-size) (prototype-size prototype + +)]
@ -667,14 +700,23 @@
(make-target-element* (make-target-element*
make-target-element make-target-element
stx-id stx-id
(inner-make-target-element (let* ([name
#f (apply string-append
(list content) (map symbol->string (car wrappers)))]
(register-scheme-definition [tag
(datum->syntax-object stx-id (register-scheme-definition
(string->symbol (datum->syntax-object stx-id
(apply string-append (string->symbol
(map symbol->string (car wrappers))))))) 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)))) (cdr wrappers))))
(define (*defstruct stx-id name fields field-contracts immutable? transparent? content-thunk) (define (*defstruct stx-id name fields field-contracts immutable? transparent? content-thunk)
@ -841,10 +883,16 @@
(list (make-flow (list (make-flow
(list (list
(make-paragraph (make-paragraph
(list (make-toc-target-element (list (let ([tag (register-scheme-definition stx-id)]
#f [content (list (to-element (make-just-context name stx-id)))])
(list (to-element (make-just-context name stx-id))) (make-toc-target-element
(register-scheme-definition stx-id)) #f
(list (make-index-element #f
content
tag
(list (symbol->string name))
content))
tag))
spacer ":" spacer spacer ":" spacer
(to-element result-contract)))))))) (to-element result-contract))))))))
(content-thunk)))) (content-thunk))))
@ -890,13 +938,21 @@
. ,(cdr form))))))) . ,(cdr form)))))))
(and kw-id (and kw-id
(eq? form (car forms)) (eq? form (car forms))
(make-toc-target-element (let ([tag (register-scheme-form-definition kw-id)]
#f [content (list (to-element (make-just-context (if (pair? form)
(list (to-element (make-just-context (if (pair? form) (car form)
(car form) form)
form) kw-id)))])
kw-id))) (make-toc-target-element
(register-scheme-form-definition kw-id)))))))) #f
(if kw-id
(list (make-index-element #f
content
tag
(list (symbol->string (syntax-e kw-id)))
content))
content)
tag))))))))
forms form-procs) forms form-procs)
(if (null? sub-procs) (if (null? sub-procs)
null null

1
collects/scribble/scheme.ss
View File

@ -388,6 +388,7 @@
[vd [vd
(make-link-element "schemevaluelink" (list s) vtag)] (make-link-element "schemevaluelink" (list s) vtag)]
[else s])))) [else s]))))
(lambda () s)
(lambda () s)) (lambda () s))
(literalize-spaces s)) (literalize-spaces s))
(cond (cond

9
collects/scribble/scribble.css
View File

@ -118,6 +118,10 @@
font-weight: bold; font-weight: bold;
} }
.indexlink {
text-decoration: none;
}
.title { .title {
font-size: 200%; font-size: 200%;
font-weight: normal; font-weight: normal;
@ -405,3 +409,8 @@
.colophon a { .colophon a {
color: gray; color: gray;
} }
.mywbr {
width: 0;
font-size: 1px;
}

32
collects/scribble/struct.ss
View File

@ -52,13 +52,14 @@
(delayed-flow-element? p))) (delayed-flow-element? p)))
(provide-structs (provide-structs
[part ([tag (or/c false/c tag?)] [part ([tags (listof tag?)]
[title-content (or/c false/c list?)] [title-content (or/c false/c list?)]
[collected-info (or/c false/c collected-info?)] [collected-info (or/c false/c collected-info?)]
[to-collect list?]
[flow flow?] [flow flow?]
[parts (listof part?)])] [parts (listof part?)])]
[(styled-part part) ([style any/c])] [(styled-part part) ([style any/c])]
[(unnumbered-part part) ()] [(unnumbered-part styled-part) ()]
[flow ([paragraphs (listof flow-element?)])] [flow ([paragraphs (listof flow-element?)])]
[paragraph ([content list?])] [paragraph ([content list?])]
[(styled-paragraph paragraph) ([style any/c])] [(styled-paragraph paragraph) ([style any/c])]
@ -96,48 +97,54 @@
delayed-element-ref delayed-element-ref
delayed-element-set!) delayed-element-set!)
(make-struct-type 'delayed-element #f (make-struct-type 'delayed-element #f
2 1 #f 3 1 #f
(list (cons prop:serializable (list (cons prop:serializable
(make-serialize-info (make-serialize-info
(lambda (d) (lambda (d)
(unless (delayed-element-ref d 2) (unless (delayed-element-ref d 3)
(error 'serialize-delayed-element (error 'serialize-delayed-element
"cannot serialize a delayed element that was not resolved: ~e" "cannot serialize a delayed element that was not resolved: ~e"
d)) d))
(vector (delayed-element-ref d 2))) (vector (delayed-element-ref d 3)))
#'deserialize-delayed-element #'deserialize-delayed-element
#f #f
(or (current-load-relative-directory) (current-directory))))))) (or (current-load-relative-directory) (current-directory)))))))
(define-syntax delayed-element (list-immutable #'struct:delayed-element (define-syntax delayed-element (list-immutable #'struct:delayed-element
#'make-delayed-element #'make-delayed-element
#'delayed-element? #'delayed-element?
(list-immutable #'delayed-element-sizer (list-immutable #'delayed-element-plain
#'delayed-element-sizer
#'delayed-element-render) #'delayed-element-render)
(list-immutable #'set-delayed-element-sizer! (list-immutable #'set-delayed-element-plain!
#'set-delayed-element-sizer!
#'set-delayed-element-render!) #'set-delayed-element-render!)
#t)) #t))
(define delayed-element-render (make-struct-field-accessor delayed-element-ref 0)) (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-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-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-sizer! (make-struct-field-mutator delayed-element-set! 1))
(define set-delayed-element-plain! (make-struct-field-mutator delayed-element-set! 2))
(provide/contract (provide/contract
(struct delayed-element ([render (any/c part? any/c . -> . list?)] (struct delayed-element ([render (any/c part? any/c . -> . list?)]
[sizer (-> any)]))) [sizer (-> any)]
[plain (-> any)])))
(provide deserialize-delayed-element) (provide deserialize-delayed-element)
(define deserialize-delayed-element (define deserialize-delayed-element
(make-deserialize-info values values)) (make-deserialize-info values values))
(provide force-delayed-element) (provide force-delayed-element)
(define (force-delayed-element d renderer sec ht) (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)]) (let ([v ((delayed-element-ref d 0) renderer sec ht)])
(delayed-element-set! d 2 v) (delayed-element-set! d 3 v)
v))) v)))
;; ---------------------------------------- ;; ----------------------------------------
(provide content->string) (provide content->string
element->string)
(define content->string (define content->string
(case-lambda (case-lambda
@ -154,6 +161,7 @@
[(c) [(c)
(cond (cond
[(element? c) (content->string (element-content c))] [(element? c) (content->string (element-content c))]
[(delayed-element? c) (element->string ((delayed-element-plain c)))]
[(string? c) c] [(string? c) c]
[else (case c [else (case c
[(ndash) "--"] [(ndash) "--"]