suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

371.2

Browse Source 
svn: r7263

original commit: e4cbc4e6a938fd5bd90aab305ca39d61e7eae151
This commit is contained in:
Matthew Flatt 2007-09-02 17:39:32 +00:00
parent 61f344920d
commit 9e58c9fdc1
22 changed files with 2201 additions and 935 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -11,7 +11,7 @@
(class object%
(init-field dest-dir)
(define/public (get-dest-directory)
dest-dir)
@ -42,210 +42,334 @@
[else (cons (car content)
(strip-aux (cdr content)))]))
;; ----------------------------------------
;; marshal info
(define/public (get-serialize-version)
1)
(define/public (serialize-info ri)
(parameterize ([current-serialize-resolve-info ri])
(serialize (collect-info-ht (resolve-info-ci ri)))))
(define/public (deserialize-info v ci)
(let ([ht (deserialize v)]
[in-ht (collect-info-ext-ht ci)])
(hash-table-for-each ht (lambda (k v)
(hash-table-put! in-ht k v)))))
(define/public (get-defined ci)
(hash-table-map (collect-info-ht ci) (lambda (k v) k)))
(define/public (get-undefined ri)
(hash-table-map (resolve-info-undef ri) (lambda (k v) k)))
;; ----------------------------------------
;; global-info collection
(define/public (save-info fn info)
(let ([s (serialize info)])
(with-output-to-file fn
(lambda ()
(write s))
'truncate/replace)))
(define/public (load-info fn info)
(let ([ht (deserialize (with-input-from-file fn read))])
(hash-table-for-each ht (lambda (k v)
(hash-table-put! info k v))))
info)
(define/public (collect ds fns)
(let ([ht (make-hash-table 'equal)])
(map (lambda (d)
(collect-part d #f ht null))
ds)
ht))
(let ([ci (make-collect-info (make-hash-table 'equal)
(make-hash-table 'equal)
(make-hash-table)
(make-hash-table)
"")])
(start-collect ds fns ci)
ci))
(define/public (collect-part d parent ht number)
(let ([p-ht (make-hash-table 'equal)])
(define/public (start-collect ds fns ci)
(map (lambda (d)
(collect-part d #f ci null))
ds))
(define/public (collect-part d parent ci number)
(let ([p-ci (make-collect-info (make-hash-table 'equal)
(collect-info-ext-ht ci)
(collect-info-parts ci)
(collect-info-tags ci)
(if (part-tag-prefix d)
(string-append (collect-info-gen-prefix ci)
(part-tag-prefix d)
":")
(collect-info-gen-prefix ci)))])
(when (part-title-content d)
(collect-content (part-title-content d) p-ht))
(collect-part-tags d p-ht number)
(collect-content (part-to-collect d) p-ht)
(collect-flow (part-flow d) p-ht)
(collect-content (part-title-content d) p-ci))
(collect-part-tags d p-ci number)
(collect-content (part-to-collect d) p-ci)
(collect-flow (part-flow d) p-ci)
(let loop ([parts (part-parts d)]
[pos 1])
(unless (null? parts)
(let ([s (car parts)])
(collect-part s d p-ht
(collect-part s d p-ci
(cons (if (unnumbered-part? s)
#f
pos)
number))
(loop (cdr parts)
(if (unnumbered-part? s) pos (add1 pos))))))
(set-part-collected-info! d (make-collected-info
number
parent
p-ht))
(hash-table-for-each p-ht
(lambda (k v)
(hash-table-put! ht k v)))))
(hash-table-put! (collect-info-parts ci)
d
(make-collected-info
number
parent
(collect-info-ht p-ci)))
(let ([prefix (part-tag-prefix d)])
(hash-table-for-each (collect-info-ht p-ci)
(lambda (k v)
(when (cadr k)
(hash-table-put! (collect-info-ht ci)
(if prefix
(convert-key prefix k)
k)
v)))))))
(define/public (collect-part-tags d ht number)
(define/private (convert-key prefix k)
(case (car k)
[(part tech)
(if (string? (cadr k))
(list (car k)
(string-append prefix
":"
(cadr k)))
k)]
[(index-entry)
(let ([v (convert-key prefix (cadr k))])
(if (eq? v (cadr k))
k
(list 'index-entry v)))]
[else k]))
(define/public (collect-part-tags d ci number)
(for-each (lambda (t)
(hash-table-put! ht `(part ,t) (list (part-title-content d) number)))
(hash-table-put! (collect-info-ht ci)
(generate-tag t ci)
(list (or (part-title-content d) '("???"))
number)))
(part-tags d)))
(define/public (collect-content c ht)
(define/public (collect-content c ci)
(for-each (lambda (i)
(collect-element i ht))
(collect-element i ci))
c))
(define/public (collect-paragraph p ht)
(collect-content (paragraph-content p) ht))
(define/public (collect-paragraph p ci)
(collect-content (paragraph-content p) ci))
(define/public (collect-flow p ht)
(define/public (collect-flow p ci)
(for-each (lambda (p)
(collect-flow-element p ht))
(collect-flow-element p ci))
(flow-paragraphs p)))
(define/public (collect-flow-element p ht)
(define/public (collect-flow-element p ci)
(cond
[(table? p) (collect-table p ht)]
[(itemization? p) (collect-itemization p ht)]
[(blockquote? p) (collect-blockquote p ht)]
[(table? p) (collect-table p ci)]
[(itemization? p) (collect-itemization p ci)]
[(blockquote? p) (collect-blockquote p ci)]
[(delayed-flow-element? p) (void)]
[else (collect-paragraph p ht)]))
[else (collect-paragraph p ci)]))
(define/public (collect-table i ht)
(define/public (collect-table i ci)
(for-each (lambda (d) (when (flow? d)
(collect-flow d ht)))
(collect-flow d ci)))
(apply append (table-flowss i))))
(define/public (collect-itemization i ht)
(for-each (lambda (d) (collect-flow d ht))
(define/public (collect-itemization i ci)
(for-each (lambda (d) (collect-flow d ci))
(itemization-flows i)))
(define/public (collect-blockquote i ht)
(for-each (lambda (d) (collect-flow-element d ht))
(define/public (collect-blockquote i ci)
(for-each (lambda (d) (collect-flow-element d ci))
(blockquote-paragraphs i)))
(define/public (collect-element i ht)
(define/public (collect-element i ci)
(when (target-element? i)
(collect-target-element i ht))
(collect-target-element i ci))
(when (index-element? i)
(collect-index-element i ht))
(collect-index-element i ci))
(when (collect-element? i)
((collect-element-collect i) ci))
(when (element? i)
(for-each (lambda (e)
(collect-element e ht))
(collect-element e ci))
(element-content i))))
(define/public (collect-target-element i ht)
(hash-table-put! ht (target-element-tag i) (list i)))
(define/public (collect-target-element i ci)
(collect-put! ci
(generate-tag (target-element-tag i) ci)
(list i)))
(define/public (collect-index-element i ht)
(hash-table-put! ht `(index-entry ,(index-element-tag i))
(list (index-element-plain-seq i)
(index-element-entry-seq i))))
(define/public (collect-index-element i ci)
(collect-put! ci
`(index-entry ,(generate-tag (index-element-tag i) ci))
(list (index-element-plain-seq i)
(index-element-entry-seq i))))
(define/public (lookup part ht key)
(let ([v (hash-table-get (if part
(collected-info-info (part-collected-info part))
ht)
key
#f)])
(or v
(and part
(lookup (collected-info-parent
(part-collected-info part))
ht
key)))))
;; ----------------------------------------
;; global-info resolution
(define/public (resolve ds fns ci)
(let ([ri (make-resolve-info ci
(make-hash-table)
(make-hash-table 'equal))])
(start-resolve ds fns ri)
ri))
(define/public (start-resolve ds fns ri)
(map (lambda (d)
(resolve-part d ri))
ds))
(define/public (resolve-part d ri)
(when (part-title-content d)
(resolve-content (part-title-content d) d ri))
(resolve-flow (part-flow d) d ri)
(for-each (lambda (p)
(resolve-part p ri))
(part-parts d)))
(define/public (resolve-content c d ri)
(for-each (lambda (i)
(resolve-element i d ri))
c))
(define/public (resolve-paragraph p d ri)
(resolve-content (paragraph-content p) d ri))
(define/public (resolve-flow p d ri)
(for-each (lambda (p)
(resolve-flow-element p d ri))
(flow-paragraphs p)))
(define/public (resolve-flow-element p d ri)
(cond
[(table? p) (resolve-table p d ri)]
[(itemization? p) (resolve-itemization p d ri)]
[(blockquote? p) (resolve-blockquote p d ri)]
[(delayed-flow-element? p)
(let ([v ((delayed-flow-element-resolve p) this d ri)])
(hash-table-put! (resolve-info-delays ri) p v)
(resolve-flow-element v d ri))]
[else (resolve-paragraph p d ri)]))
(define/public (resolve-table i d ri)
(for-each (lambda (f) (when (flow? f)
(resolve-flow f d ri)))
(apply append (table-flowss i))))
(define/public (resolve-itemization i d ri)
(for-each (lambda (f) (resolve-flow f d ri))
(itemization-flows i)))
(define/public (resolve-blockquote i d ri)
(for-each (lambda (f) (resolve-flow-element f d ri))
(blockquote-paragraphs i)))
(define/public (resolve-element i d ri)
(cond
[(delayed-element? i)
(resolve-content (or (hash-table-get (resolve-info-delays ri)
i
#f)
(let ([v ((delayed-element-resolve i) this d ri)])
(hash-table-put! (resolve-info-delays ri)
i
v)
v))
d ri)]
[(element? i)
(cond
[(link-element? i)
(let-values ([(dest ext?) (resolve-get/where d ri (link-element-tag i))])
(when ext?
(hash-table-put! (resolve-info-undef ri)
(tag-key (link-element-tag i) ri)
#t)))])
(for-each (lambda (e)
(resolve-element e d ri))
(element-content i))]))
;; ----------------------------------------
;; render methods
(define/public (render ds fns ht)
(define/public (render ds fns ri)
(map (lambda (d fn)
(printf " [Output to ~a]\n" fn)
(with-output-to-file fn
(lambda ()
(render-one d ht fn))
(render-one d ri fn))
'truncate/replace))
ds
fns))
(define/public (render-one d ht fn)
(render-part d ht))
(define/public (render-one d ri fn)
(render-part d ri))
(define/public (render-part d ht)
(define/public (render-part d ri)
(list
(when (part-title-content d)
(render-content (part-title-content d) d ht))
(render-flow (part-flow d) d ht)
(map (lambda (s) (render-part s ht))
(render-content (part-title-content d) d ri))
(render-flow (part-flow d) d ri)
(map (lambda (s) (render-part s ri))
(part-parts d))))
(define/public (render-content c part ht)
(define/public (render-content c part ri)
(apply append
(map (lambda (i)
(render-element i part ht))
(render-element i part ri))
c)))
(define/public (render-paragraph p part ht)
(render-content (paragraph-content p) part ht))
(define/public (render-paragraph p part ri)
(render-content (paragraph-content p) part ri))
(define/public (render-flow p part ht)
(define/public (render-flow p part ri)
(apply append
(map (lambda (p)
(render-flow-element p part ht))
(render-flow-element p part ri))
(flow-paragraphs p))))
(define/public (render-flow-element p part ht)
(define/public (render-flow-element p part ri)
(cond
[(table? p) (if (auxiliary-table? p)
(render-auxiliary-table p part ht)
(render-table p part ht))]
[(itemization? p) (render-itemization p part ht)]
[(blockquote? p) (render-blockquote p part ht)]
[(delayed-flow-element? p) (render-flow-element
((delayed-flow-element-render p) this part ht)
part ht)]
[else (render-paragraph p part ht)]))
(render-auxiliary-table p part ri)
(render-table p part ri))]
[(itemization? p) (render-itemization p part ri)]
[(blockquote? p) (render-blockquote p part ri)]
[(delayed-flow-element? p)
(render-flow-element (delayed-flow-element-flow-elements p ri) part ri)]
[else (render-paragraph p part ri)]))
(define/public (render-auxiliary-table i part ht)
(define/public (render-auxiliary-table i part ri)
null)
(define/public (render-table i part ht)
(define/public (render-table i part ri)
(map (lambda (d) (if (flow? i)
(render-flow d part ht)
(render-flow d part ri)
null))
(apply append (table-flowss i))))
(define/public (render-itemization i part ht)
(map (lambda (d) (render-flow d part ht))
(define/public (render-itemization i part ri)
(map (lambda (d) (render-flow d part ri))
(itemization-flows i)))
(define/public (render-blockquote i part ht)
(map (lambda (d) (render-flow-element d part ht))
(define/public (render-blockquote i part ri)
(map (lambda (d) (render-flow-element d part ri))
(blockquote-paragraphs i)))
(define/public (render-element i part ht)
(define/public (render-element i part ri)
(cond
[(and (link-element? i)
(null? (element-content i)))
(let ([v (lookup part ht (link-element-tag i))])
(let ([v (resolve-get part ri (link-element-tag i))])
(if v
(render-content (strip-aux (car v)) part ht)
(render-content (list "[missing]") part ht)))]
(render-content (strip-aux (car v)) part ri)
(render-content (list "[missing]") part ri)))]
[(element? i)
(render-content (element-content i) part ht)]
(render-content (element-content i) part ri)]
[(delayed-element? i)
(render-content (force-delayed-element i this part ht) part ht)]
(render-content (delayed-element-content i ri) part ri)]
[else
(render-other i part ht)]))
(render-other i part ri)]))
(define/public (render-other i part ht)
(define/public (render-other i part ri)
(list i))
;; ----------------------------------------
@ -280,34 +404,32 @@
;; ----------------------------------------
(define/private (do-table-of-contents part ht delta quiet)
(make-table #f (render-toc part
(+ delta
(length (collected-info-number
(part-collected-info part))))
#t
quiet)))
(define/private (do-table-of-contents part ri delta quiet)
(make-table #f (generate-toc part
ri
(+ delta
(length (collected-info-number
(part-collected-info part ri))))
#t
quiet)))
(define/public (table-of-contents part ht)
(do-table-of-contents part ht -1 not))
(define/public (table-of-contents part ri)
(do-table-of-contents part ri -1 not))
(define/public (local-table-of-contents part ht)
(table-of-contents part ht))
(define/public (local-table-of-contents part ri)
(table-of-contents part ri))
(define/public (quiet-table-of-contents part ht)
(do-table-of-contents part ht 1 (lambda (x) #t)))
(define/public (quiet-table-of-contents part ri)
(do-table-of-contents part ri 1 (lambda (x) #t)))
(define/private (render-toc part base-len skip? quiet)
(let ([number (collected-info-number (part-collected-info part))])
(define/private (generate-toc part ri base-len skip? quiet)
(let ([number (collected-info-number (part-collected-info part ri))])
(let ([subs
(if (quiet (and (styled-part? part)
(let ([st(styled-part-style part)])
(or (eq? 'quiet st)
(and (list? st) (memq 'quiet st))))
(if (quiet (and (part-style? part 'quiet)
(not (= base-len (sub1 (length number))))))
(apply
append
(map (lambda (p) (render-toc p base-len #f quiet)) (part-parts part)))
(map (lambda (p) (generate-toc p ri base-len #f quiet)) (part-parts part)))
null)])
(if skip?
subs
@ -324,8 +446,8 @@
(format-number number
(list
(make-element 'hspace '(" "))))
(part-title-content part))
`(part ,(car (part-tags part)))))))))
(or (part-title-content part) '("???")))
(car (part-tags part))))))))
subs)])
(if (and (= 1 (length number))
(or (not (car number))

81
collects/scribble/basic.ss
View File

@ -4,7 +4,9 @@
"struct.ss"
"config.ss"
(lib "list.ss")
(lib "class.ss"))
(lib "class.ss")
(lib "main-collects.ss" "setup")
(lib "modresolve.ss" "syntax"))
(provide title
section
@ -18,21 +20,41 @@
(content->string content)
"_"))
(define (title #:tag [tag #f] #:style [style #f] . str)
(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] . str)
(let ([content (decode-content str)])
(make-title-decl (or tag (gen-tag content)) style content)))
(make-title-decl (prefix->string prefix)
`((part ,(or tag (gen-tag content))))
style
content)))
(define (section #:tag [tag #f] #:style [style #f] . str)
(define (section #:tag [tag #f] #:tag-prefix [prefix #f] #:style [style #f] . str)
(let ([content (decode-content str)])
(make-part-start 0 (or tag (gen-tag content)) style content)))
(make-part-start 0 (prefix->string prefix)
`((part ,(or tag (gen-tag content))))
style
content)))
(define (subsection #:tag [tag #f] . str)
(define (subsection #:tag [tag #f] #:tag-prefix [prefix #f] . str)
(let ([content (decode-content str)])
(make-part-start 1 (or tag (gen-tag content)) #f content)))
(make-part-start 1
(prefix->string prefix)
`((part ,(or tag (gen-tag content))))
#f
content)))
(define (subsubsection #:tag [tag #f] . str)
(define (subsubsection #:tag [tag #f] #:tag-prefix [prefix #f] . str)
(let ([content (decode-content str)])
(make-part-start 2 (or tag (gen-tag content)) #f content)))
(make-part-start 2
(prefix->string prefix)
`((part ,(or tag (gen-tag content))))
#f
content)))
(define (subsubsub*section #:tag [tag #f] . str)
(let ([content (decode-content str)])
@ -47,6 +69,14 @@
;; ----------------------------------------
(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)
@ -124,19 +154,16 @@
(define (section-index . elems)
(make-part-index-decl (map element->string elems) elems))
(define (gen-target)
(format "index:~s:~s" (current-inexact-milliseconds) (gensym)))
(define (record-index word-seq element-seq tag content)
(make-index-element
#f
(list (make-target-element #f content tag))
tag
(list (make-target-element #f content `(idx ,tag)))
`(idx ,tag)
word-seq
element-seq))
(define (index* word-seq content-seq . s)
(let ([key (gen-target)])
(let ([key (make-generated-tag)])
(record-index word-seq
content-seq
key
@ -149,7 +176,7 @@
(apply index* word-seq word-seq s)))
(define (as-index . s)
(let ([key (gen-target)]
(let ([key (make-generated-tag)]
[content (decode-content s)])
(record-index (list (content->string content))
(list (make-element #f content))
@ -158,18 +185,21 @@
(define (index-section tag)
(make-unnumbered-part
(and tag (list tag))
(list "Index")
#f
`((part , (or tag
(make-generated-tag))))
'("Index")
'index
null
(make-flow (list (make-delayed-flow-element
(lambda (renderer sec ht)
(lambda (renderer sec ri)
(let ([l null])
(hash-table-for-each
(collected-info-info
(part-collected-info
(collected-info-parent
(part-collected-info sec))))
(part-collected-info sec ri))
ri))
(lambda (k v)
(if (and (pair? k)
(eq? 'index-entry (car k)))
@ -204,8 +234,7 @@
(commas (caddr i))
(car i))))))))
l))))))))
null
'index))
null))
;; ----------------------------------------
@ -214,13 +243,13 @@
(define (table-of-contents)
(make-delayed-flow-element
(lambda (renderer part ht)
(send renderer table-of-contents part ht))))
(lambda (renderer part ri)
(send renderer table-of-contents part ri))))
(define (local-table-of-contents)
(make-delayed-flow-element
(lambda (renderer part ht)
(send renderer local-table-of-contents part ht)))))
(lambda (renderer part ri)
(send renderer local-table-of-contents part ri)))))

184
collects/scribble/decode.ss
View File

@ -13,16 +13,19 @@
whitespace?)
(provide-structs
[title-decl ([tag any/c]
[title-decl ([tag-prefix (or/c false/c string?)]
[tags (listof tag?)]
[style any/c]
[content list?])]
[part-start ([depth integer?]
[tag (or/c false/c string?)]
[tag-prefix (or/c false/c string?)]
[tags (listof tag?)]
[style any/c]
[title list?])]
[splice ([run list?])]
[part-index-decl ([plain-seq (listof string?)]
[entry-seq list?])])
[entry-seq list?])]
[part-collect-decl ([element element?])])
(define (decode-string s)
(let loop ([l '((#rx"---" mdash)
@ -52,39 +55,42 @@
null
(list (decode-paragraph (reverse (skip-whitespace accum))))))
(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])
(define (decode-flow* l keys colls tag-prefix tags style title part-depth)
(let loop ([l l][next? #f][keys keys][colls colls][accum null][title title][tag-prefix tag-prefix][tags tags][style style])
(cond
[(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)
(part-index-decl-plain-seq k)
(part-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))]
(let ([k-tags (map (lambda (k)
`(idx ,(make-generated-tag)))
keys)]
[tags (if (null? tags)
(list `(part ,(make-generated-tag)))
tags)])
(make-part tag-prefix
(append tags k-tags)
title
style
(let ([l (map (lambda (k tag)
(make-index-element
#f
null
tag
(part-index-decl-plain-seq k)
(part-index-decl-entry-seq k)))
keys k-tags)])
(append
(if title
(cons (make-index-element
#f
null
(car tags)
(list (regexp-replace #px"^(?:A|An|The)\\s" (content->string title)
""))
(list (make-element #f title)))
l)
l)
colls))
(make-flow (decode-accum-para accum))
null))]
[(title-decl? (car l))
(unless part-depth
(error 'decode
@ -94,34 +100,35 @@
(error 'decode
"found extra title: ~v"
(car l)))
(loop (cdr l) next? keys accum
(loop (cdr l) next? keys colls accum
(title-decl-content (car l))
(title-decl-tag (car l))
(title-decl-tag-prefix (car l))
(title-decl-tags (car l))
(title-decl-style (car l)))]
[(flow-element? (car l))
(let ([para (decode-accum-para accum)]
[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))))
(part-parts part)
(styled-part-style part)))]
[part (decode-flow* (cdr l) keys colls tag-prefix tags style title part-depth)])
(make-part (part-tag-prefix part)
(part-tags part)
(part-title-content part)
(part-style part)
(part-to-collect part)
(make-flow (append para
(list (car l))
(flow-paragraphs (part-flow part))))
(part-parts part)))]
[(part? (car l))
(let ([para (decode-accum-para accum)]
[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))))
(cons (car l) (part-parts part))
(styled-part-style part)))]
[part (decode-flow* (cdr l) keys colls tag-prefix tags style title part-depth)])
(make-part (part-tag-prefix part)
(part-tags part)
(part-title-content part)
(part-style part)
(part-to-collect part)
(make-flow (append para
(flow-paragraphs
(part-flow part))))
(cons (car l) (part-parts part))))]
[(and (part-start? (car l))
(or (not part-depth)
((part-start-depth (car l)) . <= . part-depth)))
@ -138,54 +145,57 @@
(part? (car l))))
(let ([para (decode-accum-para accum)]
[s (decode-styled-part (reverse s-accum)
(part-start-tag s)
(part-start-tag-prefix s)
(part-start-tags s)
(part-start-style s)
(part-start-title s)
(add1 part-depth))]
[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)))
[part (decode-flow* l keys colls tag-prefix tags style title part-depth)])
(make-part (part-tag-prefix part)
(part-tags part)
(part-title-content part)
(part-style part)
(part-to-collect part)
(make-flow para)
(cons s (part-parts part))))
(if (splice? (car l))
(loop (append (splice-run (car l)) (cdr l)) s-accum)
(loop (cdr l) (cons (car l) s-accum))))))]
[(splice? (car l))
(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)]
(loop (append (splice-run (car l)) (cdr l)) next? keys colls accum title tag-prefix tags style)]
[(null? (cdr l)) (loop null #f keys colls (cons (car l) accum) title tag-prefix tags style)]
[(part-index-decl? (car l))
(loop (cdr l) next? (cons (car l) keys) accum title tag style)]
(loop (cdr l) next? (cons (car l) keys) colls accum title tag-prefix tags style)]
[(part-collect-decl? (car l))
(loop (cdr l) next? keys (cons (part-collect-decl-element (car l)) colls) accum title tag-prefix tags style)]
[(and (pair? (cdr l))
(splice? (cadr l)))
(loop (cons (car l) (append (splice-run (cadr l)) (cddr l))) next? keys accum title tag style)]
(loop (cons (car l) (append (splice-run (cadr l)) (cddr l))) next? keys colls accum title tag-prefix tags style)]
[(line-break? (car l))
(if next?
(loop (cdr l) #t keys accum title tag style)
(loop (cdr l) #t keys colls accum title tag-prefix tags style)
(let ([m (match-newline-whitespace (cdr l))])
(if m
(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 keys (cons (car l) accum) title tag style))))]
[else (loop (cdr l) #f keys (cons (car l) accum) title tag style)])))
(let ([part (loop m #t keys colls null title tag-prefix tags style)])
(make-part (part-tag-prefix part)
(part-tags part)
(part-title-content part)
(part-style part)
(part-to-collect part)
(make-flow (append (decode-accum-para accum)
(flow-paragraphs (part-flow part))))
(part-parts part)))
(loop (cdr l) #f keys colls (cons (car l) accum) title tag-prefix tags style))))]
[else (loop (cdr l) #f keys colls (cons (car l) accum) title tag-prefix tags style)])))
(define (decode-part l tag title depth)
(decode-flow* l null tag #f title depth))
(define (decode-part l tags title depth)
(decode-flow* l null null #f tags #f title depth))
(define (decode-styled-part l tag style title depth)
(decode-flow* l null tag style title depth))
(define (decode-styled-part l tag-prefix tags style title depth)
(decode-flow* l null null tag-prefix tags style title depth))
(define (decode-flow l)
(part-flow (decode-flow* l null #f #f #f #f)))
(part-flow (decode-flow* l null null #f null #f #f #f)))
(define (match-newline-whitespace l)
(cond
@ -207,7 +217,7 @@
(loop (cdr l)))))
(define (decode l)
(decode-part l #f #f 0))
(decode-part l null #f 0))
(define (decode-paragraph l)
(make-paragraph

4
collects/scribble/doclang.ss
View File

@ -43,7 +43,8 @@
(kernel-form-identifier-list #'here)
(syntax->list #'(provide
require
require-for-syntax))))])
require-for-syntax
require-for-label))))])
(syntax-case expanded (begin)
[(begin body1 ...)
#`(doc-begin m-id exprs body1 ... . body)]
@ -53,6 +54,7 @@
(syntax->list #'(require
provide
require-for-syntax
require-for-label
define-values
define-syntaxes
define-for-syntaxes))))

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

@ -5,6 +5,8 @@
(lib "file.ss")
(lib "list.ss")
(lib "runtime-path.ss")
(lib "main-doc.ss" "setup")
(lib "main-collects.ss" "setup")
(prefix xml: (lib "xml.ss" "xml")))
(provide render-mixin
render-multi-mixin)
@ -15,12 +17,25 @@
(define current-subdirectory (make-parameter #f))
(define current-output-file (make-parameter #f))
(define current-top-part (make-parameter #f))
(define on-separate-page (make-parameter #t))
(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))
(define (path->relative p)
(let ([p (path->main-doc-relative p)])
(if (path? p)
(path->main-collects-relative p)
p)))
(define (relative->path p)
(let ([p (main-doc-relative->path p)])
(if (path? p)
p
(main-collects-relative->path p))))
;; ----------------------------------------
;; main mixin
@ -33,58 +48,57 @@
get-dest-directory
format-number
strip-aux
lookup
quiet-table-of-contents)
(define/override (get-suffix) #".html")
;; ----------------------------------------
(define/override (collect ds fns)
(let ([ht (make-hash-table 'equal)])
(map (lambda (d fn)
(parameterize ([current-output-file fn])
(collect-part d #f ht null)))
ds
fns)
ht))
(define/override (start-collect ds fns ci)
(map (lambda (d fn)
(parameterize ([current-output-file fn]
[current-top-part d])
(collect-part d #f ci null)))
ds
fns))
(define/public (part-whole-page? p ht)
(let ([dest (lookup p ht `(part ,(car (part-tags p))))])
(define/public (part-whole-page? p ri)
(let ([dest (resolve-get p ri (car (part-tags p)))])
(caddr dest)))
(define/public (current-part-whole-page?)
#f)
(define/public (current-part-whole-page? d)
(eq? d (current-top-part)))
(define/override (collect-part-tags d ht number)
(define/override (collect-part-tags d ci number)
(for-each (lambda (t)
(hash-table-put! ht
`(part ,t)
(list (current-output-file)
(part-title-content d)
(current-part-whole-page?))))
(let ([key (generate-tag t ci)])
(collect-put! ci
key
(list (path->relative (current-output-file))
(or (part-title-content d)
'("???"))
(current-part-whole-page? d)
(format "~a" key)))))
(part-tags d)))
(define/override (collect-target-element i ht)
(hash-table-put! ht
(target-element-tag i)
(list (current-output-file)
#f
(page-target-element? i))))
(define/override (collect-target-element i ci)
(let ([key (generate-tag (target-element-tag i) ci)])
(collect-put! ci
key
(list (path->relative (current-output-file))
#f
(page-target-element? i)
(format "~a" key)))))
;; ----------------------------------------
(define/private (reveal-subparts? p)
(and (styled-part? p)
(let ([s (styled-part-style p)])
(or (eq? s 'reveal)
(and (list? s)
(memq 'reveal s))))))
(define/public (render-toc-view d ht)
(part-style? p 'reveal))
(define/public (render-toc-view d ri)
(let-values ([(top mine)
(let loop ([d d][mine d])
(let ([p (collected-info-parent (part-collected-info d))])
(let ([p (collected-info-parent (part-collected-info d ri))])
(if p
(loop p (if (reveal-subparts? d)
mine
@ -95,7 +109,7 @@
(div ((class "tocviewtitle"))
(a ((href "index.html")
(class "tocviewlink"))
,@(render-content (part-title-content top) d ht)))
,@(render-content (or (part-title-content top) '("???")) d ri)))
(div nbsp)
(table
((class "tocviewlist")
@ -107,24 +121,24 @@
(td
((align "right"))
,@(if show-number?
(format-number (collected-info-number (part-collected-info p))
(format-number (collected-info-number (part-collected-info p ri))
'((tt nbsp)))
'("-" nbsp)))
(td
(a ((href ,(let ([dest (lookup p ht `(part ,(car (part-tags p))))])
(a ((href ,(let ([dest (resolve-get p ri (car (part-tags p)))])
(format "~a~a~a"
(from-root (car dest)
(from-root (relative->path (car dest))
(get-dest-directory))
(if (caddr dest)
""
"#")
(if (caddr dest)
""
`(part ,(car (part-tags p)))))))
(cadddr dest)))))
(class ,(if (eq? p mine)
"tocviewselflink"
"tocviewlink")))
,@(render-content (part-title-content p) d ht))))))
,@(render-content (or (part-title-content p) '("???")) d ri))))))
(let loop ([l (map (lambda (v) (cons v #t)) (part-parts top))])
(cond
[(null? l) null]
@ -133,92 +147,101 @@
(part-parts (caar l)))
(cdr l))))]
[else (cons (car l) (loop (cdr l)))])))))
,@(if (ormap (lambda (p) (part-whole-page? p ht)) (part-parts d))
null
(let ([ps (cdr
(let flatten ([d d])
(cons d
(apply
append
(letrec ([flow-targets
(lambda (flow)
(apply append (map flow-element-targets (flow-paragraphs flow))))]
[flow-element-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 flow-element-targets (blockquote-paragraphs e)))]
[(delayed-flow-element? e)
null]))]
[para-targets
(lambda (para)
(let loop ([c (paragraph-content para)])
(cond
[(empty? c) null]
[else (let ([a (car c)])
(cond
[(toc-target-element? a)
(cons a (loop (cdr c)))]
[(element? a)
(append (loop (element-content a))
(loop (cdr c)))]
[(delayed-element? a)
(loop (cons (force-delayed-element a this d ht)
(cdr c)))]
[else
(loop (cdr c))]))])))]
[table-targets
(lambda (table)
(apply append
(map (lambda (flows)
(apply append (map (lambda (f)
(if (eq? f 'cont)
null
(flow-targets f)))
flows)))
(table-flowss table))))])
(apply append (map flow-element-targets (flow-paragraphs (part-flow d)))))
(map flatten (part-parts d))))))])
(if (null? ps)
null
`((div ((class "tocsub"))
(div ((class "tocsubtitle"))
"On this page:")
(table
((class "tocsublist")
(cellspacing "0"))
,@(map (lambda (p)
(parameterize ([current-no-links #t]
[extra-breaking? #t])
`(tr
(td
,@(if (part? p)
`((span ((class "tocsublinknumber"))
,@(format-number (collected-info-number (part-collected-info p))
'((tt nbsp)))))
'(""))
(a ((href ,(if (part? p)
(let ([dest (lookup p ht `(part ,(car (part-tags p))))])
(format "#~a"
`(part ,(car (part-tags p)))))
(format "#~a" (target-element-tag p))))
(class ,(if (part? p)
"tocsubseclink"
"tocsublink")))
,@(if (part? p)
(render-content (part-title-content p) d ht)
(render-content (element-content p) d ht)))))))
ps)))))))
,@(render-onthispage-contents d ri top)
,@(apply append
(map (lambda (t)
(render-table t d ht))
(render-table t d ri))
(filter auxiliary-table? (flow-paragraphs (part-flow d)))))))))
(define/public (render-one-part d ht fn number)
(define/private (render-onthispage-contents d ri top)
(if (ormap (lambda (p) (part-whole-page? p ri))
(part-parts d))
null
(let* ([nearly-top? (lambda (d)
(eq? top (collected-info-parent (part-collected-info d ri))))]
[ps ((if (nearly-top? d) values cdr)
(let flatten ([d d])
(apply
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 flow-element-targets (flow-paragraphs flow))))]
[flow-element-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 flow-element-targets (blockquote-paragraphs e)))]
[(delayed-flow-element? e)
null]))]
[para-targets
(lambda (para)
(let loop ([c (paragraph-content para)])
(cond
[(empty? c) null]
[else (let ([a (car c)])
(cond
[(toc-target-element? a)
(cons a (loop (cdr c)))]
[(element? a)
(append (loop (element-content a))
(loop (cdr c)))]
[(delayed-element? a)
(loop (cons (delayed-element-content a ri)
(cdr c)))]
[else
(loop (cdr c))]))])))]
[table-targets
(lambda (table)
(apply append
(map (lambda (flows)
(apply append (map (lambda (f)
(if (eq? f 'cont)
null
(flow-targets f)))
flows)))
(table-flowss table))))])
(apply append (map flow-element-targets (flow-paragraphs (part-flow d)))))
(map flatten (part-parts d)))))])
(if (null? ps)
null
`((div ((class "tocsub"))
(div ((class "tocsubtitle"))
"On this page:")
(table
((class "tocsublist")
(cellspacing "0"))
,@(map (lambda (p)
(parameterize ([current-no-links #t]
[extra-breaking? #t])
`(tr
(td
,@(if (part? p)
`((span ((class "tocsublinknumber"))
,@(format-number (collected-info-number
(part-collected-info p ri))
'((tt nbsp)))))
'(""))
(a ((href ,(if (part? p)
(format "#~a" (tag-key (car (part-tags p)) ri))
(format "#~a" (tag-key (target-element-tag p) ri))))
(class ,(if (part? p)
"tocsubseclink"
"tocsublink")))
,@(if (part? p)
(render-content (or (part-title-content p) '("???")) d ri)
(render-content (element-content p) d ri)))))))
ps))))))))
(define/public (render-one-part d ri fn number)
(parameterize ([current-output-file fn])
(let ([xpr `(html ()
(head
@ -226,32 +249,28 @@
(content "text-html; charset=utf-8")))
,@(let ([c (part-title-content d)])
(if c
`((title ,@(format-number number '(nbsp)) ,(content->string c this d ht)))
`((title ,@(format-number number '(nbsp)) ,(content->string c this d ri)))
null))
(link ((rel "stylesheet")
(type "text/css")
(href "scribble.css")
(title "default"))))
(body ,@(render-toc-view d ht)
(div ((class "main")) ,@(render-part d ht))))])
(body ,@(render-toc-view d ri)
(div ((class "main")) ,@(render-part d ri))))])
(install-file scribble-css)
(xml:write-xml/content (xml:xexpr->xml xpr)))))
(define/override (render-one d ht fn)
(render-one-part d ht fn null))
(define/override (render-one d ri fn)
(render-one-part d ri fn null))
(define/override (render-part d ht)
(let ([number (collected-info-number (part-collected-info d))])
(define/override (render-part d ri)
(let ([number (collected-info-number (part-collected-info d ri))])
`(,@(if (and (not (part-title-content d))
(null? number))
null
(if (and (styled-part? d)
(let ([s (styled-part-style d)])
(or (eq? s 'hidden)
(and (list? s)
(memq 'hidden s)))))
(if (part-style? d 'hidden)
(map (lambda (t)
`(a ((name ,(format "~a" `(part ,t))))))
`(a ((name ,(format "~a" (tag-key t ri))))))
(part-tags d))
`((,(case (length number)
[(0) 'h2]
@ -260,21 +279,21 @@
[else 'h5])
,@(format-number number '((tt nbsp)))
,@(map (lambda (t)
`(a ((name ,(format "~a" `(part ,t))))))
`(a ((name ,(format "~a" (tag-key t ri))))))
(part-tags d))
,@(if (part-title-content d)
(render-content (part-title-content d) d ht)
(render-content (part-title-content d) d ri)
null)))))
,@(render-flow* (part-flow d) d ht #f)
,@(render-flow* (part-flow d) d ri #f)
,@(let loop ([pos 1]
[secs (part-parts d)])
(if (null? secs)
null
(append
(render-part (car secs) ht)
(render-part (car secs) ri)
(loop (add1 pos) (cdr secs))))))))
(define/private (render-flow* p part ht special-last?)
(define/private (render-flow* p part ri special-last?)
;; Wrap each table with <p>, except for a trailing table
;; when `special-last?' is #t
(let loop ([f (flow-paragraphs p)])
@ -283,71 +302,78 @@
[(and (table? (car f))
(or (not special-last?)
(not (null? (cdr f)))))
(cons `(p ,@(render-flow-element (car f) part ht))
(cons `(p ,@(render-flow-element (car f) part ri))
(loop (cdr f)))]
[else
(append (render-flow-element (car f) part ht)
(append (render-flow-element (car f) part ri)
(loop (cdr f)))])))
(define/override (render-flow p part ht)
(render-flow* p part ht #t))
(define/override (render-flow p part ri)
(render-flow* p part ri #t))
(define/override (render-paragraph p part ht)
(define/override (render-paragraph p part ri)
`((p ,@(if (styled-paragraph? p)
`(((class ,(styled-paragraph-style p))))
null)
,@(super render-paragraph p part ht))))
,@(super render-paragraph p part ri))))
(define/override (render-element e part ht)
(define/override (render-element e part ri)
(cond
[(hover-element? e)
`((span ((title ,(hover-element-text e))) ,@(render-plain-element e part ri)))]
[(target-element? e)
`((a ((name ,(target-element-tag e))))
,@(render-plain-element e part ht))]
`((a ((name ,(format "~a" (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 ([dest (lookup part ht (link-element-tag e))])
(let ([dest (resolve-get part ri (link-element-tag e))])
(if dest
`((a ((href ,(format "~a~a~a"
(from-root (car dest)
(from-root (relative->path (car dest))
(get-dest-directory))
(if (caddr dest)
""
"#")
(if (caddr dest)
""
(link-element-tag e))))
(cadddr dest))))
,@(if (string? (element-style e))
`((class ,(element-style e)))
null))
,@(if (null? (element-content e))
(render-content (strip-aux (cadr dest)) part ht)
(render-content (element-content e) part ht))))
(begin (fprintf (current-error-port) "Undefined link: ~s~n" (link-element-tag e)) ; XXX Add source info
`((font ((class "badlink"))
,@(if (null? (element-content e))
`(,(format "~s" (link-element-tag e)))
(render-plain-element e part ht))))))))]
[else (render-plain-element e part ht)]))
(render-content (strip-aux (cadr dest)) part ri)
(render-content (element-content e) part ri))))
(begin
(when #f
(fprintf (current-error-port)
"Undefined link: ~s~n"
(tag-key (link-element-tag e) ri)))
`((font ((class "badlink"))
,@(if (null? (element-content e))
`(,(format "~s" (tag-key (link-element-tag e) ri)))
(render-plain-element e part ri))))))))]
[else (render-plain-element e part ri)]))
(define/private (render-plain-element e part ht)
(define/private (render-plain-element e part ri)
(let ([style (and (element? e)
(element-style e))])
(cond
[(symbol? style)
(case style
[(italic) `((i ,@(super render-element e part ht)))]
[(bold) `((b ,@(super render-element e part ht)))]
[(tt) `((tt ,@(super render-element e part ht)))]
[(sf) `((b (font ([size "-1"][face "Helvetica"]) ,@(super render-element e part ht))))]
[(subscript) `((sub ,@(super render-element e part ht)))]
[(superscript) `((sup ,@(super render-element e part ht)))]
[(italic) `((i ,@(super render-element e part ri)))]
[(bold) `((b ,@(super render-element e part ri)))]
[(tt) `((tt ,@(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"])
,@(let ([str (content->string (element-content e))])
(map (lambda (c) 'nbsp) (string->list str)))))]
[else (error 'html-render "unrecognized style symbol: ~e" style)])]
[(string? style)
`((span ([class ,style]) ,@(super render-element e part ht)))]
`((span ([class ,style]) ,@(super render-element e part ri)))]
[(and (pair? style)
(eq? (car style) 'show-color))
`((font ((style ,(format "background-color: ~a"
@ -357,16 +383,16 @@
(cdr style))))))
(tt nbsp nbsp nbsp nbsp nbsp))
nbsp
,@(super render-element e part ht))]
,@(super render-element e part ri))]
[(target-url? style)
(if (current-no-links)
(super render-element e part ht)
(super render-element e part ri)
(parameterize ([current-no-links #t])
`((a ((href ,(target-url-addr style))) ,@(super render-element e part ht)))))]
`((a ((href ,(target-url-addr style))) ,@(super render-element e part ri)))))]
[(image-file? style) `((img ((src ,(install-file (image-file-path style))))))]
[else (super render-element e part ht)])))
[else (super render-element e part ri)])))
(define/override (render-table t part ht)
(define/override (render-table t part ri)
`((table ((cellspacing "0")
,@(case (table-style t)
[(boxed) '((class "boxed"))]
@ -423,36 +449,36 @@
[(eq? 'cont (car ds)) (loop (+ n 1) (cdr ds))]
[else n])))))
null))
,@(render-flow d part ht))
,@(render-flow d part ri))
(loop (cdr ds) (cdr as) (cdr vas)))))))))
(table-flowss t)
(cdr (or (and (list? (table-style t))
(assoc 'row-styles (or (table-style t) null)))
(cons #f (map (lambda (x) #f) (table-flowss t)))))))))
(define/override (render-blockquote t part ht)
(define/override (render-blockquote t part ri)
`((blockquote ,@(if (string? (blockquote-style t))
`(((class ,(blockquote-style t))))
null)
,@(apply append
(map (lambda (i)
(render-flow-element i part ht))
(render-flow-element i part ri))
(blockquote-paragraphs t))))))
(define/override (render-itemization t part ht)
(define/override (render-itemization t part ri)
`((ul
,@(map (lambda (flow)
`(li ,@(render-flow flow part ht)))
`(li ,@(render-flow flow part ri)))
(itemization-flows t)))))
(define/override (render-other i part ht)
(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))
`(span ((class "mywbr")) " ")
(render-other (substring i (cdar m)) part ht))
(render-other (substring i (cdar m)) part ri))
(list i)))]
[(eq? i 'mdash) `(" " ndash " ")]
[(eq? i 'hline) `((hr))]
@ -470,7 +496,9 @@
(class %
(inherit render-one
render-one-part
render-content)
render-content
part-whole-page?
format-number)
(define/override (get-suffix) #"")
@ -479,10 +507,16 @@
(current-subdirectory))
(super get-dest-directory)))
(define/private (derive-filename d ht)
(define/private (derive-filename d)
(let ([fn (format "~a.html" (regexp-replace*
"[^-a-zA-Z0-9_=]"
(format "~a" (car (part-tags d)))
(let ([s (cadr (car (part-tags d)))])
(if (string? s)
s
(if (part-title-content d)
(content->string (part-title-content d))
;; last-ditch effort to make up a unique name:
(format "???~a" (eq-hash-code d)))))
"_"))])
(when ((string-length fn) . >= . 48)
(error "file name too long (need a tag):" fn))
@ -493,28 +527,25 @@
(build-path fn "index.html"))
fns)))
(define/override (current-part-whole-page?)
(define/override (current-part-whole-page? d)
((collecting-sub) . <= . 2))
(define/private (toc-part? d)
(and (styled-part? d)
(let ([st (styled-part-style d)])
(or (eq? 'toc st)
(and (list? st) (memq 'toc st))))))
(part-style? d 'toc))
(define/override (collect-part d parent ht number)
(define/override (collect-part d parent ci number)
(let ([prev-sub (collecting-sub)])
(parameterize ([collecting-sub (if (toc-part? d)
1
(add1 prev-sub))])
(if (= 1 prev-sub)
(let ([filename (derive-filename d ht)])
(let ([filename (derive-filename d)])
(parameterize ([current-output-file (build-path (path-only (current-output-file))
filename)])
(super collect-part d parent ht number)))
(super collect-part d parent ht number)))))
(super collect-part d parent ci number)))
(super collect-part d parent ci number)))))
(define/override (render ds fns ht)
(define/override (render ds fns ri)
(map (lambda (d fn)
(printf " [Output to ~a/index.html]\n" fn)
(unless (directory-exists? fn)
@ -523,7 +554,7 @@
(let ([fn (build-path fn "index.html")])
(with-output-to-file fn
(lambda ()
(render-one d ht fn))
(render-one d ri fn))
'truncate/replace))))
ds
fns))
@ -538,8 +569,8 @@
(inherit render-table)
(define/private (find-siblings d)
(let ([parent (collected-info-parent (part-collected-info d))])
(define/private (find-siblings d ri)
(let ([parent (collected-info-parent (part-collected-info d ri))])
(let loop ([l (if parent
(part-parts parent)
(if (null? (part-parts d))
@ -552,12 +583,12 @@
(cadr l)))]
[else (loop (cdr l) (car l))]))))
(define/private (part-parent d)
(collected-info-parent (part-collected-info d)))
(define/private (part-parent d ri)
(collected-info-parent (part-collected-info d ri)))
(define/private (navigation d ht)
(let ([parent (part-parent d)])
(let*-values ([(prev next) (find-siblings d)]
(define/private (navigation d ri)
(let ([parent (part-parent d ri)])
(let*-values ([(prev next) (find-siblings d ri)]
[(prev) (if prev
(let loop ([prev prev])
(if (and (toc-part? prev)
@ -575,17 +606,17 @@
parent
(toc-part? parent))
(let-values ([(prev next)
(find-siblings parent)])
(find-siblings parent ri)])
next)]
[else next])]
[(index) (let loop ([d d])
(let ([p (part-parent d)])
(let ([p (part-parent d ri)])
(if p
(loop p)
(let ([subs (part-parts d)])
(and (pair? subs)
(let ([d (car (last-pair subs))])
(and (equal? '("Index") (part-title-content d))
(and (part-style? d 'index)
d)))))))])
`(,@(render-table (make-table
'at-left
@ -614,9 +645,9 @@
(make-link-element
#f
index-content
`(part ,(car (part-tags index))))))))))
(car (part-tags index)))))))))
null))))
d ht)
d ri)
,@(render-table (make-table
'at-right
(list
@ -628,7 +659,7 @@
(make-element
(if parent
(make-target-url (if prev
(derive-filename prev ht)
(derive-filename prev)
"index.html"))
"nonavigation")
prev-content)
@ -637,34 +668,34 @@
(if parent
(make-target-url
(if (toc-part? parent)
(derive-filename parent ht)
(derive-filename parent)
"index.html"))
"nonavigation")
up-content)
sep-element
(make-element
(if next
(make-target-url (derive-filename next ht))
(make-target-url (derive-filename next))
"nonavigation")
next-content))))))))
d
ht)))))
ri)))))
(define/override (render-part d ht)
(let ([number (collected-info-number (part-collected-info d))])
(define/override (render-part d ri)
(let ([number (collected-info-number (part-collected-info d ri))])
(cond
[(and (not (on-separate-page))
(or (= 1 (length number))
(next-separate-page)))
;; Render as just a link, and put the actual
;; content in a new file:
(let* ([filename (derive-filename d ht)]
(let* ([filename (derive-filename d)]
[full-path (build-path (path-only (current-output-file))
filename)])
(parameterize ([on-separate-page #t])
(with-output-to-file full-path
(lambda ()
(render-one-part d ht full-path number))
(render-one-part d ri full-path number))
'truncate/replace)
null))]
[else
@ -673,14 +704,14 @@
[on-separate-page #f])
(if sep?
;; Navigation bars;
`(,@(navigation d ht)
`(,@(navigation d ri)
(p nbsp)
,@(super render-part d ht)
,@(super render-part d ri)
(p nbsp)
,@(navigation d ht)
,@(navigation d ri)
(p nbsp))
;; Normal section render
(super render-part d ht))))])))
(super render-part d ri))))])))
(super-new)))

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

@ -18,13 +18,12 @@
render-flow-element
render-content
install-file
format-number
lookup)
format-number)
(define (define-color s s2)
(printf "\\newcommand{\\~a}[1]{{\\mytexttt{\\color{~a}{#1}}}}\n" s s2))
(define/override (render-one d ht fn)
(define/override (render-one d ri fn)
(printf "\\documentclass{article}\n")
(printf "\\parskip=10pt%\n")
(printf "\\parindent=0pt%\n")
@ -75,17 +74,16 @@
(printf "\\begin{document}\n\\sloppy\n")
(when (part-title-content d)
(printf "\\title{")
(render-content (part-title-content d) d ht)
(render-content (part-title-content d) d ri)
(printf "}\\maketitle\n"))
(render-part d ht)
(render-part d ri)
(printf "\\end{document}\n"))
(define/override (render-part d ht)
(let ([number (collected-info-number (part-collected-info d))])
(define/override (render-part d ri)
(let ([number (collected-info-number (part-collected-info d ri))])
(when (and (part-title-content d)
(pair? number))
(when (and (styled-part? d)
(eq? 'index (styled-part-style d)))
(when (part-style? d 'index)
(printf "\\twocolumn\n\\parskip=0pt\n\\addcontentsline{toc}{section}{Index}\n"))
(printf "\\~a~a{"
(case (length number)
@ -97,20 +95,19 @@
(not (car number)))
"*"
""))
(render-content (part-title-content d) d ht)
(render-content (part-title-content d) d ri)
(printf "}")
(when (and (styled-part? d)
(eq? 'index (styled-part-style d)))
(when (part-style? d 'index)
(printf "\n\n")))
(for-each (lambda (t)
(printf "\\label{t:~a}" (t-encode `(part ,t))))
(printf "\\label{t:~a}" (t-encode (tag-key t ri))))
(part-tags d))
(render-flow (part-flow d) d ht)
(for-each (lambda (sec) (render-part sec ht))
(render-flow (part-flow d) d ri)
(for-each (lambda (sec) (render-part sec ri))
(part-parts d))
null))
(define/override (render-paragraph p part ht)
(define/override (render-paragraph p part ri)
(printf "\n\n")
(let ([margin? (and (styled-paragraph? p)
(equal? "refpara" (styled-paragraph-style p)))])
@ -118,28 +115,35 @@
(printf "\\marginpar{\\footnotesize "))
(if (toc-paragraph? p)
(printf "\\newpage \\tableofcontents \\newpage")
(super render-paragraph p part ht))
(super render-paragraph p part ri))
(when margin?
(printf "}")))
(printf "\n\n")
null)
(define/override (render-element e part ht)
(define/override (render-element e part ri)
(let ([part-label? (and (link-element? e)
(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))))
(printf "\\label{t:~a}" (t-encode (tag-key (target-element-tag e) ri))))
(when part-label?
(printf "\\S")
(render-content (let ([dest (lookup part ht (link-element-tag e))])
(render-content (let ([dest (resolve-get part ri (link-element-tag e))])
(if dest
(format-number (cadr dest) null)
(if (list? (cadr dest))
(format-number (cadr dest) null)
(begin
(fprintf (current-error-port)
"Internal tag error: ~s -> ~s\n"
(link-element-tag e)
dest)
'("!!!")))
(list "???")))
part
ht)
ri)
(printf " ``"))
(let ([style (and (element? e)
(element-style e))]
@ -147,7 +151,7 @@
(printf "{\\~a{" s)
(parameterize ([rendering-tt (or tt?
(rendering-tt))])
(super render-element e part ht))
(super render-element e part ri))
(printf "}}"))])
(cond
[(symbol? style)
@ -155,6 +159,7 @@
[(italic) (wrap e "textit" #f)]
[(bold) (wrap e "textbf" #f)]
[(tt) (wrap e "mytexttt" #t)]
[(nobreak) (super render-element e part ri)]
[(sf) (wrap e "textsf" #f)]
[(subscript) (wrap e "textsub" #f)]
[(superscript) (wrap e "textsuper" #f)]
@ -170,12 +175,12 @@
[(image-file? style)
(let ([fn (install-file (image-file-path style))])
(printf "\\includegraphics{~a}" fn))]
[else (super render-element e part ht)])))
[else (super render-element e part ri)])))
(when part-label?
(printf "''"))
(when (and (link-element? e)
(show-link-page-numbers))
(printf ", \\pageref{t:~a}" (t-encode (link-element-tag e))))
(printf ", \\pageref{t:~a}" (t-encode (tag-key (link-element-tag e) ri))))
null))
(define/private (t-encode s)
@ -192,7 +197,7 @@
(format "x~x" (char->integer c))]))
(string->list (format "~s" s)))))
(define/override (render-table t part ht)
(define/override (render-table t part ri)
(let* ([boxed? (eq? 'boxed (table-style t))]
[index? (eq? 'index (table-style t))]
[inline? (and (not boxed?)
@ -262,7 +267,7 @@
[else n]))])
(unless (= cnt 1)
(printf "\\multicolumn{~a}{l}{" cnt))
(render-flow (car flows) part ht)
(render-flow (car flows) part ri)
(unless (= cnt 1)
(printf "}"))
(unless (null? (list-tail flows cnt))
@ -284,25 +289,25 @@
""))))))
null)
(define/override (render-itemization t part ht)
(define/override (render-itemization t part ri)
(printf "\n\n\\begin{itemize}\n")
(for-each (lambda (flow)
(printf "\n\n\\item ")
(render-flow flow part ht))
(render-flow flow part ri))
(itemization-flows t))
(printf "\n\n\\end{itemize}\n")
null)
(define/override (render-blockquote t part ht)
(define/override (render-blockquote t part ri)
(printf "\n\n\\begin{quote}\n")
(parameterize ([current-table-mode (list "blockquote" t)])
(for-each (lambda (e)
(render-flow-element e part ht))
(render-flow-element e part ri))
(blockquote-paragraphs t)))
(printf "\n\n\\end{quote}\n")
null)
(define/override (render-other i part ht)
(define/override (render-other i part ri)
(cond
[(string? i) (display-protected i)]
[(symbol? i) (display
@ -362,11 +367,11 @@
;; ----------------------------------------
(define/override (table-of-contents sec ht)
(define/override (table-of-contents sec ri)
;; FIXME: isn't local to the section
(make-toc-paragraph null))
(define/override (local-table-of-contents part ht)
(define/override (local-table-of-contents part ri)
(make-paragraph null))
;; ----------------------------------------

317
collects/scribble/manual.ss
View File

@ -10,6 +10,8 @@
(lib "class.ss")
(lib "stxparam.ss"))
(require-for-syntax (lib "stxparam.ss"))
(require-for-label (lib "lang.ss" "big")
(lib "class.ss"))
(provide (all-from "basic.ss"))
@ -50,10 +52,24 @@
(define (to-element/id s)
(make-element "schemesymbol" (list (to-element/no-color s))))
(define (keep-s-expr ctx s v)
(define-syntax (keep-s-expr stx)
(syntax-case stx ()
[(_ ctx s srcloc)
(let ([sv (syntax-e #'s)])
(if (or (number? sv)
(boolean? sv)
(and (pair? sv)
(identifier? (car sv))
(module-identifier=? #'cons (car sv))))
;; We know that the context is irrelvant
#'s
;; Context may be relevant:
#'(*keep-s-expr s ctx)))]))
(define (*keep-s-expr s ctx)
(if (symbol? s)
(make-just-context s ctx)
s))
(define (add-sq-prop s name val)
(if (eq? name 'paren-shape)
(make-shaped-parens s val)
@ -158,9 +174,9 @@
(define (exec . str)
(make-element 'tt (decode-content str)))
(define (Flag . str)
(make-element 'tt (cons "-" (decode-content str))))
(make-element 'no-break (list (make-element 'tt (cons "-" (decode-content str))))))
(define (DFlag . str)
(make-element 'tt (cons "--" (decode-content str))))
(make-element 'no-break (list (make-element 'tt (cons "--" (decode-content str))))))
(define (envvar . str)
(make-element 'tt (decode-content str)))
(define (indexed-envvar . str)
@ -198,9 +214,8 @@
(elem (method a b) " in " (scheme a))]))
(define (*method sym id)
(let ([tag (format "~a::~a"
(register-scheme-definition id)
sym)])
(let ([tag (method-tag (register-scheme-definition id #t)
sym)])
(make-element
"schemesymbol"
(list (make-link-element
@ -208,6 +223,9 @@
(list (symbol->string sym))
tag)))))
(define (method-tag vtag sym)
(list 'meth
(format "~a::~a" (cadr vtag) sym)))
;; ----------------------------------------
@ -222,7 +240,7 @@
(provide deftech tech techlink)
(define (*tech make-elem style s)
(define (*tech make-elem style doc s)
(let* ([c (decode-content s)]
[s (regexp-replace* #px"[-\\s]+"
(regexp-replace
@ -235,26 +253,27 @@
" ")])
(make-elem style
c
(format "tech-term:~a" s))))
(list 'tech (doc-prefix doc s)))))
(define (deftech . s)
(let* ([e (apply defterm s)]
[t (*tech make-target-element #f (list e))])
[t (*tech make-target-element #f #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))
(define (tech #:doc [doc #f] . s)
(*tech make-link-element "techlink" doc s))
(define (techlink . s)
(*tech make-link-element #f s))
(define (techlink #:doc [doc #f] . s)
(*tech make-link-element #f doc s))
;; ----------------------------------------
(provide defproc defproc* defstruct defthing defparam defboolparam
(provide declare-exporting
defproc defproc* defstruct defthing defparam defboolparam
defform defform* defform/subs defform*/subs defform/none
defidform
specform specform/subs
@ -262,6 +281,33 @@
schemegrammar schemegrammar*
var svar void-const undefined-const)
(define-syntax declare-exporting
(syntax-rules ()
[(_ lib ...) (*declare-exporting '(lib ...))]))
(define (*declare-exporting libs)
(make-part-collect-decl
(make-collect-element #f
null
(lambda (ri)
(collect-put! ri '(exporting-libraries #f)libs)))))
(define-syntax (quote-syntax/loc stx)
(syntax-case stx ()
[(_ id)
(with-syntax ([loc
(let ([s #'id])
(list (syntax-source s)
(syntax-line s)
(syntax-column s)
(syntax-position s)
(syntax-span s)))])
#'(let ([s (quote-syntax id)])
(datum->syntax-object s
(syntax-e s)
'loc
s)))]))
(define void-const
(schemeresultfont "#<void>"))
(define undefined-const
@ -304,13 +350,13 @@
(syntax-rules ()
[(_ (id arg ...) result desc ...)
(defproc* [[(id arg ...) result]] desc ...)]))
(define-syntax defproc*
(define-syntax defproc*
(syntax-rules ()
[(_ [[(id arg ...) result] ...] desc ...)
(defproc* #:mode procedure #:within #f [[(id arg ...) result] ...] desc ...)]
[(_ #:mode m #:within cl [[(id arg ...) result] ...] desc ...)
(*defproc 'm (quote-syntax cl)
(list (quote-syntax id) ...)
(*defproc 'm (quote-syntax/loc cl)
(list (quote-syntax/loc id) ...)
'[(id arg ...) ...]
(list (list (lambda () (arg-contract arg)) ...) ...)
(list (lambda () (schemeblock0 result)) ...)
@ -328,7 +374,7 @@
(define-syntax **defstruct
(syntax-rules ()
[(_ name ([field field-contract] ...) immutable? transparent? desc ...)
(*defstruct (quote-syntax name) 'name
(*defstruct (quote-syntax/loc name) 'name
'([field field-contract] ...) (list (lambda () (schemeblock0 field-contract)) ...)
#t #t (lambda () (list desc ...)))]))
(define-syntax (defform*/subs stx)
@ -347,7 +393,7 @@
[spec-id
(syntax-case #'spec ()
[(name . rest) #'name])])
#'(*defforms (quote-syntax spec-id) '(lit ...)
#'(*defforms (quote-syntax/loc spec-id) '(lit ...)
'(spec spec1 ...)
(list (lambda (x) (schemeblock0 new-spec))
(lambda (ignored) (schemeblock0 spec1)) ...)
@ -381,7 +427,7 @@
(define-syntax (defidform stx)
(syntax-case stx ()
[(_ spec-id desc ...)
#'(*defforms (quote-syntax spec-id) null
#'(*defforms (quote-syntax/loc spec-id) null
'(spec-id)
(list (lambda (x) (make-paragraph (list x))))
null
@ -440,7 +486,7 @@
(define-syntax defthing
(syntax-rules ()
[(_ id result desc ...)
(*defthing (quote-syntax id) 'id (quote-syntax result) (lambda () (list desc ...)))]))
(*defthing (quote-syntax/loc id) 'id (quote-syntax result) (lambda () (list desc ...)))]))
(define-syntax defparam
(syntax-rules ()
[(_ id arg contract desc ...)
@ -494,6 +540,27 @@
type-sym)
""))))
(define (annote-exporting-library e)
(make-delayed-element
(lambda (render p ri)
(let ([from (resolve-get p ri '(exporting-libraries #f))])
(if (and from
(pair? from))
(list (make-hover-element
#f
(list e)
(string-append
"Provided from: "
(let loop ([from from])
(if (null? (cdr from))
(format "~s" (car from))
(format "~s, ~a"
(car from)
(loop (cdr from))))))))
(list e))))
(lambda () e)
(lambda () e)))
(define (*defproc mode within-id
stx-ids prototypes arg-contractss result-contracts content-thunk)
(let ([spacer (hspace 1)]
@ -589,34 +656,40 @@
(hspace 1)
(if first?
(let* ([mname (car prototype)]
[tag (format "~a::~a"
(register-scheme-definition within-id)
mname)]
[ctag (register-scheme-definition within-id #t)]
[tag (method-tag ctag mname)]
[content (list (*method mname within-id))])
(make-toc-target-element
#f
(list (make-index-element #f
content
tag
(list (symbol->string mname))
content))
tag))
(if tag
(make-toc-target-element
#f
(list (make-index-element #f
content
tag
(list (symbol->string mname))
content))
tag)
(car content)))
(*method (car prototype) within-id))))]
[else
(if first?
(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)))])]
(let ([tag (register-scheme-definition stx-id #t)]
[content (list
(annote-exporting-library
(to-element (make-just-context (car prototype)
stx-id))))])
(if tag
(make-toc-target-element
#f
(list (make-index-element #f
content
tag
(list (symbol->string (car prototype)))
content))
tag)
(car content)))
(annote-exporting-library
(to-element (make-just-context (car prototype)
stx-id))))])]
[(flat-size) (+ (prototype-size (cdr prototype) + +)
(element-width tagged))]
[(short?) (or (flat-size . < . 40)
@ -799,16 +872,19 @@
(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))
name))
#t)])
(if tag
(inner-make-target-element
#f
(list
(make-index-element #f
(list content)
tag
(list name)
(list (schemeidfont (make-element "schemevaluelink" (list name))))))
tag)
content))
(cdr wrappers))))
(define (*defstruct stx-id name fields field-contracts immutable? transparent? content-thunk)
@ -826,9 +902,10 @@
(make-target-element*
make-toc-target-element
stx-id
(to-element (if (pair? name)
(make-just-context (car name) stx-id)
stx-id))
(annote-exporting-library
(to-element (if (pair? name)
(make-just-context (car name) stx-id)
stx-id)))
(let ([name (if (pair? name)
(car name)
name)])
@ -975,16 +1052,19 @@
(list (make-flow
(list
(make-paragraph
(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))
(list (let ([tag (register-scheme-definition stx-id #t)]
[content (list (annote-exporting-library
(to-element (make-just-context name stx-id))))])
(if tag
(make-toc-target-element
#f
(list (make-index-element #f
content
tag
(list (symbol->string name))
content))
tag)
(car content)))
spacer ":" spacer
(to-element result-contract))))))))
(content-thunk))))
@ -1026,25 +1106,32 @@
(make-paragraph
(list
(to-element
`(,x
. ,(cdr form)))))))
`(,x . ,(cdr form)))))))
(and kw-id
(eq? form (car forms))
(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))))))))
(let ([tag (register-scheme-definition kw-id #t)]
[stag (register-scheme-form-definition kw-id)]
[content (list (annote-exporting-library
(to-element (make-just-context (if (pair? form)
(car form)
form)
kw-id))))])
(if tag
(make-toc-target-element
#f
(list
(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))
stag)
(car content)))))))))
forms form-procs)
(if (null? sub-procs)
null
@ -1156,17 +1243,25 @@
(make-paragraph (list (hspace 2) (apply tt s))))
(define (elemtag t . body)
(make-target-element #f (decode-content body) t))
(make-target-element #f (decode-content body) `(elem ,t)))
(define (elemref t . body)
(make-link-element #f (decode-content body) t))
(make-link-element #f (decode-content body) `(elem ,t)))
(provide elemtag elemref)
(define (secref s)
(make-link-element #f null `(part ,s)))
(define (seclink tag . s)
(make-link-element #f (decode-content s) `(part ,tag)))
(define (doc-prefix doc s)
(if doc
(format "~a:~a"
(module-path-prefix->string doc)
s)
s))
(define (secref s #:doc [doc #f])
(make-link-element #f null `(part ,(doc-prefix doc s))))
(define (seclink tag #:doc [doc #f] . s)
(make-link-element #f (decode-content s) `(part ,(doc-prefix doc tag))))
(define (*schemelink stx-id id . s)
(make-link-element #f (decode-content s) (register-scheme-definition stx-id)))
(make-link-element #f (decode-content s) (or (register-scheme-definition stx-id)
(format "--UNDEFINED:~a--" (syntax-e stx-id)))))
(define-syntax schemelink
(syntax-rules ()
[(_ id . content) (*schemelink (quote-syntax id) 'id . content)]))
@ -1261,7 +1356,7 @@
(define id val)))]))
(define-syntax (class-doc-info stx)
(syntax-case stx (object%)
(syntax-case* stx (object%) module-label-identifier=?
[(_ object%) #'#f]
[(_ id) (class-id->class-doc-info-id #'id)]))
@ -1357,18 +1452,22 @@
(list (make-flow
(list
(make-paragraph
(list (let ([tag (register-scheme-definition stx-id)]
[content (list (to-element stx-id))])
((if whole-page?
make-page-target-element
make-toc-target-element)
#f
(list (make-index-element #f
content
tag
(list (symbol->string (syntax-e stx-id)))
content))
tag))
(list (let ([tag (register-scheme-definition stx-id #t)]
[content (list (annote-exporting-library (to-element stx-id)))])
(if tag
((if whole-page?
make-page-target-element
make-toc-target-element)
#f
(if whole-page?
content ; title is already an index entry
(list (make-index-element #f
content
tag
(list (symbol->string (syntax-e stx-id)))
content)))
tag)
(car content)))
spacer ":" spacer
(if super
(scheme class?)
@ -1403,12 +1502,12 @@
[(_ name super (intf ...) body ...)
(define-class-doc-info name
(syntax-parameterize ([current-class (quote-syntax name)])
(register-class (quote-syntax name)
(register-class (quote-syntax/loc name)
(class-doc-info super)
(list (class-doc-info intf) ...)
(lambda (whole-page?)
(list
(*defclass (quote-syntax name)
(*defclass (quote-syntax/loc name)
(quote-syntax super)
(list (quote-syntax intf) ...)
whole-page?)))
@ -1419,12 +1518,12 @@
[(_ name (intf ...) body ...)
(define-class-doc-info name
(syntax-parameterize ([current-class (quote-syntax name)])
(register-class (quote-syntax name)
(register-class (quote-syntax/loc name)
#f
(list (class-doc-info intf) ...)
(lambda (whole-page?)
(list
(*defclass (quote-syntax name)
(*defclass (quote-syntax/loc name)
#f
(list (quote-syntax intf) ...)
whole-page?)))

17
collects/scribble/run.ss
View File

@ -67,7 +67,7 @@
(when dir
(make-directory* dir))
(let ([renderer (new ((current-render-mixin) render% )
(let ([renderer (new ((current-render-mixin) render%)
[dest-dir dir])])
(let* ([fns (map (lambda (fn)
(let-values ([(base name dir?) (split-path fn)])
@ -82,8 +82,15 @@
[files (reverse (current-info-input-files))])
(if (null? files)
info
(loop (send renderer load-info (car files) info)
(loop (let ([s (with-input-from-file (car files) read)])
(send renderer deserialize-info s info)
info)
(cdr files))))])
(send renderer render docs fns info))
(when (current-info-output-file)
(send renderer save-info (current-info-output-file) info)))))))
(let ([r-info (send renderer resolve docs fns info)])
(send renderer render docs fns r-info)
(when (current-info-output-file)
(let ([s (send renderer serialize-info r-info)])
(with-output-to-file (current-info-output-file)
(lambda ()
(write s))
'truncate/replace))))))))))

237
collects/scribble/scheme.ss
View File

@ -1,9 +1,10 @@
(module scheme mzscheme
(module scheme (lib "lang.ss" "big")
(require "struct.ss"
"basic.ss"
(lib "class.ss")
(lib "for.ss")
(lib "modcollapse.ss" "syntax"))
(lib "main-collects.ss" "setup")
(lib "modresolve.ss" "syntax"))
(provide define-code
to-element
@ -33,13 +34,7 @@
(define opt-color "schemeopt")
(define current-keyword-list
;; This is temporary, until the MzScheme manual is filled in...
(make-parameter null #;'(require
provide
new send else => and or
define-syntax syntax-rules define-struct
quasiquote unquote unquote-splicing
syntax quasisyntax unsyntax unsyntax-splicing)))
(make-parameter null))
(define current-variable-list
(make-parameter null))
(define current-meta-list
@ -51,7 +46,76 @@
(define-struct spaces (pre cnt post))
(define (typeset c multi-line? prefix1 prefix suffix color?)
(define (literalize-spaces i)
(let ([m (regexp-match-positions #rx" +" i)])
(if m
(make-spaces (literalize-spaces (substring i 0 (caar m)))
(- (cdar m) (caar m))
(literalize-spaces (substring i (cdar m))))
i)))
(define (typeset-atom c out color? quote-depth)
(let-values ([(s it? sub?)
(let ([c (syntax-e c)])
(let ([s (format "~s" c)])
(if (and (symbol? c)
((string-length s) . > . 1)
(char=? (string-ref s 0) #\_))
(values (substring s 1) #t #f)
(values s #f #f))))]
[(is-var?) (and (identifier? c)
(memq (syntax-e c) (current-variable-list)))])
(if (or (element? (syntax-e c))
(delayed-element? (syntax-e c)))
(out (syntax-e c) #f)
(out (if (and (identifier? c)
color?
(quote-depth . <= . 0)
(not (or it? is-var?)))
(let ([tag (register-scheme c)])
(if tag
(make-delayed-element
(lambda (renderer sec ri)
(let* ([vtag `(def ,tag)]
[stag `(form ,tag)]
[sd (resolve-get sec ri stag)])
(list
(cond
[sd
(make-link-element "schemesyntaxlink" (list s) stag)]
[else
(make-link-element "schemevaluelink" (list s) vtag)]))))
(lambda () s)
(lambda () s))
s))
(literalize-spaces s))
(cond
[(positive? quote-depth) value-color]
[(let ([v (syntax-e c)])
(or (number? v)
(string? v)
(bytes? v)
(char? v)
(regexp? v)
(byte-regexp? v)
(boolean? v)))
value-color]
[(identifier? c)
(cond
[is-var?
variable-color]
[(and (identifier? c)
(memq (syntax-e c) (current-keyword-list)))
keyword-color]
[(and (identifier? c)
(memq (syntax-e c) (current-meta-list)))
meta-color]
[it? variable-color]
[else symbol-color])]
[else paren-color])
(string-length s)))))
(define (gen-typeset c multi-line? prefix1 prefix suffix color?)
(let* ([c (syntax-ize c 0)]
[content null]
[docs null]
@ -80,6 +144,10 @@
[(and (element? v)
(= 1 (length (element-content v))))
(sz-loop (car (element-content v)))]
[(element? v)
(element-width v)]
[(delayed-element? v)
(element-width v)]
[(spaces? v)
(+ (sz-loop (spaces-pre v))
(spaces-cnt v)
@ -176,13 +244,6 @@
c)
(loop (cdr l)
(cons (car l) prev))))]))))))
(define (literalize-spaces i)
(let ([m (regexp-match-positions #rx" +" i)])
(if m
(make-spaces (literalize-spaces (substring i 0 (caar m)))
(- (cdar m) (caar m))
(literalize-spaces (substring i (cdar m))))
i)))
(define (no-fancy-chars s)
(cond
[(eq? s 'rsquo) "'"]
@ -359,65 +420,10 @@
(set! src-col (+ orig-col (syntax-span c)))))]
[else
(advance c init-line!)
(let-values ([(s it? sub?)
(let ([c (syntax-e c)])
(let ([s (format "~s" c)])
(if (and (symbol? c)
((string-length s) . > . 1)
(char=? (string-ref s 0) #\_))
(values (substring s 1) #t #f)
(values s #f #f))))]
[(is-var?) (and (identifier? c)
(memq (syntax-e c) (current-variable-list)))])
(if (element? (syntax-e c))
(out (syntax-e c) #f)
(out (if (and (identifier? c)
color?
(quote-depth . <= . 0)
(not (or it? is-var?)))
(make-delayed-element
(lambda (renderer sec ht)
(let* ([vtag (register-scheme-definition c)]
[stag (register-scheme-form-definition c)]
[vd (hash-table-get ht vtag #f)]
[sd (hash-table-get ht stag #f)])
(list
(cond
[sd
(make-link-element "schemesyntaxlink" (list s) stag)]
[vd
(make-link-element "schemevaluelink" (list s) vtag)]
[else s]))))
(lambda () s)
(lambda () s))
(literalize-spaces s))
(cond
[(positive? quote-depth) value-color]
[(or (number? (syntax-e c))
(string? (syntax-e c))
(bytes? (syntax-e c))
(char? (syntax-e c))
(regexp? (syntax-e c))
(byte-regexp? (syntax-e c))
(boolean? (syntax-e c)))
value-color]
[(identifier? c)
(cond
[is-var?
variable-color]
[(and (identifier? c)
(memq (syntax-e c) (current-keyword-list)))
keyword-color]
[(and (identifier? c)
(memq (syntax-e c) (current-meta-list)))
meta-color]
[it? variable-color]
[else symbol-color])]
[else paren-color])
(string-length s)))
(set! src-col (+ src-col (or (syntax-span c) 1)))
#;
(hash-table-put! next-col-map src-col dest-col))])))
(typeset-atom c out color? quote-depth)
(set! src-col (+ src-col (or (syntax-span c) 1)))
#;
(hash-table-put! next-col-map src-col dest-col)])))
(out prefix1 #f)
(set! dest-col 0)
(hash-table-put! next-col-map init-col dest-col)
@ -436,6 +442,25 @@
(make-table "schemeblock" (map list (reverse docs))))
(make-sized-element #f (reverse content) dest-col))))
(define (typeset c multi-line? prefix1 prefix suffix color?)
(let* ([c (syntax-ize c 0)]
[s (syntax-e c)])
(if (or multi-line?
(eq? 'code:blank s)
(pair? s)
(vector? s)
(box? s)
(null? s)
(hash-table? s))
(gen-typeset c multi-line? prefix1 prefix suffix color?)
(typeset-atom c
(case-lambda
[(elem color)
(make-sized-element (and color? color) (list elem) (or (syntax-span c) 1))]
[(elem color len)
(make-sized-element (and color? color) (list elem) len)])
color? 0))))
(define (to-element c)
(typeset c #f "" "" "" #t))
@ -457,15 +482,15 @@
(cond
[(syntax? v)
(let ([mk `(,#'d->s
(quote-syntax ,v)
(quote-syntax ,(datum->syntax-object v 'defcode))
,(syntax-case v (uncode)
[(uncode e) #'e]
[else (stx->loc-s-expr (syntax-e v))])
(list 'code
,(syntax-line v)
,(syntax-column v)
,(syntax-position v)
,(syntax-span v)))])
'(code
,(syntax-line v)
,(syntax-column v)
,(syntax-position v)
,(syntax-span v)))])
(let ([prop (syntax-property v 'paren-shape)])
(if prop
`(,#'stx-prop ,mk 'paren-shape ,prop)
@ -484,27 +509,43 @@
[(_ expr) #`(typeset-code #,(cvt #'expr))]
[(_ expr (... ...))
#`(typeset-code #,(cvt #'(code:line expr (... ...))))])))]
[(_ code typeset-code uncode d->s)
#'(define-code code typeset-code uncode d->s syntax-property)]
[(_ code typeset-code uncode)
#'(define-code code typeset-code uncode datum->syntax-object syntax-property)]
[(_ code typeset-code) #'(define-code code typeset-code unsyntax)]))
(define (register-scheme-definition stx)
(define (register-scheme stx [warn-if-no-label? #f])
(unless (identifier? stx)
(error 'register-scheme-definition "not an identifier: ~e" (syntax-object->datum stx)))
(format "definition:~a"
(let ([b (identifier-binding stx)])
(cond
[(not b) (format "top:~a" (syntax-e stx))]
[(eq? b 'lexical) (format "lexical:~a" (syntax-e stx))]
[else (format "module:~a:~a"
(if (module-path-index? (car b))
(collapse-module-path-index (car b) '(lib "ack.ss" "scribble"))
(car b))
(cadr b))]))))
(let ([b (identifier-label-binding stx)])
(if (or (not b)
(eq? b 'lexical))
(if warn-if-no-label?
(begin
(fprintf (current-error-port)
"~a\n"
;; Call raise-syntax-error to capture error message:
(with-handlers ([exn:fail:syntax? (lambda (exn)
(exn-message exn))])
(raise-syntax-error 'WARNING
"no for-label binding of identifier"
stx)))
(format ":NOLABEL:~a" (syntax-e stx)))
#f)
(format ":~a:~a"
(if (module-path-index? (car b))
(let ([p (resolve-module-path-index (car b) #f)])
(path->main-collects-relative p))
(car b))
(cadr b)))))
(define (register-scheme-form-definition stx)
(format "form~s" (register-scheme-definition stx)))
(define (register-scheme-definition stx [warn-if-no-label? #f])
`(def ,(register-scheme stx warn-if-no-label?)))
(define (register-scheme-form-definition stx [warn-if-no-label? #f])
`(form ,(register-scheme stx warn-if-no-label?)))
(define syntax-ize-hook (make-parameter (lambda (v col) #f)))
@ -551,7 +592,11 @@
(just-context-ctx v)))]
[(and (list? v)
(pair? v)
(memq (car v) '(quote unquote unquote-splicing)))
(memq (let ([s (car v)])
(if (just-context? s)
(just-context-val s)
s))
'(quote unquote unquote-splicing)))
(let ([c (syntax-ize (cadr v) (+ col 1))])
(datum->syntax-object #f
(list (syntax-ize (car v) col)

4
collects/scribble/scribble.css
View File

@ -140,6 +140,10 @@
text-decoration: none;
}
.nobreak {
white-space: nowrap;
}
.title {
font-size: 200%;
font-weight: normal;

242
collects/scribble/struct.ss
View File

@ -1,8 +1,56 @@
(module struct mzscheme
(module struct (lib "lang.ss" "big")
(require (lib "contract.ss")
(lib "serialize.ss"))
;; ----------------------------------------
(define-struct collect-info (ht ext-ht parts tags gen-prefix))
(define-struct resolve-info (ci delays undef))
(define (part-collected-info part ri)
(hash-table-get (collect-info-parts (resolve-info-ci ri))
part))
(define (collect-put! ci key val)
(hash-table-put! (collect-info-ht ci)
key
val))
(define (resolve-get/where part ri key)
(let ([key (tag-key key ri)])
(let ([v (hash-table-get (if part
(collected-info-info (part-collected-info part ri))
(collect-info-ht (resolve-info-ci ri)))
key
#f)])
(cond
[v (values v #f)]
[part (resolve-get/where (collected-info-parent
(part-collected-info part ri))
ri
key)]
[else
(let ([v (hash-table-get (collect-info-ext-ht (resolve-info-ci ri))
key
#f)])
(values v #t))]))))
(define (resolve-get part ri key)
(let-values ([(v ext?) (resolve-get/where part ri key)])
v))
(provide
(struct collect-info (ht ext-ht parts tags gen-prefix))
(struct resolve-info (ci delays undef))
part-collected-info
collect-put!
resolve-get
resolve-get/where)
;; ----------------------------------------
(provide provide-structs)
(define-syntax (provide-structs stx)
@ -36,12 +84,12 @@
fields+cts)))))]))
(provide tag?)
(define (tag? s) (or (string? s)
(and (pair? s)
(symbol? (car s))
(pair? (cdr s))
(string? (cadr s))
(null? (cddr s)))))
(define (tag? s) (and (pair? s)
(symbol? (car s))
(pair? (cdr s))
(or (string? (cadr s))
(generated-tag? (cadr s)))
(null? (cddr s))))
(provide flow-element?)
(define (flow-element? p)
@ -52,21 +100,21 @@
(delayed-flow-element? p)))
(provide-structs
[part ([tags (listof tag?)]
[part ([tag-prefix (or/c false/c string?)]
[tags (listof tag?)]
[title-content (or/c false/c list?)]
[collected-info (or/c false/c collected-info?)]
[style any/c]
[to-collect list?]
[flow flow?]
[parts (listof part?)])]
[(styled-part part) ([style any/c])]
[(unnumbered-part styled-part) ()]
[(unnumbered-part part) ()]
[flow ([paragraphs (listof flow-element?)])]
[paragraph ([content list?])]
[(styled-paragraph paragraph) ([style any/c])]
[table ([style any/c]
[flowss (listof (listof (or/c flow? (one-of/c 'cont))))])]
[(auxiliary-table table) ()]
[delayed-flow-element ([render (any/c part? any/c . -> . flow-element?)])]
[delayed-flow-element ([resolve (any/c part? resolve-info? . -> . flow-element?)])]
[itemization ([flows (listof flow?)])]
[blockquote ([style any/c]
[paragraphs (listof flow-element?)])]
@ -81,6 +129,7 @@
[plain-seq (listof string?)]
[entry-seq list?])]
[(aux-element element) ()]
[(hover-element element) ([text string?])]
;; specific renders support other elements, especially strings
[collected-info ([number (listof (or/c false/c integer?))]
@ -89,46 +138,32 @@
[target-url ([addr string?])]
[image-file ([path path-string?])])
;; ----------------------------------------
;; Delayed element has special serialization support:
(define-values (struct:delayed-element
make-delayed-element
delayed-element?
delayed-element-ref
delayed-element-set!)
(make-struct-type 'delayed-element #f
3 1 #f
(list (cons prop:serializable
(make-serialize-info
(lambda (d)
(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 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-plain
#'delayed-element-sizer
#'delayed-element-render)
(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))
(define-struct delayed-element (resolve sizer plain)
#:property
prop:serializable
(make-serialize-info
(lambda (d)
(let ([ri (current-serialize-resolve-info)])
(unless ri
(error 'serialize-delayed-element
"current-serialize-resolve-info not set"))
(with-handlers ([exn:fail:contract?
(lambda (exn)
(error 'serialize-delayed-element
"serialization failed (wrong resolve info?); ~a"
(exn-message exn)))])
(vector
(make-element #f (delayed-element-content d ri))))))
#'deserialize-delayed-element
#f
(or (current-load-relative-directory) (current-directory))))
(provide/contract
(struct delayed-element ([render (any/c part? any/c . -> . list?)]
(struct delayed-element ([resolve (any/c part? resolve-info? . -> . list?)]
[sizer (-> any)]
[plain (-> any)])))
@ -136,12 +171,90 @@
(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 3)
(let ([v ((delayed-element-ref d 0) renderer sec ht)])
(delayed-element-set! d 3 v)
v)))
(provide delayed-element-content)
(define (delayed-element-content e ri)
(hash-table-get (resolve-info-delays ri) e))
(provide delayed-flow-element-flow-elements)
(define (delayed-flow-element-flow-elements p ri)
(hash-table-get (resolve-info-delays ri) p))
(provide current-serialize-resolve-info)
(define current-serialize-resolve-info (make-parameter #f))
;; ----------------------------------------
(define-struct (collect-element element) (collect)
#:property
prop:serializable
(make-serialize-info
(lambda (d)
(vector (collect-element-collect d)))
#'deserialize-collect-element
#f
(or (current-load-relative-directory) (current-directory))))
(provide deserialize-collect-element)
(define deserialize-collect-element
(make-deserialize-info values values))
(provide/contract
[struct collect-element ([style any/c]
[content list?]
[collect (collect-info? . -> . any)])])
;; ----------------------------------------
(define-struct generated-tag ()
#:property
prop:serializable
(make-serialize-info
(lambda (g)
(let ([ri (current-serialize-resolve-info)])
(unless ri
(error 'serialize-generated-tag
"current-serialize-resolve-info not set"))
(let ([t (hash-table-get (collect-info-tags
(resolve-info-ci ri))
g
#f)])
(if t
(vector t)
(error 'serialize-generated-tag
"serialization failed (wrong resolve info?)")))))
#'deserialize-generated-tag
#f
(or (current-load-relative-directory) (current-directory))))
(provide
(struct generated-tag ()))
(provide deserialize-generated-tag)
(define deserialize-generated-tag
(make-deserialize-info values values))
(provide generate-tag tag-key)
(define (generate-tag tg ci)
(if (generated-tag? (cadr tg))
(let ([t (cadr tg)])
(list (car tg)
(let ([tags (collect-info-tags ci)])
(or (hash-table-get tags t #f)
(let ([key (format "gentag:~a~a"
(collect-info-gen-prefix ci)
(hash-table-count tags))])
(hash-table-put! tags t key)
key)))))
tg))
(define (tag-key tg ri)
(if (generated-tag? (cadr tg))
(list (car tg)
(hash-table-get (collect-info-tags
(resolve-info-ci ri))
(cadr tg)))
tg))
;; ----------------------------------------
@ -151,8 +264,8 @@
(define content->string
(case-lambda
[(c) (c->s c element->string)]
[(c renderer sec ht) (c->s c (lambda (e)
(element->string e renderer sec ht)))]))
[(c renderer sec ri) (c->s c (lambda (e)
(element->string e renderer sec ri)))]))
(define (c->s c do-elem)
(apply string-append
@ -171,12 +284,12 @@
[(rsquo) "'"]
[(rarr) "->"]
[else (format "~s" c)])])]
[(c renderer sec ht)
[(c renderer sec ri)
(cond
[(element? c) (content->string (element-content c) renderer sec ht)]
[(element? c) (content->string (element-content c) renderer sec ri)]
[(delayed-element? c)
(content->string (force-delayed-element c renderer sec ht)
renderer sec ht)]
(content->string (delayed-element-content c ri)
renderer sec ri)]
[else (element->string c)])]))
;; ----------------------------------------
@ -226,5 +339,14 @@
;; ----------------------------------------
(provide part-style?)
(define (part-style? p s)
(let ([st (part-style p)])
(or (eq? s st)
(and (list? st) (memq s st)))))
;; ----------------------------------------
)

5
collects/scribblings/scribble/basic.scrbl
View File

@ -96,6 +96,11 @@ removed.}
@scheme[pre-flow] list is parsed with @scheme[decode-flow].
}
@defproc[(item? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is an item produced by
@scheme[item], @scheme[#f] otherwise.}
@defform[(include-section module-path)]{ Requires @scheme[module-path]
and returns its @scheme[doc] export (without making any imports
visible to the enclosing context). Since this form expands to

47
collects/scribblings/scribble/decode.scrbl
View File

@ -5,7 +5,7 @@
@title[#:tag "decode"]{Text Decoder}
The @file{decode.ss} library helps you write document content in a
natural way---more like plain text, except for @elem["@"] escapes.
natural way---more like plain text, except for @litchar["@"] escapes.
Roughly, it processes a stream of strings to produces instances of the
@file{struct.ss} datatypes (see @secref["struct"]).
@ -34,24 +34,26 @@ special text conversions:
Decodes a document, producing a part. In @scheme[lst], instances of
@scheme[splice] are inlined into the list. An instance of
@scheme[title-decl] supplies the title for the part. Instances of
@scheme[index-section-decl] (that preceed any sub-part) add index
entries that point to the section. Instances of @scheme[part-start] at
level 0 trigger sub-part parsing. Instances of @scheme[section]
trigger are used as-is as subsections, and instances of
@scheme[paragraph] and other flow-element datatypes are used as-is in
the enclosing flow.
@scheme[part-index-decl] (that precede any sub-part) add index entries
that point to the section. Instances of @scheme[part-collect-decl] add
elements to the part that are used only during the @techlink{collect
pass}. Instances of @scheme[part-start] at level 0 trigger sub-part
parsing. Instances of @scheme[section] trigger are used as-is as
subsections, and instances of @scheme[paragraph] and other
flow-element datatypes are used as-is in the enclosing flow.
}
@defproc[(decode-part [lst list?]
[tag string?]
[tags (listof string?)]
[title (or/c false/c list?)]
[depth excat-nonnegative-integer?])
part?]{
Like @scheme[decode], but given a tag for the section, a title (if
@scheme[#f], then a @scheme[title-decl] instance is used if found),
and a depth for @scheme[part-start]s to trigger sub-part parsing.
Like @scheme[decode], but given a list of tag string for the part, a
title (if @scheme[#f], then a @scheme[title-decl] instance is used if
found), and a depth for @scheme[part-start]s to trigger sub-part
parsing.
}
@ -90,28 +92,41 @@ otherwise.
}
@defstruct[title-decl ([tag any/c]
@defstruct[title-decl ([tag-prefix (or/c false/c string?)]
[tags (listof string?)]
[style any/c]
[content list?])]{
See @scheme[decode] and @scheme[decode-part].
See @scheme[decode] and @scheme[decode-part]. The @scheme[tag-prefix]
and @scheme[style] fields are propagated to the resulting
@scheme[part].
}
@defstruct[part-start ([depth integer?]
[tag (or/c false/c string?)]
[tag-prefix (or/c false/c string?)]
[tags (listof string?)]
[style any/c]
[title list?])]{
See @scheme[decode] and @scheme[decode-part].
Like @scheme[title-decl], but for a sub-part. See @scheme[decode] and
@scheme[decode-part].
}
@defstruct[part-index-decl ([plain-seq (listof string?)]
[content-seq list?])]{
[entry-seq list?])]{
See @scheme[decode]. The two fields are as for @scheme[index-element].
}
@defstruct[part-collect-decl ([element element?])]{
See @scheme[decode].
}
@defstruct[splice ([run list?])]{
See @scheme[decode], @scheme[decode-part], and @scheme[decode-flow].

474
collects/scribblings/scribble/how-to.scrbl Normal file
View File

@ -0,0 +1,474 @@
#reader(lib "docreader.ss" "scribble")
@require[(lib "manual.ss" "scribble")
(lib "bnf.ss" "scribble")]
@require["utils.ss"]
@title{How to Scribble Documentation}
@;----------------------------------------
@section[#:tag "getting-started"]{Getting Started}
To document a collection or @|PLaneT| package:
@itemize{
@item{Create a file in your collection or planet package with the
file extension @file{.scrbl}. The remainder of these
instructions assume that the file is called @file{manual.scrbl}.}
@item{Start @file{manual.scrbl} like this:
@verbatim[#<<EOS
#reader(lib "docreader.ss" "scribble")
@begin[(require (lib "manual.ss" "scribble"))]
@title{My Library}
Welcome to my documentation: @scheme[(list 'testing 1 2 3)].
EOS
]
The first line starts the file in ``text'' mode, and
introduces the @litchar["@"] syntax to use Scheme bindings.
The second line introduces bindings like @scheme[title] and
@scheme[scheme] for writing PLT Scheme documentation. The
@scheme[title] call (using @litchar["@"]) produces a title
declaration in the text stream.}
@item{Add the following entry to your collect or package's
@file{info.ss}:
@schemeblock[
(define scribblings '(("manual.scrbl" ())))
]
The @scheme[()] above is a list of options. When your document
gets large enough that you want it split into multiple pages,
add the @scheme['multi-page] option (omitting the quote, since
the whole right-hand side of the definition is already
quoted).}
@item{Run @exec{setup-plt} to build your documentation. For a
collection, optionally supply @Flag{l} followed by the
collection name to limit the build process to the collection.}
@item{The generated documentation is
@file{compiled/doc/manual/index.html} within the collection or
@|PLaneT| package directory.}
}
@; ----------------------------------------
@section{Document Syntax}
Whether in ``text'' mode or Scheme mode, @litchar["@"] in a document
provides an escape to Scheme mode. The syntax of @litchar["@"] is
@schemeblock[
#, @BNF-seq[@litchar["@"]
@nonterm{cmd}
@litchar{[} @kleenestar{@nonterm{datum}} @litchar{]}
@litchar["{"] @nonterm{text-body} @litchar["}"]]
]
where all three parts after @litchar["@"] are optional, but at least
one must be present. No spaces are allowed between
@itemize{
@item{@litchar["@"] and @nonterm{cmd}, @litchar["["], or @litchar["{"]}
@item{@nonterm{cmd} and @litchar["["] or @litchar["{"]; or}
@item{@litchar["]"] and @litchar["{"].}
}
A @nonterm{cmd} or @nonterm{datum} is a Scheme datum, while a
@nonterm{text-body} is itself in text mode.
The expansion of a @litchar["@"] form into Scheme code is
@schemeblock[
(#, @nonterm{cmd} #, @kleenestar{@nonterm{datum}} #, @kleenestar{@nonterm{parsed-body}})
]
where @kleenestar{@nonterm{parsed-body}} is the parse result of the
@nonterm{text-body}. It often turns out to be a sequence of Scheme
strings.
In practice, the @nonterm{cmd} is normally a Scheme identifier that is
bound to a procedure or syntactic form. If the procedure or form
expects further text to typeset, then @litchar["{"] @litchar["}"]
supplies the text. If the form expects other data, typically
@litchar["["] @litchar["]"] is used to surround Scheme arguments,
instead. Sometimes, both @litchar["["] @litchar["]"] and @litchar["{"]
@litchar["}"] are used, where the former surround Scheme arguments
that precede text to typeset.
Thus,
@verbatim[#<<EOS
@title{My Library}
@scheme[(list 'testing 1 2 3)]
@section[#:tag "here"]{You Are Here}
EOS
]
means
@schemeblock[
(title "My Library")
(scheme (list 'testing 1 2 3))
(section #:tag "here" "You Are Here")
]
For more information on the syntax of @litchar["@"], see
@secref["reader"].
In a document that starts @tt{#reader(lib "docreader.ss" "scribble")},
the top level is a text-mode sequence. The parsed sequence is further
decoded to turn it into a hierarchy of sections and paragraphs. For
example, a linear sequence of @scheme[section] declarations with
interleaved text is turned into a list of @scheme[part] instances with
all text assigned to a particular part. See @secref["decode"] for more
information on the decoding process.
@; ----------------------------------------
@section[#:tag "scheme-hyperlinks"]{Scheme Typesetting and Hyperlinks}
With the document source in @secref["getting-started"], the Scheme
expression @scheme[(#,(schemeidfont "list") 'testing 1 2 3)] is
typeset properly, but the @schemeidfont{list} identifier is not
hyperlinked to the usual definition. To cause @schemeidfont{list} to
be hyperlinked, add the following to the @tt["@begin"] body:
@schemeblock[
(require-for-label (lib "big.ss" "lang"))
]
This @scheme[require-for-label] declaration introduces a document-time
binding for each export of the @scheme[(lib "big.ss" "lang")]
module. When the document is built, the @scheme[scheme] form detects
the binding for @scheme[list], and so it generates a reference to the
specification of @scheme[list]. The setup process detects the
reference, and it finds the matching specification in the existing
documentation, and it ultimately directs the hyperlink to that
specification.
Hyperlinks based on @scheme[require-for-label] and @scheme[scheme] are
the preferred mechanism for linking to information outside of a single
document. Such links require no information about where and how a
binding is documented elsewhere:
@verbatim[#<<EOS
#reader(lib "docreader.ss" "scribble")
@begin[(require (lib "manual.ss" "scribble"))
(require-for-label (lib "lang.ss" "big"))]
@title{My Library}
See also @scheme[list].
EOS
]
The @scheme[scheme] form typesets a Scheme expression for inline text,
so it ignores the source formatting of the expression. The
@scheme[schemeblock] form, in contrast, typesets inset Scheme code,
and it preserves the expression's formatting from the document source.
@verbatim[#<<EOS
#reader(lib "docreader.ss" "scribble")
@begin[(require (lib "manual.ss" "scribble"))
(require-for-label (lib "lang.ss" "big"))]
@title{My Library}
Some example Scheme code:
@schemeblock[
(define (nobody-understands-me what)
(list "When I think of all the"
what
"I've tried so hard to explain!"))
(nobody-understands-me "glorble snop")
]
EOS
]
@; ----------------------------------------
@section[#:tag "section-hyperlinks"]{Section Hyperlinks}
A @scheme[section] declaration in a document can include a
@scheme[#:tag] argument that declares a hyperlink-target tag. The
@scheme[secref] function generates a hyperlink, using the section name
as the text of the hyperlink. Use @scheme[seclink] to create a
hyperlink with text other than the section title.
The following example illustrates section hyperlinks:
@verbatim[#<<EOS
#reader(lib "docreader.ss" "scribble")
@begin[(require (lib "manual.ss" "scribble"))
(require-for-label (lib "lang.ss" "big"))]
@title{My Library}
Welcome to my documentation: @scheme[(list 'testing 1 2 3)].
@table-of-contents[]
@section[#:tag "chickens"]{Philadelphia Chickens}
Dancing tonight!
@section{Reprise}
See @secref{chickens}.
EOS
]
Since the page is so short, it the hyperlinks are more effective if
you change the @file{info.ss} file to add the @scheme['multi-file]
flag:
@schemeblock[
(define scribblings '(("manual.scrbl" (multi-page))))
]
A section can have a @techlink{tag prefix} that applies to all tags as
seen from outside the section. Such a prefix is automatically given to
each top-level document as processed by @exec{setup-plt}. Thus,
referencing a section tag in a different document requires using a
prefix, which is based on the target document's main source file. The
following example links to a section in the PLT Scheme reference
manual:
@verbatim[#<<EOS
#reader(lib "docreader.ss" "scribble")
@begin[(require (lib "manual.ss" "scribble"))
(require-for-label (lib "lang.ss" "big"))
(define ref-src
'(lib "reference.scrbl" "scribblings" "reference"))]
@title{My Library}
See also @italic{@secref[#:doc reference-src]{pairs}}.
EOS
]
As mentioned in @secref{scheme-hyperlinks}, however, cross-document
references based on @scheme[require-for-label] and @scheme[scheme] are
usually better than to cross-document references using
@scheme[secref].
@; ----------------------------------------
@section{Defining Scheme Bindings}
Use @scheme[defproc] to document a procedure, @scheme[defform] to
document a syntactic form, @scheme[defstruct] to document a structure
type, etc. These forms provide consistent formatting of definitions,
and they declare hyperlink targets for @scheme[scheme]-based
hyperlinks.
To document a @scheme[my-helper] procedure that is exported by
@file{helper.ss} in the collection that contains @file{manual.scrbl},
first use @scheme[require-for-label] to import the binding information
of @file{helper.ss}. Then use @scheme[defproc] to document the
procedure:
@verbatim[#<<EOS
#reader(lib "docreader.ss" "scribble")
@begin[(require (lib "manual.ss" "scribble"))
(require-for-label (lib "lang.ss" "big")
"helper.ss")]
@title{My Library}
@defproc[(my-helper [lst list?])
(listof
(not/c (one-of/c 'cow)))]{
Replaces each @scheme['cow] in @scheme[lst] with
@scheme['aardvark].}
EOS
]
In @scheme[defproc], a contract is specified with each argument to the
procedure. In this example, the contract for the @scheme[_lst]
argument is @scheme[list?], which is the contract for a list. After
the closing parenthesis that ends the argument sequence, the contract
of the result must be given; in this case, @scheme[my-helper]
guarantees a result that is a list where none of the elements are
@scheme['cow].
Some things to notice in this example and the documentation that it
generates:
@itemize{
@item{The @scheme[list?], @scheme[listof], @|etc| elements of
contracts are hyperlinked to their documentation.}
@item{The result contract is formatted in the generated documentation
in the same way as in the source. That is, the source layout of
contracts is preserved. (In this case, putting the contract all
on one line would be better.)}
@item{In the prose that documents @scheme[my-helper], @scheme[_lst]
is automatically typeset in italic, matching the typesetting in
the blue box. The @scheme[scheme] form essentially knows that
it's used in the scope of a procedure with argument
@scheme[_lst].}
@item{If you use @scheme[my-helper] in any documentation now, as long
as that documentation source also has a
@scheme[require-for-label] of @file{my-helper.ss}, then the
reference is hyperlinked to the definition above.}
}
See @scheme[defproc*], @scheme[defform], @|etc| for more information
on forms to document Scheme bindings.
@; ----------------------------------------
@section{Showing Scheme Examples}
The @scheme[examples] form from @scheme[(lib "eval.ss" "scribble")]
helps you generate examples in your documentation. @bold{Warning:} the
@scheme[examples] form is especially likely to change or be replaced.
To use @scheme[examples], the procedures to document must be suitable
for use at documentation time; in fact, @scheme[examples] uses
bindings introduced into the document source by
@scheme[require]. Thus, to generate examples using @scheme[my-helper]
from the previous section, then @file{helper.ss} must be imported both
via @scheme[require-for-label] and @scheme[require]:
@verbatim[#<<EOS
#reader(lib "docreader.ss" "scribble")
@begin[(require (lib "manual.ss" "scribble")
(lib "eval.ss" "scribble") ; <--- added
"helper.ss") ; <--- added
(require-for-label (lib "lang.ss" "big")
"helper.ss")]
@title{My Library}
@defproc[(my-helper [lst list?])
(listof (not/c (one-of/c 'cow)))]{
Replaces each @scheme['cow] in @scheme[lst] with
@scheme['aardvark].
@examples[
(my-helper '())
(my-helper '(cows such remarkable cows))
]}
EOS
]
@;----------------------------------------
@section{Splitting the Document Source}
In general, a @file{.scrbl} file produces a @techlink{part}. A part
produced by a document's main source (as specified in the
@scheme{info.ss} file) represents the whole document. The
@scheme[include-section] procedure can be used to incorporate a part
as a sub-part of the enclosing part.
In @file{manual.scrbl}:
@verbatim[#<<EOS
#reader(lib "docreader.ss" "scribble")
@begin[(require (lib "manual.ss" "scribble"))]
@title{My Library}
@include-section["cows.scrbl"]
@include-section["aardvarks.scrbl"]
EOS
]
In @file{cows.scrbl}:
@verbatim[#<<EOS
#reader(lib "docreader.ss" "scribble")
@begin[(require (lib "manual.ss" "scribble"))]
@title{Cows}
Wherever they go, it's a quite a show.
EOS
]
In @file{aardvarks.scrbl}:
@verbatim[#<<EOS
#reader(lib "docreader.ss" "scribble")
@begin[(require (lib "manual.ss" "scribble"))
(require-for-label (lib "lang.ss" "big")
"helper.ss")]
@title{Aardvarks}
@defproc[(my-helper [lst list?])
(listof (not/c (one-of/c 'cow)))]{
Replaces each @scheme['cow] in @scheme[lst] with
@scheme['aardvark].}
EOS
]
@;----------------------------------------
@section{Multi-Page Sections}
Setting the @scheme['multi-page] option (see
@secref["section-hyperlinks"]) causes each top-level section of a
document to be rendered as a separate HTML page.
To push sub-sections onto separate pages, use the @scheme['toc] style
for the enclosing section (as started by @scheme[title],
@scheme[section], @scheme[subsection], etc.) and use
@scheme[local-table-of-contents] to generate hyperlinks to the
sub-sections.
Revising @file{cows.scrbl} from the previous section:
@verbatim[#<<EOS
#reader(lib "docreader.ss" "scribble")
@begin[(require (lib "manual.ss" "scribble"))]
@title[#:style '(toc)]{Cows}
@local-table-of-contents[]
@section[#:tag "singing"]{Singing}
Wherever they go, it's a quite a show.
@section{Dancing}
See @secref["singing"].
EOS
]
To run this example, remember to change @file{info.ss} to add the
@scheme['multi-page] style. You may also want to add a call to
@scheme[table-of-contents] in @file{manual.scrbl}.
The difference between @scheme[table-of-contents] and
@scheme[local-table-of-contents] is that the latter is ignored for
Latex output.
When using @scheme[local-table-of-contents], often it makes sense to
include introductory text before the call of
@scheme[local-table-of-contents]. When the introductory text is less
important and when when local table of contents is short, putting the
introductory text after the call of @scheme[local-table-of-contents]
make be appropriate.
@;----------------------------------------
@include-section["style.scrbl"]

3
collects/scribblings/scribble/info.ss Normal file
View File

@ -0,0 +1,3 @@
(module info (lib "infotab.ss" "setup")
(define name "Scribblings: Scribble")
(define scribblings '(("scribble.scrbl" (multi-page main-doc)))))

7
collects/scribblings/scribble/manual.scrbl
View File

@ -57,7 +57,7 @@ produces
]
The @scheme[unsyntax] form is regonized via
@scheme[module-identifier=?], so if you want to typeset code that
@scheme[free-identifier=?], so if you want to typeset code that
includes @scheme[unsyntax], you can simply hide the usual binding:
@SCHEMEBLOCK[
@ -68,8 +68,7 @@ includes @scheme[unsyntax], you can simply hide the usual binding:
]
Or use @scheme[SCHEMEBLOCK], whose escape form is @scheme[UNSYNTAX]
instead of @scheme[unsyntax]. See also @scheme[define-code] from
@file{scheme.ss}.
instead of @scheme[unsyntax].
A few other escapes are recognized symbolically:
@ -546,5 +545,5 @@ centered table with the @scheme[pre-flow] parsed by
@defproc[(commandline [pre-content any/c] ...) paragraph?]{Produces
an inset command-line example (e.g., in typewriter font).}
@defproc[(margin-code [pre-content any/c] ...) paragraph?]{Produces
@defproc[(margin-note [pre-content any/c] ...) paragraph?]{Produces
a paragraph to be typeset in the margin instead of inlined.}

19
collects/scribblings/scribble/reader.scrbl
View File

@ -721,9 +721,19 @@ an example of this.
@;--------------------------------------------------------------------
@section{Interface}
The @file{reader.ss} module provides very little functionality for
advanced needs.
The @file{reader.ss} module provides functionality for advanced needs.
@; The `with-scribble-read' trick below shadows `read' and
@; `read-syntax' with for-label bindings from the Scribble reader
@define-syntax[with-scribble-read
(syntax-rules ()
[(_)
(...
(begin
(require-for-label (lib "reader.ss" "scribble"))
@; *** Start reader-import section ***
@defproc[(read [in input-port? (current-input-port)]) any]{}
@defproc[(read-syntax [source-name any/c (object-name in)]
[in input-port? (current-input-port)])
@ -807,3 +817,8 @@ Installs the Scribble readtable as the default. Useful for REPL
experimentation. (Note: enables line and column tracking.) The given
keyword arguments are used with `make-at-readtable'.
}
@; *** End reader-import section ***
))])]
@with-scribble-read[]

54
collects/scribblings/scribble/renderer.scrbl
View File

@ -1,6 +1,7 @@
#reader(lib "docreader.ss" "scribble")
@require[(lib "manual.ss" "scribble")]
@require["utils.ss"]
@require-for-label[(lib "class.ss")]
@title[#:tag "renderer"]{Renderer}
@ -29,3 +30,56 @@ See @file{base-render.ss} for more information about the methods of
the renderer. Documents built with higher layers, such as
@file{manual.ss}, generally do not call the render object's methods
directly.
@defclass[render% object% ()]{
Represents a renderer.
@defconstructor[([dest-dir path-string?])]{
Creates a renderer whose output goes to @scheme[dest-dir].
}
@defmethod[(collect [srcs (listof path-string?)]
[dests (listof path-string?)])
collect-info?]{
}
@defmethod[(resolve [srcs (listof path-string?)]
[dests (listof path-string?)]
[ci collect-info?])
resolve-info?]{
}
@defmethod[(render [srcs (listof path-string?)]
[dests (listof path-string?)]
[ri resolve-info?])
void?]{
}
@defmethod[(serialize-info [ri resolve-info?])
any/c]{
Serializes the collected info in @scheme[ri].
}
@defmethod[(deserialize-info [v any/c]
[ci collect-info?])
void?]{
Adds the deserialized form of @scheme[v] to @scheme[ci].
}
}
@include-class[render%]

18
collects/scribblings/scribble/scribble.scrbl
View File

@ -3,13 +3,17 @@
@require[(lib "bnf.ss" "scribble")]
@require["utils.ss"]
@title{PLT Scribble}
@title[#:tag-prefix '(lib "scribble.scrbl" "scribblings" "scribble")
#:tag "top"]{PLT Scribble}
The @file{scribble} collection provides libraries that can be used to
create documents from Scheme.
@table-of-contents[]
@; ------------------------------------------------------------------------
@include-section["how-to.scrbl"]
@; ------------------------------------------------------------------------
@section{Scribble Layers}
@ -26,23 +30,24 @@ The layers are:
with @"@"-forms for conveniently embedding a mixin of text and
escapes. See @secref["reader"].}
@item{@file{struct.ss}: a set of document datatypes, which define the
basic layout of a document. See @secref["struct"].}
@item{@file{struct.ss}: a set of document datatypes and utilities
that define the basic layout and processing of a document. See
@secref["struct"].}
@item{@file{base-render.ss} with @file{html-render.ss},
@file{latex-render.ss}, or @file{text-render.ss}: A base
renderer and mixins that generate documents in various formats
from instances of the @file{struct.ss} datatype. See
from instances of the @file{struct.ss} datatypes. See
@secref["renderer"].}
@item{@file{decode.ss}: Processes a stream of text, section-start
markers, etc. to produce instances of the @file{struct.ss}
datatype. See @secref["decode"].}
datatypes. See @secref["decode"].}
@item{@file{doclang.ss}: to be used for the initial import of a
module; processes the module top level through
@file{decode.ss}, and otherwise provides all of
@scheme[mzscheme]. See @secref["doclang"].}
@schememodname[big]. See @secref["doclang"].}
@item{@file{docreader.ss}: a reader that is meant to tbe used to
process an entire file; it essentially combines
@ -88,4 +93,3 @@ information.
@include-section["basic.scrbl"]
@include-section["manual.scrbl"]
@include-section["eval.scrbl"]
@include-section["style.scrbl"]

450
collects/scribblings/scribble/struct.scrbl
View File

@ -2,50 +2,66 @@
@require[(lib "manual.ss" "scribble")]
@require["utils.ss"]
@title[#:tag "struct"]{Document Structures}
@title[#:tag "struct"]{Document Structures And Processing}
A single document is represented as a @defterm{part}:
A document is represented as a @techlink{part}, as described in
@secref["parts"]. This representation is intended to
independent of its eventual rendering, and it is intended to be
immutable; rendering extensions and specific data in a document can
collude arbitrarily, however.
A document is processed in three passes. The first pass is the
@deftech{collect pass}, which globally collects information in the
document, such as targets for hyperlinking. The second pass is the
@deftech{resolve pass}, which matches hyperlink references with
targets and expands delayed elements (where the expansion should not
contribute new hyperlink targets). The final pass is the
@deftech{render pass}, which generates the resulting document. None
of the passes mutate the document, but instead collect information in
side @scheme[collect-info] and @scheme[resolve-info] tables.
@; ------------------------------------------------------------------------
@section[#:tag "parts"]{Parts}
A @deftech{part} is an instance of @scheme[part]; among other things,
it has a title @techlink{content}, an initial @techlink{flow}, and a
list of subsection @techlink{parts}. An @scheme[unnumbered-part] is
the same as a @scheme[part], but it isn't numbered. There's no
difference between a part and a full document; a particular source
module just as easily defines a subsection (incorporated via
@scheme[include-section]) as a document.
A @deftech{flow} is an instance of @scheme[flow]; it has a list of
@techlink{flow elements}.
A @deftech{flow element} is either a @techlink{table}, an
@techlink{itemization}, @techlink{blockquote}, @techlink{paragraph},
or a @techlink{delayed flow element}.
@itemize{
@item{A @defterm{part} is an instance of @scheme[part]; it has a list
of @defterm{tags} used as link targets, a title
@defterm{content}, a list of @defterm{elements} that supply
information during the ``collect'' phase but are not rendered,
an initial @defterm{flow}, and a list of subsection
@defterm{part}s. After the ``collect'' phase of rendering, it
also has @defterm{collected info}. A @scheme[styled-part]
includes an extra style flag. An @scheme[unnumbered-part] is
the same as a @scheme[styled-part], but it isn't numbered.}
@item{A @deftech{table} is an instance of @scheme[table]; it
has a list of list of @techlink{flows} with a particular
style. In Latex output, each table cell is typeset as a
single line.}
@item{A @defterm{flow} is an instance of @scheme[flow]; it has a list
of @defterm{flow element}s.}
@item{A @deftech{itemization} is an instance of @scheme[itemization];
it has a list of @techlink{flows}.}
@item{A @defterm{flow element} is either a @defterm{table}, an
@defterm{itemization}, @defterm{blockquote}, @defterm{paragraph}, or a
@defterm{delayed flow element}.
@itemize{
@item{A @defterm{table} is an instance of @scheme[table]; it has a
list of list of @defterm{flow}s with a particular style.}
@item{A @defterm{itemization} is an instance of @scheme[itemization];
it has a list of flows.}
@item{A @defterm{blockquote} is an instance of
@item{A @deftech{blockquote} is an instance of
@scheme[blockquote]; it has list of flow elements that
are indented according to a specified style.}
@item{A @defterm{paragraph} is an instance of @scheme[paragraph]; it
has a list of @defterm{element}s.
@item{A @deftech{paragraph} is an instance of
@scheme[paragraph]; it has a @deftech{content}, which is
a list of @techlink{elements}:
@itemize{
@item{An element can be a string, one of a few symbols, an instance of
@scheme[element] (possibly @scheme[link-element],
@scheme[target-element], or
@scheme[index-element]), a @defterm{delayed
@item{An @deftech{element} can be a string, one of a few
symbols, an instance of @scheme[element] (possibly
@scheme[link-element], etc.), a @techlink{delayed
element}, or anything else allowed by the current
renderer.
@ -66,26 +82,21 @@ A single document is represented as a @defterm{part}:
@scheme['ndash], @scheme['ldquo],
@scheme['lsquo], @scheme['rsquo],
@scheme['rarr], or @scheme['prime]; it is
drawn as the corresponding HTML entity.}
rendered as the corresponding HTML entity
(even for Latex output).}
@item{An instance of @scheme[element] has a list of
@defterm{element}s plus a style. The style's
interpretation depends on the rendrer; it can
be one of a few special symbols that are
recognized by all renderers: @scheme['tt],
@scheme['italic], @scheme['bold],
@scheme['sf], @scheme['subscript],
@scheme['superscript], or @scheme['hspace].
A string corresponds to a CSS class, LaTeX
macro, or something else renderer-specific.
Instances of @scheme[target-url] and
@scheme[image-file] may also be supported.}
@techlink{elements} plus a style. The style's
interpretation depends on the rendrer, but it
can be one of a few special symbols (such as
@scheme['bold]) that are recognized by all
renderers.}
@item{An instance of @scheme[link-element] has a
@defterm{tag} for the target of the link.}
@techlink{tag} for the target of the link.}
@item{An instance of @scheme[target-element] has a
@defterm{tag} to be referenced by
@techlink{tag} to be referenced by
@scheme[link-element]s. An instance of the
subtype @scheme[toc-target-element] is
treated like a kind of section label, to be
@ -93,16 +104,23 @@ A single document is represented as a @defterm{part}:
output.}
@item{An instance of @scheme[index-element] has a
@defterm{tag} (as a target), a list of
@techlink{tag} (as a target), a list of
strings for the keywords (for sorting and
search), and a list of @defterm{element}s to
search), and a list of @techlink{elements} to
appear in the end-of-document index.}
@item{A @defterm{delayed element} is an instance of
@item{An instance of @scheme[collect-element] has a
procedure that is called in the
@techlink{collect pass} of document
processing to record information used by
later passes.}
@item{A @deftech{delayed element} is an instance of
@scheme[delayed-element], which has a
procedure that produces a
@defterm{element}. The ``collect'' phase of
rendering ignores delayed flow elements.}
procedure that is called in the
@techlink{resolve pass} of document
processing to obtain @defterm{content} (i.e.,
a list of @defterm{elements}).}
@item{An instance of @scheme[aux-element] is
excluded in the text of a link when it
@ -110,43 +128,99 @@ A single document is represented as a @defterm{part}:
}}}}
@item{A @defterm{delayed flow element} is an instance of
@item{A @deftech{delayed flow element} is an instance of
@scheme[delayed-flow-element], which has a procedure that
produces a @defterm{flow element}. The ``collect'' phase
of rendering ignores delayed flow elements.}
}}
@item{The @defterm{collected info} of a part includes its number, its
parent part (or @scheme[#f]), and information about link
targets and index entries within the part.}
@item{A @defterm{tag} is eiter a string or a list containing a symbol
and a string.}
is called in the @techlink{resolve pass} of document
processing to obtain a @defterm{flow element}.}
}
Note that there's no difference between a part and a full document. A
particular source module just as easily defines a subsection
(incoprated via @scheme[include-section]) as a document.
@; ------------------------------------------------------------------------
@defstruct[part ([tags (listof tag?)]
@section[#:tag "tags"]{Tags}
A @deftech{tag} is a list containing a symbol and a string. The symbol
effectively identifies the type of the tag, such as @scheme['part]
for a tag that links to a part, or @scheme['def] for a Scheme
function definition.
A section can have a @deftech{tag prefix}, which is effectively
prefixed onto the string part of each @scheme['part] and
@scheme['tech] tag within the part for reference outside the part,
including the tags in the @scheme[tags] field. Typically, a
document's main part has a tag prefix that applies to the whole
document; references to sections and defined terms within the
document from other documents must include the prefix plus a
separating @litchar{:}, while references within the same document
omit the prefix. Part prefixes can be used within a document as well,
to help disambiguate references within the document.
Some procedures accept a ``tag'' that is just the string part of the
full tag, where the symbol part is supplied automatically. For
example, @scheme[section] and @scheme[secref] both accept a string
``tag'', where @scheme['part] is implicit.
@; ------------------------------------------------------------------------
@section[#:tag "passes"]{Collected and Resolved Information}
The @techlink{collect pass}, @techlink{resolve pass}, and
@techlink{render pass} processing steps all produce information that
is specific to a rendering mode. Concretely, the operations are all
represented as methods on a @scheme[render%] object.
The result of the @method[render% collect] method is a
@scheme[collect-info] instance. This result is provided back as an
argument to the @method[render% resolve] method, which produces a
@scheme[resolve-info] value that encapsulates the results from both
iterations. The @scheme[resolve-info] value is provided back to the
@method[render% resolve] method for final rendering.
Optionally, before the @method[render% resolve] method is called,
serialized information from other documents can be folded into the
@scheme[collect-info] instance via the @method[render%
deserialize-info] method. Other methods provide serialized information
out of the collected and resolved records.
During the @techlink{collect pass}, the procedure associated with a
@scheme[collect-element] instance can register information with
@scheme[collect-put!].
During the @techlink{resolve pass}, collected information for a part
can be extracted with @scheme[part-collected-info], which includes a
part's number and its parent part (or @scheme[#f]). More generally,
the @scheme[resolve-get] method looks up information previously
collected. This resolve-time information is normally obtained by the
procedure associated with a @techlink{delayed flow element} or
@techlink{delayed element}.
The @scheme[resolve-get] information accepts both a @scheme[part] and
a @scheme[resolve-info] argument. The @scheme[part] argument enables
searching for information in each enclosing part before sibling parts.
@; ------------------------------------------------------------------------
@section{Structure Reference}
@defstruct[part ([tag-prefix (or/c false/c string?)]
[tags (listof tag?)]
[title-content (or/c false/c list?)]
[collected-info (or/c false/c collected-info?)]
[style any/c]
[to-collect list?]
[flow flow?]
[parts (listof part?)])]{
Each element of @scheme[tags] is actually wrapped as @scheme[`(part
,_tag)] as a target for links; functions like @scheme[seclink]
similarly insert the @scheme[`(part ,_tag)] wrapper.
The @scheme[tag-prefix] field determines the optional @techlink{tag
prefix} for the part.
}
The @scheme[tags] indicates a list of @techlink{tags} that each link
to the section.
The @scheme[title-content] field holds the part's title, if any.
@defstruct[(styled-part part) ([style any/c])]{
The currently recognized values for @scheme[style] are as follows:
The @scheme[style] field is normally either a symbol or a list of
symbols. The currently recognized style symbols (alone or in a list)
are as follows:
@itemize{
@ -155,69 +229,132 @@ The currently recognized values for @scheme[style] are as follows:
@item{@scheme['index] --- the part represents an index.}
}
@item{@scheme['reveal] --- shows sub-parts when this part is
displayed in a table-of-contents panel in HTML output (which
normally shows only the top-level sections).}
@item{@scheme['hidden] --- the part title is not shown in rendered output.}
}
@defstruct[(unnumbered-part styled-part) ()]{
The @scheme[to-collect] field contains @techlink{content} that is
inspected during the @techlink{collect pass}, but ignored in later
passes (i.e., it doesn't directly contribute to the output).
The @scheme[flow] field contains the part's initial flow (before
sub-parts).
The @scheme[parts] field contains sub-parts.
}
@defstruct[(unnumbered-part part) ()]{
Although a section number is computed for an ``unnumbered'' section
during the ``collect'' phase, the number is not rendered.
during the @techlink{collect pass}, the number is not rendered.
}
@defstruct[flow ([paragraphs (listof flow-element?)])]{
A @techlink{flow} has a list of flow elements.
}
@defstruct[paragraph ([content list?])]{
A @techlink{paragraph} has a list of elements.
}
@defstruct[(styled-paragraph paragraph) ([style any/c])]{
The @scheme[style] is normally a string that corresponds to a CSS
class for HTML output.
}
@defstruct[table ([style any/c]
[flowss (listof (listof flow?))])]{
[flowss (listof (listof (or/c flow? (one-of/c 'cont))))])]{
}
@defstruct[delayed-flow-element ([render (any/c part? any/c . -> . flow-element?)])]{
For the @scheme[render] procedure, the first argument corresponds to
the rendering context, the second to the immediately enclosing
section, and the last argument correspond to global information
(possibly psanning multiple documents).
A @techlink{table} has, roughly, a list of list of flows. A cell in
the table can span multiple columns by using @scheme['cont] instead of
a flow in the following columns (i.e., for all but the first in a set
of cells that contain a single flow).
}
@defstruct[itemization ([flows (listof flow?)])]{
A @techlink{itemization} has a list of flows.
}
@defstruct[blockquote ([style any/c]
[flows (listof flow-element?)])]{
[paragraphs (listof flow-element?)])]{
A @techlink{blockquote} has a style and a list of flow elements. The
@scheme[style] field is normally a string that corresponds to a CSS
class for HTML output.
}
@defstruct[delayed-flow-element ([resolve (any/c part? resolve-info? . -> . flow-element?)])]{
The @scheme[resolve] procedure is called during the @techlink{resolve
pass} to obtain a normal flow element. The first argument to
@scheme[resolve] is the renderer.
}
@defstruct[element ([style any/c]
[content list?])]{
The @scheme[style] field is normally either
@itemize{
@item{a string, which corresponds to a CSS class for HTML output;}
@item{one of the symbols that all renderers recognize: @scheme['tt],
@scheme['italic], @scheme['bold], @scheme['sf],
@scheme['subscript], @scheme['superscript], or
@scheme['hspace];}
@item{an instance of @scheme[target-url] to generate a hyperlink; or}
@item{an instance of @scheme[image-file] to support an inline image.}
}
The @scheme[content] field is a list of @techlink{elements}.
}
@defstruct[(target-element element) ([tag tag?])]{
Declares the content as a hyperlink target for @scheme[tag].
}
@defstruct[(toc-target-element target-element) ()]{
Like @scheme[target-element], the content is also a kind of section
label to be shown in the ``on this page'' table for HTML output.
}
@defstruct[(link-element element) ([tag any/c]
[complain-if-fail? boolean?])]{
@defstruct[(link-element element) ([tag any/c])]{
Hyperlinks the content to @scheme[tag].
}
@ -227,49 +364,69 @@ section, and the last argument correspond to global information
[entry-seq list?])]{
The @scheme[plain-seq] specifies the keys for sorting, where the first
element is the main key, the second is a sub-key, etc. The
@scheme[entry-seq] list must have the same length, and it provides the
form of each key to render in the final document. See also
@scheme[index].
element is the main key, the second is a sub-key, etc. The
@scheme[entry-seq] list must have the same length, and it provides
the form of each key to render in the final document. See also
@scheme[index].
}
@defstruct[(aux-element element) ()]{
Instances of this structure type are intended for use in titles, where
the auxiliary part of the title can be omitted in hyperlinks. See, for
example, @scheme[secref].
the auxiliary part of the title can be omitted in hyperlinks. See,
for example, @scheme[secref].
}
@defstruct[delayed-element ([render (any/c part? any/c . -> . list?)]
@defstruct[delayed-element ([resolve (any/c part? resolve-info? . -> . list?)]
[sizer (-> any/c)]
[plain (-> any/c)])]{
The @scheme[render] procedure's arguments are the same as for
@scheme[delayed-flow-element]. Unlike @scheme[delayed-flow-element],
the result of the @scheme[render] procedure's argument is remembered
on the first call. Furthemore, the element can be marshelled (e.g.,
for an index entry or a section-title entry) only if it has been
rendered first.
@scheme[delayed-flow-element]. Unlike @scheme[delayed-flow-element],
the result of the @scheme[render] procedure's argument is remembered
on the first call.
The @scheme[sizer] field is a procedure that produces a substitute
element for the delayed element for the purposes of determine the
element's width (see @scheme[element-width]).
element for the delayed element for the purposes of determining the
element's width (see @scheme[element-width]).
The @scheme[plain] field is a procedure that produces a substitute for
the element when needed before the ``collect'' phase.
the element when needed before the @techlink{collect pass}.
}
@defstruct[(collect-element element) ([collect (collect-info . -> . any)])]{
Like @scheme[element], but the @scheme[collect] procedure is called
during the @techlink{collect pass}. The @scheme[collect] procedure
normally calls @scheme[collect-put!].
}
@defstruct[collected-info ([number (listof (or/c false/c integer?))]
[parent (or/c false/c part?)]
[info any/c])]{
Computed for each part by the ``collect'' phase.
Computed for each part by the @techlink{collect pass}.
}
@defstruct[target-url ([addr string?])]{
Used as a style for an @scheme[element].}
@defstruct[image-file ([path path-string?])]{
Used as a style for an @scheme[element].}
@defproc[(flow-element? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is a @scheme[paragraph],
@ -281,13 +438,22 @@ Returns @scheme[#t] if @scheme[v] is a @scheme[paragraph],
@defproc[(tag? [v any/c]) boolean?]{
Returns @scheme[#t] if @scheme[v] is acceptable as a link tag,
@scheme[#f], otherwise. Currently, an acceptable tag is either a
string or a list containing a symbol and a string.}
Returns @scheme[#t] if @scheme[v] is acceptable as a link tag, which
is a list containing a symbol and either a string or a
@scheme[generated-tag] instance.}
@defstruct[generated-tag ()]{
A placeholder for a tag to be generated during the @scheme{collect
pass}. Use @scheme[tag-key] to convert a tag containing a
@scheme[generated-tag] instance to one containing a string.
}
@defproc*[([(content->string (content list?)) string?]
[(content->string (content list?) (p part?) (info any/c)) string?])]{
[(content->string (content list?) (p part?) (info resolve-info?)) string?])]{
Converts a list of elements to a single string (essentially
rendering the content as ``plain text'').
@ -299,7 +465,65 @@ element (if it has not been forced already).}
@defproc*[([(element->string (element any/c)) string?]
[(element->string (element any/c) (p part?) (info any/c)) string?])]{
[(element->string (element any/c) (p part?) (info resolve-info?)) string?])]{
Like @scheme[content->string], but for a single element.
}
@defproc[(element-width (element any/c)) nonnegative-exact-integer?]{
Returns the width in characters of the given element.}
@defproc[(flow-element-width (e flow-element?)) nonnegative-exact-integer?]{
Returns the width in characters of the given flow element.}
@defstruct[collect-info ([ht any/c] [ext-ht any/c] [parts any/c] [tags any/c] [gen-prefix any/c])]{
Encapsulates information accumulated (or being accumulated) from the
@techlink{collect pass}. The fields are exposed, but not currently
intended for external use.
}
@defstruct[resolve-info ([ci any/c] [delays any/c] [undef any/c])]{
Encapsulates information accumulated (or being accumulated) from the
@techlink{resolve pass}. The fields are exposed, but not currently
intended for external use.
}
@defproc[(collect-put! [ci collect-info?] [key any/c] [val any/c])
void?]{
Registers information in @scheme[ci]. This procedure should be called
only during the @techlink{collect pass}.
}
@defproc[(resolve-get [ri resolve-info?] [key any/c])
void?]{
Extract information during the @techlink{resolve pass} or
@techlink{render pass} from @scheme[ri], where the information was
previously registered during the @techlink{collect pass}. See also
@secref["passes"].
}
@defproc[(part-collected-info [p part?]
[ri resolve-info?])
collected-info?]{
Returns the information collected for @scheme[p] as recorded within
@scheme[ri].
}
@defproc[(tag-key [t tag?] [ri resolve-info?]) tag?]{
Converts a @scheme[generated-tag] value with @scheme[t] to a string.
}

24
collects/scribblings/scribble/style.scrbl
View File

@ -2,12 +2,10 @@
@require[(lib "manual.ss" "scribble")]
@require["utils.ss"]
@title[#:tag "reference-style"]{PLT Reference Style Guide}
@italic{Notes toward an eventual guide chapter...}
@title[#:tag "reference-style"]{Style Guide}
In the descriptive body of @scheme[defform], @scheme[defproc], etc.,
do not start with ``This...'' Instead, start with a sentence whose
do not start with ``This ...'' Instead, start with a sentence whose
implicit subject is the form or value being described. Thus, the
description will often start with ``Produces.'' Refer to arguments by
name.
@ -20,24 +18,6 @@ expression position within a syntactic form. Use @schemeidfont{body}
for a form (definition or expression) in an internal-definition
position.
Break up HTML documents into multiple pages by using the @scheme['toc]
section style in combination with
@scheme[local-table-of-contents]. The @scheme[local-table-of-contents]
should go after a short introduction, if any. In some cases, a longer
introduction is better placed after the
@scheme[local-table-of-contents] call, especially if the contents are
short.
Favor hyperlinks installed by @scheme[scheme] instead of explicit
section links produced by @scheme[secref]. In particular, there's
rarely a need to have both links (e.g., ``see @scheme[scheme] in
@secref["scribble:manual:code"]'').
Link tags are resolved relative to surrounding sections, but if you
think anyone will ever refer to a link targer, try to pick a tag that
will be globally unique. For example, all of the section tags in the
PLT Scheme reference start with @litchar["mz:"].
Pay attention to the difference between identifiers and meta-variables
when using @scheme[scheme], especially outside of @scheme[defproc] or
@scheme[defform]. Prefix a meta-variable with @litchar{_}; for

17
collects/scribblings/scribble/utils.ss
View File

@ -6,6 +6,23 @@
(prefix scribble: (lib "reader.ss" "scribble"))
(lib "string.ss"))
(define-syntax bounce-for-label
(syntax-rules ()
[(_ mod) (begin
(require-for-label mod)
(provide-for-label (all-from mod)))]
[(_ mod ...) (begin (bounce-for-label mod) ...)]))
(bounce-for-label (lib "lang.ss" "big")
(lib "struct.ss" "scribble")
(lib "base-render.ss" "scribble")
(lib "decode.ss" "scribble")
(lib "basic.ss" "scribble")
(lib "manual.ss" "scribble")
(lib "scheme.ss" "scribble")
(lib "eval.ss" "scribble")
(lib "bnf.ss" "scribble"))
(provide scribble-examples litchar/lines)
(define (litchar/lines . strs)